From 9ceeca0880248eee8c2796f5e6ebc172b95277f7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 May 2018 15:04:36 +0200 Subject: system: Remove uses of the 'title' field of . * gnu/system/install.scm (installation-os): Remove uses of the 'title' field of 'file-system'; use 'file-system-label' as appropriate. * gnu/system/vm.scm (system-disk-image, system-qemu-image): Likewise. * gnu/tests.scm (%simple-os): Likewise. * gnu/tests/install.scm (%minimal-os, %minimal-extlinux-os) (%minimal-os-on-vda, %separate-home-os, %separate-store-os) (%raid-root-os, %encrypted-root-os, %btrfs-root-os): Likewise. * gnu/build/shepherd.scm (default-mounts)[tmpfs]: Likewise. * tests/guix-system.sh: Likewise. * tests/system.scm (%root-fs): Likewise. ("operating-system-boot-mapped-devices, implicit dependency"): Likewise. --- gnu/tests/install.scm | 26 ++++++++------------------ 1 file changed, 8 insertions(+), 18 deletions(-) (limited to 'gnu/tests') diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index e3bb1b46af..4764ffffde 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -66,8 +66,7 @@ (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -105,8 +104,7 @@ (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -351,8 +349,7 @@ per %test-installed-os, this test is expensive in terms of CPU and storage.") (target "/dev/vda"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -428,13 +425,11 @@ reboot\n") (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons* (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "ext4")) (file-system (device "none") - (title 'device) (type "tmpfs") (mount-point "/home") (type "tmpfs")) @@ -488,13 +483,11 @@ partition. In particular, home directories must be correctly created (see (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons* (file-system - (device "root-fs") - (title 'label) + (device (file-system-label "root-fs")) (mount-point "/") (type "ext4")) (file-system - (device "store-fs") - (title 'label) + (device (file-system-label "store-fs")) (mount-point "/gnu") (type "ext4")) %base-file-systems)) @@ -574,8 +567,7 @@ where /gnu lives on a separate partition.") (target "/dev/md0") (type raid-device-mapping)))) (file-systems (cons (file-system - (device "root-fs") - (title 'label) + (device (file-system-label "root-fs")) (mount-point "/") (type "ext4") (dependencies mapped-devices)) @@ -658,7 +650,6 @@ by 'mdadm'.") (type luks-device-mapping)))) (file-systems (cons (file-system (device "/dev/mapper/the-root-device") - (title 'device) (mount-point "/") (type "ext4")) %base-file-systems)) @@ -779,8 +770,7 @@ build (current-guix) and then store a couple of full system images.") (target "/dev/vdb"))) (kernel-arguments '("console=ttyS0")) (file-systems (cons (file-system - (device "my-root") - (title 'label) + (device (file-system-label "my-root")) (mount-point "/") (type "btrfs")) %base-file-systems)) -- cgit v1.2.3 From 7a4e2eaab34f7fad6951f312203ac0d9dfa3d44a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 10:01:05 +0200 Subject: marionette: Add 'wait-for-tcp-port'. * gnu/build/marionette.scm (wait-for-tcp-port): New procedure. * gnu/tests/dict.scm (run-dicod-test)["connect inside"]: Use it instead of the inline loop. --- gnu/build/marionette.scm | 27 +++++++++++++++++++++++++++ gnu/tests/dict.scm | 19 ++----------------- 2 files changed, 29 insertions(+), 17 deletions(-) (limited to 'gnu/tests') diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index 173a67cef9..bb018fc9c1 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -26,6 +26,7 @@ make-marionette marionette-eval wait-for-file + wait-for-tcp-port marionette-control marionette-screen-text wait-for-screen-text @@ -187,6 +188,32 @@ FILE has not shown up after TIMEOUT seconds, raise an error." ('failure (error "file didn't show up" file)))) +(define* (wait-for-tcp-port port marionette + #:key (timeout 20)) + "Wait for up to TIMEOUT seconds for PORT to accept connections in +MARIONETTE. Raise an error on failure." + ;; Note: The 'connect' loop has to run within the guest because, when we + ;; forward ports to the host, connecting to the host never raises + ;; ECONNREFUSED. + (match (marionette-eval + `(begin + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (let loop ((i 0)) + (catch 'system-error + (lambda () + (connect sock AF_INET INADDR_LOOPBACK ,port) + 'success) + (lambda args + (if (< i ,timeout) + (begin + (sleep 1) + (loop (+ 1 i))) + 'failure)))))) + marionette) + ('success #t) + ('failure + (error "nobody's listening on port" port)))) + (define (marionette-control command marionette) "Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc) diff --git a/gnu/tests/dict.scm b/gnu/tests/dict.scm index b9c741e3e0..4431e37dc1 100644 --- a/gnu/tests/dict.scm +++ b/gnu/tests/dict.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,22 +96,7 @@ ;; Wait until dicod is actually listening. ;; TODO: Use a PID file instead. (test-assert "connect inside" - (marionette-eval - '(begin - (use-modules (ice-9 rdelim)) - (let ((sock (socket PF_INET SOCK_STREAM 0))) - (let loop ((i 0)) - (pk 'try i) - (catch 'system-error - (lambda () - (connect sock AF_INET INADDR_LOOPBACK 2628)) - (lambda args - (pk 'connection-error args) - (when (< i 20) - (sleep 1) - (loop (+ 1 i)))))) - (read-line sock 'concat))) - marionette)) + (wait-for-tcp-port 2628 marionette)) (test-assert "connect" (let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000))) -- cgit v1.2.3 From 93b83eb31e35aedaafcc40cfbb9a8743e0f6352d Mon Sep 17 00:00:00 2001 From: Rouby Pierre-Antoine Date: Wed, 30 May 2018 11:47:04 +0200 Subject: services: Add hpcguix-web. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/service/web.scm (): New record-type. (%hpcguix-web-accounts): New variable. (%hpcguix-web-activation,hpcguix-web-shepherd-service, hpcguix-web-service-type): New procedures. * gnu/tests/web.scm (run-hpcguix-web-server-test): New procedure. (%hpcguix-web-specs, %hpcguix-web-os, %test-hpcguix-web): New variable. * doc/guix.texi (Web Services): Add 'hpcguix-web'. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 61 +++++++++++++++++++++++++++++++++++++- gnu/services/web.scm | 72 ++++++++++++++++++++++++++++++++++++++++++++- gnu/tests/web.scm | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 212 insertions(+), 3 deletions(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index 09749b15e1..3b5078741d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -47,7 +47,8 @@ Copyright @copyright{} 2017, 2018 Arun Isaac@* Copyright @copyright{} 2017 nee@* Copyright @copyright{} 2018 Rutger Helling@* Copyright @copyright{} 2018 Oleg Pykhalov@* -Copyright @copyright{} 2018 Mike Gerwitz +Copyright @copyright{} 2018 Mike Gerwitz@* +Copyright @copyright{} 2018 Pierre-Antoine Rouby Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -16159,6 +16160,64 @@ A simple setup for cat-avatar-generator can look like this: %base-services)) @end example +@subsubheading Hpcguix-web + +@cindex hpcguix-web +The @uref{hpcguix-web, https://github.com/UMCUGenetics/hpcguix-web/} +program is a customizable web interface to browse Guix packages, +initially designed for users of high-performance computing (HPC) +clusters. + +@defvr {Scheme Variable} hpcguix-web-service-type +The service type for @code{hpcguix-web}. +@end defvr + +@deftp {Data Type} hpcguix-web-configuration +Data type for the hpcguix-web service configuration. + +@table @asis +@item @code{specs} +A gexp (@pxref{G-Expressions}) specifying the hpcguix-web service +configuration. The main items available in this spec are: + +@table @asis +@item @code{title-prefix} (default: @code{"hpcguix | "}) +The page title prefix. + +@item @code{guix-command} (default: @code{"guix"}) +The @command{guix} command. + +@item @code{package-filter-proc} (default: @code{(const #t)}) +A procedure specifying how to filter packages that are displayed. + +@item @code{package-page-extension-proc} (default: @code{(const '())}) +Extension package for @code{hpcguix-web}. + +@item @code{menu} (default: @code{'()}) +Additional entry in page @code{menu}. +@end table + +See the hpcguix-web repository for a +@uref{https://github.com/UMCUGenetics/hpcguix-web/blob/master/hpcweb-configuration.scm, +complete example}. + +@item @code{package} (default: @code{hpcguix-web}) +The hpcguix-web package to use. +@end table +@end deftp + +A typical hpcguix-web service declaration looks like this: + +@example +(service hpcguix-web-service-type + (hpcguix-web-configuration + (specs + #~(define site-config + (hpcweb-configuration + (title-prefix "Guix-HPC - ") + (menu '(("/about" "ABOUT")))))))) +@end example + @node Certificate Services @subsubsection Certificate Services diff --git a/gnu/services/web.scm b/gnu/services/web.scm index b336a8dd30..aae2f3db0d 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2017 Christopher Baines ;;; Copyright © 2017 nee ;;; Copyright © 2017 Clément Lassieur +;;; Copyright © 2018 Pierre-Antoine Rouby ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,11 +26,14 @@ (define-module (gnu services web) #:use-module (gnu services) #:use-module (gnu services shepherd) + #:use-module (gnu system pam) #:use-module (gnu system shadow) #:use-module (gnu packages admin) #:use-module (gnu packages web) #:use-module (gnu packages php) + #:use-module (gnu packages guile) #:use-module (guix records) + #:use-module (guix modules) #:use-module (guix gexp) #:use-module ((guix utils) #:select (version-major)) #:use-module ((guix packages) #:select (package-version)) @@ -155,7 +159,11 @@ php-fpm-service-type nginx-php-location - cat-avatar-generator-service)) + cat-avatar-generator-service + + hpcguix-web-configuration + hpcguix-web-configuration? + hpcguix-web-service-type)) ;;; Commentary: ;;; @@ -893,3 +901,65 @@ a webserver.") (nginx-server-configuration-locations configuration))) (root #~(string-append #$package "/share/web/cat-avatar-generator")))))) + + +(define-record-type* + hpcguix-web-configuration make-hpcguix-web-configuration + hpcguix-web-configuration? + + (package hpcguix-web-package (default hpcguix-web)) ; + + ;; Specs is gexp of hpcguix-web configuration file + (specs hpcguix-web-configuration-specs)) + +(define %hpcguix-web-accounts + (list (user-group + (name "hpcguix-web") + (system? #t)) + (user-account + (name "hpcguix-web") + (group "hpcguix-web") + (system? #t) + (comment "hpcguix-web") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define %hpcguix-web-activation + #~(begin + (use-modules (guix build utils)) + (let ((home-dir "/var/cache/guix/web") + (user (getpwnam "hpcguix-web"))) + (mkdir-p home-dir) + (chown home-dir (passwd:uid user) (passwd:gid user)) + (chmod home-dir #o755)))) + +(define (hpcguix-web-shepherd-service config) + (let ((specs (hpcguix-web-configuration-specs config)) + (hpcguix-web (hpcguix-web-package config))) + (with-imported-modules (source-module-closure + '((gnu build shepherd))) + (shepherd-service + (documentation "hpcguix-web daemon") + (provision '(hpcguix-web)) + (requirement '(networking)) + (start #~(make-forkexec-constructor + (list #$(file-append hpcguix-web "/bin/run") + (string-append "--config=" + #$(scheme-file "hpcguix-web.scm" specs))) + #:user "hpcguix-web" + #:group "hpcguix-web" + #:environment-variables + (list "XDG_CACHE_HOME=/var/cache"))) + (stop #~(make-kill-destructor)))))) + +(define hpcguix-web-service-type + (service-type + (name 'hpcguix-web) + (description "Run the hpcguix-web server.") + (extensions + (list (service-extension account-service-type + (const %hpcguix-web-accounts)) + (service-extension activation-service-type + (const %hpcguix-web-activation)) + (service-extension shepherd-root-service-type + (compose list hpcguix-web-shepherd-service)))))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 1912f8f79d..a6bf6efcfe 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Ludovic Courtès ;;; Copyright © 2017 Christopher Baines ;;; Copyright © 2017 Clément Lassieur +;;; Copyright © 2018 Pierre-Antoine Rouby ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +32,8 @@ #:use-module (guix store) #:export (%test-httpd %test-nginx - %test-php-fpm)) + %test-php-fpm + %test-hpcguix-web)) (define %index.html-contents ;; Contents of the /index.html file. @@ -281,3 +283,81 @@ HTTP-PORT, along with php-fpm." (name "php-fpm") (description "Test PHP-FPM through nginx.") (value (run-php-fpm-test)))) + + +;;; +;;; hpcguix-web +;;; + +(define* (run-hpcguix-web-server-test name test-os) + "Run tests in %HPCGUIX-WEB-OS, which has hpcguix-web running." + (define os + (marionette-operating-system + test-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings '((8080 . 5000))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette) + (web uri) + (web client) + (web response)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin #$name) + + (test-assert "hpcguix-web running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'hpcguix-web) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((pid) (number? pid)))))) + marionette)) + + (test-equal "http-get" + 200 + (begin + (wait-for-tcp-port 5000 marionette) + (let-values (((response text) + (http-get "http://localhost:8080"))) + (response-code response)))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation (string-append name "-test") test)) + +(define %hpcguix-web-specs + ;; Server config gexp. + #~(define site-config + (hpcweb-configuration + (title-prefix "[TEST] HPCGUIX-WEB")))) + +(define %hpcguix-web-os + (simple-operating-system + (dhcp-client-service) + (service hpcguix-web-service-type + (hpcguix-web-configuration + (specs %hpcguix-web-specs))))) + +(define %test-hpcguix-web + (system-test + (name "hpcguix-web") + (description "Connect to a running hpcguix-web server.") + (value (run-hpcguix-web-server-test name %hpcguix-web-os)))) -- cgit v1.2.3 From ff913cf514b2a1d6d8400b24c675125387049b41 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 18:23:24 +0200 Subject: tests: ssh: Use 'with-extensions'. * gnu/tests/ssh.scm (run-ssh-test)[test]: Wrap body in 'with-extensions'. Remove %load-path manipulation code. --- gnu/tests/ssh.scm | 290 ++++++++++++++++++++++++++---------------------------- 1 file changed, 142 insertions(+), 148 deletions(-) (limited to 'gnu/tests') diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm index 6abc6c2501..9247a43e6d 100644 --- a/gnu/tests/ssh.scm +++ b/gnu/tests/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2017 Clément Lassieur ;;; Copyright © 2017 Marius Bakke ;;; @@ -49,156 +49,150 @@ When SFTP? is true, run an SFTP server test." (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 #$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 + (with-extensions (list guile-ssh) + #~(begin + (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 #$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 + (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) - (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" marionette)))))) - - ;; 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) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + (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) + (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" marionette)))))) + + ;; 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) + (exit (= (test-runner-fail-count (test-runner-current)) 0)))))) (gexp->derivation name test)) -- cgit v1.2.3