From e22e6181427f52936752fd2f73ab2fdfe6554084 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Thu, 23 Jan 2025 17:12:56 +0000 Subject: [PATCH] Remove interceptors from the main branch --- examples/interceptor.scm | 66 ------------- modules/ordo/interceptor.scm | 181 ----------------------------------- 2 files changed, 247 deletions(-) delete mode 100644 examples/interceptor.scm delete mode 100644 modules/ordo/interceptor.scm diff --git a/examples/interceptor.scm b/examples/interceptor.scm deleted file mode 100644 index ebb8689..0000000 --- a/examples/interceptor.scm +++ /dev/null @@ -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 #: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/interceptor.scm b/modules/ordo/interceptor.scm deleted file mode 100644 index 2a1eda0..0000000 --- a/modules/ordo/interceptor.scm +++ /dev/null @@ -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 - (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 - (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))