aboutsummaryrefslogtreecommitdiff
ModeNameSize
-rw-r--r--.dir-locals.el4740logplainabout
-rw-r--r--.gitignore2588logplainabout
-rw-r--r--.mailmap4168logplainabout
-rw-r--r--AUTHORS472logplainabout
-rw-r--r--CODE-OF-CONDUCT3273logplainabout
-rw-r--r--COPYING35147logplainabout
-rw-r--r--ChangeLog163logplainabout
-rw-r--r--HACKING3161logplainabout
-rw-r--r--Makefile.am26504logplainabout
-rw-r--r--NEWS342134logplainabout
-rw-r--r--README6678logplainabout
-rw-r--r--ROADMAP3237logplainabout
-rw-r--r--THANKS2381logplainabout
-rw-r--r--TODO2843logplainabout
-rwxr-xr-xbootstrap69logplainabout
d---------build-aux730logplain
-rw-r--r--config-daemon.ac5262logplainabout
-rw-r--r--configure.ac8840logplainabout
-rw-r--r--d3.v3.js339545logplainabout
d---------doc499logplain
d---------etc470logplain
-rw-r--r--gnu.scm5309logplainabout
d---------gnu476logplain
-rw-r--r--graph.js4207logplainabout
-rw-r--r--guix.scm1357logplainabout
d---------guix2543logplain
d---------m435logplain
d---------nix316logplain
d---------po96logplain
-rw-r--r--release.nix4619logplainabout
d---------scripts35logplain
d---------tests3585logplain
generated by cgit
" marionette) (wait-for-screen-text marionette (lambda (text) (string-contains text "Password")) #:ocr #$(file-append ocrad "/bin/ocrad")) (marionette-type (string-append password "\n\n") marionette)) (marionette-type "root\n\n" marionette))) (marionette-type "id -un > logged-in\n" marionette) ;; It can take a while before the shell commands are executed. (marionette-eval '(use-modules (rnrs io ports)) marionette) (wait-for-file "/root/logged-in" marionette #:read 'get-string-all #:timeout 30))) (test-equal "getlogin on tty1" "\"root\"" (begin ;; Assume we logged in in the previous test and type. (marionette-type "guile -c '(write (getlogin))' > /root/login-id.tmp\n" marionette) (marionette-type "mv /root/login-id{.tmp,}\n" marionette) ;; It can take a while before the shell commands are executed. (marionette-eval '(use-modules (rnrs io ports)) marionette) (wait-for-file "/root/login-id" marionette #:read 'get-string-all #:timeout 30))) ;; 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-assert "nscd configuration action" (marionette-eval '(with-shepherd-action 'nscd ('configuration) results (file-exists? (car results))) marionette)) (test-equal "nscd invalidate action" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts") result result) marionette)) ;; FIXME: The 'invalidate' action can't reliably obtain the exit ;; code of 'nscd' so skip this test. (test-skip 1) (test-equal "nscd invalidate action, wrong table" '(#f) ;one value, #f (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz") result result) marionette)) (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. (eval-when (expand load eval) (set! %load-path (append (map (lambda (package) (string-append package "/share/guile/site/" (effective-version))) '#$guix&co) %load-path))) (use-modules (srfi srfi-34) (guix store)) (let ((system (readlink "/run/current-system"))) (guard (c ((store-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-equal "guix-daemon set-http-proxy action" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'guix-daemon ('set-http-proxy "http://localhost:8118") result result) marionette)) (test-equal "guix-daemon set-http-proxy action, clear" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'guix-daemon ('set-http-proxy) result result) marionette)) (test-assert "screendump" (begin (let ((capture (string-append #$output "/tty1.ppm"))) (marionette-control (string-append "screendump " capture) marionette) (file-exists? capture)))) (test-assert "screen text" (wait-for-screen-text marionette (lambda (text) ;; 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))))) #:ocr #$(file-append ocrad "/bin/ocrad"))) (test-end)))) (gexp->derivation name test)) (define* (test-basic-os #:optional (kernel linux-libre)) (system-test (name (if (eq? kernel linux-libre) "basic" (string-append (package-name kernel) "-" (version-major+minor (package-version kernel))))) (description "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic functionality tests, using the given KERNEL.") (value (let* ((os (marionette-operating-system (operating-system (inherit %simple-os) (kernel kernel)) #: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) name))))) (define %test-basic-os (test-basic-os)) ;; Ensure the LTS kernels are up to snuff, too. (define %test-linux-libre-5.15 (test-basic-os linux-libre-5.15)) (define %test-linux-libre-5.10 (test-basic-os linux-libre-5.10)) (define %test-linux-libre-5.4 (test-basic-os linux-libre-5.4)) (define %test-linux-libre-4.19 (test-basic-os linux-libre-4.19)) ;;; ;;; Halt. ;;; (define (run-halt-test vm) ;; As reported in <http://bugs.gnu.org/26931>, running tmux would previously ;; lead the 'stop' method of 'user-processes' to an infinite loop, with the ;; tmux server process as a zombie that remains in the list of processes. ;; This test reproduces this scenario. (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (gnu build marionette)) (define marionette (make-marionette '(#$vm))) (define ocrad #$(file-append ocrad "/bin/ocrad")) ;; Wait for tty1 and log in. (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'term-tty1)) marionette) (marionette-type "root\n" marionette) ;; Start tmux and wait for it to be ready. (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n" marionette) (wait-for-file "/ready" marionette) ;; Make sure to stop the test after a while. (sigaction SIGALRM (lambda _ (format (current-error-port) "FAIL: Time is up, but VM still running.\n") (primitive-exit 1))) (alarm 10) ;; Get debugging info. (marionette-eval '(current-output-port (open-file "/dev/console" "w0")) marionette) (marionette-eval '(system* #$(file-append procps "/bin/ps") "-eo" "pid,ppid,stat,comm") marionette) ;; See if 'halt' actually works. (marionette-eval '(system* "/run/current-system/profile/sbin/halt") marionette) ;; If we reach this line, that means the VM was properly stopped in ;; a timely fashion. (alarm 0) (call-with-output-file #$output (lambda (port) (display "success!" port)))))) (gexp->derivation "halt" test)) (define %test-halt (system-test (name "halt") (description "Use the 'halt' command and make sure it succeeds and does not get stuck in a loop. See <http://bugs.gnu.org/26931>.") (value (let ((os (marionette-operating-system (operating-system (inherit %simple-os) (packages (cons tmux %base-packages))) #:imported-modules '((gnu services herd) (guix combinators))))) (run-halt-test (virtual-machine os)))))) ;;; ;;; Root cleanly unmounted. ;;; (define (run-root-unmount-test os) (define test-image (image (operating-system os) (format 'compressed-qcow2) (volatile-root? #f) (shared-store? #f) (partition-table-type 'mbr) (partitions (list (partition (size 'guess) (offset (* 512 2048)) ;leave room for GRUB (flags '(boot)) (label "root-under-test")))))) ;max 16 characters! (define observer-os (marionette-operating-system %simple-os #:imported-modules (source-module-closure '((guix build syscalls) (gnu build file-systems))))) (define test (with-imported-modules (source-module-closure '((gnu build marionette) (guix build utils))) #~(begin (use-modules (gnu build marionette) (guix build utils) (srfi srfi-64) (ice-9 ftw)) (define image "/tmp/writable-image.qcow2") (define (test-system-marionette) ;; Return a marionette on a system where we'll run 'halt'. (invoke #$(file-append qemu-minimal "/bin/qemu-img") "create" "-f" "qcow2" image "3G" "-b" #$(system-image test-image) "-F" "qcow2") (make-marionette `(,(string-append #$qemu-minimal "/bin/" (qemu-command)) ,@(if (file-exists? "/dev/kvm") '("-enable-kvm") '()) "-no-reboot" "-m" "1024" ;memory size, in MiB "-drive" ,(format #f "file=~a,if=virtio" image)))) (define witness-size ;; Size of the /witness file. (* 20 (expt 2 20))) (test-runner-current (system-test-runner #$output)) (test-begin "root-unmount") (let ((marionette (test-system-marionette))) (test-assert "file created" (marionette-eval `(begin (use-modules (guix build utils)) (call-with-output-file "/witness" (lambda (port) (call-with-input-file "/dev/random" (lambda (input) (dump-port input port ,witness-size)))))) marionette)) ;; Halt the system. (marionette-eval '(system* "/run/current-system/profile/sbin/halt") marionette) (display "waiting for marionette to complete...") (force-output) (false-if-exception (waitpid (marionette-pid marionette))) (display " done\n") (force-output)) ;; Remove the sockets used by the marionette above to avoid ;; EADDRINUSE. (for-each delete-file (find-files "/tmp" (lambda (file stat) (eq? (stat:type stat) 'socket)))) ;; Now boot another system and check whether the root file system of ;; the first one was cleanly unmounted. (let ((observer (make-marionette (list #$(virtual-machine observer-os) "-drive" (format #f "file=~a,if=virtio" image))))) (test-assert "partitions" (marionette-eval '(begin (use-modules (gnu build file-systems)) (disk-partitions)) observer)) (test-assert "partition found" (marionette-eval '(find-partition-by-label "root-under-test") observer)) (test-assert "root file system is clean" (marionette-eval '(cleanly-unmounted-ext2? (find-partition-by-label "root-under-test")) observer)) (test-equal "root file system contains /witness" witness-size (let ((files (marionette-eval '(begin (use-modules (guix build syscalls) (ice-9 ftw)) (mount (find-partition-by-label "root-under-test") "/mnt" "ext4" MS_RDONLY) (scandir "/mnt")) observer))) (if (member "witness" files) (marionette-eval '(stat:size (stat "/mnt/witness")) observer) files)))) (test-end)))) (gexp->derivation "root-unmount" test)) (define %test-root-unmount (system-test (name "root-unmount") (description "Make sure the root file system is cleanly unmounted when the system is halted.") (value (let ((os (marionette-operating-system %simple-os))) (run-root-unmount-test os))))) ;;; ;;; Cleanup of /tmp, /var/run, etc. ;;; (define %cleanup-os (simple-operating-system (simple-service 'dirty-things boot-service-type (let ((script (plain-file "create-utf8-file.sh" (string-append "echo $0: dirtying /tmp...\n" "set -e; set -x\n" "touch /witness\n" "exec touch /tmp/λαμβδα")))) (with-imported-modules '((guix build utils)) #~(begin (setenv "PATH" #$(file-append coreutils "/bin")) (invoke #$(file-append bash "/bin/sh") #$script))))))) (define (run-cleanup-test name) (define os (marionette-operating-system %cleanup-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)))) (test-runner-current (system-test-runner #$output)) (test-begin "cleanup") (test-assert "dirty service worked" (marionette-eval '(file-exists? "/witness") marionette)) (test-equal "/tmp cleaned up" '("." "..") (marionette-eval '(begin (use-modules (ice-9 ftw)) (scandir "/tmp")) marionette)) (test-end)))) (gexp->derivation "cleanup" test)) (define %test-cleanup ;; See <https://bugs.gnu.org/26353>. (system-test (name "cleanup") (description "Make sure the 'cleanup' service can remove files with non-ASCII names from /tmp.") (value (run-cleanup-test name)))) ;;; ;;; Mcron. ;;; (define %mcron-os ;; System with an mcron service, with one mcron job for "root" and one mcron ;; job for an unprivileged user. (let ((job1 #~(job '(next-second '(0 5 10 15 20 25 30 35 40 45 50 55)) (lambda () (unless (file-exists? "witness") (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 (service mcron-service-type (mcron-configuration (jobs (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)))) (test-runner-current (system-test-runner #$output)) (test-begin "mcron") (test-assert "service running" (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'mcron)) 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. (test-equal "root's job with command" "" (wait-for-file "/root/witness-touch" marionette #:read '(@ (ice-9 rdelim) read-string))) ;; Make sure the 'schedule' action is accepted. (test-equal "schedule action" '(#t) ;one value, #t (marionette-eval '(with-shepherd-action 'mcron ('schedule) result result) marionette)) (test-end)))) (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)))) ;;; ;;; Avahi and NSS-mDNS. ;;; (define %avahi-os (operating-system (inherit %simple-os) (name-service-switch %mdns-host-lookup-nss) (services (cons* (service avahi-service-type (avahi-configuration (debug? #t))) (service dbus-root-service-type) (service dhcp-client-service-type) ;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-runner-current (system-test-runner)) (test-begin "avahi") (test-assert "nscd PID file is created" (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'nscd)) marionette)) (test-assert "nscd is listening on its socket" (marionette-eval ;; 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~%") #t) (lambda args (format #t "waiting for nscd...~%") (usleep 500000) (try))))) marionette)) (test-assert "avahi is running" (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'avahi-daemon)) marionette)) (test-assert "network is up" (marionette-eval '(begin (use-modules (gnu services herd)) (start-service 'networking)) 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* "/run/current-system/profile/bin/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)))) (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))))
generated by cgit