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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 monads)
  #:use-module (guix utils)
  #:use-module (gnu packages cpio)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages guile)
  #:use-module ((gnu packages make-bootstrap)
                #:select (%guile-static-stripped))
  #:export (expression->initrd
            qemu-initrd
            gnu-system-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)
                             (cpio cpio)
                             (gzip gzip)
                             (name "guile-initrd")
                             (system (%current-system))
                             (modules '())
                             (linux #f)
                             (linux-modules '()))
  "Return a package that contains a Linux initrd (a gzipped cpio archive)
containing GUILE and that evaluates EXP upon booting.  LINUX-MODULES is a list
of `.ko' file names to be copied from LINUX into the initrd.  MODULES is a
list of Guile module names to be embedded in the initrd."

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

  (define builder
    `(begin
       (use-modules (guix build utils)
                    (ice-9 pretty-print)
                    (ice-9 popen)
                    (ice-9 match)
                    (ice-9 ftw)
                    (srfi srfi-26)
                    (system base compile)
                    (rnrs bytevectors)
                    ((system foreign) #:select (sizeof)))

       (let ((guile   (assoc-ref %build-inputs "guile"))
             (cpio    (string-append (assoc-ref %build-inputs "cpio")
                                     "/bin/cpio"))
             (gzip    (string-append (assoc-ref %build-inputs "gzip")
                                     "/bin/gzip"))
             (modules (assoc-ref %build-inputs "modules"))
             (gos     (assoc-ref %build-inputs "modules/compiled"))
             (scm-dir (string-append "share/guile/" (effective-version)))
             (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
                              (effective-version)
                              (if (eq? (native-endianness) (endianness little))
                                  "LE"
                                  "BE")
                              (sizeof '*)
                              (effective-version)))
             (out     (assoc-ref %outputs "out")))
         (mkdir out)
         (mkdir "contents")
         (with-directory-excursion "contents"
           (copy-recursively guile ".")
           (call-with-output-file "init"
             (lambda (p)
               (format p "#!/bin/guile -ds~%!#~%" guile)
               (pretty-print ',exp p)))
           (chmod "init" #o555)
           (chmod "bin/guile" #o555)

           ;; Copy Guile modules.
           (chmod scm-dir #o777)
           (copy-recursively modules scm-dir
                             #:follow-symlinks? #t)
           (copy-recursively gos (string-append "lib/guile/"
                                                (effective-version) "/ccache")
                             #:follow-symlinks? #t)

           ;; Compile `init'.
           (mkdir-p go-dir)
           (set! %load-path (cons modules %load-path))
           (set! %load-compiled-path (cons gos %load-compiled-path))
           (compile-file "init"
                         #:opts %auto-compilation-options
                         #:output-file (string-append go-dir "/init.go"))

           ;; Copy Linux modules.
           (let* ((linux      (assoc-ref %build-inputs "linux"))
                  (module-dir (and linux
                                   (string-append linux "/lib/modules"))))
             (mkdir "modules")
             ,@(map (lambda (module)
                      `(match (find-files module-dir ,module)
                         ((file)
                          (format #t "copying '~a'...~%" file)
                          (copy-file file (string-append "modules/"
                                                         ,module)))
                         (()
                          (error "module not found" ,module module-dir))
                         ((_ ...)
                          (error "several modules by that name"
                                 ,module module-dir))))
                    linux-modules))

           ;; Reset the timestamps of all the files that will make it in the
           ;; initrd.
           (for-each (cut utime <> 0 0 0 0)
                     (find-files "." ".*"))

           (system* cpio "--version")
           (let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
                                   "-O" (string-append out "/initrd")
                                   "-H" "newc" "--null")))
             (define print0
               (let ((len (string-length "./")))
                 (lambda (file)
                   (format pipe "~a\0" (string-drop file len)))))

             ;; Note: as per `ramfs-rootfs-initramfs.txt', always add
             ;; directory entries before the files that are inside of it: "The
             ;; Linux kernel cpio extractor won't create files in a directory
             ;; that doesn't exist, so the directory entries must go before
             ;; the files that go in those directories."
             (file-system-fold (const #t)
                               (lambda (file stat result) ; leaf
                                 (print0 file))
                               (lambda (dir stat result) ; down
                                 (unless (string=? dir ".")
                                   (print0 dir)))
                               (const #f)         ; up
                               (const #f)         ; skip
                               (const #f)
                               #f
                               ".")

             (and (zero? (close-pipe pipe))
                  (with-directory-excursion out
                    (and (zero? (system* gzip "--best" "initrd"))
                         (rename-file "initrd.gz" "initrd")))))))))

  (mlet* %store-monad
      ((source   (imported-modules modules))
       (compiled (compiled-modules modules))
       (inputs   (lower-inputs
                  `(("guile" ,guile)
                    ("cpio" ,cpio)
                    ("gzip" ,gzip)
                    ("modules" ,source)
                    ("modules/compiled" ,compiled)
                    ,@(if linux
                          `(("linux" ,linux))
                          '())))))
   (derivation-expression name builder
                          #:modules '((guix build utils))
                          #:inputs inputs)))

(define (qemu-initrd)
  "Return a monadic derivation that builds an initrd for use in a QEMU guest
where the store is shared with the host."
  (expression->initrd
   '(begin
      (use-modules (srfi srfi-1)
                   (srfi srfi-26)
                   (ice-9 match)
                   ((system base compile) #:select (compile-file))
                   (guix build utils)
                   (guix build linux-initrd))

      (display "Welcome, this is GNU's early boot Guile.\n")
      (display "Use '--repl' for an initrd REPL.\n\n")

      (mount-essential-file-systems)
      (let* ((args    (linux-command-line))
             (option  (lambda (opt)
                        (let ((opt (string-append opt "=")))
                          (and=> (find (cut string-prefix? opt <>)
                                       args)
                                 (lambda (arg)
                                   (substring arg (+ 1 (string-index arg #\=))))))))
             (to-load (option "--load"))
             (root    (option "--root")))

        (when (member "--repl" args)
          ((@ (system repl repl) start-repl)))

        (display "loading CIFS and companion modules...\n")
        (for-each (compose load-linux-module*
                           (cut string-append "/modules/" <>))
                  (list "md4.ko" "ecb.ko" "cifs.ko"))

        (unless (configure-qemu-networking)
          (display "network interface is DOWN\n"))

        ;; Make /dev nodes.
        (make-essential-device-nodes)

        ;; Prepare the real root file system under /root.
        (unless (file-exists? "/root")
          (mkdir "/root"))
        (if root
            (mount root "/root" "ext3")
            (mount "none" "/root" "tmpfs"))
        (mount-essential-file-systems #:root "/root")

        (mkdir-p "/root/xchg")
        (mkdir-p "/root/nix/store")

        (unless (file-exists? "/root/dev")
          (mkdir "/root/dev")
          (make-essential-device-nodes #:root "/root"))

        ;; Mount the host's store and exchange directory.
        (mount-qemu-smb-share "/store" "/root/nix/store")
        (mount-qemu-smb-share "/xchg" "/root/xchg")

        ;; Copy the directories that contain .scm and .go files so that the
        ;; child process in the chroot can load modules (we would bind-mount
        ;; them but for some reason that fails with EINVAL -- XXX).
        (mkdir-p "/root/share")
        (mkdir-p "/root/lib")
        (mount "none" "/root/share" "tmpfs")
        (mount "none" "/root/lib" "tmpfs")
        (copy-recursively "/share" "/root/share"
                          #:log (%make-void-port "w"))
        (copy-recursively "/lib" "/root/lib"
                          #:log (%make-void-port "w"))


        (if to-load
            (letrec ((resolve
                      (lambda (file)
                        ;; If FILE is a symlink to an absolute file name,
                        ;; resolve it as if we were under /root.
                        (let ((st (lstat file)))
                          (if (eq? 'symlink (stat:type st))
                              (let ((target (readlink file)))
                                (resolve (string-append "/root" target)))
                              file)))))
              (format #t "loading boot file '~a'...\n" to-load)
              (compile-file (resolve (string-append "/root/" to-load))
                            #:output-file "/root/loader.go"
                            #:opts %auto-compilation-options)
              (match (primitive-fork)
                (0
                 (chroot "/root")
                 (load-compiled "/loader.go")

                 ;; TODO: Remove /lib, /share, and /loader.go.
                 )
                (pid
                 (format #t "boot file loaded under PID ~a~%" pid)
                 (let ((status (waitpid pid)))
                   (reboot)))))
            (begin
              (display "no boot file passed via '--load'\n")
              (display "entering a warm and cozy REPL\n")
              ((@ (system repl repl) start-repl))))))
   #:name "qemu-initrd"
   #:modules '((guix build utils)
               (guix build linux-initrd))
   #:linux linux-libre
   #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))

(define (gnu-system-initrd)
  "Initrd for the GNU system itself, with nothing QEMU-specific."
  (expression->initrd
   '(begin
      (use-modules (srfi srfi-1)
                   (srfi srfi-26)
                   (ice-9 match)
                   (guix build utils)
                   (guix build linux-initrd))

      (display "Welcome, this is GNU's early boot Guile.\n")
      (display "Use '--repl' for an initrd REPL.\n\n")

      (mount-essential-file-systems)
      (let* ((args    (linux-command-line))
             (option  (lambda (opt)
                        (let ((opt (string-append opt "=")))
                          (and=> (find (cut string-prefix? opt <>)
                                       args)
                                 (lambda (arg)
                                   (substring arg (+ 1 (string-index arg #\=))))))))
             (to-load (option "--load"))
             (root    (option "--root")))

        (when (member "--repl" args)
          ((@ (system repl repl) start-repl)))

        ;; Make /dev nodes.
        (make-essential-device-nodes)

        ;; Prepare the real root file system under /root.
        (mkdir-p "/root")
        (if root
            ;; Assume ROOT has a usable /dev tree.
            (mount root "/root" "ext3")
            (begin
              (mount "none" "/root" "tmpfs")
              (make-essential-device-nodes #:root "/root")))

        (mount-essential-file-systems #:root "/root")

        (mkdir-p "/root/tmp")
        (mount "none" "/root/tmp" "tmpfs")

        ;; XXX: We don't copy our fellow Guile modules to /root (see
        ;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can
        ;; happen if it throws, to display the exception!), then we're
        ;; screwed.  Hopefully TO-LOAD is a simple expression that just does
        ;; '(execlp ...)'.

        (if to-load
            (begin
              (format #t "loading '~a'...\n" to-load)
              (chroot "/root")
              (primitive-load to-load)
              (format (current-error-port)
                      "boot program '~a' terminated, rebooting~%"
                      to-load)
              (sleep 2)
              (reboot))
            (begin
              (display "no init file passed via '--load'\n")
              (display "entering a warm and cozy REPL\n")
              ((@ (system repl repl) start-repl))))))
   #:name "qemu-system-initrd"
   #:modules '((guix build linux-initrd)
               (guix build utils))
   #:linux linux-libre))

;;; linux-initrd.scm ends here
Commit	Line	Data
f09d925b	1	;;; GNU Guix --- Functional package management for GNU
b0dd47a8	2	;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
f09d925b LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
735c6dd7 LC	19	(define-module (gnu system linux-initrd)
735c6dd7 LC	20	#:use-module (guix monads)
f09d925b	21	#:use-module (guix utils)
f09d925b LC	22	#:use-module (gnu packages cpio)
	23	#:use-module (gnu packages compression)
	24	#:use-module (gnu packages linux)
f989fa39	25	#:use-module (gnu packages guile)
f09d925b LC	26	#:use-module ((gnu packages make-bootstrap)
f09d925b LC	27	#:select (%guile-static-stripped))
735c6dd7 LC	28	#:export (expression->initrd
	29	qemu-initrd
	30	gnu-system-initrd))
f09d925b LC	31
	32	\f
	33	;;; Commentary:
	34	;;;
	35	;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
	36	;;; particular initrd's that run Guile.
	37	;;;
	38	;;; Code:
	39
	40
	41	(define* (expression->initrd exp
	42	#:key
	43	(guile %guile-static-stripped)
	44	(cpio cpio)
	45	(gzip gzip)
	46	(name "guile-initrd")
	47	(system (%current-system))
f989fa39	48	(modules '())
f09d925b LC	49	(linux #f)
	50	(linux-modules '()))
	51	"Return a package that contains a Linux initrd (a gzipped cpio archive)
	52	containing GUILE and that evaluates EXP upon booting. LINUX-MODULES is a list
f989fa39 LC	53	of `.ko' file names to be copied from LINUX into the initrd. MODULES is a
f989fa39 LC	54	list of Guile module names to be embedded in the initrd."
f09d925b LC	55
	56	;; General Linux overview in `Documentation/early-userspace/README' and
	57	;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
	58
	59	(define builder
	60	`(begin
	61	(use-modules (guix build utils)
	62	(ice-9 pretty-print)
	63	(ice-9 popen)
	64	(ice-9 match)
	65	(ice-9 ftw)
	66	(srfi srfi-26)
	67	(system base compile)
	68	(rnrs bytevectors)
	69	((system foreign) #:select (sizeof)))
	70
f989fa39 LC	71	(let ((guile (assoc-ref %build-inputs "guile"))
	72	(cpio (string-append (assoc-ref %build-inputs "cpio")
	73	"/bin/cpio"))
	74	(gzip (string-append (assoc-ref %build-inputs "gzip")
	75	"/bin/gzip"))
	76	(modules (assoc-ref %build-inputs "modules"))
	77	(gos (assoc-ref %build-inputs "modules/compiled"))
	78	(scm-dir (string-append "share/guile/" (effective-version)))
	79	(go-dir (format #f ".cache/guile/ccache/~a-~a-~a-~a"
	80	(effective-version)
	81	(if (eq? (native-endianness) (endianness little))
	82	"LE"
	83	"BE")
	84	(sizeof '*)
	85	(effective-version)))
	86	(out (assoc-ref %outputs "out")))
f09d925b LC	87	(mkdir out)
	88	(mkdir "contents")
	89	(with-directory-excursion "contents"
	90	(copy-recursively guile ".")
	91	(call-with-output-file "init"
	92	(lambda (p)
	93	(format p "#!/bin/guile -ds~%!#~%" guile)
	94	(pretty-print ',exp p)))
	95	(chmod "init" #o555)
	96	(chmod "bin/guile" #o555)
	97
f989fa39 LC	98	;; Copy Guile modules.
	99	(chmod scm-dir #o777)
	100	(copy-recursively modules scm-dir
	101	#:follow-symlinks? #t)
	102	(copy-recursively gos (string-append "lib/guile/"
	103	(effective-version) "/ccache")
	104	#:follow-symlinks? #t)
	105
f09d925b	106	;; Compile `init'.
f989fa39 LC	107	(mkdir-p go-dir)
	108	(set! %load-path (cons modules %load-path))
	109	(set! %load-compiled-path (cons gos %load-compiled-path))
	110	(compile-file "init"
	111	#:opts %auto-compilation-options
	112	#:output-file (string-append go-dir "/init.go"))
f09d925b	113
f989fa39	114	;; Copy Linux modules.
f09d925b LC	115	(let* ((linux (assoc-ref %build-inputs "linux"))
	116	(module-dir (and linux
	117	(string-append linux "/lib/modules"))))
	118	(mkdir "modules")
	119	,@(map (lambda (module)
	120	`(match (find-files module-dir ,module)
	121	((file)
	122	(format #t "copying '~a'...~%" file)
	123	(copy-file file (string-append "modules/"
	124	,module)))
	125	(()
	126	(error "module not found" ,module module-dir))
	127	((_ ...)
	128	(error "several modules by that name"
	129	,module module-dir))))
	130	linux-modules))
	131
	132	;; Reset the timestamps of all the files that will make it in the
	133	;; initrd.
	134	(for-each (cut utime <> 0 0 0 0)
	135	(find-files "." ".*"))
	136
	137	(system* cpio "--version")
	138	(let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
	139	"-O" (string-append out "/initrd")
	140	"-H" "newc" "--null")))
	141	(define print0
	142	(let ((len (string-length "./")))
	143	(lambda (file)
	144	(format pipe "~a\0" (string-drop file len)))))
	145
	146	;; Note: as per `ramfs-rootfs-initramfs.txt', always add
	147	;; directory entries before the files that are inside of it: "The
	148	;; Linux kernel cpio extractor won't create files in a directory
	149	;; that doesn't exist, so the directory entries must go before
	150	;; the files that go in those directories."
	151	(file-system-fold (const #t)
	152	(lambda (file stat result) ; leaf
	153	(print0 file))
	154	(lambda (dir stat result) ; down
	155	(unless (string=? dir ".")
	156	(print0 dir)))
	157	(const #f) ; up
	158	(const #f) ; skip
	159	(const #f)
	160	#f
	161	".")
	162
	163	(and (zero? (close-pipe pipe))
	164	(with-directory-excursion out
	165	(and (zero? (system* gzip "--best" "initrd"))
	166	(rename-file "initrd.gz" "initrd")))))))))
	167
735c6dd7 LC	168	(mlet* %store-monad
	169	((source (imported-modules modules))
	170	(compiled (compiled-modules modules))
	171	(inputs (lower-inputs
	172	`(("guile" ,guile)
	173	("cpio" ,cpio)
	174	("gzip" ,gzip)
	175	("modules" ,source)
	176	("modules/compiled" ,compiled)
	177	,@(if linux
	178	`(("linux" ,linux))
	179	'())))))
	180	(derivation-expression name builder
	181	#:modules '((guix build utils))
	182	#:inputs inputs)))
	183
	184	(define (qemu-initrd)
	185	"Return a monadic derivation that builds an initrd for use in a QEMU guest
	186	where the store is shared with the host."
f09d925b LC	187	(expression->initrd
f09d925b LC	188	'(begin
88840f02	189	(use-modules (srfi srfi-1)
f09d925b LC	190	(srfi srfi-26)
f09d925b LC	191	(ice-9 match)
88840f02	192	((system base compile) #:select (compile-file))
89bf140b	193	(guix build utils)
88840f02	194	(guix build linux-initrd))
f09d925b	195
88840f02	196	(display "Welcome, this is GNU's early boot Guile.\n")
f09d925b LC	197	(display "Use '--repl' for an initrd REPL.\n\n")
f09d925b LC	198
88840f02 LC	199	(mount-essential-file-systems)
88840f02 LC	200	(let* ((args (linux-command-line))
f09d925b LC	201	(option (lambda (opt)
	202	(let ((opt (string-append opt "=")))
	203	(and=> (find (cut string-prefix? opt <>)
	204	args)
	205	(lambda (arg)
	206	(substring arg (+ 1 (string-index arg #\=))))))))
	207	(to-load (option "--load"))
	208	(root (option "--root")))
	209
	210	(when (member "--repl" args)
	211	((@ (system repl repl) start-repl)))
	212
88840f02 LC	213	(display "loading CIFS and companion modules...\n")
	214	(for-each (compose load-linux-module*
	215	(cut string-append "/modules/" <>))
	216	(list "md4.ko" "ecb.ko" "cifs.ko"))
f09d925b	217
88840f02 LC	218	(unless (configure-qemu-networking)
88840f02 LC	219	(display "network interface is DOWN\n"))
f09d925b	220
d91712ee LC	221	;; Make /dev nodes.
d91712ee LC	222	(make-essential-device-nodes)
b48d21b2	223
f09d925b LC	224	;; Prepare the real root file system under /root.
	225	(unless (file-exists? "/root")
	226	(mkdir "/root"))
	227	(if root
	228	(mount root "/root" "ext3")
	229	(mount "none" "/root" "tmpfs"))
88840f02 LC	230	(mount-essential-file-systems #:root "/root")
88840f02 LC	231
b0dd47a8	232	(mkdir-p "/root/xchg")
89bf140b	233	(mkdir-p "/root/nix/store")
f09d925b	234
7c1d8146 LC	235	(unless (file-exists? "/root/dev")
	236	(mkdir "/root/dev")
	237	(make-essential-device-nodes #:root "/root"))
f09d925b LC	238
f09d925b LC	239	;; Mount the host's store and exchange directory.
88840f02 LC	240	(mount-qemu-smb-share "/store" "/root/nix/store")
88840f02 LC	241	(mount-qemu-smb-share "/xchg" "/root/xchg")
f09d925b	242
89bf140b LC	243	;; Copy the directories that contain .scm and .go files so that the
	244	;; child process in the chroot can load modules (we would bind-mount
	245	;; them but for some reason that fails with EINVAL -- XXX).
b0dd47a8 LC	246	(mkdir-p "/root/share")
b0dd47a8 LC	247	(mkdir-p "/root/lib")
89bf140b LC	248	(mount "none" "/root/share" "tmpfs")
	249	(mount "none" "/root/lib" "tmpfs")
	250	(copy-recursively "/share" "/root/share"
	251	#:log (%make-void-port "w"))
	252	(copy-recursively "/lib" "/root/lib"
	253	#:log (%make-void-port "w"))
	254
	255
f09d925b	256	(if to-load
b0dd47a8 LC	257	(letrec ((resolve
	258	(lambda (file)
	259	;; If FILE is a symlink to an absolute file name,
	260	;; resolve it as if we were under /root.
	261	(let ((st (lstat file)))
	262	(if (eq? 'symlink (stat:type st))
	263	(let ((target (readlink file)))
	264	(resolve (string-append "/root" target)))
	265	file)))))
f09d925b	266	(format #t "loading boot file '~a'...\n" to-load)
b0dd47a8	267	(compile-file (resolve (string-append "/root/" to-load))
f09d925b LC	268	#:output-file "/root/loader.go"
	269	#:opts %auto-compilation-options)
	270	(match (primitive-fork)
	271	(0
	272	(chroot "/root")
89bf140b LC	273	(load-compiled "/loader.go")
	274
	275	;; TODO: Remove /lib, /share, and /loader.go.
	276	)
f09d925b LC	277	(pid
	278	(format #t "boot file loaded under PID ~a~%" pid)
	279	(let ((status (waitpid pid)))
	280	(reboot)))))
	281	(begin
	282	(display "no boot file passed via '--load'\n")
	283	(display "entering a warm and cozy REPL\n")
	284	((@ (system repl repl) start-repl))))))
	285	#:name "qemu-initrd"
89bf140b LC	286	#:modules '((guix build utils)
89bf140b LC	287	(guix build linux-initrd))
f09d925b LC	288	#:linux linux-libre
	289	#:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
	290
735c6dd7 LC	291	(define (gnu-system-initrd)
735c6dd7 LC	292	"Initrd for the GNU system itself, with nothing QEMU-specific."
1b89a66e LC	293	(expression->initrd
	294	'(begin
	295	(use-modules (srfi srfi-1)
	296	(srfi srfi-26)
	297	(ice-9 match)
	298	(guix build utils)
	299	(guix build linux-initrd))
	300
	301	(display "Welcome, this is GNU's early boot Guile.\n")
	302	(display "Use '--repl' for an initrd REPL.\n\n")
	303
	304	(mount-essential-file-systems)
	305	(let* ((args (linux-command-line))
	306	(option (lambda (opt)
	307	(let ((opt (string-append opt "=")))
	308	(and=> (find (cut string-prefix? opt <>)
	309	args)
	310	(lambda (arg)
	311	(substring arg (+ 1 (string-index arg #\=))))))))
	312	(to-load (option "--load"))
	313	(root (option "--root")))
	314
	315	(when (member "--repl" args)
	316	((@ (system repl repl) start-repl)))
	317
	318	;; Make /dev nodes.
	319	(make-essential-device-nodes)
	320
	321	;; Prepare the real root file system under /root.
fbd1c3e9	322	(mkdir-p "/root")
1b89a66e LC	323	(if root
	324	;; Assume ROOT has a usable /dev tree.
	325	(mount root "/root" "ext3")
	326	(begin
	327	(mount "none" "/root" "tmpfs")
	328	(make-essential-device-nodes #:root "/root")))
	329
	330	(mount-essential-file-systems #:root "/root")
	331
fbd1c3e9 LC	332	(mkdir-p "/root/tmp")
	333	(mount "none" "/root/tmp" "tmpfs")
	334
1b89a66e LC	335	;; XXX: We don't copy our fellow Guile modules to /root (see
	336	;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can
	337	;; happen if it throws, to display the exception!), then we're
	338	;; screwed. Hopefully TO-LOAD is a simple expression that just does
	339	;; '(execlp ...)'.
	340
	341	(if to-load
	342	(begin
	343	(format #t "loading '~a'...\n" to-load)
	344	(chroot "/root")
	345	(primitive-load to-load)
	346	(format (current-error-port)
e0ba5fe5 LC	347	"boot program '~a' terminated, rebooting~%"
e0ba5fe5 LC	348	to-load)
1b89a66e LC	349	(sleep 2)
	350	(reboot))
	351	(begin
b0dd47a8	352	(display "no init file passed via '--load'\n")
1b89a66e LC	353	(display "entering a warm and cozy REPL\n")
	354	((@ (system repl repl) start-repl))))))
	355	#:name "qemu-system-initrd"
	356	#:modules '((guix build linux-initrd)
	357	(guix build utils))
	358	#:linux linux-libre))
	359
f09d925b	360	;;; linux-initrd.scm ends here