gnu/tests/ssh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
   4 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu tests ssh)
  22   #:use-module (gnu tests)
  23   #:use-module (gnu system)
  24   #:use-module (gnu system vm)
  25   #:use-module (gnu services)
  26   #:use-module (gnu services ssh)
  27   #:use-module (gnu services networking)
  28   #:use-module (gnu packages ssh)
  29   #:use-module (guix gexp)
  30   #:use-module (guix store)
  31   #:export (%test-openssh
  32             %test-dropbear))
  33
  34 (define* (run-ssh-test name ssh-service pid-file
  35                        #:key (sftp? #f) (test-getlogin? #t))
  36   "Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE.
  37 SSH-SERVICE must be configured to listen on port 22 and to allow for root and
  38 empty-password logins.
  39
  40 When SFTP? is true, run an SFTP server test."
  41   (define os
  42     (marionette-operating-system
  43      (simple-operating-system (service dhcp-client-service-type) ssh-service)
  44      #:imported-modules '((gnu services herd)
  45                           (guix combinators))))
  46   (define vm
  47     (virtual-machine
  48      (operating-system os)
  49      (port-forwardings '((2222 . 22)))))
  50
  51   (define test
  52     (with-imported-modules '((gnu build marionette))
  53       (with-extensions (list guile-ssh)
  54         #~(begin
  55             (use-modules (gnu build marionette)
  56                          (srfi srfi-26)
  57                          (srfi srfi-64)
  58                          (ice-9 textual-ports)
  59                          (ice-9 match)
  60                          (ssh session)
  61                          (ssh auth)
  62                          (ssh channel)
  63                          (ssh popen)
  64                          (ssh sftp))
  65
  66             (define marionette
  67               ;; Enable TCP forwarding of the guest's port 22.
  68               (make-marionette (list #$vm)))
  69
  70             (define (make-session-for-test)
  71               "Make a session with predefined parameters for a test."
  72               (make-session #:user "root"
  73                             #:port 2222
  74                             #:host "localhost"
  75                             #:log-verbosity 'protocol))
  76
  77             (define (call-with-connected-session proc)
  78               "Call the one-argument procedure PROC with a freshly created and
  79 connected SSH session object, return the result of the procedure call.  The
  80 session is disconnected when the PROC is finished."
  81               (let ((session (make-session-for-test)))
  82                 (dynamic-wind
  83                   (lambda ()
  84                     (let ((result (connect! session)))
  85                       (unless (equal? result 'ok)
  86                         (error "Could not connect to a server"
  87                                session result))))
  88                   (lambda () (proc session))
  89                   (lambda () (disconnect! session)))))
  90
  91             (define (call-with-connected-session/auth proc)
  92               "Make an authenticated session.  We should be able to connect as
  93 root with an empty password."
  94               (call-with-connected-session
  95                (lambda (session)
  96                  ;; Try the simple authentication methods.  Dropbear requires
  97                  ;; 'none' when there are no passwords, whereas OpenSSH accepts
  98                  ;; 'password' with an empty password.
  99                  (let loop ((methods (list (cut userauth-password! <> "")
 100                                            (cut userauth-none! <>))))
 101                    (match methods
 102                      (()
 103                       (error "all the authentication methods failed"))
 104                      ((auth rest ...)
 105                       (match (pk 'auth (auth session))
 106                         ('success
 107                          (proc session))
 108                         ('denied
 109                          (loop rest)))))))))
 110
 111             (test-runner-current (system-test-runner #$output))
 112             (test-begin "ssh-daemon")
 113
 114             ;; Wait for sshd to be up and running.
 115             (test-assert "service running"
 116               (marionette-eval
 117                '(begin
 118                   (use-modules (gnu services herd))
 119                   (start-service 'ssh-daemon))
 120                marionette))
 121
 122             ;; Check sshd's PID file.
 123             (test-assert "sshd PID"
 124               (let ((pid (marionette-eval
 125                           '(begin
 126                              (use-modules (gnu services herd)
 127                                           (srfi srfi-1))
 128
 129                              (live-service-running
 130                               (find (lambda (live)
 131                                       (memq 'ssh-daemon
 132                                             (live-service-provision live)))
 133                                     (current-services))))
 134                           marionette)))
 135                 (if #$pid-file
 136                     (= pid (wait-for-file #$pid-file marionette))
 137                     pid)))
 138
 139             (test-assert "wait for port 22, IPv4"
 140               (wait-for-tcp-port 22 marionette))
 141
 142             (test-assert "wait for port 22, IPv6"
 143               ;; Make sure it's also available as IPv6.
 144               ;; See <https://issues.guix.gnu.org/55335>.
 145               (wait-for-tcp-port 22 marionette
 146                                  #:address
 147                                  `(make-socket-address
 148                                    AF_INET6
 149                                    (inet-pton AF_INET6 "::1")
 150                                    22)))
 151
 152             ;; Connect to the guest over SSH.  Make sure we can run a shell
 153             ;; command there.
 154             (test-equal "shell command"
 155               'hello
 156               (call-with-connected-session/auth
 157                (lambda (session)
 158                  ;; FIXME: 'get-server-public-key' segfaults.
 159                  ;; (get-server-public-key session)
 160                  (let ((channel (make-channel session)))
 161                    (channel-open-session channel)
 162                    (channel-request-exec channel "echo hello > /root/witness")
 163                    (and (zero? (channel-get-exit-status channel))
 164                         (wait-for-file "/root/witness" marionette))))))
 165
 166             ;; Check whether the 'getlogin' procedure returns the right thing.
 167             (unless #$test-getlogin?
 168               (test-skip 1))
 169             (test-equal "getlogin"
 170               '(0 "root")
 171               (call-with-connected-session/auth
 172                (lambda (session)
 173                  (let* ((pipe   (open-remote-input-pipe
 174                                  session
 175                                  "guile -c '(display (getlogin))'"))
 176                         (output (get-string-all pipe))
 177                         (status (channel-get-exit-status pipe)))
 178                    (list status output)))))
 179
 180             ;; Connect to the guest over SFTP.  Make sure we can write and
 181             ;; read a file there.
 182             (unless #$sftp?
 183               (test-skip 1))
 184             (test-equal "SFTP file writing and reading"
 185               'hello
 186               (call-with-connected-session/auth
 187                (lambda (session)
 188                  (let ((sftp-session (make-sftp-session session))
 189                        (witness "/root/sftp-witness"))
 190                    (call-with-remote-output-file sftp-session witness
 191                                                  (cut display "hello" <>))
 192                    (call-with-remote-input-file sftp-session witness
 193                                                 read)))))
 194
 195             ;; Connect to the guest over SSH.  Make sure we can run commands
 196             ;; from the system profile.
 197             (test-equal "run executables from system profile"
 198               #t
 199               (call-with-connected-session/auth
 200                (lambda (session)
 201                  (let ((channel (make-channel session)))
 202                    (channel-open-session channel)
 203                    (channel-request-exec
 204                     channel
 205                     (string-append
 206                      "mkdir -p /root/.guix-profile/bin && "
 207                      "touch /root/.guix-profile/bin/path-witness && "
 208                      "chmod 755 /root/.guix-profile/bin/path-witness"))
 209                    (zero? (channel-get-exit-status channel))))))
 210
 211             ;; Connect to the guest over SSH.  Make sure we can run commands
 212             ;; from the user profile.
 213             (test-equal "run executable from user profile"
 214               #t
 215               (call-with-connected-session/auth
 216                (lambda (session)
 217                  (let ((channel (make-channel session)))
 218                    (channel-open-session channel)
 219                    (channel-request-exec channel "path-witness")
 220                    (zero? (channel-get-exit-status channel))))))
 221
 222             (test-end)))))
 223
 224   (gexp->derivation name test))
 225
 226 (define %test-openssh
 227   (system-test
 228    (name "openssh")
 229    (description "Connect to a running OpenSSH daemon.")
 230    (value (run-ssh-test name
 231                         ;; Allow root logins with an empty password to
 232                         ;; simplify testing.
 233                         (service openssh-service-type
 234                                  (openssh-configuration
 235                                   (permit-root-login #t)
 236                                   (allow-empty-passwords? #t)))
 237                         #f                        ;inetd-style, no PID file
 238                         #:sftp? #t))))
 239
 240 (define %test-dropbear
 241   (system-test
 242    (name "dropbear")
 243    (description "Connect to a running Dropbear SSH daemon.")
 244    (value (run-ssh-test name
 245                         (service dropbear-service-type
 246                                  (dropbear-configuration
 247                                   (root-login? #t)
 248                                   (allow-empty-passwords? #t)))
 249                         "/var/run/dropbear.pid"
 250
 251                         ;; XXX: Our Dropbear is not built with PAM support.
 252                         ;; Even when it is, it seems to ignore the PAM
 253                         ;; 'session' requirements.
 254                         #:test-getlogin? #f))))