diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/activation.scm | 87 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 103 | ||||
| -rw-r--r-- | gnu/build/image.scm | 14 | ||||
| -rw-r--r-- | gnu/build/linux-modules.scm | 62 |
4 files changed, 194 insertions, 72 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index d8c0cd22a3..a57ca78a86 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr> ;;; ;;; This file is part of GNU Guix. @@ -27,7 +28,7 @@ (define-module (gnu build activation) #:use-module (gnu system accounts) - #:use-module (gnu system setuid) + #:use-module (gnu system privilege) #:use-module (gnu build accounts) #:use-module (gnu build linux-boot) #:use-module (guix build utils) @@ -41,7 +42,7 @@ #:export (activate-users+groups activate-user-home activate-etc - activate-setuid-programs + activate-privileged-programs activate-special-files activate-modprobe activate-firmware @@ -279,56 +280,80 @@ they already exist." string<?))) (define %setuid-directory - ;; Place where setuid programs are stored. + ;; Place where setuid programs used to be stored. It exists for backwards + ;; compatibility & will be removed. Use %PRIVILEGED-PROGRAM-DIRECTORY instead. "/run/setuid-programs") -(define (activate-setuid-programs programs) - "Turn PROGRAMS, a list of file setuid-programs record, into setuid programs -stored under %SETUID-DIRECTORY." - (define (make-setuid-program program setuid? setgid? uid gid) - (let ((target (string-append %setuid-directory +(define %privileged-program-directory + ;; Place where privileged copies of programs are stored. + "/run/privileged/bin") + +(define (activate-privileged-programs programs libcap) + "Turn PROGRAMS, a list of file privileged-programs records, into privileged +copies stored under %PRIVILEGED-PROGRAM-DIRECTORY, using LIBCAP's setcap(8) +binary if needed." + (define (ensure-empty-directory directory) + (if (file-exists? directory) + (for-each (compose delete-file + (cut string-append directory "/" <>)) + (scandir directory + (lambda (file) + (not (member file '("." "..")))) + string<?)) + (mkdir-p directory)) ) + + (define (make-privileged-program program setuid? setgid? uid gid capabilities) + (let ((target (string-append %privileged-program-directory "/" (basename program))) (mode (+ #o0555 ; base permissions (if setuid? #o4000 0) ; setuid bit (if setgid? #o2000 0)))) ; setgid bit (copy-file program target) (chown target uid gid) - (chmod target mode))) - - (format #t "setting up setuid programs in '~a'...~%" - %setuid-directory) - (if (file-exists? %setuid-directory) - (for-each (compose delete-file - (cut string-append %setuid-directory "/" <>)) - (scandir %setuid-directory - (lambda (file) - (not (member file '("." "..")))) - string<?)) - (mkdir-p %setuid-directory)) + (chmod target mode) + (when (and capabilities libcap) + (system* (string-append libcap "/sbin/setcap") + "-q" capabilities target)))) + + (define (make-deprecated-wrapper program) + ;; This will eventually become a script that warns on usage, then vanish. + (symlink (string-append %privileged-program-directory + "/" (basename program)) + (string-append %setuid-directory + "/" (basename program)))) + + (format #t "setting up privileged programs in '~a'...~%" + %privileged-program-directory) + (ensure-empty-directory %privileged-program-directory) + (ensure-empty-directory %setuid-directory) (for-each (lambda (program) (catch 'system-error (lambda () - (let* ((program-name (setuid-program-program program)) - (setuid? (setuid-program-setuid? program)) - (setgid? (setuid-program-setgid? program)) - (user (setuid-program-user program)) - (group (setuid-program-group program)) + (let* ((program-name (privileged-program-program program)) + (setuid? (privileged-program-setuid? program)) + (setgid? (privileged-program-setgid? program)) + (user (privileged-program-user program)) + (group (privileged-program-group program)) + (capabilities (privileged-program-capabilities program)) (uid (match user ((? string?) (passwd:uid (getpwnam user))) ((? integer?) user))) (gid (match group ((? string?) (group:gid (getgrnam group))) ((? integer?) group)))) - (make-setuid-program program-name setuid? setgid? uid gid))) + (make-privileged-program program-name + setuid? setgid? uid gid + capabilities) + (make-deprecated-wrapper program-name))) (lambda args - ;; If we fail to create a setuid program, better keep going - ;; so that we don't leave %SETUID-DIRECTORY empty or - ;; half-populated. This can happen if PROGRAMS contains + ;; If we fail to create a privileged program, better keep going + ;; so that we don't leave %PRIVILEGED-PROGRAM-DIRECTORY empty + ;; or half-populated. This can happen if PROGRAMS contains ;; incorrect file names: <https://bugs.gnu.org/38800>. (format (current-error-port) - "warning: failed to make ~s setuid/setgid: ~a~%" - (setuid-program-program program) + "warning: failed to privilege ~s: ~a~%" + (privileged-program-program program) (strerror (system-error-errno args)))))) programs)) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 78d779f398..9ceb2fda4e 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr> +;;; Copyright © 2024 Richard Sent <richard@freakingpenguin.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,6 +38,8 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 string-fun) #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) @@ -1047,8 +1050,11 @@ file name or an nfs-root containing ':/')." (match spec ((? string?) - (if (or (string-contains spec ":/") (string=? spec "none")) - spec ; do not resolve NFS / tmpfs devices + (if (or (string-contains spec ":/") ;nfs + (and (>= (string-length spec) 2) + (equal? (string-take spec 2) "//")) ;cifs + (string=? spec "none")) + spec ; do not resolve NFS / CIFS / tmpfs devices ;; Nothing to do, but wait until SPEC shows up. (resolve identity spec identity))) ((? file-system-label?) @@ -1078,6 +1084,7 @@ an exception in such cases but perform the nearest sane action." ((string-prefix? "f2fs" type) check-f2fs-file-system) ((string-prefix? "ntfs" type) check-ntfs-file-system) ((string-prefix? "nfs" type) (const 'pass)) + ((string-prefix? "cifs" type) (const 'pass)) ((string-prefix? "xfs" type) check-xfs-file-system) (else #f))) @@ -1156,6 +1163,14 @@ corresponds to the symbols listed in FLAGS." (repair (file-system-repair fs))) "Mount the file system described by FS, a <file-system> object, under ROOT." + (define* (host-to-ip host #:optional service) + "Return the IP address for host, which may be an IP address or a hostname." + (let* ((aa (match (getaddrinfo host service) ((x . _) x))) + (sa (addrinfo:addr aa)) + (inet-addr (inet-ntop (sockaddr:fam sa) + (sockaddr:addr sa)))) + inet-addr)) + (define (mount-nfs source mount-point type flags options) (let* ((idx (string-rindex source #\:)) (host-part (string-take source idx)) @@ -1163,11 +1178,7 @@ corresponds to the symbols listed in FLAGS." (host (match (string-split host-part (string->char-set "[]")) (("" h "") h) ((h) h))) - (aa (match (getaddrinfo host "nfs") ((x . _) x))) - (sa (addrinfo:addr aa)) - (inet-addr (inet-ntop (sockaddr:fam sa) - (sockaddr:addr sa)))) - + (inet-addr (host-to-ip host "nfs"))) ;; Mounting an NFS file system requires passing the address ;; of the server in the addr= option (mount source mount-point type flags @@ -1176,6 +1187,82 @@ corresponds to the symbols listed in FLAGS." (if options (string-append "," options) ""))))) + + (define (read-cifs-credential-file file) + ;; Read password, user and domain options from file + ;; + ;; XXX: As of version 7.0, mount.cifs strips all lines of leading + ;; whitespace, parses those starting with "pass", "user" and "dom" into + ;; "pass=", "user=" and "domain=" options respectively and ignores + ;; everything else. To simplify the implementation, we pass those lines + ;; as is. As a consequence, the "password2" option can be specified in a + ;; credential file with the expected semantics (see: + ;; https://issues.guix.gnu.org/71594#3). + (with-input-from-file file + (lambda () + (let loop + ((next-line (read-line)) + (lines '())) + (match next-line + ((? eof-object?) + lines) + ((= string-trim line) + (loop (read-line) + (cond + ((string-prefix? "pass" line) + ;; mount.cifs escapes commas in the password by doubling + ;; them + (cons (string-replace-substring line "," ",,") + lines)) + ((or (string-prefix? "user" line) + (string-prefix? "dom" line)) + (cons line lines)) + ;; Ignore all other lines. + (else + lines))))))))) + + (define (mount-cifs source mount-point type flags options) + ;; Source is of form "//<server-ip-or-host>/<service>" + (let* ((regex-match (string-match "//([^/]+)/(.+)" source)) + (server (match:substring regex-match 1)) + (share (match:substring regex-match 2)) + ;; Match ",guest,", ",guest$", "^guest,", or "^guest$," not + ;; e.g. user=foo,pass=notaguest + (guest? (string-match "(^|,)(guest)($|,)" options)) + (credential-file (and=> (string-match "(^|,)(credentials|cred)=([^,]+)(,|$)" + options) + (cut match:substring <> 3))) + ;; Perform DNS resolution now instead of attempting kernel dns + ;; resolver upcalling. /sbin/request-key does not exist and the + ;; kernel hardcodes the path. + ;; + ;; (getaddrinfo) doesn't support cifs service, so omit it. + (inet-addr (host-to-ip server))) + (mount source mount-point type flags + (string-append "ip=" + inet-addr + ;; As of Linux af1a3d2ba9 (v5.11) unc is ignored + ;; and source is parsed by the kernel + ;; directly. Pass it for compatibility. + ",unc=" + ;; Match format of mount.cifs's mount syscall. + "\\\\" server "\\" share + (if guest? + ",user=,pass=" + "") + (if options + ;; No need to delete "guest" from options. + ;; linux/fs/smb/client/fs_context.c explicitly + ;; ignores it. Also, avoiding excess commas + ;; when deleting is a pain. + (string-append "," options) + "") + (if credential-file + ;; The "credentials" option is ignored too. + (string-join (read-cifs-credential-file credential-file) + "," 'prefix) + ""))))) + (let* ((type (file-system-type fs)) (source (canonicalize-device-spec (file-system-device fs))) (target (string-append root "/" @@ -1210,6 +1297,8 @@ corresponds to the symbols listed in FLAGS." (cond ((string-prefix? "nfs" type) (mount-nfs source target type flags options)) + ((string-prefix? "cifs" type) + (mount-cifs source target type flags options)) ((memq 'shared (file-system-flags fs)) (mount source target type flags options) (mount "none" target #f MS_SHARED)) diff --git a/gnu/build/image.scm b/gnu/build/image.scm index 49dc01c0d1..6ca0a428e0 100644 --- a/gnu/build/image.scm +++ b/gnu/build/image.scm @@ -328,18 +328,16 @@ GRUB configuration and OS-DRV as the stuff in it." "-volume_date" "all_file_dates" "=1" `(,@(if compression? - '(;; ‘zisofs’ compression reduces the total image size by - ;; ~60%. + '(;; ‘zisofs’ compression reduces the total image size by ~60%. "-zisofs" "level=9:block_size=128k" ; highest compression ;; It's transparent to our Linux-Libre kernel but not to - ;; GRUB. Don't compress the kernel, initrd, and other - ;; files read by grub.cfg, as well as common - ;; already-compressed file names. + ;; GRUB. Don't compress the kernel, initrd, and other files + ;; read by grub.cfg, as well as common already-compressed + ;; file names. "-find" "/" "-type" "f" ;; XXX Even after "--" above, and despite documentation - ;; claiming otherwise, "-or" is stolen by grub-mkrescue - ;; which then chokes on it (as ‘-o …’) and dies. Don't use - ;; "-or". + ;; claiming otherwise, "-or" is stolen by grub-mkrescue which + ;; then chokes on it (as ‘-o …’) and dies. Don't use "-or". "-not" "-wholename" "/boot/*" "-not" "-wholename" "/System/*" "-not" "-name" "unicode.pf2" diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index 68c32ff873..32baf6c525 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2023 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module ((guix build utils) #:select (find-files invoke)) #:use-module (guix build union) #:autoload (zlib) (call-with-gzip-input-port) + #:autoload (zstd) (call-with-zstd-input-port) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -108,24 +110,29 @@ string list." (cons (string->symbol (string-take str =)) (string-drop str (+ 1 =))))) -;; Matches kernel modules, without compression, with GZIP compression or with -;; XZ compression. -(define module-regex "\\.ko(\\.gz|\\.xz)?$") +;; Matches kernel modules, without compression, with GZIP, XZ or ZSTD +;; compression. +(define module-regex "\\.ko(\\.gz|\\.xz|\\.zst)?$") (define (modinfo-section-contents file) "Return the contents of the '.modinfo' section of FILE as a list of key/value pairs.." + (define (decompress-file decompressor file) + (let ((port (open-file file "r0"))) + (dynamic-wind + (lambda () + #t) + (lambda () + (decompressor port get-bytevector-all)) + (lambda () + (close-port port))))) + (define (get-bytevector file) (cond ((string-suffix? ".ko.gz" file) - (let ((port (open-file file "r0"))) - (dynamic-wind - (lambda () - #t) - (lambda () - (call-with-gzip-input-port port get-bytevector-all)) - (lambda () - (close-port port))))) + (decompress-file call-with-gzip-input-port file)) + ((string-suffix? ".ko.zst" file) + (decompress-file call-with-zstd-input-port file)) (else (call-with-input-file file get-bytevector-all)))) @@ -213,11 +220,12 @@ modules that can be postloaded, of the soft dependencies of module FILE." (let ((suffix (match compression ('xz ".ko.xz") ('gzip ".ko.gz") + ('zstd ".ko.zst") (else ".ko")))) (string-append name suffix))) (define (ensure-dot-ko name compression) - "Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has + "Return NAME with a '.ko[.gz|.xz|.zst]' suffix appended, unless it already has it." (if (string-contains name ".ko") name @@ -235,7 +243,7 @@ underscores." (define (file-name->module-name file) "Return the module name corresponding to FILE, stripping the trailing -'.ko[.gz|.xz]' and normalizing it." +'.ko[.gz|.xz|.zst]' and normalizing it." (normalize-module-name (strip-extension (basename file)))) (define (find-module-file directory module) @@ -333,11 +341,11 @@ not a file name." (recursive? #t) (lookup-module dot-ko) (black-list (module-black-list))) - "Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true -on success, false otherwise. When RECURSIVE? is true, load its dependencies -first (à la 'modprobe'.) The actual files containing modules depended on are -obtained by calling LOOKUP-MODULE with the module name. Modules whose name -appears in BLACK-LIST are not loaded." + "Load Linux module from FILE, the name of a '.ko[.gz|.xz|.zst]' file; return +true on success, false otherwise. When RECURSIVE? is true, load its +dependencies first (à la 'modprobe'.) The actual files containing modules +depended on are obtained by calling LOOKUP-MODULE with the module name. +Modules whose name appears in BLACK-LIST are not loaded." (define (black-listed? module) (let ((result (member module black-list))) (when result @@ -695,7 +703,7 @@ are required to access DEVICE." "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\"). If the module is -compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the +compressed then COMPRESSED can be set to 'zstd, 'xz or 'gzip, depending on the compression type." (string-append directory "/" (ensure-dot-ko name compression))) @@ -707,6 +715,8 @@ compression type." (let ((names (list (module-name->file-name/guess directory name) (module-name->file-name/guess directory name + #:compression 'zstd) + (module-name->file-name/guess directory name #:compression 'xz) (module-name->file-name/guess directory name #:compression 'gzip)))) @@ -729,8 +739,8 @@ compression type." (define (write-module-name-database directory) "Write a database that maps \"module names\" as they appear in the relevant -ELF section of '.ko[.gz|.xz]' files, to actual file names. This format is -Guix-specific. It aims to deal with inconsistent naming, in particular +ELF section of '.ko[.gz|.xz|.zst]' 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) @@ -749,8 +759,8 @@ hyphens vs. underscores." (pretty-print mapping port)))) (define (write-module-alias-database directory) - "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding -'modules.alias' file." + "Traverse the '.ko[.gz|.xz|.zst]' files in DIRECTORY and create the +corresponding 'modules.alias' file." (define aliases (map (lambda (file) (cons (file-name->module-name file) (module-aliases file))) @@ -796,9 +806,9 @@ are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f." (char-set-complement (char-set #\-))) (define (write-module-device-database directory) - "Traverse the '.ko[.gz|.xz]' 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." + "Traverse the '.ko[.gz|.xz|.zst]' 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)) |