160/197: installer: New convenience procedures.

[Danny Milosavljevic]

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

commit 9c20b996785703101585d3f4bf0a9346c3d4ca3f
Author: John Darrington <address@hidden>
Date:   Tue Jan 31 20:13:34 2017 +0100

    installer: New convenience procedures.
    
    * gnu/system/installer/format.scm (device-attributes): New procedure.
    (device-fs-label):  New procedure.
---
 gnu/system/installer/format.scm | 27 +++++++++++++++++++--------
 1 file changed, 19 insertions(+), 8 deletions(-)

diff --git a/gnu/system/installer/format.scm b/gnu/system/installer/format.scm
index 29b8316..f0a9aaf 100644
--- a/gnu/system/installer/format.scm
+++ b/gnu/system/installer/format.scm
@@ -35,17 +35,28 @@
 
 (include "i18n.scm")
 
+(define (device-attributes dev)
+  (slurp (string-append "blkid -o export " dev)
+         (lambda (x)
+           (let ((idx (string-index x #\=)))
+             (cons (string->symbol (string-fold
+                                    (lambda (c acc)
+                                      (string-append
+                                       acc
+                                       (make-string 1 (char-downcase c))))
+                                    ""
+                                    (substring x 0 idx)))
+                   (substring x (1+ idx) (string-length x)))))))
+
 (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"
-  (match (assoc-ref
-          (slurp (string-append "blkid -o export " dev)
-                 (lambda (x)
-                   (string-split x #\=))) "UUID")
-         (() #f)
-         ((? list? l)
-          (car l))
-         (_ #f)))
+  (assq-ref (device-attributes dev) 'uuid))
+
+(define (device-fs-label dev)
+  "Retrieve the LABEL of the filesystem on DEV, where DEV is the name of the
+device such as /dev/sda1"
+  (assq-ref (device-attributes dev) 'label))
 
 (define (filesystems-are-current?)
   "Returns #t iff there is at least one mount point AND all mount-points' uuids