gnu/packages/linux-initrd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
   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
  19 (define-module (gnu packages linux-initrd)
  20   #:use-module (guix utils)
  21   #:use-module (guix licenses)
  22   #:use-module (guix build-system)
  23   #:use-module ((guix derivations)
  24                 #:select (imported-modules compiled-modules %guile-for-build))
  25   #:use-module (gnu packages)
  26   #:use-module (gnu packages cpio)
  27   #:use-module (gnu packages compression)
  28   #:use-module (gnu packages linux)
  29   #:use-module (gnu packages guile)
  30   #:use-module ((gnu packages make-bootstrap)
  31                 #:select (%guile-static-stripped))
  32   #:use-module (guix packages)
  33   #:use-module (guix download)
  34   #:use-module (guix build-system trivial))
  35
  36 \f
  37 ;;; Commentary:
  38 ;;;
  39 ;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
  40 ;;; particular initrd's that run Guile.
  41 ;;;
  42 ;;; Code:
  43
  44
  45 (define-syntax-rule (raw-build-system (store system name inputs) body ...)
  46   "Lift BODY to a package build system."
  47   ;; TODO: Generalize.
  48   (build-system
  49    (name "raw")
  50    (description "Raw build system")
  51    (build (lambda* (store name source inputs #:key system #:allow-other-keys)
  52             (parameterize ((%guile-for-build (package-derivation store
  53                                                                  guile-2.0)))
  54               body ...)))))
  55
  56 (define (module-package modules)
  57   "Return a package that contains all of MODULES, a list of Guile module
  58 names."
  59   (package
  60     (name "guile-modules")
  61     (version "0")
  62     (source #f)
  63     (build-system (raw-build-system (store system name inputs)
  64                     (imported-modules store modules
  65                                       #:name name
  66                                       #:system system)))
  67     (synopsis "Set of Guile modules")
  68     (description synopsis)
  69     (license gpl3+)
  70     (home-page "http://www.gnu.org/software/guix/")))
  71
  72 (define (compiled-module-package modules)
  73   "Return a package that contains the .go files corresponding to MODULES, a
  74 list of Guile module names."
  75   (package
  76     (name "guile-compiled-modules")
  77     (version "0")
  78     (source #f)
  79     (build-system (raw-build-system (store system name inputs)
  80                     (compiled-modules store modules
  81                                       #:name name
  82                                       #:system system)))
  83     (synopsis "Set of compiled Guile modules")
  84     (description synopsis)
  85     (license gpl3+)
  86     (home-page "http://www.gnu.org/software/guix/")))
  87
  88 (define* (expression->initrd exp
  89                              #:key
  90                              (guile %guile-static-stripped)
  91                              (cpio cpio)
  92                              (gzip gzip)
  93                              (name "guile-initrd")
  94                              (system (%current-system))
  95                              (modules '())
  96                              (linux #f)
  97                              (linux-modules '()))
  98   "Return a package that contains a Linux initrd (a gzipped cpio archive)
  99 containing GUILE and that evaluates EXP upon booting.  LINUX-MODULES is a list
 100 of `.ko' file names to be copied from LINUX into the initrd.  MODULES is a
 101 list of Guile module names to be embedded in the initrd."
 102
 103   ;; General Linux overview in `Documentation/early-userspace/README' and
 104   ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
 105
 106   (define builder
 107     `(begin
 108        (use-modules (guix build utils)
 109                     (ice-9 pretty-print)
 110                     (ice-9 popen)
 111                     (ice-9 match)
 112                     (ice-9 ftw)
 113                     (srfi srfi-26)
 114                     (system base compile)
 115                     (rnrs bytevectors)
 116                     ((system foreign) #:select (sizeof)))
 117
 118        (let ((guile   (assoc-ref %build-inputs "guile"))
 119              (cpio    (string-append (assoc-ref %build-inputs "cpio")
 120                                      "/bin/cpio"))
 121              (gzip    (string-append (assoc-ref %build-inputs "gzip")
 122                                      "/bin/gzip"))
 123              (modules (assoc-ref %build-inputs "modules"))
 124              (gos     (assoc-ref %build-inputs "modules/compiled"))
 125              (scm-dir (string-append "share/guile/" (effective-version)))
 126              (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
 127                               (effective-version)
 128                               (if (eq? (native-endianness) (endianness little))
 129                                   "LE"
 130                                   "BE")
 131                               (sizeof '*)
 132                               (effective-version)))
 133              (out     (assoc-ref %outputs "out")))
 134          (mkdir out)
 135          (mkdir "contents")
 136          (with-directory-excursion "contents"
 137            (copy-recursively guile ".")
 138            (call-with-output-file "init"
 139              (lambda (p)
 140                (format p "#!/bin/guile -ds~%!#~%" guile)
 141                (pretty-print ',exp p)))
 142            (chmod "init" #o555)
 143            (chmod "bin/guile" #o555)
 144
 145            ;; Copy Guile modules.
 146            (chmod scm-dir #o777)
 147            (copy-recursively modules scm-dir
 148                              #:follow-symlinks? #t)
 149            (copy-recursively gos (string-append "lib/guile/"
 150                                                 (effective-version) "/ccache")
 151                              #:follow-symlinks? #t)
 152
 153            ;; Compile `init'.
 154            (mkdir-p go-dir)
 155            (set! %load-path (cons modules %load-path))
 156            (set! %load-compiled-path (cons gos %load-compiled-path))
 157            (compile-file "init"
 158                          #:opts %auto-compilation-options
 159                          #:output-file (string-append go-dir "/init.go"))
 160
 161            ;; Copy Linux modules.
 162            (let* ((linux      (assoc-ref %build-inputs "linux"))
 163                   (module-dir (and linux
 164                                    (string-append linux "/lib/modules"))))
 165              (mkdir "modules")
 166              ,@(map (lambda (module)
 167                       `(match (find-files module-dir ,module)
 168                          ((file)
 169                           (format #t "copying '~a'...~%" file)
 170                           (copy-file file (string-append "modules/"
 171                                                          ,module)))
 172                          (()
 173                           (error "module not found" ,module module-dir))
 174                          ((_ ...)
 175                           (error "several modules by that name"
 176                                  ,module module-dir))))
 177                     linux-modules))
 178
 179            ;; Reset the timestamps of all the files that will make it in the
 180            ;; initrd.
 181            (for-each (cut utime <> 0 0 0 0)
 182                      (find-files "." ".*"))
 183
 184            (system* cpio "--version")
 185            (let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
 186                                    "-O" (string-append out "/initrd")
 187                                    "-H" "newc" "--null")))
 188              (define print0
 189                (let ((len (string-length "./")))
 190                  (lambda (file)
 191                    (format pipe "~a\0" (string-drop file len)))))
 192
 193              ;; Note: as per `ramfs-rootfs-initramfs.txt', always add
 194              ;; directory entries before the files that are inside of it: "The
 195              ;; Linux kernel cpio extractor won't create files in a directory
 196              ;; that doesn't exist, so the directory entries must go before
 197              ;; the files that go in those directories."
 198              (file-system-fold (const #t)
 199                                (lambda (file stat result) ; leaf
 200                                  (print0 file))
 201                                (lambda (dir stat result) ; down
 202                                  (unless (string=? dir ".")
 203                                    (print0 dir)))
 204                                (const #f)         ; up
 205                                (const #f)         ; skip
 206                                (const #f)
 207                                #f
 208                                ".")
 209
 210              (and (zero? (close-pipe pipe))
 211                   (with-directory-excursion out
 212                     (and (zero? (system* gzip "--best" "initrd"))
 213                          (rename-file "initrd.gz" "initrd")))))))))
 214
 215   (let ((name* name))
 216     (package
 217       (name name*)
 218       (version "0")
 219       (source #f)
 220       (build-system trivial-build-system)
 221       (arguments `(#:modules ((guix build utils))
 222                    #:builder ,builder))
 223       (inputs `(("guile" ,guile)
 224                 ("cpio" ,cpio)
 225                 ("gzip" ,gzip)
 226                 ("modules" ,(module-package modules))
 227                 ("modules/compiled" ,(compiled-module-package modules))
 228                 ,@(if linux
 229                       `(("linux" ,linux))
 230                       '())))
 231       (synopsis "An initial RAM disk (initrd) for the Linux kernel")
 232       (description
 233        "An initial RAM disk (initrd), really a gzipped cpio archive, for use by
 234 the Linux kernel.")
 235       (license gpl3+)
 236       (home-page "http://www.gnu.org/software/guix/"))))
 237
 238 (define-public qemu-initrd
 239   (expression->initrd
 240    '(begin
 241       (use-modules (srfi srfi-1)
 242                    (srfi srfi-26)
 243                    (ice-9 match)
 244                    ((system base compile) #:select (compile-file))
 245                    (guix build linux-initrd))
 246
 247       (display "Welcome, this is GNU's early boot Guile.\n")
 248       (display "Use '--repl' for an initrd REPL.\n\n")
 249
 250       (mount-essential-file-systems)
 251       (let* ((args    (linux-command-line))
 252              (option  (lambda (opt)
 253                         (let ((opt (string-append opt "=")))
 254                           (and=> (find (cut string-prefix? opt <>)
 255                                        args)
 256                                  (lambda (arg)
 257                                    (substring arg (+ 1 (string-index arg #\=))))))))
 258              (to-load (option "--load"))
 259              (root    (option "--root")))
 260
 261         (when (member "--repl" args)
 262           ((@ (system repl repl) start-repl)))
 263
 264         (display "loading CIFS and companion modules...\n")
 265         (for-each (compose load-linux-module*
 266                            (cut string-append "/modules/" <>))
 267                   (list "md4.ko" "ecb.ko" "cifs.ko"))
 268
 269         (unless (configure-qemu-networking)
 270           (display "network interface is DOWN\n"))
 271
 272         ;; Prepare the real root file system under /root.
 273         (unless (file-exists? "/root")
 274           (mkdir "/root"))
 275         (if root
 276             (mount root "/root" "ext3")
 277             (mount "none" "/root" "tmpfs"))
 278         (mount-essential-file-systems #:root "/root")
 279
 280         (mkdir "/root/xchg")
 281         (mkdir "/root/nix")
 282         (mkdir "/root/nix/store")
 283
 284         (mkdir "/root/dev")
 285         (mknod "/root/dev/null" 'char-special #o666 (device-number 1 3))
 286         (mknod "/root/dev/zero" 'char-special #o666 (device-number 1 5))
 287
 288         ;; Mount the host's store and exchange directory.
 289         (mount-qemu-smb-share "/store" "/root/nix/store")
 290         (mount-qemu-smb-share "/xchg" "/root/xchg")
 291
 292         (if to-load
 293             (begin
 294               (format #t "loading boot file '~a'...\n" to-load)
 295               (compile-file (string-append "/root/" to-load)
 296                             #:output-file "/root/loader.go"
 297                             #:opts %auto-compilation-options)
 298               (match (primitive-fork)
 299                 (0
 300                  (chroot "/root")
 301                  (load-compiled "/loader.go"))
 302                 (pid
 303                  (format #t "boot file loaded under PID ~a~%" pid)
 304                  (let ((status (waitpid pid)))
 305                    (reboot)))))
 306             (begin
 307               (display "no boot file passed via '--load'\n")
 308               (display "entering a warm and cozy REPL\n")
 309               ((@ (system repl repl) start-repl))))))
 310    #:name "qemu-initrd"
 311    #:modules '((guix build linux-initrd))
 312    #:linux linux-libre
 313    #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
 314
 315 ;;; linux-initrd.scm ends here