Support for context vars without macros
This commit is contained in:
parent
af16ee29b6
commit
b4cdfc341a
GPG key ID:
043F786C4CD681B8
7 changed files with 91 additions and 94 deletions
|
|
@ -5,33 +5,34 @@
|
|||
#:use-module (srfi srfi-71) ; extended let
|
||||
#:use-module ((srfi srfi-197) #:select (chain-when))
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo context)
|
||||
#:export (create-temporary-directory
|
||||
install-directory
|
||||
install-file))
|
||||
|
||||
(define* (create-temporary-directory #:key tmpdir suffix template)
|
||||
(lambda (conn)
|
||||
(connection-must conn "mktemp" (chain-when
|
||||
'("--directory")
|
||||
(tmpdir (append _ `("--tmpdir" tmpdir)))
|
||||
(suffix (append _ `("--suffix" suffix)))
|
||||
(template (append _ `(template)))))))
|
||||
(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* (install-directory path #:key owner group mode)
|
||||
(lambda (conn)
|
||||
(format #t "install-directory ~a~%" path)
|
||||
(connection-must conn "install" (chain-when
|
||||
'("--directory")
|
||||
(owner (append _ `("--owner" ,owner)))
|
||||
(group (append _ `("--group" ,group)))
|
||||
(mode (append _ `("--mode" ,mode)))
|
||||
(#t (append _ `(,path)))))))
|
||||
(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))))))
|
||||
|
||||
;; Helper not intended for use outside of this module
|
||||
(define (upload-tmp-file conn)
|
||||
(define (upload-tmp-file ctx)
|
||||
(lambda (input-port)
|
||||
(let ((tmp-path (car (connection-must conn "mktemp" '()))))
|
||||
(connection-call-with-output-file conn tmp-path
|
||||
(let ((tmp-path (car (connection-must (context-connection ctx)
|
||||
"mktemp" `("-p" ,(context-scratch-dir ctx))))))
|
||||
(connection-call-with-output-file (context-connection ctx) tmp-path
|
||||
(lambda (output-port)
|
||||
(let loop ((data (get-bytevector-some input-port)))
|
||||
(unless (eof-object? data)
|
||||
|
|
@ -42,21 +43,21 @@
|
|||
|
||||
;; Because we might need sudo to install the remote file, we first
|
||||
;; upload the source to a temporary file.
|
||||
(define* (install-file path #:key owner group mode content local-src remote-src backup?)
|
||||
(define* (install-file ctx 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)
|
||||
(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 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
|
||||
'()
|
||||
(owner (append _ `("--owner" ,owner)))
|
||||
(group (append _ `("--group" ,group)))
|
||||
(mode (append _ `("--mode" ,mode)))
|
||||
(backup? (append _ '("--backup" "numbered")))
|
||||
(#t (append _ (list remote-src path))))))))
|
||||
(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)))))))
|
||||
|
|
|
|||
|
|
@ -11,7 +11,8 @@
|
|||
#:use-module (ssh popen)
|
||||
#:use-module (ssh sftp)
|
||||
#:use-module (ordo util shell-quote)
|
||||
#:export (local-connection
|
||||
#:export (<connection>
|
||||
local-connection
|
||||
ssh-connection
|
||||
init-connection!
|
||||
close-connection!
|
||||
|
|
|
|||
|
|
@ -2,33 +2,30 @@
|
|||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:export (context
|
||||
#:export (make-context
|
||||
context?
|
||||
context-connection
|
||||
context-scratch-dir
|
||||
set-context-scratch-dir!
|
||||
add-context-triggers!
|
||||
get-context-triggers
|
||||
context-triggered?
|
||||
register-context-var!
|
||||
resolve-context-refs))
|
||||
context-ref))
|
||||
|
||||
(define-record-type <context>
|
||||
(make-context scratch-dir vars)
|
||||
(make-context connection vars scratch-dir)
|
||||
context?
|
||||
(connection context-connection)
|
||||
(scratch-dir context-scratch-dir set-context-scratch-dir!)
|
||||
(vars context-vars set-context-vars!)
|
||||
(triggers context-triggers set-context-triggers!))
|
||||
|
||||
(define* (context #:key scratch-dir init-vars)
|
||||
(make-context scratch-dir init-vars))
|
||||
|
||||
;; TODO: (resolve-content-refs ctx (lambda (x) x)) fails
|
||||
(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 (context-ref ctx var-name)
|
||||
(let ((kv (assoc var-name (context-vars ctx))))
|
||||
(if kv
|
||||
(cdr kv)
|
||||
(error (format #f "failed to resolve context reference: ~a" var-name)))))
|
||||
|
||||
(define (add-context-triggers! ctx triggers)
|
||||
(when triggers
|
||||
|
|
|
|||
|
|
@ -16,19 +16,10 @@
|
|||
(description handler-description)
|
||||
(action handler-action))
|
||||
|
||||
(define* (handler% description action)
|
||||
(make-handler description action))
|
||||
(define handler make-handler)
|
||||
|
||||
(define-syntax handler
|
||||
(syntax-rules ()
|
||||
((_ description (action arg ...))
|
||||
(handler%
|
||||
description
|
||||
(lambda (ctx)
|
||||
(action (resolve-context-refs ctx arg) ...))))))
|
||||
|
||||
(define (run-handler conn ctx h)
|
||||
(define (run-handler ctx h)
|
||||
(match h
|
||||
(($ <handler> description action)
|
||||
(format #t "RUNNING HANDLER ~a~%" description)
|
||||
((action ctx) conn))))
|
||||
(action ctx))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
(define-module (ordo play)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1) ; list utils
|
||||
#:use-module (srfi srfi-9) ; records
|
||||
|
|
@ -19,10 +20,11 @@
|
|||
(handlers play-handlers))
|
||||
|
||||
(define* (play description #:key connection tasks (vars '()) (handlers '()))
|
||||
;; TODO: validation could be better - check for non-empty tasks list, check
|
||||
;; type of connection, tasks, and handlers, etc.
|
||||
(unless connection (error "connection is required"))
|
||||
(unless tasks (error "tasks are required"))
|
||||
(unless (is-a? connection <connection>) (error (format #f "invalid connection: ~a" connection)))
|
||||
(unless (and tasks (not (null? tasks))) (error "tasks are required"))
|
||||
(unless (every task? tasks) (error "invalid tasks"))
|
||||
(unless (every (compose handler? cdr) handlers) (error "invalid handlers"))
|
||||
(for-each (lambda (task)
|
||||
(for-each (lambda (trigger)
|
||||
(unless (assoc-ref handlers trigger)
|
||||
|
|
@ -31,13 +33,7 @@
|
|||
trigger))))
|
||||
(task-triggers task)))
|
||||
tasks)
|
||||
(make-play description connection vars tasks handlers))
|
||||
|
||||
(define (run-trigger conn ctx handlers trigger)
|
||||
(let ((h (assoc-ref handlers trigger)))
|
||||
(unless h
|
||||
(error (format #f "no handler defined for trigger ~a" trigger)))
|
||||
(run-handler conn ctx h)))
|
||||
(make-play description connection (fold (match-lambda* (((k . v) accum) (alist-cons k v accum))) '() vars) tasks handlers))
|
||||
|
||||
(define (run-play play)
|
||||
(format #t "RUNNING PLAY ~a~%" (play-description play))
|
||||
|
|
@ -45,14 +41,15 @@
|
|||
(play-connection play)
|
||||
(lambda (c)
|
||||
(let* ((tmp-dir (car (connection-must c "mktemp" '("--directory"))))
|
||||
(ctx (context #:scratch-dir tmp-dir #:init-vars (play-vars play))))
|
||||
(ctx (make-context c (play-vars play) tmp-dir)))
|
||||
(pk ctx)
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda ()
|
||||
(for-each (cut run-task c ctx <>) (play-tasks play))
|
||||
(for-each (cut run-task ctx <>) (play-tasks play))
|
||||
(for-each (match-lambda
|
||||
((name . handler)
|
||||
(when (context-triggered? ctx name)
|
||||
(run-handler c ctx handler))))
|
||||
(run-handler ctx handler))))
|
||||
(play-handlers play)))
|
||||
(lambda () (connection-must c "rm" `("-rf" ,tmp-dir))))))))
|
||||
|
|
|
|||
|
|
@ -20,23 +20,14 @@
|
|||
(register task-register)
|
||||
(triggers task-triggers))
|
||||
|
||||
(define* (task% description action #:key (register #f) (triggers '()))
|
||||
(define* (task description action #:key (register #f) (triggers '()))
|
||||
(make-task description action register triggers))
|
||||
|
||||
(define-syntax task
|
||||
(syntax-rules ()
|
||||
((_ description (action arg ...) kwarg ...)
|
||||
(task%
|
||||
description
|
||||
(lambda (ctx)
|
||||
(action (resolve-context-refs ctx arg) ...))
|
||||
kwarg ...))))
|
||||
|
||||
(define (run-task conn ctx t)
|
||||
(define (run-task ctx t)
|
||||
(match t
|
||||
(($ <task> description action register triggers)
|
||||
(format #t "RUNNING TASK ~a~%" description)
|
||||
(let ((result ((action ctx) conn)))
|
||||
(let ((result (action ctx)))
|
||||
(when register
|
||||
(register-context-var! ctx register result))
|
||||
(when triggers
|
||||
|
|
|
|||
33
tryme.scm
33
tryme.scm
|
|
@ -1,11 +1,26 @@
|
|||
(use-modules
|
||||
(ice-9 filesystem)
|
||||
(ordo connection)
|
||||
(ordo context )
|
||||
(ordo action filesystem)
|
||||
(ordo play)
|
||||
(ordo task)
|
||||
(ordo handler))
|
||||
|
||||
;; uname -a => Linux little-rascal 6.11.10-gnu #1 SMP PREEMPT_DYNAMIC 1 x86_64 GNU/Linux
|
||||
;; kernel name: Linux
|
||||
;; node name: little-rascal
|
||||
;; kernel release: 6.11.10-gnu
|
||||
;; kernel version: #1
|
||||
;; machine: SMP PREEMPT_DYNAMIC
|
||||
;; processor: 1
|
||||
;; hardware platform: x86_64
|
||||
;; operating system: GNU/Linux
|
||||
;;
|
||||
;; Linux toolbox 6.12.6-200.fc41.x86_64 #1 SMP PREEMPT_DYNAMIC Thu Dec 19 21:06:34 UTC 2024 x86_64 x86_64 x86_64 GNU/Linux
|
||||
;; uname --kernel-name --nodename --kernel-release --machine --operating-system
|
||||
;; Linux little-rascal 6.11.10-gnu x86_64 GNU/Linux
|
||||
|
||||
(define test-play
|
||||
(play "Test play"
|
||||
#:connection (local-connection)
|
||||
|
|
@ -15,17 +30,21 @@
|
|||
(const "/home/ray/ordo-test-again")
|
||||
#:register 'base-dir)
|
||||
(task "Create test directory"
|
||||
(install-directory ($ 'base-dir)))
|
||||
(lambda (ctx)
|
||||
(install-directory ctx (context-ref ctx 'base-dir))))
|
||||
(task "Create test file from string content"
|
||||
(install-file (file-name-join* ($ 'base-dir) "foo")
|
||||
#:content "Hello, world!\n"))
|
||||
(lambda (ctx)
|
||||
(install-file ctx (file-name-join* (context-ref ctx 'base-dir) "foo")
|
||||
#:content "Hello, world!\n")))
|
||||
(task "Create test file from local source"
|
||||
(install-file (file-name-join* ($ 'base-dir) "bar")
|
||||
#:local-src (file-name-join* ($ 'base-dir) "foo"))
|
||||
(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")))
|
||||
#:triggers '(fritz))
|
||||
(task "Create test file from remote source"
|
||||
(install-file (file-name-join* ($ 'base-dir) "baz")
|
||||
#:remote-src (file-name-join* ($ 'base-dir) "bar"))
|
||||
(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")))
|
||||
#:triggers '(frobnicate)))
|
||||
#:handlers `((frobnicate . ,(handler "Frobnicate" (const #t)))
|
||||
(fritz . ,(handler "Fritz" (const #t)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue