Implement trigger handlers
This commit is contained in:
parent
c290a5caea
commit
297d779ea4
4 changed files with 70 additions and 24 deletions
|
@ -7,6 +7,10 @@
|
|||
get-context-scratch-dir
|
||||
set-context-scratch-dir!
|
||||
add-context-triggers!
|
||||
get-context-triggers
|
||||
set-context-triggers!
|
||||
get-context-vars
|
||||
set-context-vars!
|
||||
register-context-var!
|
||||
context-ref
|
||||
resolve-context-ref
|
||||
|
|
|
@ -1,18 +1,51 @@
|
|||
(define-module (ordo play)
|
||||
#:use-module (srfi srfi-1) ; list utils
|
||||
#:use-module (srfi srfi-9) ; records
|
||||
#:use-module (srfi srfi-26) ; cut
|
||||
#:use-module (ordo connection)
|
||||
#:use-module (ordo context)
|
||||
#:use-module (ordo task)
|
||||
#:export (play))
|
||||
#:export (play run-play))
|
||||
|
||||
(define (play conn tasks)
|
||||
(define-record-type <play>
|
||||
(make-play description connection tasks handlers)
|
||||
play?
|
||||
(connection get-play-connection)
|
||||
(description get-play-description)
|
||||
(tasks get-play-tasks)
|
||||
(handlers get-play-handlers))
|
||||
|
||||
(define* (play description #:key connection tasks (handlers '()))
|
||||
(unless connection (error "connection is required"))
|
||||
(unless tasks (error "tasks are required"))
|
||||
(for-each (lambda (task)
|
||||
(for-each (lambda (trigger)
|
||||
(unless (assoc-ref handlers trigger)
|
||||
(error (format #f "task \"~a\" references an undefined trigger: ~a"
|
||||
(get-task-description task)
|
||||
trigger))))
|
||||
(get-task-triggers task)))
|
||||
tasks)
|
||||
(make-play description connection tasks handlers))
|
||||
|
||||
(define (run-trigger conn ctx handlers trigger)
|
||||
(let ((handler (assoc-ref handlers trigger)))
|
||||
(unless handler
|
||||
(error (format #f "no handler defined for trigger ~a" trigger)))
|
||||
(run-task conn ctx handler)))
|
||||
|
||||
(define (run-play play)
|
||||
(format #t "Running play ~a~%" (get-play-description play))
|
||||
(call-with-connection
|
||||
conn
|
||||
(get-play-connection play)
|
||||
(lambda (c)
|
||||
(let ((tmp-dir (car (connection-must c "mktemp" '("--directory"))))
|
||||
(ctx (make-context)))
|
||||
(set-context-scratch-dir! ctx tmp-dir)
|
||||
(dynamic-wind
|
||||
(const #t)
|
||||
(lambda () (for-each (cut run-task c ctx <>) tasks))
|
||||
(lambda ()
|
||||
(for-each (cut run-task c ctx <>) (get-play-tasks play))
|
||||
(for-each (cut run-trigger c ctx (get-play-handlers play) <>)
|
||||
(delete-duplicates (get-context-triggers ctx))))
|
||||
(lambda () (connection-must c "rm" `("-rf" ,tmp-dir))))))))
|
||||
|
|
|
@ -4,17 +4,25 @@
|
|||
#:use-module (srfi srfi-9) ; records
|
||||
#:use-module (srfi srfi-26) ; cut
|
||||
#:use-module (ordo context)
|
||||
#:export (task run-task))
|
||||
#:export (task
|
||||
task?
|
||||
get-task-description
|
||||
set-task-description!
|
||||
get-task-register
|
||||
set-task-register!
|
||||
get-task-triggers
|
||||
set-task-triggers!
|
||||
run-task))
|
||||
|
||||
(define-record-type <task>
|
||||
(make-task description action register triggers)
|
||||
task?
|
||||
(description get-description set-description!)
|
||||
(action get-action set-action!)
|
||||
(register get-register set-regiseter!)
|
||||
(triggers get-triggers set-triggers!))
|
||||
(description get-task-description set-task-description!)
|
||||
(action get-task-action set-task-action!)
|
||||
(register get-task-register set-task-regiseter!)
|
||||
(triggers get-task-triggers set-task-triggers!))
|
||||
|
||||
(define* (task description action #:key register triggers)
|
||||
(define* (task description action #:key (register #f) (triggers '()))
|
||||
(make-task description action register triggers))
|
||||
|
||||
(define (run-task conn ctx task)
|
||||
|
|
15
tryme.scm
15
tryme.scm
|
@ -4,9 +4,10 @@
|
|||
(ordo play)
|
||||
(ordo task))
|
||||
|
||||
(define (tryme)
|
||||
(play (local-connection)
|
||||
(list
|
||||
(define test-play
|
||||
(play "Test play"
|
||||
#:connection (local-connection)
|
||||
#:tasks (list
|
||||
(task "Create test directory"
|
||||
(install-directory "/home/ray/ordo-test"))
|
||||
(task "Create test file from string content"
|
||||
|
@ -14,8 +15,8 @@
|
|||
(task "Create test file from local source"
|
||||
(install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo"))
|
||||
(task "Create test file from remote source"
|
||||
(install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar"))
|
||||
(task "Expect this to fail"
|
||||
(install-file "/root/ordo.txt" #:content "Hello from Ordo!")))))
|
||||
(install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar")
|
||||
#:triggers `(frobnicate)))
|
||||
#:handlers `((frobnicate . ,(task "Frobnicate" (const #t))))))
|
||||
|
||||
(tryme)
|
||||
;;(run-play test-play)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue