;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 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.
;;;
(define-module (gnu tests ssh)
#:use-module (gnu tests)
#:use-module (gnu system)
- #:use-module (gnu system grub)
- #:use-module (gnu system file-systems)
- #:use-module (gnu system shadow)
#:use-module (gnu system vm)
#:use-module (gnu services)
- #:use-module (gnu services base)
#:use-module (gnu services ssh)
#:use-module (gnu services networking)
#:use-module (gnu packages ssh)
#:use-module (guix gexp)
#:use-module (guix store)
- #:use-module (guix monads)
#:export (%test-openssh
%test-dropbear))
-(define %base-os
- (operating-system
- (host-name "komputilo")
- (timezone "Europe/Berlin")
- (locale "en_US.UTF-8")
-
- (bootloader (grub-configuration (device "/dev/sdX")))
- (file-systems %base-file-systems)
- (firmware '())
- (users %base-user-accounts)
- (services (cons (dhcp-client-service)
- %base-services))))
-
-(define (os-with-service service)
- "Return a test operating system that runs SERVICE."
- (operating-system
- (inherit %base-os)
- (services (cons service
- (operating-system-user-services %base-os)))))
-
-(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.
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)
- (guix combinators))))
- (command (system-qemu-image/shared-store-script
- os #:graphic? #f)))
- (define test
- (with-imported-modules '((gnu build marionette))
+ (define os
+ (marionette-operating-system
+ (simple-operating-system (service dhcp-client-service-type) ssh-service)
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (port-forwardings '((2222 . 22)))))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ (with-extensions (list guile-ssh)
#~(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 textual-ports)
(ice-9 match)
(ssh session)
(ssh auth)
(ssh channel)
+ (ssh popen)
(ssh sftp))
(define marionette
;; Enable TCP forwarding of the guest's port 22.
- (make-marionette (list #$command "-net"
- "user,hostfwd=tcp::2222-:22")))
-
- (define (wait-for-file file)
- ;; Wait until FILE exists in the guest; 'read' its content and
- ;; return it.
- (marionette-eval
- `(let loop ((i 10))
- (cond ((file-exists? ,file)
- (call-with-input-file ,file read))
- ((> i 0)
- (sleep 1)
- (loop (- i 1)))
- (else
- (error "file didn't show up" ,file))))
- marionette))
+ (make-marionette (list #$vm)))
(define (make-session-for-test)
"Make a session with predefined parameters for a test."
(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.
(test-equal "sshd PID"
- (wait-for-file #$pid-file)
+ (wait-for-file #$pid-file marionette)
(marionette-eval
'(begin
(use-modules (gnu services herd)
(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"
(channel-open-session channel)
(channel-request-exec channel "echo hello > /root/witness")
(and (zero? (channel-get-exit-status channel))
- (wait-for-file "/root/witness"))))))
+ (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.
(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)))))
+ (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
- (gexp->derivation name test)))
+ (gexp->derivation name test))
(define %test-openssh
(system-test
(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))))
HCoop / jackhill / guix / guix.git / blobdiff