[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
05/13: tests: ssh: Use 'with-extensions'.
From: |
Ludovic Courtès |
Subject: |
05/13: tests: ssh: Use 'with-extensions'. |
Date: |
Fri, 1 Jun 2018 09:38:32 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit ff913cf514b2a1d6d8400b24c675125387049b41
Author: Ludovic Courtès <address@hidden>
Date: Mon May 28 18:23:24 2018 +0200
tests: ssh: Use 'with-extensions'.
* gnu/tests/ssh.scm (run-ssh-test)[test]: Wrap body in
'with-extensions'. Remove %load-path manipulation code.
---
gnu/tests/ssh.scm | 290 ++++++++++++++++++++++++++----------------------------
1 file changed, 142 insertions(+), 148 deletions(-)
diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index 6abc6c2..9247a43 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 <address@hidden>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <address@hidden>
;;; Copyright © 2017 Clément Lassieur <address@hidden>
;;; Copyright © 2017 Marius Bakke <address@hidden>
;;;
@@ -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))
- branch master updated (5d66988 -> bf5bf57), Ludovic Courtès, 2018/06/01
- 02/13: pack: Adjust test to expect relative symlinks., Ludovic Courtès, 2018/06/01
- 01/13: tests: Fix arguments in pack test., Ludovic Courtès, 2018/06/01
- 06/13: bootloader: grub: Simplify 'svg->png'., Ludovic Courtès, 2018/06/01
- 12/13: database: 'register-path' resets timestamps., Ludovic Courtès, 2018/06/01
- 05/13: tests: ssh: Use 'with-extensions'.,
Ludovic Courtès <=
- 13/13: Add (guix store deduplication)., Ludovic Courtès, 2018/06/01
- 07/13: bootloader: grub: Use 'with-extensions'., Ludovic Courtès, 2018/06/01
- 10/13: build: Check for Guile-SQLite3., Ludovic Courtès, 2018/06/01
- 08/13: profiles: Use 'with-extensions'., Ludovic Courtès, 2018/06/01
- 03/13: gexp: Add 'with-extensions'., Ludovic Courtès, 2018/06/01
- 09/13: vm: Use 'with-extensions'., Ludovic Courtès, 2018/06/01
- 04/13: pack: Use 'with-extensions' when referring to (guix docker)., Ludovic Courtès, 2018/06/01
- 11/13: Add (gnu store database)., Ludovic Courtès, 2018/06/01