ray/ordo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Try to make context vars nestable in task action args

Browse source
This commit is contained in:
Ray Miller 2025-01-06 20:49:42 +00:00
parent b7e4b9dc74
commit f2f88ce0dc
3 changed files with 19 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

25
modules/ordo/action/filesystem.scm
View file

@ -11,28 +11,26 @@
install-file)) install-file))
(define* (create-temporary-directory #:key tmpdir suffix template) (define* (create-temporary-directory #:key tmpdir suffix template)
(lambda (conn ctx) (lambda (conn)
(connection-must conn "mktemp" (chain-when (connection-must conn "mktemp" (chain-when
'("--directory") '("--directory")
(tmpdir (append _ `("--tmpdir" tmpdir))) (tmpdir (append _ `("--tmpdir" tmpdir)))
(suffix (append _ `("--suffix" suffix))) (suffix (append _ `("--suffix" suffix)))
(template (append _ `(template))) (template (append _ `(template)))))))
(#t (resolve-context-refs ctx _))))))
(define* (install-directory path #:key owner group mode) (define* (install-directory path #:key owner group mode)
(lambda (conn ctx) (lambda (conn)
(connection-must conn "install" (chain-when (connection-must conn "install" (chain-when
'("--directory") '("--directory")
(owner (append _ `("--owner" ,owner))) (owner (append _ `("--owner" ,owner)))
(group (append _ `("--group" ,group))) (group (append _ `("--group" ,group)))
(mode (append _ `("--mode" ,mode))) (mode (append _ `("--mode" ,mode)))
(#t (append _ `(,path))) (#t (append _ `(,path)))))))
(#t (resolve-context-refs ctx _))))))
;; Helper not intended for use outside of this module ;; Helper not intended for use outside of this module
(define (upload-tmp-file conn ctx) (define (upload-tmp-file conn)
(lambda (input-port) (lambda (input-port)
(let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(context-scratch-dir ctx)))))) (let ((tmp-path (car (connection-must conn "mktemp"))))
(connection-call-with-output-file conn tmp-path (connection-call-with-output-file conn tmp-path
(lambda (output-port) (lambda (output-port)
(let loop ((data (get-bytevector-some input-port))) (let loop ((data (get-bytevector-some input-port)))
@ -47,12 +45,12 @@
(define* (install-file path #:key owner group mode content local-src remote-src backup?) (define* (install-file path #:key owner group mode content local-src remote-src backup?)
(when (not (= 1 (length (filter identity (list content local-src remote-src))))) (when (not (= 1 (length (filter identity (list content local-src remote-src)))))
(error "exactly one of #:content, #:local-src, or #:remote-src is required")) (error "exactly one of #:content, #:local-src, or #:remote-src is required"))
(lambda (conn ctx) (lambda (conn)
(let ((remote-src (cond (let ((remote-src (cond
(remote-src remote-src) (remote-src remote-src)
(local-src (call-with-input-file local-src (upload-tmp-file conn ctx))) (local-src (call-with-input-file local-src (upload-tmp-file conn)))
((string? content) (call-with-input-string content (upload-tmp-file conn ctx))) ((string? content) (call-with-input-string content (upload-tmp-file conn)))
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn ctx))) ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn)))
(else (error "unsupported type for #:content"))))) (else (error "unsupported type for #:content")))))
(connection-must conn "install" (chain-when (connection-must conn "install" (chain-when
'() '()
@ -60,5 +58,4 @@
(group (append _ `("--group" ,group))) (group (append _ `("--group" ,group)))
(mode (append _ `("--mode" ,mode))) (mode (append _ `("--mode" ,mode)))
(backup? (append _ '("--backup" "numbered"))) (backup? (append _ '("--backup" "numbered")))
(#t (append _ (list remote-src path))) (#t (append _ (list remote-src path))))))))
(#t (resolve-context-refs ctx _)))))))

21
modules/ordo/context.scm
View file

@ -9,8 +9,6 @@
get-context-triggers get-context-triggers
context-triggered? context-triggered?
register-context-var! register-context-var!
context-ref
resolve-context-ref
resolve-context-refs)) resolve-context-refs))
(define-record-type <context> (define-record-type <context>
@ -23,18 +21,13 @@
(define* (context #:key scratch-dir init-vars) (define* (context #:key scratch-dir init-vars)
(make-context scratch-dir init-vars)) (make-context scratch-dir init-vars))
(define-record-type <context-ref> (define-syntax resolve-context-refs
(context-ref name) (syntax-rules ($)
context-ref? ((_ ctx ($ x))
(name var-name)) (assoc-ref (context-vars ctx) x))
((_ ctx (f x ...))
(define (resolve-context-ref ctx v) (f (resolve-context-refs ctx x) ...))
(if (context-ref? v) ((_ ctx x) x)))
(assoc-ref (context-vars ctx) (var-name v))
v))
(define (resolve-context-refs ctx args)
(map (cut resolve-context-ref ctx <>) args))
(define (add-context-triggers! ctx triggers) (define (add-context-triggers! ctx triggers)
(when triggers (when triggers

2
modules/ordo/task.scm
View file

@ -29,7 +29,7 @@
(task% (task%
description description
(lambda (conn ctx) (lambda (conn ctx)
(action conn ctx (assoc-ref ctx arg) ...)) (action conn (resolve-context-refs ctx arg) ...))
kwarg ...)))) kwarg ...))))
(define (run-task conn ctx task) (define (run-task conn ctx task)