Bugfix interceptor and add example

examples/interceptor.scm

@@ -1,66 +1,31 @@
 (use-modules
  (ice-9 filesystem)
- (oop goops)
  (logging logger)
- (srfi srfi-26)
- (ordo logger)
- (ordo interceptor)
  (ordo connection)
- (ordo connection sudo)
+ (ordo interceptor)
- (ordo action filesystem))
+ (ordo interceptor tmp-dir)
-
+ (ordo interceptor debug)
-(define* (i:connection c #:key sudo? sudo-user sudo-password)
+ (ordo action filesystem)
-  "Interceptor to manage the current connection."
+ (ordo logger))
-  (interceptor
-   "manage-connection"
-   #:enter (lambda (ctx)
-             (let ((c (if sudo?
-                          (make <sudo-connection> #:connection c #:become-user sudo-user #:become-password sudo-password)
-                          c)))
-               (conn:setup c)
-               (set-context-connection! ctx c)))
-   #:leave (lambda (ctx)
-             (and=> (context-connection ctx) conn:teardown)
-             (set-context-connection! ctx #f))))
-
-(define (i:handle-errors)
-  "Interceptor to log (and clear) the context error. This will allow any
-   earlier #:leave handlers in the chain to run normally."
-  (interceptor
-   "handle-errors"
-   #:error (lambda (ctx)
-             (and=> (context-error ctx) (cut log-msg 'ERROR <>))
-             (set-context-error! ctx #f))))
-
-(define (i:tmp-dir)
-  "Interceptor to manage a temporary directory."
-  (interceptor
-   "tmp-dir"
-   #:enter (lambda (ctx)
-             (var-set! ctx 'tmp-dir (fs:create-tmp-dir (context-connection ctx))))
-   #:leave (lambda (ctx)
-             (and=> (var-ref ctx 'tmp-dir #f)
-                    (cut fs:remove (context-connection ctx) <> #:recurse? #t))
-             (var-delete! ctx 'tmp-dir))))
 
 (define chain
-  (list (i:connection (local-connection))
+  (list (connection-interceptor (local-connection))
-        (i:tmp-dir)
+        (tmp-dir-interceptor #:tmp-dir)
-        (i:handle-errors)
         (interceptor
-         "hello-world"
+         "install hello"
          #:enter (lambda (ctx)
-                   (var-set! ctx 'hello
+                   (fs:install-file (context-connection ctx)
-                             (fs:install-file (context-connection ctx)
+                                    (file-name-join* (var-ref ctx #:tmp-dir) "hello.txt")
-                                              (file-name-join* (var-ref ctx 'tmp-dir)
+                                    #:content "Hello, world!\n"))
-                                                               "hello.txt")
+         #:register #:hello)
-                                              #:content "Hello, world!\n"))))
         (interceptor
-         "get-file-status"
+         "stat hello"
          #:enter (lambda (ctx)
-                   (let ((st (fs:stat (context-connection ctx) (var-ref ctx 'hello))))
+                   (fs:stat (context-connection ctx) (var-ref ctx #:hello)))
-                     (log-msg 'INFO "stat result: " st))))))
+         #:register #:hello-stat)
+        (debug-vars-interceptor #:hello #:hello-stat)
+        (debug-vars-interceptor)))
 
-(setup-logging #:level 'DEBUG)
+(setup-logging #:level 'INFO)
 (execute (init-context) chain)
 (shutdown-logging)

modules/ordo/connection.scm

@@ -9,15 +9,16 @@
   #:use-module (ordo connection local)
   #:use-module (ordo connection ssh)
   #:use-module (ordo connection sudo)
+  #:use-module (ordo interceptor)
   #:use-module (ordo util flatten)
   #:use-module (ordo util shell-quote)
   #:use-module (ordo util keyword-args)
-  #:export (connection?
+  #:export (connection-interceptor
+            connection?
             local-connection
             ssh-connection
             call-with-connection
-            run)
+            run))
-  #:re-export (conn:setup conn:teardown))
 
 (define (connection? c)
   (is-a? c <connection>))
@@ -67,3 +68,17 @@
                                 (make-external-error)
                                 (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog)))))
           (values (return out) rc)))))
+
+(define* (connection-interceptor c #:key sudo? sudo-user sudo-password)
+  "Interceptor to manage the current connection."
+  (interceptor
+   "manage-connection"
+   #:enter (lambda (ctx)
+             (let ((c (if sudo?
+                          (make <sudo-connection> #:connection c #:become-user sudo-user #:become-password sudo-password)
+                          c)))
+               (conn:setup c)
+               (set-context-connection! ctx c)))
+   #:leave (lambda (ctx)
+             (and=> (context-connection ctx) conn:teardown)
+             (set-context-connection! ctx #f))))

modules/ordo/interceptor.scm

@@ -3,9 +3,9 @@
   #:use-module (logging logger)
   #:use-module (srfi srfi-1)  ; list utils
   #:use-module (srfi srfi-9)  ; records
+  #:use-module (srfi srfi-26) ; cut
   #:use-module (srfi srfi-69) ; hash tables
   #:use-module (srfi srfi-71) ; extended let
-  #:use-module (ordo connection)
   #:export (interceptor
             init-context
             context-connection
@@ -13,23 +13,20 @@
             context-error
             set-context-error!
             context-suppressed
-            terminate-when
+            context-vars
-            execute
+            set-context-vars!
-            var-set!
             var-ref
-            var-delete!))
+            var-set!
+            var-delete!
+            terminate-when
+            execute))
 
-(define-record-type <interceptor>
+(define (check-var-name name)
-  (make-interceptor name enter leave error)
+  (unless (keyword? name)
-  interceptor?
+    (raise-exception (make-exception
-  (name interceptor-name)
+                      (make-assertion-failure)
-  (enter interceptor-enter)
+                      (make-exception-with-message "Variable name should be a keyword")
-  (leave interceptor-leave)
+                      (make-exception-with-irritants name)))))
-  (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)
@@ -44,6 +41,7 @@
 
 (define* (init-context #:key conn (vars '()))
   "Initialize a context with optional connection and vars."
+  (for-each check-var-name (map car vars))
   (make-context
    ;; connection
    conn
@@ -60,6 +58,34 @@
    ;; suppressed errors
    '()))
 
+(define (var-set! ctx name value)
+  (check-var-name name)
+  (log-msg 'DEBUG "Setting variable " name " to " value)
+  (hash-table-set! (context-vars ctx) name value))
+
+(define* (var-ref ctx name #:optional default)
+  (check-var-name name)
+  (log-msg 'DEBUG "Getting variable " name " with default " default)
+  (hash-table-ref/default (context-vars ctx) name default))
+
+(define (var-delete! ctx name)
+  (check-var-name name)
+  (log-msg 'DEBUG "Deleting variable " name)
+  (hash-table-delete! (context-vars ctx) name))
+
+(define-record-type <interceptor>
+  (make-interceptor name enter leave error register)
+  interceptor?
+  (name interceptor-name)
+  (enter interceptor-enter)
+  (leave interceptor-leave)
+  (error interceptor-error)
+  (register interceptor-register))
+
+(define* (interceptor name #:key enter leave error register)
+  "Create an interceptor with optional enter, leave, and error functions."
+  (make-interceptor name enter leave error register))
+
 (define-exception-type &interceptor-error &error
   make-interceptor-error
   interceptor-error?
@@ -91,19 +117,21 @@
   "Run the interceptor's #:enter function."
   (let ((handler (interceptor-enter t)))
     (when handler
-      (log-msg 'INFO "Running #:enter function for " (interceptor-name t))
+      (log-msg 'NOTICE "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))
+        (lambda ()
+          (let ((result (handler ctx)))
+            (and=> (interceptor-register t) (cut var-set! ctx <> result))))
         #: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))
+      (log-msg 'NOTICE "Running #:leave function for " (interceptor-name t))
       (with-exception-handler
           (lambda (e)
             (set-context-error! ctx
@@ -115,7 +143,7 @@
   "Run the interceptor's #:error function."
   (let ((handler (interceptor-error t)))
     (when handler
-      (log-msg 'INFO "Running #:error function for " (interceptor-name t))
+      (log-msg 'NOTICE "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)
@@ -143,22 +171,24 @@
 
 (define (execute-enter ctx)
   "Run all the #:enter functions in the queue."
-  (unless (null? (context-queue ctx))
+  (if (null? (context-queue ctx))
-    (let ((t (car (context-queue ctx))))
+      ;; Prepare to leave
-      ;; Run the enter handler for the interceptor
+      (set-context-queue! ctx (context-stack ctx))
-      (try-enter ctx t)
+      (let ((t (car (context-queue ctx))))
-      ;; Remove the current interceptor from the queue and add it to the stack
+        ;; Run the enter handler for the interceptor
-      (set-context-stack! ctx (cons t (context-stack ctx)))
+        (try-enter ctx t)
-      (set-context-queue! ctx (cdr (context-queue ctx)))
+        ;; Remove the current interceptor from the queue and add it to the stack
-      (if (context-error ctx)
+        (set-context-stack! ctx (cons t (context-stack ctx)))
-          ;; If an error was caught, abort the enter phase and set up to run the leave phase
+        (set-context-queue! ctx (cdr (context-queue ctx)))
-          (begin
+        (if (context-error ctx)
-            (set-context-queue! ctx (context-stack ctx))
+            ;; If an error was caught, abort the enter phase and set up to run the leave phase
-            (set-context-stack! ctx '()))
+            (begin
-          ;; Otherwise, check for early termination or carry on down the chain
+              (set-context-queue! ctx (context-stack ctx))
-          (begin
+              (set-context-stack! ctx '()))
-            (check-terminators ctx)
+            ;; Otherwise, check for early termination or carry on down the chain
-            (execute-enter ctx))))))
+            (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."
@@ -166,16 +196,10 @@
 
 (define (execute ctx interceptors)
   "Execute all the interceptors on the given context."
+  (log-msg 'DEBUG "Enqueuing interceptors: " (map interceptor-name interceptors))
   (enqueue ctx interceptors)
+  (log-msg 'DEBUG "Starting #:enter chain: " (map interceptor-name (context-queue ctx)))
   (execute-enter ctx)
+  (log-msg 'DEBUG "Starting #:leave chain: " (map interceptor-name (context-queue ctx)))
   (execute-leave ctx)
   (and=> (context-error ctx) raise-exception))
-
-(define (var-set! ctx name value)
-  (hash-table-set! (context-vars ctx) name value))
-
-(define* (var-ref ctx name #:optional default)
-  (hash-table-ref/default (context-vars ctx) name default))
-
-(define (var-delete! ctx name)
-  (hash-table-delete! (context-vars ctx) name))

modules/ordo/interceptor/debug.scm

@@ -0,0 +1,16 @@
+(define-module (ordo interceptor debug)
+  #:use-module (ice-9 pretty-print)
+  #:use-module ((srfi srfi-1) #:select (concatenate))
+  #:use-module ((srfi srfi-69) #:select (hash-table-keys))
+  #:use-module (ordo interceptor)
+  #:export (debug-vars-interceptor))
+
+(define (debug-vars-interceptor . var-names)
+  (interceptor
+   "debug-vars"
+   #:enter (lambda (ctx)
+             (let ((var-names (if (null? var-names)
+                                  (hash-table-keys (context-vars ctx))
+                                  var-names)))
+               (pretty-print (map (lambda (v) (list v (var-ref ctx v 'not-found)))
+                                  var-names))))))

modules/ordo/interceptor/errors.scm

@@ -0,0 +1,14 @@
+(define-module (ordo interceptor errors)
+  #:use-module (logging logger)
+  #:use-module (srfi srfi-26)
+  #:use-module (ordo interceptor)
+  #:export (errors-interceptor))
+
+(define (errors-interceptor)
+  "Interceptor to log (and clear) the context error. This will allow any
+   earlier #:leave handlers in the chain to run normally."
+  (interceptor
+   "handle-errors"
+   #:error (lambda (ctx)
+             (and=> (context-error ctx) (cut log-msg 'ERROR <>))
+             (set-context-error! ctx #f))))

modules/ordo/interceptor/tmp-dir.scm

@@ -0,0 +1,20 @@
+(define-module (ordo interceptor tmp-dir)
+  #:use-module (ice-9 format)
+  #:use-module (ordo connection)
+  #:use-module (ordo interceptor)
+  #:export (tmp-dir-interceptor))
+
+(define (tmp-dir-interceptor var-name)
+  (define (create-tmp-dir ctx)
+    (run (context-connection ctx) "mktemp" "--directory" #:check? #t #:return car))
+  (define (cleanup-tmp-dir ctx)
+    (and=> (var-ref ctx var-name #f)
+           (lambda (dir-name)
+             (run (context-connection ctx) "rm" "-rf" dir-name)))
+    (var-delete! ctx var-name))
+  (interceptor
+   (format #f "manage-tmp-dir ~a" var-name)
+   #:enter create-tmp-dir
+   #:register var-name
+   #:leave cleanup-tmp-dir
+   #:error cleanup-tmp-dir))