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

10
modules/ordo/context.scm
View file

@ -11,7 +11,8 @@
get-context-triggers
context-triggered?
register-context-var!
context-ref))
context-ref
bind-context-vars))
(define-record-type <context>
(make-context connection vars scratch-dir)
@ -37,3 +38,10 @@
(define (register-context-var! 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)
(let* ((tmp-dir (car (connection-must c "mktemp" '("--directory"))))
(ctx (make-context c (play-vars play) tmp-dir)))
(pk ctx)
(dynamic-wind
(const #t)
(lambda ()

23
tryme.scm
View file

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