87 lines
3.7 KiB
Scheme
87 lines
3.7 KiB
Scheme
(module backend mzscheme
|
|
(require (lib "servlet.ss" "web-server")
|
|
(lib "timer.ss" "web-server")
|
|
(lib "response.ss" "web-server")
|
|
(lib "connection-manager.ss" "web-server"))
|
|
|
|
(provide start-servlet resume-servlet)
|
|
|
|
;; make-servlet-custodian: -> custodian
|
|
(define make-servlet-custodian
|
|
(let ([cust (current-custodian)])
|
|
(lambda () (make-custodian cust))))
|
|
|
|
;; start-servlet: connection request hash-table number (number->void request -> response) -> void
|
|
;; start a new instance of a servlet
|
|
(define (start-servlet conn req instance-table instance-timeout svt)
|
|
(let ([sema (make-semaphore 0)])
|
|
(let/cc suspend
|
|
(let* ([servlet-custodian (make-servlet-custodian)]
|
|
[inst (create-new-instance!
|
|
instance-table servlet-custodian
|
|
(make-execution-context
|
|
conn req (lambda () (suspend #t)))
|
|
sema)]
|
|
[servlet-exit-handler (make-servlet-exit-handler inst instance-table)]
|
|
[time-bomb (start-timer instance-timeout
|
|
(lambda () (servlet-exit-handler #f)))])
|
|
(parameterize ([current-custodian servlet-custodian]
|
|
[current-servlet-instance inst]
|
|
[exit-handler servlet-exit-handler])
|
|
(with-handlers ([(lambda (x) #t)
|
|
(make-servlet-exception-handler inst)])
|
|
(let ([r (svt (lambda (secs)
|
|
(reset-timer! time-bomb secs))
|
|
req)])
|
|
(when (response? r)
|
|
(send/back r)))))))
|
|
(semaphore-post sema)))
|
|
|
|
;; make-servlet-exit-handler: servlet-instance -> alpha -> void
|
|
;; exit handler for a servlet
|
|
(define (make-servlet-exit-handler inst instance-table)
|
|
(lambda (x)
|
|
(remove-instance! instance-table inst)
|
|
(kill-connection!
|
|
(execution-context-connection
|
|
(servlet-instance-context inst)))
|
|
(custodian-shutdown-all (servlet-instance-custodian inst))))
|
|
|
|
;; make-servlet-exception-handler: host -> exn -> void
|
|
;; This exception handler traps all unhandled servlet exceptions
|
|
(define (make-servlet-exception-handler inst)
|
|
(lambda (the-exn)
|
|
(let* ([ctxt (servlet-instance-context inst)]
|
|
[req (execution-context-request ctxt)])
|
|
(output-response/method
|
|
(execution-context-connection ctxt)
|
|
`(html (head (title "Error"))
|
|
(body
|
|
(p "there was an error:")
|
|
(p ,(exn-message the-exn))))
|
|
(request-method req))
|
|
((execution-context-suspend ctxt)))))
|
|
|
|
;; resume-servlet: connection request continuation-reference hash-table -> void
|
|
;; pull the continuation out of the table and apply it
|
|
(define (resume-servlet conn req k-ref instance-table)
|
|
(let* ([inst (hash-table-get instance-table (car k-ref)
|
|
(lambda ()
|
|
(raise
|
|
(make-exn:servlet:instance
|
|
"" (current-continuation-marks)))))]
|
|
[k-table
|
|
(servlet-instance-k-table inst)])
|
|
(let/cc suspend
|
|
(set-servlet-instance-context!
|
|
inst
|
|
(make-execution-context
|
|
conn req (lambda () (suspend #t))))
|
|
(semaphore-wait (servlet-instance-mutex inst))
|
|
((hash-table-get k-table (cadr k-ref)
|
|
(lambda ()
|
|
(raise
|
|
(make-exn:servlet:continuation
|
|
"" (current-continuation-marks)))))
|
|
req))
|
|
(semaphore-post (servlet-instance-mutex inst))))) |