[jackhill/guix/guix.git] / gnu / tests / ssh.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu tests ssh)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #: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* (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.

When SFTP? is true, run an SFTP server test."
  (mlet* %store-monad ((os ->   (marionette-operating-system
                                 (simple-operating-system
                                  (dhcp-client-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))
        #~(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 #$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))

            (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)

            (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-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"))))))

            ;; 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)))))

            (test-end)
            (exit (= (test-runner-fail-count (test-runner-current)) 0)))))

    (gexp->derivation name test)))

(define %test-openssh
  (system-test
   (name "openssh")
   (description "Connect to a running OpenSSH daemon.")
   (value (run-ssh-test name
                        ;; Allow root logins with an empty password to
                        ;; simplify testing.
                        (service openssh-service-type
                                 (openssh-configuration
                                  (permit-root-login #t)
                                  (allow-empty-passwords? #t)))
                        "/var/run/sshd.pid"
                        #:sftp? #t))))

(define %test-dropbear
  (system-test
   (name "dropbear")
   (description "Connect to a running Dropbear SSH daemon.")
   (value (run-ssh-test name
                        (service dropbear-service-type
                                 (dropbear-configuration
                                  (root-login? #t)
                                  (allow-empty-passwords? #t)))
                        "/var/run/dropbear.pid"))))
Commit	Line	Data
d5b0c902	1	;;; GNU Guix --- Functional package management for GNU
892d9089	2	;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
cfaf4d11	3	;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
d5b0c902 LC	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	(define-module (gnu tests ssh)
	21	#:use-module (gnu tests)
	22	#:use-module (gnu system)
d5b0c902 LC	23	#:use-module (gnu system vm)
d5b0c902 LC	24	#:use-module (gnu services)
d5b0c902 LC	25	#:use-module (gnu services ssh)
	26	#:use-module (gnu services networking)
	27	#:use-module (gnu packages ssh)
	28	#:use-module (guix gexp)
	29	#:use-module (guix store)
	30	#:use-module (guix monads)
2b436389 LC	31	#:export (%test-openssh
2b436389 LC	32	%test-dropbear))
d5b0c902	33
36f666c6	34	(define* (run-ssh-test name ssh-service pid-file #:key (sftp? #f))
0e598850 LC	35	"Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE.
0e598850 LC	36	SSH-SERVICE must be configured to listen on port 22 and to allow for root and
36f666c6 CL	37	empty-password logins.
	38
	39	When SFTP? is true, run an SFTP server test."
d5b0c902	40	(mlet* %store-monad ((os -> (marionette-operating-system
892d9089 LC	41	(simple-operating-system
	42	(dhcp-client-service)
	43	ssh-service)
d5b0c902 LC	44	#:imported-modules '((gnu services herd)
	45	(guix combinators))))
	46	(command (system-qemu-image/shared-store-script
	47	os #:graphic? #f)))
	48	(define test
	49	(with-imported-modules '((gnu build marionette))
	50	#~(begin
	51	(eval-when (expand load eval)
	52	;; Prepare to use Guile-SSH.
	53	(set! %load-path
	54	(cons (string-append #$guile-ssh "/share/guile/site/"
	55	(effective-version))
	56	%load-path)))
	57
	58	(use-modules (gnu build marionette)
2b436389	59	(srfi srfi-26)
d5b0c902 LC	60	(srfi srfi-64)
	61	(ice-9 match)
	62	(ssh session)
	63	(ssh auth)
36f666c6 CL	64	(ssh channel)
36f666c6 CL	65	(ssh sftp))
d5b0c902 LC	66
	67	(define marionette
	68	;; Enable TCP forwarding of the guest's port 22.
	69	(make-marionette (list #$command "-net"
	70	"user,hostfwd=tcp::2222-:22")))
	71
	72	(define (wait-for-file file)
	73	;; Wait until FILE exists in the guest; 'read' its content and
	74	;; return it.
	75	(marionette-eval
	76	`(let loop ((i 10))
	77	(cond ((file-exists? ,file)
	78	(call-with-input-file ,file read))
	79	((> i 0)
	80	(sleep 1)
	81	(loop (- i 1)))
	82	(else
	83	(error "file didn't show up" ,file))))
	84	marionette))
	85
cfaf4d11 CL	86	(define (make-session-for-test)
	87	"Make a session with predefined parameters for a test."
	88	(make-session #:user "root"
	89	#:port 2222
	90	#:host "localhost"
	91	#:log-verbosity 'protocol))
	92
	93	(define (call-with-connected-session proc)
	94	"Call the one-argument procedure PROC with a freshly created and
	95	connected SSH session object, return the result of the procedure call. The
	96	session is disconnected when the PROC is finished."
	97	(let ((session (make-session-for-test)))
	98	(dynamic-wind
	99	(lambda ()
	100	(let ((result (connect! session)))
	101	(unless (equal? result 'ok)
	102	(error "Could not connect to a server"
	103	session result))))
	104	(lambda () (proc session))
	105	(lambda () (disconnect! session)))))
	106
	107	(define (call-with-connected-session/auth proc)
	108	"Make an authenticated session. We should be able to connect as
	109	root with an empty password."
	110	(call-with-connected-session
	111	(lambda (session)
	112	;; Try the simple authentication methods. Dropbear requires
	113	;; 'none' when there are no passwords, whereas OpenSSH accepts
	114	;; 'password' with an empty password.
	115	(let loop ((methods (list (cut userauth-password! <> "")
	116	(cut userauth-none! <>))))
	117	(match methods
	118	(()
	119	(error "all the authentication methods failed"))
	120	((auth rest ...)
	121	(match (pk 'auth (auth session))
	122	('success
	123	(proc session))
	124	('denied
	125	(loop rest)))))))))
	126
d5b0c902 LC	127	(mkdir #$output)
	128	(chdir #$output)
	129
0e598850	130	(test-begin "ssh-daemon")
d5b0c902 LC	131
	132	;; Wait for sshd to be up and running.
	133	(test-eq "service running"
	134	'running!
	135	(marionette-eval
	136	'(begin
	137	(use-modules (gnu services herd))
	138	(start-service 'ssh-daemon)
	139	'running!)
	140	marionette))
	141
	142	;; Check sshd's PID file.
	143	(test-equal "sshd PID"
0e598850	144	(wait-for-file #$pid-file)
d5b0c902 LC	145	(marionette-eval
	146	'(begin
	147	(use-modules (gnu services herd)
	148	(srfi srfi-1))
	149
	150	(live-service-running
	151	(find (lambda (live)
	152	(memq 'ssh-daemon
	153	(live-service-provision live)))
	154	(current-services))))
	155	marionette))
	156
cfaf4d11	157	;; Connect to the guest over SSH. Make sure we can run a shell
d5b0c902	158	;; command there.
cfaf4d11	159	(test-equal "shell command"
d5b0c902	160	'hello
cfaf4d11 CL	161	(call-with-connected-session/auth
	162	(lambda (session)
	163	;; FIXME: 'get-server-public-key' segfaults.
	164	;; (get-server-public-key session)
	165	(let ((channel (make-channel session)))
	166	(channel-open-session channel)
	167	(channel-request-exec channel "echo hello > /root/witness")
	168	(and (zero? (channel-get-exit-status channel))
	169	(wait-for-file "/root/witness"))))))
d5b0c902	170
36f666c6 CL	171	;; Connect to the guest over SFTP. Make sure we can write and
	172	;; read a file there.
	173	(unless #$sftp?
	174	(test-skip 1))
	175	(test-equal "SFTP file writing and reading"
	176	'hello
	177	(call-with-connected-session/auth
	178	(lambda (session)
	179	(let ((sftp-session (make-sftp-session session))
	180	(witness "/root/sftp-witness"))
	181	(call-with-remote-output-file sftp-session witness
	182	(cut display "hello" <>))
	183	(call-with-remote-input-file sftp-session witness
	184	read)))))
	185
d5b0c902 LC	186	(test-end)
	187	(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
	188
	189	(gexp->derivation name test)))
	190
	191	(define %test-openssh
	192	(system-test
	193	(name "openssh")
	194	(description "Connect to a running OpenSSH daemon.")
0e598850 LC	195	(value (run-ssh-test name
	196	;; Allow root logins with an empty password to
	197	;; simplify testing.
	198	(service openssh-service-type
	199	(openssh-configuration
	200	(permit-root-login #t)
	201	(allow-empty-passwords? #t)))
36f666c6 CL	202	"/var/run/sshd.pid"
36f666c6 CL	203	#:sftp? #t))))
2b436389 LC	204
	205	(define %test-dropbear
	206	(system-test
	207	(name "dropbear")
	208	(description "Connect to a running Dropbear SSH daemon.")
	209	(value (run-ssh-test name
	210	(service dropbear-service-type
	211	(dropbear-configuration
	212	(root-login? #t)
	213	(allow-empty-passwords? #t)))
	214	"/var/run/dropbear.pid"))))