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

Add macro to simplify task context references

Browse source
This commit is contained in:
Ray Miller 2025-01-08 09:13:19 +00:00
parent b4cdfc341a
commit 5360e73d60
Signed by: ray
GPG key ID: 043F786C4CD681B8
4 changed files with 54 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -10,22 +10,24 @@
install-directory install-directory
install-file)) install-file))
(define* (create-temporary-directory ctx #:key tmpdir suffix template) (define* (create-temporary-directory #:key tmpdir suffix template)
(connection-must (context-connection ctx) (lambda (ctx)
"mktemp" (chain-when (connection-must (context-connection ctx)
'("--directory") "mktemp" (chain-when
(tmpdir (append _ `("--tmpdir" tmpdir))) '("--directory")
(suffix (append _ `("--suffix" suffix))) (tmpdir (append _ `("--tmpdir" tmpdir)))
(template (append _ `(template)))))) (suffix (append _ `("--suffix" suffix)))
(template (append _ `(template)))))))
(define* (install-directory ctx path #:key owner group mode) (define* (install-directory path #:key owner group mode)
(connection-must (context-connection ctx) (lambda (ctx)
"install" (chain-when (connection-must (context-connection ctx)
'("--directory") "install" (chain-when
(owner (append _ `("--owner" ,owner))) '("--directory")
(group (append _ `("--group" ,group))) (owner (append _ `("--owner" ,owner)))
(mode (append _ `("--mode" ,mode))) (group (append _ `("--group" ,group)))
(#t (append _ `(,path)))))) (mode (append _ `("--mode" ,mode)))
(#t (append _ `(,path)))))))
;; Helper not intended for use outside of this module ;; Helper not intended for use outside of this module
(define (upload-tmp-file ctx) (define (upload-tmp-file ctx)
@ -43,21 +45,21 @@
;; Because we might need sudo to install the remote file, we first ;; Because we might need sudo to install the remote file, we first
;; upload the source to a temporary file. ;; upload the source to a temporary file.
(define* (install-file ctx 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"))
(format #t "install-file ~a~%" path) (lambda (ctx)
(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 ctx))) (local-src (call-with-input-file local-src (upload-tmp-file ctx)))
((string? content) (call-with-input-string content (upload-tmp-file ctx))) ((string? content) (call-with-input-string content (upload-tmp-file ctx)))
((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx))) ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file ctx)))
(else (error "unsupported type for #:content"))))) (else (error "unsupported type for #:content")))))
(connection-must (context-connection ctx) (connection-must (context-connection ctx)
"install" (chain-when "install" (chain-when
'() '()
(owner (append _ `("--owner" ,owner))) (owner (append _ `("--owner" ,owner)))
(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))))))))

10
modules/ordo/context.scm
View file

@ -11,7 +11,8 @@
get-context-triggers get-context-triggers
context-triggered? context-triggered?
register-context-var! register-context-var!
context-ref)) context-ref
bind-context-vars))
(define-record-type <context> (define-record-type <context>
(make-context connection vars scratch-dir) (make-context connection vars scratch-dir)
@ -37,3 +38,10 @@
(define (register-context-var! ctx var-name val) (define (register-context-var! ctx var-name val)
(set-context-vars! ctx (assoc-set! (context-vars ctx) var-name val))) (set-context-vars! ctx (assoc-set! (context-vars ctx) var-name val)))
(define-syntax bind-context-vars
(syntax-rules ()
((bind-context-vars (var-name ...) proc)
(lambda (ctx)
(let ((var-name (context-ref ctx (quote var-name))) ...)
(proc ctx))))))

1
modules/ordo/play.scm
View file

@ -42,7 +42,6 @@
(lambda (c) (lambda (c)
(let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory"))))
(ctx (make-context c (play-vars play) tmp-dir))) (ctx (make-context c (play-vars play) tmp-dir)))
(pk ctx)
(dynamic-wind (dynamic-wind
(const #t) (const #t)
(lambda () (lambda ()

23
tryme.scm
View file

@ -30,21 +30,22 @@
(const "/home/ray/ordo-test-again") (const "/home/ray/ordo-test-again")
#:register 'base-dir) #:register 'base-dir)
(task "Create test directory" (task "Create test directory"
(lambda (ctx) (bind-context-vars
(install-directory ctx (context-ref ctx 'base-dir)))) (base-dir)
(install-directory base-dir)))
(task "Create test file from string content" (task "Create test file from string content"
(lambda (ctx) (bind-context-vars
(install-file ctx (file-name-join* (context-ref ctx 'base-dir) "foo") (base-dir)
#:content "Hello, world!\n"))) (install-file (file-name-join* base-dir "foo") #:content "Hello, world!\n")))
(task "Create test file from local source" (task "Create test file from local source"
(lambda (ctx) (bind-context-vars
(install-file ctx (file-name-join* (context-ref ctx 'base-dir) "bar") (base-dir)
#:local-src (file-name-join* (context-ref ctx 'base-dir) "foo"))) (install-file (file-name-join* base-dir "bar") #:local-src (file-name-join* base-dir "foo")))
#:triggers '(fritz)) #:triggers '(fritz))
(task "Create test file from remote source" (task "Create test file from remote source"
(lambda (ctx) (bind-context-vars
(install-file ctx (file-name-join* (context-ref ctx 'base-dir) "baz") (base-dir)
#:remote-src (file-name-join* (context-ref ctx 'base-dir) "bar"))) (install-file (file-name-join* base-dir "baz") #:remote-src (file-name-join* base-dir "bar")))
#:triggers '(frobnicate))) #:triggers '(frobnicate)))
#:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t)))
(fritz . ,(handler "Fritz" (const #t))) (fritz . ,(handler "Fritz" (const #t)))