764 lines
23 KiB
Text
764 lines
23 KiB
Text
|
#!/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)
|