Implement trigger handlers

This commit is contained in:
Ray Miller 2025-01-05 18:24:33 +00:00
parent c290a5caea
commit 297d779ea4
Signed by: ray
GPG key ID: 043F786C4CD681B8
4 changed files with 70 additions and 24 deletions

View file

@ -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

View file

@ -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))))))))

View file

@ -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)

View file

@ -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)