You've already forked fruix-bootstrap
122 lines
4.7 KiB
Scheme
122 lines
4.7 KiB
Scheme
(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)))))
|