aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2019, 2022-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2016 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 pinoaffe <pinoaffe@airmail.cc>
;;; Copyright © 2020 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services ssh)
  #:use-module (gnu packages ssh)
  #:use-module (gnu packages admin)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services web)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)
  #:use-module (guix deprecation)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix modules)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (lsh-configuration
            lsh-configuration?
            lsh-service  ; deprecated
            lsh-service-type

            openssh-configuration
            openssh-configuration?
            openssh-configuration-openssh
            openssh-configuration-pid-file
            openssh-configuration-port-number
            openssh-configuration-max-connections
            openssh-configuration-permit-root-login
            openssh-configuration-allow-empty-passwords?
            openssh-configuration-password-authentication?
            openssh-configuration-public-key-authentication?
            openssh-configuration-x11-forwarding?
            openssh-configuration-allow-agent-forwarding?
            openssh-configuration-allow-tcp-forwarding?
            openssh-configuration-gateway-ports?
            openssh-configuration-challenge-response-authentication?
            openssh-configuration-use-pam?
            openssh-configuration-print-last-log?
            openssh-configuration-subsystems
            openssh-configuration-accepted-environment
            openssh-configuration-log-level
            openssh-configuration-extra-content
            openssh-configuration-authorized-keys
            openssh-configuration-generate-host-keys?
            openssh-service-type

            dropbear-configuration
            dropbear-configuration?
            dropbear-service-type
            dropbear-service  ; deprecated

            autossh-configuration
            autossh-configuration?
            autossh-service-type

            webssh-configuration
            webssh-configuration?
            webssh-service-type
            %webssh-configuration-nginx))

;;; Commentary:
;;;
;;; This module implements secure shell (SSH) services.
;;;
;;; Code:

(define-record-type* <lsh-configuration>
  lsh-configuration make-lsh-configuration
  lsh-configuration?
  (lsh lsh-configuration-lsh
       (default lsh))
  (daemonic? lsh-configuration-daemonic?
             (default #t))
  (host-key lsh-configuration-host-key
            (default "/etc/lsh/host-key"))
  (interfaces lsh-configuration-interfaces
              (default '()))
  (port-number lsh-configuration-port-number
               (default 22))
  (allow-empty-passwords? lsh-configuration-allow-empty-passwords?
                          (default #f))
  (root-login? lsh-configuration-root-login?
               (default #f))
  (syslog-output? lsh-configuration-syslog-output?
                  (default #t))
  (pid-file? lsh-configuration-pid-file?
             (default #f))
  (pid-file lsh-configuration-pid-file
            (default "/var/run/lshd.pid"))
  (x11-forwarding? lsh-configuration-x11-forwarding?
                   (default #t))
  (tcp/ip-forwarding? lsh-configuration-tcp/ip-forwarding?
                      (default #t))
  (password-authentication? lsh-configuration-password-authentication?
                            (default #t))
  (public-key-authentication? lsh-configuration-public-key-authentication?
                              (default #t))
  (initialize? lsh-configuration-initialize?
               (default #t)))

(define %yarrow-seed
  "/var/spool/lsh/yarrow-seed-file")

(define (lsh-initialization lsh host-key)
  "Return the gexp to initialize the LSH service for HOST-KEY."
  #~(begin
      (unless (file-exists? #$%yarrow-seed)
        (system* (string-append #$lsh "/bin/lsh-make-seed")
                 "--sloppy" "-o" #$%yarrow-seed))

      (unless (file-exists? #$host-key)
        (mkdir-p (dirname #$host-key))
        (format #t "creating SSH host key '~a'...~%" #$host-key)

        ;; FIXME: We're just doing a simple pipeline, but 'system' cannot be
        ;; used yet because /bin/sh might be dangling; factorize this somehow.
        (let* ((in+out (pipe))
               (keygen (primitive-fork)))
          (case keygen
            ((0)
             (close-port (car in+out))
             (close-fdes 1)
             (dup2 (fileno (cdr in+out)) 1)
             (execl (string-append #$lsh "/bin/lsh-keygen")
                    "lsh-keygen" "--server"))
            (else
             (let ((write-key (primitive-fork)))
               (case write-key
                 ((0)
                  (close-port (cdr in+out))
                  (close-fdes 0)
                  (dup2 (fileno (car in+out)) 0)
                  (execl (string-append #$lsh "/bin/lsh-writekey")
                         "lsh-writekey" "--server" "-o" #$host-key))
                 (else
                  (close-port (car in+out))
                  (close-port (cdr in+out))
                  (waitpid keygen)
                  (waitpid write-key))))))))))

(define (lsh-activation config)
  "Return the activation gexp for CONFIG."
  #~(begin
      (use-modules (guix build utils))
      (mkdir-p "/var/spool/lsh")
      #$(if (lsh-configuration-initialize? config)
            (lsh-initialization (lsh-configuration-lsh config)
                                (lsh-configuration-host-key config))
            #t)))

(define (lsh-shepherd-service config)
  "Return a <shepherd-service> for lsh with CONFIG."
  (define lsh (lsh-configuration-lsh config))
  (define pid-file (lsh-configuration-pid-file config))
  (define pid-file? (lsh-configuration-pid-file? config))
  (define daemonic? (lsh-configuration-daemonic? config))
  (define interfaces (lsh-configuration-interfaces config))

  (define lsh-command
    (append
     (cons (file-append lsh "/sbin/lshd")
           (if daemonic?
               (let ((syslog (if (lsh-configuration-syslog-output? config)
                                 '()
                                 (list "--no-syslog"))))
                 (cons "--daemonic"
                       (if pid-file?
                           (cons #~(string-append "--pid-file=" #$pid-file)
                                 syslog)
                           (cons "--no-pid-file" syslog))))
               (if pid-file?
                   (list #~(string-append "--pid-file=" #$pid-file))
                   '())))
     (cons* #~(string-append "--host-key="
                             #$(lsh-configuration-host-key config))
            #~(string-append "--password-helper=" #$lsh "/sbin/lsh-pam-checkpw")
            #~(string-append "--subsystems=sftp=" #$lsh "/sbin/sftp-server")
            "-p" (number->string (lsh-configuration-port-number config))
            (if (lsh-configuration-password-authentication? config)
                "--password" "--no-password")
            (if (lsh-configuration-public-key-authentication? config)
                "--publickey" "--no-publickey")
            (if (lsh-configuration-root-login? config)
                "--root-login" "--no-root-login")
            (if (lsh-configuration-x11-forwarding? config)
                "--x11-forward" "--no-x11-forward")
            (if (lsh-configuration-tcp/ip-forwarding? config)
                "--tcpip-forward" "--no-tcpip-forward")
            (if (null? interfaces)
                '()
                (map (cut string-append "--interface=" <>)
                     interfaces)))))

  (define requires
    `(networking
      pam
      ,@(if (and daemonic? (lsh-configuration-syslog-output? config))
            '(syslogd)
            '())))

  (list (shepherd-service
         (documentation "GNU lsh SSH server")
         (provision '(ssh-daemon ssh sshd))
         (requirement requires)
         (start #~(make-forkexec-constructor (list #$@lsh-command)))
         (stop  #~(make-kill-destructor)))))

(define (lsh-pam-services config)
  "Return a list of <pam-services> for lshd with CONFIG."
  (list (unix-pam-service
         "lshd"
         #:login-uid? #t
         #:allow-empty-passwords?
         (lsh-configuration-allow-empty-passwords? config))))

(define lsh-service-type
  (service-type
   (name 'lsh)
   (extensions
    (list (service-extension shepherd-root-service-type
                             lsh-shepherd-service)
          (service-extension pam-root-service-type
                             lsh-pam-services)
          (service-extension activation-service-type
                             lsh-activation)))
   (description "Run the GNU@tie{}lsh secure shell (SSH) daemon,
@command{lshd}.")
   (default-value (lsh-configuration))))

(define-deprecated (lsh-service #:key
                      (lsh lsh)
                      (daemonic? #t)
                      (host-key "/etc/lsh/host-key")
                      (interfaces '())
                      (port-number 22)
                      (allow-empty-passwords? #f)
                      (root-login? #f)
                      (syslog-output? #t)
                      (pid-file? #f)
                      (pid-file "/var/run/lshd.pid")
                      (x11-forwarding? #t)
                      (tcp/ip-forwarding? #t)
                      (password-authentication? #t)
                      (public-key-authentication? #t)
                      (initialize? #t))
  lsh-service-type
  "Run the @command{lshd} program from @var{lsh} to listen on port @var{port-number}.
@var{host-key} must designate a file containing the host key, and readable
only by root.

When @var{daemonic?} is true, @command{lshd} will detach from the
controlling terminal and log its output to syslogd, unless one sets
@var{syslog-output?} to false.  Obviously, it also makes lsh-service
depend on existence of syslogd service.  When @var{pid-file?} is true,
@command{lshd} writes its PID to the file called @var{pid-file}.

When @var{initialize?} is true, automatically create the seed and host key
upon service activation if they do not exist yet.  This may take long and
require interaction.

When @var{initialize?} is false, it is up to the user to initialize the
randomness generator (@pxref{lsh-make-seed,,, lsh, LSH Manual}), and to create
a key pair with the private key stored in file @var{host-key} (@pxref{lshd
basics,,, lsh, LSH Manual}).

When @var{interfaces} is empty, lshd listens for connections on all the
network interfaces; otherwise, @var{interfaces} must be a list of host names
or addresses.

@var{allow-empty-passwords?} specifies whether to accept log-ins with empty
passwords, and @var{root-login?} specifies whether to accept log-ins as
root.

The other options should be self-descriptive."
  (service lsh-service-type
           (lsh-configuration (lsh lsh) (daemonic? daemonic?)
                              (host-key host-key) (interfaces interfaces)
                              (port-number port-number)
                              (allow-empty-passwords? allow-empty-passwords?)
                              (root-login? root-login?)
                              (syslog-output? syslog-output?)
                              (pid-file? pid-file?) (pid-file pid-file)
                              (x11-forwarding? x11-forwarding?)
                              (tcp/ip-forwarding? tcp/ip-forwarding?)
                              (password-authentication?
                               password-authentication?)
                              (public-key-authentication?
                               public-key-authentication?)
                              (initialize? initialize?))))


;;;
;;; OpenSSH.
;;;

(define-record-type* <openssh-configuration>
  openssh-configuration make-openssh-configuration
  openssh-configuration?
  ;; file-like object
  (openssh               openssh-configuration-openssh
                         (default openssh))
  ;; string
  (pid-file              openssh-configuration-pid-file
                         (default "/var/run/sshd.pid"))
  ;; integer
  (port-number           openssh-configuration-port-number
                         (default 22))
  ;; integer
  (max-connections       openssh-configuration-max-connections
                         (default 200))
  ;; Boolean | 'prohibit-password
  (permit-root-login     openssh-configuration-permit-root-login
                         (default #f))
  ;; Boolean
  (allow-empty-passwords? openssh-configuration-allow-empty-passwords?
                          (default #f))
  ;; Boolean
  (password-authentication? openssh-configuration-password-authentication?
                            (default #t))
  ;; Boolean
  (public-key-authentication? openssh-configuration-public-key-authentication?
                              (default #t))
  ;; Boolean
  (x11-forwarding?       openssh-configuration-x11-forwarding?
                         (default #f))

  ;; Boolean
  (allow-agent-forwarding? openssh-configuration-allow-agent-forwarding?
                           (default #t))

  ;; Boolean
  (allow-tcp-forwarding? openssh-configuration-allow-tcp-forwarding?
                         (default #t))

  ;; Boolean
  (gateway-ports? openssh-configuration-gateway-ports?
                         (default #f))

  ;; Boolean
  (challenge-response-authentication?
   openssh-configuration-challenge-response-authentication?
   (default #f))

  ;; Boolean
  (use-pam?              openssh-configuration-use-pam?
                         (default #t))
  ;; Boolean
  (print-last-log?       openssh-configuration-print-last-log?
                         (default #t))
  ;; list of two-element lists
  (subsystems            openssh-configuration-subsystems
                         (default '(("sftp" "internal-sftp"))))

  ;; list of strings
  (accepted-environment  openssh-configuration-accepted-environment
                         (default '()))

  ;; symbol
  (log-level             openssh-configuration-log-level
                         (default 'info))

  ;; String
  ;; This is an "escape hatch" to provide configuration that isn't yet
  ;; supported by this configuration record.
  (extra-content         openssh-configuration-extra-content
                         (default ""))

  ;; list of user-name/file-like tuples
  (authorized-keys       openssh-configuration-authorized-keys
                         (default '()))

  ;; Boolean
  (generate-host-keys?   openssh-configuration-generate-host-keys?
                         (default #t))

  ;; Boolean
  ;; XXX: This should really be handled in an orthogonal way, for instance as
  ;; proposed in <https://bugs.gnu.org/27155>.  Keep it internal/undocumented
  ;; for now.
  (%auto-start?          openssh-auto-start?
                         (default #t)))

(define %openssh-accounts
  (list (user-group (name "sshd") (system? #t))
        (user-account
          (name "sshd")
          (group "sshd")
          (system? #t)
          (comment "sshd privilege separation user")
          (home-directory "/var/run/sshd")
          (shell (file-append shadow "/sbin/nologin")))))

(define (openssh-activation config)
  "Return the activation GEXP for CONFIG."
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))

        (define (touch file-name)
          (call-with-output-file file-name (const #t)))

        ;; Make sure /etc/ssh can be read by the 'sshd' user.
        (mkdir-p "/etc/ssh")
        (chmod "/etc/ssh" #o755)
        (mkdir-p (dirname #$(openssh-configuration-pid-file config)))

        ;; 'sshd' complains if the authorized-key directory and its parents
        ;; are group-writable, which rules out /gnu/store.  Thus we copy the
        ;; authorized-key directory to /etc.
        (catch 'system-error
          (lambda ()
            (delete-file-recursively "/etc/ssh/authorized_keys.d"))
          (lambda args
            (unless (= ENOENT (system-error-errno args))
              (apply throw args))))
        (copy-recursively #$(authorized-key-directory
                             (openssh-configuration-authorized-keys config))
                          "/etc/ssh/authorized_keys.d")

        (chmod "/etc/ssh/authorized_keys.d" #o555)

        (let ((lastlog "/var/log/lastlog"))
          (when #$(openssh-configuration-print-last-log? config)
            (unless (file-exists? lastlog)
              (touch lastlog))))

        (when #$(openssh-configuration-generate-host-keys? config)
          ;; Generate missing host keys.
          (system* (string-append #$(openssh-configuration-openssh config)
                                  "/bin/ssh-keygen") "-A")))))

(define (authorized-key-directory keys)
  "Return a directory containing the authorized keys specified in KEYS, a list
of user-name/file-like tuples."
  (define build
    (with-imported-modules (source-module-closure '((guix build utils)))
      #~(begin
          (use-modules (ice-9 match) (srfi srfi-26)
                       (guix build utils))

          (mkdir #$output)
          (for-each (match-lambda
                      ((user keys ...)
                       (let ((file (string-append #$output "/" user)))
                         (call-with-output-file file
                           (lambda (port)
                             (for-each (lambda (key)
                                         (call-with-input-file key
                                           (cut dump-port <> port)))
                                       keys))))))
                    '#$keys))))

  (computed-file "openssh-authorized-keys" build))

(define (openssh-config-file config)
  "Return the sshd configuration file corresponding to CONFIG."
  (computed-file
   "sshd_config"
   #~(begin
       (use-modules (ice-9 match))
       (call-with-output-file #$output
         (lambda (port)
           (display "# Generated by 'openssh-service'.\n" port)
           (format port "Port ~a\n"
                   #$(number->string
                      (openssh-configuration-port-number config)))
           (format port "PermitRootLogin ~a\n"
                   #$(match (openssh-configuration-permit-root-login config)
                       (#t "yes")
                       (#f "no")
                       ('without-password (warn-about-deprecation
                                           'without-password #f
                                           #:replacement 'prohibit-password)
                                          "prohibit-password")
                       ('prohibit-password "prohibit-password")))
           (format port "PermitEmptyPasswords ~a\n"
                   #$(if (openssh-configuration-allow-empty-passwords? config)
                         "yes" "no"))
           (format port "PasswordAuthentication ~a\n"
                   #$(if (openssh-configuration-password-authentication? config)
                         "yes" "no"))
           (format port "PubkeyAuthentication ~a\n"
                   #$(if (openssh-configuration-public-key-authentication?
                          config)
                         "yes" "no"))
           (format port "X11Forwarding ~a\n"
                   #$(if (openssh-configuration-x11-forwarding? config)
                         "yes" "no"))
           (format port "AllowAgentForwarding ~a\n"
                   #$(if (openssh-configuration-allow-agent-forwarding? config)
                         "yes" "no"))
           (format port "AllowTcpForwarding ~a\n"
                   #$(if (openssh-configuration-allow-tcp-forwarding? config)
                         "yes" "no"))
           (format port "GatewayPorts ~a\n"
                   #$(if (openssh-configuration-gateway-ports? config)
                         "yes" "no"))
           (format port "PidFile ~a\n"
                   #$(openssh-configuration-pid-file config))
           (format port "ChallengeResponseAuthentication ~a\n"
                   #$(if (openssh-configuration-challenge-response-authentication?
                          config)
                         "yes" "no"))
           (format port "UsePAM ~a\n"
                   #$(if (openssh-configuration-use-pam? config)
                         "yes" "no"))
           (format port "PrintLastLog ~a\n"
                   #$(if (openssh-configuration-print-last-log? config)
                         "yes" "no"))
           (format port "LogLevel ~a\n"
                   #$(string-upcase
                      (symbol->string
                       (openssh-configuration-log-level config))))

           ;; Add '/etc/authorized_keys.d/%u', which we populate.
           (format port "AuthorizedKeysFile \
 .ssh/authorized_keys .ssh/authorized_keys2 /etc/ssh/authorized_keys.d/%u\n")

           (for-each (lambda (s) (format port "AcceptEnv ~a\n" s))
                     '#$(openssh-configuration-accepted-environment config))

           (for-each
            (match-lambda
              ((name command) (format port "Subsystem\t~a\t~a\n" name command)))
            '#$(openssh-configuration-subsystems config))

           (format port "~a\n"
                   #$(openssh-configuration-extra-content config))
           #t)))))

(define (openssh-shepherd-service config)
  "Return a <shepherd-service> for openssh with CONFIG."

  (define pid-file
    (openssh-configuration-pid-file config))

  (define port-number
    (openssh-configuration-port-number config))

  (define max-connections
    (openssh-configuration-max-connections config))

  (define config-file
    (openssh-config-file config))

  (define openssh-command
    #~(list (string-append #$(openssh-configuration-openssh config) "/sbin/sshd")
            "-D" "-f" #$config-file))

  (define inetd-style?
    ;; Whether to use 'make-inetd-constructor'.  That procedure appeared in
    ;; Shepherd 0.9.0, but in 0.9.0, 'make-inetd-constructor' wouldn't let us
    ;; pass a list of endpoints, and it wouldn't let us define a service
    ;; listening on both IPv4 and IPv6, hence the conditional below.
    #~(and (defined? 'make-inetd-constructor)
           (not (string=? (@ (shepherd config) Version) "0.9.0"))))

  (define ipv6-support?
    ;; Expression that returns true if IPv6 support is available.
    #~(catch 'system-error
        (lambda ()
          (let ((sock (socket AF_INET6 SOCK_STREAM 0)))
            (close-port sock)
            #t))
        (const #f)))

  (list (shepherd-service
         (documentation "OpenSSH server.")

         ;; On the Hurd, this can only be started after pfinet is up, hence
         ;; the dependency on 'networking'.
         (requirement '(pam syslogd loopback networking))
         (provision '(ssh-daemon ssh sshd))

         (start #~(if #$inetd-style?
                      (make-inetd-constructor
                       (append #$openssh-command '("-i"))
                       (cons (endpoint
                              (make-socket-address AF_INET INADDR_ANY
                                                   #$port-number))
                             (if #$ipv6-support?
                                 (list
                                  (endpoint
                                   (make-socket-address AF_INET6 IN6ADDR_ANY
                                                        #$port-number)))
                                 '()))
                       #:requirements '#$requirement
                       #:max-connections #$max-connections)
                      (make-forkexec-constructor #$openssh-command
                                                 #:pid-file #$pid-file)))
         (stop #~(if #$inetd-style?
                     (make-inetd-destructor)
                     (make-kill-destructor)))
         (actions (list (shepherd-configuration-action config-file)))
         (auto-start? (openssh-auto-start? config)))))

(define (openssh-pam-services config)
  "Return a list of <pam-services> for sshd with CONFIG."
  (list (unix-pam-service
         "sshd"
         #:login-uid? #t
         #:allow-empty-passwords?
         (openssh-configuration-allow-empty-passwords? config))))

(define (extend-openssh-authorized-keys config keys)
  "Extend CONFIG with the extra authorized keys listed in KEYS."
  (openssh-configuration
   (inherit config)
   (authorized-keys
    (match (append (openssh-configuration-authorized-keys config) keys)
      ((and alist ((users _ ...) ...))
       ;; Build a user/key-list mapping.
       (let ((user-keys (alist->vhash alist)))
         ;; Coalesce the key lists associated with each user.
         (map (lambda (user)
                `(,user
                  ,@(concatenate (vhash-fold* cons '() user user-keys))))
              users)))))))

(define openssh-service-type
  (service-type (name 'openssh)
                (description
                 "Run the OpenSSH secure shell (SSH) server, @command{sshd}.")
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          openssh-shepherd-service)
                       (service-extension pam-root-service-type
                                          openssh-pam-services)
                       (service-extension activation-service-type
                                          openssh-activation)
                       (service-extension account-service-type
                                          (const %openssh-accounts))

                       ;; Install OpenSSH in the system profile.  That way,
                       ;; 'scp' is found when someone tries to copy to or from
                       ;; this machine.
                       (service-extension profile-service-type
                                          (lambda (config)
                                            (list (openssh-configuration-openssh
                                                   config))))))
                (compose concatenate)
                (extend extend-openssh-authorized-keys)
                (default-value (openssh-configuration))))


;;;
;;; Dropbear.
;;;

(define-record-type* <dropbear-configuration>
  dropbear-configuration make-dropbear-configuration
  dropbear-configuration?
  (dropbear               dropbear-configuration-dropbear
                          (default dropbear))
  (port-number            dropbear-configuration-port-number
                          (default 22))
  (syslog-output?         dropbear-configuration-syslog-output?
                          (default #t))
  (pid-file               dropbear-configuration-pid-file
                          (default "/var/run/dropbear.pid"))
  (root-login?            dropbear-configuration-root-login?
                          (default #f))
  (allow-empty-passwords? dropbear-configuration-allow-empty-passwords?
                          (default #f))
  (password-authentication? dropbear-configuration-password-authentication?
                            (default #t)))

(define (dropbear-activation config)
  "Return the activation gexp for CONFIG."
  #~(begin
      (use-modules (guix build utils))
      (mkdir-p "/etc/dropbear")))

(define (dropbear-shepherd-service config)
  "Return a <shepherd-service> for dropbear with CONFIG."
  (define dropbear
    (dropbear-configuration-dropbear config))

  (define pid-file
    (dropbear-configuration-pid-file config))

  (define dropbear-command
    #~(list (string-append #$dropbear "/sbin/dropbear")

            ;; '-R' allows host keys to be automatically generated upon first
            ;; connection, at a time when /dev/urandom is more likely securely
            ;; seeded.
            "-F" "-R"

            "-p" #$(number->string (dropbear-configuration-port-number config))
            "-P" #$pid-file
            #$@(if (dropbear-configuration-syslog-output? config) '() '("-E"))
            #$@(if (dropbear-configuration-root-login? config) '() '("-w"))
            #$@(if (dropbear-configuration-password-authentication? config)
                   '()
                   '("-s" "-g"))
            #$@(if (dropbear-configuration-allow-empty-passwords? config)
                   '("-B")
                   '())))

  (define requires
    (if (dropbear-configuration-syslog-output? config)
        '(networking syslogd) '(networking)))

  (list (shepherd-service
         (documentation "Dropbear SSH server.")
         (requirement requires)
         (provision '(ssh-daemon ssh sshd))
         (start #~(make-forkexec-constructor #$dropbear-command
                                             #:pid-file #$pid-file))
         (stop #~(make-kill-destructor)))))

(define dropbear-service-type
  (service-type (name 'dropbear)
                (description
                 "Run the Dropbear secure shell (SSH) server.")
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          dropbear-shepherd-service)
                       (service-extension activation-service-type
                                          dropbear-activation)))
                (default-value (dropbear-configuration))))

(define-deprecated (dropbear-service #:optional
                                     (config (dropbear-configuration)))
  dropbear-service-type
  "Run the @uref{https://matt.ucc.asn.au/dropbear/dropbear.html,Dropbear SSH
daemon} with the given @var{config}, a @code{<dropbear-configuration>}
object."
  (service dropbear-service-type config))


;;;
;;; AutoSSH.
;;;


(define-record-type* <autossh-configuration>
  autossh-configuration make-autossh-configuration
  autossh-configuration?
  (user            autossh-configuration-user
                   (default "autossh"))
  (poll            autossh-configuration-poll
                   (default 600))
  (first-poll      autossh-configuration-first-poll
                   (default #f))
  (gate-time       autossh-configuration-gate-time
                   (default 30))
  (log-level       autossh-configuration-log-level
                   (default 1))
  (max-start       autossh-configuration-max-start
                   (default #f))
  (message         autossh-configuration-message
                   (default ""))
  (port            autossh-configuration-port
                   (default "0"))
  (ssh-options     autossh-configuration-ssh-options
                   (default '())))

(define (autossh-file-name config file)
  "Return a path in /var/run/autossh/ that is writable
   by @code{user} from @code{config}."
  (string-append "/var/run/autossh/"
                 (autossh-configuration-user config)
                 "/" file))

(define (autossh-shepherd-service config)
  (shepherd-service
   (documentation "Automatically set up ssh connections (and keep them alive).")
   (provision '(autossh))
   (start #~(make-forkexec-constructor
             (list #$(file-append autossh "/bin/autossh")
                   #$@(autossh-configuration-ssh-options config))
             #:user #$(autossh-configuration-user config)
             #:group (passwd:gid (getpw #$(autossh-configuration-user config)))
             #:pid-file #$(autossh-file-name config "pid")
             #:log-file #$(autossh-file-name config "log")
             #:environment-variables
             '(#$(string-append "AUTOSSH_PIDFILE="
                                (autossh-file-name config "pid"))
               #$(string-append "AUTOSSH_LOGFILE="
                                (autossh-file-name config "log"))
               #$(string-append "AUTOSSH_POLL="
                                (number->string
                                 (autossh-configuration-poll config)))
               #$(string-append "AUTOSSH_FIRST_POLL="
                                (number->string
                                 (or
                                  (autossh-configuration-first-poll config)
                                  (autossh-configuration-poll config))))
               #$(string-append "AUTOSSH_GATETIME="
                                (number->string
                                 (autossh-configuration-gate-time config)))
               #$(string-append "AUTOSSH_LOGLEVEL="
                                (number->string
                                 (autossh-configuration-log-level config)))
               #$(string-append "AUTOSSH_MAXSTART="
                                (number->string
                                 (or (autossh-configuration-max-start config)
                                     -1)))
               #$(string-append "AUTOSSH_MESSAGE="
                                (autossh-configuration-message config))
               #$(string-append "AUTOSSH_PORT="
                                (autossh-configuration-port config)))))
   (stop #~(make-kill-destructor))))

(define (autossh-service-activation config)
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))
        (define %user
          (getpw #$(autossh-configuration-user config)))
        (let* ((directory #$(autossh-file-name config ""))
               (log (string-append directory "/log")))
          (mkdir-p directory)
          (chown directory (passwd:uid %user) (passwd:gid %user))
          (call-with-output-file log (const #t))
          (chown log (passwd:uid %user) (passwd:gid %user))))))

(define autossh-service-type
  (service-type
   (name 'autossh)
   (description "Automatically set up ssh connections (and keep them alive).")
   (extensions
    (list (service-extension shepherd-root-service-type
                             (compose list autossh-shepherd-service))
          (service-extension activation-service-type
                             autossh-service-activation)))
   (default-value (autossh-configuration))))


;;;
;;; WebSSH
;;;

(define-record-type* <webssh-configuration>
  webssh-configuration make-webssh-configuration
  webssh-configuration?
  (package     webssh-configuration-package     ;file-like
               (default webssh))
  (user-name   webssh-configuration-user-name   ;string
               (default "webssh"))
  (group-name  webssh-configuration-group-name  ;string
               (default "webssh"))
  (policy      webssh-configuration-policy      ;symbol
               (default #f))
  (known-hosts webssh-configuration-known-hosts ;list of strings
               (default #f))
  (port        webssh-configuration-port        ;number
               (default #f))
  (address     webssh-configuration-address     ;string
               (default #f))
  (log-file    webssh-configuration-log-file    ;string
               (default "/var/log/webssh.log"))
  (log-level   webssh-configuration-log-level   ;symbol
               (default #f)))

(define %webssh-configuration-nginx
  (nginx-server-configuration
   (listen '("80"))
   (locations
    (list (nginx-location-configuration
           (uri "/")
           (body '("proxy_pass http://127.0.0.1:8888;"
                   "proxy_http_version 1.1;"
                   "proxy_read_timeout 300;"
                   "proxy_set_header Upgrade $http_upgrade;"
                   "proxy_set_header Connection \"upgrade\";"
                   "proxy_set_header Host $http_host;"
                   "proxy_set_header X-Real-IP $remote_addr;"
                   "proxy_set_header X-Real-PORT $remote_port;")))))))

(define webssh-account
  ;; Return the user accounts and user groups for CONFIG.
  (match-lambda
    (($ <webssh-configuration> _ user-name group-name _ _ _ _ _ _)
     (list (user-group
            (name group-name))
           (user-account
            (name user-name)
            (group group-name)
            (comment "webssh privilege separation user")
            (home-directory (string-append "/var/run/" user-name))
            (shell #~(string-append #$shadow "/sbin/nologin")))))))

(define webssh-activation
  ;; Return the activation GEXP for CONFIG.
  (match-lambda
    (($ <webssh-configuration> _ user-name group-name policy known-hosts _ _
                               log-file _)
     (with-imported-modules '((guix build utils))
       #~(begin
           (let* ((home-dir (string-append "/var/run/" #$user-name))
                  (ssh-dir (string-append home-dir "/.ssh"))
                  (known-hosts-file (string-append ssh-dir "/known_hosts")))
             (call-with-output-file #$log-file (const #t))
             (mkdir-p ssh-dir)
             (case '#$policy
               ((reject)
                (if '#$known-hosts
                    (call-with-output-file known-hosts-file
                      (lambda (port)
                        (for-each (lambda (host) (display host port) (newline port))
                                  '#$known-hosts)))
                    (display-hint (G_ "webssh: reject policy requires `known-hosts'.")))))
             (for-each (lambda (file)
                         (chown file
                                (passwd:uid (getpw #$user-name))
                                (group:gid (getpw #$group-name))))
                       (list #$log-file ssh-dir known-hosts-file))
             (chmod ssh-dir #o700)))))))

(define webssh-shepherd-service
  (match-lambda
    (($ <webssh-configuration> package user-name group-name policy _ port
                               address log-file log-level)
     (list (shepherd-service
            (provision '(webssh))
            (documentation "Run webssh daemon.")
            (start #~(make-forkexec-constructor
                      `(,(string-append #$webssh "/bin/wssh")
                        ,(string-append "--log-file-prefix=" #$log-file)
                        ,@(case '#$log-level
                            ((debug) '("--logging=debug"))
                            (else '()))
                        ,@(case '#$policy
                            ((reject) '("--policy=reject"))
                            (else '()))
                        ,@(if #$port
                              (list (string-append "--port=" (number->string #$port)))
                              '())
                        ,@(if #$address
                              (list (string-append "--address=" #$address))
                              '()))
                      #:user #$user-name
                      #:group #$group-name))
            (stop #~(make-kill-destructor)))))))

(define webssh-service-type
  (service-type
   (name 'webssh)
   (extensions
    (list (service-extension shepherd-root-service-type
                             webssh-shepherd-service)
          (service-extension account-service-type
                             webssh-account)
          (service-extension activation-service-type
                             webssh-activation)))
   (default-value (webssh-configuration))
   (description
    "Run the webssh.")))

;;; ssh.scm ends here
generated by cgit
tion'. The files containing the reference graphs are made available under the /xchg CIFS share." (define user-builder (program-file "builder-in-linux-vm" exp)) (define loader ;; Invoke USER-BUILDER instead using 'primitive-load'. The reason for ;; this is to allow USER-BUILDER to dlopen stuff by using a full-featured ;; Guile, which it couldn't do using the statically-linked guile used in ;; the initrd. See example at ;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html>. (program-file "linux-vm-loader" ;; When USER-BUILDER succeeds, reboot (indicating a ;; success), otherwise die, which causes a kernel panic ;; ("Attempted to kill init!"). #~(if (zero? (system* #$user-builder)) (reboot) (exit 1)))) (let ((initrd (or initrd (base-initrd file-systems #:on-error 'backtrace #:linux linux #:linux-modules %base-initrd-modules #:qemu-networking? #t)))) (define builder ;; Code that launches the VM that evaluates EXP. (with-extensions gcrypt-sqlite3&co (with-imported-modules `(,@(source-module-closure '((guix build utils) (gnu build vm)) #:select? not-config?) ;; For consumption by (gnu store database). ((guix config) => ,(make-config.scm))) #~(begin (use-modules (guix build utils) (gnu build vm)) (let* ((inputs '#$(list qemu (canonical-package coreutils))) (linux (string-append #$linux "/" #$(system-linux-image-file-name))) (initrd #$initrd) (loader #$loader) (graphs '#$(match references-graphs (((graph-files . _) ...) graph-files) (_ #f))) (size #$(if (eq? 'guess disk-image-size) #~(+ (* 70 (expt 2 20)) ;ESP (estimated-partition-size graphs)) disk-image-size))) (set-path-environment-variable "PATH" '("bin") inputs) (load-in-linux-vm loader #:output #$output #:linux linux #:initrd initrd #:memory-size #$memory-size #:make-disk-image? #$make-disk-image? #:single-file-output? #$single-file-output? ;; FIXME: ‘target-arm32?’ may not operate on ;; the right system/target values. Rewrite ;; using ‘let-system’ when available. #:target-arm32? #$(target-arm32?) #:disk-image-format #$disk-image-format #:disk-image-size size #:references-graphs graphs)))))) (gexp->derivation name builder ;; TODO: Require the "kvm" feature. #:system system #:env-vars env-vars #:guile-for-build guile-for-build #:references-graphs references-graphs))) (define (has-guix-service-type? os) "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." (not (not (find (lambda (service) (eq? (service-kind service) guix-service-type)) (operating-system-services os))))) (define* (iso9660-image #:key (name "iso9660-image") file-system-label file-system-uuid (system (%current-system)) (qemu qemu-minimal) os bootcfg-drv bootloader (register-closures? (has-guix-service-type? os)) (inputs '()) (grub-mkrescue-environment '())) "Return a bootable, stand-alone iso9660 image. INPUTS is a list of inputs (as for packages)." (define schema (and register-closures? (local-file (search-path %load-path "guix/store/schema.sql")))) (expression->derivation-in-linux-vm name (with-extensions gcrypt-sqlite3&co (with-imported-modules `(,@(source-module-closure '((gnu build vm) (guix store database) (guix build utils)) #:select? not-config?) ((guix config) => ,(make-config.scm))) #~(begin (use-modules (gnu build vm) (guix store database) (guix build utils)) (sql-schema #$schema) ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. (setenv "GUIX_LOCPATH" #+(file-append glibc-utf8-locales "/lib/locale")) (setlocale LC_ALL "en_US.utf8") (let ((inputs '#$(append (list qemu parted e2fsprogs dosfstools xorriso) (map canonical-package (list sed grep coreutils findutils gawk)))) (graphs '#$(match inputs (((names . _) ...) names))) ;; This variable is unused but allows us to add INPUTS-TO-COPY ;; as inputs. (to-register '#$(map (match-lambda ((name thing) thing) ((name thing output) `(,thing ,output))) inputs))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) (make-iso9660-image #$xorriso '#$grub-mkrescue-environment #$(bootloader-package bootloader) #$bootcfg-drv #$os "/xchg/guixsd.iso" #:register-closures? #$register-closures? #:closures graphs #:volume-id #$file-system-label #:volume-uuid #$(and=> file-system-uuid uuid-bytevector)))))) #:system system ;; Keep a local file system for /tmp so that we can populate it directly as ;; root and have files owned by root. See <https://bugs.gnu.org/31752>. #:file-systems (remove (lambda (file-system) (string=? (file-system-mount-point file-system) "/tmp")) %linux-vm-file-systems) #:make-disk-image? #f #:single-file-output? #t #:references-graphs inputs ;; Xorriso seems to be quite memory-hungry, so increase the VM's RAM size. #:memory-size 512)) (define* (qemu-image #:key (name "qemu-image") (system (%current-system)) (qemu qemu-minimal) (disk-image-size 'guess) (disk-image-format "qcow2") (file-system-type "ext4") file-system-label file-system-uuid os bootcfg-drv bootloader (register-closures? (has-guix-service-type? os)) (inputs '()) copy-inputs?) "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root partition (a UUID object). The returned image is a full disk image that runs OS-DERIVATION, with a GRUB installation that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in the image. By default, REGISTER-CLOSURES? is set to true only if a service of type GUIX-SERVICE-TYPE is present in the services definition of the operating system." (define schema (and register-closures? (local-file (search-path %load-path "guix/store/schema.sql")))) (expression->derivation-in-linux-vm name (with-extensions gcrypt-sqlite3&co (with-imported-modules `(,@(source-module-closure '((gnu build vm) (gnu build bootloader) (guix store database) (guix build utils)) #:select? not-config?) ((guix config) => ,(make-config.scm))) #~(begin (use-modules (gnu build bootloader) (gnu build vm) (guix store database) (guix build utils) (srfi srfi-26) (ice-9 binary-ports)) (sql-schema #$schema) ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. (setenv "GUIX_LOCPATH" #+(file-append glibc-utf8-locales "/lib/locale")) (setlocale LC_ALL "en_US.utf8") (let ((inputs '#$(append (list qemu parted e2fsprogs dosfstools) (map canonical-package (list sed grep coreutils findutils gawk)))) ;; This variable is unused but allows us to add INPUTS-TO-COPY ;; as inputs. (to-register '#$(map (match-lambda ((name thing) thing) ((name thing output) `(,thing ,output))) inputs))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) (let* ((graphs '#$(match inputs (((names . _) ...) names))) (initialize (root-partition-initializer #:closures graphs #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? #:system-directory #$os ;; Disable deduplication to speed things up, ;; and because it doesn't help much for a ;; single system generation. #:deduplicate? #f)) (root-size #$(if (eq? 'guess disk-image-size) #~(max ;; Minimum 20 MiB root size (* 20 (expt 2 20)) (estimated-partition-size (map (cut string-append "/xchg/" <>) graphs))) (- disk-image-size (* 50 (expt 2 20))))) (partitions (append (list (partition (size root-size) (label #$file-system-label) (uuid #$(and=> file-system-uuid uuid-bytevector)) (file-system #$file-system-type) (flags '(boot)) (initializer initialize))) ;; Append a small EFI System Partition for use with UEFI ;; bootloaders if we are not targeting ARM because UEFI ;; support in U-Boot is experimental. ;; ;; FIXME: ‘target-arm32?’ may be not operate on the right ;; system/target values. Rewrite using ‘let-system’ when ;; available. (if #$(target-arm32?) '() (list (partition ;; The standalone grub image is about 10MiB, but ;; leave some room for custom or multiple images. (size (* 40 (expt 2 20))) (label "GNU-ESP") ;cosmetic only ;; Use "vfat" here since this property is used ;; when mounting. The actual FAT-ness is based ;; on file system size (16 in this case). (file-system "vfat") (flags '(esp)))))))) (initialize-hard-disk "/dev/vda" #:partitions partitions #:grub-efi #$grub-efi #:bootloader-package #$(bootloader-package bootloader) #:bootcfg #$bootcfg-drv #:bootcfg-location #$(bootloader-configuration-file bootloader) #:bootloader-installer #$(bootloader-installer bootloader))))))) #:system system #:make-disk-image? #t #:disk-image-size disk-image-size #:disk-image-format disk-image-format #:references-graphs inputs)) (define* (system-docker-image os #:key (name "guix-docker-image") (register-closures? (has-guix-service-type? os))) "Build a docker image. OS is the desired <operating-system>. NAME is the base name to use for the output file. When REGISTER-CLOSURES? is true, register the closure of OS with Guix in the resulting Docker image. By default, REGISTER-CLOSURES? is set to true only if a service of type GUIX-SERVICE-TYPE is present in the services definition of the operating system." (define schema (and register-closures? (local-file (search-path %load-path "guix/store/schema.sql")))) (define boot-program ;; Program that runs the boot script of OS, which in turn starts shepherd. (program-file "boot-program" #~(let ((system (cadr (command-line)))) (setenv "GUIX_NEW_SYSTEM" system) (execl #$(file-append guile-2.2 "/bin/guile") "guile" "--no-auto-compile" (string-append system "/boot"))))) (let ((os (operating-system-with-gc-roots (containerized-operating-system os '()) (list boot-program))) (name (string-append name ".tar.gz")) (graph "system-graph")) (define build (with-extensions (cons guile-json-3 ;for (guix docker) gcrypt-sqlite3&co) ;for (guix store database) (with-imported-modules `(,@(source-module-closure '((guix docker) (guix store database) (guix build utils) (guix build store-copy) (gnu build vm)) #:select? not-config?) ((guix config) => ,(make-config.scm))) #~(begin (use-modules (guix docker) (guix build utils) (gnu build vm) (srfi srfi-19) (guix build store-copy) (guix store database)) ;; Set the SQL schema location. (sql-schema #$schema) ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. (setenv "GUIX_LOCPATH" #+(file-append glibc-utf8-locales "/lib/locale")) (setlocale LC_ALL "en_US.utf8") (let* (;; This initializer requires elevated privileges that are ;; not normally available in the build environment (e.g., ;; it needs to create device nodes). In order to obtain ;; such privileges, we run it as root in a VM. (initialize (root-partition-initializer #:closures '(#$graph) #:register-closures? #$register-closures? #:system-directory #$os ;; De-duplication would fail due to ;; cross-device link errors, so don't do it. #:deduplicate? #f)) ;; Even as root in a VM, the initializer would fail due to ;; lack of privileges if we use a root-directory that is on ;; a file system that is shared with the host (e.g., /tmp). (root-directory "/guixsd-system-root")) (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar)) (mkdir root-directory) (initialize root-directory) (build-docker-image (string-append "/xchg/" #$name) ;; The output file. (cons* root-directory (map store-info-item (call-with-input-file (string-append "/xchg/" #$graph) read-reference-graph))) #$os #:entry-point '(#$boot-program #$os) #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:creation-time (make-time time-utc 0 1) #:transformations `((,root-directory -> "")))))))) (expression->derivation-in-linux-vm name build #:make-disk-image? #f #:single-file-output? #t #:references-graphs `((,graph ,os))))) ;;; ;;; VM and disk images. ;;; (define* (operating-system-uuid os #:optional (type 'dce)) "Compute UUID object with a deterministic \"UUID\" for OS, of the given TYPE (one of 'iso9660 or 'dce). Return a UUID object." ;; Note: For this to be deterministic, we must not hash things that contains ;; (directly or indirectly) procedures, for example. That rules out ;; anything that contains gexps, thunk or delayed record fields, etc. (define service-name (compose service-type-name service-kind)) (define (file-system-digest fs) ;; Return a hashable digest that does not contain 'dependencies' since ;; this field can contain procedures. (let ((device (file-system-device fs))) (list (file-system-mount-point fs) (file-system-type fs) (cond ((file-system-label? device) (file-system-label->string device)) ((uuid? device) (uuid->string device)) ((string? device) device) (else #f)) (file-system-options fs)))) (if (eq? type 'iso9660) (let ((pad (compose (cut string-pad <> 2 #\0) number->string)) (h (hash (map service-name (operating-system-services os)) 3600))) (bytevector->uuid (string->iso9660-uuid (string-append "1970-01-01-" (pad (hash (operating-system-host-name os) 24)) "-" (pad (quotient h 60)) "-" (pad (modulo h 60)) "-" (pad (hash (map file-system-digest (operating-system-file-systems os)) 100)))) 'iso9660)) (bytevector->uuid (uint-list->bytevector (list (hash file-system-type (- (expt 2 32) 1)) (hash (operating-system-host-name os) (- (expt 2 32) 1)) (hash (map service-name (operating-system-services os)) (- (expt 2 32) 1)) (hash (map file-system-digest (operating-system-file-systems os)) (- (expt 2 32) 1))) (endianness little) 4) type))) (define* (system-disk-image os #:key (name "disk-image") (file-system-type "ext4") (disk-image-size (* 900 (expt 2 20))) (volatile? #t)) "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the system described by OS. Said image can be copied on a USB stick as is. When VOLATILE? is true, the root file system is made volatile; this is useful to USB sticks meant to be read-only." (define normalize-label ;; ISO labels are all-caps (case-insensitive), but since ;; 'find-partition-by-label' is case-sensitive, make it all-caps here. (if (string=? "iso9660" file-system-type) string-upcase identity)) (define root-label ;; Volume name of the root file system. (normalize-label "Guix_image")) (define (root-uuid os) ;; UUID of the root file system, computed in a deterministic fashion. ;; This is what we use to locate the root file system so it has to be ;; different from the user's own file system UUIDs. (operating-system-uuid os (if (string=? file-system-type "iso9660") 'iso9660 'dce))) (define file-systems-to-keep (remove (lambda (fs) (string=? (file-system-mount-point fs) "/")) (operating-system-file-systems os))) (let* ((os (operating-system (inherit os) ;; Since this is meant to be used on real hardware, don't ;; install QEMU networking or anything like that. Assume USB ;; mass storage devices (usb-storage.ko) are available. (initrd (lambda (file-systems . rest) (apply (operating-system-initrd os) file-systems #:volatile-root? #t rest))) (bootloader (if (string=? "iso9660" file-system-type) (bootloader-configuration (inherit (operating-system-bootloader os)) (bootloader grub-mkrescue-bootloader)) (operating-system-bootloader os))) ;; Force our own root file system. (We need a "/" file system ;; to call 'root-uuid'.) (file-systems (cons (file-system (mount-point "/") (device "/dev/placeholder") (type file-system-type)) file-systems-to-keep)))) (uuid (root-uuid os)) (os (operating-system (inherit os) (file-systems (cons (file-system (mount-point "/") (device uuid) (type file-system-type)) file-systems-to-keep)))) (bootcfg (operating-system-bootcfg os))) (if (string=? "iso9660" file-system-type) (iso9660-image #:name name #:file-system-label root-label #:file-system-uuid uuid #:os os #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:inputs `(("system" ,os) ("bootcfg" ,bootcfg)) #:grub-mkrescue-environment '(("MKRESCUE_SED_MODE" . "mbr_hfs"))) (qemu-image #:name name #:os os #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:disk-image-format "raw" #:file-system-type file-system-type #:file-system-label root-label #:file-system-uuid uuid #:copy-inputs? #t #:inputs `(("system" ,os) ("bootcfg" ,bootcfg)))))) (define* (system-qemu-image os #:key (file-system-type "ext4") (disk-image-size (* 900 (expt 2 20)))) "Return the derivation of a freestanding QEMU image of DISK-IMAGE-SIZE bytes of the GNU system as described by OS." (define file-systems-to-keep ;; Keep only file systems other than root and not normally bound to real ;; devices. (remove (lambda (fs) (let ((target (file-system-mount-point fs)) (source (file-system-device fs))) (or (string=? target "/") (string-prefix? "/dev/" source)))) (operating-system-file-systems os))) (define root-uuid ;; UUID of the root file system. (operating-system-uuid os (if (string=? file-system-type "iso9660") 'iso9660 'dce))) (let* ((os (operating-system (inherit os) ;; Assume we have an initrd with the whole QEMU shebang. ;; Force our own root file system. Refer to it by UUID so that ;; it works regardless of how the image is used ("qemu -hda", ;; Xen, etc.). (file-systems (cons (file-system (mount-point "/") (device root-uuid) (type file-system-type)) file-systems-to-keep)))) (bootcfg (operating-system-bootcfg os))) (qemu-image #:os os #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:file-system-type file-system-type #:file-system-uuid root-uuid #:inputs `(("system" ,os) ("bootcfg" ,bootcfg)) #:copy-inputs? #t))) ;;; ;;; VMs that share file systems with the host. ;;; (define (file-system->mount-tag fs) "Return a 9p mount tag for host file system FS." ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain ;; slashes, and cannot start with '_'. Compute an identifier that ;; corresponds to the rules. (string-append "TAG" (string-drop (bytevector->base32-string (sha1 (string->utf8 fs))) 4))) (define (mapping->file-system mapping) "Return a 9p file system that realizes MAPPING." (match mapping (($ <file-system-mapping> source target writable?) (file-system (mount-point target) (device (file-system->mount-tag source)) (type "9p") (flags (if writable? '() '(read-only))) (options "trans=virtio,cache=loose") (check? #f) (create-mount-point? #t))))) (define* (virtualized-operating-system os mappings #:optional (full-boot? #f)) "Return an operating system based on OS suitable for use in a virtualized environment with the store shared with the host. MAPPINGS is a list of <file-system-mapping> to realize in the virtualized OS." (define user-file-systems ;; Remove file systems that conflict with those added below, or that are ;; normally bound to real devices. (remove (lambda (fs) (let ((target (file-system-mount-point fs)) (source (file-system-device fs))) (or (string=? target (%store-prefix)) (string=? target "/") (and (string? source) (string-prefix? "/dev/" source)) ;; Labels and UUIDs are necessarily invalid in the VM. (and (file-system-mount? fs) (or (file-system-label? source) (uuid? source)))))) (operating-system-file-systems os))) (define virtual-file-systems (cons (file-system (mount-point "/") (device "/dev/vda1") (type "ext4")) (append (map mapping->file-system mappings) user-file-systems))) (operating-system (inherit os) ;; XXX: Until we run QEMU with UEFI support (with the OVMF firmware), ;; force the traditional i386/BIOS method. ;; See <https://bugs.gnu.org/28768>. (bootloader (bootloader-configuration (inherit (operating-system-bootloader os)) (bootloader grub-bootloader) (target "/dev/vda"))) (initrd (lambda (file-systems . rest) (apply (operating-system-initrd os) file-systems #:volatile-root? #t rest))) ;; Disable swap. (swap-devices '()) ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store ;; since that would lead the bootloader config to look for the kernel and ;; initrd in it. (file-systems (if full-boot? virtual-file-systems (cons (file-system (inherit (mapping->file-system %store-mapping)) (needed-for-boot? #t)) virtual-file-systems))))) (define* (system-qemu-image/shared-store os #:key full-boot? (disk-image-size (* (if full-boot? 500 30) (expt 2 20)))) "Return a derivation that builds a QEMU image of OS that shares its store with the host. When FULL-BOOT? is true, return an image that does a complete boot sequence, bootloaded included; thus, make a disk image that contains everything the bootloader refers to: OS kernel, initrd, bootloader data, etc." (define root-uuid ;; Use a fixed UUID to improve determinism. (operating-system-uuid os 'dce)) (define bootcfg (operating-system-bootcfg os)) ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains ;; BOOTCFG and all its dependencies, including the output of OS. ;; This is more than needed (we only need the kernel, initrd, GRUB for its ;; font, and the background image), but it's hard to filter that. (qemu-image #:os os #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:disk-image-size disk-image-size #:file-system-uuid root-uuid #:inputs (if full-boot? `(("bootcfg" ,bootcfg)) '()) ;; XXX: Passing #t here is too slow, so let it off by default. #:register-closures? #f #:copy-inputs? full-boot?)) (define* (common-qemu-options image shared-fs) "Return the a string-value gexp with the common QEMU options to boot IMAGE, with '-virtfs' options for the host file systems listed in SHARED-FS." (define (virtfs-option fs) #~(format #f "-virtfs local,path=~s,security_model=none,mount_tag=~s" #$fs #$(file-system->mount-tag fs))) #~(;; Only enable kvm if we see /dev/kvm exists. ;; This allows users without hardware virtualization to still use these ;; commands. #$@(if (file-exists? "/dev/kvm") '("-enable-kvm") '()) "-no-reboot" "-net nic,model=virtio" "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" "-device" "virtio-rng-pci,rng=guixsd-vm-rng" #$@(map virtfs-option shared-fs) "-vga std" (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly" #$image))) (define* (system-qemu-image/shared-store-script os #:key (qemu qemu) (graphic? #t) (memory-size 256) (mappings '()) full-boot? (disk-image-size (* (if full-boot? 500 70) (expt 2 20))) (options '())) "Return a derivation that builds a script to run a virtual machine image of OS that shares its store with the host. The virtual machine runs with MEMORY-SIZE MiB of memory. MAPPINGS is a list of <file-system-mapping> specifying mapping of host file systems into the guest. When FULL-BOOT? is true, the returned script runs everything starting from the bootloader; otherwise it directly starts the operating system kernel. The DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image; it is mostly useful when FULL-BOOT? is true." (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?)) (image (system-qemu-image/shared-store os #:full-boot? full-boot? #:disk-image-size disk-image-size))) (define kernel-arguments #~(list #$@(if graphic? #~() #~("console=ttyS0")) #+@(operating-system-kernel-arguments os "/dev/vda1"))) (define qemu-exec #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system))) #$@(if full-boot? #~() #~("-kernel" #$(operating-system-kernel-file os) "-initrd" #$(file-append os "/initrd") (format #f "-append ~s" (string-join #$kernel-arguments " ")))) #$@(common-qemu-options image (map file-system-mapping-source (cons %store-mapping mappings))) "-m " (number->string #$memory-size) #$@options)) (define builder #~(call-with-output-file #$output (lambda (port) (format port "#!~a~% exec ~a \"$@\"~%" #$(file-append bash "/bin/sh") (string-join #$qemu-exec " ")) (chmod port #o555)))) (gexp->derivation "run-vm.sh" builder))) ;;; ;;; High-level abstraction. ;;; (define-record-type* <virtual-machine> %virtual-machine make-virtual-machine virtual-machine? (operating-system virtual-machine-operating-system) ;<operating-system> (qemu virtual-machine-qemu ;<package> (default qemu)) (graphic? virtual-machine-graphic? ;Boolean (default #f)) (memory-size virtual-machine-memory-size ;integer (MiB) (default 256)) (disk-image-size virtual-machine-disk-image-size ;integer (bytes) (default 'guess)) (port-forwardings virtual-machine-port-forwardings ;list of integer pairs (default '()))) (define-syntax virtual-machine (syntax-rules () "Declare a virtual machine running the specified OS, with the given options." ((_ os) ;shortcut (%virtual-machine (operating-system os))) ((_ fields ...) (%virtual-machine fields ...)))) (define (port-forwardings->qemu-options forwardings) "Return the QEMU option for the given port FORWARDINGS as a string, where FORWARDINGS is a list of host-port/guest-port pairs." (string-join (map (match-lambda ((host-port . guest-port) (string-append "hostfwd=tcp::" (number->string host-port) "-:" (number->string guest-port)))) forwardings) ",")) (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>) system target) ;; XXX: SYSTEM and TARGET are ignored. (match vm (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ()) (system-qemu-image/shared-store-script os #:qemu qemu #:graphic? graphic? #:memory-size memory-size #:disk-image-size disk-image-size)) (($ <virtual-machine> os qemu graphic? memory-size disk-image-size forwardings) (let ((options `("-net" ,(string-append "user," (port-forwardings->qemu-options forwardings))))) (system-qemu-image/shared-store-script os #:qemu qemu #:graphic? graphic? #:memory-size memory-size #:disk-image-size disk-image-size #:options options))))) ;;; vm.scm ends here
generated by cgit