rewrite guix installer

1 files changed, 763 insertions, 0 deletions

diff --git a/scripts/install-system b/scripts/install-system
new file mode 100755
index 0000000..bcfd003
--- /dev/null
+++ b/scripts/install-system
@@ -0,0 +1,763 @@
+#!/run/current-system/profile/bin/guile -s
+!#
+;;; file: install-system
+;;; author: Freya Murphy <freya@freyacat.org>
+;;; desc: Installs Guix onto your system
+
+;;
+;; root check
+;;
+
+;; we need to be root to access block devices and mounts
+(if (not (string=? (getenv "USER") "root"))
+  (begin
+    (display "Requesting root user access...\n")
+    (system* "sudo" "-E" (current-filename))
+    ;; dont continue as orig user... exit
+    (exit 0)))
+
+;;
+;; environment
+;;
+
+(setenv "TERM" "xterm") ; this should fix more problems then it might cause
+                        ; ...always can remove it if not the case
+
+(setenv "PATH" (string-append (getenv "PATH") ;; needed for guix-retry
+                              ":"
+                              (dirname (current-filename))))
+
+(setenv "GUILE_HISTORY"
+        (string-append (getenv "HOME")
+                       "/.guix_installer_history"))
+
+;;
+;; import modules
+;;
+
+(use-modules (guix records)
+             (os process)
+             (ice-9 popen)
+             (ice-9 textual-ports)
+             (ice-9 readline)
+             (ice-9 match)
+             (ice-9 regex)
+             (ice-9 format)
+             (srfi srfi-1) ; fold, last
+             (srfi srfi-9) ; records
+             (srfi srfi-34)) ; exceptions
+
+(activate-readline)
+
+;;
+;; config
+;;
+
+(define %dotfiles-dir
+  (dirname (dirname (current-filename))))
+
+(define %user
+  "freya")
+
+(define %block-device-min
+  ;; smallest size in GiB a block device is allowed to be
+  8)
+
+(define %bypass-block-dev-check
+  ;; bypass checking if a file is a block device
+  (getenv "DEBUG"))
+
+;;
+;; option
+;;
+
+(define (option? option)
+  (and (list? option)
+       (not (null? option))
+       (eq? 'option (car option))))
+
+(define (some? option)
+  (and (option? option)
+       (= (length option) 2)))
+
+(define (none)
+  `(option))
+
+(define (some value)
+  `(option ,value))
+
+(define (match-option option onSome onNone)
+  (if (option? option)
+    (if (some? option)
+      (onSome (cadr option))
+      (onNone))
+    (error "Expected option:" option)))
+
+(define (unwrap-option option)
+  (if (some? option)
+    (cadr option)
+    (error "Expected some:" option)))
+
+(define (wrap-option value check?)
+  (if (check? value)
+    (some value)
+    (none)))
+
+;;
+;; shell functions
+;;
+
+(define* (invoke command #:key (stdin #f))
+  ;; invokes a shell command with `args`
+  ;; and returns stdout as a string
+  (let* (;; Spawn process
+         (command* (map (lambda (value)
+                          (cond ((string? value) value)
+                                ((number? value) (number->string value))
+                                ((symbol? value) (symbol->string value))
+                                (#t (throw 'invalid-command-arg value))))
+                        (filter
+                          (lambda (value)
+                            (not (unspecified? value)))
+                          command)))
+         (proc (apply run-with-pipe (cons* "r+" command*)))
+         (pid  (car proc))
+         (in   (cadr proc))
+         (out  (cddr proc)))
+    ;; write stdin
+    (when stdin
+      (put-string out stdin)
+      (force-output out))
+    ;; close stdin
+    (close-port out)
+    ;; read stdout
+    (let* ((output (get-string-all in)))
+      ;; close stdout
+      (close-port in)
+      ;; return
+      output)))
+
+(define* (invoke* prog . args)
+  (invoke (cons* prog args)))
+
+(define (read-file path)
+  (call-with-input-file path get-string-all))
+
+(define (write-file path contents)
+  (call-with-output-file path (lambda (port)
+                                (put-string port contents))))
+
+(define (string-trim-full content)
+  (fold (lambda (char content)
+          (string-trim-both content char))
+        content
+        (list #\tab
+              #\space
+              #\newline)))
+
+;;
+;; exception functions
+;;
+
+(define (catch-or thunk default)
+  ;; runs the provided `thunk` callback
+  ;; and returns `default` on any exception
+  (with-exception-handler
+    (lambda _ default)
+    thunk
+    #:unwind? #t))
+
+(define-syntax-rule (catch-or* default . exprs)
+  ;; macro to not have to type lambda _
+  (catch-or (lambda _ . exprs) default))
+
+;;
+;; prompt functions
+;;
+
+(define* (prompt* #:key
+                  (heading #f)   ; header message
+                  (prompt ": ")  ; prompt
+                  (err #f)       ; error message to print on invalid input
+                  (fn some)      ; transition function
+                  (confirm? #f)  ; confirm input before returning value
+                  (clear? #t)    ; clear terminal before prompt
+                  (passwd? #f)   ; if we are prompting for a password
+                  (helper #f))   ; readline autocompletion helper
+  ;; prompts for user input
+  ;; - returns result of `fn` if some
+  ;; - retries on none
+  (let inner ((err? #f))
+    (let* (; reset function - sets up prompt terminal view
+           (reset
+             (lambda (err?)
+               (if clear? (system "clear"))
+               (if heading (display heading))
+               (if err? (format (current-error-port) "\n~a\n\n" err))))
+           ; confirm function - confirms if input is what user wants
+           (confirm
+             (lambda (content)
+               (if confirm?
+                 (prompt*
+                    #:prompt (string-append "confirm (" content ") y/N: ")
+                    #:fn (lambda (str)
+                           (some (string=? str "y")))
+                    #:clear? #f)
+                 #t)))
+           ; helper* - readline helper
+           (helper*
+             (cond ((list? helper)
+                    (make-completion-function helper))
+                   ((procedure? helper)
+                    helper)
+                   (#t
+                    (lambda (text state) #f))))
+           ; readline* function
+           (readline*
+             (lambda (prompt)
+               (if passwd?
+                 ; dont use readline if prompting for password
+                 (getpass prompt)
+                 ; use readline
+                 (with-readline-completion-function
+                   helper*
+                   (lambda () (readline prompt)))))))
+      ; setup terminal view
+      (reset err?)
+      ; get input
+      (let* ((content (readline* prompt))
+             (content? (string? content))
+             (content* (string-trim-full (if content? content ""))))
+        ;; exit script on EOF
+        (if (eof-object? content)
+          (exit 0))
+        ;; update readline history
+        (if (and content?
+                 (not passwd?))
+          (add-history content))
+        ;; handle result
+        (match-option (fn content*)
+          (lambda (value) ; onSome
+            (if (confirm content*)
+              value
+              (inner #f)))
+          (lambda _ ; onNone
+            (inner #t)))))))
+
+(define* (prompt-passwd #:key
+                      (heading #f)    ; header message
+                      (fn some)       ; transition function
+                      (confirm? #t)   ; should the user confirm the password
+                      (clear? #t))    ; clear terminal before prompt
+  (prompt*
+    #:heading heading
+    #:prompt "passwd: "
+    #:err "Passwords did not match or do not meet requirements"
+    #:fn (lambda (passwd)
+           (if confirm?
+             (let ((confirm-passwd (getpass "confirm: ")))
+               (if (not (string=? passwd confirm-passwd))
+                 (none)
+                 (fn passwd)))
+             (fn passwd)))
+    #:clear? clear?
+    #:passwd? #t))
+
+(define* (prompt-bool #:key
+                      (heading #f)      ; header message
+                      (prompt "y/n: ")  ; prompt
+                      (fn some)         ; transition function
+                      (confirm? #f)     ; confirm input before returning value
+                      (clear? #t)       ; clear terminal before prompt
+                      (passwd? #f))     ; if we are prompting for a password
+  (prompt*
+    #:heading heading
+    #:prompt prompt
+    #:err "Must type 'y' for yes, 'n' for no"
+    #:fn (lambda (str)
+           (match str
+             ("y" (fn #t))
+             ("n" (fn #f))
+             (_ (none))))
+    #:confirm? confirm?
+    #:clear? clear?
+    #:passwd? passwd?
+    #:helper (list "y" "n")))
+
+(define* (prompt-number #:key
+                        (heading #f)   ; header message
+                        (prompt "#: ") ; prompt
+                        (fn some)      ; transition function
+                        (confirm? #f)  ; confirm input before returning value
+                        (clear? #t)    ; clear terminal before prompt
+                        (passwd? #f))  ; if we are prompting for a password
+  (prompt*
+    #:heading heading
+    #:prompt prompt
+    #:err "Must type a valid integer"
+    #:fn (lambda (str)
+           (let ((num (string->number str)))
+             (if (integer? num)
+               (fn num)
+               (none))))
+    #:confirm? confirm?
+    #:clear? clear?
+    #:passwd? passwd?))
+
+;;
+;; storage functions
+;;
+
+(define (is-valid-block-device? path)
+  ;; #t if the path is a valid block device, otherwise #f
+  (catch-or* #f
+    (let* ((info (stat path))
+           (type (stat:type info)))
+      (cond ((and %bypass-block-dev-check
+                  (eq? type 'regular)) #t)
+            ((eq? type 'block-special) #t)
+            (#t #f)))))
+
+(define (block-device-size path)
+  ;; returns size of block device in GiB
+  (catch-or* 0
+    (let* ((info (stat path))
+           (result (invoke* "blockdev" "--getsize64" path))
+           (result* (string-trim-full result))
+           (bytes (or (string->number result*) 0))
+           (bytes* (if (and %bypass-block-dev-check
+                            (eq? (stat:type info) 'regular))
+                     (stat:size info)
+                     bytes)))
+      (round (/ bytes* (* 1024 1024 1024))))))
+
+(define (block-device-uuid path)
+  ;; returns uuid of block device
+  (string-trim-full
+    (invoke* "blkid" "-s" "UUID" "-o" "value" path)))
+
+;;
+;; config
+;;
+
+(define-record-type* <installer-config>
+  installer-config make-installer-config
+  installer-config?
+  (dev          config-dev)
+  (filesystem   config-filesystem)
+  (crypt?       config-crypt?)
+  (crypt-passwd config-crypt-passwd)
+  (swap?        config-swap?)
+  (swap-size    config-swap-size)
+  (hostname     config-hostname))
+
+;;
+;; partition
+;;
+
+(define-record-type* <partition>
+  partition make-partition
+  partition?
+  (dev        partition-dev)    ; block device (string)
+  (label      partition-label)  ; symbol
+  (index      partition-index)  ; integer
+  (start      partition-start)  ; n MiB
+  (end        partition-end)    ; n MiB
+  (type       partition-type)   ; symbol
+  (boot?      partition-boot?
+              (default #f))
+  (swap?      partition-swap?
+              (default #f)))
+
+(define (partition-name part)
+  ;; TODO: sata
+  (string-append (partition-dev part) "p" (number->string (partition-index part))))
+
+(define (partition-crypt? config part)
+  (and (config-crypt? config)
+       (eq? 'root (partition-label part))))
+
+(define (partition-crypt-label part)
+  (string-append "installer"
+                 (symbol->string (partition-label part))))
+
+(define (find-partition partitions label)
+  (cond ((null? partitions) #f)
+        ((eq? label (partition-label (car partitions))) (car partitions))
+        (#t (find-partition (cdr partitions) label))))
+
+(define (config->partitions config)
+  (let* (; read needed config values
+         (dev (config-dev config))
+         (filesystem (config-filesystem config))
+         (swap? (config-swap? config))
+         (swap-size (config-swap-size config))
+         ; boot
+         (boot (partition
+                 (dev   dev)
+                 (label 'boot)
+                 (index 1)
+                 (start 1)
+                 (end   1024)
+                 (type  'fat32)
+                 (boot? #t)))
+         ; swap
+         (swap (partition
+                 (dev   dev)
+                 (label 'swap)
+                 (index 2)
+                 (start (partition-end boot))
+                 (end   (+ (partition-end boot) (* swap-size 1024)))
+                 (type  'linux-swap)
+                 (swap? #t)))
+         ; root
+         (root (partition
+                 (dev   dev)
+                 (label 'root)
+                 (index (+ (partition-index swap) (if swap? 1 0)))
+                 (start (partition-end swap))
+                 (end   #f)
+                 (type  filesystem))))
+    (if swap?
+      (list boot swap root)
+      (list boot root))))
+
+;;
+;; step 0. get all user input
+;;
+
+(define (prompt-block-device)
+  (prompt*
+    #:heading "Which block device to install GUIX on?\n"
+    #:prompt "Disk: "
+    #:err "Invalid Block Device"
+    #:fn (lambda (dev)
+           (cond ((not (is-valid-block-device? dev)) (none))
+                 ((not (>= (block-device-size dev) %block-device-min)) (none))
+                 (#t (some dev))))
+    #:confirm? #t
+    #:helper filename-completion-function))
+
+(define (prompt-filesystem)
+  (let ((supported (list 'fat32 'btrfs 'ext4)))
+    (prompt*
+      #:heading "What filesystem do you want to use?\n"
+      #:prompt "Filesystem: "
+      #:err "Invalid or unsupported filesystem"
+      #:fn (lambda (name)
+             (wrap-option (string->symbol name)
+                          (lambda (type)
+                            (member type supported))))
+      #:helper (map symbol->string supported))))
+
+(define (prompt-crypt?)
+  (prompt-bool
+    #:heading "Do you want an encrypted system?\n"))
+
+(define (prompt-crypt-passwd)
+  (prompt-passwd
+    #:heading "Enter crypt device password\n"
+    #:fn (lambda (passwd)
+           (wrap-option passwd (lambda (passwd)
+                                 ;; dont allow empty password
+                                 (>= (string-length passwd) 1))))))
+
+(define (prompt-crypt-reconfirm-passwd)
+  (prompt-passwd
+    #:heading "\nReconfirm crypt password\n"
+    #:clear? #f
+    #:confirm? #f))
+
+(define (prompt-swap?)
+  (prompt-bool
+    #:heading "Do you want a swap partition?\n"))
+
+(define (prompt-swap-size dev-size)
+  (let* ((max* (round (/ (- dev-size 1) 2))) ; (GiB - 1) / 2
+         (heading (format #f "How large should the swap parition be? [1-~a] GiB\n" max*)))
+    (prompt-number
+      #:heading heading
+      #:fn (lambda (num)
+             (cond ((> num max*) (none))
+                   ((< num 1) (none))
+                   (#t (some num)))))))
+
+(define (prompt-hostname)
+  (prompt*
+    #:heading "What will the hostname of this device be?\n"
+    #:prompt "Hostname: "
+    #:err "Invalid Hostname"
+    #:fn (lambda (hostname)
+           (wrap-option hostname (lambda (hostname)
+                                   (string-match "[a-zA-Z]{1,63}" hostname))))
+    #:confirm? #t))
+
+(define (prompt-installer-config)
+  (let inner ()
+    (let* (; get all config values
+           (dev (prompt-block-device))
+           (filesystem (prompt-filesystem))
+           (crypt? (prompt-crypt?))
+           (crypt-passwd (if crypt?
+                           (prompt-crypt-passwd) #f))
+           (swap? (prompt-swap?))
+           (swap-size (if swap?
+                        (prompt-swap-size (block-device-size dev)) 0))
+           (hostname (prompt-hostname))
+           ; confirm result
+           (boolean->string (lambda (bool)
+                              (if bool "true" "false")))
+           (heading
+             (string-append
+               (format #f "Disk: ~a\n" dev)
+               (format #f "Filesystem: ~a\n" filesystem)
+               (format #f "Crypt: ~a\n" (boolean->string crypt?))
+               (if crypt?
+                 (format #f "Crypt passwd: ~a\n" "********") "")
+               (format #f "Swap: ~a\n" (boolean->string swap?))
+               (if swap?
+                 (format #f "Swap Size: ~d (GiB)\n" swap-size) "")
+               (format #f "Hostname: ~a\n" hostname)
+               "\nAre these options correct?\n"))
+           (confirm?
+                   ;; make sure this is what the user wants
+             (cond ((not (prompt-bool #:heading heading)) #f)
+                   ;; make sure the user acutally knows the crypt password
+                   ((not (or (not crypt?)
+                             (string=? crypt-passwd
+                                       (prompt-crypt-reconfirm-passwd)))) #f)
+                   ;; approved
+                   (#t #t))))
+      (if confirm?
+        ; config approved
+        (installer-config
+          (dev dev)
+          (filesystem filesystem)
+          (crypt? crypt?)
+          (crypt-passwd crypt-passwd)
+          (swap? swap?)
+          (swap-size swap-size)
+          (hostname hostname))
+        ; re-prompt values
+        (inner)))))
+
+;;
+;; step 1. partition
+;;
+
+(define* (parted dev . args)
+  (invoke (cons* "parted"
+                 dev
+                 "--script"
+                 args)))
+
+(define (create-partition part)
+  (let* (;; partition info
+         (dev   (partition-dev part))
+         (label (partition-label part))
+         (index (partition-index part))
+         (type (partition-type part))
+         ;; start and end
+         (start (partition-start part))
+         (start* (string-append (number->string start)
+                                "MiB"))
+         (end (partition-end part))
+         (end* (if end
+                 (string-append (number->string end)
+                                "MiB")
+                 "100%")))
+    ;; create partition
+    (parted dev
+            "mkpart" label type start* end*)
+    ;; when boot?
+    (when (partition-boot? part)
+      (parted dev
+              "set" index "boot" "on"))
+    ;; when swap?
+    (when (partition-swap? part)
+      (parted dev
+              "set" index "swap" "on"))))
+
+(define (create-partitions partitions)
+  (let ((dev (partition-dev (car partitions))))
+    (parted dev "mklabel" "gpt"))
+  (for-each create-partition
+            partitions))
+
+;;
+;; step 2. format
+;;
+
+(define (format-luks config part)
+  (let* (;read needed config values
+         (name (partition-name part))
+         (label (partition-crypt-label part))
+         (crypt-passwd (config-crypt-passwd config)))
+    (format #t "formatting ~a with luks\n" name)
+    ;; format root partition with luksFormat
+    (invoke `("cryptsetup" "-q" "luksFormat" ,name)
+            #:stdin (string-append crypt-passwd "\n"
+                                   crypt-passwd "\n"))
+    ;; open luks
+    (invoke `("cryptsetup" "open" ,name ,label)
+            #:stdin (string-append crypt-passwd "\n"))
+    ;; format luks mapper
+    (format-path (partition-type part)
+                 (string-append "/dev/mapper/" label))))
+
+(define (format-path type path)
+  (format #t "formatting ~a with ~a\n" path type)
+  (match type
+    ('fat32 (invoke* "mkfs.vfat" "-F" "32" path))
+    ('btrfs (invoke* "mkfs.btrfs" "--force" path))
+    ('ext4 (invoke* "mkfs.ext4" path))
+    ('linux-swap (invoke* "mkswap" path))
+    (_ (throw 'unknown-fs (string-append "Unhandeled partition type: "
+                                           (symbol->string type))))))
+
+(define (format-partition config part)
+  (let* (;; partition info
+         (label (partition-label part))
+         (name (partition-name part))
+         (type (partition-type part)))
+    (if (partition-crypt? config part)
+      (format-luks config part)
+      (format-path type name))))
+
+(define (format-partitions config partitions)
+  (for-each (lambda (part)
+              (format-partition config part))
+            partitions))
+
+;;
+;; step 3. mount
+;;
+
+(define (mount-path from to)
+  (format #t "mounting ~a to ~a\n" from to)
+  (invoke* "mkdir" "-p" to)
+  (invoke* "mount" from to))
+
+(define (mount-swap from)
+  (format #t "swapping ~a\n" from)
+  (invoke* "swapon" from))
+
+(define (mount-partitions config partitions)
+  (let* ((root (find-partition partitions 'root))
+         (swap (find-partition partitions 'swap))
+         (boot (find-partition partitions 'boot)))
+    ;; root
+    (let ((path (if (partition-crypt? config root)
+                  (string-append "/dev/mapper/" (partition-crypt-label root))
+                  (partition-name root))))
+      (mount-path path "/mnt"))
+    ;; swap
+    (when swap
+      (mount-swap (partition-name swap)))
+    ;; boot
+    (mount-path (partition-name boot) "/mnt/boot")))
+
+;;
+;; step 4. create specification
+;;
+
+(define %base-scm-path
+  (string-append %dotfiles-dir
+                 "/files/base.scm.m4"))
+
+(define (get-specification config partitions)
+  (let* (;; config values
+         (host (config-hostname config))
+         (fsys (symbol->string (config-filesystem config)))
+         (swap? (config-swap? config))
+         (crypt? (config-crypt? config))
+         ;; uuid helper
+         (getuuid (lambda (label)
+                    (let ((part (find-partition partitions label)))
+                      (if part
+                        (block-device-uuid
+                          (partition-name part))
+                        #f))))
+         ;; uuids
+         (root (getuuid 'root))
+         (swap (getuuid 'swap))
+         (boot (getuuid 'boot)))
+    (invoke* "m4"
+             ; Required
+             (string-append "--define=HOST=" host)
+             (string-append "--define=ROOT=" root)
+             (string-append "--define=BOOT=" boot)
+             (string-append "--define=FSYS=" fsys)
+             ; Optional
+             (if crypt?
+               "--define=CRYPT")
+             (if swap?
+               (string-append "--define=SWAP=" swap))
+             ; Pass in file
+             %base-scm-path)))
+
+;;
+;; step 5. install system
+;;
+
+(define %channels-path
+  (string-append %dotfiles-dir
+                 "/channels.scm"))
+
+(define %modules-path
+  (string-append %dotfiles-dir
+                 "/modules"))
+
+(define %substitute-urls
+  (list "https://substitutes.nonguix.org"
+        "https://substitutes.freya.cat"
+        "https://bordeaux.guix.gnu.org"
+        "https://ci.guix.gnu.org"))
+
+(define (install-system config scm)
+  (let* ((hostname (config-hostname config))
+         (system-scm (string-append %dotfiles-dir
+                                    "/systems/"
+                                    hostname
+                                    ".scm")))
+    ;; write scm to system-scm
+    (write-file system-scm scm)
+    ;; start cow store
+    (system* "herd" "start" "cow-store" "/mnt")
+    ;; approve signing keys
+    (for-each (lambda (key)
+                (invoke '("guix" "archive" "--authorize")
+                        #:stdin (read-file key)))
+              (map (lambda (name)
+                     (string-append %dotfiles-dir
+                                    "/files/keys/"
+                                    name))
+                   (list "nonguix.pub"
+                         "sakura.pub")))
+    ;; install base system
+    (system* "guix-retry" ; fix TLS 'write_to_session_record_port' failures
+             "guix" "time-machine" "-C" %channels-path "--"
+             "system" "-L" %modules-path
+             (string-append "--substitute-urls='"
+                            (string-join %substitute-urls " ")
+                            "'")
+             "init" system-scm "/mnt")))
+
+;;
+;; entry
+;;
+
+(let* (; step 0 - prompt
+       (config (prompt-installer-config))
+       (partitions (config->partitions config))
+       ; step 1 - partition
+       (_ (create-partitions partitions))
+       ; step 2 - format
+       (_ (format-partitions config partitions))
+       ; step 3 - mount
+       (_ (mount-partitions config partitions))
+       ;; step 4 - create specification
+       (scm (get-specification config partitions))
+       ; step 5 - install
+       (_ (install-system config scm)))
+  #t)