gnu/tests/ssh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu tests ssh)
  20   #:use-module (gnu tests)
  21   #:use-module (gnu system)
  22   #:use-module (gnu system grub)
  23   #:use-module (gnu system file-systems)
  24   #:use-module (gnu system shadow)
  25   #:use-module (gnu system vm)
  26   #:use-module (gnu services)
  27   #:use-module (gnu services base)
  28   #:use-module (gnu services ssh)
  29   #:use-module (gnu services networking)
  30   #:use-module (gnu packages ssh)
  31   #:use-module (guix gexp)
  32   #:use-module (guix store)
  33   #:use-module (guix monads)
  34   #:export (%test-openssh))
  35
  36 (define %base-os
  37   (operating-system
  38     (host-name "komputilo")
  39     (timezone "Europe/Berlin")
  40     (locale "en_US.UTF-8")
  41
  42     (bootloader (grub-configuration (device "/dev/sdX")))
  43     (file-systems %base-file-systems)
  44     (firmware '())
  45     (users %base-user-accounts)
  46     (services (cons (dhcp-client-service)
  47                     %base-services))))
  48
  49 (define (os-with-service service)
  50   "Return a test operating system that runs SERVICE."
  51   (operating-system
  52     (inherit %base-os)
  53     (services (cons service
  54                     (operating-system-user-services %base-os)))))
  55
  56 (define (run-ssh-test name ssh-service pid-file)
  57   "Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE.
  58 SSH-SERVICE must be configured to listen on port 22 and to allow for root and
  59 empty-password logins."
  60   (mlet* %store-monad ((os ->   (marionette-operating-system
  61                                  (os-with-service ssh-service)
  62                                  #:imported-modules '((gnu services herd)
  63                                                       (guix combinators))))
  64                        (command (system-qemu-image/shared-store-script
  65                                  os #:graphic? #f)))
  66     (define test
  67       (with-imported-modules '((gnu build marionette))
  68         #~(begin
  69             (eval-when (expand load eval)
  70               ;; Prepare to use Guile-SSH.
  71               (set! %load-path
  72                 (cons (string-append #$guile-ssh "/share/guile/site/"
  73                                      (effective-version))
  74                       %load-path)))
  75
  76             (use-modules (gnu build marionette)
  77                          (srfi srfi-64)
  78                          (ice-9 match)
  79                          (ssh session)
  80                          (ssh auth)
  81                          (ssh channel))
  82
  83             (define marionette
  84               ;; Enable TCP forwarding of the guest's port 22.
  85               (make-marionette (list #$command "-net"
  86                                      "user,hostfwd=tcp::2222-:22")))
  87
  88             (define (wait-for-file file)
  89               ;; Wait until FILE exists in the guest; 'read' its content and
  90               ;; return it.
  91               (marionette-eval
  92                `(let loop ((i 10))
  93                   (cond ((file-exists? ,file)
  94                          (call-with-input-file ,file read))
  95                         ((> i 0)
  96                          (sleep 1)
  97                          (loop (- i 1)))
  98                         (else
  99                          (error "file didn't show up" ,file))))
 100                marionette))
 101
 102             (mkdir #$output)
 103             (chdir #$output)
 104
 105             (test-begin "ssh-daemon")
 106
 107             ;; Wait for sshd to be up and running.
 108             (test-eq "service running"
 109               'running!
 110               (marionette-eval
 111                '(begin
 112                   (use-modules (gnu services herd))
 113                   (start-service 'ssh-daemon)
 114                   'running!)
 115                marionette))
 116
 117             ;; Check sshd's PID file.
 118             (test-equal "sshd PID"
 119               (wait-for-file #$pid-file)
 120               (marionette-eval
 121                '(begin
 122                   (use-modules (gnu services herd)
 123                                (srfi srfi-1))
 124
 125                   (live-service-running
 126                    (find (lambda (live)
 127                            (memq 'ssh-daemon
 128                                  (live-service-provision live)))
 129                          (current-services))))
 130                marionette))
 131
 132             ;; Connect to the guest over SSH.  We should be able to connect as
 133             ;; "root" with an empty password.  Make sure we can run a shell
 134             ;; command there.
 135             (test-equal "connect"
 136               'hello
 137               (let* ((session (make-session #:user "root"
 138                                             #:port 2222 #:host "localhost"
 139                                             #:log-verbosity 'protocol)))
 140                 (match (connect! session)
 141                   ('ok
 142                    (match (pk 'auth (userauth-password! session ""))
 143                      ('success
 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
 149                                               "echo hello > /root/witness")
 150                         (and (zero? (channel-get-exit-status channel))
 151                              (wait-for-file "/root/witness")))))))))
 152
 153             (test-end)
 154             (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 155
 156     (gexp->derivation name test)))
 157
 158 (define %test-openssh
 159   (system-test
 160    (name "openssh")
 161    (description "Connect to a running OpenSSH daemon.")
 162    (value (run-ssh-test name
 163                         ;; Allow root logins with an empty password to
 164                         ;; simplify testing.
 165                         (service openssh-service-type
 166                                  (openssh-configuration
 167                                   (permit-root-login #t)
 168                                   (allow-empty-passwords? #t)))
 169                         "/var/run/sshd.pid"))))