diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/examples/desktop.tmpl | 2 | ||||
| -rw-r--r-- | gnu/system/examples/lightweight-desktop.tmpl | 1 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 46 | ||||
| -rw-r--r-- | gnu/system/image.scm | 17 | ||||
| -rw-r--r-- | gnu/system/install.scm | 53 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 72 | ||||
| -rw-r--r-- | gnu/system/mapped-devices.scm | 36 | ||||
| -rw-r--r-- | gnu/system/uuid.scm | 37 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 3 |
9 files changed, 172 insertions, 95 deletions
diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl index 3931bad60d..716b9feb8d 100644 --- a/gnu/system/examples/desktop.tmpl +++ b/gnu/system/examples/desktop.tmpl @@ -42,9 +42,11 @@ (type "vfat"))) %base-file-systems)) + ;; Create user `bob' with `alice' as its initial password. (users (cons (user-account (name "bob") (comment "Alice's brother") + (password (crypt "alice" "$6$abc")) (group "users") (supplementary-groups '("wheel" "netdev" "audio" "video"))) diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl index 20b122fe51..b4037d4f79 100644 --- a/gnu/system/examples/lightweight-desktop.tmpl +++ b/gnu/system/examples/lightweight-desktop.tmpl @@ -4,7 +4,6 @@ (use-modules (gnu) (gnu system nss)) (use-service-modules desktop) -(use-package-modules bootloaders certs ratpoison suckless wm) (use-package-modules bootloaders certs ratpoison suckless wm xorg) (operating-system diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 0f94577760..5c02dfac93 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; @@ -28,6 +28,8 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-9 gnu) #:use-module (guix records) + #:use-module ((guix diagnostics) #:select (&fix-hint)) + #:use-module (guix i18n) #:use-module (gnu system uuid) #:re-export (uuid ;backward compatibility string->uuid @@ -46,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 @@ -66,6 +69,8 @@ %pseudo-file-system-types %fuse-control-file-system %binary-format-file-system + %debug-file-system + %efivars-file-system %shared-memory-file-system %pseudo-terminal-file-system %tty-gid @@ -111,6 +116,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 @@ -298,18 +305,21 @@ 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 - (($ <file-system> device mount-point type flags options _ _ check?) + (($ <file-system> device mount-point type flags options mount? + mount-may-fail? needed-for-boot? check?) + ;; Note: Add new fields towards the end for compatibility. (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 <file-system> object." (match sexp - ((device mount-point type flags options check?) + ((device mount-point type flags options mount-may-fail? check? + _ ...) ;placeholder for new fields (file-system (device (match device (('uuid (? symbol? type) (? bytevector? bv)) @@ -320,6 +330,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?) @@ -366,6 +377,24 @@ TARGET in the other system." (type "binfmt_misc") (check? #f))) +(define %debug-file-system + (file-system + (type "debugfs") + (device "none") + (mount-point "/sys/kernel/debug") + (check? #f) + (create-mount-point? #t))) + +(define %efivars-file-system + ;; Support for EFI variables file system. + (file-system + (device "efivarfs") + (mount-point "/sys/firmware/efi/efivars") + (type "efivarfs") + (mount-may-fail? #t) + (needed-for-boot? #f) + (check? #f))) + (define %tty-gid ;; ID of the 'tty' group. Allocate it statically to make it easy to refer ;; to it from here and from the 'tty' group definitions. @@ -465,7 +494,9 @@ TARGET in the other system." ;; List of basic file systems to be mounted. Note that /proc and /sys are ;; currently mounted by the initrd. (list %pseudo-terminal-file-system + %debug-file-system %shared-memory-file-system + %efivars-file-system %immutable-store)) ;; File systems for Linux containers differ from %base-file-systems in that @@ -613,12 +644,13 @@ store is located, else #f." ;; XXX: Deriving the subvolume name based from a subvolume ID is not ;; supported, as we'd need to query the actual file system. (or (and=> (assoc-ref options "subvol") prepend-slash/maybe) - ;; FIXME: Use &fix-hint once it no longer pulls in (guix utils). (raise (condition (&message (message "The store is on a Btrfs subvolume, but the \ -subvolume name is unknown. -Hint: Use the \"subvol\" Btrfs file system option."))))))) +subvolume name is unknown.")) + (&fix-hint + (hint + (G_ "Use the @code{subvol} Btrfs file system option.")))))))) ;;; file-systems.scm ends here diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 36f56e237d..97c7021454 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -63,7 +63,8 @@ iso9660-image find-image - system-image)) + system-image + image-with-label)) ;;; @@ -404,6 +405,20 @@ used in the image. " #:options `(#:references-graphs ,inputs #:substitutable? ,substitutable?)))) +(define (image-with-label base-image label) + "The volume ID of an ISO is the label of the first partition. This procedure +returns an image record where the first partition's label is set to <label>." + (image + (inherit base-image) + (partitions + (match (image-partitions base-image) + ((boot others ...) + (cons + (partition + (inherit boot) + (label label)) + others)))))) + ;; ;; Image creation. diff --git a/gnu/system/install.scm b/gnu/system/install.scm index d0ff2e7c52..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 @@ -497,6 +469,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m ;; elogind's cgroup file systems. (list %pseudo-terminal-file-system %shared-memory-file-system + %efivars-file-system %immutable-store))) (users (list (user-account 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/mapped-devices.scm b/gnu/system/mapped-devices.scm index c3f98302ad..31c50c4e40 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -23,8 +23,9 @@ #:use-module (guix records) #:use-module ((guix modules) #:hide (file-name->module-name)) #:use-module (guix i18n) - #:use-module ((guix utils) + #:use-module ((guix diagnostics) #:select (source-properties->location + formatted-message &fix-hint &error-location)) #:use-module (gnu services) @@ -132,13 +133,13 @@ DEVICE must be a \"/dev\" file name." ;; "usb_storage"), not file names (e.g., "usb-storage.ko"). This is ;; OK because we have machinery that accepts both the hyphen and the ;; underscore version. - (raise (condition - (&message - (message (format #f (G_ "you may need these modules \ + (raise (make-compound-condition + (formatted-message (G_ "you may need these modules \ in the initrd for ~a:~{ ~a~}") - device missing))) - (&fix-hint - (hint (format #f (G_ "Try adding them to the + device missing) + (condition + (&fix-hint + (hint (format #f (G_ "Try adding them to the @code{initrd-modules} field of your @code{operating-system} declaration, along these lines: @@ -151,9 +152,10 @@ these lines: If you think this diagnostic is inaccurate, use the @option{--skip-checks} option of @command{guix system}.\n") - missing))) - (&error-location - (location (source-properties->location location))))))) + missing)))) + (condition + (&error-location + (location (source-properties->location location)))))))) ;;; @@ -215,13 +217,13 @@ option of @command{guix system}.\n") (if (uuid? source) (match (find-partition-by-luks-uuid (uuid-bytevector source)) (#f - (raise (condition - (&message - (message (format #f (G_ "no LUKS partition with UUID '~a'") - (uuid->string source)))) - (&error-location - (location (source-properties->location - (mapped-device-location md))))))) + (raise (make-compound-condition + (formatted-message (G_ "no LUKS partition with UUID '~a'") + (uuid->string source)) + (condition + (&error-location + (location (source-properties->location + (mapped-device-location md)))))))) ((? string? device) (check-device-initrd-modules device initrd-modules location))) (check-device-initrd-modules source initrd-modules location))))) diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index bc3af69610..c8352f4933 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -45,6 +45,7 @@ string->btrfs-uuid string->fat-uuid string->jfs-uuid + string->ntfs-uuid iso9660-uuid->string ;; XXX: For lack of a better place. @@ -197,6 +198,38 @@ ISO9660 UUID representation." ;;; +;;; NTFS. +;;; + +(define-syntax %ntfs-endianness + ;; Endianness of NTFS file system. + (identifier-syntax (endianness little))) + +(define (ntfs-uuid->string uuid) + "Convert NTFS UUID, a 8-byte bytevector, to its string representation." + (format #f "~{~:@(~x~)~}" (reverse (bytevector->u8-list uuid)))) + +(define %ntfs-uuid-rx + (make-regexp "^([[:xdigit:]]{16})$")) + +(define (string->ntfs-uuid str) + "Parse STR, which is in NTFS format, and return a bytevector or #f." + (match (regexp-exec %ntfs-uuid-rx str) + (#f + #f) + (rx-match + (u8-list->bytevector + (let loop ((str str) + (res '())) + (if (string=? str "") + res + (loop (string-drop str 2) + (cons + (string->number (string-take str 2) 16) + res)))))))) + + +;;; ;;; Generic interface. ;;; @@ -220,13 +253,15 @@ ISO9660 UUID representation." (vhashq ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => string->dce-uuid) ('fat32 'fat16 'fat => string->fat-uuid) + ('ntfs => string->ntfs-uuid) ('iso9660 => string->iso9660-uuid))) (define %uuid-printers (vhashq ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => dce-uuid->string) ('iso9660 => iso9660-uuid->string) - ('fat32 'fat16 'fat => fat-uuid->string))) + ('fat32 'fat16 'fat => fat-uuid->string) + ('ntfs => ntfs-uuid->string))) (define* (string->uuid str #:optional (type 'dce)) "Parse STR as a UUID of the given TYPE. On success, return the diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 861f2a427a..80a8618729 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -699,7 +699,8 @@ of the GNU system as described by OS." (device (file-system->mount-tag source)) (type "9p") (flags (if writable? '() '(read-only))) - (options "trans=virtio,cache=loose") + (options (string-append "trans=virtio" + (if writable? "" ",cache=loose"))) (check? #f) (create-mount-point? #t))))) |