;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2022, 2024 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.
;;;
;;; 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)
#:export (%test-openssh
%test-dropbear))
(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."
(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
(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 #$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
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)))))))))
(test-runner-current (system-test-runner #$output))
(test-begin "ssh-daemon")
;; Wait for sshd to be up and running.
(test-assert "service running"
(marionette-eval
'(begin
(use-modules (gnu services herd))
(start-service 'ssh-daemon))
marionette))
;; Check sshd's PID file.
(test-assert "sshd PID"
(let ((pid (marionette-eval
'(begin
(use-modules (gnu services herd)
(srfi srfi-1)
(ice-9 match))
(match (live-service-running
(find (lambda (live)
(memq 'ssh-daemon
(live-service-provision live)))
(current-services)))
((? number? pid)
;; shepherd < 1.0.0
pid)
(('inetd-service _ ...)
#t)
(('process ('version 0 _ ...)
('id pid) _ ...)
pid)))
marionette)))
(if #$pid-file
(= pid (wait-for-file #$pid-file marionette))
pid)))
(test-assert "wait for port 22, IPv4"
(wait-for-tcp-port 22 marionette))
(test-assert "wait for port 22, IPv6"
;; Make sure it's also available as IPv6.
;; See <https://issues.guix.gnu.org/55335>.
(wait-for-tcp-port 22 marionette
#:address
`(make-socket-address
AF_INET6
(inet-pton AF_INET6 "::1")
22)))
;; 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))))))
;; 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.
(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)))))
(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)))
#f ;inetd-style, no PID file
#: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"
;; XXX: Our Dropbear is not built with PAM support.
;; Even when it is, it seems to ignore the PAM
;; 'session' requirements.
#:test-getlogin? #f))))
