#!/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)