;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services base)
- #:use-module (gnu system grub)
+ #:use-module (gnu bootloader)
#:use-module (gnu system shadow)
#:use-module (gnu system nss)
#:use-module (gnu system locale)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (rnrs bytevectors)
#:export (operating-system
operating-system?
operating-system-derivation
operating-system-profile
- operating-system-grub.cfg
+ operating-system-bootcfg
operating-system-etc-directory
operating-system-locale-directory
operating-system-boot-script
+ system-linux-image-file-name
+
boot-parameters
boot-parameters?
boot-parameters-label
boot-parameters-root-device
+ boot-parameters-bootloader-name
+ boot-parameters-store-device
+ boot-parameters-store-mount-point
boot-parameters-kernel
boot-parameters-kernel-arguments
+ boot-parameters-initrd
read-boot-parameters
+ read-boot-parameters-file
+ menu-entry->boot-parameters
local-host-aliases
%setuid-programs
;;;
;;; Code:
+(define (bootable-kernel-arguments kernel-arguments system.drv root-device)
+ "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be
+booted from ROOT-DEVICE"
+ (cons* (string-append "--root=" root-device)
+ #~(string-append "--system=" #$system.drv)
+ #~(string-append "--load=" #$system.drv "/boot")
+ kernel-arguments))
+
;; System-wide configuration.
;; TODO: Add per-field docstrings/stexi.
(define-record-type* <operating-system> operating-system
operating-system?
(kernel operating-system-kernel ; package
(default linux-libre))
- (kernel-arguments operating-system-kernel-arguments
+ (kernel-arguments operating-system-user-kernel-arguments
(default '())) ; list of gexps/strings
- (bootloader operating-system-bootloader) ; <grub-configuration>
+ (bootloader operating-system-bootloader) ; <bootloader-configuration>
(initrd operating-system-initrd ; (list fs) -> M derivation
(default base-initrd))
(sudoers-file operating-system-sudoers-file ; file-like
(default %sudoers-specification)))
+(define (operating-system-kernel-arguments os system.drv root-device)
+ "Return all the kernel arguments, including the ones not specified
+directly by the user."
+ (bootable-kernel-arguments (operating-system-user-kernel-arguments os)
+ system.drv
+ root-device))
+
+\f
+;;;
+;;; Boot parameters
+;;;
+
+(define-record-type* <boot-parameters>
+ boot-parameters make-boot-parameters boot-parameters?
+ (label boot-parameters-label)
+ ;; Because we will use the 'store-device' to create the GRUB search command,
+ ;; the 'store-device' has slightly different semantics than 'root-device'.
+ ;; The 'store-device' can be a file system uuid, a file system label, or #f,
+ ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not
+ ;; understand that. The 'root-device', on the other hand, corresponds
+ ;; exactly to the device field of the <file-system> object representing the
+ ;; OS's root file system, so it might be a device path like "/dev/sda3".
+ (root-device boot-parameters-root-device)
+ (bootloader-name boot-parameters-bootloader-name)
+ (store-device boot-parameters-store-device)
+ (store-mount-point boot-parameters-store-mount-point)
+ (kernel boot-parameters-kernel)
+ (kernel-arguments boot-parameters-kernel-arguments)
+ (initrd boot-parameters-initrd))
+
+(define (read-boot-parameters port)
+ "Read boot parameters from PORT and return the corresponding
+<boot-parameters> object or #f if the format is unrecognized."
+ (match (read port)
+ (('boot-parameters ('version 0)
+ ('label label) ('root-device root)
+ ('kernel linux)
+ rest ...)
+ (boot-parameters
+ (label label)
+ (root-device root)
+
+ (bootloader-name
+ (match (assq 'bootloader-name rest)
+ ((_ args) args)
+ (#f 'grub))) ; for compatibility reasons.
+
+ ;; In the past, we would store the directory name of the kernel instead
+ ;; of the absolute file name of its image. Detect that and correct it.
+ (kernel (if (string=? linux (direct-store-path linux))
+ (string-append linux "/"
+ (system-linux-image-file-name))
+ linux))
+
+ (kernel-arguments
+ (match (assq 'kernel-arguments rest)
+ ((_ args) args)
+ (#f '()))) ;the old format
+
+ (initrd
+ (match (assq 'initrd rest)
+ (('initrd ('string-append directory file)) ;the old format
+ (string-append directory file))
+ (('initrd (? string? file))
+ file)))
+
+ (store-device
+ (match (assq 'store rest)
+ (('store ('device device) _ ...)
+ device)
+ (_ ;the old format
+ ;; Root might be a device path like "/dev/sda1", which is not a
+ ;; suitable GRUB device identifier.
+ (if (string-prefix? "/" root)
+ #f
+ root))))
+
+ (store-mount-point
+ (match (assq 'store rest)
+ (('store ('device _) ('mount-point mount-point) _ ...)
+ mount-point)
+ (_ ;the old format
+ "/")))))
+ (x ;unsupported format
+ (warning (G_ "unrecognized boot parameters for '~a'~%")
+ system)
+ #f)))
+
+(define (read-boot-parameters-file system)
+ "Read boot parameters from SYSTEM's (system or generation) \"parameters\"
+file and returns the corresponding <boot-parameters> object or #f if the
+format is unrecognized.
+The object has its kernel-arguments extended in order to make it bootable."
+ (let* ((file (string-append system "/parameters"))
+ (params (call-with-input-file file read-boot-parameters))
+ (root (boot-parameters-root-device params))
+ (root-device (if (bytevector? root)
+ (uuid->string root)
+ root))
+ (kernel-arguments (boot-parameters-kernel-arguments params)))
+ (if params
+ (boot-parameters
+ (inherit params)
+ (kernel-arguments (bootable-kernel-arguments kernel-arguments
+ system
+ root-device)))
+ #f)))
+
+(define (menu-entry->boot-parameters menu-entry)
+ "Convert a <menu-entry> instance to a corresponding <boot-parameters>."
+ (boot-parameters
+ (label (menu-entry-label menu-entry))
+ (root-device #f)
+ (bootloader-name 'custom)
+ (store-device #f)
+ (store-mount-point #f)
+ (kernel (menu-entry-linux menu-entry))
+ (kernel-arguments (menu-entry-linux-arguments menu-entry))
+ (initrd (menu-entry-initrd menu-entry))))
+
\f
;;;
;;; Services.
(define* (system-linux-image-file-name #:optional (system (%current-system)))
"Return the basename of the kernel image file for SYSTEM."
;; FIXME: Evaluate the conditional based on the actual current system.
- (if (string-prefix? "mips" (%current-system))
- "vmlinuz"
- "bzImage"))
+ (cond
+ ((string-prefix? "arm" (%current-system)) "zImage")
+ ((string-prefix? "mips" (%current-system)) "vmlinuz")
+ ((string-prefix? "aarch64" (%current-system)) "Image")
+ (else "bzImage")))
(define (operating-system-kernel-file os)
"Return an object representing the absolute file name of the kernel image of
(define* (operating-system-directory-base-entries os #:key container?)
"Return the basic entries of the 'system' directory of OS for use as the
value of the SYSTEM-SERVICE-TYPE service."
- (mlet %store-monad ((locale (operating-system-locale-directory os)))
- (if container?
- (return `(("locale" ,locale)))
- (mlet %store-monad
- ((kernel -> (operating-system-kernel os))
- (initrd (operating-system-initrd-file os))
- (params (operating-system-parameters-file os)))
- (return `(("kernel" ,kernel)
- ("parameters" ,params)
- ("initrd" ,initrd)
- ("locale" ,locale))))))) ;used by libc
+ (let ((locale (operating-system-locale-directory os)))
+ (with-monad %store-monad
+ (if container?
+ (return `(("locale" ,locale)))
+ (mlet %store-monad
+ ((kernel -> (operating-system-kernel os))
+ (initrd (operating-system-initrd-file os))
+ (params (operating-system-boot-parameters-file os)))
+ (return `(("kernel" ,kernel)
+ ("parameters" ,params)
+ ("initrd" ,initrd)
+ ("locale" ,locale)))))))) ;used by libc
(define* (essential-services os #:key container?)
"Return the list of essential services for OS. These are special services
(other-fs (non-boot-file-system-service os))
(unmount (user-unmount-service known-fs))
(swaps (swap-services os))
- (procs (user-processes-service
- (service-parameters other-fs)))
+ (procs (user-processes-service))
(host-name (host-name-service (operating-system-host-name os)))
(entries (operating-system-directory-base-entries
os #:container? container?)))
(define %base-firmware
;; Firmware usable by default.
- (list ath9k-htc-firmware))
+ (list ath9k-htc-firmware
+ openfwwf-firmware))
(define %base-packages
;; Default set of packages globally visible. It should include anything
lsof ;for Guix's 'list-runtime-roots'
pciutils usbutils
util-linux inetutils isc-dhcp
+ (@ (gnu packages admin) shadow) ;for 'passwd'
;; wireless-tools is deprecated in favor of iw, but it's still what
;; many people are familiar with, so keep it around.
;; The packages below are also in %FINAL-INPUTS, so take them from
;; there to avoid duplication.
(map canonical-package
- (list guile-2.0 bash coreutils findutils grep sed
+ (list guile-2.2 bash coreutils-8.27 findutils grep sed
diffutils patch gawk tar gzip bzip2 xz lzip))))
(define %default-issue
source /run/current-system/profile/etc/profile.d/bash_completion.sh
fi\n")))
(etc-service
- `(("services" ,#~(string-append #$net-base "/etc/services"))
- ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
- ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
+ `(("services" ,(file-append net-base "/etc/services"))
+ ("protocols" ,(file-append net-base "/etc/protocols"))
+ ("rpc" ,(file-append net-base "/etc/rpc"))
("login.defs" ,#~#$login.defs)
("issue" ,#~#$issue)
("nsswitch.conf" ,#~#$nsswitch)
("bashrc" ,#~#$bashrc)
("hosts" ,#~#$(or (operating-system-hosts-file os)
(default-/etc/hosts (operating-system-host-name os))))
- ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
- #$(operating-system-timezone os)))
+ ("localtime" ,(file-append tzdata "/share/zoneinfo/"
+ (operating-system-timezone os)))
("sudoers" ,(operating-system-sudoers-file os))))))
(define %root-account
now file-like objects.."
(match thing
((? string?)
- (warning (_ "using a string for file '~a' is deprecated; \
+ (warning (G_ "using a string for file '~a' is deprecated; \
use 'plain-file' instead~%")
file-name)
(plain-file file-name thing))
(with-monad %store-monad
(match thing
((? procedure?)
- (warning (_ "using a monadic value for '~a' is deprecated; \
+ (warning (G_ "using a monadic value for '~a' is deprecated; \
use 'plain-file' instead~%")
file-name)
thing)
@var{session-environment-service-type}, to be used in @file{/etc/environment}."
`(("LANG" . ,(operating-system-locale os))
("TZ" . ,(operating-system-timezone os))
- ("TZDIR" . ,#~(string-append #$tzdata "/share/zoneinfo"))
+ ("TZDIR" . ,(file-append tzdata "/share/zoneinfo"))
;; Tell 'modprobe' & co. where to look for modules.
("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
;; These variables are honored by OpenSSL (libssl) and Git.
("DBUS_FATAL_WARNINGS" . "0")
;; XXX: Normally we wouldn't need to do this, but our glibc@2.23 package
- ;; looks things up in 'PREFIX/lib/locale' instead of
- ;; '/run/current-system/locale' as was intended.
+ ;; used to look things up in 'PREFIX/lib/locale' instead of
+ ;; '/run/current-system/locale' as was intended. Keep this hack around so
+ ;; that people who still have glibc@2.23-using packages in their profiles
+ ;; can use them correctly.
+ ;; TODO: Remove when glibc@2.23 is long gone.
("GUIX_LOCPATH" . "/run/current-system/locale")))
(define %setuid-programs
;; Default set of setuid-root programs.
(let ((shadow (@ (gnu packages admin) shadow)))
- (list #~(string-append #$shadow "/bin/passwd")
- #~(string-append #$shadow "/bin/su")
- #~(string-append #$inetutils "/bin/ping")
- #~(string-append #$inetutils "/bin/ping6")
- #~(string-append #$sudo "/bin/sudo")
- #~(string-append #$fuse "/bin/fusermount"))))
+ (list (file-append shadow "/bin/passwd")
+ (file-append shadow "/bin/su")
+ (file-append shadow "/bin/newuidmap")
+ (file-append shadow "/bin/newgidmap")
+ (file-append inetutils "/bin/ping")
+ (file-append inetutils "/bin/ping6")
+ (file-append sudo "/bin/sudo")
+ (file-append fuse "/bin/fusermount"))))
(define %sudoers-specification
;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
(let* ((services (operating-system-services os #:container? container?))
(boot (fold-services services #:target-type boot-service-type)))
;; BOOT is the script as a monadic value.
- (service-parameters boot)))
+ (service-value boot)))
(define (operating-system-user-accounts os)
"Return the list of user accounts of OS."
(account (fold-services services
#:target-type account-service-type)))
(filter user-account?
- (service-parameters account))))
+ (service-value account))))
(define (operating-system-shepherd-service-names os)
"Return the list of Shepherd service names for OS."
(append-map shepherd-service-provision
- (service-parameters
+ (service-value
(fold-services (operating-system-services os)
#:target-type
shepherd-root-service-type))))
(let* ((services (operating-system-services os #:container? container?))
(system (fold-services services)))
;; SYSTEM contains the derivation as a monadic value.
- (service-parameters system)))
+ (service-value system)))
(define* (operating-system-profile os #:key container?)
"Return a derivation that builds the system profile of OS."
(define (operating-system-root-file-system os)
"Return the root file system of OS."
(find (match-lambda
- (($ <file-system> _ _ "/") #t)
- (_ #f))
+ (($ <file-system> device title "/") #t)
+ (x #f))
(operating-system-file-systems os)))
(define (operating-system-initrd-file os)
(#f
(raise (condition
(&message
- (message (format #f (_ "~a: invalid locale name") name))))))
+ (message (format #f (G_ "~a: invalid locale name") name))))))
(def def)))
(define (operating-system-locale-directory os)
(locale-directory definitions
#:libcs (operating-system-locale-libcs os)))
-(define (kernel->grub-label kernel)
- "Return a label for the GRUB menu entry that boots KERNEL."
+(define (kernel->boot-label kernel)
+ "Return a label for the bootloader menu entry that boots KERNEL."
(string-append "GNU with "
(string-titlecase (package-name kernel)) " "
(package-version kernel)
"Return the file system that contains the store of OS."
(store-file-system (operating-system-file-systems os)))
-(define* (operating-system-grub.cfg os #:optional (old-entries '()))
- "Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the
-\"old entries\" menu."
+(define* (operating-system-bootcfg os #:optional (old-entries '()))
+ "Return the bootloader configuration file for OS. Use OLD-ENTRIES to
+populate the \"old entries\" menu."
(mlet* %store-monad
((system (operating-system-derivation os))
(root-fs -> (operating-system-root-file-system os))
- (store-fs -> (operating-system-store-file-system os))
- (label -> (kernel->grub-label (operating-system-kernel os)))
- (kernel -> (operating-system-kernel-file os))
(root-device -> (if (eq? 'uuid (file-system-title root-fs))
(uuid->string (file-system-device root-fs))
(file-system-device root-fs)))
- (entries -> (list (menu-entry
- (label label)
- (linux kernel)
- (linux-arguments
- (cons* (string-append "--root=" root-device)
- #~(string-append "--system=" #$system)
- #~(string-append "--load=" #$system
- "/boot")
- (operating-system-kernel-arguments os)))
- (initrd (file-append system "/initrd"))))))
- (grub-configuration-file (operating-system-bootloader os)
- store-fs entries
- #:old-entries old-entries)))
-
-(define (operating-system-parameters-file os)
- "Return a file that describes the boot parameters of OS. The primary use of
-this file is the reconstruction of GRUB menu entries for old configurations."
- (mlet %store-monad ((initrd (operating-system-initrd-file os))
- (root -> (operating-system-root-file-system os))
- (label -> (kernel->grub-label
- (operating-system-kernel os))))
- (gexp->file "parameters"
- #~(boot-parameters (version 0)
- (label #$label)
- (root-device #$(file-system-device root))
- (kernel #$(operating-system-kernel-file os))
- (kernel-arguments
- #$(operating-system-kernel-arguments os))
- (initrd #$initrd))
- #:set-load-path? #f)))
-
-\f
-;;;
-;;; Boot parameters
-;;;
-
-(define-record-type* <boot-parameters>
- boot-parameters make-boot-parameters boot-parameters?
- (label boot-parameters-label)
- (root-device boot-parameters-root-device)
- (kernel boot-parameters-kernel)
- (kernel-arguments boot-parameters-kernel-arguments))
-
-(define (read-boot-parameters port)
- "Read boot parameters from PORT and return the corresponding
-<boot-parameters> object or #f if the format is unrecognized."
- (match (read port)
- (('boot-parameters ('version 0)
- ('label label) ('root-device root)
- ('kernel linux)
- rest ...)
- (boot-parameters
- (label label)
- (root-device root)
-
- ;; In the past, we would store the directory name of the kernel instead
- ;; of the absolute file name of its image. Detect that and correct it.
- (kernel (if (string=? linux (direct-store-path linux))
- (string-append linux "/"
- (system-linux-image-file-name))
- linux))
-
- (kernel-arguments
- (match (assq 'kernel-arguments rest)
- ((_ args) args)
- (#f '()))))) ;the old format
- (x ;unsupported format
- (warning (_ "unrecognized boot parameters for '~a'~%")
- system)
- #f)))
+ (entry (operating-system-boot-parameters os system root-device))
+ (bootloader-conf -> (operating-system-bootloader os)))
+ ((bootloader-configuration-file-generator
+ (bootloader-configuration-bootloader bootloader-conf))
+ bootloader-conf (list entry) #:old-entries old-entries)))
+
+(define (fs->boot-device fs)
+ "Given FS, a <file-system> object, return a value suitable for use as the
+device in a <menu-entry>."
+ (case (file-system-title fs)
+ ((uuid) (file-system-device fs))
+ ((label) (file-system-device fs))
+ (else #f)))
+
+(define (operating-system-boot-parameters os system.drv root-device)
+ "Return a monadic <boot-parameters> record that describes the boot parameters
+of OS. SYSTEM.DRV is either a derivation or #f. If it's a derivation, adds
+kernel arguments for that derivation to <boot-parameters>."
+ (mlet* %store-monad
+ ((initrd (operating-system-initrd-file os))
+ (store -> (operating-system-store-file-system os))
+ (bootloader -> (bootloader-configuration-bootloader
+ (operating-system-bootloader os)))
+ (bootloader-name -> (bootloader-name bootloader))
+ (label -> (kernel->boot-label (operating-system-kernel os))))
+ (return (boot-parameters
+ (label label)
+ (root-device root-device)
+ (kernel (operating-system-kernel-file os))
+ (kernel-arguments
+ (if system.drv
+ (operating-system-kernel-arguments os system.drv root-device)
+ (operating-system-user-kernel-arguments os)))
+ (initrd initrd)
+ (bootloader-name bootloader-name)
+ (store-device (fs->boot-device store))
+ (store-mount-point (file-system-mount-point store))))))
+
+(define* (operating-system-boot-parameters-file os #:optional (system.drv #f))
+ "Return a file that describes the boot parameters of OS. The primary use of
+this file is the reconstruction of GRUB menu entries for old configurations.
+SYSTEM.DRV is optional. If given, adds kernel arguments for that system to the
+returned file (since the returned file is then usually stored into the
+content-addressed \"system\" directory, it's usually not a good idea
+to give it because the content hash would change by the content hash
+being stored into the \"parameters\" file)."
+ (mlet* %store-monad ((root -> (operating-system-root-file-system os))
+ (device -> (file-system-device root))
+ (params (operating-system-boot-parameters os
+ system.drv
+ device)))
+ (gexp->file "parameters"
+ #~(boot-parameters
+ (version 0)
+ (label #$(boot-parameters-label params))
+ (root-device #$(boot-parameters-root-device params))
+ (kernel #$(boot-parameters-kernel params))
+ (kernel-arguments
+ #$(boot-parameters-kernel-arguments params))
+ (initrd #$(boot-parameters-initrd params))
+ (bootloader-name #$(boot-parameters-bootloader-name params))
+ (store
+ (device #$(boot-parameters-store-device params))
+ (mount-point #$(boot-parameters-store-mount-point params))))
+ #:set-load-path? #f)))
;;; system.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff