diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/accounts.scm | 2 | ||||
| -rw-r--r-- | gnu/build/bootloader.scm | 62 | ||||
| -rw-r--r-- | gnu/build/cross-toolchain.scm | 29 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 14 | ||||
| -rw-r--r-- | gnu/build/linux-container.scm | 7 | ||||
| -rw-r--r-- | gnu/build/linux-initrd.scm | 4 | ||||
| -rw-r--r-- | gnu/build/linux-modules.scm | 147 | ||||
| -rw-r--r-- | gnu/build/shepherd.scm | 14 |
8 files changed, 182 insertions, 97 deletions
diff --git a/gnu/build/accounts.scm b/gnu/build/accounts.scm index 5094456ab1..f60d68d9b3 100644 --- a/gnu/build/accounts.scm +++ b/gnu/build/accounts.scm @@ -238,7 +238,7 @@ to it atomically and set the appropriate permissions." (for-each (lambda (entry) (display (entry->string entry) port) (newline port)) - entries)) + (delete-duplicates entries))) (if (port? file-or-port) (write-entries file-or-port) diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm index c5febcde1e..9570d6dd18 100644 --- a/gnu/build/bootloader.scm +++ b/gnu/build/bootloader.scm @@ -18,15 +18,8 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu build bootloader) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (ice-9 binary-ports) - #:use-module (ice-9 popen) - #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 format) - #:export (write-file-on-device - invoke/quiet)) + #:export (write-file-on-device)) ;;; @@ -43,56 +36,3 @@ (seek output offset SEEK_SET) (put-bytevector output bv)) #:binary #t))))) - -(define-syntax-rule (G_ str) str) ;for xgettext - -(define (open-pipe-with-stderr program . args) - "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect -both its standard output and standard error to the pipe. Return two value: -the pipe to read PROGRAM's data from, and the PID of the child process running -PROGRAM." - ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why - ;; we need to roll our own. - (match (pipe) - ((input . output) - (match (primitive-fork) - (0 - (dynamic-wind - (const #t) - (lambda () - (close-port input) - (dup2 (fileno output) 1) - (dup2 (fileno output) 2) - (apply execlp program program args)) - (lambda () - (primitive-exit 127)))) - (pid - (close-port output) - (values input pid)))))) - -;; TODO: Move to (guix build utils) on the next rebuild cycle. -(define (invoke/quiet program . args) - "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard -error. If PROGRAM succeeds, print nothing and return the unspecified value; -otherwise, raise a '&message' error condition that includes the status code -and the output of PROGRAM." - (define-values (pipe pid) - (apply open-pipe-with-stderr program args)) - - (let loop ((lines '())) - (match (read-line pipe) - ((? eof-object?) - (close-port pipe) - (match (waitpid pid) - ((_ . status) - (unless (zero? status) - (raise (condition - (&message - (message (format #f (G_ "'~a~{ ~a~}' exited with status ~a; \ -output follows:~%~%~{ ~a~%~}") - program args - (or (status:exit-val status) - status) - (reverse lines)))))))))) - (line - (loop (cons line lines)))))) diff --git a/gnu/build/cross-toolchain.scm b/gnu/build/cross-toolchain.scm index d430b8afc4..6bdbdd5411 100644 --- a/gnu/build/cross-toolchain.scm +++ b/gnu/build/cross-toolchain.scm @@ -3,6 +3,8 @@ ;;; Copyright © 2014, 2015, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016 Manolis Fragkiskos Ragkousis <manolis837@gmail.com> +;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2019 Carl Dong <contact@carldong.me> ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,11 +38,8 @@ (define %gcc-include-paths ;; Environment variables for header search paths. - ;; Note: See <http://bugs.gnu.org/22186> for why not 'CPATH'. - '("C_INCLUDE_PATH" - "CPLUS_INCLUDE_PATH" - "OBJC_INCLUDE_PATH" - "OBJCPLUS_INCLUDE_PATH")) + ;; Note: See <http://bugs.gnu.org/30756> for why not 'C_INCLUDE_PATH' & co. + '("CPATH")) (define %gcc-cross-include-paths ;; Search path for target headers when cross-compiling. @@ -95,7 +94,7 @@ C_INCLUDE_PATH et al." ;; We're building the sans-libc cross-compiler, so nothing to do. #t))) -(define* (set-cross-path/mingw #:key inputs #:allow-other-keys) +(define* (set-cross-path/mingw #:key inputs target #:allow-other-keys) "Add the cross MinGW headers to CROSS_C_*_INCLUDE_PATH, and remove them from C_*INCLUDE_PATH." (let ((libc (assoc-ref inputs "libc")) @@ -112,7 +111,7 @@ C_*INCLUDE_PATH." (if libc (let ((cpath (string-append libc "/include" - ":" libc "/i686-w64-mingw32/include"))) + ":" libc "/" target "/include"))) (for-each (cut setenv <> cpath) %gcc-cross-include-paths)) @@ -129,7 +128,11 @@ C_*INCLUDE_PATH." (substitute* (string-append mingw-headers "/crt/_mingw.h") (("@MINGW_HAS_SECURE_API@") - "#define MINGW_HAS_SECURE_API 1")) + "#define MINGW_HAS_SECURE_API 1") + (("@DEFAULT_WIN32_WINNT@") + "0x502") + (("@DEFAULT_MSVCRT_VERSION@") + "0x700")) (let ((cpath (string-append mingw-headers "/include" ":" mingw-headers "/crt" @@ -142,7 +145,7 @@ C_*INCLUDE_PATH." (when libc (setenv "CROSS_LIBRARY_PATH" (string-append libc "/lib" - ":" libc "/i686-w64-mingw32/lib"))) + ":" libc "/" target "/lib"))) (setenv "CPP" (string-append gcc "/bin/cpp")) (for-each (lambda (var) @@ -168,8 +171,12 @@ C_*INCLUDE_PATH." a target triplet." (modify-phases phases (add-before 'configure 'set-cross-path - (if (string-contains target "mingw") - set-cross-path/mingw + ;; This mingw32 target checking logic should match that of target-mingw? + ;; in (guix utils), but (guix utils) is too large too copy over to the + ;; build side entirely and for now we have no way to select variables to + ;; copy over. See (gnu packages cross-base) for more details. + (if (string-suffix? "-mingw32" target) + (cut set-cross-path/mingw #:target target <...>) set-cross-path)) (add-after 'install 'make-cross-binutils-visible (cut make-cross-binutils-visible #:target target <...>)) diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 03f2ea245c..84a5447977 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -359,8 +359,9 @@ the last argument of `mknod'." (define* (mount-root-file-system root type #:key volatile-root?) "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? -is true, mount ROOT read-only and make it a overlay with a writable tmpfs -using the kernel build-in overlayfs." +is true, mount ROOT read-only and make it an overlay with a writable tmpfs +using the kernel built-in overlayfs." + (if volatile-root? (begin (mkdir-p "/real-root") @@ -471,10 +472,6 @@ upon error." mounts) "ext4")) - (define (lookup-module name) - (string-append linux-module-directory "/" - (ensure-dot-ko name))) - (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -489,9 +486,8 @@ upon error." (start-repl)) (display "loading kernel modules...\n") - (for-each (cut load-linux-module* <> - #:lookup-module lookup-module) - (map lookup-module linux-modules)) + (load-linux-modules-from-directory linux-modules + linux-module-directory) (when keymap-file (let ((status (system* "loadkeys" keymap-file))) diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 6ccb924861..87695c98fd 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -299,8 +299,10 @@ delete it when leaving the dynamic extent of this call." (false-if-exception (delete-file-recursively tmp-dir)))))) (define* (call-with-container mounts thunk #:key (namespaces %namespaces) - (host-uids 1) (guest-uid 0) (guest-gid 0)) - "Run THUNK in a new container process and return its exit status. + (host-uids 1) (guest-uid 0) (guest-gid 0) + (process-spawned-hook (const #t))) + "Run THUNK in a new container process and return its exit status; call +PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned. MOUNTS is a list of <file-system> objects that specify file systems to mount inside the container. NAMESPACES is a list of symbols corresponding to the identifiers for Linux namespaces: mnt, ipc, uts, pid, user, and net. By @@ -329,6 +331,7 @@ load path must be adjusted as needed." (false-if-exception (kill pid SIGKILL)))) + (process-spawned-hook pid) (match (waitpid pid) ((_ . status) status)))))) diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm index 3aaa06d3a0..ea7de58553 100644 --- a/gnu/build/linux-initrd.scm +++ b/gnu/build/linux-initrd.scm @@ -71,8 +71,7 @@ COMPRESS? is true, compress it using GZIP. On success, return OUTPUT." (cpio:write-cpio-archive files port #:file->header cpio:file->cpio-header*))) - (or (not compress?) - + (if compress? ;; Gzip insists on adding a '.gz' suffix and does nothing if the input ;; file already has that suffix. Shuffle files around to placate it. (let* ((gz-suffix? (string-suffix? ".gz" output)) @@ -88,7 +87,6 @@ COMPRESS? is true, compress it using GZIP. On success, return OUTPUT." (unless gz-suffix? (rename-file (string-append output ".gz") output)) output))) - output)) (define (cache-compiled-file-name file) diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index c66ef97012..a149eff329 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,8 +31,10 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:autoload (ice-9 pretty-print) (pretty-print) #:export (dot-ko ensure-dot-ko + module-formal-name module-aliases module-dependencies module-soft-dependencies @@ -42,13 +45,18 @@ modules-loaded module-loaded? load-linux-module* + load-linux-modules-from-directory current-module-debugging-port device-module-aliases known-module-aliases matching-modules - missing-modules)) + missing-modules + + write-module-name-database + write-module-alias-database + write-module-device-database)) ;;; Commentary: ;;; @@ -95,6 +103,14 @@ key/value pairs.." (define %not-comma (char-set-complement (char-set #\,))) +(define (module-formal-name file) + "Return the module name of FILE as it appears in its info section. Usually +the module name is the same as the base name of FILE, modulo hyphens and minus +the \".ko\" extension." + (match (assq 'name (modinfo-section-contents file)) + (('name . name) name) + (#f #f))) + (define (module-dependencies file) "Return the list of modules that FILE depends on. The returned list contains module names, not actual file names." @@ -310,6 +326,18 @@ appears in BLACK-LIST are not loaded." (or (and recursive? (= EEXIST (system-error-errno args))) (apply throw args))))))) +(define (load-linux-modules-from-directory modules directory) + "Load MODULES and their dependencies from DIRECTORY, a directory containing +the '.ko' files. The '.ko' suffix is automatically added to MODULES if +needed." + (define module-name->file-name + (module-name-lookup directory)) + + (for-each (lambda (module) + (load-linux-module* (module-name->file-name module) + #:lookup-module module-name->file-name)) + modules)) + ;;; ;;; Device modules. @@ -486,4 +514,121 @@ are required to access DEVICE." (remove (cut member <> provided) modules)) '())) + +;;; +;;; Module databases. +;;; + +(define (module-name->file-name/guess directory name) + "Guess the file name corresponding to NAME, a module name. That doesn't +always work because sometimes underscores in NAME map to hyphens (e.g., +\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\")." + (string-append directory "/" (ensure-dot-ko name))) + +(define (module-name-lookup directory) + "Return a one argument procedure that takes a module name (e.g., +\"input_leds\") and returns its absolute file name (e.g., +\"/.../input-leds.ko\")." + (catch 'system-error + (lambda () + (define mapping + (call-with-input-file (string-append directory "/modules.name") + read)) + + (lambda (name) + (or (assoc-ref mapping name) + (module-name->file-name/guess directory name)))) + (lambda args + (if (= ENOENT (system-error-errno args)) + (cut module-name->file-name/guess directory <>) + (apply throw args))))) + +(define (write-module-name-database directory) + "Write a database that maps \"module names\" as they appear in the relevant +ELF section of '.ko' files, to actual file names. This format is +Guix-specific. It aims to deal with inconsistent naming, in particular +hyphens vs. underscores." + (define mapping + (map (lambda (file) + (match (module-formal-name file) + (#f (cons (basename file ".ko") file)) + (name (cons name file)))) + (find-files directory "\\.ko$"))) + + (call-with-output-file (string-append directory "/modules.name") + (lambda (port) + (display ";; Module name to file name mapping. +;; +;; This format is Guix-specific; it is not supported by upstream Linux tools. +\n" + port) + (pretty-print mapping port)))) + +(define (write-module-alias-database directory) + "Traverse the '.ko' files in DIRECTORY and create the corresponding +'modules.alias' file." + (define aliases + (map (lambda (file) + (cons (file-name->module-name file) (module-aliases file))) + (find-files directory "\\.ko$"))) + + (call-with-output-file (string-append directory "/modules.alias") + (lambda (port) + (display "# Aliases extracted from modules themselves.\n" port) + (for-each (match-lambda + ((module . aliases) + (for-each (lambda (alias) + (format port "alias ~a ~a\n" alias module)) + aliases))) + aliases)))) + +(define (aliases->device-tuple aliases) + "Traverse ALIASES, a list of module aliases, and search for +\"char-major-M-N\", \"block-major-M-N\", or \"devname:\" aliases. When they +are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f." + (define (char/block-major? alias) + (or (string-prefix? "char-major-" alias) + (string-prefix? "block-major-" alias))) + + (define (char/block-major->tuple alias) + (match (string-tokenize alias %not-dash) + ((type "major" (= string->number major) (= string->number minor)) + (list (match type + ("char" "c") + ("block" "b")) + major minor)))) + + (let* ((devname (any (lambda (alias) + (and (string-prefix? "devname:" alias) + (string-drop alias 8))) + aliases)) + (major/minor (match (find char/block-major? aliases) + (#f #f) + (str (char/block-major->tuple str))))) + (and devname major/minor + (cons devname major/minor)))) + +(define %not-dash + (char-set-complement (char-set #\-))) + +(define (write-module-device-database directory) + "Traverse the '.ko' files in DIRECTORY and create the corresponding +'modules.devname' file. This file contains information about modules that can +be loaded on-demand, such as file system modules." + (define aliases + (filter-map (lambda (file) + (match (aliases->device-tuple (module-aliases file)) + (#f #f) + (tuple (cons (file-name->module-name file) tuple)))) + (find-files directory "\\.ko$"))) + + (call-with-output-file (string-append directory "/modules.devname") + (lambda (port) + (display "# Device nodes to trigger on-demand module loading.\n" port) + (for-each (match-lambda + ((module devname type major minor) + (format port "~a ~a ~a~a:~a~%" + module devname type major minor))) + aliases)))) + ;;; linux-modules.scm ends here diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index cf68f2108b..14bdf4edb8 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -67,16 +67,10 @@ (file-system-mapping (source "/etc/group") (target source)))) - (define nscd-socket - (file-system-mapping - (source "/var/run/nscd") (target source) - (writable? #t))) - (append (cons (tmpfs "/tmp") %container-file-systems) (let ((mappings `(,@(if (memq 'net namespaces) '() - (cons nscd-socket - %network-file-mappings)) + %network-file-mappings) ,@(if (and (memq 'mnt namespaces) (not (memq 'user namespaces))) accounts @@ -156,14 +150,16 @@ namespace, in addition to essential bind-mounts such /proc." (when log-file ;; Create LOG-FILE so we can map it in the container. (unless (file-exists? log-file) - (call-with-output-file log-file (const #t)))) + (call-with-output-file log-file (const #t)) + (when user + (let ((pw (getpwnam user))) + (chown log-file (passwd:uid pw) (passwd:gid pw)))))) (let ((pid (run-container container-directory mounts namespaces 1 (lambda () (mkdir-p "/var/run") (clean-up pid-file) - (clean-up log-file) (exec-command command #:user user |