diff options
| -rw-r--r-- | README.md | 8 | ||||
| -rw-r--r-- | files/base.scm.m4 | 52 | ||||
| -rwxr-xr-x | installer/guix-configure | 49 | ||||
| -rwxr-xr-x | installer/guix-crypt | 70 | ||||
| -rwxr-xr-x | installer/guix-install | 25 | ||||
| -rwxr-xr-x | installer/guix-log | 23 | ||||
| -rwxr-xr-x | installer/guix-partition | 66 | ||||
| -rwxr-xr-x | installer/guix-password | 51 | ||||
| -rwxr-xr-x | installer/guix-setup | 43 | ||||
| -rwxr-xr-x | installer/guix-setup-user | 21 | ||||
| -rw-r--r-- | installer/system.scm | 23 | ||||
| -rw-r--r-- | modules/freya/system.scm | 1 | ||||
| -rwxr-xr-x | scripts/install-system | 763 |
13 files changed, 820 insertions, 375 deletions
@@ -4,8 +4,8 @@ ### Instructions -- Create USB with Guix installation image -- Boot and immediately drop into shell, skip graphical installer -- Install git `guix shell git`, and pull this repo `git clone https://g.freya.cat/freya/dotfiles-guix.git` -- Enter the `installer` directory and run `./guix-setup` +- Build Guix ISO Image with `systems/installer.scm` +- Boot into it and get root shell +- Pull this repo `git clone https://g.freya.cat/freya/dotfiles-guix.git` +- Execute `scripts/install-system` - Its Guixing time diff --git a/files/base.scm.m4 b/files/base.scm.m4 new file mode 100644 index 0000000..397d274 --- /dev/null +++ b/files/base.scm.m4 @@ -0,0 +1,52 @@ +divert(-1) +changecom(`//') +// +// This is the base system file for the installer. +// +// Macro definitions: +// +// Required: +// HOST: The systems hostname +// BOOT: Boot partition uuid +// ROOT: Root partition uuid +// FSYS: Root filesystem +// +// Optional: +// SWAP: Swap partition uuid +// CRYPT: If using luks (boolean) +// +divert(0)dnl +(use-modules (freya system) + (gnu)) + +(operating-system + (inherit %desktop-freya-operating-system) + (host-name "HOST") +ifdef(`CRYPT', `dnl + (mapped-devices (list (mapped-device + (source (uuid + "ROOT")) + (target "root") + (type luks-device-mapping)))) +')dnl +ifdef(`SWAP', `dnl + (swap-devices (list (swap-space + (target (uuid + "SWAP"))))) +')dnl + (file-systems (cons* (file-system + (mount-point "/") +ifdef(`CRYPT', `dnl + (device "/dev/mapper/root") +', `dnl + (device (uuid "ROOT")) +')dnl + (type "FSYS") + (dependencies mapped-devices)) + (file-system + (mount-point "/boot/efi") + (device (uuid "BOOT" + 'fat32)) + (type "vfat")) + (operating-system-file-systems + %desktop-freya-operating-system)))) diff --git a/installer/guix-configure b/installer/guix-configure deleted file mode 100755 index b96c3c1..0000000 --- a/installer/guix-configure +++ /dev/null @@ -1,49 +0,0 @@ -#!/run/current-system/profile/bin/bash - -source ./guix-log -source ./guix-env - -HOSTNAME="" -CRYPT_UUID="" -EFI_UUID="" - -get_uuid() { - blkid -s UUID -o value $1 -} - -CRYPT_UUID=$(get_uuid $CRYPT_PARTITION) -EFI_UUID=$(get_uuid $EFI_PARTITION) - -get_hostname() { - CONFIRM="" - read -p "Enter system hostname: " HOSTNAME - if [ ! -z "$HOSTNAME" -a "$HOSTNAME" != " " ]; then - (confirm "$HOSTNAME"); - if [ "$?" -ne 0 ]; then - get_hostname - fi - else - ERROR "'$HOSTNAME' is not a valid hostname" - fi -} - -EVENT "Getting hostname" - -get_hostname - -EVENT "Hostname set to '$HOSTNAME'" - -EVENT "Generating system config file" - -cp system.scm "$HOSTNAME.scm" -sed -i "s/SED_CRYPT_UUID/$CRYPT_UUID/" ./$HOSTNAME.scm -sed -i "s/SED_EFI_UUID/$EFI_UUID/" ./$HOSTNAME.scm -sed -i "s/SED_HOSTNAME/$HOSTNAME/" ./$HOSTNAME.scm - -mv "$HOSTNAME.scm" .. - -EVENT "Successfully configured $HOSTNAME.scm" - -echo "HOSTNAME=\"$HOSTNAME\"" >> ./guix-env -echo "CRYPT_UUID=\"$CRYPT_UUID\"" >> ./guix-env -echo "EFI_UUID=\"$EFI_UUID\"" >> ./guix-env diff --git a/installer/guix-crypt b/installer/guix-crypt deleted file mode 100755 index b25bc99..0000000 --- a/installer/guix-crypt +++ /dev/null @@ -1,70 +0,0 @@ -#!/run/current-system/profile/bin/bash - -source ./guix-log -source ./guix-env - -CRYPT_PARTITION="" -EFI_PARTITION="" -PASSWORD="" -PASSWORD_CONFIRM="" - -EVENT "Setting up disk encryption with luks" - -if [[ $DISK == "/dev/sd"* ]]; then - CRYPT_PARTITION="$DISK""2" - EFI_PARTITION="$DISK""1" -elif [[ $DISK == "/dev/vd"* ]]; then - CRYPT_PARTITION="$DISK""2" - EFI_PARTITION="$DISK""1" -elif [[ $DISK == "/dev/nvme"* ]]; then - CRYPT_PARTITION="$DISK""p2" - EFI_PARTITION="$DISK""p1" -else - ERROR "Unsupported drive type, must be sata or nvme!" - exit 1 -fi - -get_password() { - read -s -p "LUKS password: " PASSWORD - printf "\n" - read -s -p "Confirm password: " PASSWORD_CONFIRM - printf "\n" - if [ "$PASSWORD" == "$PASSWORD_CONFIRM" ]; then - return - else - ERROR "Passwords do not match" - get_password - fi -} - -get_password - -EVENT "Setting up luks" - -cryptsetup luksFormat --type luks1 "$CRYPT_PARTITION" <<EOF -$PASSWORD -$PASSWORD_CONFIRM -EOF - -EVENT "Opening root" - -cryptsetup open "$CRYPT_PARTITION" root <<EOF -$PASSWORD -EOF - -EVENT "Setting up root btrfs" - -mkfs.btrfs "/dev/mapper/root" - -EVENT "Mounting root" - -mount /dev/mapper/root /mnt - -EVENT "Setting up EFI vfat" - -mkfs.vfat "-F32" "$EFI_PARTITION" - -EVENT "Successfully setup efi vfat and luks" - -echo "CRYPT_PARTITION=\"$CRYPT_PARTITION\"" >> ./guix-env -echo "EFI_PARTITION=\"$EFI_PARTITION\"" >> ./guix-env diff --git a/installer/guix-install b/installer/guix-install deleted file mode 100755 index 3b3cb14..0000000 --- a/installer/guix-install +++ /dev/null @@ -1,25 +0,0 @@ -#!/run/current-system/profile/bin/bash - -source ./guix-env -source ./guix-log - -EVENT "Mounting /gnu/store to destination disk..." -herd start cow-store /mnt - -EVENT "Installing non-guix signing keys for substitutes..." -curl -o /tmp/sign-key.pub https://substitutes.nonguix.org/signing-key.pub -guix archive --authorize < /tmp/sign-key.pub - -EVENT "Installing GNU Guix" -guix time-machine -C ../channels.scm -- system -L ../modules --substitute-urls='https://substitutes.nonguix.org https://bordeaux.guix.gnu.org https://ci.guix.gnu.org' init ../$HOSTNAME.scm /mnt - -EVENT "Installing User Environment" - -USER=freya -guix shell git -- git clone https://g.freya.cat/freya/dotfiles /mnt/home/$USER/.config/guix -cp ../$HOSTNAME.scm /mnt/home/$USER/.config/guix/$HOSTNAME.scm -cp ./guix-setup-user /mnt/home/$USER/.zprofile - -chown 1000:1000 -R /mnt/home/$USER - -EVENT "Successflly installed Guix root and user" diff --git a/installer/guix-log b/installer/guix-log deleted file mode 100755 index 0d26853..0000000 --- a/installer/guix-log +++ /dev/null @@ -1,23 +0,0 @@ -#!/run/current-system/profile/bin/bash - -ERROR() { - >&2 printf "\x1b[91mError: \x1b[0m\x1b[98m$1\n" -} - -EVENT() { - printf "\x1b[95m>>> \x1b[0m\x1b[98m$1\n" -} - -CONFIRM="" - -confirm() { - if [ "$CONFIRM" == "y" ]; then - exit 0 - fi - read -p "Are you sure: ($1)? [y/N] " CONFIRM - if [ "$CONFIRM" == "y" ]; then - exit 0 - else - exit 1 - fi -} diff --git a/installer/guix-partition b/installer/guix-partition deleted file mode 100755 index 7acaefd..0000000 --- a/installer/guix-partition +++ /dev/null @@ -1,66 +0,0 @@ -#!/run/current-system/profile/bin/bash - -set -o emacs; - -DISK="" - -source ./guix-log -source ./guix-env - -EVENT "Partitioning disks" - -check_disk() { - lsblk $1 &> /dev/null || exit 1 - FS=$(df $1 | tail -n 1 | awk '{print $1}') - if [ "$FS" == "none" ]; then - exit 0 - else - exit 1 - fi -} - -get_disk() { - CONFIRM="" - read -ep "Enter disk (e.g. /dev/sda): " DISK - if [ ! -b "$DISK" ]; then - ERROR "$DISK: file does not exist" - get_disk - return - fi - (check_disk "$DISK"); - if [ "$?" -ne 0 ]; then - ERROR "$DISK: not a valid disk" - get_disk - return - fi - (confirm "$DISK"); - if [ "$?" -ne 0 ]; then - get_disk - fi -} - -get_disk - -EVENT "Partitioning disks with fdisk..." - -fdisk "$DISK" <<EOF -g -n - - -+1GiB -t -EFI System -n - - - -t -2 -Linux Filesystem -w -EOF - -echo "DISK=\"$DISK\"" >> ./guix-env - -EVENT "Disks have been successfully partitioned on $DISK" diff --git a/installer/guix-password b/installer/guix-password deleted file mode 100755 index a39c566..0000000 --- a/installer/guix-password +++ /dev/null @@ -1,51 +0,0 @@ -#!/run/current-system/profile/bin/bash - -USER_PASSWORD="" -ROOT_PASSWORD="" - -source ./guix-env -source ./guix-log - -get_root_password() { - read -s -p "Root password: " PASSWORD - printf "\n" - read -s -p "Confirm password: " PASSWORD_CONFIRM - printf "\n" - if [ "$PASSWORD" == "$PASSWORD_CONFIRM" ]; then - ROOT_PASSWORD=$PASSWORD - return - else - ERROR "Passwords do not match" - get_root_password - fi -} - -get_user_password() { - read -s -p "User password: " PASSWORD - printf "\n" - read -s -p "Confirm password: " PASSWORD_CONFIRM - printf "\n" - if [ "$PASSWORD" == "$PASSWORD_CONFIRM" ]; then - USER_PASSWORD=$PASSWORD - return - else - ERROR "Passwords do not match" - get_user_password - fi -} - -EVENT "Setup /etc/shadow for root and user" - -get_root_password -get_user_password - -cat << EOF | chroot /mnt -passwd -$ROOT_PASSWORD -$ROOT_PASSWORD -passwd freya -$USER_PASSWORD -$USER_PASSWORD -EOF - -EVENT "Successfully set passwords" diff --git a/installer/guix-setup b/installer/guix-setup deleted file mode 100755 index 7fb027b..0000000 --- a/installer/guix-setup +++ /dev/null @@ -1,43 +0,0 @@ -#!/run/current-system/profile/bin/bash - -echo "#!/run/current-system/profile/bin/bash" > ./guix-env -echo "" > ./guix-env - -welcome() { - cat<<"EOF" - ░░░ ░░░ - ░░▒▒░░░░░░░░░ ░░░░░░░░░▒▒░░ - ░░▒▒▒▒▒░░░░░░░ ░░░░░░░▒▒▒▒▒░ - ░▒▒▒░░▒▒▒▒▒ ░░░░░░░▒▒░ - ░▒▒▒▒░ ░░░░░░ - ▒▒▒▒▒ ░░░░░░ - ▒▒▒▒▒ ░░░░░ - ░▒▒▒▒▒ ░░░░░ - ▒▒▒▒▒ ░░░░░ - ▒▒▒▒▒ ░░░░░ - ░▒▒▒▒▒░░░░░ - ▒▒▒▒▒▒░░░ - ▒▒▒▒▒▒░ - ____ _ _ _____ __ ____ _ - / ___| | | |_ _\ \/ / / ___|| |_ _ __ __ _ _ __ - | | _| | | || | \ / \___ \| __| '__/ _` | '_ \ - | |_| | |_| || | / \ ___) | |_| | | (_| | |_) | - \____|\___/|___/_/\_\ |____/ \__|_| \__,_| .__/ - |_| -This script installs GNU Guix on your system - -https://www.gnu.org/software/guix/ -EOF - echo -n "Press return to continue..." - read -r ANSWER -} - -welcome -./guix-partition -./guix-crypt -./guix-configure -./guix-install -./guix-password - -echo "GNU Guix has been installed, you can now reboot..." -exit 0 diff --git a/installer/guix-setup-user b/installer/guix-setup-user deleted file mode 100755 index 5933116..0000000 --- a/installer/guix-setup-user +++ /dev/null @@ -1,21 +0,0 @@ -#!/run/current-system/profile/bin/bash - -# This should run on user first logon, so let's a go! -# First, we should run a guix pull - -guix pull - -hash guix - -guix home -L ~/.config/guix/modules reconfigure ~/.config/guix/home-config/home-configuration.scm - -sudo -E herd restart nix-daemon - -nix-channel --update - -nix-shell '<home-manager>' -A install - -rm ~/.zprofile -source ~/.config/zsh/.zprofile - -home-manager switch diff --git a/installer/system.scm b/installer/system.scm deleted file mode 100644 index af791c5..0000000 --- a/installer/system.scm +++ /dev/null @@ -1,23 +0,0 @@ -(use-modules (home-config base-system) - (gnu)) - -(operating-system - (inherit base-operating-system) - (host-name "SED_HOSTNAME") - - (mapped-devices (list (mapped-device - (source (uuid - "SED_CRYPT_UUID")) - (target "root") - (type luks-device-mapping)))) - - (file-systems (cons* (file-system - (mount-point "/") - (device "/dev/mapper/root") - (type "btrfs") - (dependencies mapped-devices)) - (file-system - (mount-point "/boot/efi") - (device (uuid "SED_EFI_UUID" - 'fat32)) - (type "vfat")) %base-file-systems))) diff --git a/modules/freya/system.scm b/modules/freya/system.scm index 002a910..0a8852d 100644 --- a/modules/freya/system.scm +++ b/modules/freya/system.scm @@ -120,6 +120,7 @@ "ripgrep" "ncurses" "jq" + "m4" "openssl")) ;; append freyanet certs (list freya-ca-certs) 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) |