diff --git a/examples/interceptor.scm b/examples/interceptor.scm index ebb8689..cedff3f 100644 --- a/examples/interceptor.scm +++ b/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 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 #: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)))) + (ordo interceptor) + (ordo interceptor tmp-dir) + (ordo interceptor debug) + (ordo action filesystem) + (ordo logger)) (define chain - (list (i:connection (local-connection)) - (i:tmp-dir) - (i:handle-errors) + (list (connection-interceptor (local-connection)) + (tmp-dir-interceptor #:tmp-dir) (interceptor - "hello-world" + "install hello" #: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")))) + (fs:install-file (context-connection ctx) + (file-name-join* (var-ref ctx #:tmp-dir) "hello.txt") + #:content "Hello, world!\n")) + #:register #:hello) (interceptor - "get-file-status" + "stat hello" #:enter (lambda (ctx) - (let ((st (fs:stat (context-connection ctx) (var-ref ctx 'hello)))) - (log-msg 'INFO "stat result: " st)))))) + (fs:stat (context-connection ctx) (var-ref ctx #:hello))) + #: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) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index d5e3223..2e4c9b7 100644 --- a/modules/ordo/connection.scm +++ b/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) - #:re-export (conn:setup conn:teardown)) + run)) (define (connection? c) (is-a? c )) @@ -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 #: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)))) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index 2a1eda0..d899769 100644 --- a/modules/ordo/interceptor.scm +++ b/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 - execute - var-set! + context-vars + set-context-vars! var-ref - var-delete!)) + var-set! + var-delete! + terminate-when + execute)) -(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 (check-var-name name) + (unless (keyword? name) + (raise-exception (make-exception + (make-assertion-failure) + (make-exception-with-message "Variable name should be a keyword") + (make-exception-with-irritants name))))) (define-record-type (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 + (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)) - (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 set up to run the leave phase - (begin - (set-context-queue! ctx (context-stack ctx)) - (set-context-stack! ctx '())) - ;; Otherwise, check for early termination or carry on down the chain - (begin - (check-terminators ctx) - (execute-enter ctx)))))) + (if (null? (context-queue ctx)) + ;; Prepare to leave + (set-context-queue! ctx (context-stack 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 set up to run the leave phase + (begin + (set-context-queue! ctx (context-stack ctx)) + (set-context-stack! 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." @@ -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)) diff --git a/modules/ordo/interceptor/debug.scm b/modules/ordo/interceptor/debug.scm new file mode 100644 index 0000000..ca4707a --- /dev/null +++ b/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)))))) diff --git a/modules/ordo/interceptor/errors.scm b/modules/ordo/interceptor/errors.scm new file mode 100644 index 0000000..7dbf012 --- /dev/null +++ b/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)))) diff --git a/modules/ordo/interceptor/tmp-dir.scm b/modules/ordo/interceptor/tmp-dir.scm new file mode 100644 index 0000000..f1d0acd --- /dev/null +++ b/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))