gnu/tests/ssh.scm

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