diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/activation.scm | 9 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 88 | ||||
| -rw-r--r-- | gnu/build/install.scm | 36 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 2 | ||||
| -rw-r--r-- | gnu/build/linux-modules.scm | 2 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 133 |
6 files changed, 202 insertions, 68 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index beee56d437..a1d2a9cc7d 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -227,7 +227,11 @@ numeric gid or #f." #:supplementary-groups supplementary-groups #:comment comment #:home home + + ;; Home directories of non-system accounts are created by + ;; 'activate-user-home'. #:create-home? (and create-home? system?) + #:shell shell #:password password) @@ -282,7 +286,10 @@ they already exist." (match-lambda ((name uid group supplementary-groups comment home create-home? shell password system?) - (unless (or (not home) (directory-exists? home)) + ;; The home directories of system accounts are created during + ;; activation, not here. + (unless (or (not home) (not create-home?) system? + (directory-exists? home)) (let* ((pw (getpwnam name)) (uid (passwd:uid pw)) (gid (passwd:gid pw))) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index fe98df95d5..47aa77dd3e 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 David Craven <david@craven.ch> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -47,12 +48,7 @@ mount-flags->bit-mask check-file-system - mount-file-system) - #:re-export (mount - umount - MS_BIND - MS_MOVE - MS_RDONLY)) + mount-file-system)) ;;; Commentary: ;;; @@ -61,13 +57,6 @@ ;;; ;;; Code: -;; 'mount' is already defined in the statically linked Guile used for initial -;; RAM disks, in which case the bindings in (guix build syscalls) do not work -;; (the FFI bindings do not work there). Override them in that case. -(when (module-defined? the-scm-module 'mount) - (set! mount (@ (guile) mount)) - (set! umount (@ (guile) umount))) - (define (bind-mount source target) "Bind-mount SOURCE at TARGET." (mount source target "" MS_BIND)) @@ -241,6 +230,63 @@ Trailing spaces are trimmed." ;;; +;;; ISO9660 file systems. +;;; + +;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>. + +(define (iso9660-superblock? sblock) + "Return #t when SBLOCK is a iso9660 superblock." + (bytevector=? (sub-bytevector sblock 1 6) + ;; Note: "\x01" is the volume descriptor format version + (string->utf8 "CD001\x01"))) + +(define (read-iso9660-primary-volume-descriptor device offset) + "Find and read the first primary volume descriptor, starting at OFFSET. + Return #f if not found." + (let* ((sblock (read-superblock device offset 2048 iso9660-superblock?)) + (type-code (if sblock (array-ref sblock 0) 255))) + (match type-code + (255 #f) ; Volume Descriptor Set Terminator. + (1 sblock) ; Primary Volume Descriptor + (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048)))))) + +(define (read-iso9660-superblock device) + "Return the raw contents of DEVICE's iso9660 superblock as a bytevector, or +#f if DEVICE does not contain a iso9660 file system." + ;; Start reading at sector 16. + (read-iso9660-primary-volume-descriptor device (* 2048 16))) + +(define (iso9660-superblock-uuid sblock) + "Return the modification time of a iso9660 superblock SBLOCK as a bytevector." + ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid. + ;; Compare Grub: "2014-12-02-19-30-23-00". + ;; Compare blkid result: "2014-12-02-19-30-23-00". + ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00". + (sub-bytevector sblock 830 16)) + +(define (iso9660-uuid->string uuid) + "Given an UUID bytevector, return its timestamp string." + (define (digits->string bytes) + (latin1->string bytes (lambda (c) #f))) + (let* ((year (sub-bytevector uuid 0 4)) + (month (sub-bytevector uuid 4 2)) + (day (sub-bytevector uuid 6 2)) + (hour (sub-bytevector uuid 8 2)) + (minute (sub-bytevector uuid 10 2)) + (second (sub-bytevector uuid 12 2)) + (hundredths (sub-bytevector uuid 14 2)) + (parts (list year month day hour minute second hundredths))) + (string-append (string-join (map digits->string parts))))) + +(define (iso9660-superblock-volume-name sblock) + "Return the volume name of SBLOCK as a string. The volume name is an ASCII +string. Trailing spaces are trimmed." + (string-trim-right (latin1->string (sub-bytevector sblock 40 32) + (lambda (c) #f)) #\space)) + + +;;; ;;; LUKS encrypted devices. ;;; @@ -351,7 +397,9 @@ partition field reader that returned a value." (_ #f))) (define %partition-label-readers - (list (partition-field-reader read-ext2-superblock + (list (partition-field-reader read-iso9660-superblock + iso9660-superblock-volume-name) + (partition-field-reader read-ext2-superblock ext2-superblock-volume-name) (partition-field-reader read-btrfs-superblock btrfs-superblock-volume-name) @@ -359,7 +407,9 @@ partition field reader that returned a value." fat32-superblock-volume-name))) (define %partition-uuid-readers - (list (partition-field-reader read-ext2-superblock + (list (partition-field-reader read-iso9660-superblock + iso9660-superblock-uuid) + (partition-field-reader read-ext2-superblock ext2-superblock-uuid) (partition-field-reader read-btrfs-superblock btrfs-superblock-uuid) @@ -576,10 +626,6 @@ corresponds to the symbols listed in FLAGS." (() 0)))) -(define (regular-file? file-name) - "Return #t if FILE-NAME is a regular file." - (eq? (stat:type (stat file-name)) 'regular)) - (define* (mount-file-system spec #:key (root "/root")) "Mount the file system described by SPEC under ROOT. SPEC must have the form: @@ -619,9 +665,9 @@ run a file system check." (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 may be needed. + ;; in the case of a bind mount, a regular file or socket may be needed. (if (and (= MS_BIND (logand flags MS_BIND)) - (regular-file? source)) + (not (file-is-directory? source))) (unless (file-exists? mount-point) (mkdir-p (dirname mount-point)) (call-with-output-file mount-point (const #t))) diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 5cb6055a0c..9e30c0d23e 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -22,8 +22,7 @@ #:use-module (guix build store-copy) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:export (install-grub - install-grub-config + #:export (install-boot-config evaluate-populate-directive populate-root-file-system reset-timestamps @@ -39,36 +38,17 @@ ;;; ;;; Code: -(define (install-grub grub.cfg device mount-point) - "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. - -Note that the caller must make sure that GRUB.CFG is registered as a GC root -so that the fonts, background images, etc. referred to by GRUB.CFG are not -GC'd." - (install-grub-config grub.cfg mount-point) - - ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or root - ;; partition. - (setenv "GRUB_ENABLE_CRYPTODISK" "y") - - (unless (zero? (system* "grub-install" "--no-floppy" - "--boot-directory" - (string-append mount-point "/boot") - device)) - (error "failed to install GRUB"))) - -(define (install-grub-config grub.cfg mount-point) - "Atomically copy GRUB.CFG into boot/grub/grub.cfg on the MOUNT-POINT. Note -that the caller must make sure that GRUB.CFG is registered as a GC root so -that the fonts, background images, etc. referred to by GRUB.CFG are not GC'd." - (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) +(define (install-boot-config bootcfg bootcfg-location mount-point) + "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT. Note +that the caller must make sure that BOOTCFG is registered as a GC root so +that the fonts, background images, etc. referred to by BOOTCFG are not GC'd." + (let* ((target (string-append mount-point bootcfg-location)) (pivot (string-append target ".new"))) (mkdir-p (dirname target)) - ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't + ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't ;; work when /boot is on a separate partition. Do that atomically. - (copy-file grub.cfg pivot) + (copy-file bootcfg pivot) (rename-file pivot target))) (define (evaluate-populate-directive directive target) diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index c34a3f7c18..360ef3faed 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:use-module (guix build utils) + #:use-module (guix build syscalls) #:use-module (gnu build linux-modules) #:use-module (gnu build file-systems) #:export (mount-essential-file-systems diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index d7feb3a080..5ca7bf8e38 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +19,7 @@ (define-module (gnu build linux-modules) #:use-module (guix elf) + #:use-module (guix build syscalls) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 60ee18ebe0..57619764ce 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -2,6 +2,8 @@ ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org> ;;; Copyright © 2016 Leo Famulari <leo@famulari.name> +;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,9 +23,11 @@ (define-module (gnu build vm) #:use-module (guix build utils) #:use-module (guix build store-copy) + #:use-module (guix build syscalls) #:use-module (gnu build linux-boot) #:use-module (gnu build install) #:use-module (guix records) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -39,7 +43,7 @@ partition-size partition-file-system partition-label - partition-bootable? + partition-flags partition-initializer root-partition-initializer @@ -139,7 +143,7 @@ the #:references-graphs parameter of 'derivation'." (size partition-size) (file-system partition-file-system (default "ext4")) (label partition-label (default #f)) - (bootable? partition-bootable? (default #f)) + (flags partition-flags (default '())) (initializer partition-initializer (default (const #t)))) (define (fold2 proc seed1 seed2 lst) ;TODO: factorize @@ -166,9 +170,10 @@ actual /dev name based on DEVICE." (cons* "mkpart" "primary" "ext2" (format #f "~aB" offset) (format #f "~aB" (+ offset (partition-size part))) - (if (partition-bootable? part) - `("set" ,(number->string index) "boot" "on") - '()))) + (append-map (lambda (flag) + (list "set" (number->string index) + (symbol->string flag) "on")) + (partition-flags part)))) (define (options partitions offset) (let loop ((partitions partitions) @@ -209,10 +214,10 @@ actual /dev name based on DEVICE." (define MS_BIND 4096) ; <sys/mounts.h> again! -(define* (format-partition partition type - #:key label) - "Create a file system TYPE on PARTITION. If LABEL is true, use that as the -volume name." +(define* (create-ext-file-system partition type + #:key label) + "Create an ext-family filesystem of TYPE on PARTITION. If LABEL is true, +use that as the volume name." (format #t "creating ~a partition...\n" type) (unless (zero? (apply system* (string-append "mkfs." type) "-F" partition @@ -221,6 +226,28 @@ volume name." '()))) (error "failed to create partition"))) +(define* (create-fat-file-system partition + #:key label) + "Create a FAT filesystem on PARTITION. The number of File Allocation Tables +will be determined based on filesystem size. If LABEL is true, use that as the +volume name." + (format #t "creating FAT partition...\n") + (unless (zero? (apply system* "mkfs.fat" partition + (if label + `("-n" ,label) + '()))) + (error "failed to create FAT partition"))) + +(define* (format-partition partition type + #:key label) + "Create a file system TYPE on PARTITION. If LABEL is true, use that as the +volume name." + (cond ((string-prefix? "ext" type) + (create-ext-file-system partition type #:label label)) + ((or (string-prefix? "fat" type) (string= "vfat" type)) + (create-fat-file-system partition #:label label)) + (else (error "Unsupported file system.")))) + (define (initialize-partition partition) "Format PARTITION, a <partition> object with a non-#f 'device' field, mount it, run its initializer, and unmount it." @@ -283,23 +310,65 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (unless register-closures? (reset-timestamps target)))) -(define (register-grub.cfg-root target grub.cfg) - "On file system TARGET, register GRUB.CFG as a GC root." +(define (register-bootcfg-root target bootcfg) + "On file system TARGET, register BOOTCFG as a GC root." (let ((directory (string-append target "/var/guix/gcroots"))) (mkdir-p directory) - (symlink grub.cfg (string-append directory "/grub.cfg")))) + (symlink bootcfg (string-append directory "/bootcfg")))) + +(define (install-efi grub esp config-file) + "Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE." + (let* ((system %host-type) + ;; Hard code the output location to a well-known path recognized by + ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour": + ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf + (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone")) + (efi-directory (string-append esp "/EFI/BOOT")) + ;; Map grub target names to boot file names. + (efi-targets (cond ((string-prefix? "x86_64" system) + '("x86_64-efi" . "BOOTX64.EFI")) + ((string-prefix? "i686" system) + '("i386-efi" . "BOOTIA32.EFI")) + ((string-prefix? "armhf" system) + '("arm-efi" . "BOOTARM.EFI")) + ((string-prefix? "aarch64" system) + '("arm64-efi" . "BOOTAA64.EFI"))))) + ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image. + (setenv "TMPDIR" esp) + + (mkdir-p efi-directory) + (unless (zero? (system* grub-mkstandalone "-O" (car efi-targets) + "-o" (string-append efi-directory "/" + (cdr efi-targets)) + ;; Graft the configuration file onto the image. + (string-append "boot/grub/grub.cfg=" config-file))) + (error "failed to create GRUB EFI image")))) (define* (initialize-hard-disk device #:key - grub.cfg + bootloader-package + bootcfg + bootcfg-location + bootloader-installer + (grub-efi #f) (partitions '())) "Initialize DEVICE as a disk containing all the <partition> objects listed -in PARTITIONS, and using GRUB.CFG as its bootloader configuration file. +in PARTITIONS, and using BOOTCFG as its bootloader configuration file. Each partition is initialized by calling its 'initializer' procedure, passing it a directory name where it is mounted." + + (define (partition-bootable? partition) + "Return the first partition found with the boot flag set." + (member 'boot (partition-flags partition))) + + (define (partition-esp? partition) + "Return the first EFI System Partition." + (member 'esp (partition-flags partition))) + (let* ((partitions (initialize-partition-table device partitions)) (root (find partition-bootable? partitions)) + (esp (find partition-esp? partitions)) (target "/fs")) (unless root (error "no bootable partition specified" partitions)) @@ -309,10 +378,38 @@ passing it a directory name where it is mounted." (display "mounting root partition...\n") (mkdir-p target) (mount (partition-device root) target (partition-file-system root)) - (install-grub grub.cfg device target) - - ;; Register GRUB.CFG as a GC root. - (register-grub.cfg-root target grub.cfg) + (install-boot-config bootcfg bootcfg-location target) + (when bootloader-installer + (display "installing bootloader...\n") + (bootloader-installer bootloader-package device target)) + + (when esp + ;; Mount the ESP somewhere and install GRUB UEFI image. + (let ((mount-point (string-append target "/boot/efi")) + (grub-config (string-append target "/tmp/grub-standalone.cfg"))) + (display "mounting EFI system partition...\n") + (mkdir-p mount-point) + (mount (partition-device esp) mount-point + (partition-file-system esp)) + + ;; Create a tiny configuration file telling the embedded grub + ;; where to load the real thing. + (call-with-output-file grub-config + (lambda (port) + (format port + "insmod part_msdos~@ + search --set=root --label gnu-disk-image~@ + configfile /boot/grub/grub.cfg~%"))) + + (display "creating EFI firmware image...") + (install-efi grub-efi mount-point grub-config) + (display "done.\n") + + (delete-file grub-config) + (umount mount-point))) + + ;; Register BOOTCFG as a GC root. + (register-bootcfg-root target bootcfg) (umount target))) |