From f49be4af29116e02d95f126a1a300320b47f62e0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 22 Jan 2025 22:00:13 +0000 Subject: [PATCH] Bugfixes and interceptor chain example. --- examples/interceptor.scm | 66 ++++++++++++++++++++++++++++++ modules/ordo/action/filesystem.scm | 31 +++++++------- modules/ordo/connection.scm | 3 +- modules/ordo/interceptor.scm | 42 ++++++++----------- 4 files changed, 102 insertions(+), 40 deletions(-) create mode 100644 examples/interceptor.scm diff --git a/examples/interceptor.scm b/examples/interceptor.scm new file mode 100644 index 0000000..ebb8689 --- /dev/null +++ b/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 #: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) diff --git a/modules/ordo/action/filesystem.scm b/modules/ordo/action/filesystem.scm index 5989e65..2a56409 100644 --- a/modules/ordo/action/filesystem.scm +++ b/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 - '("--directory") - (tmpdir (append _ `("--tmpdir" tmpdir))) - (suffix (append _ `("--suffix" suffix))) - (template (append _ `(template)))) - #:check? #t))) - tmp-dir)) + (run conn "mktemp" (chain-when + '("--directory") + (tmpdir (append _ `("--tmpdir" tmpdir))) + (suffix (append _ `("--suffix" suffix))) + (template (append _ `(template)))) + #:check? #t + #: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 - (lambda (output-port) - (let loop ((data (get-bytevector-some input-port))) - (unless (eof-object? data) - (put-bytevector output-port data) - (loop (get-bytevector-some input-port)))) - (close-port output-port))))) + (conn:call-with-output-file conn tmp-file + (lambda (output-port) + (let loop ((data (get-bytevector-some input-port))) + (unless (eof-object? data) + (put-bytevector output-port data) + (loop (get-bytevector-some input-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 () diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm index f5b4c60..d5e3223 100644 --- a/modules/ordo/connection.scm +++ b/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 )) diff --git a/modules/ordo/interceptor.scm b/modules/ordo/interceptor.scm index 772aaf5..2a1eda0 100644 --- a/modules/ordo/interceptor.scm +++ b/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 - unbind)) + var-set! + var-ref + var-delete!)) (define-record-type (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 '())) - "Initialize a context with optional vars." +(define* (init-context #:key conn (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 '()) - (execute-leave ctx)) + (set-context-stack! 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 - (syntax-rules () - ((bind ctx name value) - (hash-table-set! (context-vars ctx) (quote name) value)))) +(define (var-set! ctx name value) + (hash-table-set! (context-vars ctx) 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* (var-ref ctx name #:optional default) + (hash-table-ref/default (context-vars ctx) 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 (var-delete! ctx name) + (hash-table-delete! (context-vars ctx) name))