Experiment with interceptor chains

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 <interceptor>
+  (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 <context>
+  (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))))))

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 <play>
+  (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"))))))