ray/ordo
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Bugfixes and interceptor chain example.

Browse source
This commit is contained in:
Ray Miller 2025-01-22 22:00:13 +00:00
parent de18c1d771
commit f49be4af29
Signed by: ray
GPG key ID: 043F786C4CD681B8
4 changed files with 102 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

66
examples/interceptor.scm Normal file
View file

@ -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)

31
modules/ordo/action/filesystem.scm
View file

@ -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 ()

3
modules/ordo/connection.scm
View file

@ -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>))

42
modules/ordo/interceptor.scm
View file

@ -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 <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 '()))
"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))