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))
(define* (create-temporary-directory #:key tmpdir suffix template)
(lambda (conn ctx)
(lambda (conn)
(connection-must conn "mktemp" (chain-when
'("--directory")
(tmpdir (append _ `("--tmpdir" tmpdir)))
(suffix (append _ `("--suffix" suffix)))
(template (append _ `(template)))
(#t (resolve-context-refs ctx _))))))
(template (append _ `(template)))))))
(define* (install-directory path #:key owner group mode)
(lambda (conn ctx)
(lambda (conn)
(connection-must conn "install" (chain-when
'("--directory")
(owner (append _ `("--owner" ,owner)))
(group (append _ `("--group" ,group)))
(mode (append _ `("--mode" ,mode)))
(#t (append _ `(,path)))
(#t (resolve-context-refs ctx _))))))
(#t (append _ `(,path)))))))
;; Helper not intended for use outside of this module
(define (upload-tmp-file conn ctx)
(define (upload-tmp-file conn)
(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
(lambda (output-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?)
(when (not (= 1 (length (filter identity (list content local-src remote-src)))))
(error "exactly one of #:content, #:local-src, or #:remote-src is required"))
(lambda (conn ctx)
(lambda (conn)
(let ((remote-src (cond
(remote-src remote-src)
(local-src (call-with-input-file local-src (upload-tmp-file conn ctx)))
((string? content) (call-with-input-string content (upload-tmp-file conn ctx)))
((bytevector? content) (call-with-input-bytevector content (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)))
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn)))
(else (error "unsupported type for #:content")))))
(connection-must conn "install" (chain-when
'()
@ -60,5 +58,4 @@
(group (append _ `("--group" ,group)))
(mode (append _ `("--mode" ,mode)))
(backup? (append _ '("--backup" "numbered")))
(#t (append _ (list remote-src path)))
(#t (resolve-context-refs ctx _)))))))
(#t (append _ (list remote-src path))))))))

21
modules/ordo/context.scm
View file

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

2
modules/ordo/task.scm
View file

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