Merge branch 'master' into core-updates

Conflicts:
	gnu/packages/image.scm

1 files changed, 77 insertions, 14 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index ea7fdf1cb7..9bdf227eca 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -44,6 +44,7 @@
   #:use-module (gnu system linux)
   #:use-module (gnu system linux-initrd)
   #:use-module (gnu system file-systems)
+  #:autoload   (gnu packages cryptsetup) (cryptsetup)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -55,6 +56,7 @@
             operating-system-user-services
             operating-system-packages
             operating-system-host-name
+            operating-system-hosts-file
             operating-system-kernel
             operating-system-initrd
             operating-system-users
@@ -63,6 +65,7 @@
             operating-system-packages
             operating-system-timezone
             operating-system-locale
+            operating-system-mapped-devices
             operating-system-file-systems
             operating-system-activation-script
 
@@ -70,7 +73,10 @@
             operating-system-profile
             operating-system-grub.cfg
 
-            %base-packages))
+            %setuid-programs
+            %base-packages
+
+            luks-device-mapping))
 
 ;;; Commentary:
 ;;;
@@ -91,7 +97,11 @@
           (default base-initrd))
 
   (host-name operating-system-host-name)          ; string
+  (hosts-file operating-system-hosts-file         ; M item | #f
+              (default #f))
 
+  (mapped-devices operating-system-mapped-devices ; list of <mapped-device>
+                  (default '()))
   (file-systems operating-system-file-systems)    ; list of fs
 
   (users operating-system-users                   ; list of user accounts
@@ -148,6 +158,13 @@ file."
 ;;; Services.
 ;;;
 
+(define (luks-device-mapping source target)
+  "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
+'cryptsetup'."
+  #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
+                    "open" "--type" "luks"
+                    #$source #$target)))
+
 (define (other-file-system-services os)
   "Return file system services for the file systems of OS that are not marked
 as 'needed-for-boot'."
@@ -157,30 +174,58 @@ as 'needed-for-boot'."
                   (string=? "/" (file-system-mount-point fs))))
             (operating-system-file-systems os)))
 
+  (define (device-mappings fs)
+    (filter (lambda (md)
+              (string=? (string-append "/dev/mapper/"
+                                       (mapped-device-target md))
+                        (file-system-device fs)))
+            (operating-system-mapped-devices os)))
+
+  (define (requirements fs)
+    (map (lambda (md)
+           (symbol-append 'device-mapping-
+                          (string->symbol (mapped-device-target md))))
+         (device-mappings fs)))
+
   (sequence %store-monad
-            (map (match-lambda
-                  (($ <file-system> device title target type flags opts
-                                    #f check? create?)
-                   (file-system-service device target type
-                                        #:title title
-                                        #:check? check?
-                                        #:create-mount-point? create?
-                                        #:options opts
-                                        #:flags flags)))
+            (map (lambda (fs)
+                   (match fs
+                     (($ <file-system> device title target type flags opts
+                                       #f check? create?)
+                      (file-system-service device target type
+                                           #:title title
+                                           #:requirements (requirements fs)
+                                           #:check? check?
+                                           #:create-mount-point? create?
+                                           #:options opts
+                                           #:flags flags))))
                  file-systems)))
 
+(define (device-mapping-services os)
+  "Return the list of device-mapping services for OS as a monadic list."
+  (sequence %store-monad
+            (map (lambda (md)
+                   (let ((source  (mapped-device-source md))
+                         (target  (mapped-device-target md))
+                         (command (mapped-device-command md)))
+                     (device-mapping-service target
+                                             (command source target))))
+                 (operating-system-mapped-devices os))))
+
 (define (essential-services os)
   "Return the list of essential services for OS.  These are special services
 that implement part of what's declared in OS are responsible for low-level
 bookkeeping."
-  (mlet* %store-monad ((root-fs   (root-file-system-service))
+  (mlet* %store-monad ((mappings  (device-mapping-services os))
+                       (root-fs   (root-file-system-service))
                        (other-fs  (other-file-system-services os))
                        (procs     (user-processes-service
                                    (map (compose first service-provision)
                                         other-fs)))
                        (host-name (host-name-service
                                    (operating-system-host-name os))))
-    (return (cons* host-name procs root-fs other-fs))))
+    (return (cons* host-name procs root-fs
+                   (append other-fs mappings)))))
 
 (define (operating-system-services os)
   "Return all the services of OS, including \"internal\" services that do not
@@ -220,12 +265,19 @@ explicitly appear in OS."
   "
 This is the GNU system.  Welcome.\n")
 
+(define (default-/etc/hosts host-name)
+  "Return the default /etc/hosts file."
+  (text-file "hosts"
+             (string-append "localhost 127.0.0.1\n"
+                            host-name " 127.0.0.1\n")))
+
 (define* (etc-directory #:key
                         (locale "C") (timezone "Europe/Paris")
                         (issue "Hello!\n")
                         (skeletons '())
                         (pam-services '())
                         (profile "/run/current-system/profile")
+                        hosts-file
                         (sudoers ""))
   "Return a derivation that builds the static part of the /etc directory."
   (mlet* %store-monad
@@ -241,7 +293,7 @@ This is the GNU system.  Welcome.\n")
 
        ;; TODO: Generate bashrc from packages' search-paths.
        (bashrc    (text-file* "bashrc"  "
-export PS1='\\u@\\h\\$ '
+export PS1='\\u@\\h \\w\\$ '
 
 export LC_ALL=\"" locale "\"
 export TZ=\"" timezone "\"
@@ -268,6 +320,7 @@ alias ll='ls -l'
                   ("skel" ,#~#$skel)
                   ("shells" ,#~#$shells)
                   ("profile" ,#~#$bashrc)
+                  ("hosts" ,#~#$hosts-file)
                   ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
                                                  #$timezone))
                   ("sudoers" ,#~#$sudoers)))))
@@ -310,12 +363,15 @@ alias ll='ls -l'
                       (append (operating-system-pam-services os)
                               (append-map service-pam-services services))))
        (profile-drv (operating-system-profile os))
-       (skeletons   (operating-system-skeletons os)))
+       (skeletons   (operating-system-skeletons os))
+       (/etc/hosts  (or (operating-system-hosts-file os)
+                        (default-/etc/hosts (operating-system-host-name os)))))
    (etc-directory #:pam-services pam-services
                   #:skeletons skeletons
                   #:issue (operating-system-issue os)
                   #:locale (operating-system-locale os)
                   #:timezone (operating-system-timezone os)
+                  #:hosts-file /etc/hosts
                   #:sudoers (operating-system-sudoers os)
                   #:profile profile-drv)))
 
@@ -402,6 +458,11 @@ etc."
 
                     (use-modules (gnu build activation))
 
+                    ;; Make sure /bin/sh is valid and current.
+                    (activate-/bin/sh
+                     (string-append #$(canonical-package bash)
+                                    "/bin/sh"))
+
                     ;; Populate /etc.
                     (activate-etc #$etc)
 
@@ -470,6 +531,8 @@ we're running in the final root."
               boot?))
             (operating-system-file-systems os)))
 
+  ;; TODO: Pass the mapped devices required by boot-time file systems to the
+  ;; initrd.
   (mlet %store-monad
       ((initrd ((operating-system-initrd os) boot-file-systems)))
     (return #~(string-append #$initrd "/initrd"))))