gnu/tests/ssh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 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 #:key (sftp? #f))
  35   "Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE.
  36 SSH-SERVICE must be configured to listen on port 22 and to allow for root and
  37 empty-password logins.
  38
  39 When SFTP? is true, run an SFTP server test."
  40   (define os
  41     (marionette-operating-system
  42      (simple-operating-system (dhcp-client-service) ssh-service)
  43      #:imported-modules '((gnu services herd)
  44                           (guix combinators))))
  45   (define vm
  46     (virtual-machine
  47      (operating-system os)
  48      (port-forwardings '((2222 . 22)))))
  49
  50   (define test
  51     (with-imported-modules '((gnu build marionette))
  52       (with-extensions (list guile-ssh)
  53         #~(begin
  54             (use-modules (gnu build marionette)
  55                          (srfi srfi-26)
  56                          (srfi srfi-64)
  57                          (ice-9 match)
  58                          (ssh session)
  59                          (ssh auth)
  60                          (ssh channel)
  61                          (ssh sftp))
  62
  63             (define marionette
  64               ;; Enable TCP forwarding of the guest's port 22.
  65               (make-marionette (list #$vm)))
  66
  67             (define (make-session-for-test)
  68               "Make a session with predefined parameters for a test."
  69               (make-session #:user "root"
  70                             #:port 2222
  71                             #:host "localhost"
  72                             #:log-verbosity 'protocol))
  73
  74             (define (call-with-connected-session proc)
  75               "Call the one-argument procedure PROC with a freshly created and
  76 connected SSH session object, return the result of the procedure call.  The
  77 session is disconnected when the PROC is finished."
  78               (let ((session (make-session-for-test)))
  79                 (dynamic-wind
  80                   (lambda ()
  81                     (let ((result (connect! session)))
  82                       (unless (equal? result 'ok)
  83                         (error "Could not connect to a server"
  84                                session result))))
  85                   (lambda () (proc session))
  86                   (lambda () (disconnect! session)))))
  87
  88             (define (call-with-connected-session/auth proc)
  89               "Make an authenticated session.  We should be able to connect as
  90 root with an empty password."
  91               (call-with-connected-session
  92                (lambda (session)
  93                  ;; Try the simple authentication methods.  Dropbear requires
  94                  ;; 'none' when there are no passwords, whereas OpenSSH accepts
  95                  ;; 'password' with an empty password.
  96                  (let loop ((methods (list (cut userauth-password! <> "")
  97                                            (cut userauth-none! <>))))
  98                    (match methods
  99                      (()
 100                       (error "all the authentication methods failed"))
 101                      ((auth rest ...)
 102                       (match (pk 'auth (auth session))
 103                         ('success
 104                          (proc session))
 105                         ('denied
 106                          (loop rest)))))))))
 107
 108             (mkdir #$output)
 109             (chdir #$output)
 110
 111             (test-begin "ssh-daemon")
 112
 113             ;; Wait for sshd to be up and running.
 114             (test-eq "service running"
 115               'running!
 116               (marionette-eval
 117                '(begin
 118                   (use-modules (gnu services herd))
 119                   (start-service 'ssh-daemon)
 120                   'running!)
 121                marionette))
 122
 123             ;; Check sshd's PID file.
 124             (test-equal "sshd PID"
 125               (wait-for-file #$pid-file marionette)
 126               (marionette-eval
 127                '(begin
 128                   (use-modules (gnu services herd)
 129                                (srfi srfi-1))
 130
 131                   (live-service-running
 132                    (find (lambda (live)
 133                            (memq 'ssh-daemon
 134                                  (live-service-provision live)))
 135                          (current-services))))
 136                marionette))
 137
 138             ;; Connect to the guest over SSH.  Make sure we can run a shell
 139             ;; command there.
 140             (test-equal "shell command"
 141               'hello
 142               (call-with-connected-session/auth
 143                (lambda (session)
 144                  ;; FIXME: 'get-server-public-key' segfaults.
 145                  ;; (get-server-public-key session)
 146                  (let ((channel (make-channel session)))
 147                    (channel-open-session channel)
 148                    (channel-request-exec channel "echo hello > /root/witness")
 149                    (and (zero? (channel-get-exit-status channel))
 150                         (wait-for-file "/root/witness" marionette))))))
 151
 152             ;; Connect to the guest over SFTP.  Make sure we can write and
 153             ;; read a file there.
 154             (unless #$sftp?
 155               (test-skip 1))
 156             (test-equal "SFTP file writing and reading"
 157               'hello
 158               (call-with-connected-session/auth
 159                (lambda (session)
 160                  (let ((sftp-session (make-sftp-session session))
 161                        (witness "/root/sftp-witness"))
 162                    (call-with-remote-output-file sftp-session witness
 163                                                  (cut display "hello" <>))
 164                    (call-with-remote-input-file sftp-session witness
 165                                                 read)))))
 166
 167             ;; Connect to the guest over SSH.  Make sure we can run commands
 168             ;; from the system profile.
 169             (test-equal "run executables from system profile"
 170               #t
 171               (call-with-connected-session/auth
 172                (lambda (session)
 173                  (let ((channel (make-channel session)))
 174                    (channel-open-session channel)
 175                    (channel-request-exec
 176                     channel
 177                     (string-append
 178                      "mkdir -p /root/.guix-profile/bin && "
 179                      "touch /root/.guix-profile/bin/path-witness && "
 180                      "chmod 755 /root/.guix-profile/bin/path-witness"))
 181                    (zero? (channel-get-exit-status channel))))))
 182
 183             ;; Connect to the guest over SSH.  Make sure we can run commands
 184             ;; from the user profile.
 185             (test-equal "run executable from user profile"
 186               #t
 187               (call-with-connected-session/auth
 188                (lambda (session)
 189                  (let ((channel (make-channel session)))
 190                    (channel-open-session channel)
 191                    (channel-request-exec channel "path-witness")
 192                    (zero? (channel-get-exit-status channel))))))
 193
 194             (test-end)
 195             (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
 196
 197   (gexp->derivation name test))
 198
 199 (define %test-openssh
 200   (system-test
 201    (name "openssh")
 202    (description "Connect to a running OpenSSH daemon.")
 203    (value (run-ssh-test name
 204                         ;; Allow root logins with an empty password to
 205                         ;; simplify testing.
 206                         (service openssh-service-type
 207                                  (openssh-configuration
 208                                   (permit-root-login #t)
 209                                   (allow-empty-passwords? #t)))
 210                         "/var/run/sshd.pid"
 211                         #:sftp? #t))))
 212
 213 (define %test-dropbear
 214   (system-test
 215    (name "dropbear")
 216    (description "Connect to a running Dropbear SSH daemon.")
 217    (value (run-ssh-test name
 218                         (service dropbear-service-type
 219                                  (dropbear-configuration
 220                                   (root-login? #t)
 221                                   (allow-empty-passwords? #t)))
 222                         "/var/run/dropbear.pid"))))