(define-module (fruix system freebsd executor)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (native-build-executor-model-version
            native-build-executor
            native-build-executor?
            native-build-executor-ref
            native-build-executor-kind
            native-build-executor-name
            native-build-executor-version
            native-build-executor-properties
            normalize-native-build-executor
            host-native-build-executor
            ssh-guest-native-build-executor
            self-hosted-native-build-executor))

(define native-build-executor-model-version "1")

(define (association-list? value)
  (and (list? value)
       (every pair? value)))

(define (executor-name kind provided-name)
  (or provided-name
      (symbol->string kind)))

(define* (native-build-executor #:key kind name
                                (version native-build-executor-model-version)
                                (properties '()))
  (unless (symbol? kind)
    (error "native build executor kind must be a symbol" kind))
  (unless (string? (executor-name kind name))
    (error "native build executor name must be a string" name))
  (unless (string? version)
    (error "native build executor version must be a string" version))
  (unless (association-list? properties)
    (error "native build executor properties must be an association list" properties))
  `((kind . ,kind)
    (name . ,(executor-name kind name))
    (version . ,version)
    (properties . ,properties)))

(define (native-build-executor-ref executor key default)
  (match (assoc key executor)
    ((_ . value) value)
    (#f default)))

(define (native-build-executor? value)
  (and (association-list? value)
       (symbol? (native-build-executor-ref value 'kind #f))
       (string? (native-build-executor-ref value 'name #f))
       (string? (native-build-executor-ref value 'version #f))
       (association-list? (native-build-executor-ref value 'properties '()))))

(define (native-build-executor-kind executor)
  (native-build-executor-ref executor 'kind 'unknown))

(define (native-build-executor-name executor)
  (native-build-executor-ref executor 'name "unknown"))

(define (native-build-executor-version executor)
  (native-build-executor-ref executor 'version "unknown"))

(define (native-build-executor-properties executor)
  (native-build-executor-ref executor 'properties '()))

(define (legacy-executor-kind name)
  (cond
   ((member name '("host")) 'host)
   ((member name '("ssh-guest" "guest-ssh" "guest-host-initiated")) 'ssh-guest)
   ((member name '("self-hosted" "guest-self-hosted")) 'self-hosted)
   ((member name '("jail")) 'jail)
   ((member name '("remote-builder")) 'remote-builder)
   (else 'legacy)))

(define (normalize-native-build-executor value)
  (cond
   ((native-build-executor? value)
    value)
   ((string? value)
    (native-build-executor #:kind (legacy-executor-kind value)
                           #:name value
                           #:version "legacy"))
   (else
    (error "unsupported native build executor representation" value))))

(define* (host-native-build-executor #:key (name "host")
                                     host-name working-directory)
  (native-build-executor
   #:kind 'host
   #:name name
   #:properties (filter-map identity
                            `((host-name . ,host-name)
                              (working-directory . ,working-directory)))))

(define* (ssh-guest-native-build-executor #:key (name "ssh-guest")
                                          transport orchestrator
                                          guest-host-name guest-ip vm-id vdi-id)
  (native-build-executor
   #:kind 'ssh-guest
   #:name name
   #:properties (filter-map identity
                            `((transport . ,(or transport "ssh"))
                              (orchestrator . ,(or orchestrator "host"))
                              (guest-host-name . ,guest-host-name)
                              (guest-ip . ,guest-ip)
                              (vm-id . ,vm-id)
                              (vdi-id . ,vdi-id)))))

(define* (self-hosted-native-build-executor #:key (name "self-hosted")
                                            helper-path helper-version
                                            guest-host-name build-root-base result-root-base)
  (native-build-executor
   #:kind 'self-hosted
   #:name name
   #:version (or helper-version native-build-executor-model-version)
   #:properties (filter-map identity
                            `((helper-path . ,helper-path)
                              (guest-host-name . ,guest-host-name)
                              (build-root-base . ,build-root-base)
                              (result-root-base . ,result-root-base)))))