diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm new file mode 100644 index 0000000..0e60674 --- /dev/null +++ b/modules/ordo/interceptor.scm @@ -0,0 +1,207 @@ +(define-module (ordo interceptor) + #:use-module (ice-9 exceptions) + #:use-module (logging logger) + #:use-module (srfi srfi-1) ; list utils + #:use-module (srfi srfi-9) ; records + #:use-module (srfi srfi-69) ; hash tables + #:use-module (srfi srfi-71) ; extended let + #:use-module (ordo connection) + #:export (interceptor + init-context + context-error + set-context-error! + context-suppressed + terminate-when + execute + bind + unbind + run + must)) + +(define-record-type + (make-interceptor name enter leave error) + interceptor? + (name interceptor-name) + (enter interceptor-enter) + (leave interceptor-leave) + (error interceptor-error)) + +(define* (interceptor name #:key enter leave error) + "Create an interceptor with optional enter, leave, and error functions." + (make-interceptor name enter leave error)) + +(define-record-type + (make-context connection vars stack queue terminators error suppressed) + context? + (connection context-connection set-context-connection!) + (vars context-vars set-context-vars!) + (stack context-stack set-context-stack!) + (queue context-queue set-context-queue!) + (terminators context-terminators set-context-terminators!) + (error context-error set-context-error!) + (suppressed context-suppressed set-context-suppressed!)) + +(define* (init-context conn #:key (vars '())) + "Initialize a context with optional vars." + (make-context + ;; connection + conn + ;; vars + (alist->hash-table vars equal?) + ;; stack + '() + ;; queue + '() + ;; terminators + '() + ;; error + #f + ;; suppressed errors + '())) + +(define-exception-type &interceptor-error &error + make-interceptor-error + interceptor-error? + (interceptor-name interceptor-error-interceptor-name) + (stage interceptor-error-stage) + (cause interceptor-error-cause)) + +(define (enqueue ctx interceptors) + "Add interceptors to the context." + (unless (every interceptor? interceptors) + (error "invalid interceptors")) + (set-context-queue! ctx interceptors)) + +(define (terminate ctx) + "Remove all remaining interceptors from the queue, short-circuiting the + enter stage and running the leave stage." + (set-context-queue! ctx '())) + +(define (check-terminators ctx) + "Check the context terminators and possibly trigger early termination." + (let loop ((terminators (context-terminators ctx))) + (unless (null? terminators) + (let ((t (car terminators))) + (if (t ctx) + (terminate ctx) + (loop (cdr terminators))))))) + +(define (try-enter ctx t) + "Run the interceptor's #:enter function." + (let ((handler (interceptor-enter t))) + (when handler + (log-msg 'INFO "Running #:enter function for " (interceptor-name t)) + (with-exception-handler + (lambda (e) + (set-context-error! ctx + (make-interceptor-error (interceptor-name t) #:enter e))) + (lambda () (handler ctx)) + #:unwind? #t)))) + +(define (try-leave ctx t) + "Run the interceptor's #:leave function." + (let ((handler (interceptor-leave t))) + (when handler + (log-msg 'INFO "Running #:leave function for " (interceptor-name t)) + (with-exception-handler + (lambda (e) + (set-context-error! ctx + (make-interceptor-error (interceptor-name t) #:leave e))) + (lambda () (handler ctx)) + #:unwind? #t)))) + +(define (try-error ctx t err) + "Run the interceptor's #:error function." + (let ((handler (interceptor-error t))) + (when handler + (log-msg 'INFO "Running #:error function for " (interceptor-name t)) + (with-exception-handler + (lambda (e) + (log-msg 'WARN "error handler for interceptor '" (interceptor-name t) "' threw error: " e) + (set-context-suppressed! ctx + (cons (make-interceptor-error (interceptor-name t) #:error e) + (context-suppressed ctx)))) + (lambda () (handler ctx (context-error ctx))) + #:unwind? #t)))) + +(define (execute-leave ctx) + "Run all the #:leave functions in the queue." + (unless (null? (context-queue ctx)) + (let ((t (car (context-queue ctx))) + (err (context-error ctx))) + ;; Run the error or leave handler, according to whether or not we are + ;; handling an error + (if err + (try-error ctx t err) + (try-leave ctx t)) + ;; Remove the current interceptor from the queue and add it to the stack + (set-context-stack! ctx (cons t (context-stack ctx))) + (set-context-queue! ctx (cdr (context-queue ctx))) + ;; Carry on down the chain + (execute-leave ctx)))) + +(define (execute-enter ctx) + "Run all the #:enter functions in the queue." + (unless (null? (context-queue ctx)) + (let ((t (car (context-queue ctx)))) + ;; Run the enter handler for the interceptor + (try-enter ctx t) + ;; Remove the current interceptor from the queue and add it to the stack + (set-context-stack! ctx (cons t (context-stack ctx))) + (set-context-queue! ctx (cdr (context-queue ctx))) + (if (context-error ctx) + ;; If an error was caught, abort the enter phase and execute the leave phase + (begin + (set-context-queue! ctx (context-stack ctx)) + (set-context-stack! ctx '()) + (execute-leave ctx)) + ;; Otherwise, check for early termination or carry on down the chain + (begin + (check-terminators ctx) + (execute-enter ctx)))))) + +(define (terminate-when ctx pred) + "Add a predicate for a termination condition to exit the #:enter chain early." + (set-context-terminators! ctx (cons pred (context-terminators ctx)))) + +(define (execute ctx interceptors) + "Execute all the interceptors on the given context." + (enqueue ctx interceptors) + (execute-enter ctx) + (execute-leave ctx)) + +(define-syntax bind + (syntax-rules () + ((bind ctx name value) + (hash-table-set! (context-vars ctx) (quote name) value)))) + +(define-syntax unbind + (syntax-rules () + ((unbind ctx name) + (hash-table-ref (context-vars ctx) (quote name))) + ((unbind ctx name default) + (hash-table-ref/default (context-vars ctx) (quote name) default)))) + +(define (keyword-arg kw args) + (cond + ((< (length args) 2) #f) + ((equal? (first args) kw) (second args)) + (else (keyword-arg kw (cddr args))))) + +(define (run ctx prog . args) + (let* ((args kwargs (break keyword? args)) + (pwd (keyword-arg #:pwd kwargs)) + (env (keyword-arg #:env kwargs))) + (connection-run (context-connection ctx) pwd env prog args))) + +(define (must ctx prog . args) + (let* ((args kwargs (break keyword? args)) + (pwd (keyword-arg #:pwd kwargs)) + (env (keyword-arg #:env kwargs)) + (error-msg (keyword-arg #:error-msg kwargs)) + (out rc (connection-run (context-connection ctx) pwd env prog args))) + (if (zero? rc) + out + (error (if error-msg + (format #f "~a: ~a" error-msg out) + (format #f "~a error: ~a" prog out)))))) diff --git a/tryme-interceptors.scm b/tryme-interceptors.scm new file mode 100644 index 0000000..00a8ded --- /dev/null +++ b/tryme-interceptors.scm @@ -0,0 +1,55 @@ +(use-modules + (ice-9 filesystem) + (logging logger) + (srfi srfi-9) + (ordo connection) + (ordo interceptor) + (ordo logger)) + +(define-record-type + (make-play name connection vars interceptors) + play? + (connection play-connection) + (vars play-vars) + (name play-name) + (interceptors play-interceptors)) + +(define* (play #:key name connection (interceptors '()) (vars '())) + (make-play name connection vars interceptors)) + +(define (run-play play) + (dynamic-wind + (lambda () + (log-msg 'NOTICE "Running play: " (play-name play)) + (init-connection! (play-connection play))) + (lambda () + (let ((ctx (init-context (play-connection play) #:vars (play-vars play)))) + (execute ctx (play-interceptors play)) + (if (context-error ctx) + (log-msg 'ERROR "Play " (play-name play) " terminated with error: " (context-error ctx)) + (log-msg 'NOTICE "Completed play: " (play-name play))))) + (lambda () + (close-connection! (play-connection play))))) + +(define test-play + (play + #:name "Test play" + #:connection (local-connection) + #:vars '((base-dir . "/home/ray/ordo-test")) + #:interceptors (list + (interceptor + "Handle errors" + #:error (lambda (ctx err) + (log-msg 'WARN "Handling error " err) + (set-context-error! ctx #f))) + (interceptor + "Create base directory" + #:enter (lambda (ctx) + (must ctx "mkdir" "-p" (unbind ctx base-dir)))) + (interceptor + "Create test file" + #:enter (lambda (ctx) + (must ctx "touch" (file-name-join* (unbind ctx base-dir) "test-file")))) + (interceptor + "Throw an error" + #:enter (lambda (ctx) (error "badness"))))))