Merge remote-tracking branch 'origin/master' into core-updates

1 files changed, 76 insertions, 33 deletions

diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index 456476e69d..c1582c4737 100644
--- a/gnu/tests/ssh.scm
+++ b/gnu/tests/ssh.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -54,10 +55,12 @@
     (services (cons service
                     (operating-system-user-services %base-os)))))
 
-(define (run-ssh-test name ssh-service pid-file)
+(define* (run-ssh-test name ssh-service pid-file #:key (sftp? #f))
   "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."
+empty-password logins.
+
+When SFTP? is true, run an SFTP server test."
   (mlet* %store-monad ((os ->   (marionette-operating-system
                                  (os-with-service ssh-service)
                                  #:imported-modules '((gnu services herd)
@@ -80,7 +83,8 @@ empty-password logins."
                          (ice-9 match)
                          (ssh session)
                          (ssh auth)
-                         (ssh channel))
+                         (ssh channel)
+                         (ssh sftp))
 
             (define marionette
               ;; Enable TCP forwarding of the guest's port 22.
@@ -101,6 +105,47 @@ empty-password logins."
                          (error "file didn't show up" ,file))))
                marionette))
 
+            (define (make-session-for-test)
+              "Make a session with predefined parameters for a test."
+              (make-session #:user "root"
+                            #:port 2222
+                            #:host "localhost"
+                            #:log-verbosity 'protocol))
+
+            (define (call-with-connected-session proc)
+              "Call the one-argument procedure PROC with a freshly created and
+connected SSH session object, return the result of the procedure call.  The
+session is disconnected when the PROC is finished."
+              (let ((session (make-session-for-test)))
+                (dynamic-wind
+                  (lambda ()
+                    (let ((result (connect! session)))
+                      (unless (equal? result 'ok)
+                        (error "Could not connect to a server"
+                               session result))))
+                  (lambda () (proc session))
+                  (lambda () (disconnect! session)))))
+
+            (define (call-with-connected-session/auth proc)
+              "Make an authenticated session.  We should be able to connect as
+root with an empty password."
+              (call-with-connected-session
+               (lambda (session)
+                 ;; Try the simple authentication methods.  Dropbear requires
+                 ;; 'none' when there are no passwords, whereas OpenSSH accepts
+                 ;; 'password' with an empty password.
+                 (let loop ((methods (list (cut userauth-password! <> "")
+                                           (cut userauth-none! <>))))
+                   (match methods
+                     (()
+                      (error "all the authentication methods failed"))
+                     ((auth rest ...)
+                      (match (pk 'auth (auth session))
+                        ('success
+                         (proc session))
+                        ('denied
+                         (loop rest)))))))))
+
             (mkdir #$output)
             (chdir #$output)
 
@@ -131,37 +176,34 @@ empty-password logins."
                          (current-services))))
                marionette))
 
-            ;; Connect to the guest over SSH.  We should be able to connect as
-            ;; "root" with an empty password.  Make sure we can run a shell
+            ;; Connect to the guest over SSH.  Make sure we can run a shell
             ;; command there.
-            (test-equal "connect"
+            (test-equal "shell command"
+              'hello
+              (call-with-connected-session/auth
+               (lambda (session)
+                 ;; FIXME: 'get-server-public-key' segfaults.
+                 ;; (get-server-public-key session)
+                 (let ((channel (make-channel session)))
+                   (channel-open-session channel)
+                   (channel-request-exec channel "echo hello > /root/witness")
+                   (and (zero? (channel-get-exit-status channel))
+                        (wait-for-file "/root/witness"))))))
+
+            ;; Connect to the guest over SFTP.  Make sure we can write and
+            ;; read a file there.
+            (unless #$sftp?
+              (test-skip 1))
+            (test-equal "SFTP file writing and reading"
               'hello
-              (let* ((session (make-session #:user "root"
-                                            #:port 2222 #:host "localhost"
-                                            #:log-verbosity 'protocol)))
-                (match (connect! session)
-                  ('ok
-                   ;; Try the simple authentication methods.  Dropbear
-                   ;; requires 'none' when there are no passwords, whereas
-                   ;; OpenSSH accepts 'password' with an empty password.
-                   (let loop ((methods (list (cut userauth-password! <> "")
-                                             (cut userauth-none! <>))))
-                     (match methods
-                       (()
-                        (error "all the authentication methods failed"))
-                       ((auth rest ...)
-                        (match (pk 'auth (auth session))
-                          ('success
-                           ;; FIXME: 'get-server-public-key' segfaults.
-                           ;; (get-server-public-key session)
-                           (let ((channel (make-channel session)))
-                             (channel-open-session channel)
-                             (channel-request-exec channel
-                                                   "echo hello > /root/witness")
-                             (and (zero? (channel-get-exit-status channel))
-                                  (wait-for-file "/root/witness"))))
-                          ('denied
-                           (loop rest))))))))))
+              (call-with-connected-session/auth
+               (lambda (session)
+                 (let ((sftp-session (make-sftp-session session))
+                       (witness "/root/sftp-witness"))
+                   (call-with-remote-output-file sftp-session witness
+                                                 (cut display "hello" <>))
+                   (call-with-remote-input-file sftp-session witness
+                                                read)))))
 
             (test-end)
             (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
@@ -179,7 +221,8 @@ empty-password logins."
                                  (openssh-configuration
                                   (permit-root-login #t)
                                   (allow-empty-passwords? #t)))
-                        "/var/run/sshd.pid"))))
+                        "/var/run/sshd.pid"
+                        #:sftp? #t))))
 
 (define %test-dropbear
   (system-test