self/fruix
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

system: split FreeBSD system module

Browse Source
This commit is contained in:
Steffen
2026-04-04 09:38:27 +02:00
parent 56d9d6a54b
commit ebe064a652
7 changed files with 2834 additions and 2683 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2737
modules/fruix/system/freebsd.scm
View File

File diff suppressed because it is too large Load Diff

470
modules/fruix/system/freebsd/build.scm Normal file
View File

@@ -0,0 +1,470 @@
(define-module (fruix system freebsd build)
#:use-module (fruix packages freebsd)
#:use-module (fruix system freebsd model)
#:use-module (fruix system freebsd source)
#:use-module (fruix system freebsd utils)
#:use-module (guix build utils)
#:use-module (ice-9 format)
#:use-module (ice-9 hash-table)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (host-freebsd-provenance
materialize-freebsd-package
materialize-prefix))
(define (host-freebsd-provenance)
(let ((src-git? (file-exists? "/usr/src/.git"))
(newvers "/usr/src/sys/conf/newvers.sh"))
`((freebsd-release . ,freebsd-release)
(freebsd-version-kru . ,(or (safe-command-output "freebsd-version" "-kru") "unknown"))
(uname . ,(or (safe-command-output "uname" "-a") "unknown"))
(usr-src-path . "/usr/src")
(usr-src-git-revision . ,(or (and src-git?
(safe-command-output "git" "-C" "/usr/src" "rev-parse" "HEAD"))
"absent"))
(usr-src-git-branch . ,(or (and src-git?
(safe-command-output "git" "-C" "/usr/src" "rev-parse" "--abbrev-ref" "HEAD"))
"absent"))
(usr-src-newvers-sha256 . ,(if (file-exists? newvers)
(file-hash newvers)
"absent")))))
(define native-freebsd-build-version "1")
(define (freebsd-native-build-system? build-system)
(not (not (memq build-system '(freebsd-kernel-build-system freebsd-world-build-system)))))
(define (build-plan-ref plan key default)
(match (assoc key plan)
((_ . value) value)
(#f default)))
(define (make-flag->pair flag)
(match (string-split flag #\=)
((name value ...) (cons name (string-join value "=")))
((name) (cons name "yes"))
(_ (error (format #f "invalid make flag: ~a" flag)))))
(define (native-build-kernconf-path plan)
(or (build-plan-ref plan 'kernconf-path #f)
(string-append (build-plan-ref plan 'source-root "/usr/src")
"/sys/"
(build-plan-ref plan 'target-arch "amd64")
"/conf/"
(build-plan-ref plan 'kernconf "GENERIC"))))
(define (native-build-common-manifest plan)
(let* ((source-root (build-plan-ref plan 'source-root "/usr/src"))
(target (build-plan-ref plan 'target "amd64"))
(target-arch (build-plan-ref plan 'target-arch "amd64"))
(kernconf (build-plan-ref plan 'kernconf "GENERIC"))
(make-flags (build-plan-ref plan 'make-flags '()))
(kernconf-path (native-build-kernconf-path plan)))
(unless (file-exists? source-root)
(error (format #f "native FreeBSD source root does not exist: ~a" source-root)))
(unless (file-exists? kernconf-path)
(error (format #f "native FreeBSD kernconf does not exist: ~a" kernconf-path)))
`((build-version . ,native-freebsd-build-version)
(source-root . ,source-root)
(source-tree-identity-mode . "mtree:type,link,size,mode,sha256digest")
(source-tree-sha256 . ,(or (build-plan-ref plan 'materialized-source-tree-sha256 #f)
(native-build-source-tree-sha256 source-root)))
(target . ,target)
(target-arch . ,target-arch)
(kernconf . ,kernconf)
(kernconf-path . ,kernconf-path)
(kernconf-sha256 . ,(file-hash kernconf-path))
(make-flags . ,make-flags))))
(define (native-build-declared-base plan)
`((name . ,(build-plan-ref plan 'base-name "default"))
(version-label . ,(build-plan-ref plan 'base-version-label freebsd-release))
(release . ,(build-plan-ref plan 'base-release freebsd-release))
(branch . ,(build-plan-ref plan 'base-branch "unknown"))))
(define (native-build-declared-source plan)
`((name . ,(build-plan-ref plan 'base-source-name "default"))
(kind . ,(build-plan-ref plan 'base-source-kind 'local-tree))
(url . ,(build-plan-ref plan 'base-source-url #f))
(path . ,(build-plan-ref plan 'base-source-path #f))
(ref . ,(build-plan-ref plan 'base-source-ref #f))
(commit . ,(build-plan-ref plan 'base-source-commit #f))
(sha256 . ,(build-plan-ref plan 'base-source-sha256 #f))))
(define (native-build-materialized-source plan)
`((store-path . ,(build-plan-ref plan 'materialized-source-store #f))
(source-root . ,(build-plan-ref plan 'source-root "/usr/src"))
(info-file . ,(build-plan-ref plan 'materialized-source-info-file #f))
(tree-sha256 . ,(build-plan-ref plan 'materialized-source-tree-sha256 #f))
(cache-path . ,(build-plan-ref plan 'materialized-source-cache-path #f))
(effective-source . ((kind . ,(build-plan-ref plan 'effective-source-kind #f))
(url . ,(build-plan-ref plan 'effective-source-url #f))
(path . ,(build-plan-ref plan 'effective-source-path #f))
(ref . ,(build-plan-ref plan 'effective-source-ref #f))
(commit . ,(build-plan-ref plan 'effective-source-commit #f))
(sha256 . ,(build-plan-ref plan 'effective-source-sha256 #f))))))
(define (native-build-manifest-string package input-paths)
(let* ((plan (freebsd-package-install-plan package))
(common (native-build-common-manifest plan))
(declared-base (native-build-declared-base plan))
(declared-source (native-build-declared-source plan))
(materialized-source (native-build-materialized-source plan))
(keep-paths (build-plan-ref plan 'keep-paths '()))
(prune-paths (build-plan-ref plan 'prune-paths '())))
(string-append
"name=" (freebsd-package-name package) "\n"
"version=" (freebsd-package-version package) "\n"
"build-system=" (symbol->string (freebsd-package-build-system package)) "\n"
"inputs=" (string-join input-paths ",") "\n"
"declared-base=\n"
(object->string declared-base)
"\ndeclared-source=\n"
(object->string declared-source)
"\nmaterialized-source=\n"
(object->string materialized-source)
"\nnative-build-common=\n"
(object->string common)
"\nkeep-paths=\n"
(object->string keep-paths)
"\nprune-paths=\n"
(object->string prune-paths))))
(define (copy-build-manifest-string package input-paths)
(string-append
"name=" (freebsd-package-name package) "\n"
"version=" (freebsd-package-version package) "\n"
"build-system=" (symbol->string (freebsd-package-build-system package)) "\n"
"inputs=" (string-join input-paths ",") "\n"
"install-plan-signature=\n"
(string-join (map install-plan-signature
(freebsd-package-install-plan package))
"\n")))
(define (package-manifest-string package input-paths)
(if (freebsd-native-build-system? (freebsd-package-build-system package))
(native-build-manifest-string package input-paths)
(copy-build-manifest-string package input-paths)))
(define (current-build-jobs)
(or (getenv "FRUIX_FREEBSD_BUILD_JOBS")
(safe-command-output "sysctl" "-n" "hw.ncpu")
"1"))
(define (native-build-root common)
(string-append "/var/tmp/fruix-freebsd-native-build-"
(string-hash (object->string common))))
(define (native-make-arguments common _build-root)
(append
(list "-C" (assoc-ref common 'source-root)
(string-append "TARGET=" (assoc-ref common 'target))
(string-append "TARGET_ARCH=" (assoc-ref common 'target-arch))
(string-append "KERNCONF=" (assoc-ref common 'kernconf)))
(assoc-ref common 'make-flags)))
(define* (make-command-string common build-root target #:key (parallel? #f) (destdir #f))
(string-join
(append
(list "env" (string-append "MAKEOBJDIRPREFIX=" build-root "/obj") "make")
(if parallel?
(list (string-append "-j" (current-build-jobs)))
'())
(native-make-arguments common build-root)
(if destdir
(list (string-append "DESTDIR=" destdir))
'())
(list target))
" "))
(define (run-command/log log-file command)
(mkdir-p (dirname log-file))
(let ((status (system* "sh" "-c" (string-append command " >" log-file " 2>&1"))))
(unless (zero? status)
(error (format #f "command failed; see ~a: ~a" log-file command)))))
(define (ensure-native-build-root common build-root)
(mkdir-p build-root)
(mkdir-p (string-append build-root "/logs"))
(mkdir-p (string-append build-root "/stamps"))
(write-file (string-append build-root "/build-parameters.scm")
(object->string common)))
(define (ensure-native-buildworld common build-root)
(let ((stamp (string-append build-root "/stamps/buildworld.done")))
(ensure-native-build-root common build-root)
(unless (file-exists? stamp)
(run-command/log (string-append build-root "/logs/buildworld.log")
(make-command-string common build-root "buildworld" #:parallel? #t))
(write-file stamp "ok\n"))))
(define (ensure-native-buildkernel common build-root)
(let ((stamp (string-append build-root "/stamps/buildkernel-" (assoc-ref common 'kernconf) ".done")))
(ensure-native-buildworld common build-root)
(unless (file-exists? stamp)
(run-command/log (string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log")
(make-command-string common build-root "buildkernel" #:parallel? #t))
(write-file stamp "ok\n"))))
(define (prune-stage-paths stage-root paths)
(for-each (lambda (path)
(delete-path-if-exists (string-append stage-root "/" path)))
paths))
(define (select-stage-paths stage-root paths)
(let ((selected-root (string-append stage-root ".selected")))
(delete-path-if-exists selected-root)
(mkdir-p selected-root)
(for-each (lambda (path)
(let ((source (string-append stage-root "/" path))
(target (string-append selected-root "/" path)))
(unless (or (file-exists? source)
(false-if-exception (readlink source)))
(error (format #f "native stage path is missing: ~a" source)))
(copy-node source target)))
paths)
selected-root))
(define (native-build-output-metadata package common build-root stage-root)
(let ((plan (freebsd-package-install-plan package)))
`((package . ,(freebsd-package-name package))
(version . ,(freebsd-package-version package))
(declared-base . ,(native-build-declared-base plan))
(declared-source . ,(native-build-declared-source plan))
(materialized-source . ,(native-build-materialized-source plan))
(build-system . ,(freebsd-package-build-system package))
(source-root . ,(assoc-ref common 'source-root))
(source-tree-sha256 . ,(assoc-ref common 'source-tree-sha256))
(target . ,(assoc-ref common 'target))
(target-arch . ,(assoc-ref common 'target-arch))
(kernconf . ,(assoc-ref common 'kernconf))
(kernconf-path . ,(assoc-ref common 'kernconf-path))
(kernconf-sha256 . ,(assoc-ref common 'kernconf-sha256))
(make-flags . ,(assoc-ref common 'make-flags))
(keep-paths . ,(build-plan-ref plan 'keep-paths '()))
(prune-paths . ,(build-plan-ref plan 'prune-paths '()))
(build-root . ,build-root)
(stage-root . ,stage-root)
(buildworld-log . ,(string-append build-root "/logs/buildworld.log"))
(buildkernel-log . ,(string-append build-root "/logs/buildkernel-" (assoc-ref common 'kernconf) ".log"))
(install-log . ,(string-append build-root "/logs/install-" (freebsd-package-name package) ".log")))))
(define (materialize-native-freebsd-package package input-paths manifest output-path)
(let* ((plan (freebsd-package-install-plan package))
(common (native-build-common-manifest plan))
(build-root (native-build-root common))
(stage-root (string-append build-root "/stage-" (freebsd-package-name package) "-" (string-hash manifest)))
(install-log (string-append build-root "/logs/install-" (freebsd-package-name package) ".log"))
(final-stage-root
(case (freebsd-package-build-system package)
((freebsd-world-build-system)
(ensure-native-buildworld common build-root)
(delete-path-if-exists stage-root)
(mkdir-p stage-root)
(run-command/log install-log
(string-append (make-command-string common build-root "installworld" #:destdir stage-root)
" && "
(make-command-string common build-root "distribution" #:destdir stage-root)))
(let* ((keep-paths (build-plan-ref plan 'keep-paths '()))
(selected-root (if (null? keep-paths)
stage-root
(select-stage-paths stage-root keep-paths))))
(prune-stage-paths selected-root (build-plan-ref plan 'prune-paths '()))
selected-root))
((freebsd-kernel-build-system)
(ensure-native-buildkernel common build-root)
(delete-path-if-exists stage-root)
(mkdir-p stage-root)
(run-command/log install-log
(make-command-string common build-root "installkernel" #:destdir stage-root))
stage-root)
(else
(error (format #f "unsupported native FreeBSD build system: ~a"
(freebsd-package-build-system package)))))))
(mkdir-p output-path)
(stage-tree-into-output final-stage-root output-path)
(write-file (string-append output-path "/.references")
(string-join input-paths "\n"))
(write-file (string-append output-path "/.fruix-package") manifest)
(write-file (string-append output-path "/.freebsd-native-build-info.scm")
(object->string (native-build-output-metadata package common build-root final-stage-root)))))
(define (package-with-install-plan package install-plan)
(freebsd-package
#:name (freebsd-package-name package)
#:version (freebsd-package-version package)
#:build-system (freebsd-package-build-system package)
#:inputs (freebsd-package-inputs package)
#:home-page (freebsd-package-home-page package)
#:synopsis (freebsd-package-synopsis package)
#:description (freebsd-package-description package)
#:license (freebsd-package-license package)
#:install-plan install-plan))
(define (plan-freebsd-source plan)
(freebsd-source #:name (build-plan-ref plan 'base-source-name "default")
#:kind (build-plan-ref plan 'base-source-kind 'local-tree)
#:url (build-plan-ref plan 'base-source-url #f)
#:path (build-plan-ref plan 'base-source-path #f)
#:ref (build-plan-ref plan 'base-source-ref #f)
#:commit (build-plan-ref plan 'base-source-commit #f)
#:sha256 (build-plan-ref plan 'base-source-sha256 #f)))
(define (source-cache-key source)
(string-hash (object->string (freebsd-source-spec source))))
(define (materialize-freebsd-source/cached source store-dir source-cache)
(let* ((key (source-cache-key source))
(cached (hash-ref source-cache key #f)))
(or cached
(let ((result (materialize-freebsd-source source #:store-dir store-dir)))
(hash-set! source-cache key result)
result))))
(define (plan-with-materialized-source plan source-result)
(let* ((effective (assoc-ref source-result 'effective-source))
(overrides
`((source-root . ,(assoc-ref source-result 'source-root))
(materialized-source-store . ,(assoc-ref source-result 'source-store-path))
(materialized-source-info-file . ,(assoc-ref source-result 'source-info-file))
(materialized-source-tree-sha256 . ,(assoc-ref source-result 'source-tree-sha256))
(materialized-source-cache-path . ,(assoc-ref source-result 'cache-path))
(effective-source-kind . ,(assoc-ref effective 'kind))
(effective-source-url . ,(assoc-ref effective 'url))
(effective-source-path . ,(assoc-ref effective 'path))
(effective-source-ref . ,(assoc-ref effective 'ref))
(effective-source-commit . ,(assoc-ref effective 'commit))
(effective-source-sha256 . ,(assoc-ref effective 'sha256)))))
(append overrides plan)))
(define* (materialize-freebsd-package package store-dir cache #:optional source-cache)
(let* ((source-cache (or source-cache (make-hash-table)))
(input-paths (map (lambda (input)
(materialize-freebsd-package input store-dir cache source-cache))
(freebsd-package-inputs package)))
(prepared-package
(if (freebsd-native-build-package? package)
(let* ((source (plan-freebsd-source (freebsd-package-install-plan package)))
(source-result (materialize-freebsd-source/cached source store-dir source-cache))
(plan (plan-with-materialized-source (freebsd-package-install-plan package)
source-result)))
(package-with-install-plan package plan))
package))
(effective-input-paths
(if (freebsd-native-build-package? package)
(cons (build-plan-ref (freebsd-package-install-plan prepared-package)
'materialized-source-store
#f)
input-paths)
input-paths))
(effective-input-paths (filter identity effective-input-paths))
(manifest (package-manifest-string prepared-package effective-input-paths))
(cache-key (string-hash manifest))
(cached (hash-ref cache cache-key #f)))
(if cached
cached
(let* ((hash (string-hash manifest))
(output-path (string-append store-dir "/" hash "-"
(freebsd-package-name prepared-package)
"-"
(freebsd-package-version prepared-package))))
(unless (file-exists? output-path)
(case (freebsd-package-build-system prepared-package)
((copy-build-system)
(mkdir-p output-path)
(for-each (lambda (entry)
(materialize-plan-entry output-path entry))
(freebsd-package-install-plan prepared-package))
(write-file (string-append output-path "/.references")
(string-join effective-input-paths "\n"))
(write-file (string-append output-path "/.fruix-package") manifest))
((freebsd-world-build-system freebsd-kernel-build-system)
(materialize-native-freebsd-package prepared-package effective-input-paths manifest output-path))
(else
(error (format #f "unsupported package build system: ~a"
(freebsd-package-build-system prepared-package))))))
(hash-set! cache cache-key output-path)
output-path))))
(define (sanitize-materialized-prefix name output-path)
(cond
((string=? name "fruix-guile-extra")
(rewrite-text-file
(string-append output-path "/share/guile/site/3.0/fibers/config.scm")
'(("((getenv \"FIBERS_BUILD_DIR\")\n => (lambda (builddir) (in-vicinity builddir \".libs\")))\n (else \"/tmp/guile-gnutls-freebsd-validate-install/lib/guile/3.0/extensions\"))"
. "((getenv \"FIBERS_BUILD_DIR\")\n => (lambda (builddir) (in-vicinity builddir \".libs\")))\n ((getenv \"GUILE_EXTENSIONS_PATH\"))\n (else \"/usr/local/lib/guile/3.0/extensions\"))")))
(rewrite-text-file
(string-append output-path "/share/guile/site/3.0/gnutls.scm")
'(("\"/tmp/guile-gnutls-freebsd-validate-install/lib/guile/3.0/extensions\""
. "(or (getenv \"GUILE_EXTENSIONS_PATH\") \"/usr/local/lib/guile/3.0/extensions\")")))
(delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/fibers/config.go"))
(delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/gnutls.go")))
((string=? name "fruix-shepherd-runtime")
(rewrite-text-file
(string-append output-path "/share/guile/site/3.0/shepherd/config.scm")
'(("(define Prefix-dir \"/tmp/shepherd-freebsd-validate-install\")"
. "(define Prefix-dir \"/frx\")")
("(define %localstatedir \"/tmp/shepherd-freebsd-validate-install/var\")"
. "(define %localstatedir \"/var\")")
("(define %runstatedir \"/tmp/shepherd-freebsd-validate-install/var/run\")"
. "(define %runstatedir \"/var/run\")")
("(define %sysconfdir \"/tmp/shepherd-freebsd-validate-install/etc\")"
. "(define %sysconfdir \"/etc\")")
("(define %localedir \"/tmp/shepherd-freebsd-validate-install/share/locale\")"
. "(define %localedir \"/usr/share/locale\")")
("(define %pkglibdir \"/tmp/shepherd-freebsd-validate-install/lib/shepherd\")"
. "(define %pkglibdir \"/usr/local/lib/shepherd\")")))
(delete-file-if-exists (string-append output-path "/lib/guile/3.0/site-ccache/shepherd/config.go"))))
#t)
(define (prefix-manifest-string source-path extra-files)
(string-append
"prefix-materializer-version=" prefix-materializer-version "\n"
"prefix-source=" source-path "\n"
(path-signature source-path)
(if (null? extra-files)
""
(string-append
"\nextra-files=\n"
(string-join
(map (lambda (entry)
(string-append (cdr entry) "\n" (path-signature (car entry))))
extra-files)
"\n")))))
(define (copy-extra-node source destination)
(let ((kind (stat:type (lstat source))))
(mkdir-p (dirname destination))
(case kind
((symlink)
(unless (or (file-exists? destination)
(false-if-exception (readlink destination)))
(let ((target (readlink source)))
(symlink target destination)
(unless (string-prefix? "/" target)
(copy-extra-node (string-append (dirname source) "/" target)
(string-append (dirname destination) "/" target))))))
(else
(unless (file-exists? destination)
(copy-node source destination))))))
(define* (materialize-prefix source-path name version store-dir #:key (extra-files '()))
(let* ((manifest (prefix-manifest-string source-path extra-files))
(hash (string-hash manifest))
(output-path (string-append store-dir "/" hash "-" name "-" version)))
(unless (file-exists? output-path)
(mkdir-p output-path)
(for-each (lambda (entry)
(copy-node (string-append source-path "/" entry)
(string-append output-path "/" entry)))
(directory-entries source-path))
(for-each (lambda (entry)
(copy-extra-node (car entry)
(string-append output-path "/" (cdr entry))))
extra-files)
(sanitize-materialized-prefix name output-path)
(write-file (string-append output-path "/.fruix-package") manifest))
output-path))

1031
modules/fruix/system/freebsd/media.scm Normal file
View File

File diff suppressed because it is too large Load Diff

334
modules/fruix/system/freebsd/model.scm Normal file
View File

@@ -0,0 +1,334 @@
(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?
operating-system
operating-system?
operating-system-host-name
operating-system-freebsd-base
operating-system-kernel
operating-system-bootloader
operating-system-base-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 <operating-system>
(make-operating-system host-name freebsd-base kernel bootloader base-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)
(kernel operating-system-kernel)
(bootloader operating-system-bootloader)
(base-packages operating-system-base-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)
(kernel freebsd-kernel)
(bootloader freebsd-bootloader)
(base-packages %freebsd-system-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 kernel bootloader base-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))
(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"))
(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"
"activate"
"shepherd/init.scm")
(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)))
(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)))
(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))))

499
modules/fruix/system/freebsd/render.scm Normal file
View File

@@ -0,0 +1,499 @@
(define-module (fruix system freebsd render)
#:use-module (fruix system freebsd model)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:export (operating-system-generated-files
render-activation-rc-script
render-rc-script))
(define (render-loader-conf os)
(string-append
(string-join (map (lambda (entry)
(format #f "~a=\"~a\"" (car entry) (cdr entry)))
(effective-loader-entries os))
"\n")
"\n"))
(define (render-rc.conf os)
(let* ((entries (append `(("hostname" . ,(operating-system-host-name os))
("fruix_activate_enable" . "YES")
("fruix_shepherd_enable" . "YES"))
(operating-system-rc-conf-entries os))))
(string-append
(string-join (map (lambda (entry)
(format #f "~a=\"~a\"" (car entry) (cdr entry)))
entries)
"\n")
"\n")))
(define (group-name->gid groups name)
(let ((group (find (lambda (item)
(string=? (user-group-name item) name))
groups)))
(and group (user-group-gid group))))
(define (render-passwd os)
(let ((groups (operating-system-groups os)))
(string-append
(string-join
(map (lambda (account)
(format #f "~a:*:~a:~a:~a:~a:~a"
(user-account-name account)
(user-account-uid account)
(or (group-name->gid groups (user-account-group account))
(error "unknown primary group" (user-account-group account)))
(user-account-comment account)
(user-account-home account)
(user-account-shell account)))
(operating-system-users os))
"\n")
"\n")))
(define (render-master-passwd os)
(let ((groups (operating-system-groups os)))
(string-append
(string-join
(map (lambda (account)
(format #f "~a:*:~a:~a::0:0:~a:~a:~a"
(user-account-name account)
(user-account-uid account)
(or (group-name->gid groups (user-account-group account))
(error "unknown primary group" (user-account-group account)))
(user-account-comment account)
(user-account-home account)
(user-account-shell account)))
(operating-system-users os))
"\n")
"\n")))
(define (render-group os)
(let ((users (operating-system-users os)))
(string-append
(string-join
(map (lambda (group)
(let ((members (filter-map (lambda (account)
(and (member (user-group-name group)
(user-account-supplementary-groups account))
(user-account-name account)))
users)))
(format #f "~a:*:~a:~a"
(user-group-name group)
(user-group-gid group)
(string-join members ","))))
(operating-system-groups os))
"\n")
"\n")))
(define (fstab-fsck-fields fs)
(if (string=? (file-system-type fs) "ufs")
(if (string=? (file-system-mount-point fs) "/")
'(1 1)
'(2 2))
'(0 0)))
(define (render-fstab os)
(string-append
(string-join
(map (lambda (fs)
(let ((checks (fstab-fsck-fields fs)))
(format #f "~a\t~a\t~a\t~a\t~a\t~a"
(file-system-device fs)
(file-system-mount-point fs)
(file-system-type fs)
(file-system-options fs)
(first checks)
(second checks))))
(operating-system-file-systems os))
"\n")
"\n"))
(define (render-hosts os)
(string-append
"127.0.0.1\tlocalhost " (operating-system-host-name os) "\n"
"::1\tlocalhost\n"))
(define (render-shells os)
(let ((shells (delete-duplicates (map user-account-shell (operating-system-users os)))))
(string-append (string-join shells "\n") "\n")))
(define (render-motd os)
(string-append "Welcome to Fruix on FreeBSD (" (operating-system-host-name os) ")\n"))
(define (render-login-conf)
(string-append
"default:\\\n"
"\t:path=/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin:\\\n"
"\t:umask=022:\\\n"
"\t:charset=UTF-8:\\\n"
"\t:lang=C.UTF-8:\n"
"daemon:\\\n"
"\t:path=/sbin /bin /usr/sbin /usr/bin /usr/local/sbin /usr/local/bin:\\\n"
"\t:tc=default:\n"
"root:\\\n"
"\t:ignorenologin:\\\n"
"\t:tc=default:\n"))
(define (render-ttys)
(string-append
"console\tnone\tunknown\toff secure\n"
"ttyu0\tnone\tvt100\toff secure\n"
"xc0\tnone\txterm\toff secure\n"))
(define (render-root-authorized-keys os)
(if (null? (operating-system-root-authorized-keys os))
""
(string-append
(string-join (operating-system-root-authorized-keys os) "\n")
"\n")))
(define (render-sshd-config os)
(string-append
"Port 22\n"
"PermitRootLogin yes\n"
"PasswordAuthentication no\n"
"KbdInteractiveAuthentication no\n"
"ChallengeResponseAuthentication no\n"
"UsePAM no\n"
"PubkeyAuthentication yes\n"
"AuthorizedKeysFile .ssh/authorized_keys\n"
"PidFile /var/run/sshd.pid\n"
"UseDNS no\n"))
(define* (render-activation-script os #:key guile-store guile-extra-store shepherd-store)
(let* ((users (operating-system-users os))
(groups (operating-system-groups os))
(home-setup
(string-join
(map (lambda (account)
(let ((name (user-account-name account))
(uid (user-account-uid account))
(gid (or (group-name->gid groups (user-account-group account))
(error "unknown primary group" (user-account-group account))))
(home (user-account-home account))
(system? (user-account-system? account)))
(string-append
"mkdir -p " home "\n"
(if (or (string=? name "root") system?)
""
(format #f "if [ -x /usr/sbin/chown ]; then /usr/sbin/chown ~a:~a ~a 2>/dev/null || true; fi\n"
uid gid home)))))
users)
""))
(refresh-db-input-files
(string-join
(map (lambda (entry)
(match entry
((name mode)
(string-append
"if [ -f /run/current-system/etc/" name " ]; then rm -f /etc/" name "; cp /run/current-system/etc/" name " /etc/" name "; chmod " mode " /etc/" name "; fi\n"))))
'(("passwd" "0644")
("master.passwd" "0600")
("group" "0644")
("login.conf" "0644")))
""))
(ssh-section
(string-append
"mkdir -p /var/empty /etc/ssh /root/.ssh\n"
"chmod 700 /root/.ssh\n"
(if (null? (operating-system-root-authorized-keys os))
""
"if [ -f /run/current-system/root/.ssh/authorized_keys ]; then cp /run/current-system/root/.ssh/authorized_keys /root/.ssh/authorized_keys; chmod 600 /root/.ssh/authorized_keys; fi\n")
(if (sshd-enabled? os)
"if [ -x /usr/bin/ssh-keygen ]; then /usr/bin/ssh-keygen -A; fi\n"
""))))
(string-append
"#!/bin/sh\n"
"set -eu\n"
"logfile=/var/log/fruix-activate.log\n"
"mkdir -p /var/cron /var/db /var/lib/fruix /var/log /var/run /root /home /tmp\n"
": >> \"$logfile\"\n"
"trap 'status=$?; echo \"fruix-activate:exit status=$status\" >> \"$logfile\"' EXIT\n"
"echo \"fruix-activate:start\" >> \"$logfile\"\n"
"chmod 1777 /tmp\n"
refresh-db-input-files
"if [ -x /usr/bin/cap_mkdb ] && [ -f /etc/login.conf ]; then\n"
" if /usr/bin/cap_mkdb /etc/login.conf; then echo \"fruix-activate:cap_mkdb=ok\" >> \"$logfile\"; else echo \"fruix-activate:cap_mkdb=failed\" >> \"$logfile\"; fi\n"
"fi\n"
"if [ -x /usr/sbin/pwd_mkdb ] && [ -f /etc/master.passwd ]; then\n"
" if /usr/sbin/pwd_mkdb -p /etc/master.passwd; then echo \"fruix-activate:pwd_mkdb=ok\" >> \"$logfile\"; else echo \"fruix-activate:pwd_mkdb=failed\" >> \"$logfile\"; fi\n"
"fi\n"
home-setup
ssh-section
"echo \"fruix-activate:done\" >> \"$logfile\"\n")))
(define (pid1-mount-commands os)
(string-join
(filter-map (lambda (fs)
(and (not (string=? "/" (file-system-mount-point fs)))
(string-append
"mkdir -p '" (file-system-mount-point fs) "'\n"
"/sbin/mount -t '" (file-system-type fs)
"' -o '" (file-system-options fs)
"' '" (file-system-device fs)
"' '" (file-system-mount-point fs)
"' >/dev/null 2>&1 || true\n")))
(operating-system-file-systems os))
""))
(define (render-pid1-script os shepherd-store guile-store guile-extra-store)
(let ((ld-library-path (string-append guile-extra-store "/lib:"
guile-store "/lib:/usr/local/lib"))
(guile-system-path
(string-append guile-store "/share/guile/3.0:"
guile-store "/share/guile/site/3.0:"
guile-store "/share/guile/site:"
guile-store "/share/guile"))
(guile-load-path (string-append shepherd-store "/share/guile/site/3.0:"
guile-extra-store "/share/guile/site/3.0"))
(guile-system-compiled-path
(string-append guile-store "/lib/guile/3.0/ccache:"
guile-store "/lib/guile/3.0/site-ccache"))
(guile-load-compiled-path
(string-append shepherd-store "/lib/guile/3.0/site-ccache:"
guile-extra-store "/lib/guile/3.0/site-ccache"))
(guile-system-extensions-path (string-append guile-store "/lib/guile/3.0/extensions"))
(guile-extensions-path (string-append guile-extra-store "/lib/guile/3.0/extensions")))
(string-append
"#!/bin/sh\n"
"set -eu\n"
"PATH=/sbin:/bin:/usr/sbin:/usr/bin:/usr/local/sbin:/usr/local/bin\n"
"/sbin/mount -u -o rw / >/dev/null 2>&1 || true\n"
(pid1-mount-commands os)
"/bin/hostname '" (operating-system-host-name os) "' >/dev/null 2>&1 || true\n"
"/run/current-system/activate\n"
"export GUILE_AUTO_COMPILE=0\n"
"export LANG='C.UTF-8'\n"
"export LC_ALL='C.UTF-8'\n"
"export LD_LIBRARY_PATH='" ld-library-path "'\n"
"export GUILE_SYSTEM_PATH='" guile-system-path "'\n"
"export GUILE_LOAD_PATH='" guile-load-path "'\n"
"export GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "'\n"
"export GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "'\n"
"export GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "'\n"
"export GUILE_EXTENSIONS_PATH='" guile-extensions-path "'\n"
"exec " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/shepherd -I -s /var/run/shepherd.sock -c /run/current-system/shepherd/init.scm --pid=/var/run/shepherd.pid -l /var/log/shepherd.log\n")))
(define (render-shepherd-config os)
(let* ((ready-marker (operating-system-ready-marker os))
(pid1? (pid1-init-mode? os))
(start-sshd? (and pid1? (or (sshd-enabled? os)
(member 'sshd (operating-system-services os)))))
(ready-requirements (if start-sshd?
"'(fruix-logger sshd)"
"'(fruix-logger)"))
(pid1-helpers
(if pid1?
(string-append
"(define (run-command program . args)\n"
" (let ((status (apply system* program args)))\n"
" (unless (zero? status)\n"
" (error \"command failed\" (cons program args) status))\n"
" #t))\n\n"
"(define* (freebsd-rc-service provision script-name\n"
" #:key\n"
" (requirement '())\n"
" (documentation\n"
" \"Manage a FreeBSD rc.d service through 'service'.\"))\n"
" (service provision\n"
" #:documentation documentation\n"
" #:requirement requirement\n"
" #:start (lambda _\n"
" (run-command \"/usr/sbin/service\" script-name \"onestart\")\n"
" #t)\n"
" #:stop (lambda _\n"
" (run-command \"/usr/sbin/service\" script-name \"onestop\")\n"
" #f)\n"
" #:respawn? #f))\n\n")
""))
(pid1-services
(if pid1?
(string-append
(if start-sshd?
" (freebsd-rc-service '(netif) \"netif\"\n"
"")
(if start-sshd?
" #:requirement '(fruix-logger)\n"
"")
(if start-sshd?
" #:documentation \"Bring up FreeBSD networking from rc.conf.\")\n"
"")
(if start-sshd?
" (freebsd-rc-service '(sshd) \"sshd\"\n"
"")
(if start-sshd?
" #:requirement '(netif)\n"
"")
(if start-sshd?
" #:documentation \"Start OpenSSH under Shepherd PID 1.\")\n"
""))
"")))
(string-append
"(use-modules (shepherd service)\n"
" (ice-9 ftw)\n"
" (ice-9 popen))\n\n"
"(define ready-marker \"" ready-marker "\")\n\n"
"(define (mkdir-p* dir)\n"
" (unless (or (string=? dir \"\")\n"
" (string=? dir \"/\")\n"
" (file-exists? dir))\n"
" (mkdir-p* (dirname dir))\n"
" (mkdir dir)))\n\n"
"(define (ensure-parent-directory file)\n"
" (mkdir-p* (dirname file)))\n\n"
pid1-helpers
"(register-services\n"
" (list\n"
" (service '(fruix-logger)\n"
" #:documentation \"Append a boot trace line for Fruix.\"\n"
" #:start (lambda _\n"
" (ensure-parent-directory \"/var/log/fruix-shepherd.log\")\n"
" (let ((port (open-file \"/var/log/fruix-shepherd.log\" \"a\")))\n"
" (display \"fruix-shepherd-started\\n\" port)\n"
" (close-port port))\n"
" #t)\n"
" #:stop (lambda _ #f)\n"
" #:respawn? #f)\n"
pid1-services
" (service '(fruix-ready)\n"
" #:documentation \"Write the Fruix ready marker.\"\n"
" #:requirement " ready-requirements "\n"
" #:start (lambda _\n"
" (ensure-parent-directory ready-marker)\n"
" (call-with-output-file ready-marker\n"
" (lambda (port) (display \"ready\" port)))\n"
" #t)\n"
" #:stop (lambda _ #f)\n"
" #:respawn? #f)))\n\n"
"(start-service (lookup-service 'fruix-ready))\n")))
(define (render-activation-rc-script)
(string-append
"#!/bin/sh\n"
"# PROVIDE: fruix_activate\n"
"# REQUIRE: FILESYSTEMS\n"
"# BEFORE: LOGIN sshd fruix_shepherd\n"
"# KEYWORD: shutdown\n\n"
". /etc/rc.subr\n\n"
"name=fruix_activate\n"
"rcvar=fruix_activate_enable\n"
": ${fruix_activate_enable:=YES}\n"
"start_cmd=fruix_activate_start\n"
"stop_cmd=:\n\n"
"fruix_activate_start()\n"
"{\n"
" /run/current-system/activate\n"
"}\n\n"
"load_rc_config $name\n"
"run_rc_command \"$1\"\n"))
(define (render-rc-script shepherd-store guile-store guile-extra-store)
(let ((ld-library-path (string-append guile-extra-store "/lib:"
guile-store "/lib:/usr/local/lib"))
(guile-system-path
(string-append guile-store "/share/guile/3.0:"
guile-store "/share/guile/site/3.0:"
guile-store "/share/guile/site:"
guile-store "/share/guile"))
(guile-load-path (string-append shepherd-store "/share/guile/site/3.0:"
guile-extra-store "/share/guile/site/3.0"))
(guile-system-compiled-path
(string-append guile-store "/lib/guile/3.0/ccache:"
guile-store "/lib/guile/3.0/site-ccache"))
(guile-load-compiled-path
(string-append shepherd-store "/lib/guile/3.0/site-ccache:"
guile-extra-store "/lib/guile/3.0/site-ccache"))
(guile-system-extensions-path (string-append guile-store "/lib/guile/3.0/extensions"))
(guile-extensions-path (string-append guile-extra-store "/lib/guile/3.0/extensions")))
(string-append
"#!/bin/sh\n"
"# PROVIDE: fruix_shepherd\n"
"# REQUIRE: FILESYSTEMS fruix_activate\n"
"# BEFORE: LOGIN\n"
"# KEYWORD: shutdown\n\n"
". /etc/rc.subr\n\n"
"name=fruix_shepherd\n"
"rcvar=fruix_shepherd_enable\n"
": ${fruix_shepherd_enable:=YES}\n"
"pidfile=/var/run/shepherd.pid\n"
"socket=/var/run/shepherd.sock\n"
"config=/run/current-system/shepherd/init.scm\n"
"logfile=/var/log/shepherd.log\n"
"command=" shepherd-store "/bin/shepherd\n"
"start_cmd=fruix_shepherd_start\n"
"stop_cmd=fruix_shepherd_stop\n"
"status_cmd=fruix_shepherd_status\n\n"
"fruix_shepherd_start()\n"
"{\n"
" /usr/sbin/daemon -c -f -p \"$pidfile\" -o /var/log/shepherd-bootstrap.out /usr/bin/env \\\n"
" LANG='C.UTF-8' LC_ALL='C.UTF-8' \\\n"
" LD_LIBRARY_PATH='" ld-library-path "' \\\n"
" GUILE_SYSTEM_PATH='" guile-system-path "' \\\n"
" GUILE_LOAD_PATH='" guile-load-path "' \\\n"
" GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "' \\\n"
" GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "' \\\n"
" GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "' \\\n"
" GUILE_EXTENSIONS_PATH='" guile-extensions-path "' \\\n"
" " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/shepherd -I -s \"$socket\" -c \"$config\" -l \"$logfile\"\n"
" for _try in 1 2 3 4 5 6 7 8 9 10; do\n"
" [ -f \"$pidfile\" ] && [ -S \"$socket\" ] && return 0\n"
" sleep 1\n"
" done\n"
" return 1\n"
"}\n\n"
"fruix_shepherd_stop()\n"
"{\n"
" env LANG='C.UTF-8' LC_ALL='C.UTF-8' \\\n"
" LD_LIBRARY_PATH='" ld-library-path "' \\\n"
" GUILE_SYSTEM_PATH='" guile-system-path "' \\\n"
" GUILE_LOAD_PATH='" guile-load-path "' \\\n"
" GUILE_SYSTEM_COMPILED_PATH='" guile-system-compiled-path "' \\\n"
" GUILE_LOAD_COMPILED_PATH='" guile-load-compiled-path "' \\\n"
" GUILE_SYSTEM_EXTENSIONS_PATH='" guile-system-extensions-path "' \\\n"
" GUILE_EXTENSIONS_PATH='" guile-extensions-path "' \\\n"
" " guile-store "/bin/guile --no-auto-compile " shepherd-store "/bin/herd -s \"$socket\" stop root >/dev/null 2>&1 || true\n"
" for _try in 1 2 3 4 5 6 7 8 9 10; do\n"
" [ ! -f \"$pidfile\" ] && return 0\n"
" sleep 1\n"
" done\n"
" kill \"$(cat \"$pidfile\")\" >/dev/null 2>&1 || true\n"
" rm -f \"$pidfile\"\n"
" return 0\n"
"}\n\n"
"fruix_shepherd_status()\n"
"{\n"
" [ -f \"$pidfile\" ] && kill -0 \"$(cat \"$pidfile\")\" >/dev/null 2>&1\n"
"}\n\n"
"load_rc_config $name\n"
"run_rc_command \"$1\"\n")))
(define* (operating-system-generated-files os #:key guile-store guile-extra-store shepherd-store)
(append
`(("boot/loader.conf" . ,(render-loader-conf os))
("etc/rc.conf" . ,(render-rc.conf os))
("etc/fstab" . ,(render-fstab os))
("etc/hosts" . ,(render-hosts os))
("etc/passwd" . ,(render-passwd os))
("etc/master.passwd" . ,(render-master-passwd os))
("etc/group" . ,(render-group os))
("etc/login.conf" . ,(render-login-conf))
("etc/shells" . ,(render-shells os))
("etc/motd" . ,(render-motd os))
("etc/ttys" . ,(render-ttys))
("activate" . ,(render-activation-script os
#:guile-store guile-store
#:guile-extra-store guile-extra-store
#:shepherd-store shepherd-store))
("shepherd/init.scm" . ,(render-shepherd-config os)))
(if (pid1-init-mode? os)
`(("boot/fruix-pid1" . ,(render-pid1-script os shepherd-store guile-store guile-extra-store)))
'())
(if (sshd-enabled? os)
`(("etc/ssh/sshd_config" . ,(render-sshd-config os)))
'())
(if (null? (operating-system-root-authorized-keys os))
'()
`(("root/.ssh/authorized_keys" . ,(render-root-authorized-keys os))))))

203
modules/fruix/system/freebsd/source.scm Normal file
View File

@@ -0,0 +1,203 @@
(define-module (fruix system freebsd source)
#:use-module (fruix packages freebsd)
#:use-module (fruix system freebsd model)
#:use-module (fruix system freebsd utils)
#:use-module (guix build utils)
#:use-module (srfi srfi-13)
#:export (materialize-freebsd-source
freebsd-source-materialization-spec))
(define freebsd-source-materializer-version "2")
(define (string-downcase* value)
(list->string (map char-downcase (string->list value))))
(define (safe-name-fragment value)
(let* ((text (if (and (string? value) (not (string-null? value))) value "source"))
(chars (map (lambda (ch)
(if (or (char-alphabetic? ch)
(char-numeric? ch)
(memv ch '(#\- #\_ #\.)))
ch
#\-))
(string->list text))))
(list->string chars)))
(define (freebsd-source-manifest source effective-source identity)
(string-append
"materializer-version=" freebsd-source-materializer-version "\n"
"declared-source=\n"
(object->string (freebsd-source-spec source))
"\neffective-source=\n"
(object->string (freebsd-source-spec effective-source))
"\nidentity=\n"
(object->string identity)))
(define (ensure-git-source-cache source cache-dir)
(let* ((url (freebsd-source-url source))
(repo-dir (string-append cache-dir "/git/"
(string-hash (string-append "git:" url))
".git")))
(mkdir-p (dirname repo-dir))
(unless (file-exists? repo-dir)
(unless (zero? (system* "git" "init" "--quiet" "--bare" repo-dir))
(error "failed to initialize git source cache" repo-dir))
(unless (zero? (system* "git" "-C" repo-dir "remote" "add" "origin" url))
(error "failed to add git source remote" url)))
(let ((current-url (safe-command-output "git" "-C" repo-dir "remote" "get-url" "origin")))
(unless (and current-url (string=? current-url url))
(unless (zero? (system* "git" "-C" repo-dir "remote" "set-url" "origin" url))
(error "failed to update git source remote" url))))
repo-dir))
(define (resolve-git-freebsd-source source cache-dir)
(let* ((selector (or (freebsd-source-commit source)
(freebsd-source-ref source)
(error "git freebsd source requires a ref or commit" source)))
(repo-dir (ensure-git-source-cache source cache-dir)))
(unless (zero? (system* "git" "-C" repo-dir "fetch" "--quiet" "--depth" "1" "origin" selector))
(error "failed to fetch git freebsd source" selector))
(let ((resolved-commit (command-output "git" "-C" repo-dir "rev-parse" "FETCH_HEAD")))
`((cache-path . ,repo-dir)
(effective-source . ,(freebsd-source #:name (freebsd-source-name source)
#:kind 'git
#:url (freebsd-source-url source)
#:ref (freebsd-source-ref source)
#:commit resolved-commit
#:sha256 #f))
(identity . ((resolved-commit . ,resolved-commit)))
(populate-tree . ,(lambda (tree-root)
(let ((archive-path (string-append (dirname tree-root) "/git-export.tar")))
(unless (zero? (system* "git" "-C" repo-dir "archive"
"--format=tar" "-o" archive-path resolved-commit))
(error "failed to archive git freebsd source" resolved-commit))
(unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root))
(error "failed to extract archived git freebsd source" archive-path))
(delete-path-if-exists archive-path))))))))
(define (normalize-expected-sha256 source)
(let ((sha256 (freebsd-source-sha256 source)))
(and sha256 (string-downcase* sha256))))
(define (resolve-txz-freebsd-source source cache-dir)
(let* ((url (freebsd-source-url source))
(expected-sha256 (or (normalize-expected-sha256 source)
(error "src-txz freebsd source requires sha256 for materialization" source)))
(archive-path (string-append cache-dir "/archives/"
(string-hash (string-append "txz:" url))
"-src.txz")))
(mkdir-p (dirname archive-path))
(when (file-exists? archive-path)
(let ((actual (string-downcase* (file-hash archive-path))))
(unless (string=? actual expected-sha256)
(delete-file archive-path))))
(unless (file-exists? archive-path)
(unless (zero? (system* "fetch" "-q" "-o" archive-path url))
(error "failed to download FreeBSD src.txz source" url)))
(let ((actual-sha256 (string-downcase* (file-hash archive-path))))
(unless (string=? actual-sha256 expected-sha256)
(error "downloaded src.txz hash mismatch" url expected-sha256 actual-sha256))
`((cache-path . ,archive-path)
(effective-source . ,(freebsd-source #:name (freebsd-source-name source)
#:kind 'src-txz
#:url url
#:path #f
#:ref #f
#:commit #f
#:sha256 actual-sha256))
(identity . ((archive-sha256 . ,actual-sha256)))
(populate-tree . ,(lambda (tree-root)
(unless (zero? (system* "tar" "-xpf" archive-path "-C" tree-root))
(error "failed to extract FreeBSD src.txz source" archive-path))))))))
(define (resolve-local-freebsd-source source)
(let* ((path (freebsd-source-path source))
(tree-sha256 (native-build-source-tree-sha256 path)))
`((cache-path . #f)
(effective-source . ,(freebsd-source #:name (freebsd-source-name source)
#:kind 'local-tree
#:url #f
#:path path
#:ref #f
#:commit #f
#:sha256 tree-sha256))
(identity . ((tree-sha256 . ,tree-sha256)))
(populate-tree . ,(lambda (tree-root)
(copy-tree-contents path tree-root))))))
(define (detect-materialized-source-relative-root tree-root)
(cond
((file-exists? (string-append tree-root "/Makefile"))
"tree")
((file-exists? (string-append tree-root "/usr/src/Makefile"))
"tree/usr/src")
(else
"tree")))
(define* (materialize-freebsd-source source #:key
(store-dir "/frx/store")
(cache-dir "/frx/var/cache/fruix/freebsd-source"))
(validate-freebsd-source source)
(let* ((resolution (case (freebsd-source-kind source)
((local-tree)
(resolve-local-freebsd-source source))
((git)
(resolve-git-freebsd-source source cache-dir))
((src-txz)
(resolve-txz-freebsd-source source cache-dir))
(else
(error "unsupported freebsd source kind" (freebsd-source-kind source)))))
(effective-source (assoc-ref resolution 'effective-source))
(identity (assoc-ref resolution 'identity))
(manifest (freebsd-source-manifest source effective-source identity))
(hash (string-hash manifest))
(output-path (string-append store-dir "/" hash "-freebsd-source-"
(safe-name-fragment (freebsd-source-name source))))
(info-file (string-append output-path "/.freebsd-source-info.scm"))
(cache-path (assoc-ref resolution 'cache-path))
(populate-tree (assoc-ref resolution 'populate-tree)))
(unless (file-exists? output-path)
(let* ((temp-output (string-append output-path ".tmp"))
(temp-tree-root (string-append temp-output "/tree")))
(delete-path-if-exists temp-output)
(mkdir-p temp-tree-root)
(populate-tree temp-tree-root)
(let* ((relative-root (detect-materialized-source-relative-root temp-tree-root))
(source-root (string-append output-path "/" relative-root))
(temp-source-root (string-append temp-output "/" relative-root))
(tree-sha256 (native-build-source-tree-sha256 temp-source-root)))
(write-file (string-append temp-output "/.references") "")
(write-file (string-append temp-output "/.fruix-source") manifest)
(write-file (string-append temp-output "/.freebsd-source-info.scm")
(object->string
`((materializer-version . ,freebsd-source-materializer-version)
(declared-source . ,(freebsd-source-spec source))
(effective-source . ,(freebsd-source-spec effective-source))
(identity . ,identity)
(source-store . ,output-path)
(source-root . ,source-root)
(source-tree-sha256 . ,tree-sha256)
(cache-path . ,cache-path)))))
(rename-file temp-output output-path)))
(call-with-input-file info-file
(lambda (port)
(let* ((info (read port))
(effective (assoc-ref info 'effective-source)))
`((source-store-path . ,output-path)
(source-root . ,(assoc-ref info 'source-root))
(source-info-file . ,info-file)
(source-tree-sha256 . ,(assoc-ref info 'source-tree-sha256))
(cache-path . ,(assoc-ref info 'cache-path))
(effective-source . ,effective)
(effective-commit . ,(assoc-ref effective 'commit))
(effective-sha256 . ,(assoc-ref effective 'sha256))))))))
(define (freebsd-source-materialization-spec result)
`((source-store-path . ,(assoc-ref result 'source-store-path))
(source-root . ,(assoc-ref result 'source-root))
(source-info-file . ,(assoc-ref result 'source-info-file))
(source-tree-sha256 . ,(assoc-ref result 'source-tree-sha256))
(cache-path . ,(assoc-ref result 'cache-path))
(effective-source . ,(assoc-ref result 'effective-source))))

243
modules/fruix/system/freebsd/utils.scm Normal file
View File

@@ -0,0 +1,243 @@
(define-module (fruix system freebsd utils)
#:use-module (guix build utils)
#:use-module (ice-9 ftw)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 hash-table)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-13)
#:use-module (rnrs io ports)
#:export (getenv*
trim-trailing-newlines
command-output
safe-command-output
write-file
string-hash
file-hash
directory-entries
path-signature
install-plan-signature
native-build-source-tree-sha256
copy-regular-file
copy-node
materialize-plan-entry
delete-path-if-exists
stage-tree-into-output
string-replace-all
rewrite-text-file
delete-file-if-exists
copy-tree-contents
path-basename
read-lines
run-command
store-reference-closure
copy-store-items-into-rootfs
copy-rootfs-for-image
mktemp-directory))
(define (getenv* name default)
(or (getenv name) default))
(define (trim-trailing-newlines str)
(let loop ((len (string-length str)))
(if (and (> len 0)
(char=? (string-ref str (- len 1)) #\newline))
(loop (- len 1))
(substring str 0 len))))
(define (command-output program . args)
(let* ((port (apply open-pipe* OPEN_READ program args))
(output (get-string-all port))
(status (close-pipe port)))
(unless (zero? status)
(error (format #f "command failed: ~a ~s => ~a" program args status)))
(trim-trailing-newlines output)))
(define (safe-command-output program . args)
(false-if-exception (apply command-output program args)))
(define (write-file path content)
(mkdir-p (dirname path))
(call-with-output-file path
(lambda (port)
(display content port))))
(define (string-hash text)
(let* ((tmp (string-append (getenv* "TMPDIR" "/tmp") "/fruix-system-hash.txt")))
(write-file tmp text)
(command-output "sha256" "-q" tmp)))
(define (file-hash path)
(command-output "sha256" "-q" path))
(define (directory-entries path)
(sort (filter (lambda (entry)
(not (member entry '("." ".."))))
(scandir path))
string<?))
(define (path-signature path)
(let ((st (lstat path)))
(case (stat:type st)
((regular)
(string-append "file:" path ":" (file-hash path)))
((symlink)
(string-append "symlink:" path ":" (readlink path)))
((directory)
(string-join
(cons (string-append "directory:" path)
(apply append
(map (lambda (entry)
(list (path-signature (string-append path "/" entry))))
(directory-entries path))))
"\n"))
(else
(string-append "other:" path ":" (symbol->string (stat:type st)))))))
(define (install-plan-signature entry)
(match entry
(('file source target)
(string-append "file-target:" target "\n" (path-signature source)))
(('directory source target)
(string-append "directory-target:" target "\n" (path-signature source)))
(_
(error (format #f "unsupported install plan entry: ~s" entry)))))
(define (native-build-source-tree-sha256 source-root)
(let* ((mtree-output (command-output "mtree" "-c" "-k" "type,link,size,mode,sha256digest" "-p" source-root))
(stable-lines (filter (lambda (line)
(not (string-prefix? "#" line)))
(string-split mtree-output #\newline))))
(string-hash (string-join stable-lines "\n"))))
(define (copy-regular-file source destination)
(let ((mode (stat:perms (stat source))))
(copy-file source destination)
(chmod destination mode)))
(define (copy-node source destination)
(let ((kind (stat:type (lstat source))))
(mkdir-p (dirname destination))
(case kind
((directory)
(mkdir-p destination)
(for-each (lambda (entry)
(copy-node (string-append source "/" entry)
(string-append destination "/" entry)))
(directory-entries source)))
((symlink)
(symlink (readlink source) destination))
(else
(copy-regular-file source destination)))))
(define (materialize-plan-entry output-path entry)
(match entry
(('file source target)
(copy-node source (string-append output-path "/" target)))
(('directory source target)
(copy-node source (string-append output-path "/" target)))
(_
(error (format #f "unsupported install plan entry: ~s" entry)))))
(define (clear-file-flags path)
(false-if-exception (system* "chflags" "-R" "noschg,nouchg" path)))
(define (delete-path-if-exists path)
(when (or (file-exists? path) (false-if-exception (readlink path)))
(clear-file-flags path)
(let ((kind (stat:type (lstat path))))
(case kind
((directory) (delete-file-recursively path))
(else (delete-file path))))))
(define (stage-tree-into-output stage-root output-path)
(mkdir-p output-path)
(for-each (lambda (entry)
(copy-node (string-append stage-root "/" entry)
(string-append output-path "/" entry)))
(directory-entries stage-root)))
(define (string-replace-all str old new)
(let ((old-len (string-length old)))
(let loop ((start 0) (chunks '()))
(let ((index (string-contains str old start)))
(if index
(loop (+ index old-len)
(cons new
(cons (substring str start index) chunks)))
(apply string-append
(reverse (cons (substring str start) chunks))))))))
(define (rewrite-text-file path replacements)
(when (file-exists? path)
(let* ((mode (stat:perms (stat path)))
(original (call-with-input-file path get-string-all))
(updated (fold (lambda (replacement text)
(string-replace-all text (car replacement) (cdr replacement)))
original
replacements)))
(unless (string=? original updated)
(write-file path updated)
(chmod path mode)))))
(define (delete-file-if-exists path)
(when (file-exists? path)
(delete-file path)))
(define (copy-tree-contents source-root target-root)
(mkdir-p target-root)
(for-each (lambda (entry)
(copy-node (string-append source-root "/" entry)
(string-append target-root "/" entry)))
(directory-entries source-root)))
(define (path-basename path)
(let ((parts (filter (lambda (part) (not (string-null? part)))
(string-split path #\/))))
(if (null? parts)
path
(last parts))))
(define (read-lines path)
(if (file-exists? path)
(filter (lambda (line) (not (string-null? line)))
(string-split (call-with-input-file path get-string-all) #\newline))
'()))
(define (run-command . args)
(let ((status (apply system* args)))
(unless (zero? status)
(error "command failed" args status))
#t))
(define (store-reference-closure roots)
(let ((seen (make-hash-table))
(result '()))
(define (visit item)
(unless (hash-ref seen item #f)
(hash-set! seen item #t)
(set! result (cons item result))
(for-each visit (read-lines (string-append item "/.references")))))
(for-each visit roots)
(reverse result)))
(define (copy-store-items-into-rootfs rootfs store-dir items)
(let ((store-root (string-append rootfs store-dir)))
(mkdir-p store-root)
(for-each (lambda (item)
(copy-node item (string-append store-root "/" (path-basename item))))
items)))
(define (copy-rootfs-for-image source-rootfs image-rootfs)
(when (file-exists? image-rootfs)
(delete-file-recursively image-rootfs))
(copy-node source-rootfs image-rootfs))
(define (mktemp-directory pattern)
(command-output "mktemp" "-d" pattern))