#!/tmp/guile-freebsd-validate-install/bin/guile -s
!#

(use-modules (fruix system freebsd)
             (ice-9 format)
             (ice-9 match)
             (srfi srfi-1)
             (srfi srfi-13))

(define (usage code)
  (format (if (= code 0) #t (current-error-port))
          "Usage: fruix system ACTION OS-FILE [OPTIONS]\n\
\n\
Actions:\n\
  build              Materialize the Fruix system closure in /frx/store.\n\
  image              Materialize the Fruix disk image in /frx/store.\n\
  rootfs             Materialize a rootfs tree at --rootfs DIR or ROOTFS-DIR.\n\
\n\
Options:\n\
  --system NAME          Scheme variable holding the operating-system object.\n\
  --store DIR            Store directory to use (default: /frx/store).\n\
  --disk-capacity SIZE   Disk capacity for 'image' (example: 30g).\n\
  --rootfs DIR           Rootfs target for 'rootfs'.\n\
  --help                 Show this help.\n")
  (exit code))

(define (option-value arg prefix)
  (and (string-prefix? prefix arg)
       (substring arg (string-length prefix))))

(define (stringify value)
  (cond ((string? value) value)
        ((symbol? value) (symbol->string value))
        ((number? value) (number->string value))
        ((boolean? value) (if value "true" "false"))
        (else (call-with-output-string (lambda (port) (write value port))))))

(define (emit-metadata fields)
  (for-each (lambda (field)
              (format #t "~a=~a~%" (car field) (stringify (cdr field))))
            fields))

(define (lookup-bound-value module symbol)
  (let ((var (module-variable module symbol)))
    (and var (variable-ref var))))

(define candidate-operating-system-symbols
  '(operating-system
    phase10-operating-system
    phase9-operating-system
    phase8-operating-system
    phase7-operating-system
    default-operating-system
    os))

(define (resolve-operating-system-symbol module requested)
  (or requested
      (find (lambda (symbol)
              (let ((value (lookup-bound-value module symbol)))
                (and value (operating-system? value))))
            candidate-operating-system-symbols)
      (error "could not infer operating-system variable; use --system NAME")))

(define (load-operating-system-from-file file requested-symbol)
  (unless (file-exists? file)
    (error "operating-system file does not exist" file))
  (primitive-load file)
  (let* ((module (current-module))
         (symbol (resolve-operating-system-symbol module requested-symbol))
         (value (lookup-bound-value module symbol)))
    (unless (and value (operating-system? value))
      (error "resolved variable is not an operating-system" symbol))
    (validate-operating-system value)
    (values value symbol)))

(define (parse-arguments argv)
  (match argv
    ((_)
     (usage 1))
    ((_ "--help")
     (usage 0))
    ((_ "help")
     (usage 0))
    ((_ "system" "--help")
     (usage 0))
    ((_ "system" action . rest)
     (let loop ((args rest)
                (positional '())
                (system-name #f)
                (store-dir "/frx/store")
                (disk-capacity #f)
                (rootfs #f))
       (match args
         (()
          (let ((positional (reverse positional)))
            `((action . ,action)
              (positional . ,positional)
              (system-name . ,system-name)
              (store-dir . ,store-dir)
              (disk-capacity . ,disk-capacity)
              (rootfs . ,rootfs))))
         (("--help")
          (usage 0))
         (((? (lambda (arg) (string-prefix? "--system=" arg)) arg) . tail)
          (loop tail positional (option-value arg "--system=") store-dir disk-capacity rootfs))
         (("--system" value . tail)
          (loop tail positional value store-dir disk-capacity rootfs))
         (((? (lambda (arg) (string-prefix? "--store=" arg)) arg) . tail)
          (loop tail positional system-name (option-value arg "--store=") disk-capacity rootfs))
         (("--store" value . tail)
          (loop tail positional system-name value disk-capacity rootfs))
         (((? (lambda (arg) (string-prefix? "--disk-capacity=" arg)) arg) . tail)
          (loop tail positional system-name store-dir (option-value arg "--disk-capacity=") rootfs))
         (("--disk-capacity" value . tail)
          (loop tail positional system-name store-dir value rootfs))
         (((? (lambda (arg) (string-prefix? "--rootfs=" arg)) arg) . tail)
          (loop tail positional system-name store-dir disk-capacity (option-value arg "--rootfs=")))
         (("--rootfs" value . tail)
          (loop tail positional system-name store-dir disk-capacity value))
         (((? (lambda (arg) (string-prefix? "--" arg)) arg) . _)
          (error "unknown option" arg))
         ((arg . tail)
          (loop tail (cons arg positional) system-name store-dir disk-capacity rootfs)))))
    ((_ . _)
     (usage 1))))

(define (main argv)
  (let* ((parsed (parse-arguments argv))
         (action (assoc-ref parsed 'action))
         (positional (assoc-ref parsed 'positional))
         (store-dir (assoc-ref parsed 'store-dir))
         (disk-capacity (assoc-ref parsed 'disk-capacity))
         (rootfs-opt (assoc-ref parsed 'rootfs))
         (system-name (assoc-ref parsed 'system-name))
         (requested-symbol (and system-name (string->symbol system-name))))
    (cond
     ((member action '("build" "image" "rootfs")) #t)
     (else (error "unknown system action" action)))
    (let* ((os-file (match positional
                      ((file . _) file)
                      (() (error "missing operating-system file argument"))))
           (rootfs (or rootfs-opt
                       (and (string=? action "rootfs")
                            (match positional
                              ((_ dir) dir)
                              ((_ _ dir . _) dir)
                              (_ #f))))))
      (call-with-values
          (lambda ()
            (load-operating-system-from-file os-file requested-symbol))
        (lambda (os resolved-symbol)
          (let* ((guile-prefix (or (getenv "GUILE_PREFIX") "/tmp/guile-freebsd-validate-install"))
                 (guile-extra-prefix (or (getenv "GUILE_EXTRA_PREFIX") "/tmp/guile-gnutls-freebsd-validate-install"))
                 (shepherd-prefix (or (getenv "SHEPHERD_PREFIX") "/tmp/shepherd-freebsd-validate-install")))
            (cond
             ((string=? action "build")
              (let* ((result (materialize-operating-system os
                                                           #:store-dir store-dir
                                                           #:guile-prefix guile-prefix
                                                           #:guile-extra-prefix guile-extra-prefix
                                                           #:shepherd-prefix shepherd-prefix))
                     (closure-path (assoc-ref result 'closure-path))
                     (generated-files (assoc-ref result 'generated-files))
                     (references (assoc-ref result 'references))
                     (base-package-stores (assoc-ref result 'base-package-stores)))
                (emit-metadata
                 `((action . "build")
                   (os_file . ,os-file)
                   (system_variable . ,resolved-symbol)
                   (store_dir . ,store-dir)
                   (closure_path . ,closure-path)
                   (ready_marker . ,(operating-system-ready-marker os))
                   (kernel_store . ,(assoc-ref result 'kernel-store))
                   (bootloader_store . ,(assoc-ref result 'bootloader-store))
                   (guile_store . ,(assoc-ref result 'guile-store))
                   (guile_extra_store . ,(assoc-ref result 'guile-extra-store))
                   (shepherd_store . ,(assoc-ref result 'shepherd-store))
                   (base_package_store_count . ,(length base-package-stores))
                   (base_package_stores . ,(string-join base-package-stores ","))
                   (generated_file_count . ,(length generated-files))
                   (reference_count . ,(length references))))))
             ((string=? action "rootfs")
              (unless rootfs
                (error "rootfs action requires ROOTFS-DIR or --rootfs DIR"))
              (let ((result (materialize-rootfs os rootfs
                                               #:store-dir store-dir
                                               #:guile-prefix guile-prefix
                                               #:guile-extra-prefix guile-extra-prefix
                                               #:shepherd-prefix shepherd-prefix)))
                (emit-metadata
                 `((action . "rootfs")
                   (os_file . ,os-file)
                   (system_variable . ,resolved-symbol)
                   (store_dir . ,store-dir)
                   (rootfs . ,(assoc-ref result 'rootfs))
                   (closure_path . ,(assoc-ref result 'closure-path))
                   (ready_marker . ,(assoc-ref result 'ready-marker))
                   (rc_script . ,(assoc-ref result 'rc-script))))))
             ((string=? action "image")
              (let* ((result (materialize-bhyve-image os
                                                      #:store-dir store-dir
                                                      #:guile-prefix guile-prefix
                                                      #:guile-extra-prefix guile-extra-prefix
                                                      #:shepherd-prefix shepherd-prefix
                                                      #:disk-capacity disk-capacity))
                     (image-spec (assoc-ref result 'image-spec))
                     (store-items (assoc-ref result 'store-items)))
                (emit-metadata
                 `((action . "image")
                   (os_file . ,os-file)
                   (system_variable . ,resolved-symbol)
                   (store_dir . ,store-dir)
                   (disk_capacity . ,(assoc-ref image-spec 'disk-capacity))
                   (image_store_path . ,(assoc-ref result 'image-store-path))
                   (disk_image . ,(assoc-ref result 'disk-image))
                   (esp_image . ,(assoc-ref result 'esp-image))
                   (root_image . ,(assoc-ref result 'root-image))
                   (closure_path . ,(assoc-ref result 'closure-path))
                   (store_item_count . ,(length store-items)))))))))))))

(main (command-line))