[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: gnu: Add graphical installer
|
From: |
John Darrington |
|
Subject: |
01/01: gnu: Add graphical installer |
|
Date: |
Fri, 16 Dec 2016 09:32:20 +0000 (UTC) |
jmd pushed a commit to branch wip-installer
in repository guix.
commit 76ec0164ece3f8d5af31fa8616e55fbaf4f97872
Author: John Darrington <address@hidden>
Date: Fri Dec 16 07:50:34 2016 +0100
gnu: Add graphical installer
* guix/scripts/system.scm (installer): New command.
* gnu/system/installer/dialog.scm
gnu/system/installer/disks.scm
gnu/system/installer/file-browser.scm
gnu/system/installer/filesystems.scm
gnu/system/installer/hostname.scm
gnu/system/installer/misc.scm
gnu/system/installer/mount-point.scm
gnu/system/installer/network.scm
gnu/system/installer/new.scm
gnu/system/installer/page.scm
gnu/system/installer/partition-reader.scm
gnu/system/installer/ping.scm
gnu/system/installer/pipe-subst/parted%-lm
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-gnu
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-home
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-root
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-scratch
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-swap_1
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp2
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-usr
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-var
gnu/system/installer/pipe-subst/tune2fs%-l%,dev,sda1
gnu/system/installer/time-zone.scm
gnu/system/installer/utils.scm
gurses/buttons.scm
gurses/form.scm
gurses/menu.scm: New files.
* gnu/local.mk: Add them.
---
gnu/local.mk | 15 +
gnu/system/installer/dialog.scm | 105 +++++++
gnu/system/installer/disks.scm | 156 ++++++++++
gnu/system/installer/file-browser.scm | 132 ++++++++
gnu/system/installer/filesystems.scm | 197 ++++++++++++
gnu/system/installer/hostname.scm | 121 ++++++++
gnu/system/installer/misc.scm | 34 +++
gnu/system/installer/mount-point.scm | 178 +++++++++++
gnu/system/installer/network.scm | 169 +++++++++++
gnu/system/installer/new.scm | 238 +++++++++++++++
gnu/system/installer/page.scm | 56 ++++
gnu/system/installer/partition-reader.scm | 213 +++++++++++++
gnu/system/installer/ping.scm | 120 ++++++++
gnu/system/installer/pipe-subst/parted%-lm | 42 +++
.../pipe-subst/tune2fs%-l%,dev,mapper,jocasta-gnu | 45 +++
.../pipe-subst/tune2fs%-l%,dev,mapper,jocasta-home | 45 +++
.../pipe-subst/tune2fs%-l%,dev,mapper,jocasta-root | 45 +++
.../tune2fs%-l%,dev,mapper,jocasta-scratch | 45 +++
.../tune2fs%-l%,dev,mapper,jocasta-swap_1 | 45 +++
.../pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp | 45 +++
.../pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp2 | 45 +++
.../pipe-subst/tune2fs%-l%,dev,mapper,jocasta-usr | 45 +++
.../pipe-subst/tune2fs%-l%,dev,mapper,jocasta-var | 45 +++
.../installer/pipe-subst/tune2fs%-l%,dev,sda1 | 45 +++
gnu/system/installer/time-zone.scm | 149 +++++++++
gnu/system/installer/utils.scm | 318 ++++++++++++++++++++
guix/scripts/system.scm | 7 +-
gurses/buttons.scm | 163 ++++++++++
gurses/form.scm | 238 +++++++++++++++
gurses/menu.scm | 153 ++++++++++
30 files changed, 3253 insertions(+), 1 deletion(-)
diff --git a/gnu/local.mk b/gnu/local.mk
index 694ce94..7e910a5 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -437,6 +437,21 @@ GNU_SYSTEM_MODULES = \
%D%/system/shadow.scm \
%D%/system/vm.scm \
\
+ %D%/system/installer/filesystems.scm \
+ %D%/system/installer/network.scm \
+ %D%/system/installer/dialog.scm \
+ %D%/system/installer/hostname.scm \
+ %D%/system/installer/mount-point.scm \
+ %D%/system/installer/new.scm \
+ %D%/system/installer/disks.scm \
+ %D%/system/installer/ping.scm \
+ %D%/system/installer/file-browser.scm \
+ %D%/system/installer/utils.scm \
+ %D%/system/installer/page.scm \
+ %D%/system/installer/time-zone.scm \
+ %D%/system/installer/misc.scm \
+ %D%/system/installer/partition-reader.scm \
+ \
%D%/build/activation.scm \
%D%/build/cross-toolchain.scm \
%D%/build/file-systems.scm \
diff --git a/gnu/system/installer/dialog.scm b/gnu/system/installer/dialog.scm
new file mode 100644
index 0000000..1324a9d
--- /dev/null
+++ b/gnu/system/installer/dialog.scm
@@ -0,0 +1,105 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer dialog)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer utils)
+ #:use-module (gurses buttons)
+ #:use-module (ncurses curses)
+
+ #:export (make-dialog))
+
+;; This module creates a single dialog with a simple message and an OK
+;; button.
+
+(define* (make-dialog parent message #:key (justify #t))
+ (let ((page (make-page (page-surface parent)
+ (gettext "Information")
+ dialog-page-refresh
+ dialog-page-key-handler)))
+ (page-set-datum! page 'message message)
+ (page-set-datum! page 'justify justify)
+ page))
+
+
+(define my-buttons `((ok ,(N_ "_OK") #t)))
+
+(define (dialog-page-key-handler page ch)
+ (let ((nav (page-datum page 'navigation)))
+
+ (cond
+ ((eq? ch #\tab)
+ (cond
+ ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+ (buttons-unselect-all nav))
+
+ (else
+ (buttons-select-next nav))))
+
+ ((buttons-key-matches-symbol? nav ch 'ok)
+ (delwin (cdr (page-wwin page)))
+ (delwin (car (page-wwin page)))
+
+ (delwin (page-datum page 'text-window))
+ (set! page-stack (cdr page-stack))
+ ))
+ #f))
+
+(define (dialog-page-refresh page)
+ (when (not (page-initialised? page))
+ (dialog-page-init page)
+ (page-set-initialised! page #t))
+ (refresh (page-datum page 'text-window)))
+
+(define (dialog-page-init p)
+ (let* ((s (page-surface p))
+ (frame (make-boxed-window #f
+ (- (getmaxy s) 5) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+ (button-window (derwin (car frame)
+ 3 (getmaxx (car frame))
+ (- (getmaxy (car frame)) 3) 0
+ #:panel #f))
+ (buttons (make-buttons my-buttons 1))
+
+ (text-window (derwin (car frame)
+ (- (getmaxy (car frame)) (getmaxy button-window))
+ (getmaxx (car frame))
+ 0 0 #:panel #f)))
+
+ (let ((m (page-datum p 'message))
+ (justify (page-datum p 'justify)))
+ (if justify
+ (addstr* text-window
+ (if (promise? m) (force m) m))
+ (addstr text-window
+ (if (promise? m) (force m) m))))
+
+ (page-set-wwin! p frame)
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'navigation buttons)
+ (buttons-post buttons button-window)
+ (buttons-select buttons 0)
+ (refresh (cdr frame))
+ (refresh (car frame))
+ (refresh text-window)
+ (refresh button-window)))
+
+
+
diff --git a/gnu/system/installer/disks.scm b/gnu/system/installer/disks.scm
new file mode 100644
index 0000000..155616d
--- /dev/null
+++ b/gnu/system/installer/disks.scm
@@ -0,0 +1,156 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer disks)
+ #:use-module (gnu system installer partition-reader)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer misc)
+ #:use-module (gnu system installer utils)
+ #:use-module (gurses menu)
+ #:use-module (gurses buttons)
+ #:use-module (ncurses curses)
+
+ #:export (make-disk-page))
+
+(define (volumes)
+ (filter (lambda (v) (not (equal? "dm" (disk-type v))))
+ (disk-volumes)))
+
+(define my-buttons `((continue ,(N_ "_Continue") #t)
+ (back ,(N_ "Go _Back") #t)))
+
+(define (make-disk-page parent title)
+ (make-page (page-surface parent)
+ title
+ disk-page-refresh
+ disk-page-key-handler))
+
+(define (disk-page-refresh page)
+ (when (not (page-initialised? page))
+ (disk-page-init page)
+ (page-set-initialised! page #t))
+
+ (let ((win (page-datum page 'text-window))
+ (menu (page-datum page 'menu)))
+ (clear win)
+ (addstr win
+ (justify* (gettext "Select a disk to partition (or repartition),
or choose \"Continue\" to leave the disk(s) unchanged.")
+ (getmaxx win)))
+
+ (menu-set-items! menu (volumes))
+ (touchwin (cdr (page-wwin page)))
+ (refresh (cdr (page-wwin page)))
+ (refresh (car (page-wwin page)))
+ (menu-redraw menu)
+ (menu-refresh menu)))
+
+(define (disk-page-key-handler page ch)
+ (let ((menu (page-datum page 'menu))
+ (nav (page-datum page 'navigation)))
+
+ (cond
+ ((eq? ch KEY_RIGHT)
+ (menu-set-active! menu #f)
+ (buttons-select-next nav))
+
+ ((eq? ch #\tab)
+ (cond
+ ((menu-active menu)
+ (menu-set-active! menu #f)
+ (buttons-select nav 0))
+
+ ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+ (menu-set-active! menu #t)
+ (buttons-unselect-all nav))
+
+ (else
+ (buttons-select-next nav))))
+
+ ((eq? ch KEY_LEFT)
+ (menu-set-active! menu #f)
+ (buttons-select-prev nav))
+
+ ((eq? ch KEY_UP)
+ (buttons-unselect-all nav)
+ (menu-set-active! menu #t))
+
+ ((and (eq? ch #\newline)
+ (menu-active menu))
+ (let ((i (menu-current-item menu)))
+ (endwin)
+ (system* "cfdisk"
+ (disk-name (list-ref (menu-items menu) i)))))
+
+ ((buttons-key-matches-symbol? nav ch 'continue)
+ (delwin (cdr (page-wwin page)))
+ (set! page-stack (cdr page-stack))
+ ((page-refresh (car page-stack)) (car page-stack))))
+
+ (std-menu-key-handler menu ch))
+
+ #f
+ )
+
+(define (truncate-string ss w)
+ (if (> (string-length ss) w)
+ (string-append
+ (string-take ss (- w 3)) "...")
+ ss))
+
+(define (disk-page-init p)
+ (let* ((s (page-surface p))
+ (frame (make-boxed-window #f
+ (- (getmaxy s) 4) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+ (button-window (derwin (car frame)
+ 3 (getmaxx (car frame))
+ (- (getmaxy (car frame)) 3) 0
+ #:panel #f))
+ (buttons (make-buttons my-buttons 1))
+
+ (text-window (derwin (car frame)
+ 4
+ (getmaxx (car frame))
+ 0 0 #:panel #f))
+
+ (menu-window (derwin (car frame)
+ (- (getmaxy (car frame)) 3 (getmaxy text-window))
+ (getmaxx (car frame))
+ (getmaxy text-window) 0 #:panel #f))
+ (menu (make-menu (volumes)
+ #:disp-proc
+ (lambda (d row)
+ (let ((w 23))
+ (format #f (ngettext "~28a ~? ~6a (~a
partition)"
+ "~28a ~? ~6a (~a
partitions)"
+ (length (disk-partitions
d)))
+ (disk-name d)
+ (format #f "~~~aa" (1+ w))
+ (list (truncate-string (disk-vendor d)
w))
+ (number->size (disk-size d))
+ (length (disk-partitions d))))))))
+
+ (page-set-datum! p 'text-window text-window)
+ (page-set-wwin! p frame)
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (menu-post menu menu-window)
+ (buttons-post buttons button-window)
+ (refresh (cdr frame))
+ (refresh button-window)))
diff --git a/gnu/system/installer/file-browser.scm
b/gnu/system/installer/file-browser.scm
new file mode 100644
index 0000000..923bf74
--- /dev/null
+++ b/gnu/system/installer/file-browser.scm
@@ -0,0 +1,132 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer file-browser)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer utils)
+ #:use-module (gnu system installer misc)
+ #:use-module (gurses menu)
+ #:use-module (gurses buttons)
+ #:use-module (ncurses curses)
+
+ #:export (make-file-browser))
+
+(define* (make-file-browser parent directory #:optional (exit-point #f))
+ (let ((page (make-page (page-surface parent)
+ (gettext "File Browser")
+ file-browser-page-refresh
+ file-browser-page-key-handler)))
+ (page-set-datum! page 'directory directory)
+ (if exit-point
+ (page-set-datum! page 'exit-point exit-point)
+ (page-set-datum! page 'exit-point (page-datum parent 'exit-point)))
+ page))
+
+
+(define my-buttons `((back ,(N_ "_Back") #t)))
+
+(define (file-browser-page-key-handler page ch)
+ (let ((nav (page-datum page 'navigation))
+ (menu (page-datum page 'menu))
+ (directory (page-datum page 'directory)))
+
+ (cond
+ ((eq? ch #\tab)
+ (cond
+ ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+ (buttons-unselect-all nav))
+
+ (else
+ (buttons-select-next nav))))
+
+ ((buttons-key-matches-symbol? nav ch 'back)
+ (delwin (cdr (page-wwin page)))
+ (delwin (car (page-wwin page)))
+
+ (set! page-stack (cdr page-stack)))
+
+ ((and (eqv? ch #\newline)
+ (menu-active menu))
+ (let* ((i (menu-get-current-item menu))
+ (new-dir (string-append directory "/" i)))
+ (if (eq? 'directory (stat:type (stat new-dir)))
+ (let ((p (make-file-browser
+ page new-dir)))
+ (set! page-stack (cons p page-stack))
+ ((page-refresh p) p))
+ (begin
+ (system* "loadkeys" i)
+ (set! page-stack (page-datum page 'exit-point))
+ #f)))
+ ))
+ (std-menu-key-handler menu ch)
+ #f))
+
+
+(define (file-browser-page-refresh page)
+ (when (not (page-initialised? page))
+ (file-browser-page-init page)
+ (page-set-initialised! page #t))
+ (touchwin (cdr (page-wwin page)))
+ (refresh (cdr (page-wwin page)))
+ (refresh (car (page-wwin page)))
+ (menu-refresh (page-datum page 'menu)))
+
+(define (file-browser-page-init p)
+ (let* ((s (page-surface p))
+ (frame (make-boxed-window #f
+ (- (getmaxy s) 5) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+ (button-window (derwin (car frame)
+ 3 (getmaxx (car frame))
+ (- (getmaxy (car frame)) 3) 0
+ #:panel #f))
+ (buttons (make-buttons my-buttons 1))
+
+ (text-window (derwin (car frame)
+ 4
+ (getmaxx (car frame))
+ 0 0 #:panel #f))
+
+ (menu-window (derwin (car frame)
+ (- (getmaxy (car frame)) 3 (getmaxy text-window))
+ (getmaxx (car frame))
+ (getmaxy text-window) 0 #:panel #f))
+
+ (menu (make-menu
+ (let ((dir (page-datum p 'directory)))
+ (slurp (string-append "ls -1 "
+ dir)
+ identity)))))
+
+ (menu-post menu menu-window)
+
+ (addstr* text-window
+ (gettext "Select an item most closely matching your keyboard
layout:" ))
+ (page-set-wwin! p frame)
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (buttons-post buttons button-window)
+ (refresh (cdr frame))
+ (refresh (car frame))
+ (refresh text-window)
+ (refresh button-window)))
+
+
+
diff --git a/gnu/system/installer/filesystems.scm
b/gnu/system/installer/filesystems.scm
new file mode 100644
index 0000000..a102d78
--- /dev/null
+++ b/gnu/system/installer/filesystems.scm
@@ -0,0 +1,197 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer filesystems)
+ #:use-module (gnu system installer partition-reader)
+ #:use-module (gnu system installer mount-point)
+ #:use-module (gnu system installer dialog)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer misc)
+ #:use-module (gnu system installer utils)
+ #:use-module (gurses buttons)
+ #:use-module (gurses menu)
+ #:use-module (ncurses curses)
+ #:use-module (srfi srfi-1)
+
+ #:export (filesystem-task-complete?)
+ #:export (make-filesystem-page))
+
+
+(define (filesystem-task-complete?)
+ (and (find-mount-device "/" mount-points)
+ (>= (sizeof-partition (find-mount-device "/gnu" mount-points)) 12000)))
+
+(define (make-filesystem-page parent title)
+ (make-page (page-surface parent)
+ title
+ filesystem-page-refresh
+ filesystem-page-key-handler))
+
+
+(define my-buttons `((continue ,(N_ "_Continue") #t)
+ (back ,(N_ "Go _Back") #t)))
+
+
+
+(define (filesystem-page-refresh page)
+ (when (not (page-initialised? page))
+ (filesystem-page-init page)
+ (page-set-initialised! page #t))
+
+ (let ((text-win (page-datum page 'text-window))
+ (menu (page-datum page 'menu)))
+ (clear text-win)
+ (addstr text-win
+ (gettext "Select a partition to change its mount point or
filesystem."))
+
+ (menu-set-items! menu (partition-volume-pairs))
+ (touchwin (cdr (page-wwin page)))
+ (refresh (cdr (page-wwin page)))
+ (refresh (car (page-wwin page)))
+ (menu-refresh menu)
+ (menu-redraw menu)))
+
+
+(define (sizeof-partition device)
+ "Return the size of the partition DEVICE"
+ (partition-size
+ (car (find (lambda (x)
+ (equal? (partition-name (car x))
+ device)) (partition-volume-pairs)))))
+
+
+(define (filesystem-page-key-handler page ch)
+ (let ((menu (page-datum page 'menu))
+ (nav (page-datum page 'navigation)))
+
+ (cond
+ ((eq? ch KEY_RIGHT)
+ (menu-set-active! menu #f)
+ (buttons-select-next nav))
+
+ ((eq? ch #\tab)
+ (cond
+ ((menu-active menu)
+ (menu-set-active! menu #f)
+ (buttons-select nav 0))
+
+ ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+ (menu-set-active! menu #t)
+ (buttons-unselect-all nav))
+
+ (else
+ (buttons-select-next nav))))
+
+ ((eq? ch KEY_LEFT)
+ (menu-set-active! menu #f)
+ (buttons-select-prev nav))
+
+ ((eq? ch KEY_UP)
+ (buttons-unselect-all nav)
+ (menu-set-active! menu #t))
+
+ ((eq? ch #\newline)
+ (let* ((dev (list-ref (menu-items menu) (menu-current-item menu)))
+ (name (partition-name (car dev)))
+ (next (make-page (page-surface page)
+ (format #f
+ (gettext "Choose the mount point for
device ~s") name)
+ mount-point-refresh
+ mount-point-page-key-handler)))
+
+ (page-set-datum! next 'device name)
+ (set! page-stack (cons next page-stack))
+ ((page-refresh next) next)
+ ))
+
+
+ ((buttons-key-matches-symbol? nav ch 'continue)
+ (cond
+ ((not (find-mount-device "/" mount-points))
+ (let ((next
+ (make-dialog
+ page
+ (gettext
+ "You must choose a device on which to mount the root (/) of
the operating system's filesystem."))))
+ (set! page-stack (cons next page-stack))
+ ((page-refresh next) next)))
+
+ ((< (sizeof-partition (find-mount-device "/gnu" mount-points)) 12000)
+ (let ((next
+ (make-dialog
+ page
+ (format #f
+ (gettext
+ "The filesystem for ~a needs at least ~a of disk space.")
"/gnu" "12GB"))))
+ (set! page-stack (cons next page-stack))
+ ((page-refresh next) next)))
+
+ (else
+ (delwin (cdr (page-wwin page)))
+ (set! page-stack (cdr page-stack))
+ ((page-refresh (car page-stack)) (car page-stack))
+ ))))
+ (std-menu-key-handler menu ch))
+ #f
+ )
+
+(define (filesystem-page-init p)
+ (let* ((s (page-surface p))
+ (pr (make-boxed-window #f
+ (- (getmaxy s) 4) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+
+ (text-window (derwin (car pr) 3 (getmaxx (car pr))
+ 0 0))
+
+ (bwin (derwin (car pr)
+ 3 (getmaxx (car pr))
+ (- (getmaxy (car pr)) 3) 0
+ #:panel #f))
+ (buttons (make-buttons my-buttons 1))
+
+ (mwin (derwin (car pr)
+ (- (getmaxy (car pr)) 3 (getmaxy text-window))
+ (- (getmaxx (car 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 "~30a ~7a ~16a ~a"
+ name
+ (number->size (partition-size part))
+ (partition-fs part)
+ (let ((x (assoc-ref mount-points name)))
+ (if x x ""))))))))
+
+
+ (page-set-wwin! p pr)
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (page-set-datum! p 'text-window text-window)
+ (menu-post menu mwin)
+ (buttons-post buttons bwin)
+ (refresh (cdr pr))
+ (refresh bwin)))
+
+
diff --git a/gnu/system/installer/hostname.scm
b/gnu/system/installer/hostname.scm
new file mode 100644
index 0000000..bc10e6b
--- /dev/null
+++ b/gnu/system/installer/hostname.scm
@@ -0,0 +1,121 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer hostname)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer misc)
+ #:use-module (gnu system installer utils)
+ #:use-module (gurses form)
+ #:use-module (gurses buttons)
+ #:use-module (ncurses curses)
+
+ #:export (make-host-name-page))
+
+(define my-fields `((name ,(N_ "Host Name") 64)))
+
+(define (make-host-name-page parent title)
+ (make-page (page-surface parent)
+ title
+ host-name-refresh
+ host-name-key-handler))
+
+(define (host-name-refresh page)
+ (when (not (page-initialised? page))
+ (host-name-init page)
+ (page-set-initialised! page #t))
+
+ (let ((form (page-datum page 'form))
+ (text-window (page-datum page 'text-window)))
+ (clear text-window)
+ (addstr*
+ text-window
+ (gettext "Enter the host name for the new system. Only letters, digits
and hyphens are allowed. The first character may not be a hyphen. A maximum of
64 characters are allowed."))
+ (refresh text-window)
+ (refresh (cdr (page-wwin page)))
+ (refresh (form-window form))))
+
+(define (host-name-key-handler page ch)
+ (let ((form (page-datum page 'form))
+ (nav (page-datum page 'navigation))
+ (dev (page-datum page 'device)))
+
+ (cond
+ ((buttons-key-matches-symbol? nav ch 'continue)
+ (set! host-name (form-get-value form 0))
+ (set! page-stack (cdr page-stack))
+ ((page-refresh (car page-stack)) (car page-stack)))
+
+ ((or (eq? ch KEY_RIGHT)
+ (eq? ch #\tab))
+ (form-set-enabled! form #f)
+ (buttons-select-next nav))
+
+ ((eq? ch KEY_LEFT)
+ (form-set-enabled! form #f)
+ (buttons-select-prev nav))
+
+ ((eq? ch KEY_UP)
+ (buttons-unselect-all nav)
+ (form-set-enabled! form #t))
+
+ ((eq? ch KEY_DOWN)
+ (buttons-unselect-all nav)
+ (form-set-enabled! form #t))
+ )
+
+ (curs-set 1)
+ (form-enter form ch))
+ #f)
+
+(define my-buttons `((continue ,(N_ "Continue") #f)))
+
+(define (host-name-init p)
+ (let* ((s (page-surface p))
+ (pr (make-boxed-window
+ #f
+ (- (getmaxy s) 4) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+
+ (text-window (derwin (car pr) 5 (getmaxx (car pr))
+ 0 0))
+
+ (bwin (derwin (car pr)
+ 3 (getmaxx (car pr))
+ (- (getmaxy (car pr)) 3) 0
+ #:panel #f))
+
+ (nav (make-buttons my-buttons 1))
+
+ (fw (derwin (car pr)
+ 2
+ (getmaxx (car pr))
+ (getmaxy text-window) 0))
+
+
+ (form (make-form my-fields)))
+
+ (page-set-datum! p 'navigation nav)
+ (page-set-datum! p 'text-window text-window)
+ (page-set-datum! p 'form form)
+
+ (form-post form fw)
+ (buttons-post nav bwin)
+ (page-set-wwin! p pr)
+ (refresh (cdr pr))))
+
diff --git a/gnu/system/installer/misc.scm b/gnu/system/installer/misc.scm
new file mode 100644
index 0000000..0503424
--- /dev/null
+++ b/gnu/system/installer/misc.scm
@@ -0,0 +1,34 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer misc)
+ #:use-module (ncurses curses)
+
+ #:export (livery-title)
+ #:export (time-zone)
+ #:export (host-name)
+ #:export (mount-points))
+
+(define livery-title 1)
+
+(define mount-points '())
+
+(define time-zone "")
+
+(define host-name #f)
+
diff --git a/gnu/system/installer/mount-point.scm
b/gnu/system/installer/mount-point.scm
new file mode 100644
index 0000000..67d048b
--- /dev/null
+++ b/gnu/system/installer/mount-point.scm
@@ -0,0 +1,178 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer mount-point)
+ #:use-module (gnu system installer partition-reader)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer misc)
+ #:use-module (gnu system installer utils)
+ #:use-module (gurses form)
+ #:use-module (gurses buttons)
+ #:use-module (ncurses curses)
+
+ #: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 (mount-point-refresh page)
+ (when (not (page-initialised? page))
+ (mount-point-page-init page)
+ (page-set-initialised! page #t))
+ (let ((form (page-datum page 'form)))
+ (refresh (cdr (page-wwin page)))
+ (refresh (form-window form))))
+
+(define (mount-point-page-key-handler page ch)
+ (let ((form (page-datum page 'form))
+ (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)
+ (set! mount-points (assoc-set! mount-points
+ dev
+ (form-get-value form
'mount-point)))
+ (set! page-stack (cdr page-stack))
+ ((page-refresh (car page-stack)) (car page-stack)))
+
+ ((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
+ ((or (eq? ch KEY_RIGHT)
+ (eq? ch #\tab))
+ (form-set-enabled! form #f)
+ (buttons-select-next nav))
+
+ ((eq? ch KEY_LEFT)
+ (form-set-enabled! form #f)
+ (buttons-select-prev nav))
+
+ ((eq? ch KEY_UP)
+ (buttons-unselect-all nav)
+ (form-set-enabled! form #t))
+
+ ((eq? ch KEY_DOWN)
+ (buttons-unselect-all nav)
+ (form-set-enabled! form #t))
+ )
+
+ (curs-set 1)
+ (form-enter form ch))
+ #f)
+
+(define my-buttons `((continue ,(N_ "Continue") #f)
+ (check ,(N_ "Check") #f)
+ (write ,(N_ "Write") #f)
+ (recreate ,(N_ "(re)Create") #f)
+ (back ,(N_ "Go Back") #f)))
+
+(define (mount-point-page-init p)
+ (let* ((s (page-surface p))
+ (pr (make-boxed-window
+ #f
+ (- (getmaxy s) 4) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+
+ (text-window (derwin (car pr) 3 (getmaxx (car pr))
+ 0 0))
+
+ (bwin (derwin (car pr)
+ 3 (getmaxx (car pr))
+ (- (getmaxy (car pr)) 3) 0
+ #:panel #f))
+
+ (nav (make-buttons my-buttons 1))
+
+ (fw (derwin (car pr)
+ 2
+ (getmaxx (car pr))
+ (getmaxy text-window) 0))
+
+
+ (out (derwin (car pr)
+ (- (getmaxy (car pr)) (getmaxy bwin) (getmaxy text-window)
(getmaxy fw))
+ (getmaxx (car pr))
+ (+ (getmaxy text-window) (getmaxy fw))
+ 0))
+
+ (form (make-form my-fields)))
+
+ (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)))
+ (addstr*
+ text-window
+ (format #f
+ (gettext
+ "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)
+ "")))
+
+ (buttons-post nav bwin)
+ (page-set-datum! p 'form form)
+
+ (page-set-wwin! p pr)
+ (refresh (cdr pr))))
+
diff --git a/gnu/system/installer/network.scm b/gnu/system/installer/network.scm
new file mode 100644
index 0000000..f5cb7f4
--- /dev/null
+++ b/gnu/system/installer/network.scm
@@ -0,0 +1,169 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer network)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer ping)
+ #:use-module (gnu system installer misc)
+ #:use-module (gnu system installer utils)
+ #:use-module (ice-9 match)
+ #:use-module (gurses menu)
+ #:use-module (gurses buttons)
+ #:use-module (ncurses curses)
+
+ #:export (make-network-page))
+
+(define (make-network-page parent title)
+ (make-page (page-surface parent)
+ title
+ network-page-refresh
+ network-page-key-handler))
+
+
+(define interfaces (delete "lo"
+ (slurp "ip -o link"
+ (lambda (s)
+ (string-trim-both
+ (cadr (string-split s #\:))
+ char-set:whitespace)))))
+
+(define my-buttons `((continue ,(N_ "_Continue") #t)
+ (test ,(N_ "_Test") #t)))
+
+(define (network-page-key-handler page ch)
+ (let ((menu (page-datum page 'menu))
+ (nav (page-datum page 'navigation)))
+
+ (cond
+ ((eq? ch KEY_RIGHT)
+ (menu-set-active! menu #f)
+ (buttons-select-next nav))
+
+ ((eq? ch #\tab)
+ (cond
+ ((menu-active menu)
+ (menu-set-active! menu #f)
+ (buttons-select nav 0))
+
+ ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+ (menu-set-active! menu #t)
+ (buttons-unselect-all nav))
+
+ (else
+ (buttons-select-next nav))))
+
+ ((eq? ch KEY_LEFT)
+ (menu-set-active! menu #f)
+ (buttons-select-prev nav))
+
+ ((eq? ch KEY_UP)
+ (buttons-unselect-all nav)
+ (menu-set-active! menu #t))
+
+
+
+ ((buttons-key-matches-symbol? nav ch 'continue)
+ (delwin (cdr (page-wwin page)))
+ (set! page-stack (cdr page-stack))
+ ((page-refresh (car page-stack)) (car page-stack)))
+
+
+ ((buttons-key-matches-symbol? nav ch 'test)
+ (let ((next (make-page (page-surface page)
+ "Ping"
+ ping-page-refresh
+ ping-page-key-handler)))
+
+ (set! page-stack (cons next page-stack))
+ ((page-refresh next) next))))
+
+ (std-menu-key-handler menu ch))
+ #f)
+
+
+(define (network-page-refresh page)
+ (when (not (page-initialised? page))
+ (network-page-init page)
+ (page-set-initialised! page #t))
+ (touchwin (cdr (page-wwin page)))
+ (refresh (cdr (page-wwin page)))
+ (refresh (car (page-wwin page)))
+ (menu-refresh (page-datum page 'menu)))
+
+
+(define (network-page-init p)
+ (let* ((s (page-surface p))
+ (pr (make-boxed-window #f
+ (- (getmaxy s) 3) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+ (text-window (derwin
+ (car pr)
+ 5 (getmaxx (car pr))
+ 0 0
+ #:panel #f))
+
+ (bwin (derwin (car pr)
+ 3 (getmaxx (car pr))
+ (- (getmaxy (car pr)) 3) 0
+ #:panel #f))
+ (buttons (make-buttons my-buttons 1))
+
+ (mwin (derwin (car pr)
+ (- (getmaxy (car pr)) (getmaxy text-window) 3)
+ (- (getmaxx (car pr)) 0)
+ (getmaxy text-window) 0 #:panel #f))
+
+ (menu (make-menu
+ interfaces
+ #:disp-proc
+ (lambda (datum row)
+ ;; Convert a network device name such as "enp0s25" to
+ ;; something more descriptive like
+ ;; "82567LM Gigabit Network Connection"
+ (let* ((addr (string-tokenize datum char-set:digit))
+ (bus (match addr ((n . _)
+ (string->number n 10))))
+
+ (device (match addr ((_ . (n . _))
+ (string->number n 10))))
+
+ (func (match addr
+ ((_ . (_ . (n . _)))
+ (string->number n 10)) (_ 0))))
+ (car (assoc-ref
+ (slurp (format #f "lspci -vm -s~x:~x.~x" bus device
func)
+ (lambda (x)
+ (string-split x #\tab)))
+ "Device:")))))))
+
+
+ (addstr* text-window (format #f
+ (gettext
+ "To install GuixSD a connection to ~a must be available. The
following network devices exist on the system. Select one to configure or
\"Continue\" to proceeed.") (car substitution-servers)))
+
+ (page-set-wwin! p pr)
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (menu-post menu mwin)
+ (buttons-post buttons bwin)
+ (refresh (cdr pr))
+ (refresh text-window)
+ (refresh bwin)))
+
+
diff --git a/gnu/system/installer/new.scm b/gnu/system/installer/new.scm
new file mode 100644
index 0000000..1e7ee19
--- /dev/null
+++ b/gnu/system/installer/new.scm
@@ -0,0 +1,238 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer new))
+
+(use-modules (ncurses curses)
+ (gurses menu)
+ (gurses buttons)
+ (gnu system installer utils)
+ (gnu system installer misc)
+ (gnu system installer partition-reader)
+ (gnu system installer disks)
+ (gnu system installer filesystems)
+ (gnu system installer hostname)
+ (gnu system installer file-browser)
+ (gnu system installer time-zone)
+ (gnu system installer network)
+ (gnu system installer page)
+ (gnu system installer dialog)
+
+ (ice-9 format)
+ (ice-9 pretty-print)
+ (srfi srfi-9))
+
+(define main-options
+ `((disk ,(N_ "Partition the disk(s)")
+ ()
+ ,(lambda () #t)
+ ,(lambda (page)
+ (make-disk-page
+ page
+ (car (assq-ref main-options 'disk)))))
+
+
+ (filesystems ,(N_ "Allocate disk partitions")
+ (disk)
+ ,(lambda () (filesystem-task-complete?))
+ ,(lambda (page)
+ (make-filesystem-page
+ page
+ (car (assq-ref main-options 'filesystems)))))
+
+ (network ,(N_ "Setup the network")
+ ()
+ ,(lambda () #f)
+ ,(lambda (page)
+ (make-network-page
+ page
+ (car (assq-ref main-options 'network)))))
+
+ (timezone ,(N_ "Set the time zone")
+ ()
+ ,(lambda () (not (equal? "" time-zone)))
+ ,(lambda (page)
+ (make-tz-browser
+ page
+ (string-append (getenv "tzdata_package")
+ "/share/zoneinfo")
+ page-stack)))
+
+ (hostname ,(N_ "Set the host name")
+ ()
+ ,(lambda () #t)
+ ,(lambda (page)
+ (make-host-name-page
+ page
+ (car (assq-ref main-options 'hostname)))))
+
+ (generate ,(N_ "Generate the configuration")
+ (filesystems timezone)
+ ,(lambda () #t)
+ ,(lambda (page)
+ (make-dialog
+ page
+ (delay
+ (generate-guix-config
+ `(operating-system
+ (timezone ,time-zone)
+ (host-name ,host-name)
+ (locale "POSIX")
+ ,(let ((grub-mount-point
+ (find-mount-device "/boot/grub"
+ mount-points)))
+ (if grub-mount-point
+ `(bootloader
+ (grub-configuration
+ (device
+ ,(disk-name
+ (assoc-ref
+ (partition-volume-pairs)
+ (find-partition grub-mount-point))))
+ (timeout 2)))))
+
+ (file-systems
+ (cons*
+ ,(map (lambda (x)
+ (let ((z (find-partition (car x))))
+ `(filesystem
+ (device ,(car x))
+ (title 'device)
+ (mount-point ,(cdr x))
+ (type ,(partition-fs z)))))
+ mount-points)
+ %base-file-systems))
+ (users (cons* %base-user-accounts))
+ (packages (cons* nss-certs %base-packages))
+ (services (cons* %desktop-services))
+ (name-service-switch %mdns-host-lookup-nss))))
+ #:justify #f)))
+
+
+ (configure ,(N_ "Configure the system")
+ (generate network))))
+
+(define (generate-guix-config cfg)
+ (call-with-output-string
+ (lambda (p) (pretty-print cfg p))))
+
+
+(define (base-page-key-handler page ch)
+(cond
+ ((eqv? ch (key-f 1))
+ (endwin)
+ (let* ((p (mkstemp! (string-copy "/tmp/installer.XXXXXX")))
+ (file-name (port-filename p)))
+ (format p "echo '~a'\n" (gettext "Type \"exit\" to return to the GuixSD
installer."))
+ (close p)
+ (system* "bash" "--rcfile" file-name)
+ (delete-file file-name)))
+
+ ((eqv? ch (key-f 9))
+ (setlocale LC_ALL "de_DE.UTF-8")
+ )
+
+ ((eqv? ch (key-f 10))
+ (let ((p (make-file-browser
+ page
+ (string-append (getenv "kbd_package") "/share/keymaps")
+ page-stack)))
+ (set! page-stack (cons p page-stack))
+ ((page-refresh p) p)))))
+
+(define (main-page-key-handler page ch)
+ (let ((main-menu (page-datum page 'menu)))
+ (std-menu-key-handler main-menu ch)
+ (cond
+
+ ((eq? ch #\newline)
+ (let ((mi (menu-current-item main-menu))
+ (item (menu-get-current-item main-menu)))
+ (let ((direct-page ((cadddr (cdr item)) page)))
+ (set! page-stack (cons direct-page page-stack))
+ ((page-refresh (car page-stack)) (car page-stack))))))))
+
+
+(define (main-page-init page)
+ (let* ((frame (make-boxed-window (page-surface page) (lines) (cols) 0 0
+ #:title (page-title page)))
+ (background (car frame)))
+
+ (let ((win (derwin background (- (getmaxy background) 3)
+ (- (getmaxx background) 2) 0 1 #:panel #f))
+ (main-menu (make-menu main-options
+ #:disp-proc (lambda (datum row)
+ (format #f "~a" (gettext (cadr
datum)))))))
+ (page-set-wwin! page frame)
+ (page-set-datum! page 'menu main-menu)
+ (menu-post main-menu win))
+
+ ;; Do the key action labels
+ (let ((ypos (1- (getmaxy background)))
+ (str0 (gettext "Get a Shell <F1>"))
+ (str1 (gettext "Language <F9>"))
+ (str2 (gettext "Keyboard <F10>")))
+
+ (addstr background str0 #:y ypos #:x 0)
+ (addstr background str1 #:y ypos #:x
+ (truncate (/ (- (getmaxx background)
+ (string-length str1)) 2)))
+ (addstr background str2 #:y ypos #:x
+ (- (getmaxx background) (string-length str2))))))
+
+
+(define (main-page-refresh page)
+ (when (not (page-initialised? page))
+ (main-page-init page)
+ (page-set-initialised! page #t))
+
+ (touchwin (cdr (page-wwin page)))
+ (refresh (cdr (page-wwin page)))
+ (refresh (car (page-wwin page)))
+ (menu-refresh (page-datum page 'menu))
+ (menu-redraw (page-datum page 'menu)))
+
+
+
+(define-public (guixsd-installer)
+ (define stdscr (initscr)) ; Start curses
+ (cbreak!) ; Line buffering disabled
+ (keypad! stdscr #t) ; Check for function keys
+ (noecho!)
+
+ (start-color!)
+
+ (init-pair! livery-title COLOR_RED COLOR_BLACK)
+
+ (curs-set 0)
+
+
+ (let ((page (make-page
+ stdscr (gettext "GuixSD Installer")
+ main-page-refresh main-page-key-handler)))
+
+ (set! page-stack (cons page page-stack))
+ ((page-refresh page) (car page-stack))
+ (let loop ((ch (getch stdscr)))
+ (let ((current-page (car page-stack)))
+ ((page-key-handler current-page) current-page ch)
+ (base-page-key-handler current-page ch))
+ ((page-refresh (car page-stack)) (car page-stack))
+ (loop (getch stdscr)))
+
+ (endwin)))
diff --git a/gnu/system/installer/page.scm b/gnu/system/installer/page.scm
new file mode 100644
index 0000000..e17326c
--- /dev/null
+++ b/gnu/system/installer/page.scm
@@ -0,0 +1,56 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer page)
+ #:export (make-page)
+ #:export (page-stack)
+ #:export (page-surface)
+ #:export (page-refresh)
+ #:export (page-initialised?)
+ #:export (page-set-initialised!)
+ #:export (page-stack)
+ #:export (page-set-wwin!)
+ #:export (page-wwin)
+ #:export (page-title)
+ #:export (page-datum)
+ #:export (page-set-datum!)
+ #:export (page-key-handler)
+
+ #:use-module (srfi srfi-9))
+
+(define page-stack '())
+
+(define-record-type <page>
+ (make-page' surface title inited refresh key-handler data)
+ page?
+ (title page-title)
+ (surface page-surface)
+ (inited page-initialised? page-set-initialised!)
+ (refresh page-refresh)
+ (key-handler page-key-handler)
+ (wwin page-wwin page-set-wwin!)
+ (data page-data page-set-data!))
+
+(define (make-page surface title refresh key-handler)
+ (make-page' surface title #f refresh key-handler '()))
+
+(define (page-set-datum! page key value)
+ (page-set-data! page (acons key value (page-data page))))
+
+(define (page-datum page key)
+ (assq-ref (page-data page) key))
diff --git a/gnu/system/installer/partition-reader.scm
b/gnu/system/installer/partition-reader.scm
new file mode 100644
index 0000000..f6d7d65
--- /dev/null
+++ b/gnu/system/installer/partition-reader.scm
@@ -0,0 +1,213 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer partition-reader)
+ #:export (disk?
+ partition?
+ disk-vendor
+ disk-size
+ disk-name
+ disk-type
+ disk-partitions
+
+ partition-number
+ partition-size
+ partition-fs
+ partition-name
+
+ partition-volume-pairs
+
+ number->size
+
+ find-partition
+
+ disk-volumes)
+
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (gnu system installer utils)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-9))
+
+(define (number->size n)
+ "Convert a number of megabytes into a human readable size representation"
+ (let ((pr
+ (let loop ((q (* n 1000))
+ (m 0))
+ (if (and (integer? (/ q 100))
+ (>= (/ q 1000.0) 1))
+ (loop (/ q 1000) (1+ m))
+ (cons q m)))))
+ (format #f "~h~aB" (car pr)
+ (case (cdr pr)
+ ((0) #\K)
+ ((1) #\M)
+ ((2) #\G)
+ ((3) #\T)
+ ((4) #\P)
+ (else (error "Extremely large"))))))
+
+(define (size->number size)
+ "Convert a size string in the form 12.34[KMGT]B into a number, representing
the
+number of Megabytes"
+ (let* ((threshold (1+ (string-index-right size char-set:digit)))
+ (quantity (string->number (substring size 0 threshold)))
+ (unit (substring size threshold))
+ (multiplier
+ (cond
+ ((equal? "KB" unit)
+ 0.001)
+ ((equal? "MB" unit)
+ 1)
+ ((equal? "GB" unit)
+ 1000)
+ ((equal? "TB" unit)
+ 1000000)
+ )))
+
+ (* multiplier quantity)))
+
+
+
+(define-record-type <partition>
+ (make-partition number start stop size fs type flags)
+ partition?
+ (number partition-number)
+ (name partition-name partition-set-name!)
+ (start partition-start)
+ (stop partition-stop)
+ (size partition-size)
+ (fs partition-fs)
+ (type partition-type)
+ (flags partition-flags))
+
+(define-record-type <disk>
+ (make-disk name size type logical-sector-size physical-sector-size table
+ vendor xx)
+ disk?
+ (name disk-name)
+ (size disk-size)
+ (type disk-type)
+ (logical-sector-size disk-logical-sector-size)
+ (physical-sector-size disk-physical-sector-size)
+ (table disk-table)
+ (vendor disk-vendor)
+ (xx disk-xx) ; I have no idea what this field means
+ (partitions disk-partitions disk-set-partitions!))
+
+
+(define (read-line-drop-semi port)
+ (let ((line (read-line port)))
+ (if (eq? #\;
+ (string-ref line (1- (string-length line))))
+ (string-drop-right line 1)
+ line)))
+
+(define (parse-disk port disk-list)
+ (if (not (string=? "BYT" (read-line-drop-semi port)))
+ (error "Expected BYT;"))
+
+ (let ((line (read-line-drop-semi port)))
+ (match (string-split line #\:)
+ ((name size type logical physical table vendor xx)
+ (cons
+ (make-disk name (size->number size) type logical physical table vendor
xx)
+ disk-list)))))
+
+
+(define (parse-partition port partition-list)
+ (let ((line (read-line-drop-semi port)))
+ (match (string-split line #\:)
+ ((number start stop size fs type flags)
+ (cons
+ (make-partition number start stop
+ (size->number size)
+ fs type flags)
+ partition-list)))))
+
+(define (read-partition-info)
+ (define (read-partition-info' port l)
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ l
+ (if (or (zero? (string-length line))
+ (string-match "[\t ][\t ]*" line))
+ (read-partition-info' port l)
+ (begin
+ (unread-string (string-append line "\n") port)
+ (read-partition-info' port
+ (if (string=? "BYT;" line)
+ (parse-disk port l)
+ (parse-partition port l))))))))
+
+ (let* ((port (open-input-pipe-with-fallback "parted -lm"))
+ (r (read-partition-info' port '())))
+ (close-pipe port)
+ r))
+
+(define (assemble-partitions input disks partitions)
+ (if (null? input)
+ disks
+ (if (disk? (car input))
+ (let ((current-disk (car input)))
+ (disk-set-partitions! current-disk partitions)
+ (map
+ (lambda (p) (partition-set-name! p (device-id (cons p
current-disk))))
+ partitions)
+ (assemble-partitions (cdr input) (cons current-disk disks) '()))
+ (assemble-partitions (cdr input) disks (cons (car input)
partitions)))))
+
+(define (disk-volumes)
+ "Return a list of disk volumes on the current machine"
+ (assemble-partitions (read-partition-info) '() '()))
+
+
+
+(define (device-id pr)
+ "Given PR which is a (partition . volume) pair return the string
+representing its name"
+ (let ((volume (cdr pr))
+ (part (car pr)))
+ (string-append (disk-name volume)
+ (if (equal? "dm" (disk-type volume))
+ ""
+ (partition-number part)))))
+
+;; Return a list of pairs whose CAR is a partition and whose CDR is the volume
+;; on which that partition resides
+(define (partition-volume-pairs)
+ (let loop ((volumes (disk-volumes))
+ (partitions '()))
+ (if (null? volumes)
+ partitions
+ (loop (cdr volumes)
+ (append partitions
+ (map-in-order (lambda (part) (cons part (car volumes)))
+ (disk-partitions (car volumes))))))))
+
+(define (find-partition target)
+ "Return the partition whose name is TARGET"
+ (let loop ((p (partition-volume-pairs)))
+ (if (not (null? p))
+ (let* ((pr (car p))
+ (part (car pr))
+ (name (partition-name part)))
+ (if (equal? name target)
+ part
+ (loop (cdr p)))))))
diff --git a/gnu/system/installer/ping.scm b/gnu/system/installer/ping.scm
new file mode 100644
index 0000000..fcf5827
--- /dev/null
+++ b/gnu/system/installer/ping.scm
@@ -0,0 +1,120 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer ping)
+ #:use-module (gnu system installer partition-reader)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer misc)
+ #:use-module (gnu system installer utils)
+ #:use-module (gurses buttons)
+ #:use-module (ncurses curses)
+
+ #:export (substitution-servers)
+ #:export (ping-page-refresh)
+ #:export (ping-page-key-handler))
+
+
+(define substitution-servers '("mirror.hydra.gnu.org"))
+
+(define my-buttons `((test ,(N_ "_Test") #t)
+ (continue ,(N_ "_Continue") #t)
+ (back ,(N_ "Go _Back") #t)))
+
+(define (ping-page-key-handler page ch)
+ (let ((nav (page-datum page 'navigation))
+ (test-window (page-datum page 'test-window)))
+
+ (cond
+ ((eq? ch KEY_RIGHT)
+ (buttons-select-next nav))
+
+ ((eq? ch #\tab)
+ (cond
+ ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+ (buttons-unselect-all nav))
+
+ (else
+ (buttons-select-next nav))))
+
+ ((eq? ch KEY_LEFT)
+ (buttons-select-prev nav))
+
+ ((eq? ch KEY_UP)
+ (buttons-unselect-all nav))
+
+ ((buttons-key-matches-symbol? nav ch 'continue)
+ (delwin (cdr (page-wwin page)))
+ (delwin (car (page-wwin page)))
+
+ (delwin (page-datum page 'test-window))
+ (set! page-stack (cdr page-stack))
+ )
+
+ ((buttons-key-matches-symbol? nav ch 'test)
+
+ (let* ((windowp (make-window-port test-window)))
+ (if (zero?
+ (window-pipe test-window "ping" "ping" "-c" "3" (car
substitution-servers)))
+ (addstr test-window
+ (gettext "Test successful. Network is working."))
+ (addstr test-window
+ (gettext "Test failed. No servers reached.")))
+
+ (refresh test-window)))) #f))
+
+(define (ping-page-refresh page)
+ (when (not (page-initialised? page))
+ (ping-page-init page)
+ (page-set-initialised! page #t))
+ (refresh (page-datum page 'test-window)))
+
+(define (ping-page-init p)
+ (let* ((s (page-surface p))
+ (frame (make-boxed-window #f
+ (- (getmaxy s) 5) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+ (button-window (derwin (car frame)
+ 3 (getmaxx (car frame))
+ (- (getmaxy (car frame)) 3) 0
+ #:panel #f))
+ (buttons (make-buttons my-buttons 1))
+
+ (text-window (derwin (car frame)
+ 4
+ (getmaxx (car frame))
+ 0 0 #:panel #f))
+
+ (test-window (derwin (car frame)
+ (- (getmaxy (car frame)) (getmaxy text-window)
(getmaxy button-window))
+ (getmaxx (car frame))
+ (getmaxy text-window) 0 #:panel #f))
+ )
+
+ (box test-window 0 0)
+ (addstr* text-window
+ (gettext "Choose \"Test\" to check network connectivity."))
+ (page-set-wwin! p frame)
+ (page-set-datum! p 'test-window test-window)
+ (page-set-datum! p 'navigation buttons)
+ (buttons-post buttons button-window)
+ (refresh text-window)
+ (refresh button-window)))
+
+
+
diff --git a/gnu/system/installer/pipe-subst/parted%-lm
b/gnu/system/installer/pipe-subst/parted%-lm
new file mode 100644
index 0000000..cbf7b12
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/parted%-lm
@@ -0,0 +1,42 @@
+BYT;
+/dev/sda:500GB:scsi:512:4096:msdos:ATA WDC WD5000LPVX-2:;
+1:1049kB:256MB:255MB:ext2::boot;
+2:257MB:500GB:500GB:::;
+5:257MB:500GB:500GB:::lvm;
+
+BYT;
+/dev/mapper/jocasta-var:2999MB:dm:512:4096:loop:Linux device-mapper (linear):;
+1:0.00B:2999MB:2999MB:ext4::;
+
+BYT;
+/dev/mapper/jocasta-scratch:107GB:dm:512:4096:loop:Linux device-mapper
(linear):;
+1:0.00B:107GB:107GB:ext4::;
+
+BYT;
+/dev/mapper/jocasta-gnu:32.8GB:dm:512:4096:loop:Linux device-mapper (linear):;
+1:0.00B:32.8GB:32.8GB:ext4::;
+
+BYT;
+/dev/mapper/jocasta-swap_1:3448MB:dm:512:4096:loop:Linux device-mapper
(linear):;
+1:0.00B:3448MB:3448MB:linux-swap(v1)::;
+
+BYT;
+/dev/mapper/jocasta-home:48.3GB:dm:512:4096:loop:Linux device-mapper (linear):;
+1:0.00B:48.3GB:48.3GB:ext4::;
+
+BYT;
+/dev/mapper/jocasta-tmp:12.9GB:dm:512:4096:loop:Linux device-mapper (linear):;
+1:0.00B:12.9GB:12.9GB:ext4::;
+
+BYT;
+/dev/mapper/jocasta-tmp2:12.9GB:dm:512:4096:loop:Linux device-mapper (linear):;
+1:0.00B:12.9GB:12.9GB:ext4::;
+
+BYT;
+/dev/mapper/jocasta-usr:8997MB:dm:512:4096:loop:Linux device-mapper (linear):;
+1:0.00B:8997MB:8997MB:ext4::;
+
+BYT;
+/dev/mapper/jocasta-root:688MB:dm:512:4096:loop:Linux device-mapper (linear):;
+1:0.00B:688MB:688MB:ext4::;
+
diff --git a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-gnu
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-gnu
new file mode 100644
index 0000000..68b113e
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-gnu
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-gnu
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git
a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-home
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-home
new file mode 100644
index 0000000..95615aa
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-home
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-root
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git
a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-root
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-root
new file mode 100644
index 0000000..95615aa
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-root
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-root
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git
a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-scratch
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-scratch
new file mode 100644
index 0000000..9af3353
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-scratch
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-scratch
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git
a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-swap_1
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-swap_1
new file mode 100644
index 0000000..8ad4886
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-swap_1
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-swap1
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp
new file mode 100644
index 0000000..3867426
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-tmp
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git
a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp2
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp2
new file mode 100644
index 0000000..90b1398
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-tmp2
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-tmp2
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-usr
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-usr
new file mode 100644
index 0000000..0ae2afa
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-usr
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-usr
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-var
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-var
new file mode 100644
index 0000000..120d118
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,mapper,jocasta-var
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-var
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git a/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,sda1
b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,sda1
new file mode 100644
index 0000000..d925adf
--- /dev/null
+++ b/gnu/system/installer/pipe-subst/tune2fs%-l%,dev,sda1
@@ -0,0 +1,45 @@
+tune2fs 1.42.13 (17-May-2015)
+Filesystem volume name: gambrinus-sda1
+Last mounted on: /
+Filesystem UUID: fffdeafe-fb95-43c8-9855-2bfaabcd4f7f
+Filesystem magic number: 0xEF53
+Filesystem revision #: 1 (dynamic)
+Filesystem features: has_journal ext_attr resize_inode dir_index filetype
needs_recovery extent flex_bg sparse_super large_file huge_file uninit_bg
dir_nlink extra_isize
+Filesystem flags: signed_directory_hash
+Default mount options: user_xattr acl
+Filesystem state: clean
+Errors behavior: Continue
+Filesystem OS type: Linux
+Inode count: 14339376
+Block count: 57241600
+Reserved block count: 2862072
+Free blocks: 48591823
+Free inodes: 12880624
+First block: 0
+Block size: 4096
+Fragment size: 4096
+Reserved GDT blocks: 1010
+Blocks per group: 32768
+Fragments per group: 32768
+Inodes per group: 8208
+Inode blocks per group: 513
+RAID stride: 32639
+Flex block group size: 16
+Filesystem created: Tue Aug 23 23:01:31 2016
+Last mount time: Wed Nov 2 17:31:15 2016
+Last write time: Wed Nov 2 17:31:15 2016
+Mount count: 299
+Maximum mount count: -1
+Last checked: Wed Aug 24 20:34:30 2016
+Check interval: 0 (<none>)
+Lifetime writes: 436 GB
+Reserved blocks uid: 0 (user root)
+Reserved blocks gid: 0 (group root)
+First inode: 11
+Inode size: 256
+Required extra isize: 28
+Desired extra isize: 28
+Journal inode: 8
+Default directory hash: half_md4
+Directory Hash Seed: 6ea7aa75-15b6-4a70-8d25-02294393f373
+Journal backup: inode blocks
diff --git a/gnu/system/installer/time-zone.scm
b/gnu/system/installer/time-zone.scm
new file mode 100644
index 0000000..9428624
--- /dev/null
+++ b/gnu/system/installer/time-zone.scm
@@ -0,0 +1,149 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer time-zone)
+ #:use-module (gnu system installer page)
+ #:use-module (gnu system installer utils)
+ #:use-module (gnu system installer misc)
+ #:use-module (gurses menu)
+ #:use-module (gurses buttons)
+ #:use-module (ncurses curses)
+
+ #:export (make-tz-browser))
+
+(define* (make-tz-browser parent directory #:optional (exit-point #f))
+ (let ((page (make-page (page-surface parent)
+ (gettext "Time Zone")
+ file-browser-page-refresh
+ file-browser-page-key-handler)))
+ (page-set-datum! page 'directory directory)
+ (if exit-point
+ (page-set-datum! page 'exit-point exit-point)
+ (page-set-datum! page 'exit-point (page-datum parent 'exit-point)))
+ page))
+
+
+(define my-buttons `((back ,(N_ "_Back") #t)))
+
+(define (file-browser-page-key-handler page ch)
+ (let ((nav (page-datum page 'navigation))
+ (menu (page-datum page 'menu))
+ (directory (page-datum page 'directory)))
+
+ (cond
+ ((eq? ch #\tab)
+ (cond
+ ((eqv? (buttons-selected nav) (1- (buttons-n-buttons nav)))
+ (buttons-unselect-all nav))
+
+ (else
+ (buttons-select-next nav))))
+
+ ((buttons-key-matches-symbol? nav ch 'back)
+ (delwin (cdr (page-wwin page)))
+ (delwin (car (page-wwin page)))
+
+ (set! page-stack (cdr page-stack)))
+
+ ((and (eqv? ch #\newline)
+ (menu-active menu))
+ (let* ((i (menu-get-current-item menu))
+ (new-dir (string-append directory "/" i))
+ (st (lstat new-dir)))
+ (if (and (file-exists? new-dir)
+ (eq? 'directory (stat:type st)))
+ (let ((p (make-tz-browser
+ page new-dir)))
+ (page-set-datum! p 'stem
+ (if (page-datum page 'stem)
+ (string-append (page-datum page 'stem) "/" i)
+ i))
+ (set! page-stack (cons p page-stack))
+ ((page-refresh p) p))
+ (begin
+ (set! time-zone
+ (if (page-datum page 'stem)
+ (string-append (page-datum page 'stem) "/" i)
+ i))
+ (set! page-stack (page-datum page 'exit-point))
+ #f)))
+ ))
+ (std-menu-key-handler menu ch)
+ #f))
+
+
+(define (file-browser-page-refresh page)
+ (when (not (page-initialised? page))
+ (file-browser-page-init page)
+ (page-set-initialised! page #t))
+ (touchwin (cdr (page-wwin page)))
+ (refresh (cdr (page-wwin page)))
+ (refresh (car (page-wwin page)))
+ (menu-refresh (page-datum page 'menu)))
+
+(define (file-browser-page-init p)
+ (let* ((s (page-surface p))
+ (frame (make-boxed-window #f
+ (- (getmaxy s) 5) (- (getmaxx s) 2)
+ 2 1
+ #:title (page-title p)))
+ (button-window (derwin (car frame)
+ 3 (getmaxx (car frame))
+ (- (getmaxy (car frame)) 3) 0
+ #:panel #f))
+ (buttons (make-buttons my-buttons 1))
+
+ (text-window (derwin (car frame)
+ 4
+ (getmaxx (car frame))
+ 0 0 #:panel #f))
+
+ (menu-window (derwin (car frame)
+ (- (getmaxy (car frame)) 3 (getmaxy text-window))
+ (getmaxx (car frame))
+ (getmaxy text-window) 0 #:panel #f))
+
+ (menu (make-menu
+ (let nn ((ds (opendir (page-datum p 'directory)))
+ (ll '()))
+ (let ((o (readdir ds)))
+ (if (eof-object? o)
+ (begin
+ (closedir ds)
+ (sort ll string< ))
+ (nn ds
+ (cond
+ ((equal? "." o) ll)
+ ((equal? ".." o) ll)
+ ((>= (string-suffix-length o ".tab") 4) ll)
+ (else
+ (cons o ll)))))))))
+ )
+
+ (menu-post menu menu-window)
+
+ (addstr* text-window
+ (gettext "Select the default time zone for the system:" ))
+ (page-set-wwin! p frame)
+ (page-set-datum! p 'menu menu)
+ (page-set-datum! p 'navigation buttons)
+ (buttons-post buttons button-window)
+ (refresh (cdr frame))
+ (refresh (car frame))
+ (refresh text-window)
+ (refresh button-window)))
diff --git a/gnu/system/installer/utils.scm b/gnu/system/installer/utils.scm
new file mode 100644
index 0000000..6df2535
--- /dev/null
+++ b/gnu/system/installer/utils.scm
@@ -0,0 +1,318 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system installer utils)
+ #:export (justify
+ justify*
+ addstr*
+ slurp
+ quit-key?
+
+ debug
+
+ push-cursor
+ pop-cursor
+
+ make-window-port
+ new-nav-form
+ standard-menu-keystrokes
+
+ make-boxed-window
+
+ open-input-pipe-with-fallback
+
+ find-mount-device
+
+ window-pipe
+
+ N_
+
+ select-key?))
+
+(use-modules (ice-9 popen)
+ (ice-9 rdelim)
+ (ncurses menu)
+ (gnu system installer misc)
+ (ncurses form)
+ (ncurses curses))
+
+(define (N_ str) str)
+
+(define debug-port (open "/tmp/xx" (logior O_APPEND O_CREAT O_WRONLY)))
+
+(define (debug str)
+ (display str debug-port)
+ (force-output debug-port))
+
+
+(define (make-window-port win)
+ "Return a port which writes to the curses window WIN"
+ (make-soft-port
+ (vector
+ (lambda (c) (addch win c))
+ (lambda (s) (addstr win s))
+ (lambda () (refresh win))
+ #f
+ #f)
+ "w"))
+
+(define* (window-pipe win cmd #:rest args)
+ "Run CMD ARGS ... sending stdout and stderr to WIN. Returns the exit status
of CMD."
+ (let* ((windowp (make-window-port win))
+ (pipep (pipe))
+ (pid (primitive-fork)))
+
+ (clear win)
+ (if (zero? pid)
+ (begin
+ (redirect-port (cdr pipep) (current-output-port))
+ (redirect-port (cdr pipep) (current-error-port))
+ (apply execlp cmd args))
+ (begin
+ (close (cdr pipep))
+ (let loop ((c (read-char (car pipep))))
+ (if (not (eof-object? c))
+ (begin
+ (display c windowp)
+ (force-output windowp)
+ (loop (read-char (car pipep))))))))
+
+ (cdr (waitpid pid))))
+
+(define (justify text width)
+ "A naive function to split a string into lines no more than width characters
long."
+ (define (justify' l n acc)
+ (if (null? l)
+ acc
+ (let* ((word (car l))
+ (len (string-length word)))
+
+ (define (linefull? n w)
+ (> (+ len n) w))
+
+ (justify'
+ (if (linefull? n width)
+ l
+ (cdr l))
+ (if (linefull? n width)
+ 0
+ (+ n (1+ len)))
+
+ (if (linefull? n width)
+ (string-append acc
+ (make-string (- width len) #\space))
+ (string-append acc word " "))))))
+
+ (justify' (string-split text char-set:blank) 0 ""))
+
+(define (justify* text width)
+ "A naive function to split a string into lines no more than width characters
long.
+This version assumes some external entity puts in the carriage returns."
+ (define (justify' l n acc)
+ (if (null? l)
+ acc
+ (let* ((word (car l))
+ (o (remainder n width))
+ (len (string-length word))
+ (appendage (cond ((zero? o)
+ (string-append word))
+
+ ((> (- width o) len)
+ (string-append " " word))
+
+ (else
+ (string-append (make-string (- width o)
#\space) word)))))
+
+ (justify'
+ (cdr l)
+
+ (+ n (string-length appendage))
+
+ (string-append acc appendage)))))
+
+ (justify' (string-split text char-set:blank) 0 ""))
+
+
+(define (addstr* win str)
+ "Call the curses addstr procedure passing STR to justify to the width of WIN"
+ (addstr win (justify* str (getmaxx win))))
+
+(define (open-input-pipe-with-fallback cmd)
+ "Kludge for testing"
+ (let* ((subst (string-append (dirname (current-filename)) "/pipe-subst/"
+ (string-map (lambda (c) (case c
+ ((#\space) #\%)
+ ((#\/) #\,)
+ (else c)))
+ cmd))))
+ (if (and (not (eqv? 0 (geteuid)))
+ (file-exists? subst))
+ (open-input-pipe (string-append "cat " subst))
+ (open-input-pipe cmd))))
+
+(define (slurp cmd proc)
+ (let ((port #f)
+ (status #f)
+ (result #f))
+ (dynamic-wind (lambda () (set! port (open-input-pipe-with-fallback cmd)))
+ (lambda () (set! result (slurp-real port proc)))
+ (lambda () (set! status (close-pipe port))))
+ (if (zero? (status:exit-val status))
+ result
+ #f)))
+
+(define (slurp-real port proc)
+ "Execute CMD in a shell and return a list of strings from its standard
output,
+one per line. If PROC is not #f then it must be a procedure taking a string
+which will process each string before returning it."
+ (let lp ((line-list '()))
+ (let ((l (read-line port)))
+ (if (eof-object? l)
+ line-list
+ (lp (cons (if proc (proc l) l) line-list))))))
+
+
+
+(define (quit-key? c)
+ (or
+ (eqv? c #\q)
+ (eqv? c #\Q)
+ (eqv? c #\esc)))
+
+(define (select-key? c)
+ (or
+ (eqv? c #\nl)
+ (eqv? c #\cr)
+ (eqv? c KEY_ENTER)))
+
+
+
+
+(define cursor-stack '())
+
+(define (push-cursor c)
+ (curs-set c)
+ (set! cursor-stack (cons c cursor-stack)))
+
+(define (pop-cursor)
+ (set! cursor-stack (cdr cursor-stack))
+ (curs-set (car cursor-stack)))
+
+
+
+
+(define (standard-menu-keystrokes ch menu)
+ (let ((win (menu-win menu)))
+ (cond
+ ((eqv? ch KEY_DOWN)
+ (menu-driver menu REQ_DOWN_ITEM)
+ )
+
+ ((eqv? ch KEY_UP)
+ (menu-driver menu REQ_UP_ITEM)
+ ))
+
+ (refresh win)))
+
+
+
+(define (new-nav-form button-fields)
+ (new-form (let usr ((ef button-fields)
+ (xpos 0)
+ (acc '()))
+ (if (null? ef)
+ (reverse acc)
+ (let* ((ff (cdr (car ef)))
+ (label (car ff))
+ (nf (new-field 1 (string-length label) 1 xpos 0 0)))
+ (list-set! ff 1 nf)
+ (set-field-buffer! nf 0 label)
+ (field-opts-off! nf O_EDIT)
+ (usr (cdr ef)
+ (+ xpos (string-length label) 1)
+ (cons nf acc)))))))
+
+
+
+
+
+(define* (make-boxed-window orig height width starty startx #:key (title #f))
+ "Create a window with a frame around it, and optionally a TITLE. Returns a
+pair whose car is the inner window and whose cdr is the frame."
+ (let* ((win (if orig
+ (derwin orig height width starty startx #:panel #f)
+ (newwin height width starty startx #:panel #f)
+ ))
+ (ystart (if title 3 1))
+ (sw (derwin win (- (getmaxy win) ystart 1)
+ (- (getmaxx win) 2)
+ ystart 1 #:panel #f)))
+ (clear win)
+ (box win (acs-vline) (acs-hline))
+
+ (if title
+ (begin
+ (move win 2 1)
+ (hline win (acs-hline) (- (getmaxx win) 2))
+ (color-set! win livery-title)
+ (addstr win title #:y 1
+ #:x (round (/ (- (getmaxx win) (string-length title)) 2)))))
+
+ (refresh sw)
+ ;; Return the inner and outer windows
+ (cons sw win)))
+
+
+(define (find-mount-device in mp)
+ "Given the list of (device . mount-point) pairs MP which indicates intended
+mounts return the device on which the path IN would be mounted."
+ (define dir-sep #\/)
+
+ (define (normalise-directory-path p)
+ ;; Drop the last character if it is #\/
+ ;; !!!even if that is the ONLY character!!!
+ (if (positive? (string-length p))
+ (let* ((last (1- (string-length p))))
+ (if (eqv? dir-sep (string-ref p last))
+ (string-drop-right p 1)
+ p))
+ p))
+
+ (if (not (absolute-file-name? in))
+ (error (format #f "Path is not absolute")))
+
+ (let ((target (string-split (normalise-directory-path in) dir-sep))
+ (paths
+ (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)))))))
+
+ (let loop ((pp paths))
+ (if (null? pp)
+ #f
+ (let* ((subject (cdar pp))
+ (len (min (length subject)
+ (length target))))
+ (if (and
+ (<= (length subject) (length target))
+ (equal? (list-head target len)
+ (list-head subject len)))
+ (caar pp)
+ (loop (cdr pp))))))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 144a7fd..194e386 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -40,6 +40,7 @@
#:use-module (gnu system file-systems)
#:use-module (gnu system linux-container)
#:use-module (gnu system vm)
+ #:use-module (gnu system installer new)
#:use-module (gnu system grub)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
@@ -727,6 +728,8 @@ Some ACTIONS support additional ARGS.\n"))
extension-graph emit the service extension graph in Dot format\n"))
(display (_ "\
shepherd-graph emit the graph of shepherd services in Dot format\n"))
+ (display (_ "\
+ installer start the graphical GuixSD installer\n"))
(show-build-options-help)
(display (_ "
@@ -894,6 +897,8 @@ argument list and OPTS is the option alist."
(with-store store
(set-build-options-from-command-line store opts)
(roll-back-system store))))
+ ((installer)
+ (guixsd-installer))
;; The following commands need to use the store, and they also
;; need an operating system configuration file.
(else (process-action command args opts))))
@@ -907,7 +912,7 @@ argument list and OPTS is the option alist."
(case action
((build container vm vm-image disk-image reconfigure init
extension-graph shepherd-graph list-generations roll-back
- switch-generation)
+ switch-generation installer)
(alist-cons 'action action result))
(else (leave (_ "~a: unknown action~%") action))))))
diff --git a/gurses/buttons.scm b/gurses/buttons.scm
new file mode 100644
index 0000000..7b1c666
--- /dev/null
+++ b/gurses/buttons.scm
@@ -0,0 +1,163 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gurses buttons)
+
+ #:export (make-buttons)
+ #:export (buttons-post)
+ #:export (buttons-select-next)
+ #:export (buttons-select-prev)
+ #:export (buttons-unselect-all)
+ #:export (buttons-select)
+ #:export (buttons-selected)
+ #:export (buttons-fetch-by-key)
+ #:export (buttons-n-buttons)
+ #:export (buttons-get-current-selection)
+ #:export (buttons-key-matches-symbol?)
+
+ #:use-module (ncurses curses)
+ #:use-module (srfi srfi-9))
+
+(define-record-type <buttons>
+ (make-buttons' items selected active-color)
+ buttons?
+ (items buttons-items buttons-set-items!) ;; FIXME this need not be
here
+ (selected buttons-selected buttons-set-selected!)
+ (array buttons-array buttons-set-array!)
+ (active-color buttons-active-color))
+
+(define (make-buttons items color)
+ (make-buttons' items -1 color))
+
+(define (buttons-n-buttons buttons)
+ (array-length (buttons-array buttons)))
+
+(define (buttons-get-current-selection buttons)
+ "Return the symbol of the button currently selected."
+ (let ((sel (buttons-selected buttons)))
+ (if (not (array-in-bounds? (buttons-array buttons) sel))
+ #f
+ (list-ref (array-ref (buttons-array buttons) sel) 2))))
+
+(define (draw-button b color)
+ (color-set! b color)
+ (box b 0 0)
+ (refresh b))
+
+(define (buttons-unselect-all buttons)
+ (let* ((arry (buttons-array buttons))
+ (current (buttons-selected buttons))
+ (old (if (array-in-bounds? arry current)
+ (cadr (array-ref arry current)) #f)))
+ (if old
+ (draw-button old 0))
+ (buttons-set-selected! buttons -1)))
+
+(define (buttons-fetch-by-key buttons c)
+ (let loop ((idx 0)
+ (key #f))
+ (if (or key (not (array-in-bounds? (buttons-array buttons) idx)))
+ key
+ (let* ((k (array-ref (buttons-array buttons) idx))
+ (kk (list-ref k 2)))
+ (loop (1+ idx) (if (eq? (car k) c) kk #f))))))
+
+
+(define (buttons-select buttons which)
+ (let ((arry (buttons-array buttons))
+ (current (buttons-selected buttons)))
+ (if (array-in-bounds? arry which)
+ (let ((new (cadr (array-ref arry which)))
+ (old (if (array-in-bounds? arry current)
+ (cadr (array-ref arry current)) #f)))
+ (if (not (eqv? old new))
+ (begin
+ (draw-button new (buttons-active-color buttons))
+ (if old
+ (draw-button old 0))))
+ (buttons-set-selected! buttons which)))))
+
+(define (buttons-select-prev buttons)
+ (let ((current (buttons-selected buttons)))
+ (buttons-select buttons (1- current))))
+
+(define* (buttons-select-next buttons #:key (wrap #f))
+ (let ((current (buttons-selected buttons)))
+ (if (and wrap
+ (>= current
+ (1- (array-length (buttons-array buttons)))))
+ (buttons-select buttons 0)
+ (buttons-select buttons (1+ current)))))
+
+(define (buttons-post buttons win)
+ (define n (length (buttons-items buttons)))
+
+ (buttons-set-array!
+ buttons
+ (list->array ;; FIXME: Populate the array directly instead of using temp
list
+ 1
+ (let loop ((bl (buttons-items buttons))
+ (i 0)
+ (alist '()))
+ (if (null? bl)
+ (reverse alist)
+ (let* ((but (car bl))
+ (key (car but))
+ (raw-label (gettext (cadr but)))
+ (use-underscore (caddr but))
+ ;; Convert the raw-label into a "complex rendered string" which
+ ;; has the mnemonic character highlighted
+ (label.mark
+ (let mk-label ((us #f)
+ (mark #f)
+ (output '())
+ (input (string->list raw-label)))
+ (if (null? input)
+ (cons (reverse output) mark)
+ (let ((c (car input)))
+ (mk-label (eq? c #\_)
+ (if mark mark (if us c #f))
+ (if (and (eq? c #\_) use-underscore)
+ output
+ (cons
+ (if us (bold c) (normal c))
+ output))
+ (cdr input))))))
+ (label (car label.mark))
+ (mark (cdr label.mark))
+ (width (+ (length label) 2))
+ (w (derwin win 3 width 0
+ (round (- (* (1+ i) (/ (getmaxx win) (1+ n)))
+ (/ width 2))))))
+ (box w 0 0)
+ (addchstr w label #:y 1 #:x 1)
+ (loop (cdr bl) (1+ i) (acons mark (list w key) alist))))))))
+
+
+
+(define (buttons-key-matches-symbol? nav ch symbol)
+ (if (char? ch)
+ (or (eq? (buttons-fetch-by-key nav (char-upcase ch)) symbol)
+ (and (or (eq? ch #\newline)
+ (eq? ch #\space))
+ (and=> (buttons-get-current-selection nav)
+ (lambda (x) (eq? x symbol)))))
+ #f))
+
+
+
diff --git a/gurses/form.scm b/gurses/form.scm
new file mode 100644
index 0000000..242f112
--- /dev/null
+++ b/gurses/form.scm
@@ -0,0 +1,238 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gurses form)
+ #:export (form-get-value)
+ #:export (form-set-value!)
+ #:export (make-form)
+ #:export (field-cursor-position)
+ #:export (form-post)
+ #:export (form-items)
+ #:export (form-window)
+ #:export (form-enter)
+ #:export (form-set-enabled!)
+ #:export (form-enabled?)
+ #:export (form-update-cursor)
+ #:export (form-set-current-field)
+
+ #:use-module (ncurses curses)
+ #:use-module (srfi srfi-9))
+
+(define-record-type <field>
+ (make-field symbol label size value cursor-position)
+ field?
+ (symbol field-symbol)
+ (label field-label)
+ (size field-size)
+ (value field-value field-set-value!)
+ (cursor-position field-cursor-position field-set-cursor-position!))
+
+(define-record-type <form>
+ (make-form' current-item enabled)
+ form?
+ (current-item form-current-item form-set-current-item!)
+ (enabled form-enabled? form-set-enabled!)
+ (items form-items form-set-items!)
+ (tabpos form-tabpos form-set-tabpos!) ;; X Position of the entries
+ (window form-window form-set-window!))
+
+(define (form-update-cursor form)
+ "Updates the cursor for FIELD in FORM"
+ (let ((field (array-ref (form-items form) (form-current-item form))))
+ (curs-set 1)
+ (move (form-window form) (form-current-item form)
+ (+ (field-cursor-position field)
+ (form-tabpos form)))))
+
+(define (redraw-field form field n)
+ "Redraw the FIELD in FORM"
+ (addchstr (form-window form)
+ (make-list (field-size field) (underline #\space))
+ #:y n
+ #:x (form-tabpos form))
+
+ (addstr (form-window form) (field-value field)
+ #:y n
+ #:x (form-tabpos form)))
+
+(define (form-set-value! form n str)
+ (cond
+ ((integer? n)
+ (let ((f (array-ref (form-items form) n)))
+ (field-set-value! f str)
+ (redraw-field form f n)))
+
+ ((symbol? n)
+ (let loop ((idx 0))
+ (if (array-in-bounds? (form-items form) idx)
+ (let ((ff (array-ref (form-items form) idx)))
+ (if (eq? n (field-symbol ff))
+ (begin
+ (field-set-value! ff str)
+ (redraw-field form ff idx))
+ (loop (1+ idx))))))))
+ (form-update-cursor form))
+
+
+
+(define (form-get-value form n)
+ "Retrieve a value from FORM. If N is an integer then the value is
+that of the Nth field. If N is a symbol, then it is the field with the
+label eq? to N"
+ (cond ((integer? n)
+ (field-value (array-ref (form-items form) n)))
+
+ ((symbol? n)
+ (let loop ((idx 0))
+ (if (array-in-bounds? (form-items form) idx)
+ (let ((ff (array-ref (form-items form) idx)))
+ (if (eq? n (field-symbol ff))
+ (field-value ff)
+ (loop (1+ idx)))))))))
+
+(define (make-form items)
+ (let ((form (make-form' 0 #t)))
+ (form-set-items! form
+ (list->array
+ 1 (map-in-order
+ (lambda (x) (make-field (car x) (cadr x) (caddr x) ""
0))
+ items)))
+ form))
+
+
+(define (form-enter form ch)
+ (define (redraw-current-field form field)
+ (redraw-field form field (form-current-item form)))
+
+ (define (cursor-move form field pos)
+ "Move the cursor to POS and redraw FIELD"
+ (field-set-cursor-position! field pos)
+ (form-update-cursor form))
+
+ (if (form-enabled? form)
+ (let* ((f (array-ref (form-items form) (form-current-item form)))
+ (left (substring (field-value f) 0 (field-cursor-position f)))
+ (centre (substring (field-value f) (field-cursor-position f)
+ (min (1+ (field-cursor-position f))
+ (string-length (field-value f)))))
+ (right (substring (field-value f)
+ (min (1+ (field-cursor-position f))
+ (string-length (field-value f)))
+ (string-length (field-value f)))))
+ (cond ((and (char? ch)
+ (not (char-set-contains? char-set:iso-control ch)))
+
+ (field-set-value! f (string-join
+ (list left right)
+ (make-string 1 ch)))
+
+ (field-set-cursor-position! f (1+ (field-cursor-position f)))
+ (addch (form-window form) (normal ch)))
+
+ ((eq? ch KEY_DC)
+ (field-set-value! f (string-append left right))
+ (redraw-current-field form f)
+ (form-update-cursor form))
+
+ ((eq? ch KEY_BACKSPACE)
+ (if (positive? (field-cursor-position f))
+ (begin
+ (field-set-value! f (string-append
+ (string-drop-right left 1) centre
+ right))
+ (field-set-cursor-position! f (1- (field-cursor-position
f)))
+ (redraw-current-field form f)
+ (form-update-cursor form))))
+
+ ((eq? ch #\vtab)
+ ;; Delete to end of line
+ (field-set-value! f (substring (field-value f)
+ 0 (field-cursor-position f)))
+ (redraw-current-field form f))
+
+ ((or (eq? ch KEY_DOWN)
+ (eq? ch #\so)
+ (eq? ch #\tab))
+ (form-next-field form)
+ (cursor-move form f 0))
+
+ ((or (eq? ch KEY_UP)
+ (eq? ch #\dle))
+ (form-previous-field form)
+ (cursor-move form f 0))
+
+ ((eq? ch KEY_RIGHT)
+ (if (< (field-cursor-position f) (string-length (field-value f)))
+ (cursor-move form f (1+ (field-cursor-position f)))))
+
+ ((eq? ch KEY_LEFT)
+ (if (positive? (field-cursor-position f))
+ (cursor-move form f (1- (field-cursor-position f)))))
+
+ ((eq? ch #\soh)
+ ;; Move to start of field
+ (cursor-move form f 0))
+
+ ((eq? ch #\enq)
+ ;; Move to end of field
+ (cursor-move form f (string-length (field-value f))))
+
+ )
+ (refresh (form-window form)))))
+
+(define (form-set-current-field form which)
+ (form-set-current-item! form which)
+ (move (form-window form) which (form-tabpos form)))
+
+
+(define (form-next-field form)
+ (if (< (form-current-item form) (1- (array-length (form-items form))))
+ (begin
+ (form-set-current-field form (1+ (form-current-item form)))
+ (refresh (form-window form)))))
+
+(define (form-previous-field form)
+ (if (> (form-current-item form) 0)
+ (begin
+ (form-set-current-field form (1- (form-current-item form)))
+ (refresh (form-window form)))))
+
+(define (form-post form win)
+ (form-set-window! form win)
+ (let ((xpos
+ ;; Print the labels and return the length of the longest
+ (let loop ((fields (form-items form))
+ (pos 0)
+ (maxlen 0))
+ (if (not (array-in-bounds? fields pos))
+ (+ maxlen 2)
+ (let ((f (array-ref fields pos)))
+ ;; Print the label
+ (addstr win (format #f "~a:" (field-label f)) #:y pos #:x 0)
+ (loop fields (1+ pos) (max maxlen
+ (string-length (field-label
f)))))))))
+
+ (form-set-tabpos! form xpos)
+
+ ;; Print the field entry areas
+ (let loop ((fields (form-items form))
+ (pos 0))
+ (if (array-in-bounds? fields pos)
+ (let ((f (array-ref fields pos)))
+ (addchstr win (make-list (field-size f) (underline #\space)) #:y
pos #:x xpos)
+ (loop fields (1+ pos)))))))
diff --git a/gurses/menu.scm b/gurses/menu.scm
new file mode 100644
index 0000000..8a8f74b
--- /dev/null
+++ b/gurses/menu.scm
@@ -0,0 +1,153 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 John Darrington <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gurses menu)
+
+ #:export (make-menu)
+ #:export (menu-post)
+ #:export (menu-refresh)
+ #:export (menu-down)
+ #:export (menu-up)
+ #:export (menu-redraw)
+ #:export (menu-current-item)
+ #:export (menu-active)
+ #:export (menu-items)
+ #:export (menu-window)
+ #:export (menu-set-active!)
+ #:export (menu-set-items!)
+ #:export (menu-set-active-attr!)
+ #:export (menu-set-active-color!)
+ #:export (menu-top-item)
+
+ #:export (menu-get-current-item)
+
+ #:export (std-menu-key-handler)
+
+ #:use-module (ncurses curses)
+ #:use-module (srfi srfi-9))
+
+(define-record-type <menu>
+ (make-menu' current-item items top-item active active-attr active-color disp)
+ menu?
+ (current-item menu-current-item menu-set-current-item!)
+ (items menu-items menu-set-items!)
+ (top-item menu-top-item menu-set-top-item!)
+ (disp menu-disp-proc)
+ (active menu-active menu-set-active!)
+ (active-attr menu-active-attr menu-set-active-attr!)
+ (active-color menu-active-color menu-set-active-color!)
+ (window menu-window menu-set-window!))
+
+(define* (make-menu items #:key (disp-proc (lambda (datum row)
+ (format #f "~a" datum))))
+ (make-menu' 0 items 0 #t A_STANDOUT 0 disp-proc))
+
+
+
+
+
+(define (menu-get-current-item menu)
+ (let ((idx (menu-current-item menu)))
+ (list-ref (menu-items menu) idx)))
+
+(define (menu-scroll-down menu step)
+ (let ((limit (- (length (menu-items menu))
+ (getmaxy (menu-window menu)))))
+ (if (< (menu-top-item menu) limit)
+ (begin
+ (menu-set-top-item! menu (min limit
+ (+ step (menu-top-item menu))))
+ (menu-redraw menu)))))
+
+(define (menu-scroll-up menu step)
+ (menu-set-top-item! menu (max 0 (- (menu-top-item menu) step)))
+ (menu-redraw menu))
+
+(define* (menu-down menu #:key (step 1))
+ "Move the selected item down by STEP items. Returns #f if on the last item."
+ (if (< (menu-current-item menu) (1- (length (menu-items menu))))
+ (begin
+ (if (>= (- (menu-current-item menu) (menu-top-item menu))
+ (- (getmaxy (menu-window menu)) step))
+ (menu-scroll-down menu step))
+ (menu-set-current-item! menu (min
+ (1- (length (menu-items menu)))
+ (+ step (menu-current-item menu))))
+ #t)
+ #f))
+
+(define* (menu-up menu #:key (step 1))
+ "Move the selected item up by STEP items."
+ (if (positive? (menu-current-item menu))
+ (begin
+ (if (< (- (menu-current-item menu) step) (menu-top-item menu))
+ (menu-scroll-up menu step))
+ (menu-set-current-item! menu (max 0 (- (menu-current-item menu)
step))))))
+
+(define (menu-redraw menu)
+ (define win (menu-window menu))
+ (clear win)
+ (let populate ((row (menu-top-item menu))
+ (data (list-tail (menu-items menu) (menu-top-item menu) )))
+ (if (and
+ (< row (+ (menu-top-item menu) (getmaxy win)))
+ (not (null? data)))
+ (begin
+ (addstr win
+ ((menu-disp-proc menu) (car data) row)
+ #:y (- row (menu-top-item menu)) #:x 0)
+ (populate (1+ row) (cdr data))))))
+
+(define (menu-post menu win)
+ (menu-set-window! menu win)
+ (menu-redraw menu))
+
+(define (menu-refresh menu)
+ (let ((win (menu-window menu))
+ (colour (if (menu-active menu) (menu-active-color menu) 0))
+ (attr (if (menu-active menu) (menu-active-attr menu) A_DIM)))
+
+ (bkgd win (color 0 (normal #\space)))
+ (chgat win -1 attr colour #:y
+ (- (menu-current-item menu) (menu-top-item menu))
+ #:x 0)
+ (refresh win)))
+
+
+
+
+
+(define (std-menu-key-handler menu ch)
+ (cond
+ ((eq? ch KEY_NPAGE)
+ (menu-active menu)
+ (menu-down menu #:step (getmaxy (menu-window menu))))
+
+ ((eq? ch KEY_PPAGE)
+ (menu-active menu)
+ (menu-up menu #:step (getmaxy (menu-window menu))))
+
+ ((or (eq? ch KEY_DOWN)
+ (eq? ch #\so))
+ (if (menu-active menu)
+ (menu-down menu)))
+
+ ((or (eq? ch KEY_UP)
+ (eq? ch #\dle))
+ (if (menu-active menu)
+ (menu-up menu)))))