259 lines
11 KiB
Scheme
259 lines
11 KiB
Scheme
(use-modules (fruix packages freebsd)
|
|
(guix build utils)
|
|
(ice-9 format)
|
|
(ice-9 ftw)
|
|
(ice-9 match)
|
|
(ice-9 popen)
|
|
(srfi srfi-1)
|
|
(srfi srfi-13)
|
|
(rnrs io ports))
|
|
|
|
(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 workdir
|
|
(or (getenv "WORKDIR")
|
|
(error "WORKDIR environment variable is required")))
|
|
(define store-dir
|
|
(string-append workdir "/store"))
|
|
(define profile-dir
|
|
(string-append workdir "/profiles/freebsd-development"))
|
|
(define build-dir
|
|
(string-append workdir "/profile-build"))
|
|
(define metadata-file
|
|
(string-append workdir "/freebsd-package-profile-prototype-metadata.txt"))
|
|
(define built-package-paths '())
|
|
|
|
(define (sha256-string text)
|
|
(let ((temp-file (string-append workdir "/hash-input.txt")))
|
|
(call-with-output-file temp-file
|
|
(lambda (port)
|
|
(display text port)))
|
|
(command-output "sha256" "-q" temp-file)))
|
|
|
|
(define (package-manifest-string package)
|
|
(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 (map freebsd-package-name
|
|
(freebsd-package-inputs package)) ",") "\n"
|
|
"install-plan=" (object->string (freebsd-package-install-plan package))))
|
|
|
|
(define (package-output-path package)
|
|
(let ((cached (assoc-ref built-package-paths (freebsd-package-name package))))
|
|
(if cached
|
|
cached
|
|
#f)))
|
|
|
|
(define (remember-package-output! package path)
|
|
(set! built-package-paths
|
|
(acons (freebsd-package-name package) path built-package-paths)))
|
|
|
|
(define (write-file path content)
|
|
(call-with-output-file path
|
|
(lambda (port)
|
|
(display content port))))
|
|
|
|
(define (install-wrapper source destination)
|
|
(write-file destination
|
|
(string-append "#!/bin/sh\nexec " source " \"$@\"\n"))
|
|
(chmod destination #o555))
|
|
|
|
(define (materialize-plan-entry output-path entry)
|
|
(match entry
|
|
(('file source target)
|
|
(let ((destination (string-append output-path "/" target)))
|
|
(mkdir-p (dirname destination))
|
|
(if (string-prefix? "bin/" target)
|
|
(install-wrapper source destination)
|
|
(symlink source destination))))
|
|
(('directory source target)
|
|
(let ((destination (string-append output-path "/" target)))
|
|
(mkdir-p (dirname destination))
|
|
(copy-recursively source destination)))
|
|
(_
|
|
(error (format #f "unsupported install plan entry: ~s" entry)))))
|
|
|
|
(define (materialize-package package)
|
|
(or (package-output-path package)
|
|
(let* ((input-paths (map materialize-package
|
|
(freebsd-package-inputs package)))
|
|
(hash (sha256-string (package-manifest-string package)))
|
|
(output-path (string-append store-dir "/" hash "-"
|
|
(freebsd-package-name package)
|
|
"-" (freebsd-package-version package))))
|
|
(unless (file-exists? output-path)
|
|
(mkdir-p output-path)
|
|
(for-each (lambda (entry)
|
|
(materialize-plan-entry output-path entry))
|
|
(freebsd-package-install-plan package))
|
|
(write-file (string-append output-path "/.references")
|
|
(string-join input-paths "\n"))
|
|
(write-file (string-append output-path "/.fruix-package")
|
|
(package-manifest-string package)))
|
|
(remember-package-output! package output-path)
|
|
output-path)))
|
|
|
|
(define (directory-entries path)
|
|
(filter (lambda (entry)
|
|
(not (member entry '("." ".."))))
|
|
(scandir path)))
|
|
|
|
(define (merge-output-into-profile output-path profile-root)
|
|
(define (walk relative)
|
|
(let ((source (if (string-null? relative)
|
|
output-path
|
|
(string-append output-path "/" relative))))
|
|
(for-each
|
|
(lambda (entry)
|
|
(unless (member entry '(".references" ".fruix-package"))
|
|
(let* ((entry-relative (if (string-null? relative)
|
|
entry
|
|
(string-append relative "/" entry)))
|
|
(source-entry (string-append output-path "/" entry-relative))
|
|
(target-entry (string-append profile-root "/" entry-relative))
|
|
(st (lstat source-entry)))
|
|
(if (eq? 'directory (stat:type st))
|
|
(begin
|
|
(mkdir-p target-entry)
|
|
(walk entry-relative))
|
|
(begin
|
|
(mkdir-p (dirname target-entry))
|
|
(if (file-exists? target-entry)
|
|
(let ((existing (false-if-exception (readlink target-entry))))
|
|
(unless (or (and existing
|
|
(string=? existing source-entry))
|
|
(and existing
|
|
(file-exists? existing)
|
|
(same-file-contents? existing source-entry)))
|
|
(error (format #f "profile collision for ~a" target-entry))))
|
|
(symlink source-entry target-entry)))))))
|
|
(directory-entries source))))
|
|
(mkdir-p profile-root)
|
|
(walk ""))
|
|
|
|
(define (profile-file path)
|
|
(string-append profile-dir "/" path))
|
|
|
|
(define (assert-file-exists path)
|
|
(unless (file-exists? path)
|
|
(error (format #f "required file missing: ~a" path))))
|
|
|
|
(define (same-file-contents? a b)
|
|
(zero? (system* "cmp" "-s" a b)))
|
|
|
|
(define (validate-profile)
|
|
(let* ((bash-version (command-output (profile-file "bin/bash") "--version"))
|
|
(make-version (command-output (profile-file "bin/make") "--version"))
|
|
(autoconf-version (command-output (profile-file "bin/autoconf") "--version"))
|
|
(cc-version (command-output (profile-file "bin/cc") "--version"))
|
|
(hello-source (string-append build-dir "/hello.c"))
|
|
(hello-binary (string-append build-dir "/hello"))
|
|
(hello-output
|
|
(begin
|
|
(mkdir-p build-dir)
|
|
(write-file hello-source
|
|
"#include <stdio.h>\nint main(void){puts(\"hello-from-freebsd-profile\");return 0;}\n")
|
|
(command-output (profile-file "bin/sh") "-c"
|
|
(string-append
|
|
"PATH=" profile-dir "/bin:/usr/bin:/bin "
|
|
"CPPFLAGS=-I" profile-dir "/include "
|
|
"LDFLAGS=-L" profile-dir "/lib "
|
|
(profile-file "bin/cc") " " hello-source
|
|
" -o " hello-binary
|
|
" && " hello-binary)))))
|
|
(for-each assert-file-exists
|
|
(list (profile-file "bin/sh")
|
|
(profile-file "bin/bash")
|
|
(profile-file "bin/cc")
|
|
(profile-file "bin/make")
|
|
(profile-file "bin/autoreconf")
|
|
(profile-file "bin/pkg-config")
|
|
(profile-file "include/sys/param.h")
|
|
(profile-file "lib/libc.so.7")
|
|
(profile-file "lib/libcrypto.so")
|
|
(profile-file "lib/libz.so.6")
|
|
(profile-file "boot/kernel/kernel")))
|
|
(unless (string-prefix? "GNU bash, version" (car (string-split bash-version #\newline)))
|
|
(error "unexpected bash version output"))
|
|
(unless (string-prefix? "GNU Make" (car (string-split make-version #\newline)))
|
|
(error "unexpected make version output"))
|
|
(unless (string-prefix? "autoconf" (car (string-split autoconf-version #\newline)))
|
|
(error "unexpected autoconf version output"))
|
|
(unless (string-contains cc-version "FreeBSD clang version")
|
|
(error "unexpected cc version output"))
|
|
(unless (string=? hello-output "hello-from-freebsd-profile")
|
|
(error (format #f "unexpected hello output: ~s" hello-output)))
|
|
`((bash-version . ,(car (string-split bash-version #\newline)))
|
|
(make-version . ,(car (string-split make-version #\newline)))
|
|
(autoconf-version . ,(car (string-split autoconf-version #\newline)))
|
|
(cc-version . ,(car (string-split cc-version #\newline)))
|
|
(hello-output . ,hello-output))))
|
|
|
|
(mkdir-p workdir)
|
|
(mkdir-p store-dir)
|
|
(mkdir-p profile-dir)
|
|
|
|
(let* ((core-paths (map materialize-package %freebsd-core-packages))
|
|
(profile-package-paths (map materialize-package
|
|
%freebsd-development-profile-packages))
|
|
(validation (begin
|
|
(for-each (lambda (path)
|
|
(merge-output-into-profile path profile-dir))
|
|
profile-package-paths)
|
|
(validate-profile))))
|
|
(call-with-output-file metadata-file
|
|
(lambda (port)
|
|
(format port "workdir=~a~%" workdir)
|
|
(format port "store_dir=~a~%" store-dir)
|
|
(format port "profile_dir=~a~%" profile-dir)
|
|
(format port "core_package_count=~a~%" (length %freebsd-core-packages))
|
|
(format port "profile_package_count=~a~%"
|
|
(length %freebsd-development-profile-packages))
|
|
(for-each
|
|
(lambda (package)
|
|
(format port "package=~a version=~a build_system=~a inputs=~a~%"
|
|
(freebsd-package-name package)
|
|
(freebsd-package-version package)
|
|
(freebsd-package-build-system package)
|
|
(map freebsd-package-name (freebsd-package-inputs package))))
|
|
%freebsd-core-packages)
|
|
(for-each
|
|
(lambda (path)
|
|
(format port "store_item=~a~%" path))
|
|
core-paths)
|
|
(format port "bash_version=~a~%" (assoc-ref validation 'bash-version))
|
|
(format port "make_version=~a~%" (assoc-ref validation 'make-version))
|
|
(format port "autoconf_version=~a~%" (assoc-ref validation 'autoconf-version))
|
|
(format port "cc_version=~a~%" (assoc-ref validation 'cc-version))
|
|
(format port "hello_output=~a~%" (assoc-ref validation 'hello-output))))
|
|
|
|
(when (getenv "METADATA_OUT")
|
|
(mkdir-p (dirname (getenv "METADATA_OUT")))
|
|
(copy-file metadata-file (getenv "METADATA_OUT")))
|
|
|
|
(format #t "PASS freebsd-package-profile-prototype~%")
|
|
(format #t "Profile directory: ~a~%" profile-dir)
|
|
(format #t "Metadata file: ~a~%" metadata-file)
|
|
(when (getenv "METADATA_OUT")
|
|
(format #t "Copied metadata to: ~a~%" (getenv "METADATA_OUT")))
|
|
(display "--- metadata ---\n")
|
|
(display (call-with-input-file metadata-file get-string-all)))
|