(use-modules (fruix system freebsd)
             (ice-9 format)
             (ice-9 pretty-print)
             (ice-9 popen)
             (srfi srfi-13)
             (rnrs io ports))

(define workdir
  (or (getenv "WORKDIR")
      (error "WORKDIR environment variable is required")))
(define os-file
  (or (getenv "OS_FILE")
      (error "OS_FILE environment variable is required")))
(define store-dir
  (or (getenv "STORE_DIR")
      "/frx/store"))
(define guile-prefix
  (or (getenv "GUILE_PREFIX")
      "/tmp/guile-freebsd-validate-install"))
(define guile-extra-prefix
  (or (getenv "GUILE_EXTRA_PREFIX")
      "/tmp/guile-gnutls-freebsd-validate-install"))
(define shepherd-prefix
  (or (getenv "SHEPHERD_PREFIX")
      "/tmp/shepherd-freebsd-validate-install"))
(define metadata-file
  (string-append workdir "/phase8-system-image-metadata.txt"))
(define disk-capacity
  (let ((value (getenv "DISK_CAPACITY")))
    (and value (not (string-null? value)) value)))

(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 "command failed" program args status))
    (trim-trailing-newlines output)))

(define (assert-exists path)
  (unless (file-exists? path)
    (error "required path missing" path)))

(primitive-load os-file)
(validate-operating-system phase7-operating-system)

(let* ((image-a (if disk-capacity
                    (materialize-bhyve-image phase7-operating-system
                                             #:store-dir store-dir
                                             #:guile-prefix guile-prefix
                                             #:guile-extra-prefix guile-extra-prefix
                                             #:shepherd-prefix shepherd-prefix
                                             #:disk-capacity disk-capacity)
                    (materialize-bhyve-image phase7-operating-system
                                             #:store-dir store-dir
                                             #:guile-prefix guile-prefix
                                             #:guile-extra-prefix guile-extra-prefix
                                             #:shepherd-prefix shepherd-prefix)))
       (image-b (if disk-capacity
                    (materialize-bhyve-image phase7-operating-system
                                             #:store-dir store-dir
                                             #:guile-prefix guile-prefix
                                             #:guile-extra-prefix guile-extra-prefix
                                             #:shepherd-prefix shepherd-prefix
                                             #:disk-capacity disk-capacity)
                    (materialize-bhyve-image phase7-operating-system
                                             #:store-dir store-dir
                                             #:guile-prefix guile-prefix
                                             #:guile-extra-prefix guile-extra-prefix
                                             #:shepherd-prefix shepherd-prefix)))
       (image-store-path (assoc-ref image-a 'image-store-path))
       (image-store-path-rebuild (assoc-ref image-b 'image-store-path))
       (disk-image (assoc-ref image-a 'disk-image))
       (esp-image (assoc-ref image-a 'esp-image))
       (root-image (assoc-ref image-a 'root-image))
       (closure-path (assoc-ref image-a 'closure-path))
       (image-spec (assoc-ref image-a 'image-spec))
       (store-items (assoc-ref image-a 'store-items))
       (raw-sha256 (command-output "sha256" "-q" disk-image))
       (image-size-bytes (command-output "stat" "-f" "%z" disk-image)))
  (for-each assert-exists
            (list image-store-path disk-image esp-image root-image
                  (string-append image-store-path "/image-spec.scm")
                  (string-append image-store-path "/closure-path")
                  (string-append image-store-path "/.references")
                  (string-append image-store-path "/.fruix-package")))
  (unless (string=? image-store-path image-store-path-rebuild)
    (error "image store path was not reproducible" image-store-path image-store-path-rebuild))
  (call-with-output-file metadata-file
    (lambda (port)
      (format port "store_dir=~a~%" store-dir)
      (format port "image_store_path=~a~%" image-store-path)
      (format port "image_store_path_rebuild=~a~%" image-store-path-rebuild)
      (format port "disk_image=~a~%" disk-image)
      (format port "esp_image=~a~%" esp-image)
      (format port "root_image=~a~%" root-image)
      (format port "closure_path=~a~%" closure-path)
      (format port "disk_capacity=~a~%" (or disk-capacity "<default>"))
      (format port "store_item_count=~a~%" (length store-items))
      (format port "raw_sha256=~a~%" raw-sha256)
      (format port "image_size_bytes=~a~%" image-size-bytes)
      (format port "image_spec=~a~%"
              (string-map (lambda (ch) (if (char=? ch #\newline) #\space ch))
                          (with-output-to-string
                            (lambda ()
                              (pretty-print image-spec)))))))
  (when (getenv "METADATA_OUT")
    (copy-file metadata-file (getenv "METADATA_OUT")))
  (format #t "PASS phase8-system-image-materialization~%")
  (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)))