Some refactoring

* Don't export record field setters (unless required)
* Remove get- prefix from record getters
* Introduce handlers (simplified tasks)
This commit is contained in:
Ray Miller 2025-01-05 19:10:42 +00:00
parent 297d779ea4
commit 52f011267b
Signed by: ray
GPG key ID: 043F786C4CD681B8
6 changed files with 89 additions and 51 deletions

View file

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

View file

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

26
modules/ordo/handler.scm Normal file
View file

@ -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 <handler>
(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
(($ <handler> description action)
(format #t "RUNNING HANDLER ~a~%" description)
(action conn ctx))))

View file

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

View file

@ -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 <task>
(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
(($ <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))))))

View file

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