129 lines
4.8 KiB
Scheme
129 lines
4.8 KiB
Scheme
#lang scheme/base
|
|
(require mzlib/plt-match
|
|
scheme/contract)
|
|
(require web-server/managers/manager
|
|
web-server/managers/timeouts
|
|
web-server/managers/none
|
|
(only-in web-server/lang/web
|
|
initialize-servlet)
|
|
web-server/http
|
|
web-server/servlet/web
|
|
web-server/configuration/namespace
|
|
web-server/private/web-server-structs
|
|
web-server/private/servlet
|
|
web-server/private/util)
|
|
|
|
(define path->servlet/c (path? . -> . servlet?))
|
|
(provide/contract
|
|
[path->servlet/c contract?]
|
|
[make-default-path->servlet
|
|
(->* ()
|
|
(#:make-servlet-namespace make-servlet-namespace/c
|
|
#:timeouts-default-servlet number?)
|
|
path->servlet/c)])
|
|
|
|
(define (v0.response->v1.lambda response response-path)
|
|
(define go
|
|
(box
|
|
(lambda ()
|
|
(set-box! go (lambda () (load/use-compiled response-path)))
|
|
response)))
|
|
(lambda (initial-request)
|
|
((unbox go))))
|
|
|
|
(define (make-v1.servlet directory timeout start)
|
|
(make-v2.servlet
|
|
directory
|
|
(create-timeout-manager
|
|
#f timeout timeout)
|
|
(lambda (initial-request)
|
|
(adjust-timeout! timeout)
|
|
(start initial-request))))
|
|
|
|
(define (make-v2.servlet directory manager start)
|
|
(make-servlet
|
|
(current-custodian)
|
|
(current-namespace)
|
|
manager
|
|
directory
|
|
(lambda (req)
|
|
(define uri (request-uri req))
|
|
|
|
(define-values (instance-id handler)
|
|
(cond
|
|
[(continuation-url? uri)
|
|
=> (match-lambda
|
|
[(list instance-id k-id salt)
|
|
(values instance-id
|
|
(custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])]
|
|
[else
|
|
(values ((manager-create-instance manager) (exit-handler))
|
|
start)]))
|
|
|
|
(parameterize ([current-servlet-instance-id instance-id])
|
|
(handler req)))))
|
|
|
|
(define (make-stateless.servlet directory start)
|
|
(define ses
|
|
(make-servlet
|
|
(current-custodian) (current-namespace)
|
|
(create-none-manager (lambda (req) (error "No continuations!")))
|
|
directory
|
|
(lambda (req) (error "Session not initialized"))))
|
|
(parameterize ([current-directory directory]
|
|
[current-servlet ses])
|
|
(set-servlet-handler! ses (initialize-servlet start)))
|
|
ses)
|
|
|
|
(define common-module-specs
|
|
'(web-server/private/servlet
|
|
web-server/http))
|
|
|
|
(define servlet-module-specs
|
|
'(web-server/servlet/web
|
|
web-server/servlet/web-cells))
|
|
(define lang-module-specs
|
|
'(web-server/lang/web-cells
|
|
web-server/lang/abort-resume))
|
|
(define default-module-specs
|
|
(append common-module-specs
|
|
servlet-module-specs
|
|
lang-module-specs))
|
|
(provide/contract
|
|
[make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)]
|
|
[make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)]
|
|
[make-stateless.servlet (path? (request? . -> . response?) . -> . servlet?)]
|
|
[default-module-specs (listof module-path?)])
|
|
|
|
(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
|
|
#:timeouts-default-servlet [timeouts-default-servlet 30])
|
|
(lambda (a-path)
|
|
(parameterize ([current-namespace (make-servlet-namespace
|
|
#:additional-specs
|
|
default-module-specs)]
|
|
[current-custodian (make-servlet-custodian)])
|
|
(define s (load/use-compiled a-path))
|
|
(cond
|
|
[(void? s)
|
|
(let* ([module-name `(file ,(path->string a-path))]
|
|
[version (dynamic-require module-name 'interface-version)])
|
|
(case version
|
|
[(v1)
|
|
(let ([timeout (dynamic-require module-name 'timeout)]
|
|
[start (dynamic-require module-name 'start)])
|
|
(make-v1.servlet (directory-part a-path) timeout start))]
|
|
[(v2)
|
|
(let ([start (dynamic-require module-name 'start)]
|
|
[manager (dynamic-require module-name 'manager)])
|
|
(make-v2.servlet (directory-part a-path) manager start))]
|
|
[(stateless)
|
|
(let ([start (dynamic-require module-name 'start)])
|
|
(make-stateless.servlet (directory-part a-path) start))]
|
|
[else
|
|
(error 'path->servlet "unknown servlet version ~e, must be 'v1, 'v2, or 'stateless" version)]))]
|
|
[(response? s)
|
|
(make-v1.servlet (directory-part a-path) timeouts-default-servlet
|
|
(v0.response->v1.lambda s a-path))]
|
|
[else
|
|
(error 'path->servlet
|
|
"Loading ~e produced ~n~e~n instead of either (1) a response or (2) nothing and exports 'interface-version" a-path s)])))) |