205 lines
11 KiB
Scheme
205 lines
11 KiB
Scheme
(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/"
|
|
(sha256-string (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/"
|
|
(sha256-string (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))
|
|
(display-name (string-append "freebsd-source-"
|
|
(safe-name-fragment (freebsd-source-name source))))
|
|
(output-path (make-store-path store-dir display-name manifest
|
|
#:kind 'freebsd-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))))
|
|
|