;;; 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 © 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (gnu packages compression)
#:use-module (gnu packages disk)
#:use-module (gnu packages linux)
+ #:use-module (gnu packages file-systems)
#:use-module (gnu packages guile)
#:use-module ((gnu packages xorg)
#:select (console-setup xkeyboard-config))
#:use-module ((gnu packages make-bootstrap)
- #:select (%guile-static-stripped))
+ #:select (%guile-3.0-static-stripped))
#:use-module (gnu system file-systems)
#:use-module (gnu system mapped-devices)
#:use-module (gnu system keyboard)
(define* (expression->initrd exp
#:key
- (guile %guile-static-stripped)
+ (guile %guile-3.0-static-stripped)
(gzip gzip)
(name "guile-initrd")
(system (%current-system)))
(define init
(program-file "init" exp #:guile guile))
+ (define (import-module? module)
+ ;; Since we don't use deduplication support in 'populate-store', don't
+ ;; import (guix store deduplication) and its dependencies, which includes
+ ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'.
+ (and (guix-module-name? module)
+ (not (equal? module '(guix store deduplication)))))
+
(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)))
+ '((gnu build linux-initrd))
+ #:select? import-module?)
#~(begin
(use-modules (gnu build linux-initrd))
#:init #$init
;; Copy everything INIT refers to into the initrd.
#:references-graphs '("closure")
- #:gzip (string-append #$gzip "/bin/gzip")))))
+ #:gzip (string-append #+gzip "/bin/gzip")))))
(file-append (computed-file name builder
#:options
(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 modules
- (let* ((lookup (cut find-module-file module-dir <>))
- (modules (map lookup '#$modules)))
- (append modules
- (recursive-module-dependencies modules
- #:lookup-module lookup))))
+ (define imported-modules
+ (source-module-closure '((gnu build linux-modules)
+ (guix build utils))))
- (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))
(define device-mapping-commands
;; List of gexps to open the mapped devices.
(map (lambda (md)
- (let* ((source (mapped-device-source md))
- (target (mapped-device-target md))
- (type (mapped-device-type md))
- (open (mapped-device-kind-open type)))
- (open source target)))
+ (let* ((source (mapped-device-source md))
+ (targets (mapped-device-targets md))
+ (type (mapped-device-type md))
+ (open (mapped-device-kind-open type)))
+ (open source targets)))
mapped-devices))
(define kodir
#~(begin
(use-modules (gnu build linux-boot)
(gnu system file-systems)
- (guix build utils)
+ ((guix build utils) #:hide (delete))
(guix build bournish) ;add the 'bournish' meta-command
+ (srfi srfi-1) ;for lvm-device-mapping
(srfi srfi-26)
;; FIXME: The following modules are for
(set-path-environment-variable "PATH" '("bin" "sbin")
'#$helper-packages)))
- (boot-system #:mounts
- (map spec->file-system
- '#$(map file-system->spec file-systems))
- #:pre-mount (lambda ()
- (and #$@device-mapping-commands))
- #:linux-modules '#$linux-modules
- #:linux-module-directory '#$kodir
- #:keymap-file #+(and=> keyboard-layout
- keyboard-layout->console-keymap)
- #:qemu-guest-networking? #$qemu-networking?
- #:volatile-root? '#$volatile-root?
- #:on-error '#$on-error)))
+ (parameterize ((current-warning-port (%make-void-port "w")))
+ (boot-system #:mounts
+ (map spec->file-system
+ '#$(map file-system->spec file-systems))
+ #:pre-mount (lambda ()
+ (and #$@device-mapping-commands))
+ #:linux-modules '#$linux-modules
+ #:linux-module-directory '#$kodir
+ #:keymap-file #+(and=> keyboard-layout
+ keyboard-layout->console-keymap)
+ #:qemu-guest-networking? #$qemu-networking?
+ #:volatile-root? '#$volatile-root?
+ #:on-error '#$on-error))))
#:name "raw-initrd"))
(define* (file-system-packages file-systems #:key (volatile-root? #f))
file-systems)
(list fatfsck/static)
'())
+ ,@(if (find (file-system-type-predicate "bcachefs") file-systems)
+ (list bcachefs-tools/static)
+ '())
,@(if (find (file-system-type-predicate "btrfs") file-systems)
(list btrfs-progs/static)
+ '())
+ ,@(if (find (file-system-type-predicate "jfs") file-systems)
+ (list jfs_fsck/static)
+ '())
+ ,@(if (find (file-system-type-predicate "f2fs") file-systems)
+ (list f2fs-fsck/static)
'())))
(define-syntax vhash ;TODO: factorize
;; Given a file system type, return the list of modules it needs.
(lookup-procedure ("cifs" => '("md4" "ecb" "cifs"))
("9p" => '("9p" "9pnet_virtio"))
+ ("bcachefs" => '("bcachefs"))
("btrfs" => '("btrfs"))
("iso9660" => '("isofs"))
+ ("jfs" => '("jfs"))
+ ("f2fs" => '("f2fs" "crc32_generic"))
(else '())))
(define (file-system-modules file-systems)
HCoop / jackhill / guix / guix.git / blobdiff