diff options
Diffstat (limited to 'gnu/tests/ssh.scm')
| -rw-r--r-- | gnu/tests/ssh.scm | 290 |
1 files changed, 142 insertions, 148 deletions
diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm index 6abc6c2501..9247a43e6d 100644 --- a/gnu/tests/ssh.scm +++ b/gnu/tests/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; @@ -49,156 +49,150 @@ When SFTP? is true, run an SFTP server test." (define test (with-imported-modules '((gnu build marionette)) - #~(begin - (eval-when (expand load eval) - ;; Prepare to use Guile-SSH. - (set! %load-path - (cons (string-append #+guile-ssh "/share/guile/site/" - (effective-version)) - %load-path))) - - (use-modules (gnu build marionette) - (srfi srfi-26) - (srfi srfi-64) - (ice-9 match) - (ssh session) - (ssh auth) - (ssh channel) - (ssh sftp)) - - (define marionette - ;; Enable TCP forwarding of the guest's port 22. - (make-marionette (list #$vm))) - - (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 + (with-extensions (list guile-ssh) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-26) + (srfi srfi-64) + (ice-9 match) + (ssh session) + (ssh auth) + (ssh channel) + (ssh sftp)) + + (define marionette + ;; Enable TCP forwarding of the guest's port 22. + (make-marionette (list #$vm))) + + (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 + (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) - - (test-begin "ssh-daemon") - - ;; Wait for sshd to be up and running. - (test-eq "service running" - 'running! - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'ssh-daemon) - 'running!) - marionette)) - - ;; Check sshd's PID file. - (test-equal "sshd PID" - (wait-for-file #$pid-file marionette) - (marionette-eval - '(begin - (use-modules (gnu services herd) - (srfi srfi-1)) - - (live-service-running - (find (lambda (live) - (memq 'ssh-daemon - (live-service-provision live))) - (current-services)))) - marionette)) - - ;; Connect to the guest over SSH. Make sure we can run a shell - ;; command there. - (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" marionette)))))) - - ;; 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 - (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))))) - - ;; Connect to the guest over SSH. Make sure we can run commands - ;; from the system profile. - (test-equal "run executables from system profile" - #t - (call-with-connected-session/auth - (lambda (session) - (let ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec - channel - (string-append - "mkdir -p /root/.guix-profile/bin && " - "touch /root/.guix-profile/bin/path-witness && " - "chmod 755 /root/.guix-profile/bin/path-witness")) - (zero? (channel-get-exit-status channel)))))) - - ;; Connect to the guest over SSH. Make sure we can run commands - ;; from the user profile. - (test-equal "run executable from user profile" - #t - (call-with-connected-session/auth - (lambda (session) - (let ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec channel "path-witness") - (zero? (channel-get-exit-status channel)))))) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + (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) + + (test-begin "ssh-daemon") + + ;; Wait for sshd to be up and running. + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'ssh-daemon) + 'running!) + marionette)) + + ;; Check sshd's PID file. + (test-equal "sshd PID" + (wait-for-file #$pid-file marionette) + (marionette-eval + '(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + (live-service-running + (find (lambda (live) + (memq 'ssh-daemon + (live-service-provision live))) + (current-services)))) + marionette)) + + ;; Connect to the guest over SSH. Make sure we can run a shell + ;; command there. + (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" marionette)))))) + + ;; 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 + (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))))) + + ;; Connect to the guest over SSH. Make sure we can run commands + ;; from the system profile. + (test-equal "run executables from system profile" + #t + (call-with-connected-session/auth + (lambda (session) + (let ((channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec + channel + (string-append + "mkdir -p /root/.guix-profile/bin && " + "touch /root/.guix-profile/bin/path-witness && " + "chmod 755 /root/.guix-profile/bin/path-witness")) + (zero? (channel-get-exit-status channel)))))) + + ;; Connect to the guest over SSH. Make sure we can run commands + ;; from the user profile. + (test-equal "run executable from user profile" + #t + (call-with-connected-session/auth + (lambda (session) + (let ((channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec channel "path-witness") + (zero? (channel-get-exit-status channel)))))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0)))))) (gexp->derivation name test)) |