(define-module (gnu system)
#:use-module (guix inferior)
#:use-module (guix store)
+ #:use-module (guix memoization)
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module ((guix utils) #:select (substitute-keyword-arguments))
#:use-module (guix i18n)
#:use-module (guix diagnostics)
+ #:use-module (guix ui)
#:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu system uuid)
#:use-module (gnu system file-systems)
#:use-module (gnu system mapped-devices)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
#:use-module (rnrs bytevectors)
#:export (operating-system
operating-system?
(packages operating-system-packages ; list of (PACKAGE OUTPUT...)
(default %base-packages)) ; or just PACKAGE
- (timezone operating-system-timezone) ; string
+ (timezone operating-system-timezone
+ (default "Etc/UTC")) ; string
(locale operating-system-locale ; string
(default "en_US.utf8"))
(locale-definitions operating-system-locale-definitions ; list of <locale-definition>
(define* (operating-system-kernel-arguments
os root-device #:key (version %boot-parameters-version))
"Return all the kernel arguments, including the ones not specified directly
-by the user. VERSION should match that of the target <boot-parameter> record
+by the user. VERSION should match that of the target <boot-parameters> record
object that will contain the kernel parameters."
(append (bootable-kernel-arguments os root-device version)
(operating-system-user-kernel-arguments os)))
(boot-parameters-kernel-arguments params))))))
(define (boot-parameters->menu-entry conf)
+ "Return a <menu-entry> instance given CONF, a <boot-parameters> instance."
(let* ((kernel (boot-parameters-kernel conf))
(multiboot-modules (boot-parameters-multiboot-modules conf))
(multiboot? (pair? multiboot-modules)))
(service file-system-service-type
(map add-dependencies file-systems)))
+(define (boot-file-system-service os)
+ "Return a service which adds, to the system profile, packages providing the
+utilites for the file systems marked as 'needed-for-boot' in OS."
+ (let ((file-systems (filter file-system-needed-for-boot?
+ (operating-system-file-systems os))))
+ (simple-service 'boot-file-system-utilities profile-service-type
+ (file-system-utilities file-systems))))
+
(define (mapped-device-users device file-systems)
"Return the subset of FILE-SYSTEMS that use DEVICE."
(let ((targets (map (cut string-append "/dev/mapper/" <>)
(any file-system-needed-for-boot? users)))
devices)))
-(define (operating-system-bootloader-crypto-devices os)
- "Return the subset of mapped devices that the bootloader must open.
-Only devices specified by uuid are supported."
- (define (valid-crypto-device? dev)
- (or (uuid? dev)
- (begin
- (warning (G_ "\
-mapped-device '~a' may not be mounted by the bootloader.~%")
- dev)
- #f)))
- (filter-map (match-lambda
- ((and (= mapped-device-type type)
- (= mapped-device-source source))
- (and (eq? luks-device-mapping type)
- (valid-crypto-device? source)
- source))
- (_ #f))
- ;; XXX: Ordering is important, we trust the returned one.
- (operating-system-boot-mapped-devices os)))
+(define operating-system-bootloader-crypto-devices
+ (mlambdaq (os) ;to avoid duplicated output
+ "Return the sources of the LUKS mapped devices specified by UUID."
+ ;; XXX: Device ordering is important, we trust the returned one.
+ (let* ((luks-devices (filter (lambda (m)
+ (eq? luks-device-mapping
+ (mapped-device-type m)))
+ (operating-system-boot-mapped-devices os)))
+ (uuid-crypto-devices non-uuid-crypto-devices
+ (partition (compose uuid? mapped-device-source)
+ luks-devices)))
+ (when (not (null? non-uuid-crypto-devices))
+ (for-each (lambda (dev)
+ (warning
+ (source-properties->location (mapped-device-location dev))
+ (G_ "mapped device '~a' may be ignored by bootloader~%")
+ (mapped-device-source dev)))
+ non-uuid-crypto-devices)
+ (display-hint "Specify mapped device sources via their LUKS UUID."))
+ (map mapped-device-source uuid-crypto-devices))))
(define (device-mapping-services os)
"Return the list of device-mapping services for OS as a list."
(define known-fs
(map file-system-mount-point (operating-system-file-systems os)))
- (let* ((mappings (device-mapping-services os))
- (root-fs (root-file-system-service))
- (other-fs (non-boot-file-system-service os))
- (swaps (swap-services os))
- (procs (service user-processes-service-type))
- (host-name (host-name-service (operating-system-host-name os)))
- (entries (operating-system-directory-base-entries os)))
+ (let* ((mappings (device-mapping-services os))
+ (root-fs (root-file-system-service))
+ (boot-fs (boot-file-system-service os))
+ (non-boot-fs (non-boot-file-system-service os))
+ (swaps (swap-services os))
+ (procs (service user-processes-service-type))
+ (host-name (host-name-service (operating-system-host-name os)))
+ (entries (operating-system-directory-base-entries os)))
(cons* (service system-service-type entries)
(service linux-builder-service-type
(linux-builder-configuration
(operating-system-setuid-programs os))
(service profile-service-type
(operating-system-packages os))
- other-fs
+ boot-fs non-boot-fs
(append mappings swaps
;; Add the firmware service.
%boot-service
%hurd-startup-service
%activation-service
- %shepherd-root-service
+ (service shepherd-root-service-type
+ (shepherd-configuration
+ (shepherd shepherd-0.8))) ;no Fibers
+
(service user-processes-service-type)
(account-service (append (operating-system-accounts os)
(operating-system-groups os))
iw wireless-tools))
(define %base-packages-disk-utilities
- ;; A well-rounded set of packages for interacting with disks, partitions
- ;; and filesystems.
+ ;; A well-rounded set of packages for interacting with disks,
+ ;; partitions and filesystems, included with the Guix installation
+ ;; image.
(list parted gptfdisk ddrescue
;; We used to provide fdisk from GNU fdisk, but as of version 2.0.0a
;; it pulls Guile 1.8, which takes unreasonable space; furthermore
(define %base-packages
;; Default set of packages globally visible. It should include anything
;; required for basic administrator tasks.
- (append (list e2fsprogs)
- %base-packages-artwork
+ (append %base-packages-artwork
%base-packages-interactive
%base-packages-linux
%base-packages-networking
(file-append sudo "/bin/sudo")
(file-append sudo "/bin/sudoedit")
(file-append fuse "/bin/fusermount")
+ (file-append fuse-3 "/bin/fusermount3")
;; To allow mounts with the "user" option, "mount" and "umount" must
;; be setuid-root.
(lambda (store)
;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
;; 'operating-system-derivation'.
- (run-with-store store (operating-system-derivation os)
- #:system system
- #:target target)))))
+ (parameterize ((%current-system system)
+ (%current-target-system target))
+ (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (operating-system-derivation os))
+ #:system system
+ #:target target))))))
;;; system.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff