632 lines
22 KiB
Scheme
632 lines
22 KiB
Scheme
;; the surflet handler
|
|
;; Copyright Andreas Bernauer, 2002
|
|
|
|
|
|
(define *debug* #t)
|
|
|
|
;;; session-table: entry for every new request on a surflet page
|
|
(define-record-type session :session
|
|
(make-session surflet-name memo
|
|
continuation-table continuation-table-lock
|
|
continuation-counter
|
|
surflet-data)
|
|
session?
|
|
(surflet-name session-surflet-name)
|
|
(memo session-memo set-session-memo!)
|
|
(continuation-table session-continuation-table)
|
|
(continuation-table-lock session-continuation-table-lock)
|
|
(continuation-counter session-continuation-counter)
|
|
(surflet-data session-surflet-data set-session-surflet-data!))
|
|
|
|
(define-record-type memo :memo
|
|
(make-memo message value new-memo)
|
|
memo?
|
|
(message memo:message set-memo:message) ;kill, killed, adjust-timeout
|
|
(value memo:value set-memo:value)
|
|
(new-memo memo:new-memo set-memo:new-memo))
|
|
|
|
(define (make-default-memo)
|
|
(make-memo 'kill #f #f))
|
|
|
|
;; caller must do locking stuff
|
|
(define (memo-killed! memo)
|
|
(set-memo:message memo 'killed))
|
|
|
|
(define-record-type instance :instance
|
|
(make-instance session-id return-continuation)
|
|
instance?
|
|
(session-id really-instance-session-id
|
|
set-instance-session-id!)
|
|
(return-continuation really-instance-return-continuation
|
|
set-instance-return-continuation!))
|
|
|
|
(define-record-type options :options
|
|
(make-options surflet-path surflet-prefix cache-surflets? session-lifetime)
|
|
options?
|
|
(surflet-path options:surflet-path set-options:surflet-path)
|
|
(surflet-prefix options:surflet-prefix set-options:surflet-prefix)
|
|
(cache-surflets? options:cache-surflets? set-options:cache-surflets?)
|
|
;; session lifetime is in seconds
|
|
(session-lifetime options:session-lifetime set-options:session-lifetime))
|
|
|
|
;;; STATUS is the status code, an exact integer. See httpd/response.scm
|
|
;;; e.g. (status-code ok)
|
|
;;; CONTENT-TYPE is a string, most probably "text/html".
|
|
;;; HEADERS is a (maybe empty) list of pairs of (string or symbol);
|
|
;;; Additional headers to send, e.g. '(("Cache-Control" . "no-cache")) or
|
|
;;; '((Cache-Control . "no-cache")) etc.
|
|
;;; DATA is either
|
|
;;; * a string
|
|
;;; * a list of strings
|
|
;;; This list maybe extended to vectors later.
|
|
(define-record-type surflet-response :surflet-response
|
|
(make-surflet-response status content-type headers data)
|
|
surflet-response?
|
|
(status surflet-response-status)
|
|
(content-type surflet-response-content-type)
|
|
(headers surflet-response-headers)
|
|
(data surflet-response-data))
|
|
|
|
(define (valid-surflet-response-data? data)
|
|
(or (string? data) (list? data)))
|
|
|
|
|
|
;; Surflet-prefix is unused now. Formerly, it contained the virtual
|
|
;; path prefix for the handler.
|
|
(define (make-default-options surflet-path surflet-prefix)
|
|
(make-options surflet-path surflet-prefix #t 600))
|
|
|
|
(define *options* (make-preserved-thread-fluid #f))
|
|
;; preserved thread fluid because between different calls to
|
|
;; surflet-handler the options shall remain the same.
|
|
|
|
(define (make-fluid-selector selector)
|
|
(lambda () (selector (thread-fluid *options*))))
|
|
(define (make-fluid-setter setter)
|
|
(lambda (value)
|
|
(setter (thread-fluid *options*) value)))
|
|
(define options-surflet-path (make-fluid-selector options:surflet-path))
|
|
(define options-surflet-prefix (make-fluid-selector options:surflet-prefix))
|
|
(define options-cache-surflets? (make-fluid-selector options:cache-surflets?))
|
|
(define options-session-lifetime (make-fluid-selector options:session-lifetime))
|
|
(define set-options-cache-surflets? (make-fluid-setter set-options:cache-surflets?))
|
|
(define set-options-session-lifetime (make-fluid-setter set-options:session-lifetime))
|
|
|
|
(define *session-table* (make-integer-table)) ; session-id is index
|
|
(define *session-table-lock* (make-lock))
|
|
|
|
(define random
|
|
(let* ((source (make-random-source))
|
|
(random-integer (begin
|
|
(random-source-randomize! source)
|
|
(random-source-make-integers source))))
|
|
(lambda ()
|
|
(random-integer 1073741824)))) ; I hope, 1+ billion is enough....
|
|
|
|
(define (surflet-handler surflet-path)
|
|
(set-thread-fluid! *options* (make-default-options surflet-path #f))
|
|
(lambda (path req)
|
|
(if (pair? path) ; need at least one element
|
|
(let ((request-method (request-method req))
|
|
(path-string (uri-path->uri path)))
|
|
(if (or (string=? request-method "GET")
|
|
(string=? request-method "POST"))
|
|
(if (resume-url? path-string)
|
|
(resume-url path-string surflet-path req)
|
|
(launch-new-session path-string surflet-path req))
|
|
(make-error-response (status-code method-not-allowed) req
|
|
request-method)))
|
|
(make-error-response (status-code bad-request) req
|
|
(format #f "Bad path: ~s" path)))))
|
|
|
|
(define (launch-new-session path-string surflet-path req)
|
|
(cond
|
|
((file-not-exists? (absolute-file-name path-string surflet-path))
|
|
(make-error-response (status-code not-found) req path-string))
|
|
((string=? (file-name-extension path-string) ".scm")
|
|
(obtain-lock *session-table-lock*)
|
|
;; no access to session table until new session-id is saved
|
|
(let ((session-id (generate-new-table-id *session-table*))
|
|
(memo (make-default-memo)))
|
|
(table-set! *session-table* session-id
|
|
(make-session path-string ; used to make
|
|
; redirections to origin
|
|
memo
|
|
(make-integer-table) ; continuation table
|
|
(make-lock) ; continuation table lock
|
|
(make-thread-safe-counter) ; continuation counter
|
|
#f)) ; surflet-data
|
|
(release-lock *session-table-lock*)
|
|
(register-instance! session-id 'no-return)
|
|
|
|
(with-fatal-handler
|
|
;; Catch conditions from get-surflet-rt-structure.
|
|
(lambda (condition decline)
|
|
(delete-session! session-id)
|
|
(bad-gateway-error-response req path-string condition))
|
|
(let ((surflet (get-surflet-rt-structure path-string surflet-path)))
|
|
(fork-thread
|
|
(session-surveillance session-id
|
|
(+ (time) (options-session-lifetime))
|
|
memo))
|
|
(reset
|
|
(with-fatal-handler
|
|
;; Catch conditions that occur while running the surflet.
|
|
(lambda (condition decline)
|
|
(delete-session! session-id)
|
|
;; Restore correct continuation with shift.
|
|
(shift unused
|
|
(bad-gateway-error-response req path-string condition)))
|
|
(with-cwd surflet-path
|
|
(with-names-from-rt-structure
|
|
surflet surflet-interface
|
|
(main req))))))))) ; Launch serlvet's main procedure.
|
|
(else ; We'll serve every non-scm file.
|
|
;; We need access to SEND-FILE-RESPONSE of
|
|
;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we
|
|
;; don't have it, so we disable this feature here.
|
|
; (let ((full-file-name (absolute-file-name path-string surflet-path)))
|
|
; (send-file-response full-file-name
|
|
; (file-info full-file-name)
|
|
; req))
|
|
(make-error-response (status-code forbidden) req
|
|
"Can't serve other than Scheme files."
|
|
path-string))
|
|
))
|
|
|
|
(define (session-surveillance session-id time-to-die memo)
|
|
(lambda ()
|
|
(let loop ((time-to-die time-to-die)
|
|
(memo memo))
|
|
(debug "session-surveillance[~s]: going to sleep until ~a"
|
|
session-id (format-date "~c" (date time-to-die)))
|
|
(let ((seconds-to-sleep (- time-to-die (time))))
|
|
(if (positive? seconds-to-sleep)
|
|
(sleep (* 1000 seconds-to-sleep))))
|
|
;; check state of the world
|
|
(case (memo:message memo)
|
|
((killed) ; too late
|
|
(debug "session-surveillance[~s]: session already killed, dieing"
|
|
session-id)
|
|
)
|
|
((adjust-timeout) ; new timeout
|
|
(debug "session-surveillance[~s]: adjusting timeout" session-id)
|
|
(loop (memo:value memo)
|
|
(memo:new-memo memo)))
|
|
((kill) ; kill session
|
|
(debug "session-surveillance[~s]: killing"
|
|
session-id)
|
|
(obtain-lock *session-table-lock*)
|
|
(table-set! *session-table* session-id #f)
|
|
(release-lock *session-table-lock*))
|
|
(else
|
|
(format (current-error-port)
|
|
"session-surveillance[~s]: unknown message ~s; dieing"
|
|
session-id (memo:message memo)))))))
|
|
|
|
|
|
;; try to get continuation-table and then the continuation
|
|
(define resume-url
|
|
(let ((bad-request
|
|
(lambda (path-string req)
|
|
(make-error-response
|
|
(status-code bad-request) req
|
|
(format #f
|
|
"<br>
|
|
<p>There may be several reasons, why your request for a surflet was denied:
|
|
<ul>
|
|
<li>The surflet does not accept any requests any more.</li>
|
|
<li>The surflet URL has timed out.</li>
|
|
<li>You URL is illformed.</li>
|
|
</ul>
|
|
</p>
|
|
<p>In any case, you may try to restart the surflet from the <a href=\"~a\">beginning</a>. Your browser may also have cached an old session of this surflet. In this case, try to reload the page.</p>"
|
|
(resume-url-surflet-name path-string)))))
|
|
(lookup-continuation-table
|
|
(lambda (session continuation-table continuation-id)
|
|
(let ((continuation-table-lock (session-continuation-table-lock session)))
|
|
(obtain-lock continuation-table-lock)
|
|
(let ((result (table-ref continuation-table continuation-id)))
|
|
(release-lock continuation-table-lock)
|
|
result)))))
|
|
|
|
(lambda (path-string surflet-path req)
|
|
(receive (session-id continuation-id)
|
|
(resume-url-ids path-string)
|
|
(let ((session (session-lookup session-id)))
|
|
(if session
|
|
(let* ((continuation-table (session-continuation-table session))
|
|
(resume (lookup-continuation-table session continuation-table
|
|
continuation-id)))
|
|
(if resume
|
|
(with-cwd surflet-path
|
|
(reset
|
|
(begin
|
|
(register-instance! session-id 'no-return)
|
|
(resume req))))
|
|
(bad-request path-string req)))
|
|
(bad-request path-string req)))
|
|
))))
|
|
|
|
|
|
;; RESPONSE-MAKER is a procedure returnig a SURFLET-RESPONSE.
|
|
(define (send/suspend response-maker)
|
|
(shift return
|
|
(let* ((session-id (instance-session-id))
|
|
(session (session-lookup session-id)))
|
|
;; the instance might be deleted in the meanwhile
|
|
(if session
|
|
(begin
|
|
(session-adjust-timeout! session-id)
|
|
(let ((continuations-table (session-continuation-table session))
|
|
(continuation-table-lock (session-continuation-table-lock session))
|
|
(continuation-counter (session-next-continuation-counter session)))
|
|
(obtain-lock continuation-table-lock)
|
|
(let ((continuation-id (generate-new-table-id continuations-table)))
|
|
(table-set! continuations-table continuation-id return)
|
|
(release-lock continuation-table-lock)
|
|
(let ((new-url (make-resume-url (session-surflet-name session)
|
|
session-id
|
|
continuation-counter
|
|
continuation-id)))
|
|
(make-http-response (response-maker new-url))))))
|
|
(make-error-response (status-code not-found) #f
|
|
"The URL refers to a SUrflet, whose session is no longer alive.")))))
|
|
|
|
(define (send/finish response)
|
|
(delete-session! (instance-session-id))
|
|
(shift unused (make-http-response response)))
|
|
|
|
(define (send response)
|
|
(shift unused (make-http-response response)))
|
|
|
|
;; REQ may be #f in some (most) cases.
|
|
(define (send-error status-code req . messages)
|
|
(shift unused (apply make-error-response
|
|
(cons status-code
|
|
(cons #f messages)))))
|
|
|
|
(define (make-http-response response)
|
|
(cond
|
|
((surflet-response? response)
|
|
(let ((data (surflet-response-data response)))
|
|
(if (valid-surflet-response-data? data)
|
|
(make-response
|
|
(surflet-response-status response)
|
|
#f
|
|
(time)
|
|
(surflet-response-content-type response)
|
|
(surflet-response-headers response)
|
|
(make-writer-body
|
|
(lambda (out options)
|
|
(cond
|
|
((string? data) (display data out))
|
|
((list? data) (for-each (lambda (data) (display data out)) data))
|
|
(else ;; We lose.
|
|
(display "Error in SUrflet output.\n" out))
|
|
))))
|
|
(make-error-response (status-code bad-gateway) #f
|
|
"The SUrflet returned an invalid response object (no surflet-response)."))))
|
|
((and (response? response) ;; RESPONSE? refers to a HTTP-RESPONSE.
|
|
(redirect-body? (response-body response)))
|
|
response)
|
|
(else
|
|
(make-error-response (status-code bad-gateway) #f
|
|
"The SUrflet returned an invalid response object (no surflet-response)."))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; access to session-table
|
|
(define (session-lookup session-id)
|
|
(obtain-lock *session-table-lock*)
|
|
(let ((result (table-ref *session-table* session-id)))
|
|
(release-lock *session-table-lock*)
|
|
result))
|
|
|
|
(define (session-next-continuation-counter session)
|
|
(thread-safe-counter-next!
|
|
(session-continuation-counter session)))
|
|
|
|
(define (delete-session! session-id)
|
|
(obtain-lock *session-table-lock*)
|
|
;; notify surveillance of session being alread killed (prevents
|
|
;; surveillance of killing new session that has the same number by
|
|
;; accident)
|
|
(let ((session (table-ref *session-table* session-id)))
|
|
(memo-killed! (session-memo session)))
|
|
;; why can't table entries be deleted correctly?
|
|
(table-set! *session-table* session-id #f)
|
|
(release-lock *session-table-lock*))
|
|
|
|
(define (session-adjust-timeout! session-id)
|
|
(obtain-lock *session-table-lock*)
|
|
(let* ((session (table-ref *session-table* session-id))
|
|
(memo (session-memo session))
|
|
(new-memo (make-default-memo)))
|
|
;; Do it this way: new values and then new message
|
|
(set-memo:value memo
|
|
(+ (time)
|
|
(options-session-lifetime)))
|
|
(set-memo:new-memo memo new-memo)
|
|
;; I don't think we need locking here. Do you agree?
|
|
(set-session-memo! session new-memo)
|
|
(set-memo:message memo 'adjust-timeout))
|
|
(release-lock *session-table-lock*))
|
|
|
|
;; adjusts the timeout of the current session
|
|
(define (adjust-timeout)
|
|
(session-adjust-timeout! (instance-session-id)))
|
|
|
|
(define (reset-session-table!)
|
|
(with-fatal-error-handler
|
|
(lambda (condtion decline)
|
|
(release-lock *session-table-lock*)
|
|
(decline))
|
|
(lambda ()
|
|
(obtain-lock *session-table-lock*)
|
|
;; notify session killing
|
|
(table-walk
|
|
(lambda (session-id session)
|
|
(memo-killed! (session-memo session)))
|
|
*session-table*)
|
|
(set! *session-table* (make-integer-table))
|
|
(release-lock *session-table*))))
|
|
|
|
(define (get-sessions)
|
|
(obtain-lock *session-table-lock*)
|
|
(let ((sessions '()))
|
|
(table-walk
|
|
(lambda (session-id session-entry)
|
|
(set! sessions (cons (cons session-id session-entry) sessions)))
|
|
*session-table*)
|
|
(release-lock *session-table-lock*)
|
|
sessions))
|
|
|
|
(define (get-continuations session-id)
|
|
(let ((session (session-lookup session-id)))
|
|
(if session
|
|
(let ((continuation-table-lock (session-continuation-table-lock session))
|
|
(continuation-table (session-continuation-table session))
|
|
(continuations '()))
|
|
(obtain-lock continuation-table-lock)
|
|
(table-walk
|
|
(lambda (continuation-id continuation-entry)
|
|
(set! continuations (cons (cons continuation-id continuation-entry)
|
|
continuations)))
|
|
continuation-table)
|
|
(release-lock continuation-table-lock)
|
|
continuations)
|
|
'())))
|
|
|
|
(define (delete-continuation! session-id continuation-id)
|
|
(let ((session (session-lookup session-id)))
|
|
(if session
|
|
(let ((continuation-table-lock (session-continuation-table-lock session))
|
|
(continuation-table (session-continuation-table session))
|
|
(continuations '()))
|
|
(obtain-lock continuation-table-lock)
|
|
(if (table-ref continuation-table continuation-id)
|
|
(table-set! continuation-table continuation-id #f))
|
|
(release-lock continuation-table-lock)))))
|
|
|
|
(define (set-surflet-data! new-data)
|
|
(let ((session (session-lookup (instance-session-id))))
|
|
(if session
|
|
(begin
|
|
(set-session-surflet-data! session new-data)
|
|
#t)
|
|
#f)))
|
|
|
|
(define (get-surflet-data)
|
|
(let ((session (session-lookup (instance-session-id))))
|
|
(if session
|
|
(session-surflet-data session)
|
|
(error "Instance no longer alive."))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; ID generation
|
|
;; locking must be done by caller
|
|
;; FIXME?: this may loop forever, if the table is full (can this happen?)
|
|
(define (generate-new-table-id table)
|
|
(let loop ((id (random)))
|
|
(if (table-ref table id)
|
|
(loop (random))
|
|
id)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; SURFLETs CACHE
|
|
(define *surflet-table* (make-string-table)) ; path-string is index
|
|
(define *surflet-table-lock* (make-lock))
|
|
|
|
;; SURFLET-NAME is like "news-dir/latest-news.scm"
|
|
(define (get-surflet-rt-structure surflet-name directory)
|
|
(let* ((full-surflet-name (absolute-file-name surflet-name directory))
|
|
(load-surflet
|
|
(lambda (cached?)
|
|
(with-fatal-handler*
|
|
(lambda (condition decline)
|
|
(if cached? (release-lock *surflet-table-lock*))
|
|
(decline))
|
|
(lambda ()
|
|
;; load-config-file does not care about cwd(?)
|
|
;; --> absolute file name needed
|
|
(load-config-file full-surflet-name)
|
|
;; surflet-structure to load must be named "surflet"
|
|
(let ((surflet-structure (reify-structure 'surflet)))
|
|
(load-structure surflet-structure)
|
|
(if cached?
|
|
(begin
|
|
(table-set! *surflet-table* full-surflet-name
|
|
(cons surflet-structure
|
|
(file-last-mod full-surflet-name)))
|
|
;; only now the lock may be released
|
|
(release-lock *surflet-table-lock*)))
|
|
surflet-structure))))))
|
|
(if (options-cache-surflets?)
|
|
(begin
|
|
;; The lock is only obtained and released, if surflets are
|
|
;; cached. LOAD-SURFLET gets the CACHED? parameter, so
|
|
;; nothing may happen, if in the meanwhile caching is turned
|
|
;; off.
|
|
(obtain-lock *surflet-table-lock*)
|
|
(let ((surflet (table-ref *surflet-table* full-surflet-name)))
|
|
(if surflet
|
|
(if (equal? (file-last-mod full-surflet-name)
|
|
(cdr surflet))
|
|
(begin
|
|
(release-lock *surflet-table-lock*)
|
|
(car surflet))
|
|
(load-surflet #t))
|
|
(load-surflet #t))))
|
|
(load-surflet #f))))
|
|
|
|
(define (get-loaded-surflets)
|
|
(obtain-lock *surflet-table-lock*)
|
|
(let ((loaded-surflets '()))
|
|
(table-walk
|
|
(lambda (surflet-path rt-structure)
|
|
(set! loaded-surflets (cons surflet-path loaded-surflets)))
|
|
*surflet-table*)
|
|
(release-lock *surflet-table-lock*)
|
|
loaded-surflets))
|
|
|
|
(define (unload-surflet surflet-name)
|
|
(obtain-lock *surflet-table-lock*)
|
|
(if (table-ref *surflet-table* surflet-name)
|
|
(table-set! *surflet-table* surflet-name #f))
|
|
(release-lock *surflet-table-lock*))
|
|
|
|
(define (reset-surflet-cache!)
|
|
(with-fatal-error-handler*
|
|
(lambda (condition decline)
|
|
(release-lock *surflet-table-lock*)
|
|
(decline))
|
|
(lambda ()
|
|
(obtain-lock *surflet-table-lock*)
|
|
(set! *surflet-table* (make-string-table))
|
|
(release-lock *surflet-table-lock*))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; INSTANCE
|
|
(define *instance* (make-thread-cell #f))
|
|
|
|
(define (register-instance! session-id return-continuation)
|
|
(thread-cell-set! *instance*
|
|
(make-instance session-id return-continuation)))
|
|
|
|
|
|
;(define (save-instance-return-continuation! return-continuation)
|
|
; (set-instance-session-id! (thread-cell-ref *instance*)
|
|
; return-continuation))
|
|
|
|
(define (instance-session-id)
|
|
(really-instance-session-id (thread-cell-ref *instance*)))
|
|
|
|
;; unused
|
|
(define (instance-return-continuation)
|
|
(really-instance-return-continuation (thread-cell-ref *instance*)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; RESUME-URL
|
|
(define *resume-url-regexp* (rx (submatch (* (- printing ";")))
|
|
";k" (submatch (* digit)) ; Instance-ID
|
|
";c" (+ digit) "-" (submatch (* digit)))) ; Continuation-ID
|
|
|
|
(define (make-resume-url path-string session-id continuation-counter continuation-id)
|
|
(string-append path-string
|
|
";k" (number->string (instance-session-id))
|
|
";c" (number->string continuation-counter)
|
|
"-" (number->string continuation-id)))
|
|
|
|
(define (resume-url-session-id id-url)
|
|
(receive (session-id continuation-id)
|
|
(resume-url-ids id-url)
|
|
session-id))
|
|
|
|
(define (resume-url-continuation-id id-url)
|
|
(receive (session-id continuation-id)
|
|
(resume-url-ids id-url)
|
|
continuation-id))
|
|
|
|
(define (resume-url-ids id-url)
|
|
(let ((match (regexp-search *resume-url-regexp* id-url)))
|
|
(if match
|
|
(values (string->number (match:substring match 2))
|
|
(string->number (match:substring match 3)))
|
|
(values #f #f))))
|
|
|
|
(define (resume-url-surflet-name id-url)
|
|
(let ((match (regexp-search *resume-url-regexp* id-url)))
|
|
(if match
|
|
(match:substring match 1)
|
|
(values #f #f))))
|
|
|
|
(define (resume-url? id-url)
|
|
(regexp-search? *resume-url-regexp* id-url))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; thread-safe counter
|
|
|
|
(define-record-type counter :counter
|
|
(really-make-counter counter lock)
|
|
(counter counter-counter set-counter-counter!)
|
|
(lock counter-lock))
|
|
|
|
(define (make-thread-safe-counter)
|
|
(really-make-counter 0 (make-lock)))
|
|
|
|
;;; read current value
|
|
(define (thread-safe-counter counter)
|
|
(obtain-lock (counter-lock counter))
|
|
(let ((result (counter-counter counter)))
|
|
(release-lock (counter-lock counter))
|
|
result))
|
|
|
|
;;; make next value and return it
|
|
(define (thread-safe-counter-next! counter)
|
|
(obtain-lock (counter-lock counter))
|
|
(let ((result (+ 1 (counter-counter counter))))
|
|
(set-counter-counter! counter result)
|
|
(release-lock (counter-lock counter))
|
|
result))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Error-Handler
|
|
;;
|
|
;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that
|
|
;; is catchable. We must catch everything because we also want
|
|
;; exceptions (and warnings) to be catched (e.g. when the surflet is
|
|
;; loaded.)
|
|
(define (with-fatal-handler* handler thunk)
|
|
(call-with-current-continuation
|
|
(lambda (accept)
|
|
((call-with-current-continuation
|
|
(lambda (k)
|
|
(with-handler (lambda (condition more)
|
|
(call-with-current-continuation
|
|
(lambda (decline)
|
|
(k (lambda () (handler condition decline)))))
|
|
(more)) ; Keep looking for a handler.
|
|
(lambda () (call-with-values thunk accept)))))))))
|
|
|
|
(define-syntax with-fatal-handler
|
|
(syntax-rules ()
|
|
((with-fatal-handler handler body ...)
|
|
(with-fatal-handler* handler
|
|
(lambda () body ...)))))
|
|
|
|
(define (bad-gateway-error-response req path-string condition)
|
|
(make-error-response
|
|
(status-code bad-gateway) req
|
|
(format #f "Error in surflet ~s." path-string)
|
|
condition))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; DEBUGGING
|
|
|
|
(define (debug fmt . args)
|
|
(if *debug*
|
|
(format #t "DEBUG: ~?~%" fmt args)
|
|
(force-output)))
|