;;; 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
| 2017-11-21 | Revert "Add (guix self) and use it when pulling."...This reverts commit 5f93d97005897c2d859f0be1bdff34c88467ec61.
'guix pull' would fail because (guix self) needs 'scheme-files'
from (guix discovery), which was not exported until now.
| Ludovic Courtès |
| 2017-11-21 | hydra: Add jobs for the modular Guix....* build-aux/hydra/guix-modular.scm: New file.
* Makefile.am (EXTRA_DIST): Add it.
| Ludovic Courtès |
| 2017-11-21 | Add (guix self) and use it when pulling....This mitigates <https://bugs.gnu.org/27284>.
* guix/self.scm: New file.
* Makefile.am (MODULES): Add it.
* build-aux/build-self.scm (libgcrypt, zlib, gzip, bzip2, xz)
(false-if-wrong-guile, package-for-current-guile, guile-json)
(guile-ssh, guile-git, guile-bytestructures): Remove.
(build): Rewrite to simply delegate to 'compiled-guix'.
* gnu/packages.scm (%distro-root-directory): Rewrite to try different
directories.
* guix/discovery.scm (guix): Export 'scheme-files'.
* guix/scripts/pull.scm (build-and-install): Split into...
(install-latest): ... this. New procedure. And...
(build-and-install): ... this, which now takes a monadic value argument.
(indirect-root-added): Remove.
(guix-pull): Call 'add-indirect-root'. Call 'build-from-source' and
pass the result to 'build-and-install'.
| Ludovic Courtès |
d)))))
;; 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))))
