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


;;; 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 '()))
  "Return a derivation that builds 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.

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'.

  (mlet %store-monad ((init (gexp->script "init" exp
                                          #:modules modules
                                          #:guile guile)))
    (define builder
      #~(begin
          (use-modules (gnu build linux-initrd))

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

   (gexp->derivation name builder
                     #:modules '((guix build utils)
                                 (guix build store-copy)
                                 (gnu build linux-initrd))
                     #:references-graphs `(("closure" ,init)))))

(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
    #~(begin
        (use-modules (ice-9 match) (ice-9 regex)
                     (srfi srfi-1)
                     (guix build utils)
                     (gnu build linux-modules))

        (define (string->regexp str)
          ;; Return a regexp that matches STR exactly.
          (string-append "^" (regexp-quote str) "$"))

        (define module-dir
          (string-append #$linux "/lib/modules"))

        (define (lookup module)
          (let ((name (ensure-dot-ko module)))
            (match (find-files module-dir (string->regexp name))
              ((file)
               file)
              (()
               (error "module not found" name module-dir))
              ((_ ...)
               (error "several modules by that name"
                      name module-dir)))))

        (define modules
          (let ((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))))

  (gexp->derivation "linux-modules" build-exp
                    #:modules '((guix build utils)
                                (guix elf)
                                (gnu build linux-modules))))

(define (file-system->spec fs)
  "Return a list corresponding to file-system FS that can be passed to the
initrd code."
  (match fs
    (($ <file-system> device title mount-point type flags options _ check?)
     (list device title mount-point type flags options check?))))

(define* (base-initrd file-systems
                      #:key
                      (mapped-devices '())
                      qemu-networking?
                      virtio?
                      volatile-root?
                      (extra-modules '()))
  "Return a monadic derivation that builds a generic initrd.  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 QEMU-NETWORKING? is true, set up networking with the standard QEMU
parameters.  When VIRTIO? is true, load additional modules so the initrd can
be used as a QEMU guest with para-virtualized I/O drivers.

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

The initrd is automatically populated with all the kernel modules necessary
for FILE-SYSTEMS and for the given options.  However, additional kernel
modules can be listed in EXTRA-MODULES.  They will be added to the initrd, and
loaded at boot time in the order in which they appear."
  (define virtio-modules
    ;; Modules for Linux para-virtualized devices, for use in QEMU guests.
    '("virtio_pci.ko" "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko"))

  (define cifs-modules
    ;; Modules needed to mount CIFS file systems.
    '("md4.ko" "ecb.ko" "cifs.ko"))

  (define virtio-9p-modules
    ;; Modules for the 9p paravirtualized file system.
    '("9p.ko" "9pnet_virtio.ko"))

  (define (file-system-type-predicate type)
    (lambda (fs)
      (string=? (file-system-type fs) type)))

  (define linux-modules
    ;; Modules added to the initrd and loaded from the initrd.
    `("ahci.ko"                                   ;for SATA controllers
      "pata_acpi.ko" "pata_atiixp.ko"             ;for ATA controllers
      ,@(if (or virtio? qemu-networking?)
            virtio-modules
            '())
      ,@(if (find (file-system-type-predicate "cifs") file-systems)
            cifs-modules
            '())
      ,@(if (find (file-system-type-predicate "9p") file-systems)
            virtio-9p-modules
            '())
      ,@(if volatile-root?
            '("fuse.ko")
            '())
      ,@extra-modules))

  (define helper-packages
    ;; Packages to be copied on the initrd.
    `(,@(if (find (lambda (fs)
                    (string-prefix? "ext" (file-system-type fs)))
                  file-systems)
            (list e2fsck/static)
            '())
      ,@(if volatile-root?
            (list unionfs-fuse/static)
            '())))

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

  (mlet %store-monad ((kodir (flat-linux-module-directory linux-libre
                                                          linux-modules)))
    (expression->initrd
     #~(begin
         (use-modules (gnu build linux-boot)
                      (guix build utils)
                      (srfi srfi-26))

         (with-output-to-port (%make-void-port "w")
           (lambda ()
             (set-path-environment-variable "PATH" '("bin" "sbin")
                                            '#$helper-packages)))

         (boot-system #:mounts '#$(map file-system->spec file-systems)
                      #:pre-mount (lambda ()
                                    (and #$@device-mapping-commands))
                      #:linux-modules '#$linux-modules
                      #:linux-module-directory '#$kodir
                      #:qemu-guest-networking? #$qemu-networking?
                      #:volatile-root? '#$volatile-root?))
     #:name "base-initrd"
     #:modules '((guix build utils)
                 (gnu build linux-boot)
                 (gnu build linux-modules)
                 (gnu build file-systems)
                 (guix elf)))))

;;; linux-initrd.scm ends here