[jackhill/guix/guix.git] / gnu / system / linux-initrd.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 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 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu system linux-initrd)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module ((guix store)
                #:select (%store-prefix))
  #:use-module ((guix derivations)
                #:select (derivation->output-path))
  #:use-module (guix modules)
  #: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))
  #:use-module (gnu system file-systems)
  #:use-module (gnu system mapped-devices)
  #:use-module (gnu system keyboard)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (expression->initrd
            %base-initrd-modules
            raw-initrd
            file-system-packages
            base-initrd))

\f
;;; Commentary:
;;;
;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
;;; particular initrd's that run Guile.
;;;
;;; Code:


(define* (expression->initrd exp
                             #:key
                             (guile %guile-static-stripped)
                             (gzip gzip)
                             (name "guile-initrd")
                             (system (%current-system)))
  "Return as a file-like object a Linux initrd (a gzipped cpio archive)
containing GUILE and that evaluates EXP, a G-expression, upon booting.  All
the derivations referenced by EXP are automatically copied to the initrd."

  ;; General Linux overview in `Documentation/early-userspace/README' and
  ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.

  (define init
    (program-file "init" exp #:guile guile))

  (define builder
    (with-imported-modules (source-module-closure
                            '((gnu build linux-initrd)))
      #~(begin
          (use-modules (gnu build linux-initrd))

          (mkdir #$output)

          ;; The guile used in the initrd must be present in the store, so
          ;; that module loading works once the root is switched.
          ;;
          ;; To ensure that is the case, add an explicit reference to the
          ;; guile package used in the initrd to the output.
          ;;
          ;; This fixes guix-patches bug #28399, "Fix mysql activation, and
          ;; add a basic test".
          (call-with-output-file (string-append #$ output "/references")
            (lambda (port)
              (simple-format port "~A\n" #$guile)))

          (build-initrd (string-append #$output "/initrd.cpio.gz")
                        #:guile #$guile
                        #:init #$init
                        ;; Copy everything INIT refers to into the initrd.
                        #:references-graphs '("closure")
                        #:gzip (string-append #+gzip "/bin/gzip")))))

  (file-append (computed-file name builder
                              #:options
                              `(#:references-graphs (("closure" ,init))))
               "/initrd.cpio.gz"))

(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))))

          (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))))

  (computed-file "linux-modules" build-exp))

(define* (raw-initrd file-systems
                      #:key
                      (linux linux-libre)
                      (linux-modules '())
                      (mapped-devices '())
                      (keyboard-layout #f)
                      (helper-packages '())
                      qemu-networking?
                      volatile-root?
                      (on-error 'debug))
  "Return as a file-like object a raw initrd, with kernel
modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
mounted by the initrd, possibly in addition to the root file system specified
on the kernel command line via '--root'. LINUX-MODULES is a list of kernel
modules to be loaded at boot time. MAPPED-DEVICES is a list of device
mappings to realize before FILE-SYSTEMS are mounted.
HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
e2fsck/static or other packages needed by the initrd to check root partition.

When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
console keyboard layout.  This is done before MAPPED-DEVICES are set up and
before FILE-SYSTEMS are mounted such that, should the user need to enter a
passphrase or use the REPL, this happens using the intended keyboard layout.

When QEMU-NETWORKING? is true, set up networking with the standard QEMU
parameters.

When VOLATILE-ROOT? is true, the root file system is writable but any changes
to it are lost.

ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
upon error."
  (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)))
         mapped-devices))

  (define kodir
    (flat-linux-module-directory linux linux-modules))

  (expression->initrd
   (with-imported-modules (source-module-closure
                           '((gnu build linux-boot)
                             (guix build utils)
                             (guix build bournish)
                             (gnu system file-systems)
                             (gnu build file-systems)))
     #~(begin
         (use-modules (gnu build linux-boot)
                      (gnu system file-systems)
                      (guix build utils)
                      (guix build bournish)   ;add the 'bournish' meta-command
                      (srfi srfi-26)

                      ;; FIXME: The following modules are for
                      ;; LUKS-DEVICE-MAPPING.  We should instead propagate
                      ;; this info via gexps.
                      ((gnu build file-systems)
                       #:select (find-partition-by-luks-uuid))
                      (rnrs bytevectors))

         (with-output-to-port (%make-void-port "w")
           (lambda ()
             (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)))
   #:name "raw-initrd"))

(define* (file-system-packages file-systems #:key (volatile-root? #f))
  "Return the list of statically-linked, stripped packages to check
FILE-SYSTEMS."
  `(,@(if (find (lambda (fs)
                  (string-prefix? "ext" (file-system-type fs)))
                file-systems)
          (list e2fsck/static)
          '())
    ,@(if (find (lambda (fs)
                  (string-suffix? "fat" (file-system-type fs)))
                file-systems)
          (list fatfsck/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)
          '())))

(define-syntax vhash                              ;TODO: factorize
  (syntax-rules (=>)
    "Build a vhash with the given key/value mappings."
    ((_)
     vlist-null)
    ((_ (key others ... => value) rest ...)
     (vhash-cons key value
                 (vhash (others ... => value) rest ...)))
    ((_ (=> value) rest ...)
     (vhash rest ...))))

(define-syntax lookup-procedure
  (syntax-rules (else)
    "Return a procedure that lookups keys in the given dictionary."
    ((_ mapping ... (else default))
     (let ((table (vhash mapping ...)))
       (lambda (key)
         (match (vhash-assoc key table)
           (#f            default)
           ((key . value) value)))))))

(define file-system-type-modules
  ;; Given a file system type, return the list of modules it needs.
  (lookup-procedure ("cifs" => '("md4" "ecb" "cifs"))
                    ("9p" => '("9p" "9pnet_virtio"))
                    ("btrfs" => '("btrfs"))
                    ("iso9660" => '("isofs"))
                    ("jfs" => '("jfs"))
                    (else '())))

(define (file-system-modules file-systems)
  "Return the list of Linux modules needed to mount FILE-SYSTEMS."
  (append-map (compose file-system-type-modules file-system-type)
              file-systems))

(define* (default-initrd-modules
           #:optional
           (system (or (%current-target-system)
                       (%current-system))))
  "Return the list of modules included in the initrd by default."
  (define virtio-modules
    ;; Modules for Linux para-virtualized devices, for use in QEMU guests.
    '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
      "virtio_console" "virtio-rng"))

  `("ahci"                                  ;for SATA controllers
    "usb-storage" "uas"                     ;for the installation image etc.
    "usbhid" "hid-generic" "hid-apple"      ;keyboards during early boot
    "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions
    "nls_iso8859-1"                            ;for `mkfs.fat`, et.al
    ,@(if (string-match "^(x86_64|i[3-6]86)-" system)
          '("pata_acpi" "pata_atiixp"    ;for ATA controllers
            "isci")                      ;for SAS controllers like Intel C602
          '())

    ,@virtio-modules))

(define-syntax %base-initrd-modules
  ;; This more closely matches our naming convention.
  (identifier-syntax (default-initrd-modules)))

(define* (base-initrd file-systems
                      #:key
                      (linux linux-libre)
                      (linux-modules '())
                      (mapped-devices '())
                      (keyboard-layout #f)
                      qemu-networking?
                      volatile-root?
                      (extra-modules '())         ;deprecated
                      (on-error 'debug))
  "Return as a file-like object a generic initrd, with kernel
modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
mounted by the initrd, possibly in addition to the root file system specified
on the kernel command line via '--root'.  MAPPED-DEVICES is a list of device
mappings to realize before FILE-SYSTEMS are mounted.

When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
console keyboard layout.  This is done before MAPPED-DEVICES are set up and
before FILE-SYSTEMS are mounted such that, should the user need to enter a
passphrase or use the REPL, this happens using the intended keyboard layout.

QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.

The initrd is automatically populated with all the kernel modules necessary
for FILE-SYSTEMS and for the given options.  Additional kernel
modules can be listed in LINUX-MODULES.  They will be added to the initrd, and
loaded at boot time in the order in which they appear."
  (define linux-modules*
    ;; Modules added to the initrd and loaded from the initrd.
    `(,@linux-modules
      ,@(file-system-modules file-systems)
      ,@(if volatile-root?
            '("overlay")
            '())
      ,@extra-modules))

  (define helper-packages
    (append (file-system-packages file-systems
                                  #:volatile-root? volatile-root?)
            (if keyboard-layout
                (list loadkeys-static)
                '())))

  (raw-initrd file-systems
              #:linux linux
              #:linux-modules linux-modules*
              #:mapped-devices mapped-devices
              #:helper-packages helper-packages
              #:keyboard-layout keyboard-layout
              #:qemu-networking? qemu-networking?
              #:volatile-root? volatile-root?
              #:on-error on-error))

;;; linux-initrd.scm ends here
Commit	Line	Data
f09d925b	1	;;; GNU Guix --- Functional package management for GNU
ae7a316b	2	;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
cc023e32	3	;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
ad857912	4	;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
fdbf4447	5	;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
c7b5cfb0	6	;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
f09d925b LC	7	;;;
	8	;;; This file is part of GNU Guix.
	9	;;;
	10	;;; GNU Guix is free software; you can redistribute it and/or modify it
	11	;;; under the terms of the GNU General Public License as published by
	12	;;; the Free Software Foundation; either version 3 of the License, or (at
	13	;;; your option) any later version.
	14	;;;
	15	;;; GNU Guix is distributed in the hope that it will be useful, but
	16	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;;; GNU General Public License for more details.
	19	;;;
	20	;;; You should have received a copy of the GNU General Public License
	21	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	22
735c6dd7	23	(define-module (gnu system linux-initrd)
0c21d92b	24	#:use-module (guix gexp)
f09d925b	25	#:use-module (guix utils)
d4254711 LC	26	#:use-module ((guix store)
d4254711 LC	27	#:select (%store-prefix))
1c96c1bb LC	28	#:use-module ((guix derivations)
1c96c1bb LC	29	#:select (derivation->output-path))
239c6e27	30	#:use-module (guix modules)
f09d925b	31	#:use-module (gnu packages compression)
866872aa	32	#:use-module (gnu packages disk)
f09d925b	33	#:use-module (gnu packages linux)
c7b5cfb0	34	#:use-module (gnu packages file-systems)
f989fa39	35	#:use-module (gnu packages guile)
ae7a316b LC	36	#:use-module ((gnu packages xorg)
ae7a316b LC	37	#:select (console-setup xkeyboard-config))
f09d925b LC	38	#:use-module ((gnu packages make-bootstrap)
f09d925b LC	39	#:select (%guile-static-stripped))
c5df1839	40	#:use-module (gnu system file-systems)
060d62a7	41	#:use-module (gnu system mapped-devices)
ae7a316b	42	#:use-module (gnu system keyboard)
1c96c1bb	43	#:use-module (ice-9 match)
217b862f	44	#:use-module (ice-9 regex)
615a89e3	45	#:use-module (ice-9 vlist)
83bcd0b8	46	#:use-module (srfi srfi-1)
42d10464	47	#:use-module (srfi srfi-26)
735c6dd7	48	#:export (expression->initrd
bc499b11	49	%base-initrd-modules
47bdc5a1	50	raw-initrd
278d486b	51	file-system-packages
8ab10c19	52	base-initrd))
f09d925b LC	53
	54	\f
	55	;;; Commentary:
	56	;;;
	57	;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
	58	;;; particular initrd's that run Guile.
	59	;;;
	60	;;; Code:
	61
	62
	63	(define* (expression->initrd exp
	64	#:key
	65	(guile %guile-static-stripped)
f09d925b LC	66	(gzip gzip)
f09d925b LC	67	(name "guile-initrd")
4ee96a79	68	(system (%current-system)))
e34ae75d	69	"Return as a file-like object a Linux initrd (a gzipped cpio archive)
df650fa8	70	containing GUILE and that evaluates EXP, a G-expression, upon booting. All
4ee96a79	71	the derivations referenced by EXP are automatically copied to the initrd."
f09d925b LC	72
	73	;; General Linux overview in `Documentation/early-userspace/README' and
	74	;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
	75
6d9a8590 LC	76	(define init
	77	(program-file "init" exp #:guile guile))
	78
	79	(define builder
	80	(with-imported-modules (source-module-closure
	81	'((gnu build linux-initrd)))
	82	#~(begin
	83	(use-modules (gnu build linux-initrd))
	84
	85	(mkdir #$output)
b36e06c2 CB	86
	87	;; The guile used in the initrd must be present in the store, so
	88	;; that module loading works once the root is switched.
	89	;;
	90	;; To ensure that is the case, add an explicit reference to the
	91	;; guile package used in the initrd to the output.
	92	;;
	93	;; This fixes guix-patches bug #28399, "Fix mysql activation, and
	94	;; add a basic test".
	95	(call-with-output-file (string-append #$ output "/references")
	96	(lambda (port)
	97	(simple-format port "~A\n" #$guile)))
	98
d422cbb3	99	(build-initrd (string-append #$output "/initrd.cpio.gz")
6d9a8590 LC	100	#:guile #$guile
	101	#:init #$init
	102	;; Copy everything INIT refers to into the initrd.
	103	#:references-graphs '("closure")
328a4c5b	104	#:gzip (string-append #+gzip "/bin/gzip")))))
6d9a8590	105
d422cbb3 LC	106	(file-append (computed-file name builder
	107	#:options
	108	`(#:references-graphs (("closure" ,init))))
	109	"/initrd.cpio.gz"))
735c6dd7	110
b21a1c5a LC	111	(define (flat-linux-module-directory linux modules)
	112	"Return a flat directory containing the Linux kernel modules listed in
	113	MODULES and taken from LINUX."
	114	(define build-exp
239c6e27	115	(with-imported-modules (source-module-closure
fcd068e9	116	'((gnu build linux-modules)))
4ee96a79	117	#~(begin
fcd068e9	118	(use-modules (gnu build linux-modules)
4ee96a79	119	(srfi srfi-1)
fcd068e9	120	(srfi srfi-26))
b21a1c5a	121
4ee96a79 LC	122	(define module-dir
4ee96a79 LC	123	(string-append #$linux "/lib/modules"))
b21a1c5a	124
4ee96a79	125	(define modules
fcd068e9 LC	126	(let* ((lookup (cut find-module-file module-dir <>))
fcd068e9 LC	127	(modules (map lookup '#$modules)))
4ee96a79 LC	128	(append modules
	129	(recursive-module-dependencies modules
	130	#:lookup-module lookup))))
600c285b	131
4ee96a79 LC	132	(mkdir #$output)
	133	(for-each (lambda (module)
	134	(format #t "copying '~a'...~%" module)
	135	(copy-file module
	136	(string-append #$output "/"
	137	(basename module))))
c85ccf60 LC	138	(delete-duplicates modules))
	139
	140	;; Hyphen or underscore? This database tells us.
	141	(write-module-name-database #$output))))
b21a1c5a	142
6d9a8590	143	(computed-file "linux-modules" build-exp))
b21a1c5a	144
47bdc5a1 MO	145	(define* (raw-initrd file-systems
	146	#:key
	147	(linux linux-libre)
	148	(linux-modules '())
	149	(mapped-devices '())
ae7a316b	150	(keyboard-layout #f)
47bdc5a1 MO	151	(helper-packages '())
47bdc5a1 MO	152	qemu-networking?
aeed74f3 LC	153	volatile-root?
aeed74f3 LC	154	(on-error 'debug))
e34ae75d	155	"Return as a file-like object a raw initrd, with kernel
47bdc5a1 MO	156	modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be
	157	mounted by the initrd, possibly in addition to the root file system specified
	158	on the kernel command line via '--root'. LINUX-MODULES is a list of kernel
	159	modules to be loaded at boot time. MAPPED-DEVICES is a list of device
	160	mappings to realize before FILE-SYSTEMS are mounted.
	161	HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
	162	e2fsck/static or other packages needed by the initrd to check root partition.
	163
ae7a316b LC	164	When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
	165	console keyboard layout. This is done before MAPPED-DEVICES are set up and
	166	before FILE-SYSTEMS are mounted such that, should the user need to enter a
	167	passphrase or use the REPL, this happens using the intended keyboard layout.
	168
47bdc5a1 MO	169	When QEMU-NETWORKING? is true, set up networking with the standard QEMU
47bdc5a1 MO	170	parameters.
aeed74f3	171
47bdc5a1	172	When VOLATILE-ROOT? is true, the root file system is writable but any changes
aeed74f3 LC	173	to it are lost.
	174
	175	ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
	176	upon error."
47bdc5a1 MO	177	(define device-mapping-commands
	178	;; List of gexps to open the mapped devices.
	179	(map (lambda (md)
	180	(let* ((source (mapped-device-source md))
	181	(target (mapped-device-target md))
	182	(type (mapped-device-type md))
	183	(open (mapped-device-kind-open type)))
	184	(open source target)))
	185	mapped-devices))
	186
6d9a8590 LC	187	(define kodir
	188	(flat-linux-module-directory linux linux-modules))
	189
	190	(expression->initrd
	191	(with-imported-modules (source-module-closure
	192	'((gnu build linux-boot)
	193	(guix build utils)
	194	(guix build bournish)
1c65cca5	195	(gnu system file-systems)
6d9a8590 LC	196	(gnu build file-systems)))
	197	#~(begin
	198	(use-modules (gnu build linux-boot)
1c65cca5	199	(gnu system file-systems)
6d9a8590 LC	200	(guix build utils)
	201	(guix build bournish) ;add the 'bournish' meta-command
	202	(srfi srfi-26)
	203
	204	;; FIXME: The following modules are for
	205	;; LUKS-DEVICE-MAPPING. We should instead propagate
	206	;; this info via gexps.
	207	((gnu build file-systems)
	208	#:select (find-partition-by-luks-uuid))
	209	(rnrs bytevectors))
	210
	211	(with-output-to-port (%make-void-port "w")
	212	(lambda ()
	213	(set-path-environment-variable "PATH" '("bin" "sbin")
	214	'#$helper-packages)))
	215
1c65cca5 LC	216	(boot-system #:mounts
	217	(map spec->file-system
	218	'#$(map file-system->spec file-systems))
6d9a8590 LC	219	#:pre-mount (lambda ()
	220	(and #$@device-mapping-commands))
	221	#:linux-modules '#$linux-modules
	222	#:linux-module-directory '#$kodir
ae7a316b LC	223	#:keymap-file #+(and=> keyboard-layout
ae7a316b LC	224	keyboard-layout->console-keymap)
6d9a8590	225	#:qemu-guest-networking? #$qemu-networking?
aeed74f3 LC	226	#:volatile-root? '#$volatile-root?
aeed74f3 LC	227	#:on-error '#$on-error)))
6d9a8590	228	#:name "raw-initrd"))
47bdc5a1	229
278d486b LC	230	(define* (file-system-packages file-systems #:key (volatile-root? #f))
	231	"Return the list of statically-linked, stripped packages to check
	232	FILE-SYSTEMS."
	233	`(,@(if (find (lambda (fs)
	234	(string-prefix? "ext" (file-system-type fs)))
	235	file-systems)
	236	(list e2fsck/static)
	237	'())
	238	,@(if (find (lambda (fs)
	239	(string-suffix? "fat" (file-system-type fs)))
	240	file-systems)
	241	(list fatfsck/static)
	242	'())
	243	,@(if (find (file-system-type-predicate "btrfs") file-systems)
	244	(list btrfs-progs/static)
c7b5cfb0 TGR	245	'())
	246	,@(if (find (file-system-type-predicate "jfs") file-systems)
	247	(list jfs_fsck/static)
278d486b LC	248	'())))
278d486b LC	249
615a89e3 LC	250	(define-syntax vhash ;TODO: factorize
	251	(syntax-rules (=>)
	252	"Build a vhash with the given key/value mappings."
	253	((_)
	254	vlist-null)
	255	((_ (key others ... => value) rest ...)
	256	(vhash-cons key value
	257	(vhash (others ... => value) rest ...)))
	258	((_ (=> value) rest ...)
	259	(vhash rest ...))))
	260
	261	(define-syntax lookup-procedure
	262	(syntax-rules (else)
	263	"Return a procedure that lookups keys in the given dictionary."
	264	((_ mapping ... (else default))
	265	(let ((table (vhash mapping ...)))
	266	(lambda (key)
	267	(match (vhash-assoc key table)
3cb3a4e6 LC	268	(#f default)
3cb3a4e6 LC	269	((key . value) value)))))))
615a89e3 LC	270
	271	(define file-system-type-modules
	272	;; Given a file system type, return the list of modules it needs.
	273	(lookup-procedure ("cifs" => '("md4" "ecb" "cifs"))
	274	("9p" => '("9p" "9pnet_virtio"))
	275	("btrfs" => '("btrfs"))
	276	("iso9660" => '("isofs"))
c7b5cfb0	277	("jfs" => '("jfs"))
615a89e3 LC	278	(else '())))
	279
	280	(define (file-system-modules file-systems)
	281	"Return the list of Linux modules needed to mount FILE-SYSTEMS."
	282	(append-map (compose file-system-type-modules file-system-type)
	283	file-systems))
	284
fdbf4447 MO	285	(define* (default-initrd-modules
	286	#:optional
	287	(system (or (%current-target-system)
	288	(%current-system))))
bc499b11	289	"Return the list of modules included in the initrd by default."
eac026e5 LC	290	(define virtio-modules
	291	;; Modules for Linux para-virtualized devices, for use in QEMU guests.
	292	'("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
d2823887	293	"virtio_console" "virtio-rng"))
eac026e5	294
bc499b11 LC	295	`("ahci" ;for SATA controllers
	296	"usb-storage" "uas" ;for the installation image etc.
	297	"usbhid" "hid-generic" "hid-apple" ;keyboards during early boot
	298	"dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions
	299	"nls_iso8859-1" ;for `mkfs.fat`, et.al
	300	,@(if (string-match "^(x86_64\|i[3-6]86)-" system)
	301	'("pata_acpi" "pata_atiixp" ;for ATA controllers
	302	"isci") ;for SAS controllers like Intel C602
eac026e5 LC	303	'())
	304
	305	,@virtio-modules))
bc499b11 LC	306
	307	(define-syntax %base-initrd-modules
	308	;; This more closely matches our naming convention.
	309	(identifier-syntax (default-initrd-modules)))
	310
060238ae	311	(define* (base-initrd file-systems
83bcd0b8	312	#:key
0d275f4a	313	(linux linux-libre)
bc499b11	314	(linux-modules '())
de1c158f	315	(mapped-devices '())
ae7a316b	316	(keyboard-layout #f)
4fc96187	317	qemu-networking?
24e0160a	318	volatile-root?
bc499b11	319	(extra-modules '()) ;deprecated
aeed74f3	320	(on-error 'debug))
e34ae75d	321	"Return as a file-like object a generic initrd, with kernel
0d275f4a AW	322	modules taken from LINUX. FILE-SYSTEMS is a list of file-systems to be
	323	mounted by the initrd, possibly in addition to the root file system specified
	324	on the kernel command line via '--root'. MAPPED-DEVICES is a list of device
	325	mappings to realize before FILE-SYSTEMS are mounted.
f09d925b	326
ae7a316b LC	327	When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
	328	console keyboard layout. This is done before MAPPED-DEVICES are set up and
	329	before FILE-SYSTEMS are mounted such that, should the user need to enter a
	330	passphrase or use the REPL, this happens using the intended keyboard layout.
	331
47bdc5a1 MO	332	QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.
47bdc5a1 MO	333
fa16f845	334	The initrd is automatically populated with all the kernel modules necessary
eac026e5 LC	335	for FILE-SYSTEMS and for the given options. Additional kernel
eac026e5 LC	336	modules can be listed in LINUX-MODULES. They will be added to the initrd, and
6c1df081	337	loaded at boot time in the order in which they appear."
bc499b11	338	(define linux-modules*
d4254711	339	;; Modules added to the initrd and loaded from the initrd.
bc499b11	340	`(,@linux-modules
615a89e3	341	,@(file-system-modules file-systems)
1c96c1bb	342	,@(if volatile-root?
c8289690	343	'("overlay")
fa16f845 LC	344	'())
fa16f845 LC	345	,@extra-modules))
f09d925b	346
3c05b4bc	347	(define helper-packages
ae7a316b LC	348	(append (file-system-packages file-systems
	349	#:volatile-root? volatile-root?)
	350	(if keyboard-layout
	351	(list loadkeys-static)
	352	'())))
3c05b4bc	353
47bdc5a1 MO	354	(raw-initrd file-systems
47bdc5a1 MO	355	#:linux linux
bc499b11	356	#:linux-modules linux-modules*
47bdc5a1 MO	357	#:mapped-devices mapped-devices
47bdc5a1 MO	358	#:helper-packages helper-packages
ae7a316b	359	#:keyboard-layout keyboard-layout
47bdc5a1	360	#:qemu-networking? qemu-networking?
aeed74f3 LC	361	#:volatile-root? volatile-root?
aeed74f3 LC	362	#:on-error on-error))
f09d925b LC	363
f09d925b LC	364	;;; linux-initrd.scm ends here