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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.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 base)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system shadow)
  #:use-module (gnu system nss)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services dbus)
  #:use-module (gnu services avahi)
  #:use-module (gnu services mcron)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services networking)
  #:use-module (gnu packages imagemagick)
  #:use-module (gnu packages ocr)
  #:use-module (gnu packages package-management)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix packages)
  #:use-module (srfi srfi-1)
  #:export (run-basic-test
            %test-basic-os
            %test-mcron
            %test-nss-mdns))

(define %simple-os
  (simple-operating-system))

\f
(define* (run-basic-test os command #:optional (name "basic")
                         #:key initialization)
  "Return a derivation called NAME that tests basic features of the OS started
using COMMAND, a gexp that evaluates to a list of strings.  Compare some
properties of running system to what's declared in OS, an <operating-system>.

When INITIALIZATION is true, it must be a one-argument procedure that is
passed a gexp denoting the marionette, and it must return gexp that is
inserted before the first test.  This is used to introduce an extra
initialization step, such as entering a LUKS passphrase."
  (define special-files
    (service-value
     (fold-services (operating-system-services os)
                    #:target-type special-files-service-type)))

  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build syscalls))
      #~(begin
          (use-modules (gnu build marionette)
                       (guix build syscalls)
                       (srfi srfi-1)
                       (srfi srfi-26)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette #$command))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "basic")

          #$(and initialization
                 (initialization #~marionette))

          (test-assert "uname"
            (match (marionette-eval '(uname) marionette)
              (#("Linux" host-name version _ architecture)
               (and (string=? host-name
                              #$(operating-system-host-name os))
                    (string-prefix? #$(package-version
                                       (operating-system-kernel os))
                                    version)
                    (string-prefix? architecture %host-type)))))

          (test-assert "shell and user commands"
            ;; Is everything in $PATH?
            (zero? (marionette-eval '(system "
. /etc/profile
set -e -x
guix --version
ls --version
grep --version
info --version")
                                    marionette)))

          (test-equal "special files"
            '#$special-files
            (marionette-eval
             '(begin
                (use-modules (ice-9 match))

                (map (match-lambda
                       ((file target)
                        (list file (readlink file))))
                     '#$special-files))
             marionette))

          (test-assert "accounts"
            (let ((users (marionette-eval '(begin
                                             (use-modules (ice-9 match))
                                             (let loop ((result '()))
                                               (match (getpw)
                                                 (#f (reverse result))
                                                 (x  (loop (cons x result))))))
                                          marionette)))
              (lset= string=?
                     (map passwd:name users)
                     (list
                      #$@(map user-account-name
                              (operating-system-user-accounts os))))))

          (test-assert "shepherd services"
            (let ((services (marionette-eval
                             '(begin
                                (use-modules (gnu services herd))

                                (map (compose car live-service-provision)
                                     (current-services)))
                             marionette)))
              (lset= eq?
                     (pk 'services services)
                     '(root #$@(operating-system-shepherd-service-names os)))))

          (test-assert "homes"
            (let ((homes
                   '#$(map user-account-home-directory
                           (filter user-account-create-home-directory?
                                   (operating-system-user-accounts os)))))
              (marionette-eval
               `(begin
                  (use-modules (gnu services herd) (srfi srfi-1))

                  ;; Home directories are supposed to exist once 'user-homes'
                  ;; has been started.
                  (start-service 'user-homes)

                  (every (lambda (home)
                           (and (file-exists? home)
                                (file-is-directory? home)))
                         ',homes))
               marionette)))

          (test-assert "skeletons in home directories"
            (let ((users+homes
                   '#$(filter-map (lambda (account)
                                    (and (user-account-create-home-directory?
                                          account)
                                         (not (user-account-system? account))
                                         (list (user-account-name account)
                                               (user-account-home-directory
                                                account))))
                                  (operating-system-user-accounts os))))
              (marionette-eval
               `(begin
                  (use-modules (srfi srfi-1) (ice-9 ftw)
                               (ice-9 match))

                  (every (match-lambda
                           ((user home)
                            ;; Make sure HOME has all the skeletons...
                            (and (null? (lset-difference string=?
                                                         (scandir "/etc/skel/")
                                                         (scandir home)))

                                 ;; ... and that everything is user-owned.
                                 (let* ((pw  (getpwnam user))
                                        (uid (passwd:uid pw))
                                        (gid (passwd:gid pw))
                                        (st  (lstat home)))
                                   (define (user-owned? file)
                                     (= uid (stat:uid (lstat file))))

                                   (and (= uid (stat:uid st))
                                        (eq? 'directory (stat:type st))
                                        (every user-owned?
                                               (find-files home
                                                           #:directories? #t)))))))
                         ',users+homes))
               marionette)))

          (test-equal "permissions on /root"
            #o700
            (let ((root-home #$(any (lambda (account)
                                      (and (zero? (user-account-uid account))
                                           (user-account-home-directory
                                            account)))
                                    (operating-system-user-accounts os))))
              (stat:perms (marionette-eval `(stat ,root-home) marionette))))

          (test-equal "no extra home directories"
            '()

            ;; Make sure the home directories that are not supposed to be
            ;; created are indeed not created.
            (let ((nonexistent
                   '#$(filter-map (lambda (user)
                                    (and (not
                                          (user-account-create-home-directory?
                                           user))
                                         (user-account-home-directory user)))
                                  (operating-system-user-accounts os))))
              (marionette-eval
               `(begin
                  (use-modules (srfi srfi-1))

                  ;; Note: Do not flag "/var/empty".
                  (filter file-exists?
                          ',(remove (cut string-prefix? "/var/" <>)
                                    nonexistent)))
               marionette)))

          (test-equal "login on tty1"
            "root\n"
            (begin
              (marionette-control "sendkey ctrl-alt-f1" marionette)
              ;; Wait for the 'term-tty1' service to be running (using
              ;; 'start-service' is the simplest and most reliable way to do
              ;; that.)
              (marionette-eval
               '(begin
                  (use-modules (gnu services herd))
                  (start-service 'term-tty1))
               marionette)

              ;; Now we can type.
              (marionette-type "root\n\nid -un > logged-in\n" marionette)

              ;; It can take a while before the shell commands are executed.
              (marionette-eval '(use-modules (rnrs io ports)) marionette)
              (marionette-eval
               '(let loop ((i 0))
                  (catch 'system-error
                    (lambda ()
                      (call-with-input-file "/root/logged-in"
                        get-string-all))
                    (lambda args
                      (if (and (< i 15) (= ENOENT (system-error-errno args)))
                          (begin
                            (sleep 1)
                            (loop (+ i 1)))
                          (apply throw args)))))
               marionette)))

          ;; There should be one utmpx entry for the user logged in on tty1.
          (test-equal "utmpx entry"
            '(("root" "tty1" #f))
            (marionette-eval
             '(begin
                (use-modules (guix build syscalls)
                             (srfi srfi-1))

                (filter-map (lambda (entry)
                              (and (equal? (login-type USER_PROCESS)
                                           (utmpx-login-type entry))
                                   (list (utmpx-user entry) (utmpx-line entry)
                                         (utmpx-host entry))))
                            (utmpx-entries)))
             marionette))

          ;; Likewise for /var/log/wtmp (used by 'last').
          (test-assert "wtmp entry"
            (match (marionette-eval
                    '(begin
                       (use-modules (guix build syscalls)
                                    (srfi srfi-1))

                       (define (entry->list entry)
                         (list (utmpx-user entry) (utmpx-line entry)
                               (utmpx-host entry) (utmpx-login-type entry)))

                       (call-with-input-file "/var/log/wtmp"
                         (lambda (port)
                           (let loop ((result '()))
                             (if (eof-object? (peek-char port))
                                 (map entry->list (reverse result))
                                 (loop (cons (read-utmpx port) result)))))))
                    marionette)
              (((users lines hosts types) ..1)
               (every (lambda (type)
                        (eqv? type (login-type LOGIN_PROCESS)))
                      types))))

          (test-assert "host name resolution"
            (match (marionette-eval
                    '(begin
                       ;; Wait for nscd or our requests go through it.
                       (use-modules (gnu services herd))
                       (start-service 'nscd)

                       (list (getaddrinfo "localhost")
                             (getaddrinfo #$(operating-system-host-name os))))
                    marionette)
              ((((? vector?) ..1) ((? vector?) ..1))
               #t)
              (x
               (pk 'failure x #f))))

          (test-equal "host not found"
            #f
            (marionette-eval
             '(false-if-exception (getaddrinfo "does-not-exist"))
             marionette))

          (test-equal "locale"
            "en_US.utf8"
            (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8")))
                                (setlocale LC_ALL before))
                             marionette))

          (test-eq "/run/current-system is a GC root"
            'success!
            (marionette-eval '(begin
                                ;; Make sure the (guix …) modules are found.
                                ;;
                                ;; XXX: Currently shepherd and marionette run
                                ;; on Guile 2.0 whereas Guix is on 2.2.  Yet
                                ;; we should be able to load the 2.0 Scheme
                                ;; files since it's pure Scheme.
                                (add-to-load-path
                                 #+(file-append guix "/share/guile/site/2.2"))

                                (use-modules (srfi srfi-34) (guix store))

                                (let ((system (readlink "/run/current-system")))
                                  (guard (c ((nix-protocol-error? c)
                                             (and (file-exists? system)
                                                  'success!)))
                                    (with-store store
                                      (delete-paths store (list system))
                                      #f))))
                             marionette))

          ;; This symlink is currently unused, but better have it point to the
          ;; right place.  See
          ;; <https://lists.gnu.org/archive/html/guix-devel/2016-08/msg01641.html>.
          (test-equal "/var/guix/gcroots/profiles is a valid symlink"
            "/var/guix/profiles"
            (marionette-eval '(readlink "/var/guix/gcroots/profiles")
                             marionette))


          (test-assert "screendump"
            (begin
              (marionette-control (string-append "screendump " #$output
                                                 "/tty1.ppm")
                                  marionette)
              (file-exists? "tty1.ppm")))

          (test-assert "screen text"
            (let ((text (marionette-screen-text marionette
                                                #:ocrad
                                                #$(file-append ocrad
                                                               "/bin/ocrad"))))
              ;; Check whether the welcome message and shell prompt are
              ;; displayed.  Note: OCR confuses "y" and "V" for instance, so
              ;; we cannot reliably match the whole text.
              (and (string-contains text "This is the GNU")
                   (string-contains text
                                    (string-append
                                     "root@"
                                     #$(operating-system-host-name os))))))

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

  (gexp->derivation name test))

(define %test-basic-os
  (system-test
   (name "basic")
   (description
    "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
functionality tests.")
   (value
    (let* ((os  (marionette-operating-system
                 %simple-os
                 #:imported-modules '((gnu services herd)
                                      (guix combinators))))
           (vm  (virtual-machine os)))
      ;; XXX: Add call to 'virtualized-operating-system' to get the exact same
      ;; set of services as the OS produced by
      ;; 'system-qemu-image/shared-store-script'.
      (run-basic-test (virtualized-operating-system os '())
                      #~(list #$vm))))))

\f
;;;
;;; Mcron.
;;;

(define %mcron-os
  ;; System with an mcron service, with one mcron job for "root" and one mcron
  ;; job for an unprivileged user (note: #:user is an 'mcron2' thing.)
  (let ((job1 #~(job next-second-from
                     (lambda ()
                       (call-with-output-file "witness"
                         (lambda (port)
                           (display (list (getuid) (getgid)) port))))))
        (job2 #~(job next-second-from
                     (lambda ()
                       (call-with-output-file "witness"
                         (lambda (port)
                           (display (list (getuid) (getgid)) port))))
                     #:user "alice"))
        (job3 #~(job next-second-from             ;to test $PATH
                     "touch witness-touch")))
    (simple-operating-system
     (mcron-service (list job1 job2 job3)))))

(define (run-mcron-test name)
  (define os
    (marionette-operating-system
     %mcron-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "mcron")

          (test-eq "service running"
            'running!
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'mcron)
                'running!)
             marionette))

          ;; Make sure root's mcron job runs, has its cwd set to "/root", and
          ;; runs with the right UID/GID.
          (test-equal "root's job"
            '(0 0)
            (wait-for-file "/root/witness" marionette))

          ;; Likewise for Alice's job.  We cannot know what its GID is since
          ;; it's chosen by 'groupadd', but it's strictly positive.
          (test-assert "alice's job"
            (match (wait-for-file "/home/alice/witness" marionette)
              ((1000 gid)
               (>= gid 100))))

          ;; Last, the job that uses a command; allows us to test whether
          ;; $PATH is sane.  (Note that 'marionette-eval' stringifies objects
          ;; that don't have a read syntax, hence the string.)
          (test-equal "root's job with command"
            "#<eof>"
            (wait-for-file "/root/witness-touch" marionette))

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

  (gexp->derivation name test))

(define %test-mcron
  (system-test
   (name "mcron")
   (description "Make sure the mcron service works as advertised.")
   (value (run-mcron-test name))))

\f
;;;
;;; Avahi and NSS-mDNS.
;;;

(define %avahi-os
  (operating-system
    (inherit %simple-os)
    (name-service-switch %mdns-host-lookup-nss)
    (services (cons* (avahi-service #:debug? #t)
                     (dbus-service)
                     (dhcp-client-service)        ;needed for multicast

                     ;; Enable heavyweight debugging output.
                     (modify-services (operating-system-user-services
                                       %simple-os)
                       (nscd-service-type config
                                          => (nscd-configuration
                                              (inherit config)
                                              (debug-level 3)
                                              (log-file "/dev/console")))
                       (syslog-service-type config
                                            =>
                                            (syslog-configuration
                                             (inherit config)
                                             (config-file
                                              (plain-file
                                               "syslog.conf"
                                               "*.* /dev/console\n")))))))))

(define (run-nss-mdns-test)
  ;; Test resolution of '.local' names via libc.  Start the marionette service
  ;; *after* nscd.  Failing to do that, libc will try to connect to nscd,
  ;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc),
  ;; leading to '.local' resolution failures.
  (define os
    (marionette-operating-system
     %avahi-os
     #:requirements '(nscd)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define mdns-host-name
    (string-append (operating-system-host-name os)
                   ".local"))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-1)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (mkdir #$output)
          (chdir #$output)

          (test-begin "avahi")

          (test-assert "wait for services"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))

                (start-service 'nscd)

                ;; XXX: Work around a race condition in nscd: nscd creates its
                ;; PID file before it is listening on its socket.
                (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
                  (let try ()
                    (catch 'system-error
                      (lambda ()
                        (connect sock AF_UNIX "/var/run/nscd/socket")
                        (close-port sock)
                        (format #t "nscd is ready~%"))
                      (lambda args
                        (format #t "waiting for nscd...~%")
                        (usleep 500000)
                        (try)))))

                ;; Wait for the other useful things.
                (start-service 'avahi-daemon)
                (start-service 'networking)

                #t)
             marionette))

          (test-equal "avahi-resolve-host-name"
            0
            (marionette-eval
             '(system*
               "/run/current-system/profile/bin/avahi-resolve-host-name"
               "-v" #$mdns-host-name)
             marionette))

          (test-equal "avahi-browse"
            0
            (marionette-eval
             '(system* "avahi-browse" "-avt")
             marionette))

          (test-assert "getaddrinfo .local"
            ;; Wait for the 'avahi-daemon' service and perform a resolution.
            (match (marionette-eval
                    '(getaddrinfo #$mdns-host-name)
                    marionette)
              (((? vector? addrinfos) ..1)
               (pk 'getaddrinfo addrinfos)
               (and (any (lambda (ai)
                           (= AF_INET (addrinfo:fam ai)))
                         addrinfos)
                    (any (lambda (ai)
                           (= AF_INET6 (addrinfo:fam ai)))
                         addrinfos)))))

          (test-assert "gethostbyname .local"
            (match (pk 'gethostbyname
                       (marionette-eval '(gethostbyname #$mdns-host-name)
                                        marionette))
              ((? vector? result)
               (and (string=? (hostent:name result) #$mdns-host-name)
                    (= (hostent:addrtype result) AF_INET)))))


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

  (gexp->derivation "nss-mdns" test))

(define %test-nss-mdns
  (system-test
   (name "nss-mdns")
   (description
    "Test Avahi's multicast-DNS implementation, and in particular, test its
glibc name service switch (NSS) module.")
   (value (run-nss-mdns-test))))
Commit	Line	Data
e9f693d0	1	;;; GNU Guix --- Functional package management for GNU
caa78166	2	;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
e9f693d0 LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (gnu tests base)
	20	#:use-module (gnu tests)
	21	#:use-module (gnu system)
e9f693d0	22	#:use-module (gnu system shadow)
d2fa61bc	23	#:use-module (gnu system nss)
e9f693d0 LC	24	#:use-module (gnu system vm)
e9f693d0 LC	25	#:use-module (gnu services)
d2fa61bc LC	26	#:use-module (gnu services base)
	27	#:use-module (gnu services dbus)
	28	#:use-module (gnu services avahi)
c311089b	29	#:use-module (gnu services mcron)
e9f693d0	30	#:use-module (gnu services shepherd)
d2fa61bc	31	#:use-module (gnu services networking)
fe933833 LC	32	#:use-module (gnu packages imagemagick)
fe933833 LC	33	#:use-module (gnu packages ocr)
e2f9832f	34	#:use-module (gnu packages package-management)
e9f693d0 LC	35	#:use-module (guix gexp)
e9f693d0 LC	36	#:use-module (guix store)
e9f693d0 LC	37	#:use-module (guix packages)
e9f693d0 LC	38	#:use-module (srfi srfi-1)
e3de272a	39	#:export (run-basic-test
c311089b	40	%test-basic-os
d2fa61bc LC	41	%test-mcron
d2fa61bc LC	42	%test-nss-mdns))
e9f693d0 LC	43
e9f693d0 LC	44	(define %simple-os
892d9089	45	(simple-operating-system))
e9f693d0 LC	46
e9f693d0 LC	47	\f
f7f292d3 LC	48	(define* (run-basic-test os command #:optional (name "basic")
f7f292d3 LC	49	#:key initialization)
e3de272a LC	50	"Return a derivation called NAME that tests basic features of the OS started
e3de272a LC	51	using COMMAND, a gexp that evaluates to a list of strings. Compare some
f7f292d3 LC	52	properties of running system to what's declared in OS, an <operating-system>.
	53
	54	When INITIALIZATION is true, it must be a one-argument procedure that is
	55	passed a gexp denoting the marionette, and it must return gexp that is
	56	inserted before the first test. This is used to introduce an extra
	57	initialization step, such as entering a LUKS passphrase."
387e1754	58	(define special-files
efe7d19a	59	(service-value
387e1754 LC	60	(fold-services (operating-system-services os)
	61	#:target-type special-files-service-type)))
	62
e3de272a	63	(define test
caa78166 LC	64	(with-imported-modules '((gnu build marionette)
caa78166 LC	65	(guix build syscalls))
4ee96a79 LC	66	#~(begin
4ee96a79 LC	67	(use-modules (gnu build marionette)
caa78166	68	(guix build syscalls)
4ee96a79 LC	69	(srfi srfi-1)
	70	(srfi srfi-26)
	71	(srfi srfi-64)
	72	(ice-9 match))
	73
	74	(define marionette
	75	(make-marionette #$command))
	76
	77	(mkdir #$output)
	78	(chdir #$output)
	79
	80	(test-begin "basic")
	81
f7f292d3 LC	82	#$(and initialization
	83	(initialization #~marionette))
	84
4ee96a79 LC	85	(test-assert "uname"
	86	(match (marionette-eval '(uname) marionette)
	87	(#("Linux" host-name version _ architecture)
	88	(and (string=? host-name
	89	#$(operating-system-host-name os))
	90	(string-prefix? #$(package-version
	91	(operating-system-kernel os))
	92	version)
	93	(string-prefix? architecture %host-type)))))
	94
	95	(test-assert "shell and user commands"
	96	;; Is everything in $PATH?
	97	(zero? (marionette-eval '(system "
e3de272a LC	98	. /etc/profile
	99	set -e -x
	100	guix --version
	101	ls --version
	102	grep --version
	103	info --version")
4ee96a79 LC	104	marionette)))
4ee96a79 LC	105
387e1754 LC	106	(test-equal "special files"
	107	'#$special-files
	108	(marionette-eval
	109	'(begin
	110	(use-modules (ice-9 match))
	111
	112	(map (match-lambda
	113	((file target)
	114	(list file (readlink file))))
	115	'#$special-files))
	116	marionette))
	117
4ee96a79 LC	118	(test-assert "accounts"
	119	(let ((users (marionette-eval '(begin
	120	(use-modules (ice-9 match))
	121	(let loop ((result '()))
	122	(match (getpw)
	123	(#f (reverse result))
	124	(x (loop (cons x result))))))
	125	marionette)))
	126	(lset= string=?
	127	(map passwd:name users)
	128	(list
	129	#$@(map user-account-name
	130	(operating-system-user-accounts os))))))
	131
	132	(test-assert "shepherd services"
183605c8 LC	133	(let ((services (marionette-eval
	134	'(begin
	135	(use-modules (gnu services herd))
	136
	137	(map (compose car live-service-provision)
	138	(current-services)))
	139	marionette)))
4ee96a79 LC	140	(lset= eq?
	141	(pk 'services services)
	142	'(root #$@(operating-system-shepherd-service-names os)))))
	143
ae763b5b LC	144	(test-assert "homes"
	145	(let ((homes
	146	'#$(map user-account-home-directory
	147	(filter user-account-create-home-directory?
	148	(operating-system-user-accounts os)))))
	149	(marionette-eval
	150	`(begin
	151	(use-modules (gnu services herd) (srfi srfi-1))
	152
	153	;; Home directories are supposed to exist once 'user-homes'
	154	;; has been started.
	155	(start-service 'user-homes)
	156
	157	(every (lambda (home)
	158	(and (file-exists? home)
	159	(file-is-directory? home)))
	160	',homes))
	161	marionette)))
	162
	163	(test-assert "skeletons in home directories"
cf98d342	164	(let ((users+homes
ae763b5b LC	165	'#$(filter-map (lambda (account)
	166	(and (user-account-create-home-directory?
	167	account)
	168	(not (user-account-system? account))
cf98d342 LC	169	(list (user-account-name account)
	170	(user-account-home-directory
	171	account))))
ae763b5b LC	172	(operating-system-user-accounts os))))
	173	(marionette-eval
	174	`(begin
cf98d342 LC	175	(use-modules (srfi srfi-1) (ice-9 ftw)
	176	(ice-9 match))
	177
	178	(every (match-lambda
	179	((user home)
	180	;; Make sure HOME has all the skeletons...
	181	(and (null? (lset-difference string=?
	182	(scandir "/etc/skel/")
	183	(scandir home)))
	184
	185	;; ... and that everything is user-owned.
	186	(let* ((pw (getpwnam user))
	187	(uid (passwd:uid pw))
	188	(gid (passwd:gid pw))
	189	(st (lstat home)))
	190	(define (user-owned? file)
	191	(= uid (stat:uid (lstat file))))
	192
	193	(and (= uid (stat:uid st))
	194	(eq? 'directory (stat:type st))
	195	(every user-owned?
	196	(find-files home
	197	#:directories? #t)))))))
	198	',users+homes))
ae763b5b LC	199	marionette)))
ae763b5b LC	200
41db5a75 LC	201	(test-equal "permissions on /root"
	202	#o700
	203	(let ((root-home #$(any (lambda (account)
	204	(and (zero? (user-account-uid account))
	205	(user-account-home-directory
	206	account)))
	207	(operating-system-user-accounts os))))
	208	(stat:perms (marionette-eval `(stat ,root-home) marionette))))
	209
41f76ae0 LC	210	(test-equal "no extra home directories"
	211	'()
	212
	213	;; Make sure the home directories that are not supposed to be
	214	;; created are indeed not created.
	215	(let ((nonexistent
	216	'#$(filter-map (lambda (user)
	217	(and (not
	218	(user-account-create-home-directory?
	219	user))
	220	(user-account-home-directory user)))
	221	(operating-system-user-accounts os))))
	222	(marionette-eval
	223	`(begin
	224	(use-modules (srfi srfi-1))
	225
	226	;; Note: Do not flag "/var/empty".
	227	(filter file-exists?
	228	',(remove (cut string-prefix? "/var/" <>)
	229	nonexistent)))
	230	marionette)))
	231
4ee96a79 LC	232	(test-equal "login on tty1"
	233	"root\n"
	234	(begin
	235	(marionette-control "sendkey ctrl-alt-f1" marionette)
	236	;; Wait for the 'term-tty1' service to be running (using
	237	;; 'start-service' is the simplest and most reliable way to do
	238	;; that.)
	239	(marionette-eval
	240	'(begin
	241	(use-modules (gnu services herd))
	242	(start-service 'term-tty1))
	243	marionette)
	244
	245	;; Now we can type.
	246	(marionette-type "root\n\nid -un > logged-in\n" marionette)
	247
	248	;; It can take a while before the shell commands are executed.
4ee96a79	249	(marionette-eval '(use-modules (rnrs io ports)) marionette)
056d0b40 LC	250	(marionette-eval
	251	'(let loop ((i 0))
	252	(catch 'system-error
	253	(lambda ()
	254	(call-with-input-file "/root/logged-in"
	255	get-string-all))
	256	(lambda args
	257	(if (and (< i 15) (= ENOENT (system-error-errno args)))
	258	(begin
	259	(sleep 1)
	260	(loop (+ i 1)))
	261	(apply throw args)))))
	262	marionette)))
4ee96a79	263
caa78166 LC	264	;; There should be one utmpx entry for the user logged in on tty1.
	265	(test-equal "utmpx entry"
	266	'(("root" "tty1" #f))
	267	(marionette-eval
	268	'(begin
	269	(use-modules (guix build syscalls)
	270	(srfi srfi-1))
	271
	272	(filter-map (lambda (entry)
	273	(and (equal? (login-type USER_PROCESS)
	274	(utmpx-login-type entry))
	275	(list (utmpx-user entry) (utmpx-line entry)
	276	(utmpx-host entry))))
	277	(utmpx-entries)))
	278	marionette))
	279
2986995b LC	280	;; Likewise for /var/log/wtmp (used by 'last').
	281	(test-assert "wtmp entry"
	282	(match (marionette-eval
	283	'(begin
	284	(use-modules (guix build syscalls)
	285	(srfi srfi-1))
	286
	287	(define (entry->list entry)
	288	(list (utmpx-user entry) (utmpx-line entry)
	289	(utmpx-host entry) (utmpx-login-type entry)))
	290
	291	(call-with-input-file "/var/log/wtmp"
	292	(lambda (port)
	293	(let loop ((result '()))
	294	(if (eof-object? (peek-char port))
	295	(map entry->list (reverse result))
	296	(loop (cons (read-utmpx port) result)))))))
	297	marionette)
	298	(((users lines hosts types) ..1)
	299	(every (lambda (type)
	300	(eqv? type (login-type LOGIN_PROCESS)))
	301	types))))
	302
4ee96a79 LC	303	(test-assert "host name resolution"
	304	(match (marionette-eval
	305	'(begin
	306	;; Wait for nscd or our requests go through it.
	307	(use-modules (gnu services herd))
	308	(start-service 'nscd)
	309
	310	(list (getaddrinfo "localhost")
	311	(getaddrinfo #$(operating-system-host-name os))))
	312	marionette)
	313	((((? vector?) ..1) ((? vector?) ..1))
	314	#t)
	315	(x
	316	(pk 'failure x #f))))
	317
	318	(test-equal "host not found"
	319	#f
e3de272a	320	(marionette-eval
4ee96a79 LC	321	'(false-if-exception (getaddrinfo "does-not-exist"))
	322	marionette))
	323
ab3a6450 LC	324	(test-equal "locale"
ab3a6450 LC	325	"en_US.utf8"
cc73339b LC	326	(marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8")))
cc73339b LC	327	(setlocale LC_ALL before))
ab3a6450 LC	328	marionette))
ab3a6450 LC	329
d5094c81 LC	330	(test-eq "/run/current-system is a GC root"
d5094c81 LC	331	'success!
40d28609 LC	332	(marionette-eval '(begin
40d28609 LC	333	;; Make sure the (guix …) modules are found.
e2f9832f LC	334	;;
	335	;; XXX: Currently shepherd and marionette run
	336	;; on Guile 2.0 whereas Guix is on 2.2. Yet
	337	;; we should be able to load the 2.0 Scheme
	338	;; files since it's pure Scheme.
	339	(add-to-load-path
	340	#+(file-append guix "/share/guile/site/2.2"))
40d28609 LC	341
	342	(use-modules (srfi srfi-34) (guix store))
	343
	344	(let ((system (readlink "/run/current-system")))
	345	(guard (c ((nix-protocol-error? c)
d5094c81 LC	346	(and (file-exists? system)
d5094c81 LC	347	'success!)))
40d28609 LC	348	(with-store store
	349	(delete-paths store (list system))
	350	#f))))
	351	marionette))
	352
334bda9a LC	353	;; This symlink is currently unused, but better have it point to the
	354	;; right place. See
	355	;; <https://lists.gnu.org/archive/html/guix-devel/2016-08/msg01641.html>.
	356	(test-equal "/var/guix/gcroots/profiles is a valid symlink"
	357	"/var/guix/profiles"
	358	(marionette-eval '(readlink "/var/guix/gcroots/profiles")
	359	marionette))
	360
	361
4ee96a79 LC	362	(test-assert "screendump"
	363	(begin
	364	(marionette-control (string-append "screendump " #$output
	365	"/tty1.ppm")
	366	marionette)
	367	(file-exists? "tty1.ppm")))
	368
fe933833 LC	369	(test-assert "screen text"
	370	(let ((text (marionette-screen-text marionette
	371	#:ocrad
	372	#$(file-append ocrad
	373	"/bin/ocrad"))))
	374	;; Check whether the welcome message and shell prompt are
	375	;; displayed. Note: OCR confuses "y" and "V" for instance, so
	376	;; we cannot reliably match the whole text.
	377	(and (string-contains text "This is the GNU")
	378	(string-contains text
	379	(string-append
	380	"root@"
	381	#$(operating-system-host-name os))))))
	382
4ee96a79 LC	383	(test-end)
	384	(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
	385
	386	(gexp->derivation name test))
e3de272a	387
e9f693d0	388	(define %test-basic-os
98b65b5f LC	389	(system-test
	390	(name "basic")
	391	(description
125af57e	392	"Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
98b65b5f LC	393	functionality tests.")
98b65b5f LC	394	(value
8b113790 LC	395	(let* ((os (marionette-operating-system
	396	%simple-os
	397	#:imported-modules '((gnu services herd)
	398	(guix combinators))))
	399	(vm (virtual-machine os)))
98b65b5f LC	400	;; XXX: Add call to 'virtualized-operating-system' to get the exact same
	401	;; set of services as the OS produced by
	402	;; 'system-qemu-image/shared-store-script'.
	403	(run-basic-test (virtualized-operating-system os '())
8b113790	404	#~(list #$vm))))))
c311089b LC	405
	406	\f
	407	;;;
	408	;;; Mcron.
	409	;;;
	410
	411	(define %mcron-os
	412	;; System with an mcron service, with one mcron job for "root" and one mcron
	413	;; job for an unprivileged user (note: #:user is an 'mcron2' thing.)
	414	(let ((job1 #~(job next-second-from
	415	(lambda ()
	416	(call-with-output-file "witness"
	417	(lambda (port)
	418	(display (list (getuid) (getgid)) port))))))
	419	(job2 #~(job next-second-from
	420	(lambda ()
	421	(call-with-output-file "witness"
	422	(lambda (port)
	423	(display (list (getuid) (getgid)) port))))
	424	#:user "alice"))
	425	(job3 #~(job next-second-from ;to test $PATH
	426	"touch witness-touch")))
892d9089 LC	427	(simple-operating-system
892d9089 LC	428	(mcron-service (list job1 job2 job3)))))
c311089b LC	429
c311089b LC	430	(define (run-mcron-test name)
8b113790 LC	431	(define os
	432	(marionette-operating-system
	433	%mcron-os
	434	#:imported-modules '((gnu services herd)
	435	(guix combinators))))
	436
	437	(define test
	438	(with-imported-modules '((gnu build marionette))
	439	#~(begin
	440	(use-modules (gnu build marionette)
	441	(srfi srfi-64)
	442	(ice-9 match))
	443
	444	(define marionette
	445	(make-marionette (list #$(virtual-machine os))))
	446
	447	(mkdir #$output)
	448	(chdir #$output)
	449
	450	(test-begin "mcron")
	451
	452	(test-eq "service running"
	453	'running!
	454	(marionette-eval
	455	'(begin
	456	(use-modules (gnu services herd))
	457	(start-service 'mcron)
	458	'running!)
	459	marionette))
	460
	461	;; Make sure root's mcron job runs, has its cwd set to "/root", and
	462	;; runs with the right UID/GID.
	463	(test-equal "root's job"
	464	'(0 0)
	465	(wait-for-file "/root/witness" marionette))
	466
	467	;; Likewise for Alice's job. We cannot know what its GID is since
	468	;; it's chosen by 'groupadd', but it's strictly positive.
	469	(test-assert "alice's job"
	470	(match (wait-for-file "/home/alice/witness" marionette)
	471	((1000 gid)
	472	(>= gid 100))))
	473
	474	;; Last, the job that uses a command; allows us to test whether
	475	;; $PATH is sane. (Note that 'marionette-eval' stringifies objects
	476	;; that don't have a read syntax, hence the string.)
	477	(test-equal "root's job with command"
	478	"#<eof>"
	479	(wait-for-file "/root/witness-touch" marionette))
	480
	481	(test-end)
	482	(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
	483
	484	(gexp->derivation name test))
c311089b LC	485
	486	(define %test-mcron
	487	(system-test
	488	(name "mcron")
	489	(description "Make sure the mcron service works as advertised.")
	490	(value (run-mcron-test name))))
d2fa61bc LC	491
	492	\f
	493	;;;
	494	;;; Avahi and NSS-mDNS.
	495	;;;
	496
	497	(define %avahi-os
	498	(operating-system
	499	(inherit %simple-os)
	500	(name-service-switch %mdns-host-lookup-nss)
	501	(services (cons* (avahi-service #:debug? #t)
	502	(dbus-service)
	503	(dhcp-client-service) ;needed for multicast
	504
	505	;; Enable heavyweight debugging output.
	506	(modify-services (operating-system-user-services
	507	%simple-os)
	508	(nscd-service-type config
	509	=> (nscd-configuration
	510	(inherit config)
	511	(debug-level 3)
	512	(log-file "/dev/console")))
	513	(syslog-service-type config
	514	=>
ec2e2f6c DC	515	(syslog-configuration
	516	(inherit config)
	517	(config-file
	518	(plain-file
	519	"syslog.conf"
	520	". /dev/console\n")))))))))
d2fa61bc LC	521
	522	(define (run-nss-mdns-test)
	523	;; Test resolution of '.local' names via libc. Start the marionette service
	524	;; after nscd. Failing to do that, libc will try to connect to nscd,
	525	;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc),
	526	;; leading to '.local' resolution failures.
8b113790 LC	527	(define os
	528	(marionette-operating-system
	529	%avahi-os
	530	#:requirements '(nscd)
	531	#:imported-modules '((gnu services herd)
	532	(guix combinators))))
4ee96a79	533
8b113790 LC	534	(define mdns-host-name
	535	(string-append (operating-system-host-name os)
	536	".local"))
4ee96a79	537
8b113790 LC	538	(define test
	539	(with-imported-modules '((gnu build marionette))
	540	#~(begin
	541	(use-modules (gnu build marionette)
	542	(srfi srfi-1)
	543	(srfi srfi-64)
	544	(ice-9 match))
	545
	546	(define marionette
	547	(make-marionette (list #$(virtual-machine os))))
	548
	549	(mkdir #$output)
	550	(chdir #$output)
	551
	552	(test-begin "avahi")
	553
	554	(test-assert "wait for services"
	555	(marionette-eval
	556	'(begin
	557	(use-modules (gnu services herd))
	558
	559	(start-service 'nscd)
	560
	561	;; XXX: Work around a race condition in nscd: nscd creates its
	562	;; PID file before it is listening on its socket.
	563	(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
	564	(let try ()
	565	(catch 'system-error
	566	(lambda ()
	567	(connect sock AF_UNIX "/var/run/nscd/socket")
	568	(close-port sock)
	569	(format #t "nscd is ready~%"))
	570	(lambda args
	571	(format #t "waiting for nscd...~%")
	572	(usleep 500000)
	573	(try)))))
	574
	575	;; Wait for the other useful things.
	576	(start-service 'avahi-daemon)
	577	(start-service 'networking)
	578
	579	#t)
	580	marionette))
	581
	582	(test-equal "avahi-resolve-host-name"
	583	0
	584	(marionette-eval
	585	'(system*
	586	"/run/current-system/profile/bin/avahi-resolve-host-name"
	587	"-v" #$mdns-host-name)
	588	marionette))
	589
	590	(test-equal "avahi-browse"
	591	0
	592	(marionette-eval
	593	'(system* "avahi-browse" "-avt")
	594	marionette))
	595
	596	(test-assert "getaddrinfo .local"
	597	;; Wait for the 'avahi-daemon' service and perform a resolution.
	598	(match (marionette-eval
	599	'(getaddrinfo #$mdns-host-name)
	600	marionette)
	601	(((? vector? addrinfos) ..1)
602	(pk 'getaddrinfo addrinfos)
603	(and (any (lambda (ai)
604	(= AF_INET (addrinfo:fam ai)))
605	addrinfos)
606	(any (lambda (ai)
607	(= AF_INET6 (addrinfo:fam ai)))
608	addrinfos)))))
609
610	(test-assert "gethostbyname .local"
611	(match (pk 'gethostbyname
612	(marionette-eval '(gethostbyname #$mdns-host-name)
613	marionette))
614	((? vector? result)
615	(and (string=? (hostent:name result) #$mdns-host-name)
616	(= (hostent:addrtype result) AF_INET)))))
617
618
619	(test-end)
620	(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
621
622	(gexp->derivation "nss-mdns" test))
d2fa61bc LC	623
	624	(define %test-nss-mdns
	625	(system-test
	626	(name "nss-mdns")
	627	(description
	628	"Test Avahi's multicast-DNS implementation, and in particular, test its
	629	glibc name service switch (NSS) module.")
	630	(value (run-nss-mdns-test))))