Bugfixes and interceptor chain example.

examples/interceptor.scm

@@ -0,0 +1,66 @@
+(use-modules
+ (ice-9 filesystem)
+ (oop goops)
+ (logging logger)
+ (srfi srfi-26)
+ (ordo logger)
+ (ordo interceptor)
+ (ordo connection)
+ (ordo connection sudo)
+ (ordo action filesystem))
+
+(define* (i:connection 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))))
+
+(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))
+        (i:tmp-dir)
+        (i:handle-errors)
+        (interceptor
+         "hello-world"
+         #:enter (lambda (ctx)
+                   (var-set! ctx 'hello
+                             (fs:install-file (context-connection ctx)
+                                              (file-name-join* (var-ref ctx 'tmp-dir)
+                                                               "hello.txt")
+                                              #:content "Hello, world!\n"))))
+        (interceptor
+         "get-file-status"
+         #:enter (lambda (ctx)
+                   (let ((st (fs:stat (context-connection ctx) (var-ref ctx 'hello))))
+                     (log-msg 'INFO "stat result: " st))))))
+
+(setup-logging #:level 'DEBUG)
+(execute (init-context) chain)
+(shutdown-logging)

modules/ordo/action/filesystem.scm

@@ -8,6 +8,7 @@
   #:use-module (srfi srfi-71) ; extended let
   #:use-module ((srfi srfi-197) #:select (chain-when))
   #:use-module ((ordo connection) #:select (run))
+  #:use-module (ordo connection base)
   #:export (fs:create-tmp-dir
             fs:install-dir
             fs:install-file
@@ -53,13 +54,13 @@
        #:check? #t))
 
 (define* (fs:create-tmp-dir conn #:key tmpdir suffix template)
-  (match-let (((tmp-dir) (run conn "mktemp" (chain-when
+  (run conn "mktemp" (chain-when
-                                             '("--directory")
+                      '("--directory")
-                                             (tmpdir (append _ `("--tmpdir" tmpdir)))
+                      (tmpdir (append _ `("--tmpdir" tmpdir)))
-                                             (suffix (append _ `("--suffix" suffix)))
+                      (suffix (append _ `("--suffix" suffix)))
-                                             (template (append _ `(template))))
+                      (template (append _ `(template))))
-                              #:check? #t)))
+       #:check? #t
-    tmp-dir))
+       #:return car))
 
 (define* (fs:install-dir conn path #:key owner group mode)
   (when (integer? mode)
@@ -75,13 +76,13 @@
 
 (define (upload-tmp-file conn tmp-file)
   (lambda (input-port)
-    (connection-call-with-output-file conn tmp-file
+    (conn:call-with-output-file conn tmp-file
-                                      (lambda (output-port)
+                                (lambda (output-port)
-                                        (let loop ((data (get-bytevector-some input-port)))
+                                  (let loop ((data (get-bytevector-some input-port)))
-                                          (unless (eof-object? data)
+                                    (unless (eof-object? data)
-                                            (put-bytevector output-port data)
+                                      (put-bytevector output-port data)
-                                            (loop (get-bytevector-some input-port))))
+                                      (loop (get-bytevector-some input-port))))
-                                        (close-port output-port)))))
+                                  (close-port output-port)))))
 
 (define (install-remote-file conn src dest owner group mode backup?)
   ;; If owner/group/mode is unspecified and the destination file already exists,
@@ -112,7 +113,7 @@
       ;; Because we might need sudo to install the remote file, we first
       ;; upload the source to a temporary file, then call @code{install-remote-file} to
       ;; install the temporary file to the target path.
-      (let ((tmp-file (run conn "mktemp" #:check? #t #:result car)))
+      (let ((tmp-file (run conn "mktemp" #:check? #t #:return car)))
         (dynamic-wind
           (const #t)
           (lambda ()

modules/ordo/connection.scm

@@ -16,7 +16,8 @@
             local-connection
             ssh-connection
             call-with-connection
-            run))
+            run)
+  #:re-export (conn:setup conn:teardown))
 
 (define (connection? c)
   (is-a? c <connection>))

modules/ordo/interceptor.scm

@@ -8,13 +8,16 @@
   #:use-module (ordo connection)
   #:export (interceptor
             init-context
+            context-connection
+            set-context-connection!
             context-error
             set-context-error!
             context-suppressed
             terminate-when
             execute
-            bind
+            var-set!
-            unbind))
+            var-ref
+            var-delete!))
 
 (define-record-type <interceptor>
   (make-interceptor name enter leave error)
@@ -39,8 +42,8 @@
   (error context-error set-context-error!)
   (suppressed context-suppressed set-context-suppressed!))
 
-(define* (init-context conn #:key (vars '()))
+(define* (init-context #:key conn (vars '()))
-  "Initialize a context with optional vars."
+  "Initialize a context with optional connection and vars."
   (make-context
    ;; connection
    conn
@@ -119,7 +122,7 @@
             (set-context-suppressed! ctx
                                      (cons (make-interceptor-error (interceptor-name t) #:error e)
                                            (context-suppressed ctx))))
-        (lambda () (handler ctx (context-error ctx)))
+        (lambda () (handler ctx))
         #:unwind? #t))))
 
 (define (execute-leave ctx)
@@ -148,11 +151,10 @@
       (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
+          ;; If an error was caught, abort the enter phase and set up to run the leave phase
           (begin
             (set-context-queue! ctx (context-stack ctx))
-            (set-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)
@@ -166,22 +168,14 @@
   "Execute all the interceptors on the given context."
   (enqueue ctx interceptors)
   (execute-enter ctx)
-  (execute-leave ctx))
+  (execute-leave ctx)
+  (and=> (context-error ctx) raise-exception))
 
-(define-syntax bind
+(define (var-set! ctx name value)
-  (syntax-rules ()
+  (hash-table-set! (context-vars ctx) name value))
-    ((bind ctx name value)
-     (hash-table-set! (context-vars ctx) (quote name) value))))
 
-(define-syntax unbind
+(define* (var-ref ctx name #:optional default)
-  (syntax-rules ()
+  (hash-table-ref/default (context-vars ctx) name default))
-    ((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)
+(define (var-delete! ctx name)
-  (cond
+  (hash-table-delete! (context-vars ctx) name))
-   ((< (length args) 2) #f)
-   ((equal? (first args) kw) (second args))
-   (else (keyword-arg kw (cddr args)))))