88 lines
3.6 KiB
Scheme
88 lines
3.6 KiB
Scheme
#lang scheme/base
|
|
(require scheme/contract)
|
|
(require web-server/servlet/setup
|
|
web-server/managers/manager
|
|
web-server/http
|
|
web-server/http/response
|
|
net/url
|
|
web-server/dispatchers/dispatch
|
|
web-server/dispatchers/filesystem-map
|
|
web-server/configuration/responders
|
|
web-server/private/connection-manager
|
|
web-server/private/web-server-structs
|
|
web-server/private/servlet
|
|
web-server/private/cache-table)
|
|
(provide/contract
|
|
[interface-version dispatcher-interface-version/c])
|
|
(define interface-version 'v1)
|
|
|
|
(define url->servlet/c (url? . -> . servlet?))
|
|
(provide/contract
|
|
[url->servlet/c contract?]
|
|
[make-cached-url->servlet
|
|
(-> url->path/c
|
|
path->servlet/c
|
|
(values (-> void)
|
|
url->servlet/c))])
|
|
|
|
(define (make-cached-url->servlet
|
|
url->path
|
|
path->servlet)
|
|
(define config:scripts (make-cache-table))
|
|
(values (lambda ()
|
|
;; This is broken - only out of date or specifically mentioned scripts should be flushed. This destroys persistent state!
|
|
(cache-table-clear! config:scripts))
|
|
(lambda (uri)
|
|
(define-values (servlet-path _)
|
|
(with-handlers
|
|
([void (lambda (e)
|
|
(raise (make-exn:fail:filesystem:exists
|
|
(exn-message e)
|
|
(exn-continuation-marks e))))])
|
|
(url->path uri)))
|
|
(cache-table-lookup! config:scripts
|
|
(string->symbol (path->string servlet-path))
|
|
(lambda () (path->servlet servlet-path))))))
|
|
|
|
; -----
|
|
(provide/contract
|
|
[make (->* (url->servlet/c)
|
|
(#:responders-servlet-loading (url? any/c . -> . response/c)
|
|
#:responders-servlet (url? any/c . -> . response/c))
|
|
dispatcher/c)])
|
|
|
|
(define (make url->servlet
|
|
#:responders-servlet-loading [responders-servlet-loading servlet-loading-responder]
|
|
#:responders-servlet [responders-servlet servlet-error-responder])
|
|
(lambda (conn req)
|
|
(define uri (request-uri req))
|
|
(define instance-custodian (make-servlet-custodian))
|
|
(parameterize ([current-custodian instance-custodian]
|
|
[current-execution-context (make-execution-context req)]
|
|
[exit-handler
|
|
(lambda _
|
|
(kill-connection! conn)
|
|
(custodian-shutdown-all instance-custodian))])
|
|
(define response
|
|
(with-handlers ([exn:fail:filesystem:exists?
|
|
(lambda (the-exn) (next-dispatcher))]
|
|
[exn:dispatcher? raise]
|
|
[(lambda (x) #t)
|
|
(lambda (the-exn) (responders-servlet-loading uri the-exn))])
|
|
(define the-servlet (url->servlet uri))
|
|
(parameterize ([current-servlet the-servlet]
|
|
[current-custodian (servlet-custodian the-servlet)]
|
|
[current-directory (servlet-directory the-servlet)]
|
|
[current-namespace (servlet-namespace the-servlet)])
|
|
(with-handlers ([exn:dispatcher? raise]
|
|
[(lambda (x) #t)
|
|
(lambda (exn) (responders-servlet uri exn))])
|
|
(call-with-continuation-barrier
|
|
(lambda ()
|
|
(call-with-continuation-prompt
|
|
(lambda ()
|
|
((servlet-handler the-servlet) req))
|
|
servlet-prompt)))))))
|
|
|
|
(output-response conn response))))
|