diff --git a/src/debug.rkt b/src/debug.rkt new file mode 100644 index 0000000..dbc29c0 --- /dev/null +++ b/src/debug.rkt @@ -0,0 +1,36 @@ +#lang racket/base +;; Code for debugging a live server. + +(provide debug-information-dump!) + +(require "main.rkt") +(require racket/exn) +(require racket/tcp) +(require (only-in racket/string string-join)) + +(define (format-path path) + (string-join (map number->string (reverse path)) ".")) + +(define (enumerate-custodian-managed-items cust super path) + (for [(index (in-naturals)) + (item (custodian-managed-list cust super))] + (eprintf "\nItem ~a.\n~v\n" (format-path (cons index path)) item) + (cond + [(thread? item) + (eprintf "~a" (exn->string (exn "Stack snapshot:" (continuation-marks item))))] + [(tcp-port? item) + (eprintf "TCP port: (addresses ~v)\n" + (call-with-values (lambda () (tcp-addresses item #t)) list))] + [(custodian? item) + (enumerate-custodian-managed-items item cust (cons index path))] + [else (void)]))) + +(define (debug-information-dump!) + (eprintf "===========================================================================\n") + (eprintf "======================================================================\n") + (eprintf "=================================================================") + (collect-garbage) + (enumerate-custodian-managed-items (current-custodian) (outermost-custodian) '()) + (eprintf "=================================================================\n") + (eprintf "======================================================================\n") + (eprintf "===========================================================================\n")) diff --git a/src/main-inner.rkt b/src/main-inner.rkt new file mode 100644 index 0000000..2b4a769 --- /dev/null +++ b/src/main-inner.rkt @@ -0,0 +1,21 @@ +#lang racket/base +;; Inner startup module - required after establishment of server-wide custodian. + +(provide main) + +(require reloadable) +(require "entrypoint.rkt") + +(define (main [config (hash)]) + (make-persistent-state '*config* (lambda () config)) + (void (make-reloadable-entry-point 'refresh-packages! "packages.rkt")) + (void (make-reloadable-entry-point 'rerender! "site.rkt")) + (void (make-reloadable-entry-point 'debug-information-dump! "debug.rkt")) + (start-service #:port (hash-ref config 'port (lambda () + (let ((port-str (getenv "SITE_PORT"))) + (if port-str (string->number port-str) 7443)))) + #:ssl? (hash-ref config 'ssl? (lambda () #t)) + #:reloadable? (hash-ref config 'reloadable? (lambda () (getenv "SITE_RELOADABLE"))) + (make-reloadable-entry-point 'request-handler "site.rkt") + (make-reloadable-entry-point 'on-continuation-expiry "site.rkt") + (make-reloadable-entry-point 'extra-files-paths "static.rkt"))) diff --git a/src/main.rkt b/src/main.rkt index 32d2dc5..d023009 100644 --- a/src/main.rkt +++ b/src/main.rkt @@ -1,19 +1,12 @@ #lang racket/base +;; Outer startup module - delegates to main-inner.rkt after installing a custodian -(provide main) +(provide main + outermost-custodian) -(require reloadable) -(require "entrypoint.rkt") +(define *outermost-custodian* (current-custodian)) +(define (outermost-custodian) *outermost-custodian*) (define (main [config (hash)]) - (make-persistent-state '*config* (lambda () config)) - (void (make-reloadable-entry-point 'refresh-packages! "packages.rkt")) - (void (make-reloadable-entry-point 'rerender! "site.rkt")) - (start-service #:port (hash-ref config 'port (lambda () - (let ((port-str (getenv "SITE_PORT"))) - (if port-str (string->number port-str) 7443)))) - #:ssl? (hash-ref config 'ssl? (lambda () #t)) - #:reloadable? (hash-ref config 'reloadable? (lambda () (getenv "SITE_RELOADABLE"))) - (make-reloadable-entry-point 'request-handler "site.rkt") - (make-reloadable-entry-point 'on-continuation-expiry "site.rkt") - (make-reloadable-entry-point 'extra-files-paths "static.rkt"))) + (parameterize ((current-custodian (make-custodian (outermost-custodian)))) + ((dynamic-require "main-inner.rkt" 'main) config))) diff --git a/src/signals.rkt b/src/signals.rkt index a629853..7d5cc14 100644 --- a/src/signals.rkt +++ b/src/signals.rkt @@ -51,5 +51,10 @@ (if (eof-object? items-to-rerender) #f items-to-rerender)))) + (poll-signal "../signals/.dumpinfo" + "Debug information dump request received" + (lambda () + ((reloadable-entry-point->procedure + (lookup-reloadable-entry-point 'debug-information-dump! "debug.rkt"))))) (sleep 0.5) (loop)))))