diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/activation.scm | 11 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 8 | ||||
| -rw-r--r-- | gnu/build/hurd-boot.scm | 52 | ||||
| -rw-r--r-- | gnu/build/image.scm | 5 | ||||
| -rw-r--r-- | gnu/build/install.scm | 83 | ||||
| -rw-r--r-- | gnu/build/linux-modules.scm | 135 | ||||
| -rw-r--r-- | gnu/build/marionette.scm | 54 |
7 files changed, 282 insertions, 66 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index 10c9045740..eea2233563 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -363,9 +363,14 @@ second element is the name it should appear at, such as: "Tell the kernel to look for device firmware under DIRECTORY. This mechanism bypasses udev: it allows Linux to handle firmware loading directly by itself, without having to resort to a \"user helper\"." - (call-with-output-file "/sys/module/firmware_class/parameters/path" - (lambda (port) - (display directory port)))) + + ;; If the kernel was built without firmware loading support, this file + ;; does not exist. Do nothing in that case. + (let ((firmware-path "/sys/module/firmware_class/parameters/path")) + (when (file-exists? firmware-path) + (call-with-output-file firmware-path + (lambda (port) + (display directory port)))))) (define (activate-ptrace-attach) "Allow users to PTRACE_ATTACH their own processes. diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 0ed5dc5671..66ca22d6ea 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -899,6 +899,10 @@ caught and lead to a warning and #f as the result." (format (current-error-port) "warning: failed to read from device '~a'~%" device) #f) + ((= EMEDIUMTYPE errno) ;inaccessible, like DRBD secondaries + (format (current-error-port) + "warning: failed to open device '~a'~%" device) + #f) (else (apply throw args)))))))) @@ -1123,7 +1127,7 @@ corresponds to the symbols listed in FLAGS." (('read-only rest ...) (logior MS_RDONLY (loop rest))) (('bind-mount rest ...) - (logior MS_BIND (loop rest))) + (logior MS_REC (logior MS_BIND (loop rest)))) (('no-suid rest ...) (logior MS_NOSUID (loop rest))) (('no-dev rest ...) @@ -1132,6 +1136,8 @@ corresponds to the symbols listed in FLAGS." (logior MS_NOEXEC (loop rest))) (('no-atime rest ...) (logior MS_NOATIME (loop rest))) + (('no-diratime rest ...) + (logior MS_NODIRATIME (loop rest))) (('strict-atime rest ...) (logior MS_STRICTATIME (loop rest))) (('lazy-time rest ...) diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm index ad3c50d61e..abcf0304c2 100644 --- a/gnu/build/hurd-boot.scm +++ b/gnu/build/hurd-boot.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -127,6 +127,9 @@ set." (define (translated? file-name) "Return true if a translator is installed on FILE-NAME." + ;; On GNU/Hurd, 'getxattr' in glibc opens the file without O_NOTRANS, and + ;; then, for "gnu.translator", it calls 'file_get_translator', resulting in + ;; EOPNOTSUPP (conversely, 'showtrans' opens the file with O_NOTRANS). (if (string-contains %host-type "linux-gnu") (passive-translator-xattr? file-name) (passive-translator-installed? file-name))) @@ -191,7 +194,7 @@ set." ("proc" ("/hurd/procfs" "--stat-mode=444")))) (define devices - '(("dev/full" ("/hurd/null" "--full") #o666) + `(("dev/full" ("/hurd/null" "--full") #o666) ("dev/null" ("/hurd/null") #o666) ("dev/random" ("/hurd/random" "--seed-file" "/var/lib/random-seed") #o644) @@ -210,31 +213,34 @@ set." ;; 'fd_to_filename' in libc expects it. ("dev/fd" ("/hurd/magic" "--directory" "fd") #o555) - ("dev/tty1" ("/hurd/term" "/dev/tty1" "hurdio" "/dev/vcs/1/console") - #o666) - ("dev/tty2" ("/hurd/term" "/dev/tty2" "hurdio" "/dev/vcs/2/console") - #o666) - ("dev/tty3" ("/hurd/term" "/dev/tty3" "hurdio" "/dev/vcs/3/console") - #o666) - - ("dev/ptyp0" ("/hurd/term" "/dev/ptyp0" "pty-master" "/dev/ttyp0") - #o666) - ("dev/ptyp1" ("/hurd/term" "/dev/ptyp1" "pty-master" "/dev/ttyp1") - #o666) - ("dev/ptyp2" ("/hurd/term" "/dev/ptyp2" "pty-master" "/dev/ttyp2") - #o666) - - ("dev/ttyp0" ("/hurd/term" "/dev/ttyp0" "pty-slave" "/dev/ptyp0") - #o666) - ("dev/ttyp1" ("/hurd/term" "/dev/ttyp1" "pty-slave" "/dev/ptyp1") - #o666) - ("dev/ttyp2" ("/hurd/term" "/dev/ttyp2" "pty-slave" "/dev/ptyp2") - #o666))) + ;; Create a number of ttys; syslogd writes to tty12 by default. + ;; FIXME: Creating /dev/tty12 leads the console client to switch to + ;; tty12 when syslogd starts, which is confusing for users. Thus, do + ;; not create tty12. + ,@(map (lambda (n) + (let ((n (number->string n))) + `(,(string-append "dev/tty" n) + ("/hurd/term" ,(string-append "/dev/tty" n) + "hurdio" ,(string-append "/dev/vcs/" n "/console")) + #o666))) + (iota 11 1)) + + ,@(append-map (lambda (n) + (let ((n (number->string n))) + `((,(string-append "dev/ptyp" n) + ("/hurd/term" ,(string-append "/dev/ptyp" n) + "pty-master" ,(string-append "/dev/ttyp" n)) + #o666) + + (,(string-append "dev/ttyp" n) + ("/hurd/term" ,(string-append "/dev/ttyp" n) + "pty-slave" ,(string-append "/dev/ptyp" n)) + #o666)))) + (iota 10 0)))) (for-each scope-set-translator servers) (mkdir* "dev/vcs/1") (mkdir* "dev/vcs/2") - (mkdir* "dev/vcs/2") (rename-file (scope "dev/console") (scope "dev/console-")) (for-each scope-set-translator devices) diff --git a/gnu/build/image.scm b/gnu/build/image.scm index 2327cfbb45..65a0373980 100644 --- a/gnu/build/image.scm +++ b/gnu/build/image.scm @@ -111,7 +111,10 @@ turn doesn't take any constant overhead into account, force a 1-MiB minimum." (if (eq? size 'guess) (estimate-partition-size root) size)) - (if (member 'esp flags) (list "-S" "1024") '())) + ;; u-boot in particular needs the formatted block + ;; size and the physical block size to be equal. + ;; TODO: What about 4k blocks? + (if (member 'esp flags) (list "-S" "512") '())) (for-each (lambda (file) (unless (member file '("." "..")) (invoke "mcopy" "-bsp" "-i" target diff --git a/gnu/build/install.scm b/gnu/build/install.scm index f5c8407b89..d4982650c1 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -56,19 +57,24 @@ that the fonts, background images, etc. referred to by BOOTCFG are not GC'd." (define* (evaluate-populate-directive directive target #:key (default-gid 0) - (default-uid 0)) + (default-uid 0) + (error-on-dangling-symlink? #t)) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in the context of the caller. If the directive matches those defaults then, -'chown' won't be run." +'chown' won't be run. When ERROR-ON-DANGLING-SYMLINK? is true, abort with an +error when a dangling symlink would be created." + (define target* (if (string-suffix? "/" target) + target + (string-append target "/"))) (let loop ((directive directive)) (catch 'system-error (lambda () (match directive (('directory name) - (mkdir-p (string-append target name))) + (mkdir-p (string-append target* name))) (('directory name uid gid) - (let ((dir (string-append target name))) + (let ((dir (string-append target* name))) (mkdir-p dir) ;; If called from a context without "root" permissions, "chown" ;; to root will fail. In that case, do not try to run "chown" @@ -78,27 +84,38 @@ the context of the caller. If the directive matches those defaults then, (chown dir uid gid)))) (('directory name uid gid mode) (loop `(directory ,name ,uid ,gid)) - (chmod (string-append target name) mode)) + (chmod (string-append target* name) mode)) (('file name) - (call-with-output-file (string-append target name) + (call-with-output-file (string-append target* name) (const #t))) (('file name (? string? content)) - (call-with-output-file (string-append target name) + (call-with-output-file (string-append target* name) (lambda (port) (display content port)))) ((new '-> old) - (let try () - (catch 'system-error - (lambda () - (symlink old (string-append target new))) - (lambda args - ;; When doing 'guix system init' on the current '/', some - ;; symlinks may already exists. Override them. - (if (= EEXIST (system-error-errno args)) - (begin - (delete-file (string-append target new)) - (try)) - (apply throw args)))))))) + (let ((new* (string-append target* new))) + (let try () + (catch 'system-error + (lambda () + (when error-on-dangling-symlink? + ;; When the symbolic link points to a relative path, + ;; checking if its target exists must be done relatively + ;; to the link location. + (unless (if (string-prefix? "/" old) + (file-exists? old) + (with-directory-excursion (dirname new*) + (file-exists? old))) + (error (format #f "symlink `~a' points to nonexistent \ +file `~a'" new* old)))) + (symlink old new*)) + (lambda args + ;; When doing 'guix system init' on the current '/', some + ;; symlinks may already exists. Override them. + (if (= EEXIST (system-error-errno args)) + (begin + (delete-file new*) + (try)) + (apply throw args))))))))) (lambda args ;; Usually we can only get here when installing to an existing root, ;; as with 'guix system init foo.scm /'. @@ -142,7 +159,10 @@ STORE." includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM. EXTRAS is a list of directives appended to the built-in directives to populate TARGET." - (for-each (cut evaluate-populate-directive <> target) + ;; It's expected that some symbolic link targets do not exist yet, so do not + ;; error on dangling links. + (for-each (cut evaluate-populate-directive <> target + #:error-on-dangling-symlink? #f) (append (directives (%store-directory)) extras)) ;; Add system generation 1. @@ -262,12 +282,31 @@ disk." (mount "/.rw-store" (%store-directory) "" MS_MOVE) (rmdir "/.rw-store"))) +(define (umount* directory) + "Unmount DIRECTORY, but retry a few times upon EBUSY." + (let loop ((attempts 5)) + (catch 'system-error + (lambda () + (umount directory)) + (lambda args + (if (and (= EBUSY (system-error-errno args)) + (> attempts 0)) + (begin + (sleep 1) + (loop (- attempts 1))) + (apply throw args)))))) + (define (unmount-cow-store target backing-directory) "Unmount copy-on-write store." (let ((tmp-dir "/remove")) (mkdir-p tmp-dir) (mount (%store-directory) tmp-dir "" MS_MOVE) - (umount tmp-dir) + + ;; We might get EBUSY at this point, possibly because of lingering + ;; processes with open file descriptors. Use 'umount*' to retry upon + ;; EBUSY, leaving a bit of time. See <https://issues.guix.gnu.org/59884>. + (umount* tmp-dir) + (rmdir tmp-dir) (delete-file-recursively (string-append target backing-directory)))) diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index 053720574b..3b1f512663 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2016, 2018, 2019, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org> ;;; @@ -28,6 +28,7 @@ #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 ftw) @@ -50,6 +51,17 @@ load-linux-module* load-linux-modules-from-directory + pci-devices + pci-device? + pci-device-vendor + pci-device-id + pci-device-class + pci-device-module-alias + storage-pci-device? + network-pci-device? + display-pci-device? + load-pci-device-database + current-module-debugging-port device-module-aliases @@ -429,6 +441,127 @@ key such as 'MAJOR or 'DEVTYPE and each cdr is the corresponding value." (line (loop (cons (key=value->pair line) result)))))) +;; PCI device known to the Linux kernel. +(define-immutable-record-type <pci-device> + (pci-device vendor device class module-alias) + pci-device? + (vendor pci-device-vendor) ;integer + (device pci-device-id) ;integer + (class pci-device-class) ;integer + (module-alias pci-device-module-alias)) ;string | #f + +(define (pci-device-class-predicate mask bits) + (lambda (device) + "Return true if DEVICE has the chosen class." + (= (logand mask (pci-device-class device)) bits))) + +(define storage-pci-device? ;"Mass storage controller" class + (pci-device-class-predicate #xff0000 #x010000)) +(define network-pci-device? ;"Network controller" class + (pci-device-class-predicate #xff0000 #x020000)) +(define display-pci-device? ;"Display controller" class + (pci-device-class-predicate #xff0000 #x030000)) + +(define (pci-devices) + "Return the list of PCI devices of the system (<pci-device> records)." + (define (read-hex port) + (let ((line (read-line port))) + (and (string? line) + (string-prefix? "0x" line) + (string->number (string-drop line 2) 16)))) + + (filter-map (lambda (directory) + (define properties + (call-with-input-file (string-append directory "/uevent") + read-uevent)) + (define vendor + (call-with-input-file (string-append directory "/vendor") + read-hex)) + (define device + (call-with-input-file (string-append directory "/device") + read-hex)) + (define class + (call-with-input-file (string-append directory "/class") + read-hex)) + + (pci-device vendor device class + (assq-ref properties 'MODALIAS))) + (find-files "/sys/bus/pci/devices" + #:stat lstat))) + +(define (read-pci-device-database port) + "Parse the 'pci.ids' database that ships with the pciutils package and is +maintained at <https://pci-ids.ucw.cz/>." + (define (comment? str) + (string-prefix? "#" (string-trim str))) + (define (blank? str) + (string-null? (string-trim-both str))) + (define (device? str) + (eqv? #\tab (string-ref str 0))) + (define (subvendor? str) + (string-prefix? "\t\t" str)) + (define (class? str) + (string-prefix? "C " str)) + (define (parse-id-line str) + (let* ((str (string-trim-both str)) + (space (string-index str char-set:whitespace))) + (values (string->number (string-take str space) 16) + (string-trim (string-drop str (+ 1 space)))))) + (define (finish vendor vendor-id devices table) + (fold (lambda (device table) + (match device + ((device-id . name) + (vhash-consv (logior (ash vendor-id 16) device-id) + (cons vendor name) + table)))) + table + devices)) + + (let loop ((table vlist-null) + (vendor-id #f) + (vendor #f) + (devices '())) + (match (read-line port) + ((? eof-object?) + (let ((table (if (and vendor vendor-id) + (finish vendor vendor-id devices table) + table))) + (lambda (vendor device) + (match (vhash-assv (logior (ash vendor 16) device) table) + (#f + (values #f #f)) + ((_ . (vendor . name)) + (values vendor name)))))) + ((? comment?) + (loop table vendor-id vendor devices)) + ((? blank?) + (loop table vendor-id vendor devices)) + ((? subvendor?) ;currently ignored + (loop table vendor-id vendor devices)) + ((? class?) ;currently ignored + (loop table vendor-id vendor devices)) + ((? device? line) + (let-values (((id name) (parse-id-line line))) + (loop table vendor-id vendor + (if (and vendor-id vendor) ;class or device? + (alist-cons id name devices) + devices)))) + (line + (let ((table (if (and vendor vendor-id) + (finish vendor vendor-id devices table) + table))) + (let-values (((vendor-id vendor) (parse-id-line line))) + (loop table vendor-id vendor '()))))))) + +(define (load-pci-device-database file) + "Read the 'pci.ids' database at FILE (get it from the pciutils package or +from <https://pci-ids.ucw.cz/>) and return a lookup procedure that takes a PCI +vendor ID and a device ID (two integers) and returns the vendor name and +device name as two values." + (let ((port (open-file file "r0"))) + (call-with-gzip-input-port port + read-pci-device-database))) + (define (device-module-aliases device) "Return the list of module aliases required by DEVICE, a /dev file name, as in this example: diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index 5ebf783892..b8fba61d06 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -22,18 +22,19 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71) #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 regex) #:export (marionette? + marionette-pid make-marionette marionette-eval wait-for-file wait-for-tcp-port wait-for-unix-socket marionette-control - marionette-screen-text wait-for-screen-text %qwerty-us-keystrokes marionette-type @@ -312,40 +313,61 @@ Monitor\")." (define* (marionette-screen-text marionette #:key (ocr "ocrad")) "Take a screenshot of MARIONETTE, perform optical character -recognition (OCR), and return the text read from the screen as a string. Do -this by invoking OCR, which should be the file name of GNU Ocrad's -@command{ocrad} or Tesseract OCR's @command{tesseract} command." +recognition (OCR), and return the text read from the screen as a string, along +the screen dump image used. Do this by invoking OCR, which should be the file +name of GNU Ocrad's@command{ocrad} or Tesseract OCR's @command{tesseract} +command. The screen dump image returned as the second value should be deleted +if it is not needed." (define image (string-append (tmpnam) ".ppm")) ;; Use the QEMU Monitor to save an image of the screen to the host. (marionette-control (string-append "screendump " image) marionette) ;; Process it via the OCR. (cond ((string-contains ocr "ocrad") - (invoke-ocrad-ocr image #:ocrad ocr)) + (values (invoke-ocrad-ocr image #:ocrad ocr) image)) ((string-contains ocr "tesseract") - (invoke-tesseract-ocr image #:tesseract ocr)) + (values (invoke-tesseract-ocr image #:tesseract ocr) image)) (else (error "unsupported ocr command")))) (define* (wait-for-screen-text marionette predicate #:key (ocr "ocrad") - (timeout 30)) + (timeout 30) + pre-action + post-action) "Wait for TIMEOUT seconds or until the screen text on MARIONETTE matches -PREDICATE, whichever comes first. Raise an error when TIMEOUT is exceeded." +PREDICATE, whichever comes first. Raise an error when TIMEOUT is exceeded. +The error contains the recognized text along the preserved file name of the +screen dump, which is relative to the current working directory. If +PRE-ACTION is provided, it should be a thunk to call before each OCR attempt. +Likewise for POST-ACTION, except it runs at the end of a successful OCR." (define start (car (gettimeofday))) (define end (+ start timeout)) - (let loop ((last-text #f)) + (let loop ((last-text #f) + (last-screendump #f)) (if (> (car (gettimeofday)) end) - (error "'wait-for-screen-text' timeout" 'ocr-text: last-text) - (let ((text (marionette-screen-text marionette #:ocr ocr))) - (or (predicate text) - (begin - (sleep 1) - (loop text))))))) + (let ((screendump-backup (string-drop last-screendump 5))) + ;; Move the file from /tmp/fileXXXXXX.pmm to the current working + ;; directory, so that it is preserved in the test derivation output. + (copy-file last-screendump screendump-backup) + (delete-file last-screendump) + (error "'wait-for-screen-text' timeout" + 'ocr-text: last-text + 'screendump: screendump-backup)) + (let* ((_ (and (procedure? pre-action) (pre-action))) + (text screendump (marionette-screen-text marionette #:ocr ocr)) + (_ (and (procedure? post-action) (post-action))) + (result (predicate text))) + (cond (result + (delete-file screendump) + result) + (else + (sleep 1) + (loop text screendump))))))) (define %qwerty-us-keystrokes ;; Maps "special" characters to their keystrokes. @@ -367,8 +389,10 @@ PREDICATE, whichever comes first. Raise an error when TIMEOUT is exceeded." (#\> . "shift-dot") (#\. . "dot") (#\, . "comma") + (#\: . "shift-semicolon") (#\; . "semicolon") (#\' . "apostrophe") + (#\! . "shift-1") (#\" . "shift-apostrophe") (#\` . "grave_accent") (#\bs . "backspace") |