From 675e56221e3dfc58cac94bf30835f16a9c41d530 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 26 Jul 2020 15:34:33 +0200 Subject: file-systems: Add NTFS support. * gnu/system/uuid.scm (%ntfs-endianness): New macro, (ntfs-uuid->string): new procedure, (%ntfs-endianness): new variable, (string->ntfs-uuid): new exported procedure, (%uuid-parsers): add NTFS support, (%uuid-printers): add NTFS support. * gnu/build/file-systems.scm (%ntfs-endianness): New macro, (ntfs-superblock?, read-ntfs-superblock, ntfs-superblock-uuid, check-ntfs-file-system): new procedure, (%partition-uuid-readers): add NTFS support, (check-file-system): add NTFS support. --- gnu/build/file-systems.scm | 41 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 40 insertions(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index ad92d8a496..478c71a4e1 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -476,6 +476,42 @@ not valid header was found." (let ((uuid (sub-bytevector header 168 36))) (string->uuid (utf8->string uuid)))) + +;;; +;;; NTFS file systems. +;;; + +;; Taken from /fs/ntfs/layout.h + +(define-syntax %ntfs-endianness + ;; Endianness of NTFS file systems. + (identifier-syntax (endianness little))) + +(define (ntfs-superblock? sblock) + "Return #t when SBLOCK is a NTFS superblock." + (bytevector=? (sub-bytevector sblock 3 8) + (string->utf8 "NTFS "))) + +(define (read-ntfs-superblock device) + "Return the raw contents of DEVICE's NTFS superblock as a bytevector, or #f +if DEVICE does not contain a NTFS file system." + (read-superblock device 0 511 ntfs-superblock?)) + +(define (ntfs-superblock-uuid sblock) + "Return the UUID of NTFS superblock SBLOCK as a 8-byte bytevector." + (sub-bytevector sblock 72 8)) + +;; TODO: Add ntfs-superblock-volume-name. The partition label is not stored +;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems +;; way harder to access. + +(define (check-ntfs-file-system device) + "Return the health of a NTFS file system on DEVICE." + (match (status:exit-val + (system* "ntfsfix" device)) + (0 'pass) + (_ 'fatal-error))) + ;;; ;;; Partition lookup. @@ -585,7 +621,9 @@ partition field reader that returned a value." (partition-field-reader read-jfs-superblock jfs-superblock-uuid) (partition-field-reader read-f2fs-superblock - f2fs-superblock-uuid))) + f2fs-superblock-uuid) + (partition-field-reader read-ntfs-superblock + ntfs-superblock-uuid))) (define read-partition-label (cut read-partition-field <> %partition-label-readers)) @@ -684,6 +722,7 @@ were found." ((string-suffix? "fat" type) check-fat-file-system) ((string-prefix? "jfs" type) check-jfs-file-system) ((string-prefix? "f2fs" type) check-f2fs-file-system) + ((string-prefix? "ntfs" type) check-ntfs-file-system) ((string-prefix? "nfs" type) (const 'pass)) (else #f))) -- cgit v1.2.3 From 7c27bd115b14afd142da7684cc349369965f9eab Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 31 Jul 2020 13:43:20 +0200 Subject: file-system: Add mount-may-fail? option. * gnu/system/file-systems.scm (): Add a mount-may-fail? field. (file-system->spec): adapt accordingly, (spec->file-system): ditto. * gnu/build/file-systems.scm (mount-file-system): If 'system-error is raised and mount-may-fail? is true, ignore it. Otherwise, re-raise the exception. Signed-off-by: Mathieu Othacehe --- gnu/build/file-systems.scm | 49 ++++++++++++++++++++++++++------------------- gnu/system/file-systems.scm | 11 +++++++--- 2 files changed, 36 insertions(+), 24 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 478c71a4e1..4ba1503b9f 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -814,26 +814,33 @@ corresponds to the symbols listed in FLAGS." (when (file-system-check? fs) (check-file-system source type)) - ;; Create the mount point. Most of the time this is a directory, but - ;; in the case of a bind mount, a regular file or socket may be needed. - (if (and (= MS_BIND (logand flags MS_BIND)) - (not (file-is-directory? source))) - (unless (file-exists? mount-point) - (mkdir-p (dirname mount-point)) - (call-with-output-file mount-point (const #t))) - (mkdir-p mount-point)) - - (cond - ((string-prefix? "nfs" type) - (mount-nfs source mount-point type flags options)) - (else - (mount source mount-point type flags options))) - - ;; For read-only bind mounts, an extra remount is needed, as per - ;; , which still applies to Linux 4.0. - (when (and (= MS_BIND (logand flags MS_BIND)) - (= MS_RDONLY (logand flags MS_RDONLY))) - (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) - (mount source mount-point type flags #f))))) + (catch 'system-error + (lambda () + ;; Create the mount point. Most of the time this is a directory, but + ;; in the case of a bind mount, a regular file or socket may be + ;; needed. + (if (and (= MS_BIND (logand flags MS_BIND)) + (not (file-is-directory? source))) + (unless (file-exists? mount-point) + (mkdir-p (dirname mount-point)) + (call-with-output-file mount-point (const #t))) + (mkdir-p mount-point)) + + (cond + ((string-prefix? "nfs" type) + (mount-nfs source mount-point type flags options)) + (else + (mount source mount-point type flags options))) + + ;; For read-only bind mounts, an extra remount is needed, as per + ;; , which still applies to Linux + ;; 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) + (mount source mount-point type flags #f)))) + (lambda args + (or (file-system-mount-may-fail? fs) + (apply throw args)))))) ;;; file-systems.scm ends here diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 660f9942b0..9c5cbc9b4e 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -48,6 +48,7 @@ alist->file-system-options file-system-mount? + file-system-mount-may-fail? file-system-check? file-system-create-mount-point? file-system-dependencies @@ -114,6 +115,8 @@ (default #f)) (mount? file-system-mount? ; Boolean (default #t)) + (mount-may-fail? file-system-mount-may-fail? ; Boolean + (default #f)) (needed-for-boot? %file-system-needed-for-boot? ; Boolean (default #f)) (check? file-system-check? ; Boolean @@ -301,18 +304,19 @@ store--e.g., if FS is the root file system." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ device mount-point type flags options _ _ check?) + (($ device mount-point type flags options mount? + mount-may-fail? needed-for-boot? check?) (list (cond ((uuid? device) `(uuid ,(uuid-type device) ,(uuid-bytevector device))) ((file-system-label? device) `(file-system-label ,(file-system-label->string device))) (else device)) - mount-point type flags options check?)))) + mount-point type flags options mount-may-fail? check?)))) (define (spec->file-system sexp) "Deserialize SEXP, a list, to the corresponding object." (match sexp - ((device mount-point type flags options check?) + ((device mount-point type flags options mount-may-fail? check?) (file-system (device (match device (('uuid (? symbol? type) (? bytevector? bv)) @@ -323,6 +327,7 @@ initrd code." device))) (mount-point mount-point) (type type) (flags flags) (options options) + (mount-may-fail? mount-may-fail?) (check? check?))))) (define (specification->file-system-mapping spec writable?) -- cgit v1.2.3 From 755f365b02b42a5d1e8ef3000dadef069553a478 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sun, 5 Jul 2020 12:23:21 +0200 Subject: linux-libre: Support module compression. This commit adds support for GZIP compression for linux-libre kernel modules. The initrd modules are kept uncompressed as the initrd is already compressed as a whole. The linux-libre kernel also supports XZ compression, but as Guix does not have any available bindings for now, and the compression time is far more significant, GZIP seems to be a better option. * gnu/build/linux-modules.scm (modinfo-section-contents): Use 'call-with-gzip-input-port' to read from a module file using '.gz' extension, (strip-extension): new procedure, (dot-ko): adapt to support compression, (ensure-dot-ko): ditto, (file-name->module-name): ditto, (find-module-file): ditto, (load-linux-module*): ditto, (module-name->file-name/guess): ditto, (module-name-lookup): ditto, (write-module-name-database): ditto, (write-module-alias-database): ditto, (write-module-device-database): ditto. * gnu/installer.scm (installer-program): Add "guile-zlib" to the extensions. * gnu/machine/ssh.scm (machine-check-initrd-modules): Ditto. * gnu/services.scm (activation-script): Ditto. * gnu/services/base.scm (default-serial-port): Ditto, (agetty-shepherd-service): ditto, (udev-service-type): ditto. * gnu/system/image.scm (gcrypt-sqlite3&co): Ditto. * gnu/system/linux-initrd.scm (flat-linux-module-directory): Add "guile-zlib" to the extensions and make sure that the initrd only contains uncompressed module files. * gnu/system/shadow.scm (account-shepherd-service): Add "guile-zlib" to the extensions. * guix/profiles.scm (linux-module-database): Ditto. --- gnu/build/linux-modules.scm | 115 ++++++++---- gnu/installer.scm | 3 +- gnu/machine/ssh.scm | 35 ++-- gnu/services.scm | 46 ++--- gnu/services/base.scm | 428 ++++++++++++++++++++++---------------------- gnu/system/image.scm | 2 +- gnu/system/linux-initrd.scm | 72 +++++--- gnu/system/shadow.scm | 12 +- guix/profiles.scm | 71 ++++---- 9 files changed, 433 insertions(+), 351 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index aa1c7cfeae..3a47322065 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -24,6 +24,7 @@ #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (find-files invoke)) #:use-module (guix build union) + #:autoload (zlib) (call-with-gzip-input-port) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -94,10 +95,28 @@ 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)?$") + (define (modinfo-section-contents file) "Return the contents of the '.modinfo' section of FILE as a list of key/value pairs.." - (let* ((bv (call-with-input-file file get-bytevector-all)) + (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))))) + (else + (call-with-input-file file get-bytevector-all)))) + + (let* ((bv (get-bytevector file)) (elf (parse-elf bv)) (section (elf-section-by-name elf ".modinfo")) (modinfo (section-contents elf section))) @@ -110,7 +129,7 @@ key/value pairs.." (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." +the \".ko[.gz|.xz]\" extension." (match (assq 'name (modinfo-section-contents file)) (('name . name) name) (#f #f))) @@ -171,14 +190,25 @@ modules that can be postloaded, of the soft dependencies of module FILE." (_ #f)) (modinfo-section-contents file)))) -(define dot-ko - (cut string-append <> ".ko")) - -(define (ensure-dot-ko name) - "Return NAME with a '.ko' prefix appended, unless it already has it." - (if (string-suffix? ".ko" name) +(define (strip-extension filename) + (let ((extension (string-index filename #\.))) + (if extension + (string-take filename extension) + filename))) + +(define (dot-ko name compression) + (let ((suffix (match compression + ('xz ".ko.xz") + ('gzip ".ko.gz") + (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 +it." + (if (string-contains name ".ko") name - (dot-ko name))) + (dot-ko name compression))) (define (normalize-module-name module) "Return the \"canonical\" name for MODULE, replacing hyphens with @@ -191,9 +221,9 @@ underscores." module)) (define (file-name->module-name file) - "Return the module name corresponding to FILE, stripping the trailing '.ko' -and normalizing it." - (normalize-module-name (basename file ".ko"))) + "Return the module name corresponding to FILE, stripping the trailing +'.ko[.gz|.xz]' and normalizing it." + (normalize-module-name (strip-extension (basename file)))) (define (find-module-file directory module) "Lookup module NAME under DIRECTORY, and return its absolute file name. @@ -208,19 +238,19 @@ whereas file names often, but not always, use hyphens. Examples: ;; List of possible file names. XXX: It would of course be cleaner to ;; have a database that maps module names to file names and vice versa, ;; but everyone seems to be doing hacks like this one. Oh well! - (map ensure-dot-ko - (delete-duplicates - (list module - (normalize-module-name module) - (string-map (lambda (chr) ;converse of 'normalize-module-name' - (case chr - ((#\_) #\-) - (else chr))) - module))))) + (delete-duplicates + (list module + (normalize-module-name module) + (string-map (lambda (chr) ;converse of 'normalize-module-name' + (case chr + ((#\_) #\-) + (else chr))) + module)))) (match (find-files directory (lambda (file stat) - (member (basename file) names))) + (member (strip-extension + (basename file)) names))) ((file) file) (() @@ -290,8 +320,8 @@ 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' file; return true on -success, false otherwise. When RECURSIVE? is true, load its dependencies + "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." @@ -523,16 +553,29 @@ are required to access DEVICE." ;;; Module databases. ;;; -(define (module-name->file-name/guess directory name) +(define* (module-name->file-name/guess directory name + #:key compression) "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))) +\"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 +compression type." + (string-append directory "/" (ensure-dot-ko name compression))) (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\")." + (define (guess-file-name name) + (let ((names (list + (module-name->file-name/guess directory name) + (module-name->file-name/guess directory name + #:compression 'xz) + (module-name->file-name/guess directory name + #:compression 'gzip)))) + (or (find file-exists? names) + (first names)))) + (catch 'system-error (lambda () (define mapping @@ -541,23 +584,23 @@ always work because sometimes underscores in NAME map to hyphens (e.g., (lambda (name) (or (assoc-ref mapping name) - (module-name->file-name/guess directory name)))) + (guess-file-name name)))) (lambda args (if (= ENOENT (system-error-errno args)) - (cut module-name->file-name/guess directory <>) + (cut guess-file-name <>) (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 +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 hyphens vs. underscores." (define mapping (map (lambda (file) (match (module-formal-name file) - (#f (cons (basename file ".ko") file)) + (#f (cons (strip-extension (basename file)) file)) (name (cons name file)))) - (find-files directory "\\.ko$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.name") (lambda (port) @@ -569,12 +612,12 @@ hyphens vs. underscores." (pretty-print mapping port)))) (define (write-module-alias-database directory) - "Traverse the '.ko' files in DIRECTORY and create the corresponding + "Traverse the '.ko[.gz|.xz]' 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$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.alias") (lambda (port) @@ -616,7 +659,7 @@ 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' files in DIRECTORY and create the corresponding + "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." (define aliases @@ -624,7 +667,7 @@ be loaded on-demand, such as file system modules." (match (aliases->device-tuple (module-aliases file)) (#f #f) (tuple (cons (file-name->module-name file) tuple)))) - (find-files directory "\\.ko$"))) + (find-files directory module-regex))) (call-with-output-file (string-append directory "/modules.devname") (lambda (port) diff --git a/gnu/installer.scm b/gnu/installer.scm index 5c3192d7a6..576ac90a4b 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -342,7 +342,8 @@ selected keymap." ;; packages …), etc. modules. (with-extensions (list guile-gcrypt guile-newt guile-parted guile-bytestructures - guile-json-3 guile-git guix) + guile-json-3 guile-git guile-zlib + guix) (with-imported-modules `(,@(source-module-closure `(,@modules (gnu services herd) diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm index 4e31baa4b9..ee5032e281 100644 --- a/gnu/machine/ssh.scm +++ b/gnu/machine/ssh.scm @@ -21,6 +21,7 @@ #:use-module (gnu bootloader) #:use-module (gnu machine) #:autoload (gnu packages gnupg) (guile-gcrypt) + #:autoload (gnu packages guile) (guile-zlib) #:use-module (gnu system) #:use-module (gnu system file-systems) #:use-module (gnu system uuid) @@ -248,22 +249,24 @@ not available in the initrd." '((gnu build file-systems) (gnu build linux-modules) (gnu system uuid))) - #~(begin - (use-modules (gnu build file-systems) - (gnu build linux-modules) - (gnu system uuid)) - - (define dev - #$(cond ((string? device) device) - ((uuid? device) #~(find-partition-by-uuid - (string->uuid - #$(uuid->string device)))) - ((file-system-label? device) - #~(find-partition-by-label - #$(file-system-label->string device))))) - - (missing-modules dev '#$(operating-system-initrd-modules - (machine-operating-system machine))))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build file-systems) + (gnu build linux-modules) + (gnu system uuid)) + + (define dev + #$(cond ((string? device) device) + ((uuid? device) #~(find-partition-by-uuid + (string->uuid + #$(uuid->string device)))) + ((file-system-label? device) + #~(find-partition-by-label + #$(file-system-label->string device))))) + + (missing-modules dev + '#$(operating-system-initrd-modules + (machine-operating-system machine)))))))) (remote-let ((missing remote-exp)) (unless (null? missing) diff --git a/gnu/services.scm b/gnu/services.scm index 11ba21e824..3e59c6401f 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -35,6 +35,7 @@ #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) + #:use-module (gnu packages guile) #:use-module (gnu packages hurd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -585,28 +586,29 @@ ACTIVATION-SCRIPT-TYPE." (with-imported-modules (source-module-closure '((gnu build activation) (guix build utils))) - #~(begin - (use-modules (gnu build activation) - (guix build utils)) - - ;; Make sure the user accounting database exists. If it - ;; does not exist, 'setutxent' does not create it and - ;; thus there is no accounting at all. - (close-port (open-file "/var/run/utmpx" "a0")) - - ;; Same for 'wtmp', which is populated by mingetty et - ;; al. - (mkdir-p "/var/log") - (close-port (open-file "/var/log/wtmp" "a0")) - - ;; Set up /run/current-system. Among other things this - ;; sets up locales, which the activation snippets - ;; executed below may expect. - (activate-current-system) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If + ;; it does not exist, 'setutxent' does not create it + ;; and thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things + ;; this sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions)))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 491f35702a..966e7fe024 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -50,6 +50,7 @@ #:select (coreutils glibc glibc-utf8-locales)) #:use-module (gnu packages package-management) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages guile) #:select (guile-zlib)) #:use-module (gnu packages linux) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) @@ -836,36 +837,38 @@ the message of the day, among other things." to use as the tty. This is primarily useful for headless systems." (with-imported-modules (source-module-closure '((gnu build linux-boot))) ;for 'find-long-options' - #~(begin - ;; console=device,options - ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). - ;; options: BBBBPNF. P n|o|e, N number of bits, - ;; F flow control (r RTS) - (let* ((not-comma (char-set-complement (char-set #\,))) - (command (linux-command-line)) - (agetty-specs (find-long-options "agetty.tty" command)) - (console-specs (filter (lambda (spec) - (and (string-prefix? "tty" spec) - (not (or - (string-prefix? "tty0" spec) - (string-prefix? "tty1" spec) - (string-prefix? "tty2" spec) - (string-prefix? "tty3" spec) - (string-prefix? "tty4" spec) - (string-prefix? "tty5" spec) - (string-prefix? "tty6" spec) - (string-prefix? "tty7" spec) - (string-prefix? "tty8" spec) - (string-prefix? "tty9" spec))))) - (find-long-options "console" command))) - (specs (append agetty-specs console-specs))) - (match specs - (() #f) - ((spec _ ...) - ;; Extract device name from first spec. - (match (string-tokenize spec not-comma) - ((device-name _ ...) - device-name)))))))) + (with-extensions (list guile-zlib) + #~(begin + ;; console=device,options + ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial). + ;; options: BBBBPNF. P n|o|e, N number of bits, + ;; F flow control (r RTS) + (let* ((not-comma (char-set-complement (char-set #\,))) + (command (linux-command-line)) + (agetty-specs (find-long-options "agetty.tty" command)) + (console-specs + (filter (lambda (spec) + (and (string-prefix? "tty" spec) + (not (or + (string-prefix? "tty0" spec) + (string-prefix? "tty1" spec) + (string-prefix? "tty2" spec) + (string-prefix? "tty3" spec) + (string-prefix? "tty4" spec) + (string-prefix? "tty5" spec) + (string-prefix? "tty6" spec) + (string-prefix? "tty7" spec) + (string-prefix? "tty8" spec) + (string-prefix? "tty9" spec))))) + (find-long-options "console" command))) + (specs (append agetty-specs console-specs))) + (match specs + (() #f) + ((spec _ ...) + ;; Extract device name from first spec. + (match (string-tokenize spec not-comma) + ((device-name _ ...) + device-name))))))))) (define agetty-shepherd-service (match-lambda @@ -890,122 +893,124 @@ to use as the tty. This is primarily useful for headless systems." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - #~(lambda args - (let ((defaulted-tty #$(or tty (default-serial-port)))) - (apply - (if defaulted-tty - (make-forkexec-constructor - (list #$(file-append util-linux "/sbin/agetty") - #$@extra-options - #$@(if eight-bits? - #~("--8bits") - #~()) - #$@(if no-reset? - #~("--noreset") - #~()) - #$@(if remote? - #~("--remote") - #~()) - #$@(if flow-control? - #~("--flow-control") - #~()) - #$@(if host - #~("--host" #$host) - #~()) - #$@(if no-issue? - #~("--noissue") - #~()) - #$@(if init-string - #~("--init-string" #$init-string) - #~()) - #$@(if no-clear? - #~("--noclear") - #~()) -;;; FIXME This doesn't work as expected. According to agetty(8), if this option -;;; is not passed, then the default is 'auto'. However, in my tests, when that -;;; option is selected, agetty never presents the login prompt, and the -;;; term-ttyS0 service respawns every few seconds. - #$@(if local-line - #~(#$(match local-line - ('auto "--local-line=auto") - ('always "--local-line=always") - ('never "-local-line=never"))) - #~()) - #$@(if tty - #~() - #~("--keep-baud")) - #$@(if extract-baud? - #~("--extract-baud") - #~()) - #$@(if skip-login? - #~("--skip-login") - #~()) - #$@(if no-newline? - #~("--nonewline") - #~()) - #$@(if login-options - #~("--login-options" #$login-options) - #~()) - #$@(if chroot - #~("--chroot" #$chroot) - #~()) - #$@(if hangup? - #~("--hangup") - #~()) - #$@(if keep-baud? - #~("--keep-baud") - #~()) - #$@(if timeout - #~("--timeout" #$(number->string timeout)) - #~()) - #$@(if detect-case? - #~("--detect-case") - #~()) - #$@(if wait-cr? - #~("--wait-cr") - #~()) - #$@(if no-hints? - #~("--nohints?") - #~()) - #$@(if no-hostname? - #~("--nohostname") - #~()) - #$@(if long-hostname? - #~("--long-hostname") - #~()) - #$@(if erase-characters - #~("--erase-chars" #$erase-characters) - #~()) - #$@(if kill-characters - #~("--kill-chars" #$kill-characters) - #~()) - #$@(if chdir - #~("--chdir" #$chdir) - #~()) - #$@(if delay - #~("--delay" #$(number->string delay)) - #~()) - #$@(if nice - #~("--nice" #$(number->string nice)) - #~()) - #$@(if auto-login - (list "--autologin" auto-login) - '()) - #$@(if login-program - #~("--login-program" #$login-program) - #~()) - #$@(if login-pause? - #~("--login-pause") - #~()) - defaulted-tty - #$@(if baud-rate - #~(#$baud-rate) - #~()) - #$@(if term - #~(#$term) - #~()))) - (const #f)) ; never start. - args))))) + (with-extensions (list guile-zlib) + #~(lambda args + (let ((defaulted-tty #$(or tty (default-serial-port)))) + (apply + (if defaulted-tty + (make-forkexec-constructor + (list #$(file-append util-linux "/sbin/agetty") + #$@extra-options + #$@(if eight-bits? + #~("--8bits") + #~()) + #$@(if no-reset? + #~("--noreset") + #~()) + #$@(if remote? + #~("--remote") + #~()) + #$@(if flow-control? + #~("--flow-control") + #~()) + #$@(if host + #~("--host" #$host) + #~()) + #$@(if no-issue? + #~("--noissue") + #~()) + #$@(if init-string + #~("--init-string" #$init-string) + #~()) + #$@(if no-clear? + #~("--noclear") + #~()) +;;; FIXME This doesn't work as expected. According to agetty(8), if this +;;; option is not passed, then the default is 'auto'. However, in my tests, +;;; when that option is selected, agetty never presents the login prompt, and +;;; the term-ttyS0 service respawns every few seconds. + #$@(if local-line + #~(#$(match local-line + ('auto "--local-line=auto") + ('always "--local-line=always") + ('never "-local-line=never"))) + #~()) + #$@(if tty + #~() + #~("--keep-baud")) + #$@(if extract-baud? + #~("--extract-baud") + #~()) + #$@(if skip-login? + #~("--skip-login") + #~()) + #$@(if no-newline? + #~("--nonewline") + #~()) + #$@(if login-options + #~("--login-options" #$login-options) + #~()) + #$@(if chroot + #~("--chroot" #$chroot) + #~()) + #$@(if hangup? + #~("--hangup") + #~()) + #$@(if keep-baud? + #~("--keep-baud") + #~()) + #$@(if timeout + #~("--timeout" + #$(number->string timeout)) + #~()) + #$@(if detect-case? + #~("--detect-case") + #~()) + #$@(if wait-cr? + #~("--wait-cr") + #~()) + #$@(if no-hints? + #~("--nohints?") + #~()) + #$@(if no-hostname? + #~("--nohostname") + #~()) + #$@(if long-hostname? + #~("--long-hostname") + #~()) + #$@(if erase-characters + #~("--erase-chars" #$erase-characters) + #~()) + #$@(if kill-characters + #~("--kill-chars" #$kill-characters) + #~()) + #$@(if chdir + #~("--chdir" #$chdir) + #~()) + #$@(if delay + #~("--delay" #$(number->string delay)) + #~()) + #$@(if nice + #~("--nice" #$(number->string nice)) + #~()) + #$@(if auto-login + (list "--autologin" auto-login) + '()) + #$@(if login-program + #~("--login-program" #$login-program) + #~()) + #$@(if login-pause? + #~("--login-pause") + #~()) + defaulted-tty + #$@(if baud-rate + #~(#$baud-rate) + #~()) + #$@(if term + #~(#$term) + #~()))) + (const #f)) ; never start. + args)))))) (stop #~(make-kill-destructor))))))) (define agetty-service-type @@ -1939,70 +1944,73 @@ item of @var{packages}." (start (with-imported-modules (source-module-closure '((gnu build linux-boot))) - #~(lambda () - (define udevd - ;; 'udevd' from eudev. - #$(file-append udev "/sbin/udevd")) - - (define (wait-for-udevd) - ;; Wait until someone's listening on udevd's control - ;; socket. - (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) - (let try () - (catch 'system-error - (lambda () - (connect sock PF_UNIX "/run/udev/control") - (close-port sock)) - (lambda args - (format #t "waiting for udevd...~%") - (usleep 500000) - (try)))))) - - ;; Allow udev to find the modules. - (setenv "LINUX_MODULE_DIRECTORY" - "/run/booted-system/kernel/lib/modules") - - (let* ((kernel-release - (utsname:release (uname))) - (linux-module-directory - (getenv "LINUX_MODULE_DIRECTORY")) - (directory - (string-append linux-module-directory "/" - kernel-release)) - (old-umask (umask #o022))) - ;; If we're in a container, DIRECTORY might not exist, - ;; for instance because the host runs a different - ;; kernel. In that case, skip it; we'll just miss a few - ;; nodes like /dev/fuse. - (when (file-exists? directory) - (make-static-device-nodes directory)) - (umask old-umask)) - - (let ((pid (fork+exec-command (list udevd) - #:environment-variables - (cons* - ;; The first one is for udev, the second one for - ;; eudev. - (string-append "UDEV_CONFIG_FILE=" #$udev.conf) - (string-append "EUDEV_RULES_DIRECTORY=" - #$(file-append - rules "/lib/udev/rules.d")) - (string-append "LINUX_MODULE_DIRECTORY=" - (getenv "LINUX_MODULE_DIRECTORY")) - (default-environment-variables))))) - ;; Wait until udevd is up and running. This appears to - ;; be needed so that the events triggered below are - ;; actually handled. - (wait-for-udevd) - - ;; Trigger device node creation. - (system* #$(file-append udev "/bin/udevadm") - "trigger" "--action=add") - - ;; Wait for things to settle down. - (system* #$(file-append udev "/bin/udevadm") - "settle") - pid)))) + (with-extensions (list guile-zlib) + #~(lambda () + (define udevd + ;; 'udevd' from eudev. + #$(file-append udev "/sbin/udevd")) + + (define (wait-for-udevd) + ;; Wait until someone's listening on udevd's control + ;; socket. + (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0))) + (let try () + (catch 'system-error + (lambda () + (connect sock PF_UNIX "/run/udev/control") + (close-port sock)) + (lambda args + (format #t "waiting for udevd...~%") + (usleep 500000) + (try)))))) + + ;; Allow udev to find the modules. + (setenv "LINUX_MODULE_DIRECTORY" + "/run/booted-system/kernel/lib/modules") + + (let* ((kernel-release + (utsname:release (uname))) + (linux-module-directory + (getenv "LINUX_MODULE_DIRECTORY")) + (directory + (string-append linux-module-directory "/" + kernel-release)) + (old-umask (umask #o022))) + ;; If we're in a container, DIRECTORY might not exist, + ;; for instance because the host runs a different + ;; kernel. In that case, skip it; we'll just miss a few + ;; nodes like /dev/fuse. + (when (file-exists? directory) + (make-static-device-nodes directory)) + (umask old-umask)) + + (let ((pid + (fork+exec-command + (list udevd) + #:environment-variables + (cons* + ;; The first one is for udev, the second one for + ;; eudev. + (string-append "UDEV_CONFIG_FILE=" #$udev.conf) + (string-append "EUDEV_RULES_DIRECTORY=" + #$(file-append + rules "/lib/udev/rules.d")) + (string-append "LINUX_MODULE_DIRECTORY=" + (getenv "LINUX_MODULE_DIRECTORY")) + (default-environment-variables))))) + ;; Wait until udevd is up and running. This appears to + ;; be needed so that the events triggered below are + ;; actually handled. + (wait-for-udevd) + + ;; Trigger device node creation. + (system* #$(file-append udev "/bin/udevadm") + "trigger" "--action=add") + + ;; Wait for things to settle down. + (system* #$(file-append udev "/bin/udevadm") + "settle") + pid))))) (stop #~(make-kill-destructor)) ;; When halting the system, 'udev' is actually killed by diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 36f56e237d..19c99a3dfa 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -141,7 +141,7 @@ (match (package-transitive-propagated-inputs package) (((labels packages) ...) packages)))) - (list guile-gcrypt guile-sqlite3))) + (list guile-gcrypt guile-sqlite3 guile-zlib))) (define-syntax-rule (with-imported-modules* gexp* ...) (with-extensions gcrypt-sqlite3&co diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 0971ec29e2..b8a30c0abc 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -77,6 +77,9 @@ the derivations referenced by EXP are automatically copied to the initrd." (program-file "init" exp #:guile guile)) (define builder + ;; Do not use "guile-zlib" extension here, otherwise it would drag the + ;; non-static "zlib" package to the initrd closure. It is not needed + ;; anyway because the modules are stored uncompressed within the initrd. (with-imported-modules (source-module-closure '((gnu build linux-initrd))) #~(begin @@ -111,34 +114,49 @@ the derivations referenced by EXP are automatically copied to the initrd." (define (flat-linux-module-directory linux modules) "Return a flat directory containing the Linux kernel modules listed in MODULES and taken from LINUX." - (define build-exp - (with-imported-modules (source-module-closure - '((gnu build linux-modules))) - #~(begin - (use-modules (gnu build linux-modules) - (srfi srfi-1) - (srfi srfi-26)) - - (define module-dir - (string-append #$linux "/lib/modules")) + (define imported-modules + (source-module-closure '((gnu build linux-modules) + (guix build utils)))) - (define modules - (let* ((lookup (cut find-module-file module-dir <>)) - (modules (map lookup '#$modules))) - (append modules - (recursive-module-dependencies modules - #:lookup-module lookup)))) - - (mkdir #$output) - (for-each (lambda (module) - (format #t "copying '~a'...~%" module) - (copy-file module - (string-append #$output "/" - (basename module)))) - (delete-duplicates modules)) - - ;; Hyphen or underscore? This database tells us. - (write-module-name-database #$output)))) + (define build-exp + (with-imported-modules imported-modules + (with-extensions (list guile-zlib) + #~(begin + (use-modules (gnu build linux-modules) + (guix build utils) + (srfi srfi-1) + (srfi srfi-26)) + + (define module-dir + (string-append #$linux "/lib/modules")) + + (define modules + (let* ((lookup (cut find-module-file module-dir <>)) + (modules (map lookup '#$modules))) + (append modules + (recursive-module-dependencies + modules + #:lookup-module lookup)))) + + (define (maybe-uncompress file) + ;; If FILE is a compressed module, uncompress it, as the initrd + ;; is already gzipped as a whole. + (cond + ((string-contains file ".ko.gz") + (invoke #+(file-append gzip "/bin/gunzip") file)))) + + (mkdir #$output) + (for-each (lambda (module) + (let ((out-module + (string-append #$output "/" + (basename module)))) + (format #t "copying '~a'...~%" module) + (copy-file module out-module) + (maybe-uncompress out-module))) + (delete-duplicates modules)) + + ;; Hyphen or underscore? This database tells us. + (write-module-name-database #$output))))) (computed-file "linux-modules" build-exp)) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index a69339bc07..f642d250b0 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -34,6 +34,7 @@ #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) + #:use-module (gnu packages guile) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -324,11 +325,12 @@ accounts among ACCOUNTS+GROUPS." (start (with-imported-modules (source-module-closure '((gnu build activation) (gnu system accounts))) - #~(lambda () - (activate-user-home - (map sexp->user-account - (list #$@(map user-account->gexp accounts)))) - #t))) ;success + (with-extensions (list guile-zlib) + #~(lambda () + (activate-user-home + (map sexp->user-account + (list #$@(map user-account->gexp accounts)))) + #t)))) ;success (documentation "Create user home directories.")))) (define (shells-file shells) diff --git a/guix/profiles.scm b/guix/profiles.scm index 6b2344270e..856a05eed1 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1205,43 +1205,48 @@ and creates the dependency graph of all these kernel modules. This is meant to be used as a profile hook." (define kmod ; lazy reference (module-ref (resolve-interface '(gnu packages linux)) 'kmod)) + + (define guile-zlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define build (with-imported-modules (source-module-closure '((guix build utils) (gnu build linux-modules))) - #~(begin - (use-modules (ice-9 ftw) - (ice-9 match) - (srfi srfi-1) ; append-map - (gnu build linux-modules)) - - (let* ((inputs '#$(manifest-inputs manifest)) - (module-directories - (map (lambda (directory) - (string-append directory "/lib/modules")) - inputs)) - (directory-entries - (lambda (directory) - (or (scandir directory - (lambda (basename) - (not (string-prefix? "." basename)))) - '()))) - ;; Note: Should usually result in one entry. - (versions (delete-duplicates - (append-map directory-entries - module-directories)))) - (match versions - ((version) - (let ((old-path (getenv "PATH"))) - (setenv "PATH" #+(file-append kmod "/bin")) - (make-linux-module-directory inputs version #$output) - (setenv "PATH" old-path))) - (() - ;; Nothing here, maybe because this is a kernel with - ;; CONFIG_MODULES=n. - (mkdir #$output)) - (_ (error "Specified Linux kernel and Linux kernel modules -are not all of the same version"))))))) + (with-extensions (list guile-zlib) + #~(begin + (use-modules (ice-9 ftw) + (ice-9 match) + (srfi srfi-1) ; append-map + (gnu build linux-modules)) + + (let* ((inputs '#$(manifest-inputs manifest)) + (module-directories + (map (lambda (directory) + (string-append directory "/lib/modules")) + inputs)) + (directory-entries + (lambda (directory) + (or (scandir directory + (lambda (basename) + (not (string-prefix? "." basename)))) + '()))) + ;; Note: Should usually result in one entry. + (versions (delete-duplicates + (append-map directory-entries + module-directories)))) + (match versions + ((version) + (let ((old-path (getenv "PATH"))) + (setenv "PATH" #+(file-append kmod "/bin")) + (make-linux-module-directory inputs version #$output) + (setenv "PATH" old-path))) + (() + ;; Nothing here, maybe because this is a kernel with + ;; CONFIG_MODULES=n. + (mkdir #$output)) + (_ (error "Specified Linux kernel and Linux kernel modules +are not all of the same version")))))))) (gexp->derivation "linux-module-database" build #:local-build? #t #:substitutable? #f -- cgit v1.2.3 From ec32d4f291b3cc039a99f8090b6c2b2444be5a83 Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Sun, 30 Aug 2020 22:52:56 +0200 Subject: services: Add secret-service-type. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This adds a "secret-service" that can be added to a Childhurd VM to receive out-of-band secrets (keys) sent from the host. Co-authored-by: Ludovic Courtès * gnu/services/virtualization.scm (secret-service-activation): New procedure. (secret-service-type): New variable. * gnu/build/secret-service.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- gnu/build/secret-service.scm | 137 ++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + gnu/services/virtualization.scm | 29 ++++++++- 3 files changed, 166 insertions(+), 1 deletion(-) create mode 100644 gnu/build/secret-service.scm (limited to 'gnu/build') diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm new file mode 100644 index 0000000000..781651e90d --- /dev/null +++ b/gnu/build/secret-service.scm @@ -0,0 +1,137 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Ludovic Courtès +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen +;;; +;;; 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 . + +(define-module (gnu build secret-service) + #:use-module (guix build utils) + + #:use-module (srfi srfi-26) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + + #:export (secret-service-receive-secrets + secret-service-send-secrets)) + +;;; Commentary: +;;; +;;; Utility procedures for copying secrets into a VM. +;;; +;;; Code: + +(define* (secret-service-send-secrets port secret-root #:key (retry 60)) + "Copy all files under SECRET-ROOT using TCP to secret-service listening at +local PORT. If connect fails, sleep 1s and retry RETRY times." + + (define (file->file+size+mode file-name) + (let ((stat (stat file-name)) + (target (substring file-name (string-length secret-root)))) + (list target (stat:size stat) (stat:mode stat)))) + + (format (current-error-port) "sending secrets to ~a~%" port) + (let ((sock (socket AF_INET SOCK_STREAM 0)) + (addr (make-socket-address AF_INET INADDR_LOOPBACK port))) + ;; connect to wait for port + (let loop ((retry retry)) + (catch 'system-error + (cute connect sock addr) + (lambda (key . args) + (when (zero? retry) + (apply throw key args)) + (format (current-error-port) "retrying connection~%") + (sleep 1) + (loop (1- retry))))) + + (format (current-error-port) "connected! sending files in ~s %~" + secret-root) + (let* ((files (if secret-root (find-files secret-root) '())) + (files-sizes-modes (map file->file+size+mode files)) + (secrets `(secrets + (version 0) + (files ,files-sizes-modes)))) + (write secrets sock) + (for-each (compose (cute dump-port <> sock) + (cute open-input-file <>)) + files)))) + +(define (secret-service-receive-secrets port) + "Listen to local PORT and wait for a secret service client to send secrets. +Write them to the file system." + + (define (wait-for-client port) + ;; Wait for a TCP connection on PORT. Note: We cannot use the + ;; virtio-serial ports, which would be safer, because they are + ;; (presumably) unsupported on GNU/Hurd. + (let ((sock (socket AF_INET SOCK_STREAM 0))) + (bind sock AF_INET INADDR_ANY port) + (listen sock 1) + (format (current-error-port) + "waiting for secrets on port ~a...~%" + port) + (match (accept sock) + ((client . address) + (format (current-error-port) "client connection from ~a~%" + (inet-ntop (sockaddr:fam address) + (sockaddr:addr address))) + (close-port sock) + client)))) + + ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size' + ;; parameter. + (define (dump in out size) + ;; Copy SIZE bytes from IN to OUT. + (define buf-size 65536) + (define buf (make-bytevector buf-size)) + + (let loop ((left size)) + (if (<= left 0) + 0 + (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) + (if (eof-object? read) + left + (begin + (put-bytevector out buf 0 read) + (loop (- left read)))))))) + + (define (read-secrets port) + ;; Read secret files from PORT and install them. + (match (false-if-exception (read port)) + (('secrets ('version 0) + ('files ((files sizes modes) ...))) + (for-each (lambda (file size mode) + (format (current-error-port) + "installing file '~a' (~a bytes)...~%" + file size) + (mkdir-p (dirname file)) + (call-with-output-file file + (lambda (output) + (dump port output size) + (chmod file mode)))) + files sizes modes)) + (_ + (format (current-error-port) + "invalid secrets received~%") + #f))) + + (let* ((port (wait-for-client port)) + (result (read-secrets port))) + (close-port port) + result)) + +;;; secret-service.scm ends here diff --git a/gnu/local.mk b/gnu/local.mk index 67cc13d35e..dfb9640b47 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -659,6 +659,7 @@ GNU_SYSTEM_MODULES = \ %D%/build/linux-initrd.scm \ %D%/build/linux-modules.scm \ %D%/build/marionette.scm \ + %D%/build/secret-service.scm \ %D%/build/vm.scm \ \ %D%/tests.scm \ diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index b93ed70099..6d6734dcd1 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ryan Moe -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2020 Ludovic Courtès ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. @@ -804,6 +804,33 @@ given QEMU package." compiled for other architectures using QEMU and the @code{binfmt_misc} functionality of the kernel Linux."))) + +;;; +;;; Secrets for guest VMs. +;;; + +(define (secret-service-activation port) + "Return an activation snippet that fetches sensitive material at local PORT, +over TCP. Reboot upon failure." + (with-imported-modules '((gnu build secret-service) + (guix build utils)) + #~(begin + (use-modules (gnu build secret-service)) + (let ((sent (secret-service-receive-secrets #$port))) + (unless sent + (sleep 3) + (reboot)))))) + +(define secret-service-type + (service-type + (name 'secret-service) + (extensions (list (service-extension activation-service-type + secret-service-activation))) + (description + "This service fetches secret key and other sensitive material over TCP at +boot time. This service is meant to be used by virtual machines (VMs) that +can only be accessed by their host."))) + ;;; ;;; The Hurd in VM service: a Childhurd. -- cgit v1.2.3 From 22827396baea149f193f6e9558b522e6d9c89a44 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 12 Aug 2020 12:16:24 +0200 Subject: install: Factorize cow-store procedure. Move the cow-store procedure from the service declaration in (gnu system install) to (gnu build install), so that it can be called from within a different context than Shepherd. * gnu/build/install.scm (mount-cow-store, unmount-cow-store): New procedures. * gnu/system/install.scm (make-cow-store): Remove it, (cow-store-service-type): adapt it accordingly. --- gnu/build/install.scm | 44 +++++++++++++++++++++++++++++++++++++++++- gnu/system/install.scm | 52 ++++++++++++-------------------------------------- 2 files changed, 55 insertions(+), 41 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 87aa5d68da..63995e1d09 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build install) + #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-26) @@ -26,7 +27,9 @@ evaluate-populate-directive populate-root-file-system install-database-and-gc-roots - populate-single-profile-directory)) + populate-single-profile-directory + mount-cow-store + unmount-cow-store)) ;;; Commentary: ;;; @@ -229,4 +232,43 @@ This is used to create the self-contained tarballs with 'guix pack'." (_ #t))) +(define (mount-cow-store target backing-directory) + "Make the store copy-on-write, using TARGET as the backing store. This is +useful when TARGET is on a hard disk, whereas the current store is on a RAM +disk." + (define (set-store-permissions directory) + "Set the right perms on DIRECTORY to use it as the store." + (chown directory 0 30000) ;use the fixed 'guixbuild' GID + (chmod directory #o1775)) + + (let ((tmpdir (string-append target "/tmp"))) + (mkdir-p tmpdir) + (mount tmpdir "/tmp" "none" MS_BIND)) + + (let* ((rw-dir (string-append target backing-directory)) + (work-dir (string-append rw-dir "/../.overlayfs-workdir"))) + (mkdir-p rw-dir) + (mkdir-p work-dir) + (mkdir-p "/.rw-store") + (set-store-permissions rw-dir) + (set-store-permissions "/.rw-store") + + ;; Mount the overlay, then atomically make it the store. + (mount "none" "/.rw-store" "overlay" 0 + (string-append "lowerdir=" (%store-directory) "," + "upperdir=" rw-dir "," + "workdir=" work-dir)) + (mount "/.rw-store" (%store-directory) "" MS_MOVE) + (rmdir "/.rw-store"))) + +(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) + (rmdir tmp-dir) + (delete-file-recursively + (string-append target backing-directory)))) + ;;; install.scm ends here diff --git a/gnu/system/install.scm b/gnu/system/install.scm index a87c2f4207..be5a678cec 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -175,39 +175,6 @@ manual." ;; Sub-directory used as the backing store for copy-on-write. "/tmp/guix-inst") -(define (make-cow-store target) - "Return a gexp that makes the store copy-on-write, using TARGET as the -backing store. This is useful when TARGET is on a hard disk, whereas the -current store is on a RAM disk." - - (define (set-store-permissions directory) - ;; Set the right perms on DIRECTORY to use it as the store. - #~(begin - (chown #$directory 0 30000) ;use the fixed 'guixbuild' GID - (chmod #$directory #o1775))) - - #~(begin - ;; Bind-mount TARGET's /tmp in case we need space to build things. - (let ((tmpdir (string-append #$target "/tmp"))) - (mkdir-p tmpdir) - (mount tmpdir "/tmp" "none" MS_BIND)) - - (let* ((rw-dir (string-append target #$%backing-directory)) - (work-dir (string-append rw-dir "/../.overlayfs-workdir"))) - (mkdir-p rw-dir) - (mkdir-p work-dir) - (mkdir-p "/.rw-store") - #$(set-store-permissions #~rw-dir) - #$(set-store-permissions "/.rw-store") - - ;; Mount the overlay, then atomically make it the store. - (mount "none" "/.rw-store" "overlay" 0 - (string-append "lowerdir=" #$(%store-prefix) "," - "upperdir=" rw-dir "," - "workdir=" work-dir)) - (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE) - (rmdir "/.rw-store")))) - (define cow-store-service-type (shepherd-service-type 'cow-store @@ -222,13 +189,18 @@ the given target.") ;; This is meant to be explicitly started by the user. (auto-start? #f) - (start #~(case-lambda - ((target) - #$(make-cow-store #~target) - target) - (else - ;; Do nothing, and mark the service as stopped. - #f))) + (modules `((gnu build install) + ,@%default-modules)) + (start + (with-imported-modules (source-module-closure + '((gnu build install))) + #~(case-lambda + ((target) + (mount-cow-store target #$%backing-directory) + target) + (else + ;; Do nothing, and mark the service as stopped. + #f)))) (stop #~(lambda (target) ;; Delete the temporary directory, but leave everything ;; mounted as there may still be processes using it since -- cgit v1.2.3 From 5316dfc0f125b658e4a2acf7f00f49501663d943 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 13 Aug 2020 13:59:19 +0200 Subject: linux-container: Do not jail the container unconditionally. We may want to run a container inside the MNT namespace, without jailing the container. If RUN-CONTAINER is passed a null MOUNTS list, do not jail the container. * gnu/build/linux-container.scm (run-container): Do not call MOUNT-FILE-SYSTEMS if MOUNTS list is empty. --- gnu/build/linux-container.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 87695c98fd..21292b8d2f 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -243,7 +243,8 @@ that host UIDs (respectively GIDs) map to in the namespace." (match (read child) ('ready (purify-environment) - (when (memq 'mnt namespaces) + (when (and (not (null? mounts)) + (memq 'mnt namespaces)) (catch #t (lambda () (mount-file-systems root mounts -- cgit v1.2.3 From 8ce6f4dc2879919c12bc76a2f4b01200af97e019 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Thu, 13 Aug 2020 14:16:12 +0200 Subject: installer: Run the installation inside a container. When the store overlay is mounted, other processes such as kmscon, udev and guix-daemon may open files from the store, preventing the underlying install support from being umounted. See: https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html. To avoid this situation, mount the store overlay inside a container, and run the installation from within that container. * gnu/build/shepherd.scm (fork+exec-command/container): New procedure. * gnu/services/base.scm (guix-shepherd-service): Support an optional PID argument passed to the "start" method. If that argument is passed, ensure that guix-daemon enters the given PID MNT namespace by using fork+exec-command/container procedure. * gnu/installer/final.scm (umount-cow-store): Remove it, (install-system): run the installation from within a container. * gnu/installer/newt/final.scm (run-install-shell): Remove the display hack. --- gnu/build/shepherd.scm | 18 ++++++- gnu/installer/final.scm | 124 +++++++++++++++++++++---------------------- gnu/installer/newt/final.scm | 7 --- gnu/services/base.scm | 115 ++++++++++++++++++++++----------------- 4 files changed, 142 insertions(+), 122 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index fd93e7f3f4..65141bd60f 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -20,10 +20,12 @@ #:use-module (gnu system file-systems) #:use-module (gnu build linux-container) #:use-module (guix build utils) + #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:export (make-forkexec-constructor/container)) + #:export (make-forkexec-constructor/container + fork+exec-command/container)) ;;; Commentary: ;;; @@ -93,7 +95,8 @@ ;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency. (module-autoload! (current-module) '(shepherd service) - '(read-pid-file exec-command %precious-signals)) + '(fork+exec-command read-pid-file exec-command + %precious-signals)) (module-autoload! (current-module) '(shepherd system) '(unblock-signals)) @@ -188,6 +191,17 @@ namespace, in addition to essential bind-mounts such /proc." (read-pid-file pid-file #:max-delay pid-file-timeout)) pid)))) +(define* (fork+exec-command/container command + #:key pid + #:allow-other-keys + #:rest args) + "This is a variant of 'fork+exec-command' procedure, that joins the +namespaces of process PID beforehand." + (container-excursion* pid + (lambda () + (apply fork+exec-command command + (strip-keyword-arguments '(#:pid) args))))) + ;; Local Variables: ;; eval: (put 'container-excursion* 'scheme-indent-function 1) ;; End: diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm index 685aa81d89..11143b2adb 100644 --- a/gnu/installer/final.scm +++ b/gnu/installer/final.scm @@ -26,6 +26,8 @@ #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (gnu build accounts) + #:use-module (gnu build install) + #:use-module (gnu build linux-container) #:use-module ((gnu system shadow) #:prefix sys:) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) @@ -133,49 +135,18 @@ USERS." (_ #f)))))) pids))) -(define (umount-cow-store) - "Remove the store overlay and the bind-mount on /tmp created by the -cow-store service. This procedure is very fragile and a better approach would -be much appreciated." - (catch #t - (lambda () - (let ((tmp-dir "/remove")) - (syslog "Unmounting cow-store.~%") - - (mkdir-p tmp-dir) - (mount (%store-directory) tmp-dir "" MS_MOVE) - - ;; The guix-daemon has possibly opened files from the cow-store, - ;; restart it. - (restart-service 'guix-daemon) - - (syslog "Killing cow users.") - - ;; Kill all processes started while the cow-store was active (logins - ;; on other TTYs for instance). - (kill-cow-users tmp-dir) - - ;; Try to umount the store overlay. Some process such as udevd - ;; workers might still be active, so do some retries. - (let loop ((try 5)) - (syslog "Umount try ~a~%" (- 5 try)) - (sleep 1) - (let ((umounted? (false-if-exception (umount tmp-dir)))) - (if (and (not umounted?) (> try 0)) - (loop (- try 1)) - (if umounted? - (syslog "Umounted ~a successfully.~%" tmp-dir) - (syslog "Failed to umount ~a.~%" tmp-dir))))) - - (umount "/tmp"))) - (lambda args - (syslog "~a~%" args)))) - (define* (install-system locale #:key (users '())) "Create /etc/shadow and /etc/passwd on the installation target for USERS. Start COW-STORE service on target directory and launch guix install command in a subshell. LOCALE must be the locale name under which that command will run, or #f. Return #t on success and #f on failure." + (define backing-directory + ;; Sub-directory used as the backing store for copy-on-write. + "/tmp/guix-inst") + + (define (assert-exit x) + (primitive-exit (if x 0 1))) + (let* ((options (catch 'system-error (lambda () ;; If this file exists, it can provide @@ -188,7 +159,11 @@ or #f. Return #t on success and #f on failure." "--fallback") options (list (%installer-configuration-file) - (%installer-target-dir))))) + (%installer-target-dir)))) + (database-dir "/var/guix/db") + (database-file (string-append database-dir "/db.sqlite")) + (saved-database (string-append database-dir "/db.save")) + (ret #f)) (mkdir-p (%installer-target-dir)) ;; We want to initialize user passwords but we don't want to store them in @@ -198,27 +173,50 @@ or #f. Return #t on success and #f on failure." ;; passwords that we've put in there. (create-user-database users (%installer-target-dir)) - (dynamic-wind - (lambda () - (start-service 'cow-store (list (%installer-target-dir)))) - (lambda () - ;; If there are any connected clients, assume that we are running - ;; installation tests. In that case, dump the standard and error - ;; outputs to syslog. - (if (not (null? (current-clients))) - (with-output-to-file "/dev/console" - (lambda () - (with-error-to-file "/dev/console" - (lambda () - (setvbuf (current-output-port) 'none) - (setvbuf (current-error-port) 'none) - (run-command install-command #:locale locale))))) - (run-command install-command #:locale locale))) - (lambda () - (stop-service 'cow-store) - ;; Remove the store overlay created at cow-store service start. - ;; Failing to do that will result in further umount calls to fail - ;; because the target device is seen as busy. See: - ;; https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html. - (umount-cow-store) - #f)))) + ;; When the store overlay is mounted, other processes such as kmscon, udev + ;; and guix-daemon may open files from the store, preventing the + ;; underlying install support from being umounted. See: + ;; https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html. + ;; + ;; To avoid this situation, mount the store overlay inside a container, + ;; and run the installation from within that container. + (zero? + (call-with-container '() + (lambda () + (dynamic-wind + (lambda () + ;; Save the database, so that it can be restored once the + ;; cow-store is umounted. + (copy-file database-file saved-database) + (mount-cow-store (%installer-target-dir) backing-directory)) + (lambda () + ;; We need to drag the guix-daemon to the container MNT + ;; namespace, so that it can operate on the cow-store. + (stop-service 'guix-daemon) + (start-service 'guix-daemon (list (number->string (getpid)))) + + (setvbuf (current-output-port) 'none) + (setvbuf (current-error-port) 'none) + + ;; If there are any connected clients, assume that we are running + ;; installation tests. In that case, dump the standard and error + ;; outputs to syslog. + (set! ret + (if (not (null? (current-clients))) + (with-output-to-file "/dev/console" + (lambda () + (with-error-to-file "/dev/console" + (lambda () + (run-command install-command + #:locale locale))))) + (run-command install-command #:locale locale)))) + (lambda () + ;; Restart guix-daemon so that it does no keep the MNT namespace + ;; alive. + (restart-service 'guix-daemon) + (copy-file saved-database database-file) + + ;; Finally umount the cow-store and exit the container. + (unmount-cow-store (%installer-target-dir) backing-directory) + (assert-exit ret)))) + #:namespaces '(mnt))))) diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm index fa8d6fea71..89684c4d8a 100644 --- a/gnu/installer/newt/final.scm +++ b/gnu/installer/newt/final.scm @@ -102,13 +102,6 @@ a specific step, or restart the installer.")) #:key (users '())) (clear-screen) (newt-suspend) - ;; XXX: Force loading 'bold' font files before mouting the - ;; cow-store. Otherwise, if the file is loaded by kmscon after the cow-store - ;; in mounted, it will be necessary to kill kmscon to umount to cow-store. - (display - (colorize-string - (format #f (G_ "Installing Guix System ...~%")) - (color BOLD))) (let ((install-ok? (install-system locale #:users users))) (newt-resume) install-ok?)) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 491f35702a..d560ad5a13 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1558,57 +1558,72 @@ proxy of 'guix-daemon'...~%") (provision '(guix-daemon)) (requirement '(user-processes)) (actions (list shepherd-set-http-proxy-action)) - (modules '((srfi srfi-1))) + (modules '((srfi srfi-1) + (ice-9 match) + (gnu build shepherd))) (start - #~(lambda _ - (define proxy - ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by - ;; the 'set-http-proxy' action. - (or (getenv "http_proxy") #$http-proxy)) - - (fork+exec-command - (cons* #$(file-append guix "/bin/guix-daemon") - "--build-users-group" #$build-group - "--max-silent-time" #$(number->string max-silent-time) - "--timeout" #$(number->string timeout) - "--log-compression" #$(symbol->string log-compression) - #$@(if use-substitutes? - '() - '("--no-substitutes")) - "--substitute-urls" #$(string-join substitute-urls) - #$@extra-options - - ;; Add CHROOT-DIRECTORIES and all their dependencies - ;; (if these are store items) to the chroot. - (append-map (lambda (file) - (append-map (lambda (directory) - (list "--chroot-directory" - directory)) - (call-with-input-file file - read))) - '#$(map references-file - chroot-directories))) - - #:environment-variables - (append (list #$@(if tmpdir - (list (string-append "TMPDIR=" tmpdir)) - '()) - - ;; Make sure we run in a UTF-8 locale so that - ;; 'guix offload' correctly restores nars that - ;; contain UTF-8 file names such as - ;; 'nss-certs'. See - ;; . - (string-append "GUIX_LOCPATH=" - #$glibc-utf8-locales - "/lib/locale") - "LC_ALL=en_US.utf8") - (if proxy - (list (string-append "http_proxy=" proxy) - (string-append "https_proxy=" proxy)) - '())) - - #:log-file #$log-file))) + (with-imported-modules (source-module-closure + '((gnu build shepherd))) + #~(lambda args + (define proxy + ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by + ;; the 'set-http-proxy' action. + (or (getenv "http_proxy") #$http-proxy)) + + (fork+exec-command/container + (cons* #$(file-append guix "/bin/guix-daemon") + "--build-users-group" #$build-group + "--max-silent-time" + #$(number->string max-silent-time) + "--timeout" #$(number->string timeout) + "--log-compression" + #$(symbol->string log-compression) + #$@(if use-substitutes? + '() + '("--no-substitutes")) + "--substitute-urls" #$(string-join substitute-urls) + #$@extra-options + + ;; Add CHROOT-DIRECTORIES and all their dependencies + ;; (if these are store items) to the chroot. + (append-map + (lambda (file) + (append-map (lambda (directory) + (list "--chroot-directory" + directory)) + (call-with-input-file file + read))) + '#$(map references-file + chroot-directories))) + + ;; When running the installer, we need guix-daemon to + ;; operate from within the same MNT namespace as the + ;; installation container. In that case only, enter the + ;; namespace of the process PID passed as start argument. + #:pid (match args + ((pid) (string->number pid)) + (else (getpid))) + + #:environment-variables + (append (list #$@(if tmpdir + (list (string-append "TMPDIR=" tmpdir)) + '()) + + ;; Make sure we run in a UTF-8 locale so that + ;; 'guix offload' correctly restores nars + ;; that contain UTF-8 file names such as + ;; 'nss-certs'. See + ;; . + (string-append "GUIX_LOCPATH=" + #$glibc-utf8-locales + "/lib/locale") + "LC_ALL=en_US.utf8") + (if proxy + (list (string-append "http_proxy=" proxy) + (string-append "https_proxy=" proxy)) + '())) + + #:log-file #$log-file)))) (stop #~(make-kill-destructor)))))) (define (guix-accounts config) -- cgit v1.2.3