Validate GNU which builder phases on FreeBSD

tests/native-build/gnu-which-guix-phase-runner.scm

@@ -0,0 +1,175 @@
+(use-modules (guix base32)
+             (guix build gnu-build-system)
+             (guix build utils)
+             (ice-9 format)
+             (ice-9 match)
+             (ice-9 popen)
+             (srfi srfi-1)
+             (rnrs bytevectors)
+             (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 (nix-base32->hex str)
+  (string-concatenate
+   (map (lambda (byte)
+          (format #f "~2,'0x" byte))
+        (bytevector->u8-list (nix-base32-string->bytevector str)))))
+
+(define (phase-subset names)
+  (filter (match-lambda
+            ((name . _)
+             (memq name names)))
+          %standard-phases))
+
+(define (maybe-read-test-log source-dir)
+  (match (find-files source-dir "(^|/)(test-suite\\.log|testsuite\\.log)$")
+    ((file . _)
+     (call-with-input-file file get-string-all))
+    (()
+     "<no test-suite.log or testsuite.log found>")))
+
+(define (with-path path thunk)
+  (let ((original (getenv "PATH")))
+    (dynamic-wind
+      (lambda ()
+        (setenv "PATH" path))
+      thunk
+      (lambda ()
+        (if original
+            (setenv "PATH" original)
+            (unsetenv "PATH"))))))
+
+(define (host-triplet-from-source source-dir)
+  (with-directory-excursion source-dir
+    (cond
+     ((file-exists? "build-aux/config.guess")
+      (command-output "sh" "build-aux/config.guess"))
+     ((file-exists? "config.guess")
+      (command-output "sh" "config.guess"))
+     (else
+      (command-output "cc" "-dumpmachine")))))
+
+(define workdir
+  (or (getenv "WORKDIR")
+      (error "WORKDIR environment variable is required")))
+
+(define which-version
+  (getenv* "WHICH_VERSION" "2.21"))
+(define expected-nix-base32
+  (getenv* "WHICH_NIX_BASE32" "1bgafvy3ypbhhfznwjv1lxmd6mci3x1byilnnkc7gcr486wlb8pl"))
+(define source-url
+  (getenv* "WHICH_SOURCE_URL"
+           (string-append "https://ftp.gnu.org/gnu/which/which-"
+                          which-version ".tar.gz")))
+(define guix-source-dir
+  (getenv* "GUIX_SOURCE_DIR"
+           (string-append (getenv "HOME") "/repos/guix")))
+(define output-dir
+  (string-append workdir "/0000000000000000-which-" which-version))
+(define source-tarball
+  (string-append workdir "/which-" which-version ".tar.gz"))
+(define source-dir
+  (string-append workdir "/which-" which-version))
+(define metadata-file
+  (string-append workdir "/gnu-which-guix-phase-runner-metadata.txt"))
+(define expected-sha256-hex
+  (nix-base32->hex expected-nix-base32))
+(define selected-phase-names
+  '(set-SOURCE-DATE-EPOCH unpack configure build check install))
+(define selected-phases
+  (phase-subset selected-phase-names))
+(define run-path "/bin:/usr/bin")
+(define expected-which-output "/bin/sh")
+
+(setenv "NIX_BUILD_TOP" workdir)
+(mkdir-p workdir)
+
+(format #t "Using workdir: ~a~%" workdir)
+(format #t "Using Guix source: ~a~%" guix-source-dir)
+(format #t "Fetching source: ~a~%" source-url)
+(invoke "fetch" "-o" source-tarball source-url)
+
+(let ((actual-sha256-hex (command-output "sha256" "-q" source-tarball)))
+  (unless (string=? actual-sha256-hex expected-sha256-hex)
+    (error (format #f "sha256 mismatch: expected ~a but got ~a"
+                   expected-sha256-hex actual-sha256-hex)))
+
+  (format #t "Verified SHA256: ~a~%" actual-sha256-hex)
+  (format #t "Running Guix builder phases: ~s~%" selected-phase-names)
+
+  (with-directory-excursion workdir
+    (gnu-build #:source source-tarball
+               #:outputs `(("out" . ,output-dir))
+               #:phases selected-phases
+               #:tests? #t))
+
+  (let* ((installed-binary (string-append output-dir "/bin/which"))
+         (which-output (with-path run-path
+                         (lambda ()
+                           (command-output installed-binary "sh"))))
+         (host-triplet (host-triplet-from-source source-dir))
+         (binary-file (command-output "file" installed-binary))
+         (runtime-deps (command-output "ldd" installed-binary))
+         (check-summary (maybe-read-test-log source-dir))
+         (guile-bin (or (getenv "GUILE_BIN") "<unset>"))
+         (uname-string (command-output "uname" "-a")))
+    (unless (string=? which-output expected-which-output)
+      (error (format #f "unexpected which output: ~s" which-output)))
+
+    (call-with-output-file metadata-file
+      (lambda (port)
+        (format port "which_version=~a~%" which-version)
+        (format port "source_url=~a~%" source-url)
+        (format port "expected_nix_base32=~a~%" expected-nix-base32)
+        (format port "expected_sha256_hex=~a~%" expected-sha256-hex)
+        (format port "actual_sha256_hex=~a~%" actual-sha256-hex)
+        (format port "guix_source_dir=~a~%" guix-source-dir)
+        (format port "guile_bin=~a~%" guile-bin)
+        (format port "workdir=~a~%" workdir)
+        (format port "source_tarball=~a~%" source-tarball)
+        (format port "source_dir=~a~%" source-dir)
+        (format port "output_dir=~a~%" output-dir)
+        (format port "installed_binary=~a~%" installed-binary)
+        (format port "run_path=~a~%" run-path)
+        (format port "which_output=~a~%" which-output)
+        (format port "expected_which_output=~a~%" expected-which-output)
+        (format port "host_triplet=~a~%" host-triplet)
+        (format port "selected_phases=~s~%" selected-phase-names)
+        (format port "check_phase=passed~%")
+        (format port "binary_file=~a~%" binary-file)
+        (format port "uname=~a~%" uname-string)
+        (format port "check_summary_begin~%~a~%check_summary_end~%"
+                check-summary)
+        (format port "runtime_deps_begin~%~a~%runtime_deps_end~%"
+                runtime-deps)))
+
+    (when (getenv "METADATA_OUT")
+      (mkdir-p (dirname (getenv "METADATA_OUT")))
+      (copy-file metadata-file (getenv "METADATA_OUT")))
+
+    (format #t "PASS gnu-which-guix-phase-runner~%")
+    (format #t "Which output: ~a~%" which-output)
+    (format #t "Installed binary: ~a~%" installed-binary)
+    (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))))