rewrite guix installer
This commit is contained in:
parent
e0c62036ce
commit
48edfadc67
GPG key ID:
9FBC6FFD6D2DBF17
13 changed files with 820 additions and 375 deletions
|
|
@ -4,8 +4,8 @@
|
||||||
|
|
||||||
### Instructions
|
### Instructions
|
||||||
|
|
||||||
- Create USB with Guix installation image
|
- Build Guix ISO Image with `systems/installer.scm`
|
||||||
- Boot and immediately drop into shell, skip graphical installer
|
- Boot into it and get root shell
|
||||||
- Install git `guix shell git`, and pull this repo `git clone https://g.freya.cat/freya/dotfiles-guix.git`
|
- Pull this repo `git clone https://g.freya.cat/freya/dotfiles-guix.git`
|
||||||
- Enter the `installer` directory and run `./guix-setup`
|
- Execute `scripts/install-system`
|
||||||
- Its Guixing time
|
- Its Guixing time
|
||||||
|
|
|
||||||
52
files/base.scm.m4
Normal file
52
files/base.scm.m4
Normal file
|
|
@ -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))))
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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"
|
|
||||||
|
|
@ -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
|
|
||||||
}
|
|
||||||
|
|
@ -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"
|
|
||||||
|
|
@ -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"
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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)))
|
|
||||||
|
|
@ -120,6 +120,7 @@
|
||||||
"ripgrep"
|
"ripgrep"
|
||||||
"ncurses"
|
"ncurses"
|
||||||
"jq"
|
"jq"
|
||||||
|
"m4"
|
||||||
"openssl"))
|
"openssl"))
|
||||||
;; append freyanet certs
|
;; append freyanet certs
|
||||||
(list freya-ca-certs)
|
(list freya-ca-certs)
|
||||||
|
|
|
||||||
763
scripts/install-system
Executable file
763
scripts/install-system
Executable file
|
|
@ -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)
|
||||||
Loading…
Reference in a new issue