(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)))