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

Remove interceptors from the main branch

Browse source
This commit is contained in:
Ray Miller 2025-01-23 17:12:56 +00:00
parent f49be4af29
commit e22e618142
Signed by: ray
GPG key ID: 043F786C4CD681B8
2 changed files with 0 additions and 247 deletions
Download patch file Download diff file Expand all files Collapse all files

181
modules/ordo/interceptor.scm
View file

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