Add hierarchical custodians for resource management (#36)
ober
2397a98a651cd3f19e3c7ab4f2d50130317e9047
new file mode 100644 --- /dev/null +++ b/lib/std/misc/custodian.sls @@ -0,0 +1,151 @@ +#!chezscheme +;;; (std misc custodian) --- Hierarchical custodians for resource management +;;; +;;; Custodians are hierarchical resource groups that can be shut down atomically. +;;; Every managed resource (ports, custom handles) belongs to a custodian. +;;; Shutting down a parent recursively shuts down all children and their resources. +;;; +;;; Usage: +;;; (with-custodian +;;; (let ([p (custodian-open-input-file "data.txt")]) +;;; (read p))) +;;; ;; port is automatically closed when with-custodian exits + +(library (std misc custodian) + (export make-custodian + current-custodian + custodian? + custodian-shutdown-all + custodian-managed-list + custodian-register! + custodian-open-input-file + custodian-open-output-file + with-custodian) + (import (chezscheme)) + + ;; A custodian holds: + ;; parent - parent custodian or #f for root + ;; children - list of child custodians + ;; resources - list of (resource . shutdown-proc) pairs + ;; alive? - #t until shutdown + (define-record-type cust + (fields + (immutable parent) + (mutable children) + (mutable resources) + (mutable alive?)) + (protocol + (lambda (new) + (lambda (parent) + (new parent '() '() #t))))) + + (define (custodian? x) + (cust? x)) + + ;; Root custodian has no parent + (define root-custodian (make-cust #f)) + + ;; Parameter for the current custodian + (define current-custodian (make-parameter root-custodian)) + + ;; Create a new custodian. If parent is not given, uses current-custodian. + (define make-custodian + (case-lambda + [() + (make-custodian (current-custodian))] + [(parent) + (unless (cust? parent) + (error 'make-custodian "expected a custodian" parent)) + (unless (cust-alive? parent) + (error 'make-custodian "parent custodian is shut down" parent)) + (let ([c (make-cust parent)]) + (cust-children-set! parent + (cons c (cust-children parent))) + c)])) + + ;; Register a resource with a custodian. + ;; shutdown-proc is a thunk called to release the resource. + ;; Returns the resource for convenience. + (define custodian-register! + (case-lambda + [(resource shutdown-proc) + (custodian-register! (current-custodian) resource shutdown-proc)] + [(custodian resource shutdown-proc) + (unless (cust? custodian) + (error 'custodian-register! "expected a custodian" custodian)) + (unless (cust-alive? custodian) + (error 'custodian-register! "custodian is shut down" custodian)) + (unless (procedure? shutdown-proc) + (error 'custodian-register! "expected a procedure for shutdown" shutdown-proc)) + (cust-resources-set! custodian + (cons (cons resource shutdown-proc) (cust-resources custodian))) + resource])) + + ;; Shut down a custodian: close all resources, recursively shut down children, + ;; and remove self from parent's child list. + (define (custodian-shutdown-all c) + (unless (cust? c) + (error 'custodian-shutdown-all "expected a custodian" c)) + (when (cust-alive? c) + ;; First, recursively shut down children (copy the list since shutdown mutates it) + (for-each custodian-shutdown-all (list-copy (cust-children c))) + ;; Then close all resources, catching errors so one bad resource + ;; doesn't prevent others from being cleaned up + (for-each + (lambda (pair) + (guard (e [#t (void)]) ;; swallow errors during shutdown + ((cdr pair)))) + (cust-resources c)) + ;; Mark as dead and clear + (cust-alive?-set! c #f) + (cust-resources-set! c '()) + (cust-children-set! c '()) + ;; Remove self from parent's children list + (let ([parent (cust-parent c)]) + (when parent + (cust-children-set! parent + (remq c (cust-children parent))))))) + + ;; List managed resources (not shutdown procs) for a custodian + (define (custodian-managed-list c) + (unless (cust? c) + (error 'custodian-managed-list "expected a custodian" c)) + (append + (map car (cust-resources c)) + (list-copy (cust-children c)))) + + ;; Open an input file port registered with the current custodian + (define custodian-open-input-file + (case-lambda + [(path) + (custodian-open-input-file path (current-custodian))] + [(path custodian) + (let ([p (open-input-file path)]) + (custodian-register! custodian p (lambda () (close-input-port p))) + p)])) + + ;; Open an output file port registered with the current custodian + (define custodian-open-output-file + (case-lambda + [(path) + (custodian-open-output-file path (current-custodian))] + [(path custodian) + (let ([p (open-output-file path)]) + (custodian-register! custodian p (lambda () (close-output-port p))) + p)])) + + ;; Run body under a fresh custodian; shut it down when body exits + ;; (whether normally, by exception, or by continuation escape). + (define-syntax with-custodian + (syntax-rules () + [(_ body ...) + (let ([c (make-custodian)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (parameterize ([current-custodian c]) + body ...)) + (lambda () + (custodian-shutdown-all c))))])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-custodian.ss @@ -0,0 +1,212 @@ +#!/usr/bin/env scheme-script +#!chezscheme +(import (chezscheme) + (std misc custodian)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(define (assert-true val msg) + (unless val + (error 'assert-true (string-append msg ": expected #t got " (format "~s" val))))) + +;; Test 1: make-custodian and custodian? +(test "make-custodian creates a custodian" + (lambda () + (let ([c (make-custodian)]) + (assert-true (custodian? c) "custodian? should be #t") + (assert-true (not (custodian? 42)) "42 is not a custodian") + (custodian-shutdown-all c)))) + +;; Test 2: custodian-register! and custodian-managed-list +(test "register resources and list them" + (lambda () + (let ([c (make-custodian)] + [closed? #f]) + (parameterize ([current-custodian c]) + (custodian-register! 'my-resource (lambda () (set! closed? #t))) + (let ([managed (custodian-managed-list c)]) + (assert-equal (length managed) 1 "one resource") + (assert-equal (car managed) 'my-resource "resource identity"))) + (custodian-shutdown-all c) + (assert-true closed? "resource was shut down")))) + +;; Test 3: shutdown closes all resources +(test "custodian-shutdown-all closes all resources" + (lambda () + (let ([c (make-custodian)] + [log '()]) + (custodian-register! c 'a (lambda () (set! log (cons 'a log)))) + (custodian-register! c 'b (lambda () (set! log (cons 'b log)))) + (custodian-register! c 'c (lambda () (set! log (cons 'c log)))) + (custodian-shutdown-all c) + (assert-equal (length log) 3 "all three resources shut down") + (assert-equal (custodian-managed-list c) '() "no resources after shutdown")))) + +;; Test 4: hierarchical shutdown +(test "parent shutdown recursively shuts down children" + (lambda () + (let* ([parent (make-custodian)] + [child (parameterize ([current-custodian parent]) (make-custodian))] + [parent-closed? #f] + [child-closed? #f]) + (custodian-register! parent 'p-res (lambda () (set! parent-closed? #t))) + (custodian-register! child 'c-res (lambda () (set! child-closed? #t))) + ;; child should appear in parent's managed list + (let ([managed (custodian-managed-list parent)]) + (assert-true (memq child managed) "child is in parent's managed list")) + ;; shutdown parent + (custodian-shutdown-all parent) + (assert-true parent-closed? "parent resource closed") + (assert-true child-closed? "child resource closed by parent shutdown")))) + +;; Test 5: deep hierarchy +(test "three-level hierarchy shuts down recursively" + (lambda () + (let* ([root (make-custodian)] + [mid (parameterize ([current-custodian root]) (make-custodian))] + [leaf (parameterize ([current-custodian mid]) (make-custodian))] + [leaf-closed? #f]) + (custodian-register! leaf 'deep (lambda () (set! leaf-closed? #t))) + (custodian-shutdown-all root) + (assert-true leaf-closed? "leaf resource closed by root shutdown")))) + +;; Test 6: with-custodian normal exit +(test "with-custodian shuts down on normal exit" + (lambda () + (let ([closed? #f]) + (let ([result + (with-custodian + (custodian-register! 'res (lambda () (set! closed? #t))) + 42)]) + (assert-equal result 42 "body returns value") + (assert-true closed? "resource closed after with-custodian"))))) + +;; Test 7: with-custodian exception exit +(test "with-custodian shuts down on exception" + (lambda () + (let ([closed? #f]) + (guard (e [#t (void)]) + (with-custodian + (custodian-register! 'res (lambda () (set! closed? #t))) + (error 'test "boom"))) + (assert-true closed? "resource closed despite exception")))) + +;; Test 8: custodian-open-input-file +(test "custodian-open-input-file registers and closes port" + (lambda () + (let ([tmp "/tmp/test-custodian-input.txt"]) + ;; Create a temp file with known content + (with-output-to-file tmp (lambda () (display "hello")) 'replace) + (let ([c (make-custodian)]) + (let ([p (parameterize ([current-custodian c]) + (custodian-open-input-file tmp))]) + ;; open-input-file returns a textual port in Chez + (let ([data (get-string-all p)]) + (assert-equal data "hello" "read file contents")) + ;; Port should be in managed list + (assert-equal (length (custodian-managed-list c)) 1 "one managed port") + ;; Shutdown should close the port + (custodian-shutdown-all c) + (assert-true (port-closed? p) "port closed after shutdown"))) + (delete-file tmp)))) + +;; Test 9: custodian-open-output-file +(test "custodian-open-output-file registers and closes port" + (lambda () + (let ([tmp "/tmp/test-custodian-output.txt"]) + (when (file-exists? tmp) (delete-file tmp)) + (let ([c (make-custodian)]) + (let ([p (parameterize ([current-custodian c]) + (custodian-open-output-file tmp))]) + (display "world" p) + (custodian-shutdown-all c) + (assert-true (port-closed? p) "port closed after shutdown"))) + ;; Verify data was written before close + (let ([data (with-input-from-file tmp (lambda () (get-string-all (current-input-port))))]) + (assert-equal data "world" "data written to file")) + (delete-file tmp)))) + +;; Test 10: shutdown is idempotent +(test "double shutdown is safe" + (lambda () + (let ([c (make-custodian)] + [count 0]) + (custodian-register! c 'res (lambda () (set! count (+ count 1)))) + (custodian-shutdown-all c) + (custodian-shutdown-all c) ;; should not error or double-close + (assert-equal count 1 "shutdown proc called only once")))) + +;; Test 11: error in one resource shutdown doesn't prevent others +(test "error in shutdown proc does not prevent other shutdowns" + (lambda () + (let ([c (make-custodian)] + [closed? #f]) + (custodian-register! c 'good (lambda () (set! closed? #t))) + (custodian-register! c 'bad (lambda () (error 'test "shutdown error"))) + (custodian-shutdown-all c) + (assert-true closed? "good resource still shut down")))) + +;; Test 12: child shutdown removes from parent +(test "shutting down child removes it from parent" + (lambda () + (let* ([parent (make-custodian)] + [child (parameterize ([current-custodian parent]) (make-custodian))]) + (assert-true (memq child (custodian-managed-list parent)) + "child in parent before shutdown") + (custodian-shutdown-all child) + (assert-true (not (memq child (custodian-managed-list parent))) + "child removed from parent after shutdown")))) + +;; Test 13: current-custodian parameter +(test "current-custodian parameter works" + (lambda () + (let ([c (make-custodian)]) + (assert-true (not (eq? c (current-custodian))) "not current before parameterize") + (parameterize ([current-custodian c]) + (assert-true (eq? c (current-custodian)) "current inside parameterize")) + (custodian-shutdown-all c)))) + +;; Test 14: register with explicit custodian (3-arg form) +(test "custodian-register! with explicit custodian" + (lambda () + (let ([c (make-custodian)] + [closed? #f]) + (custodian-register! c 'res (lambda () (set! closed? #t))) + (custodian-shutdown-all c) + (assert-true closed? "resource in explicit custodian shut down")))) + +;; Test 15: nested with-custodian +(test "nested with-custodian creates independent scopes" + (lambda () + (let ([outer-closed? #f] + [inner-closed? #f]) + (with-custodian + (custodian-register! 'outer (lambda () (set! outer-closed? #t))) + (with-custodian + (custodian-register! 'inner (lambda () (set! inner-closed? #t)))) + ;; Inner should be closed, outer not yet + (assert-true inner-closed? "inner closed after inner with-custodian") + (assert-true (not outer-closed?) "outer not yet closed")) + (assert-true outer-closed? "outer closed after outer with-custodian")))) + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))