[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/12: installer: Remove mkfs capability from mount points page.
|
From: |
John Darrington |
|
Subject: |
02/12: installer: Remove mkfs capability from mount points page. |
|
Date: |
Sun, 15 Jan 2017 15:45:39 +0000 (UTC) |
jmd pushed a commit to branch wip-installer
in repository guix.
commit 240ed1713a3021ebeccb472ae1dc2077bae10288
Author: John Darrington <address@hidden>
Date: Sat Jan 14 12:55:55 2017 +0100
installer: Remove mkfs capability from mount points page.
* gnu/system/installer/configure.scm (generate-config): Specify filesystems
by label
instead of device.
* gnu/system/installer/filesystems.scm (<file-system-spec>): New record
type.
* gnu/system/installer/guixsd-installer.scm (mount-options): filesystems is
now
dependent upon hostname.
* gnu/system/installer/mount-point.scm (mount-point-init): Remove text
window and
filesytem creation capability.
* gnu/system/installer/utils.scm (pair->mp): New procedure.
---
gnu/system/installer/configure.scm | 15 ++--
gnu/system/installer/filesystems.scm | 88 ++++++++++++++--------
gnu/system/installer/guixsd-installer.scm | 7 +-
gnu/system/installer/mount-point.scm | 114 +++++++++++------------------
gnu/system/installer/utils.scm | 8 +-
5 files changed, 113 insertions(+), 119 deletions(-)
diff --git a/gnu/system/installer/configure.scm
b/gnu/system/installer/configure.scm
index c952983..c0f10dd 100644
--- a/gnu/system/installer/configure.scm
+++ b/gnu/system/installer/configure.scm
@@ -24,6 +24,7 @@
#:use-module (gnu system installer misc)
#:use-module (gnu system installer role)
#:use-module (gnu system installer partition-reader)
+ #:use-module (gnu system installer filesystems)
#:use-module (gnu system installer disks)
#:use-module (ice-9 format)
#:use-module (ice-9 rdelim)
@@ -129,8 +130,8 @@
(define (generate-guix-config p width)
(let ((grub-mount-point
(find-mount-device "/boot/grub"
- mount-points)))
-
+ mount-points)))
+
(pretty-print `(use-modules
(gnu)
,(when grub-mount-point
@@ -168,12 +169,12 @@
(file-systems
,(append (list 'cons*)
(map (lambda (x)
- (let ((z (find-partition (car x))))
+ (let ((fss (cdr x)))
`(file-system
- (device ,(car x))
- (title 'device)
- (mount-point ,(cdr x))
- (type ,(partition-fs z))))) mount-points)
+ (device ,(file-system-spec-label fss))
+ (title 'label)
+ (mount-point ,(file-system-spec-mount-point fss))
+ (type ,(file-system-spec-type fss)))))
mount-points)
(list '%base-file-systems)))
(users (cons* %base-user-accounts))
(packages (cons*
diff --git a/gnu/system/installer/filesystems.scm
b/gnu/system/installer/filesystems.scm
index 05d8310..cba8333 100644
--- a/gnu/system/installer/filesystems.scm
+++ b/gnu/system/installer/filesystems.scm
@@ -30,11 +30,28 @@
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+
+ #:export (make-file-system-spec)
+ #:export (<file-system-spec>)
+ #:export (file-system-spec-mount-point)
+ #:export (file-system-spec-label)
+ #:export (file-system-spec-type)
#:export (minimum-store-size)
#:export (filesystem-task-complete?)
#:export (make-filesystem-page))
+
+;; File system spec declaration.
+(define-record-type <file-system-spec>
+ (make-file-system-spec mount-point label type)
+ file-system-spec?
+ (mount-point file-system-spec-mount-point) ; string
+ (label file-system-spec-label) ; string
+ (type file-system-spec-type)) ; symbol
+
+
(define minimum-store-size 7000)
(define (filesystem-task-complete?)
@@ -47,12 +64,15 @@
(N_ "You must specify a mount point for the root (/)."))
- (let ((non-absolute-list (fold (lambda (x prev)
- (if (absolute-file-name? (cdr x))
- prev
- (cons (cdr x) prev)))
- '()
- mount-points)))
+ (let ((non-absolute-list
+ (fold (lambda (x prev)
+ (match x
+ ((dev . fss)
+ (if (absolute-file-name?
(file-system-spec-mount-point fss))
+ prev
+ (cons (file-system-spec-mount-point fss)
prev)))))
+ '()
+ mount-points)))
(and (not (null? non-absolute-list))
(ngettext
(format #f
@@ -73,27 +93,28 @@
(ac '()))
(match ll
('() #f)
- (((_ . directory) . rest)
- (if (member directory ac)
+ (((_ . (? file-system-spec? fss)) . rest)
+ (if (member fss ac)
(format #f
(N_ "You have specified the mount point ~a more than
once.")
- directory)
- (loop rest (cons directory ac))))))
+ (file-system-spec-mount-point fss))
+ (loop rest (cons fss ac))))))
(let ((partitions-without-filesystems
(fold (lambda (x prev)
- (if (not (string-prefix? "ext"
- (partition-fs (string->partition
- (car x)))))
- (cons (car x) prev)
- prev)) '() mount-points)))
+ (match x
+ ((dev . (? file-system-spec? fss))
+ (if (not (string-prefix? "ext"
+ (file-system-spec-type
fss)))
+ (cons dev prev)
+ prev)))) '() mount-points)))
(if (null? partitions-without-filesystems)
#f
(ngettext
- (format #f (N_ "The partition ~a does not contain a filesystem.")
+ (format #f (N_ "The filesystem type for partition ~a is not valid.")
(car partitions-without-filesystems))
- (format #f (N_ "The partitions ~a do not contain filesystems.")
+ (format #f (N_ "The filesystem type for partitions ~a are not
valid.")
partitions-without-filesystems)
(length partitions-without-filesystems))))))
@@ -125,8 +146,8 @@
(touchwin (outer (page-wwin page)))
(refresh (outer (page-wwin page)))
(refresh (inner (page-wwin page)))
- (menu-refresh menu)
- (menu-redraw menu)))
+ (menu-redraw menu)
+ (menu-refresh menu)))
(define (size-of-partition device)
@@ -225,19 +246,22 @@
(- (getmaxx (inner pr)) 0)
(getmaxy text-window) 0 #:panel #f))
- (menu (make-menu (partition-volume-pairs)
- #:disp-proc
- (lambda (d row)
- (let* ((part (car d))
- (name (partition-name part)))
-
- (format #f "~30a ~7a ~16a ~a"
- name
- (number->size (partition-size part))
- (partition-fs part)
- (let ((x (assoc-ref mount-points name)))
- (if x x ""))))))))
-
+ (menu (make-menu
+ (partition-volume-pairs)
+ #:disp-proc
+ (lambda (d row)
+ (let* ((part (car d))
+ (name (partition-name part))
+ (fs-spec
+ (assoc-ref mount-points name)))
+
+ (format #f "~30a ~7a ~16a ~a"
+ name
+ (number->size (partition-size part))
+ (if fs-spec (file-system-spec-type fs-spec) "")
+ (if fs-spec
+ (file-system-spec-mount-point fs-spec)
"")))))))
+
(push-cursor (page-cursor-visibility p))
(page-set-wwin! p pr)
(page-set-datum! p 'menu menu)
diff --git a/gnu/system/installer/guixsd-installer.scm
b/gnu/system/installer/guixsd-installer.scm
index 6da3b89..8314d08 100644
--- a/gnu/system/installer/guixsd-installer.scm
+++ b/gnu/system/installer/guixsd-installer.scm
@@ -78,7 +78,7 @@
partition-menu-title))))
(filesystems . ,(make-task filesystem-menu-title
- '(disk)
+ '(disk hostname)
filesystem-task-complete?
(lambda (page)
(make-filesystem-page
@@ -113,7 +113,6 @@
page
hostname-menu-title))))
-
(role . ,(make-task role-menu-title
'()
(lambda () (and system-role (role? system-role)))
@@ -122,9 +121,8 @@
page
role-menu-title))))
-
(generate . , (make-task generate-menu-title
- '(role filesystems timezone hostname)
+ '(role filesystems timezone)
(lambda ()
(and config-file
(file-exists? config-file)
@@ -178,7 +176,6 @@
(define (do-task-list task-name-list page)
"Queue the tasks whose names are the members of TASK-NAME-LIST"
-
(for-each
(lambda (task-name)
(let ((task (assoc-ref main-options task-name)))
diff --git a/gnu/system/installer/mount-point.scm
b/gnu/system/installer/mount-point.scm
index f9757b1..b5b653e 100644
--- a/gnu/system/installer/mount-point.scm
+++ b/gnu/system/installer/mount-point.scm
@@ -18,6 +18,7 @@
(define-module (gnu system installer mount-point)
#:use-module (gnu system installer partition-reader)
+ #:use-module (gnu system installer filesystems)
#:use-module (gnu system installer page)
#:use-module (gnu system installer misc)
#:use-module (gnu system installer utils)
@@ -28,21 +29,9 @@
#:export (mount-point-refresh)
#:export (mount-point-page-key-handler))
-(define (efs-params device)
- (slurp
- (string-append "tune2fs -l " device)
- (lambda (line)
- (let ((sep (string-contains line ":")))
- (if (not sep)
- ""
- (cons
- (string->symbol
- (string-map (lambda (c) (if (eq? c #\space) #\- c))
- (string-downcase (substring line 0 sep))))
- (string-trim-both (substring line (+ sep 2)))))))))
-
-(define my-fields `((label ,(N_ "Label") 40)
- (mount-point ,(N_ "Mount Point") 10)))
+(define my-fields `((mount-point ,(N_ "Mount Point") 40)
+ (fs-type ,(N_ "File System Type") 10)
+ (label ,(N_ "Label") 16)))
(define (mount-point-refresh page)
(when (not (page-initialised? page))
@@ -57,41 +46,16 @@
(nav (page-datum page 'navigation))
(dev (page-datum page 'device)))
- (if (not (form-enabled? form))
- (if (or
- (eq? ch #\space)
- (eq? ch #\nl))
- (cond
- ((buttons-key-matches-symbol? nav ch 'continue)
- (let ((mp (form-get-value form 'mount-point)))
- (if (equal? "" mp)
- (set! mount-points
- (assoc-remove! mount-points dev))
-
- (set! mount-points (assoc-set! mount-points
- dev mp))))
-
- (page-leave))
-
- ((buttons-key-matches-symbol? nav ch 'check)
- (window-pipe (page-datum page 'output) "fsck.ext4" "fsck.ext4"
"-n" "-v"
- "-f"
- dev))
-
- ((buttons-key-matches-symbol? nav ch 'write)
- (window-pipe (page-datum page 'output)
- "tune2fs" "tune2fs"
- "-L" (form-get-value form 'label)
- dev))
-
- ((buttons-key-matches-symbol? nav ch 'recreate)
- (window-pipe (page-datum page 'output)
- "mkfs.ext4" "mkfs.ext4" "-v" "-F"
- "-L" (form-get-value form 'label)
- dev))
- )))
-
(cond
+ ((buttons-key-matches-symbol? nav ch 'continue)
+ (set! mount-points
+ (assoc-set! mount-points dev
+ (make-file-system-spec
+ (form-get-value form 'mount-point)
+ (form-get-value form 'label)
+ (form-get-value form 'fs-type))))
+ (page-leave))
+
((buttons-key-matches-symbol? nav ch 'cancel)
;; Close the menu and return
(page-leave))
@@ -118,9 +82,6 @@
#f)
(define my-buttons `((continue ,(N_ "Continue") #f)
- (check ,(N_ "Check") #f)
- (write ,(N_ "Write") #f)
- (recreate ,(N_ "(re)Create") #f)
(cancel ,(N_ "Cancel") #f)))
(define (mount-point-page-init p)
@@ -142,24 +103,23 @@
(nav (make-buttons my-buttons 1))
(fw (derwin (inner pr)
- 2
+ (length my-fields)
(getmaxx (inner pr))
(getmaxy text-window) 0))
- (out (derwin (inner pr)
- (- (getmaxy (inner pr)) (getmaxy bwin) (getmaxy
text-window) (getmaxy fw))
- (getmaxx (inner pr))
- (+ (getmaxy text-window) (getmaxy fw))
- 0))
-
- (form (make-form my-fields)))
+ (form (make-form
+ my-fields
+ (lambda (f)
+ (let ((field (get-current-field f)))
+ (if (eq? (field-symbol field) 'mount-point)
+ (form-set-value! f 'label
+ (string-append
+ host-name "-"
+ (form-get-value f
'mount-point)))))))))
- (box out 0 0)
- (page-set-datum! p 'output out)
(page-set-datum! p 'navigation nav)
- (let* ((dev (page-datum p 'device))
- (efsp (efs-params dev)))
+ (let ((dev (page-datum p 'device)))
(addstr*
text-window
(format #f
@@ -167,16 +127,24 @@
"The device ~s is currently configured as follows. You may
change the configuration here if desired.")
dev))
- (form-post form fw)
- (if efsp
- (form-set-value! form 'label
- (assq-ref efsp
- 'filesystem-volume-name)))
-
- (form-set-value! form 'mount-point
- (or (assoc-ref mount-points dev)
- "")))
+ (form-post form fw))
+ (let* ((dev (page-datum p 'device))
+ (fss (assoc-ref mount-points dev)))
+
+ (form-set-value! form 'label
+ (if fss
+ (file-system-spec-label fss)
+ (string-append host-name
+ "-")))
+ (when fss
+ (form-set-value! form 'mount-point
+ (file-system-spec-mount-point fss))
+ (form-set-value! form 'fs-type
+ (file-system-spec-type fss))))
+
+ (form-set-current-field form 0)
+
(push-cursor (page-cursor-visibility p))
(buttons-post nav bwin)
(page-set-datum! p 'form form)
diff --git a/gnu/system/installer/utils.scm b/gnu/system/installer/utils.scm
index 6de519b..2d417af 100644
--- a/gnu/system/installer/utils.scm
+++ b/gnu/system/installer/utils.scm
@@ -50,6 +50,7 @@
(ice-9 match)
(ncurses menu)
(gnu system installer misc)
+ (gnu system installer filesystems)
(ncurses form)
(ncurses curses))
@@ -318,6 +319,9 @@ mounts return the device on which the path IN would be
mounted."
p))
p))
+ (define (pair->mp pr)
+ (file-system-spec-mount-point (cdr pr)))
+
(if (not (absolute-file-name? in))
(error (format #f "Path is not absolute")))
@@ -326,8 +330,8 @@ mounts return the device on which the path IN would be
mounted."
(map-in-order
(lambda (p)
(cons (car p)
- (string-split (normalise-directory-path (cdr p)) dir-sep)))
- (sort mp (lambda (x y) (string> (cdr x) (cdr y)))))))
+ (string-split (normalise-directory-path (pair->mp p))
dir-sep)))
+ (sort mp (lambda (x y) (string> (pair->mp x) (pair->mp y)))))))
(let loop ((pp paths))
(if (null? pp)
- branch wip-installer updated (3673cd8 -> ac6599d), John Darrington, 2017/01/15
- 08/12: installer: Correct bug detecting a wireless interface., John Darrington, 2017/01/15
- 01/12: installer: Add callback parameter for forms., John Darrington, 2017/01/15
- 04/12: installer: Add the notion of uuids to prospective filesystems., John Darrington, 2017/01/15
- 05/12: installer: Add a predicate to ensure the partitions have been formatted., John Darrington, 2017/01/15
- 09/12: installer: Exit the format page after all partitions are successfully formatted., John Darrington, 2017/01/15
- 11/12: installer: Replace one usage of car with match., John Darrington, 2017/01/15
- 10/12: installer: Do not perform tasks more than once., John Darrington, 2017/01/15
- 12/12: installer: Correct bug where the timezone page returned to the wrong page., John Darrington, 2017/01/15
- 02/12: installer: Remove mkfs capability from mount points page.,
John Darrington <=
- 06/12: installer: Changed N_ to M_ since N_ is used for another purpose in guix/ui.scm, John Darrington, 2017/01/15
- 07/12: installer: Whitespace changes only, John Darrington, 2017/01/15
- 03/12: installer: Add a dedicated make to format filesystems., John Darrington, 2017/01/15