You've already forked fruix-bootstrap
447 lines
21 KiB
Scheme
447 lines
21 KiB
Scheme
(define-module (fruix system freebsd model)
|
|
#:use-module (fruix packages freebsd)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-13)
|
|
#:export (user-group
|
|
user-group?
|
|
user-group-name
|
|
user-group-gid
|
|
user-group-system?
|
|
user-account
|
|
user-account?
|
|
user-account-name
|
|
user-account-uid
|
|
user-account-group
|
|
user-account-supplementary-groups
|
|
user-account-comment
|
|
user-account-home
|
|
user-account-shell
|
|
user-account-system?
|
|
file-system
|
|
file-system?
|
|
file-system-device
|
|
file-system-mount-point
|
|
file-system-type
|
|
file-system-options
|
|
file-system-needed-for-boot?
|
|
make-promoted-native-build-result
|
|
promoted-native-build-result?
|
|
promoted-native-build-result-store-path
|
|
promoted-native-build-result-metadata-file
|
|
promoted-native-build-result-metadata
|
|
promoted-native-build-result-spec
|
|
operating-system
|
|
operating-system?
|
|
operating-system-host-name
|
|
operating-system-freebsd-base
|
|
operating-system-native-build-result
|
|
operating-system-kernel
|
|
operating-system-bootloader
|
|
operating-system-base-packages
|
|
operating-system-development-packages
|
|
operating-system-build-packages
|
|
operating-system-users
|
|
operating-system-groups
|
|
operating-system-file-systems
|
|
operating-system-services
|
|
operating-system-loader-entries
|
|
operating-system-rc-conf-entries
|
|
operating-system-init-mode
|
|
operating-system-ready-marker
|
|
operating-system-root-authorized-keys
|
|
default-minimal-operating-system
|
|
freebsd-source-spec
|
|
freebsd-base-spec
|
|
validate-freebsd-source
|
|
validate-operating-system
|
|
pid1-init-mode?
|
|
effective-loader-entries
|
|
rc-conf-entry-value
|
|
sshd-enabled?
|
|
operating-system-generated-file-names
|
|
operating-system-closure-spec))
|
|
|
|
(define-record-type <user-group>
|
|
(make-user-group name gid system?)
|
|
user-group?
|
|
(name user-group-name)
|
|
(gid user-group-gid)
|
|
(system? user-group-system?))
|
|
|
|
(define* (user-group #:key name gid (system? #t))
|
|
(make-user-group name gid system?))
|
|
|
|
(define-record-type <user-account>
|
|
(make-user-account name uid group supplementary-groups comment home shell system?)
|
|
user-account?
|
|
(name user-account-name)
|
|
(uid user-account-uid)
|
|
(group user-account-group)
|
|
(supplementary-groups user-account-supplementary-groups)
|
|
(comment user-account-comment)
|
|
(home user-account-home)
|
|
(shell user-account-shell)
|
|
(system? user-account-system?))
|
|
|
|
(define* (user-account #:key name uid group (supplementary-groups '())
|
|
(comment "Fruix user") (home "/nonexistent")
|
|
(shell "/usr/sbin/nologin") (system? #t))
|
|
(make-user-account name uid group supplementary-groups comment home shell system?))
|
|
|
|
(define-record-type <file-system>
|
|
(make-file-system device mount-point type options needed-for-boot?)
|
|
file-system?
|
|
(device file-system-device)
|
|
(mount-point file-system-mount-point)
|
|
(type file-system-type)
|
|
(options file-system-options)
|
|
(needed-for-boot? file-system-needed-for-boot?))
|
|
|
|
(define* (file-system #:key device mount-point type (options "rw")
|
|
(needed-for-boot? #f))
|
|
(make-file-system device mount-point type options needed-for-boot?))
|
|
|
|
(define-record-type <promoted-native-build-result>
|
|
(make-promoted-native-build-result store-path metadata-file metadata)
|
|
promoted-native-build-result?
|
|
(store-path promoted-native-build-result-store-path)
|
|
(metadata-file promoted-native-build-result-metadata-file)
|
|
(metadata promoted-native-build-result-metadata))
|
|
|
|
(define (promoted-native-build-result-metadata-ref metadata key default)
|
|
(match (assoc key metadata)
|
|
((_ . value) value)
|
|
(#f default)))
|
|
|
|
(define (promoted-native-build-result-artifact-spec metadata artifact-kind)
|
|
(find (lambda (entry)
|
|
(eq? (promoted-native-build-result-metadata-ref entry 'artifact-kind #f)
|
|
artifact-kind))
|
|
(promoted-native-build-result-metadata-ref metadata 'artifacts '())))
|
|
|
|
(define (promoted-native-build-result-spec result)
|
|
(let* ((metadata (promoted-native-build-result-metadata result))
|
|
(base (promoted-native-build-result-metadata-ref metadata 'freebsd-base '()))
|
|
(source (promoted-native-build-result-metadata-ref metadata 'source '())))
|
|
`((store-path . ,(promoted-native-build-result-store-path result))
|
|
(metadata-file . ,(promoted-native-build-result-metadata-file result))
|
|
(executor-kind . ,(promoted-native-build-result-metadata-ref metadata 'executor-kind #f))
|
|
(executor-name . ,(promoted-native-build-result-metadata-ref metadata 'executor-name #f))
|
|
(executor-version . ,(promoted-native-build-result-metadata-ref metadata 'executor-version #f))
|
|
(run-id . ,(promoted-native-build-result-metadata-ref metadata 'run-id #f))
|
|
(version-label . ,(promoted-native-build-result-metadata-ref base 'version-label #f))
|
|
(release . ,(promoted-native-build-result-metadata-ref base 'release #f))
|
|
(branch . ,(promoted-native-build-result-metadata-ref base 'branch #f))
|
|
(source-store . ,(promoted-native-build-result-metadata-ref source 'store-path #f))
|
|
(source-root . ,(promoted-native-build-result-metadata-ref source 'source-root #f))
|
|
(artifact-count . ,(promoted-native-build-result-metadata-ref metadata 'artifact-count 0))
|
|
(world-store . ,(promoted-native-build-result-metadata-ref
|
|
(promoted-native-build-result-artifact-spec metadata 'world)
|
|
'store-path
|
|
#f))
|
|
(kernel-store . ,(promoted-native-build-result-metadata-ref
|
|
(promoted-native-build-result-artifact-spec metadata 'kernel)
|
|
'store-path
|
|
#f))
|
|
(headers-store . ,(promoted-native-build-result-metadata-ref
|
|
(promoted-native-build-result-artifact-spec metadata 'headers)
|
|
'store-path
|
|
#f))
|
|
(bootloader-store . ,(promoted-native-build-result-metadata-ref
|
|
(promoted-native-build-result-artifact-spec metadata 'bootloader)
|
|
'store-path
|
|
#f)))))
|
|
|
|
(define-record-type <operating-system>
|
|
(make-operating-system host-name freebsd-base native-build-result kernel bootloader
|
|
base-packages development-packages build-packages users groups file-systems
|
|
services loader-entries rc-conf-entries init-mode ready-marker
|
|
root-authorized-keys)
|
|
operating-system?
|
|
(host-name operating-system-host-name)
|
|
(freebsd-base operating-system-freebsd-base)
|
|
(native-build-result operating-system-native-build-result)
|
|
(kernel operating-system-kernel)
|
|
(bootloader operating-system-bootloader)
|
|
(base-packages operating-system-base-packages)
|
|
(development-packages operating-system-development-packages)
|
|
(build-packages operating-system-build-packages)
|
|
(users operating-system-users)
|
|
(groups operating-system-groups)
|
|
(file-systems operating-system-file-systems)
|
|
(services operating-system-services)
|
|
(loader-entries operating-system-loader-entries)
|
|
(rc-conf-entries operating-system-rc-conf-entries)
|
|
(init-mode operating-system-init-mode)
|
|
(ready-marker operating-system-ready-marker)
|
|
(root-authorized-keys operating-system-root-authorized-keys))
|
|
|
|
(define* (operating-system #:key
|
|
(host-name "fruix-freebsd")
|
|
(freebsd-base %default-freebsd-base)
|
|
(native-build-result #f)
|
|
(kernel freebsd-kernel)
|
|
(bootloader freebsd-bootloader)
|
|
(base-packages %freebsd-system-packages)
|
|
(development-packages '())
|
|
(build-packages '())
|
|
(users (list (user-account #:name "root"
|
|
#:uid 0
|
|
#:group "wheel"
|
|
#:comment "Charlie &"
|
|
#:home "/root"
|
|
#:shell "/bin/sh"
|
|
#:system? #t)
|
|
(user-account #:name "operator"
|
|
#:uid 1000
|
|
#:group "operator"
|
|
#:supplementary-groups '("wheel")
|
|
#:comment "Fruix Operator"
|
|
#:home "/home/operator"
|
|
#:shell "/bin/sh"
|
|
#:system? #f)))
|
|
(groups (list (user-group #:name "wheel" #:gid 0 #:system? #t)
|
|
(user-group #:name "operator" #:gid 1000 #:system? #f)))
|
|
(file-systems (list (file-system #:device "/dev/ufs/fruix-root"
|
|
#:mount-point "/"
|
|
#:type "ufs"
|
|
#:options "rw"
|
|
#:needed-for-boot? #t)
|
|
(file-system #:device "devfs"
|
|
#:mount-point "/dev"
|
|
#:type "devfs"
|
|
#:options "rw"
|
|
#:needed-for-boot? #t)
|
|
(file-system #:device "tmpfs"
|
|
#:mount-point "/tmp"
|
|
#:type "tmpfs"
|
|
#:options "rw,size=64m"
|
|
#:needed-for-boot? #f)))
|
|
(services '(shepherd ready-marker))
|
|
(loader-entries '(("autoboot_delay" . "1")
|
|
("console" . "comconsole")))
|
|
(rc-conf-entries '(("clear_tmp_enable" . "YES")
|
|
("sendmail_enable" . "NONE")
|
|
("sshd_enable" . "NO")))
|
|
(init-mode 'freebsd-init+rc.d-shepherd)
|
|
(ready-marker "/var/lib/fruix/ready")
|
|
(root-authorized-keys '()))
|
|
(make-operating-system host-name freebsd-base native-build-result kernel bootloader
|
|
base-packages development-packages build-packages users groups file-systems
|
|
services loader-entries rc-conf-entries init-mode ready-marker
|
|
root-authorized-keys))
|
|
|
|
(define default-minimal-operating-system (operating-system))
|
|
|
|
(define (package-names packages)
|
|
(map freebsd-package-name packages))
|
|
|
|
(define (freebsd-source-spec source)
|
|
`((name . ,(freebsd-source-name source))
|
|
(kind . ,(freebsd-source-kind source))
|
|
(url . ,(freebsd-source-url source))
|
|
(path . ,(freebsd-source-path source))
|
|
(ref . ,(freebsd-source-ref source))
|
|
(commit . ,(freebsd-source-commit source))
|
|
(sha256 . ,(freebsd-source-sha256 source))))
|
|
|
|
(define (freebsd-base-spec base)
|
|
`((name . ,(freebsd-base-name base))
|
|
(version-label . ,(freebsd-base-version-label base))
|
|
(release . ,(freebsd-base-release base))
|
|
(branch . ,(freebsd-base-branch base))
|
|
(source-root . ,(freebsd-base-source-root base))
|
|
(source . ,(freebsd-source-spec (freebsd-base-source base)))
|
|
(target . ,(freebsd-base-target base))
|
|
(target-arch . ,(freebsd-base-target-arch base))
|
|
(kernconf . ,(freebsd-base-kernconf base))
|
|
(make-flags . ,(freebsd-base-make-flags base))))
|
|
|
|
|
|
(define (duplicate-elements values)
|
|
(let loop ((rest values) (seen '()) (duplicates '()))
|
|
(match rest
|
|
(() (reverse duplicates))
|
|
((head . tail)
|
|
(if (member head seen)
|
|
(loop tail seen (if (member head duplicates) duplicates (cons head duplicates)))
|
|
(loop tail (cons head seen) duplicates))))))
|
|
|
|
(define (non-empty-string? value)
|
|
(and (string? value)
|
|
(not (string-null? value))))
|
|
|
|
(define (validate-freebsd-source source)
|
|
(unless (freebsd-source? source)
|
|
(error "freebsd base source must be a <freebsd-source> record"))
|
|
(let ((kind (freebsd-source-kind source)))
|
|
(unless (member kind '(local-tree git src-txz))
|
|
(error "unsupported freebsd source kind" kind))
|
|
(case kind
|
|
((local-tree)
|
|
(unless (non-empty-string? (freebsd-source-path source))
|
|
(error "local-tree freebsd source must declare a path" source)))
|
|
((git)
|
|
(unless (non-empty-string? (freebsd-source-url source))
|
|
(error "git freebsd source must declare a URL" source))
|
|
(unless (or (non-empty-string? (freebsd-source-ref source))
|
|
(non-empty-string? (freebsd-source-commit source)))
|
|
(error "git freebsd source must declare a ref or commit" source)))
|
|
((src-txz)
|
|
(unless (non-empty-string? (freebsd-source-url source))
|
|
(error "src-txz freebsd source must declare a URL" source))
|
|
(unless (non-empty-string? (freebsd-source-sha256 source))
|
|
(error "src-txz freebsd source must declare a sha256" source)))))
|
|
#t)
|
|
|
|
(define (validate-operating-system os)
|
|
(let* ((host-name (operating-system-host-name os))
|
|
(base (operating-system-freebsd-base os))
|
|
(native-build-result (operating-system-native-build-result os))
|
|
(base-packages (operating-system-base-packages os))
|
|
(development-packages (operating-system-development-packages os))
|
|
(build-packages (operating-system-build-packages os))
|
|
(users (operating-system-users os))
|
|
(groups (operating-system-groups os))
|
|
(file-systems (operating-system-file-systems os))
|
|
(user-names (map user-account-name users))
|
|
(group-names (map user-group-name groups))
|
|
(mount-points (map file-system-mount-point file-systems))
|
|
(init-mode (operating-system-init-mode os)))
|
|
(when (string-null? host-name)
|
|
(error "operating-system host-name must not be empty"))
|
|
(unless (freebsd-base? base)
|
|
(error "operating-system freebsd-base must be a <freebsd-base> record"))
|
|
(when native-build-result
|
|
(unless (promoted-native-build-result? native-build-result)
|
|
(error "operating-system native-build-result must be a <promoted-native-build-result> record")))
|
|
(unless (every freebsd-package? base-packages)
|
|
(error "operating-system base-packages must be a list of <freebsd-package> records"))
|
|
(unless (every freebsd-package? development-packages)
|
|
(error "operating-system development-packages must be a list of <freebsd-package> records"))
|
|
(unless (every freebsd-package? build-packages)
|
|
(error "operating-system build-packages must be a list of <freebsd-package> records"))
|
|
(validate-freebsd-source (freebsd-base-source base))
|
|
(let ((dups (duplicate-elements user-names)))
|
|
(unless (null? dups)
|
|
(error "duplicate user names in operating-system" dups)))
|
|
(let ((dups (duplicate-elements group-names)))
|
|
(unless (null? dups)
|
|
(error "duplicate group names in operating-system" dups)))
|
|
(unless (member "/" mount-points)
|
|
(error "operating-system must declare a root file-system"))
|
|
(unless (member "root" user-names)
|
|
(error "operating-system must declare a root user"))
|
|
(unless (member "wheel" group-names)
|
|
(error "operating-system must declare a wheel group"))
|
|
(unless (member init-mode '(freebsd-init+rc.d-shepherd shepherd-pid1))
|
|
(error "unsupported operating-system init-mode" init-mode))
|
|
#t))
|
|
|
|
(define (pid1-init-mode? os)
|
|
(eq? (operating-system-init-mode os) 'shepherd-pid1))
|
|
|
|
(define (effective-loader-entries os)
|
|
(append (if (pid1-init-mode? os)
|
|
'(("init_exec" . "/run/current-system/boot/fruix-pid1"))
|
|
'())
|
|
(operating-system-loader-entries os)))
|
|
|
|
(define (rc-conf-entry-value os key)
|
|
(let ((entry (assoc key (operating-system-rc-conf-entries os))))
|
|
(and entry (cdr entry))))
|
|
|
|
(define (sshd-enabled? os)
|
|
(let ((value (rc-conf-entry-value os "sshd_enable")))
|
|
(and value
|
|
(member (string-upcase value) '("YES" "TRUE" "1")))))
|
|
|
|
|
|
(define (operating-system-generated-file-names os)
|
|
(append
|
|
'("boot/loader.conf"
|
|
"etc/rc.conf"
|
|
"etc/fstab"
|
|
"etc/hosts"
|
|
"etc/passwd"
|
|
"etc/master.passwd"
|
|
"etc/group"
|
|
"etc/login.conf"
|
|
"etc/shells"
|
|
"etc/motd"
|
|
"etc/ttys"
|
|
"metadata/freebsd-base.scm"
|
|
"metadata/host-base-provenance.scm"
|
|
"metadata/store-layout.scm"
|
|
"metadata/system-declaration.scm"
|
|
"metadata/system-declaration-info.scm"
|
|
"metadata/system-declaration-system"
|
|
"activate"
|
|
"shepherd/init.scm"
|
|
"share/fruix/node/scripts/fruix.scm"
|
|
"usr/local/bin/fruix")
|
|
(if (operating-system-native-build-result os)
|
|
'("metadata/promoted-native-build-result.scm")
|
|
'())
|
|
(if (null? (operating-system-development-packages os))
|
|
'()
|
|
'("usr/local/bin/fruix-development-environment"))
|
|
(if (null? (operating-system-build-packages os))
|
|
'()
|
|
'("usr/local/bin/fruix-build-environment"
|
|
"usr/local/bin/fruix-self-hosted-native-build"))
|
|
(if (pid1-init-mode? os)
|
|
'("boot/fruix-pid1")
|
|
'())
|
|
(if (sshd-enabled? os)
|
|
'("etc/ssh/sshd_config")
|
|
'())
|
|
(if (null? (operating-system-root-authorized-keys os))
|
|
'()
|
|
'("root/.ssh/authorized_keys"))))
|
|
|
|
|
|
(define (operating-system-closure-spec os)
|
|
(validate-operating-system os)
|
|
`((host-name . ,(operating-system-host-name os))
|
|
(freebsd-base . ,(freebsd-base-spec (operating-system-freebsd-base os)))
|
|
(promoted-native-build-result
|
|
. ,(and (operating-system-native-build-result os)
|
|
(promoted-native-build-result-spec
|
|
(operating-system-native-build-result os))))
|
|
(kernel-package . ,(freebsd-package-name (operating-system-kernel os)))
|
|
(bootloader-package . ,(freebsd-package-name (operating-system-bootloader os)))
|
|
(base-package-count . ,(length (operating-system-base-packages os)))
|
|
(base-packages . ,(package-names (operating-system-base-packages os)))
|
|
(development-package-count . ,(length (operating-system-development-packages os)))
|
|
(development-packages . ,(package-names (operating-system-development-packages os)))
|
|
(build-package-count . ,(length (operating-system-build-packages os)))
|
|
(build-packages . ,(package-names (operating-system-build-packages os)))
|
|
(installed-system-command-surface-version . "4")
|
|
(bundled-fruix-node-cli-version . "1")
|
|
(development-environment-helper-version
|
|
. ,(if (null? (operating-system-development-packages os)) #f "1"))
|
|
(build-environment-helper-version
|
|
. ,(if (null? (operating-system-build-packages os)) #f "1"))
|
|
(self-hosted-native-build-helper-version
|
|
. ,(if (null? (operating-system-build-packages os)) #f "5"))
|
|
(user-count . ,(length (operating-system-users os)))
|
|
(users . ,(map user-account-name (operating-system-users os)))
|
|
(group-count . ,(length (operating-system-groups os)))
|
|
(groups . ,(map user-group-name (operating-system-groups os)))
|
|
(file-system-count . ,(length (operating-system-file-systems os)))
|
|
(file-systems . ,(map (lambda (fs)
|
|
`((device . ,(file-system-device fs))
|
|
(mount-point . ,(file-system-mount-point fs))
|
|
(type . ,(file-system-type fs))
|
|
(options . ,(file-system-options fs))
|
|
(needed-for-boot? . ,(file-system-needed-for-boot? fs))))
|
|
(operating-system-file-systems os)))
|
|
(services . ,(operating-system-services os))
|
|
(generated-files . ,(operating-system-generated-file-names os))
|
|
(init-mode . ,(operating-system-init-mode os))
|
|
(ready-marker . ,(operating-system-ready-marker os))))
|
|
|