Remove interceptors from the main branch
This commit is contained in:
parent
f49be4af29
commit
e22e618142
GPG key ID:
043F786C4CD681B8
2 changed files with 0 additions and 247 deletions
|
|
@ -1,66 +0,0 @@
|
||||||
(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)
|
|
||||||
|
|
@ -1,181 +0,0 @@
|
||||||
(define-module (ordo interceptor)
|
|
||||||
#:use-module (ice-9 exceptions)
|
|
||||||
#:use-module (logging logger)
|
|
||||||
#:use-module (srfi srfi-1) ; list utils
|
|
||||||
#:use-module (srfi srfi-9) ; records
|
|
||||||
#:use-module (srfi srfi-69) ; hash tables
|
|
||||||
#:use-module (srfi srfi-71) ; extended let
|
|
||||||
#:use-module (ordo connection)
|
|
||||||
#:export (interceptor
|
|
||||||
init-context
|
|
||||||
context-connection
|
|
||||||
set-context-connection!
|
|
||||||
context-error
|
|
||||||
set-context-error!
|
|
||||||
context-suppressed
|
|
||||||
terminate-when
|
|
||||||
execute
|
|
||||||
var-set!
|
|
||||||
var-ref
|
|
||||||
var-delete!))
|
|
||||||
|
|
||||||
(define-record-type <interceptor>
|
|
||||||
(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-record-type <context>
|
|
||||||
(make-context connection vars stack queue terminators error suppressed)
|
|
||||||
context?
|
|
||||||
(connection context-connection set-context-connection!)
|
|
||||||
(vars context-vars set-context-vars!)
|
|
||||||
(stack context-stack set-context-stack!)
|
|
||||||
(queue context-queue set-context-queue!)
|
|
||||||
(terminators context-terminators set-context-terminators!)
|
|
||||||
(error context-error set-context-error!)
|
|
||||||
(suppressed context-suppressed set-context-suppressed!))
|
|
||||||
|
|
||||||
(define* (init-context #:key conn (vars '()))
|
|
||||||
"Initialize a context with optional connection and vars."
|
|
||||||
(make-context
|
|
||||||
;; connection
|
|
||||||
conn
|
|
||||||
;; vars
|
|
||||||
(alist->hash-table vars equal?)
|
|
||||||
;; stack
|
|
||||||
'()
|
|
||||||
;; queue
|
|
||||||
'()
|
|
||||||
;; terminators
|
|
||||||
'()
|
|
||||||
;; error
|
|
||||||
#f
|
|
||||||
;; suppressed errors
|
|
||||||
'()))
|
|
||||||
|
|
||||||
(define-exception-type &interceptor-error &error
|
|
||||||
make-interceptor-error
|
|
||||||
interceptor-error?
|
|
||||||
(interceptor-name interceptor-error-interceptor-name)
|
|
||||||
(stage interceptor-error-stage)
|
|
||||||
(cause interceptor-error-cause))
|
|
||||||
|
|
||||||
(define (enqueue ctx interceptors)
|
|
||||||
"Add interceptors to the context."
|
|
||||||
(unless (every interceptor? interceptors)
|
|
||||||
(error "invalid interceptors"))
|
|
||||||
(set-context-queue! ctx interceptors))
|
|
||||||
|
|
||||||
(define (terminate ctx)
|
|
||||||
"Remove all remaining interceptors from the queue, short-circuiting the
|
|
||||||
enter stage and running the leave stage."
|
|
||||||
(set-context-queue! ctx '()))
|
|
||||||
|
|
||||||
(define (check-terminators ctx)
|
|
||||||
"Check the context terminators and possibly trigger early termination."
|
|
||||||
(let loop ((terminators (context-terminators ctx)))
|
|
||||||
(unless (null? terminators)
|
|
||||||
(let ((t (car terminators)))
|
|
||||||
(if (t ctx)
|
|
||||||
(terminate ctx)
|
|
||||||
(loop (cdr terminators)))))))
|
|
||||||
|
|
||||||
(define (try-enter ctx t)
|
|
||||||
"Run the interceptor's #:enter function."
|
|
||||||
(let ((handler (interceptor-enter t)))
|
|
||||||
(when handler
|
|
||||||
(log-msg 'INFO "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))
|
|
||||||
#: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))
|
|
||||||
(with-exception-handler
|
|
||||||
(lambda (e)
|
|
||||||
(set-context-error! ctx
|
|
||||||
(make-interceptor-error (interceptor-name t) #:leave e)))
|
|
||||||
(lambda () (handler ctx))
|
|
||||||
#:unwind? #t))))
|
|
||||||
|
|
||||||
(define (try-error ctx t err)
|
|
||||||
"Run the interceptor's #:error function."
|
|
||||||
(let ((handler (interceptor-error t)))
|
|
||||||
(when handler
|
|
||||||
(log-msg 'INFO "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)
|
|
||||||
(set-context-suppressed! ctx
|
|
||||||
(cons (make-interceptor-error (interceptor-name t) #:error e)
|
|
||||||
(context-suppressed ctx))))
|
|
||||||
(lambda () (handler ctx))
|
|
||||||
#:unwind? #t))))
|
|
||||||
|
|
||||||
(define (execute-leave ctx)
|
|
||||||
"Run all the #:leave functions in the queue."
|
|
||||||
(unless (null? (context-queue ctx))
|
|
||||||
(let ((t (car (context-queue ctx)))
|
|
||||||
(err (context-error ctx)))
|
|
||||||
;; Run the error or leave handler, according to whether or not we are
|
|
||||||
;; handling an error
|
|
||||||
(if err
|
|
||||||
(try-error ctx t err)
|
|
||||||
(try-leave 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)))
|
|
||||||
;; Carry on down the chain
|
|
||||||
(execute-leave ctx))))
|
|
||||||
|
|
||||||
(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))))))
|
|
||||||
|
|
||||||
(define (terminate-when ctx pred)
|
|
||||||
"Add a predicate for a termination condition to exit the #:enter chain early."
|
|
||||||
(set-context-terminators! ctx (cons pred (context-terminators ctx))))
|
|
||||||
|
|
||||||
(define (execute ctx interceptors)
|
|
||||||
"Execute all the interceptors on the given context."
|
|
||||||
(enqueue ctx interceptors)
|
|
||||||
(execute-enter 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))
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue