system: Add first-class file system declarations.

* gnu/system.scm (<operating-system>)[initrd]: Default to
  'qemu-initrd'.
  (<file-system>): New record type.
  (operating-system-root-file-system): New procedure.
  (operating-system-derivation): Take the device name for GRUB from
  'operating-system-root-file-system'.  Pass the
  'operating-system-initrd' procedure the list of boot file systems.
* gnu/system/linux-initrd.scm (file-system->spec): New procedure.
  (qemu-initrd): Add 'file-systems' parameter, and remove #:mounts
  parameter.
  [file-system-type-predicate]: New procedure.
  [linux-modules]: Use it.
  Adjust #:mounts argument in 'boot-system' call.
  (gnu-system-initrd): Remove.
* gnu/system/vm.scm (%linux-vm-file-systems): New variable.
  (expression->derivation-in-linux-vm): Adjust call to 'qemu-initrd'.
  (virtualized-operating-system): New procedure.
  (system-qemu-image/shared-store-script)[initrd]: Remove.  Use
  'virtualized-operating-system'.  Get the 'initrd' file from OS-DRV.
* guix/build/linux-initrd.scm (mount-qemu-smb-share, mount-qemu-9p):
  Remove.
  (MS_RDONLY, MS_BIND): New global variables.
  (bind-mount): Remove local 'MS_BIND' definition.
  (mount-root-file-system): New procedure, with code formerly in
  'boot-system'.
  (mount-file-system): New procedure.
  (boot-system): Add #:root-fs-type parameter.  Remove 'MS_RDONLY' local
  variable.  Use 'mount-root-file-system' and 'mount-file-system'.
* doc/guix.texi (Using the Configuration System): Add 'file-system'
  declaration.

6 files changed, 180 insertions, 100 deletions

diff --git a/.dir-locals.el b/.dir-locals.el
index a6135b171e..64a680c59f 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -17,6 +17,8 @@
    (eval . (put 'with-directory-excursion 'scheme-indent-function 1))
    (eval . (put 'package 'scheme-indent-function 0))
    (eval . (put 'origin 'scheme-indent-function 0))
+   (eval . (put 'operating-system 'scheme-indent-function 0))
+   (eval . (put 'file-system 'scheme-indent-function 0))
    (eval . (put 'manifest-entry 'scheme-indent-function 0))
    (eval . (put 'manifest-pattern 'scheme-indent-function 0))
    (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))
diff --git a/doc/guix.texi b/doc/guix.texi
index 3ae2b7e00b..99acad56e7 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3088,6 +3088,10 @@ Linux-Libre kernel, initial RAM disk, and boot loader looks like this:
    (host-name "komputilo")
    (timezone "Europe/Paris")
    (locale "fr_FR.UTF-8")
+   (file-systems (list (file-system
+                         (device "/dev/disk/by-label/root")
+                         (mount-point "/")
+                         (type "ext3"))))
    (users (list (user-account
                  (name "alice")
                  (password "")
diff --git a/gnu/system.scm b/gnu/system.scm
index 6c94eb90c5..7624b10ae4 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -51,9 +51,20 @@
             operating-system-timezone
             operating-system-locale
             operating-system-services
+            operating-system-file-systems
 
             operating-system-derivation
-            operating-system-profile))
+            operating-system-profile
+
+            <file-system>
+            file-system
+            file-system?
+            file-system-device
+            file-system-mount-point
+            file-system-type
+            file-system-needed-for-boot?
+            file-system-flags
+            file-system-options))
 
 ;;; Commentary:
 ;;;
@@ -72,8 +83,8 @@
               (default grub))
   (bootloader-entries operating-system-bootloader-entries ; list
                       (default '()))
-  (initrd operating-system-initrd                 ; monadic derivation
-          (default (gnu-system-initrd)))
+  (initrd operating-system-initrd                 ; (list fs) -> M derivation
+          (default qemu-initrd))
 
   (host-name operating-system-host-name)          ; string
 
@@ -112,6 +123,22 @@
   (sudoers operating-system-sudoers               ; /etc/sudoers contents
            (default %sudoers-specification)))
 
+;; File system declaration.
+(define-record-type* <file-system> file-system
+  make-file-system
+  file-system?
+  (device           file-system-device)           ; string
+  (mount-point      file-system-mount-point)      ; string
+  (type             file-system-type)             ; string
+  (flags            file-system-flags             ; list of symbols
+                    (default '()))
+  (options          file-system-options           ; string or #f
+                    (default #f))
+  (needed-for-boot? file-system-needed-for-boot?  ; Boolean
+                    (default #f))
+  (check?           file-system-check?            ; Boolean
+                    (default #t)))
+
 
 ;;;
 ;;; Derivation.
@@ -311,16 +338,30 @@ we're running in the final root."
                     (execl (string-append #$dmd "/bin/dmd")
                            "dmd" "--config" #$dmd-conf)))))
 
+(define (operating-system-root-file-system os)
+  "Return the root file system of OS."
+  (find (match-lambda
+         (($ <file-system> _ "/") #t)
+         (_ #f))
+        (operating-system-file-systems os)))
+
 (define (operating-system-derivation os)
   "Return a derivation that builds OS."
+  (define boot-file-systems
+    (filter (match-lambda
+             (($ <file-system> device mount-point type _ _ boot?)
+              (and boot? (not (string=? mount-point "/")))))
+            (operating-system-file-systems os)))
+
   (mlet* %store-monad
       ((profile     (operating-system-profile os))
        (etc         (operating-system-etc-directory os))
        (services    (sequence %store-monad (operating-system-services os)))
        (boot        (operating-system-boot-script os))
        (kernel  ->  (operating-system-kernel os))
-       (initrd      (operating-system-initrd os))
+       (initrd      ((operating-system-initrd os) boot-file-systems))
        (initrd-file -> #~(string-append #$initrd "/initrd"))
+       (root-fs ->  (operating-system-root-file-system os))
        (entries ->  (list (menu-entry
                            (label (string-append
                                    "GNU system with "
@@ -328,7 +369,8 @@ we're running in the final root."
                                    " (technology preview)"))
                            (linux kernel)
                            (linux-arguments
-                            (list "--root=/dev/sda1"
+                            (list (string-append "--root="
+                                                 (file-system-device root-fs))
                                   #~(string-append "--load=" #$boot)))
                            (initrd initrd-file))))
        (grub.cfg (grub-configuration-file entries)))
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 6e04ad150f..8b4ab9c4eb 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -30,11 +30,12 @@
   #:use-module (gnu packages guile)
   #:use-module ((gnu packages make-bootstrap)
                 #:select (%guile-static-stripped))
+  #:use-module (gnu system)                       ; for 'file-system'
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (srfi srfi-1)
   #:export (expression->initrd
-            qemu-initrd
-            gnu-system-initrd))
+            qemu-initrd))
 
 
 ;;; Commentary:
@@ -193,24 +194,29 @@ a list of Guile module names to be embedded in the initrd."
    (gexp->derivation name builder
                      #:modules '((guix build utils)))))
 
-(define* (qemu-initrd #:key
+(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 mount-point type flags options)
+     (list device mount-point type flags options))))
+
+(define* (qemu-initrd file-systems
+                      #:key
                       guile-modules-in-chroot?
-                      volatile-root?
-                      (mounts `((cifs "/store" ,(%store-prefix))
-                                (cifs "/xchg" "/xchg"))))
+                      volatile-root?)
   "Return a monadic derivation that builds an initrd for use in a QEMU guest
-where the store is shared with the host.  MOUNTS is a list of file systems to
-be mounted atop the root file system, where each item has the form:
+where the store is shared with the host.  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'.
 
-    (FILE-SYSTEM-TYPE SOURCE TARGET)
+When VOLATILE-ROOT? is true, the root file system is writable but any changes
+to it are lost.
 
 When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
 the new root.  This is necessary is the file specified as '--load' needs
 access to these modules (which is the case if it wants to even just print an
-exception and backtrace!).
-
-When VOLATILE-ROOT? is true, the root file system is writable but any changes
-to it are lost."
+exception and backtrace!)."
   (define cifs-modules
     ;; Modules needed to mount CIFS file systems.
     '("md4.ko" "ecb.ko" "cifs.ko"))
@@ -219,14 +225,18 @@ to it are lost."
     ;; Modules for the 9p paravirtualized file system.
     '("9pnet.ko" "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.
     `("virtio.ko" "virtio_ring.ko" "virtio_pci.ko"
       "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko"
-      ,@(if (assoc-ref mounts 'cifs)
+      ,@(if (find (file-system-type-predicate "cifs") file-systems)
             cifs-modules
             '())
-      ,@(if (assoc-ref mounts '9p)
+      ,@(if (find (file-system-type-predicate "9p") file-systems)
             virtio-9p-modules
             '())
       ,@(if volatile-root?
@@ -238,7 +248,7 @@ to it are lost."
        (use-modules (guix build linux-initrd)
                     (srfi srfi-26))
 
-       (boot-system #:mounts '#$mounts
+       (boot-system #:mounts '#$(map file-system->spec file-systems)
                     #:linux-modules '#$linux-modules
                     #:qemu-guest-networking? #t
                     #:guile-modules-in-chroot? '#$guile-modules-in-chroot?
@@ -254,9 +264,4 @@ to it are lost."
    #:linux linux-libre
    #:linux-modules linux-modules))
 
-(define (gnu-system-initrd)
-  "Initrd for the GNU system itself, with nothing QEMU-specific."
-  (qemu-initrd #:guile-modules-in-chroot? #f
-               #:mounts '()))
-
 ;;; linux-initrd.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index db24c4e761..c080317415 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -82,6 +82,22 @@ input tuple.  The output file name is when building for SYSTEM."
       ((input (and (? string?) (? store-path?) file))
        (return `(,input . ,file))))))
 
+(define %linux-vm-file-systems
+  ;; File systems mounted for 'derivation-in-linux-vm'.  The store and /xchg
+  ;; directory are shared with the host over 9p.
+  (list (file-system
+          (mount-point (%store-prefix))
+          (device "store")
+          (type "9p")
+          (needed-for-boot? #t)
+          (options "trans=virtio"))
+        (file-system
+          (mount-point "/xchg")
+          (device "xchg")
+          (type "9p")
+          (needed-for-boot? #t)
+          (options "trans=virtio"))))
+
 (define* (expression->derivation-in-linux-vm name exp
                                              #:key
                                              (system (%current-system))
@@ -130,9 +146,8 @@ made available under the /xchg CIFS share."
        (coreutils -> (car (assoc-ref %final-inputs "coreutils")))
        (initrd       (if initrd                   ; use the default initrd?
                          (return initrd)
-                         (qemu-initrd #:guile-modules-in-chroot? #t
-                                      #:mounts `((9p "store" ,(%store-prefix))
-                                                 (9p "xchg" "/xchg"))))))
+                         (qemu-initrd %linux-vm-file-systems
+                                      #:guile-modules-in-chroot? #t))))
 
     (define builder
       ;; Code that launches the VM that evaluates EXP.
@@ -292,6 +307,22 @@ system as described by OS."
                  #:initialize-store? #t
                  #:inputs-to-copy `(("system" ,os-drv)))))
 
+(define (virtualized-operating-system os)
+  "Return an operating system based on OS suitable for use in a virtualized
+environment with the store shared with the host."
+  (operating-system (inherit os)
+    (initrd (cut qemu-initrd <> #:volatile-root? #t))
+    (file-systems (list (file-system
+                          (mount-point "/")
+                          (device "/dev/vda1")
+                          (type "ext3"))
+                        (file-system
+                          (mount-point (%store-prefix))
+                          (device "store")
+                          (type "9p")
+                          (needed-for-boot? #t)
+                          (options "trans=virtio"))))))
+
 (define* (system-qemu-image/shared-store
           os
           #:key (disk-image-size (* 15 (expt 2 20))))
@@ -314,14 +345,9 @@ with the host."
           (graphic? #t))
   "Return a derivation that builds a script to run a virtual machine image of
 OS that shares its store with the host."
-  (define initrd
-    (qemu-initrd #:mounts `((9p "store" ,(%store-prefix)))
-                 #:volatile-root? #t))
-
   (mlet* %store-monad
-      ((os ->  (operating-system (inherit os) (initrd initrd)))
+      ((os ->  (virtualized-operating-system os))
        (os-drv (operating-system-derivation os))
-       (initrd initrd)
        (image  (system-qemu-image/shared-store os)))
     (define builder
       #~(call-with-output-file #$output
@@ -332,7 +358,7 @@ exec " #$qemu "/bin/qemu-system-x86_64 -enable-kvm -no-reboot -net nic,model=vir
   -virtfs local,path=" #$(%store-prefix) ",security_model=none,mount_tag=store \
   -net user \
   -kernel " #$(operating-system-kernel os) "/bzImage \
-  -initrd " #$initrd "/initrd \
+  -initrd " #$os-drv "/initrd \
 -append \"" #$(if graphic? "" "console=ttyS0 ")
   "--load=" #$os-drv "/boot --root=/dev/vda1\" \
   -drive file=" #$image
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 4decc3b15c..1e0d6e27ec 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -30,8 +30,7 @@
             linux-command-line
             make-essential-device-nodes
             configure-qemu-networking
-            mount-qemu-smb-share
-            mount-qemu-9p
+            mount-file-system
             bind-mount
             load-linux-module*
             device-number
@@ -170,33 +169,12 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
 
     (logand (network-interface-flags sock interface) IFF_UP)))
 
-(define (mount-qemu-smb-share share mount-point)
-  "Mount QEMU's CIFS/SMB SHARE at MOUNT-POINT.
-
-Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our
-`qemu-with-multiple-smb-shares' package exports the /xchg and /store shares
- (the latter allows the store to be shared between the host and guest.)"
-
-  (format #t "mounting QEMU's SMB share `~a'...\n" share)
-  (let ((server "10.0.2.4"))
-    (mount (string-append "//" server share) mount-point "cifs" 0
-           (string->pointer "guest,sec=none"))))
-
-(define (mount-qemu-9p source mount-point)
-  "Mount QEMU's 9p file system from SOURCE at MOUNT-POINT.
-
-This uses the 'virtio' transport, which requires the various virtio Linux
-modules to be loaded."
-
-  (format #t "mounting QEMU's 9p share '~a'...\n" source)
-  (let ((server "10.0.2.4"))
-    (mount source mount-point "9p" 0
-           (string->pointer "trans=virtio"))))
+;; Linux mount flags, from libc's <sys/mount.h>.
+(define MS_RDONLY 1)
+(define MS_BIND 4096)
 
 (define (bind-mount source target)
   "Bind-mount SOURCE at TARGET."
-  (define MS_BIND 4096)                           ; from libc's <sys/mount.h>
-
   (mount source target "" MS_BIND))
 
 (define (load-linux-module* file)
@@ -211,11 +189,67 @@ modules to be loaded."
 the last argument of `mknod'."
   (+ (* major 256) minor))
 
+(define* (mount-root-file-system root type
+                                 #:key volatile-root? unionfs)
+  "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
+is true, mount ROOT read-only and make it a union with a writable tmpfs using
+UNIONFS."
+  (catch #t
+    (lambda ()
+      (if volatile-root?
+          (begin
+            (mkdir-p "/real-root")
+            (mount root "/real-root" type MS_RDONLY)
+            (mkdir-p "/rw-root")
+            (mount "none" "/rw-root" "tmpfs")
+
+            ;; We want read-write /dev nodes.
+            (make-essential-device-nodes #:root "/rw-root")
+
+            ;; Make /root a union of the tmpfs and the actual root.
+            (unless (zero? (system* unionfs "-o"
+                                    "cow,allow_other,use_ino,suid,dev"
+                                    "/rw-root=RW:/real-root=RO"
+                                    "/root"))
+              (error "unionfs failed")))
+          (mount root "/root" "ext3")))
+    (lambda args
+      (format (current-error-port) "exception while mounting '~a': ~s~%"
+              root args)
+      (start-repl))))
+
+(define* (mount-file-system spec #:key (root "/root"))
+  "Mount the file system described by SPEC under ROOT.  SPEC must have the
+form:
+
+  (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS)
+
+DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
+FLAGS must be a list of symbols."
+  (define flags->bit-mask
+    (match-lambda
+     (('read-only rest ...)
+      (or MS_RDONLY (flags->bit-mask rest)))
+     (('bind-mount rest ...)
+      (or MS_BIND (flags->bit-mask rest)))
+     (()
+      0)))
+
+  (match spec
+    ((source mount-point type (flags ...) options)
+     (let ((mount-point (string-append root "/" mount-point)))
+       (mkdir-p mount-point)
+       (mount source mount-point type (flags->bit-mask flags)
+              (if options
+                  (string->pointer options)
+                  %null-pointer))))))
+
 (define* (boot-system #:key
                       (linux-modules '())
                       qemu-guest-networking?
                       guile-modules-in-chroot?
                       volatile-root? unionfs
+                      (root-fs-type "ext3")
                       (mounts '()))
   "This procedure is meant to be called from an initrd.  Boot a system by
 first loading LINUX-MODULES, then setting up QEMU guest networking if
@@ -223,9 +257,7 @@ QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS,
 and finally booting into the new root if any.  The initrd supports kernel
 command-line options '--load', '--root', and '--repl'.
 
-MOUNTS must be a list of elements of the form:
-
-  (FILE-SYSTEM-TYPE SOURCE TARGET)
+MOUNTS must be a list suitable for 'mount-file-system'.
 
 When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
 the new root.
@@ -241,8 +273,6 @@ to it are lost."
             (resolve (string-append "/root" target)))
           file)))
 
-  (define MS_RDONLY 1)
-
   (display "Welcome, this is GNU's early boot Guile.\n")
   (display "Use '--repl' for an initrd REPL.\n\n")
 
@@ -276,29 +306,9 @@ to it are lost."
     (unless (file-exists? "/root")
       (mkdir "/root"))
     (if root
-        (catch #t
-          (lambda ()
-            (if volatile-root?
-                (begin
-                  (mkdir-p "/real-root")
-                  (mount root "/real-root" "ext3" MS_RDONLY)
-                  (mkdir-p "/rw-root")
-                  (mount "none" "/rw-root" "tmpfs")
-
-                  ;; We want read-write /dev nodes.
-                  (make-essential-device-nodes #:root "/rw-root")
-
-                  ;; Make /root a union of the tmpfs and the actual root.
-                  (unless (zero? (system* unionfs "-o"
-                                          "cow,allow_other,use_ino,suid,dev"
-                                          "/rw-root=RW:/real-root=RO"
-                                          "/root"))
-                    (error "unionfs failed")))
-                (mount root "/root" "ext3")))
-          (lambda args
-            (format (current-error-port) "exception while mounting '~a': ~s~%"
-                    root args)
-            (start-repl)))
+        (mount-root-file-system root root-fs-type
+                                #:volatile-root? volatile-root?
+                                #:unionfs unionfs)
         (mount "none" "/root" "tmpfs"))
 
     (mount-essential-file-systems #:root "/root")
@@ -308,16 +318,7 @@ to it are lost."
       (make-essential-device-nodes #:root "/root"))
 
     ;; Mount the specified file systems.
-    (for-each (match-lambda
-               (('cifs source target)
-                (let ((target (string-append "/root/" target)))
-                  (mkdir-p target)
-                  (mount-qemu-smb-share source target)))
-               (('9p source target)
-                (let ((target (string-append "/root/" target)))
-                  (mkdir-p target)
-                  (mount-qemu-9p source target))))
-              mounts)
+    (for-each mount-file-system mounts)
 
     (when guile-modules-in-chroot?
       ;; Copy the directories that contain .scm and .go files so that the