179/197: installer: Mount all partitions instead of just the root.

[Danny Milosavljevic]

dannym pushed a commit to branch wip-installer-2
in repository guix.

commit 41f4eb5d09cab7fc7756a1c74165b44fc8294f48
Author: John Darrington <address@hidden>
Date:   Mon Feb 13 11:39:36 2017 +0100

    installer: Mount all partitions instead of just the root.
    
    * gnu/system/installer/install.scm (install-page-key-handler): Iterate
    through all declared mount points and mount all of them before commencing
    the install.
---
 gnu/system/installer/install.scm | 92 +++++++++++++++++++++++-----------------
 1 file changed, 52 insertions(+), 40 deletions(-)

diff --git a/gnu/system/installer/install.scm b/gnu/system/installer/install.scm
index 0d966ea..898f3aa 100644
--- a/gnu/system/installer/install.scm
+++ b/gnu/system/installer/install.scm
@@ -24,6 +24,7 @@
   #:use-module (gnu system installer filesystems)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (gurses buttons)
   #:use-module (ncurses curses)
   #:use-module (guix store)
@@ -102,47 +103,58 @@
 
      ((buttons-key-matches-symbol? nav ch 'continue)
       (let ((target "/target")
-            (window-port (make-window-port config-window))
-            (root-device (find-mount-device "/" mount-points)))
-
+            (window-port (make-window-port config-window)))
         (catch #t
-          (lambda ()
-            (and
-             (mkdir-p target)
-
-             (mount root-device target
-                    (symbol->string
-                     (file-system-spec-type (assoc-ref mount-points 
root-device)))
-                    #:update-mtab? #f)
-
-             (zero? (pipe-cmd window-port  "herd"
-                              "herd" "start" "cow-store" target))
-
-             (mkdir-p (string-append target "/etc"))
-             (or (copy-file config-file
-                            (string-append target "/etc/config.scm"))
-                 #t)
-
-             (file-exists? (string-append target "/etc/config.scm"))
-
-             (display (gettext "Installing the system ...") window-port)
-             (force-output window-port)
-
-             (zero? (pipe-cmd window-port "guix" "guix" "system" "init" 
"--fallback"
-                                 (string-append target "/etc/config.scm")
-                                 target))
-
-             (display (gettext
-                       "Installation is complete.  You should remove the 
device containing the installer image and reboot now.")
-                      window-port)))
-          (lambda (key . args)
-            #f)
-          (lambda (key subr message args . rest)
-            (display-error (stack-ref (make-stack #t) 3)
-                           window-port subr message args rest)))
-
-        (close-port window-port))))
-    #f))
+               (lambda ()
+                 (and
+
+                  (fold
+                   (lambda (x prev)
+                     (and prev
+                          (let* ((device (car x))
+                                 (fss (cdr x))
+                                 (mp (file-system-spec-mount-point fss))
+                                 (mpt (string-append target mp)))
+                            (mkdir-p mpt)
+                            (mount device mpt
+                                   (symbol->string
+                                    (file-system-spec-type fss))
+                                   #:update-mtab? #f))))
+                   #t
+                   (sort
+                    mount-points
+                    (lambda (x y)
+                      (< (string-length (file-system-spec-mount-point (cdr x)))
+                         (string-length (file-system-spec-mount-point (cdr 
y)))))))
+
+                 (zero? (pipe-cmd window-port  "herd"
+                                  "herd" "start" "cow-store" target))
+
+                 (mkdir-p (string-append target "/etc"))
+                 (or (copy-file config-file
+                                (string-append target "/etc/config.scm"))
+                     #t)
+
+                 (file-exists? (string-append target "/etc/config.scm"))
+
+                 (display (gettext "Installing the system ...") window-port)
+                 (force-output window-port)
+
+                 (zero? (pipe-cmd window-port "guix" "guix" "system" "init" 
"--fallback"
+                                  (string-append target "/etc/config.scm")
+                                  target))
+
+                 (display (gettext
+                           "Installation is complete.  You should remove the 
device containing the installer image and reboot now.")
+                          window-port)))
+        (lambda (key . args)
+          #f)
+        (lambda (key subr message args . rest)
+          (display-error (stack-ref (make-stack #t) 3)
+                         window-port subr message args rest)))
+
+      (close-port window-port))))
+  #f))
 
 (define (install-page-refresh page)
   (when (not (page-initialised? page))