summaryrefslogtreecommitdiff
path: root/gnu/tests
diff options
context:
space:
mode:
authorClément Lassieur <clement@lassieur.org>2017-03-19 13:18:37 +0100
committerClément Lassieur <clement@lassieur.org>2017-03-21 20:49:26 +0100
commitcfaf4d11659a6b78ef35676b4e37d6da179e5b51 (patch)
tree9ed1b354001e1bb9c097f4a297ff0b09be95e23c /gnu/tests
parent12723370e5a780b18eae4c44ab9634adaff927ea (diff)
downloadpatches-cfaf4d11659a6b78ef35676b4e37d6da179e5b51.tar
patches-cfaf4d11659a6b78ef35676b4e37d6da179e5b51.tar.gz
tests: ssh: Abstract session connection and authentication.
* gnu/tests/ssh.scm (run-ssh-test): Introduce make-session-for-test, call-with-connected-session and call-with-connected-session/auth. (run-ssh-test)["connect"]: Rename to "shell command". Abstract its session connection and authentication work into the above three functions.
Diffstat (limited to 'gnu/tests')
-rw-r--r--gnu/tests/ssh.scm82
1 files changed, 53 insertions, 29 deletions
diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index 456476e69d..7779b71561 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.
;;;
@@ -101,6 +102,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 +173,19 @@ 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
- (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)
+ ;; 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"))))))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))