WIP: bees service

[jackhill/guix/guix.git] / gnu / tests / ssh.scm

diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index 9247a43..10438ad 100644 (file)
--- a/gnu/tests/ssh.scm
+++ b/gnu/tests/ssh.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -31,7 +31,8 @@
   #:export (%test-openssh
             %test-dropbear))
 
-(define* (run-ssh-test name ssh-service pid-file #:key (sftp? #f))
+(define* (run-ssh-test name ssh-service pid-file
+                       #:key (sftp? #f) (test-getlogin? #t))
   "Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE.
 SSH-SERVICE must be configured to listen on port 22 and to allow for root and
 empty-password logins.
@@ -39,7 +40,7 @@ empty-password logins.
 When SFTP? is true, run an SFTP server test."
   (define os
     (marionette-operating-system
-     (simple-operating-system (dhcp-client-service) ssh-service)
+     (simple-operating-system (service dhcp-client-service-type) ssh-service)
      #:imported-modules '((gnu services herd)
                           (guix combinators))))
   (define vm
@@ -54,10 +55,12 @@ When SFTP? is true, run an SFTP server test."
             (use-modules (gnu build marionette)
                          (srfi srfi-26)
                          (srfi srfi-64)
+                         (ice-9 textual-ports)
                          (ice-9 match)
                          (ssh session)
                          (ssh auth)
                          (ssh channel)
+                         (ssh popen)
                          (ssh sftp))
 
             (define marionette
@@ -111,13 +114,11 @@ root with an empty password."
             (test-begin "ssh-daemon")
 
             ;; Wait for sshd to be up and running.
-            (test-eq "service running"
-              'running!
+            (test-assert "service running"
               (marionette-eval
                '(begin
                   (use-modules (gnu services herd))
-                  (start-service 'ssh-daemon)
-                  'running!)
+                  (start-service 'ssh-daemon))
                marionette))
 
             ;; Check sshd's PID file.
@@ -135,6 +136,9 @@ root with an empty password."
                          (current-services))))
                marionette))
 
+            (test-assert "wait for port 22"
+              (wait-for-tcp-port 22 marionette))
+
             ;; Connect to the guest over SSH.  Make sure we can run a shell
             ;; command there.
             (test-equal "shell command"
@@ -149,6 +153,20 @@ root with an empty password."
                    (and (zero? (channel-get-exit-status channel))
                         (wait-for-file "/root/witness" marionette))))))
 
+            ;; Check whether the 'getlogin' procedure returns the right thing.
+            (unless #$test-getlogin?
+              (test-skip 1))
+            (test-equal "getlogin"
+              '(0 "root")
+              (call-with-connected-session/auth
+               (lambda (session)
+                 (let* ((pipe   (open-remote-input-pipe
+                                 session
+                                 "guile -c '(display (getlogin))'"))
+                        (output (get-string-all pipe))
+                        (status (channel-get-exit-status pipe)))
+                   (list status output)))))
+
             ;; Connect to the guest over SFTP.  Make sure we can write and
             ;; read a file there.
             (unless #$sftp?
@@ -219,4 +237,9 @@ root with an empty password."
                                  (dropbear-configuration
                                   (root-login? #t)
                                   (allow-empty-passwords? #t)))
-                        "/var/run/dropbear.pid"))))
+                        "/var/run/dropbear.pid"
+
+                        ;; XXX: Our Dropbear is not built with PAM support.
+                        ;; Even when it is, it seems to ignore the PAM
+                        ;; 'session' requirements.
+                        #:test-getlogin? #f))))