diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index c4c01b6..b27c2b8 100644 --- a/modules/ordo/action/filesystem.scm +++ b/modules/ordo/action/filesystem.scm @@ -32,7 +32,7 @@ ;; Helper not intended for use outside of this module (define (upload-tmp-file conn ctx) (lambda (input-port) - (let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(get-context-scratch-dir ctx)))))) + (let ((tmp-path (car (connection-must conn "mktemp" `("-p" ,(context-scratch-dir ctx)))))) (connection-call-with-output-file conn tmp-path (lambda (output-port) (let loop ((data (get-bytevector-some input-port))) diff --git a/modules/ordo/context.scm b/modules/ordo/context.scm index c106e3e..4c5f155 100644 --- a/modules/ordo/context.scm +++ b/modules/ordo/context.scm @@ -2,26 +2,26 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) - #:export (make-context + #:export (context context? - get-context-scratch-dir - set-context-scratch-dir! + context-scratch-dir add-context-triggers! get-context-triggers - set-context-triggers! - get-context-vars - set-context-vars! + context-triggered? register-context-var! context-ref resolve-context-ref resolve-context-refs)) (define-record-type - (make-context) + (make-context scratch-dir vars) context? - (scratch-dir get-context-scratch-dir set-context-scratch-dir!) - (vars get-context-vars set-context-vars!) - (triggers get-context-triggers set-context-triggers!)) + (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)) (define-record-type (context-ref name) @@ -30,7 +30,7 @@ (define (resolve-context-ref ctx v) (if (context-ref? v) - (assoc-ref (get-context-vars ctx) (var-name v)) + (assoc-ref (context-vars ctx) (var-name v)) v)) (define (resolve-context-refs ctx args) @@ -38,7 +38,11 @@ (define (add-context-triggers! ctx triggers) (when triggers - (set-context-triggers! ctx (fold cons (or (get-context-triggers ctx) '()) triggers)))) + (set-context-triggers! ctx + (apply lset-adjoin equal? (or (context-triggers ctx) '()) triggers)))) + +(define (context-triggered? ctx trigger) + (find (lambda (t) (equal? t trigger)) (context-triggers ctx))) (define (register-context-var! ctx var-name val) - (set-context-vars! ctx (assoc-set! (get-context-vars ctx) var-name val))) + (set-context-vars! ctx (assoc-set! (context-vars ctx) var-name val))) diff --git a/modules/ordo/handler.scm b/modules/ordo/handler.scm new file mode 100644 index 0000000..d156d6c --- /dev/null +++ b/modules/ordo/handler.scm @@ -0,0 +1,26 @@ +(define-module (ordo handler) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-26) ; cut + #:use-module (ordo context) + #:export (handler + handler? + handler-description + handler-action + run-handler)) + +(define-record-type + (make-handler description action) + handler? + (description handler-description) + (action handler-action)) + +(define* (handler description action) + (make-handler description action)) + +(define (run-handler conn ctx handler) + (match handler + (($ description action) + (format #t "RUNNING HANDLER ~a~%" description) + (action conn ctx)))) diff --git a/modules/ordo/play.scm b/modules/ordo/play.scm index 99f14f1..e480bfe 100644 --- a/modules/ordo/play.scm +++ b/modules/ordo/play.scm @@ -1,51 +1,58 @@ (define-module (ordo play) + #:use-module (ice-9 match) #: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) + #:use-module (ordo handler) #:export (play run-play)) (define-record-type - (make-play description connection tasks handlers) + (make-play description connection vars tasks handlers) play? - (connection get-play-connection) - (description get-play-description) - (tasks get-play-tasks) - (handlers get-play-handlers)) + (connection play-connection) + (vars play-vars) + (description play-description) + (tasks play-tasks) + (handlers play-handlers)) -(define* (play description #:key connection tasks (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")) (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) + (task-description task) trigger)))) - (get-task-triggers task))) + (task-triggers task))) tasks) - (make-play description connection tasks handlers)) + (make-play description connection vars tasks handlers)) (define (run-trigger conn ctx handlers trigger) - (let ((handler (assoc-ref handlers trigger))) - (unless handler + (let ((h (assoc-ref handlers trigger))) + (unless h (error (format #f "no handler defined for trigger ~a" trigger))) - (run-task conn ctx handler))) + (run-handler conn ctx h))) (define (run-play play) - (format #t "Running play ~a~%" (get-play-description play)) + (format #t "RUNNING PLAY ~a~%" (play-description play)) (call-with-connection - (get-play-connection play) + (play-connection play) (lambda (c) - (let ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) - (ctx (make-context))) - (set-context-scratch-dir! ctx tmp-dir) + (let* ((tmp-dir (car (connection-must c "mktemp" '("--directory")))) + (ctx (context #:scratch-dir tmp-dir #:init-vars (play-vars play)))) (dynamic-wind (const #t) (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)))) + (for-each (cut run-task c ctx <>) (play-tasks play)) + (for-each (match-lambda + ((name . handler) + (when (context-triggered? ctx name) + (run-handler c ctx handler)))) + (play-handlers play))) (lambda () (connection-must c "rm" `("-rf" ,tmp-dir)))))))) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm index b20073e..4e2529f 100644 --- a/modules/ordo/task.scm +++ b/modules/ordo/task.scm @@ -6,21 +6,19 @@ #:use-module (ordo context) #:export (task task? - get-task-description - set-task-description! - get-task-register - set-task-register! - get-task-triggers - set-task-triggers! + task-description + task-action + task-register + task-triggers run-task)) (define-record-type (make-task description action register triggers) task? - (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!)) + (description task-description) + (action task-action) + (register task-register) + (triggers task-triggers)) (define* (task description action #:key (register #f) (triggers '())) (make-task description action register triggers)) @@ -28,10 +26,9 @@ (define (run-task conn ctx task) (match task (($ description action register triggers) - (format #t "START ~a~%" description) + (format #t "RUNNING TASK ~a~%" description) (let ((result (action conn ctx))) (when register (register-context-var! ctx register result)) (when triggers - (add-context-triggers! ctx triggers)) - (format #t "END~%"))))) + (add-context-triggers! ctx triggers)))))) diff --git a/tryme.scm b/tryme.scm index 1199a63..91511ed 100644 --- a/tryme.scm +++ b/tryme.scm @@ -2,7 +2,8 @@ (ordo connection) (ordo action filesystem) (ordo play) - (ordo task)) + (ordo task) + (ordo handler)) (define test-play (play "Test play" @@ -13,10 +14,13 @@ (task "Create test file from string content" (install-file "/home/ray/ordo-test/foo" #:content "Hello, world!\n")) (task "Create test file from local source" - (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo")) + (install-file "/home/ray/ordo-test/bar" #:local-src "/home/ray/ordo-test/foo") + #:triggers '(fritz)) (task "Create test file from remote source" (install-file "/home/ray/ordo-test/baz" #:remote-src "/home/ray/ordo-test/bar") - #:triggers `(frobnicate))) - #:handlers `((frobnicate . ,(task "Frobnicate" (const #t)))))) + #:triggers '(frobnicate))) + #:handlers `((frobnicate . ,(handler "Frobnicate" (const #t))) + (fritz . ,(handler "Fritz" (const #t))) + (frotz . ,(handler "Frotz" (const #t)))))) ;;(run-play test-play)