dannym pushed a commit to branch wip-installer-2
in repository guix.
commit ee412f64a5f58a5c35d8ee2b0e96eba692dd4fae
Author: John Darrington <[email protected]>
Date: Sat Jan 14 21:46:29 2017 +0100
installer: Add a predicate to ensure the partitions have been formatted.
* gnu/system/installer/format.scm (device-fs-uuid,
filesystems-are-current?):
New procedures.
* gnu/system/installer/guixsd-installer.scm (main-options): Update
prerequisites
for install. Update predicate for format.
---
gnu/system/installer/format.scm | 24 +++++++++++++++++++++++-
gnu/system/installer/guixsd-installer.scm | 4 ++--
2 files changed, 25 insertions(+), 3 deletions(-)
diff --git a/gnu/system/installer/format.scm b/gnu/system/installer/format.scm
index 2f965cc..73ab172 100644
--- a/gnu/system/installer/format.scm
+++ b/gnu/system/installer/format.scm
@@ -25,10 +25,32 @@
#:use-module (ice-9 match)
#:use-module (gurses buttons)
#:use-module (ncurses curses)
-
+ #:use-module (srfi srfi-1)
+
+ #:export (filesystems-are-current?)
#:export (make-format-page))
+(define (device-fs-uuid dev)
+ "Retrieve the UUID of the filesystem on DEV, where DEV is the name of the
+device such as /dev/sda1"
+ (car (assoc-ref
+ (slurp (string-append "blkid -o export " dev)
+ (lambda (x)
+ (string-split x #\=))) "UUID")))
+
+(define (filesystems-are-current?)
+ "Returns #t iff there is at least one mount point AND all mount-points' uuids
+match those uuids read from the respective partitions"
+ (and (not (null? mount-points))
+ (fold (lambda (mp prev)
+ (and prev
+ (match mp
+ ((dev . (? file-system-spec? fss))
+ (equal? (device-fs-uuid dev)
+ (file-system-spec-uuid fss))))))
+ #t mount-points)))
+
(define (make-format-page parent title)
(let ((page (make-page (page-surface parent)
title
diff --git a/gnu/system/installer/guixsd-installer.scm
b/gnu/system/installer/guixsd-installer.scm
index 1be2bea..8e8c70f 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -89,7 +89,7 @@
(format . ,(make-task format-menu-title
'(filesystems)
- (lambda () #f)
+ filesystems-are-current?
(lambda (page)
(make-format-page
page
@@ -144,7 +144,7 @@
generate-menu-title))))
(install . ,(make-task installation-menu-title
- '(network generate)
+ '(network generate format)
(lambda () #f)
(lambda (page)
(make-install-page
