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)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue