(use-modules (guix base32)
             (guix build gnu-build-system)
             (guix build utils)
             (ice-9 format)
             (ice-9 match)
             (ice-9 popen)
             (ice-9 regex)
             (srfi srfi-1)
             (srfi srfi-13)
             (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 (insert-phase-before phases target-name new-phase)
  (let loop ((remaining phases) (result '()))
    (match remaining
      (()
       (reverse (cons new-phase result)))
      (((name . proc) . rest)
       (if (eq? name target-name)
           (append (reverse result)
                   (list new-phase (cons name proc))
                   rest)
           (loop rest (cons (cons name proc) result)))))))

(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 (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 (make-tool-link directory name target)
  (let ((link (string-append directory "/" name)))
    (when (file-exists? link)
      (delete-file link))
    (symlink target link)))

(define (prepend-path directory)
  (let ((original (getenv "PATH")))
    (if original
        (setenv "PATH" (string-append directory ":" original))
        (setenv "PATH" directory))))

(define (freebsd-setup-environment workdir)
  (let* ((tools-dir (string-append workdir "/freebsd-tools"))
         (gmake (if (file-exists? "/usr/local/bin/gmake")
                    "/usr/local/bin/gmake"
                    "/usr/bin/make"))
         (cc (if (file-exists? "/usr/bin/cc")
                 "/usr/bin/cc"
                 (command-output "sh" "-c" "command -v cc")))
         (cxx (cond
               ((file-exists? "/usr/bin/c++") "/usr/bin/c++")
               ((file-exists? "/usr/bin/clang++") "/usr/bin/clang++")
               (else (command-output "sh" "-c" "command -v c++")))))
    (mkdir-p tools-dir)
    (make-tool-link tools-dir "make" gmake)
    (make-tool-link tools-dir "gmake" gmake)
    (make-tool-link tools-dir "cc" cc)
    (make-tool-link tools-dir "gcc" cc)
    (make-tool-link tools-dir "c++" cxx)
    (make-tool-link tools-dir "g++" cxx)
    (prepend-path tools-dir)
    (setenv "CC" cc)
    (setenv "CXX" cxx)
    (setenv "CONFIG_SHELL" "/bin/sh")
    (setenv "PKG_CONFIG" "/usr/local/bin/pkg-config")
    (setenv "PKG_CONFIG_PATH"
            "/usr/local/libdata/pkgconfig:/usr/local/lib/pkgconfig")
    (setenv "CPPFLAGS" "-I/usr/local/include")
    (setenv "LDFLAGS" "-L/usr/local/lib -Wl,-rpath,/usr/local/lib")
    tools-dir))

(define workdir
  (or (getenv "WORKDIR")
      (error "WORKDIR environment variable is required")))

(define package-name
  (or (getenv "PACKAGE_NAME")
      (error "PACKAGE_NAME environment variable is required")))
(define package-version
  (or (getenv "PACKAGE_VERSION")
      (error "PACKAGE_VERSION environment variable is required")))
(define source-url
  (or (getenv "PACKAGE_SOURCE_URL")
      (error "PACKAGE_SOURCE_URL environment variable is required")))
(define expected-nix-base32
  (or (getenv "PACKAGE_NIX_BASE32")
      (error "PACKAGE_NIX_BASE32 environment variable is required")))
(define verify-kind
  (or (getenv "VERIFY_KIND")
      (error "VERIFY_KIND environment variable is required")))
(define binary-relative-path
  (or (getenv "BINARY_RELATIVE_PATH")
      (error "BINARY_RELATIVE_PATH environment variable is required")))
(define version-prefix
  (getenv* "VERSION_PREFIX" ""))
(define run-tests?
  (not (string=? (getenv* "RUN_TESTS" "1") "0")))
(define guix-source-dir
  (getenv* "GUIX_SOURCE_DIR"
           (string-append (getenv "HOME") "/repos/guix")))
(define output-dir
  (string-append workdir "/0000000000000000-" package-name "-" package-version))
(define source-basename
  (basename source-url))
(define source-tarball
  (string-append workdir "/" source-basename))
(define source-dir
  (string-append workdir "/" package-name "-" package-version))
(define metadata-file
  (string-append workdir "/" package-name "-freebsd-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 adapted-tools-dir
  (string-append workdir "/freebsd-tools"))
(define selected-phases
  (insert-phase-before (phase-subset selected-phase-names)
                       'configure
                       (cons 'freebsd-setup-environment
                             (lambda* (#:key #:allow-other-keys)
                               (freebsd-setup-environment workdir)
                               #t))))

(define (write-file path content)
  (call-with-output-file path
    (lambda (port)
      (display content port))))

(define (verify-installed-output installed-binary output-dir verify-kind)
  (match verify-kind
    ("hello"
     (let ((hello-output (command-output installed-binary)))
       (unless (string=? hello-output "Hello, world!")
         (error (format #f "unexpected hello output: ~s" hello-output)))
       hello-output))
    ("which"
     (let ((which-output (command-output "env" "PATH=/bin:/usr/bin" installed-binary "sh")))
       (unless (string=? which-output "/bin/sh")
         (error (format #f "unexpected which output: ~s" which-output)))
       which-output))
    ("sed-substitute"
     (let* ((input-file (string-append output-dir "/share/freebsd-phase-runner-sed-input.txt"))
            (sed-output (begin
                          (write-file input-file "alpha beta\n")
                          (command-output installed-binary "s/beta/gamma/" input-file))))
       (unless (string=? sed-output "alpha gamma")
         (error (format #f "unexpected sed output: ~s" sed-output)))
       sed-output))
    ("diff-unified"
     (let* ((left-file (string-append output-dir "/share/freebsd-phase-runner-left.txt"))
            (right-file (string-append output-dir "/share/freebsd-phase-runner-right.txt"))
            (expected "--- left\n+++ right\n@@ -1 +1 @@\n-apple\n+orange")
            (diff-output (begin
                           (write-file left-file "apple\n")
                           (write-file right-file "orange\n")
                           (command-output installed-binary "-u" "--label" "left"
                                           "--label" "right"
                                           left-file right-file))))
       (unless (string=? diff-output expected)
         (error (format #f "unexpected diff output: ~s" diff-output)))
       diff-output))
    ("version-prefix"
     (let* ((version-output (command-output installed-binary "--version"))
            (first-line (string-trim-both (car (string-split version-output #\newline)))))
       (unless (and (not (string-null? version-prefix))
                    (string-prefix? version-prefix first-line))
         (error (format #f "unexpected version line: ~s" first-line)))
       first-line))
    (else
     (error (format #f "unknown VERIFY_KIND: ~a" verify-kind)))))

(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 adapted Guix builder phases: ~s~%" selected-phase-names)

  (with-directory-excursion workdir
    (gnu-build #:source source-tarball
               #:outputs `(("out" . ,output-dir))
               #:phases selected-phases
               #:tests? run-tests?))

  (let* ((installed-binary (string-append output-dir "/" binary-relative-path))
         (verification-output
          (verify-installed-output installed-binary output-dir verify-kind))
         (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"))
         (make-path (command-output "sh" "-c" "command -v make"))
         (make-version (command-output "make" "--version"))
         (cc-version (command-output (getenv "CC") "--version")))
    (call-with-output-file metadata-file
      (lambda (port)
        (format port "package_name=~a~%" package-name)
        (format port "package_version=~a~%" package-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 "verify_kind=~a~%" verify-kind)
        (format port "version_prefix=~a~%" version-prefix)
        (format port "run_tests=~a~%" (if run-tests? "1" "0"))
        (format port "binary_relative_path=~a~%" binary-relative-path)
        (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 "verification_output=~a~%" verification-output)
        (format port "host_triplet=~a~%" host-triplet)
        (format port "selected_phases=~s~%" selected-phase-names)
        (format port "adapted_tools_dir=~a~%" adapted-tools-dir)
        (format port "make_path=~a~%" make-path)
        (format port "make_version_begin~%~a~%make_version_end~%" make-version)
        (format port "cc=~a~%" (getenv "CC"))
        (format port "cxx=~a~%" (getenv "CXX"))
        (format port "cc_version_begin~%~a~%cc_version_end~%" cc-version)
        (format port "cppflags=~a~%" (getenv "CPPFLAGS"))
        (format port "ldflags=~a~%" (getenv "LDFLAGS"))
        (format port "pkg_config=~a~%" (getenv "PKG_CONFIG"))
        (format port "pkg_config_path=~a~%" (getenv "PKG_CONFIG_PATH"))
        (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 ~a-freebsd-phase-runner~%" package-name)
    (format #t "Installed binary: ~a~%" installed-binary)
    (format #t "Verification output: ~a~%" verification-output)
    (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))))