suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adding better contracts and renaming in accordance w/ Robbys suggestion

Browse Source 
svn: r11428
This commit is contained in:
Jay McCarthy 2008-08-25 19:57:34 +00:00
parent 354ebabe0c
commit 4e764d8f0e
49 changed files with 207 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/web-server/configuration/namespace.ss
View File

@ -30,16 +30,14 @@
additional-names))
new-namespace)))
; XXX
(define module-spec? any/c)
(define make-servlet-namespace?
(define make-servlet-namespace/c
(->* ()
(#:additional-specs (listof module-spec?))
(#:additional-specs (listof module-path?))
namespace?))
(provide/contract
[make-servlet-namespace? contract?]
[make-servlet-namespace/c contract?]
[make-make-servlet-namespace
(->* ()
(#:to-be-copied-module-specs (listof module-spec?))
make-servlet-namespace?)])
(#:to-be-copied-module-specs (listof module-path?))
make-servlet-namespace/c)])

10
collects/web-server/dispatchers/dispatch-files.ss
View File

@ -13,15 +13,13 @@
"../dispatchers/filesystem-map.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[read-range-header (-> (listof header?) (or/c (listof pair?) false/c))])
(provide/contract
[interface-version dispatcher-interface-version/c]
[read-range-header (-> (listof header?) (or/c (listof pair?) false/c))]
[make
(->* (#:url->path url-path?)
(->* (#:url->path url-path/c)
(#:path->mime-type (path? . -> . bytes?)
#:indices (listof path-string?))
dispatcher?)])
dispatcher/c)])
;; looks-like-directory : str -> bool
;; to determine if is url style path looks like it refers to a directory

4
collects/web-server/dispatchers/dispatch-filter.ss
View File

@ -5,8 +5,8 @@
"../private/request-structs.ss"
"../private/util.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make (regexp? dispatcher? . -> . dispatcher?)])
[interface-version dispatcher-interface-version/c]
[make (regexp? dispatcher/c . -> . dispatcher/c)])
(define interface-version 'v1)
(define ((make regex inner) conn req)

4
collects/web-server/dispatchers/dispatch-host.ss
View File

@ -6,8 +6,8 @@
"../private/util.ss"
"dispatch.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make ((symbol? . -> . dispatcher?) . -> . dispatcher?)])
[interface-version dispatcher-interface-version/c]
[make ((symbol? . -> . dispatcher/c) . -> . dispatcher/c)])
(define interface-version 'v1)
(define ((make lookup-dispatcher) conn req)

8
collects/web-server/dispatchers/dispatch-lang.ss
View File

@ -17,13 +17,13 @@
"../configuration/responders.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[interface-version dispatcher-interface-version/c]
[make
(->* (#:url->path url-path?)
(#:make-servlet-namespace make-servlet-namespace?
(->* (#:url->path url-path/c)
(#:make-servlet-namespace make-servlet-namespace/c
#:responders-servlet-loading (url? any/c . -> . response?)
#:responders-servlet (url? any/c . -> . response?))
dispatcher?)])
dispatcher/c)])
; XXX url->servlet
; XXX optional session manager

4
collects/web-server/dispatchers/dispatch-lift.ss
View File

@ -5,8 +5,8 @@
"../private/request-structs.ss"
"../private/response-structs.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make ((request? . -> . response?) . -> . dispatcher?)])
[interface-version dispatcher-interface-version/c]
[make ((request? . -> . response?) . -> . dispatcher/c)])
(define interface-version 'v1)
(define ((make procedure) conn req)

4
collects/web-server/dispatchers/dispatch-log.ss
View File

@ -15,11 +15,11 @@
[paren-format format-req/c]
[extended-format format-req/c]
[apache-default-format format-req/c]
[interface-version dispatcher-interface-version?]
[interface-version dispatcher-interface-version/c]
[make (->* ()
(#:format format-req/c
#:log-path path-string?)
dispatcher?)])
dispatcher/c)])
(define interface-version 'v1)
(define (make #:format [format paren-format]

4
collects/web-server/dispatchers/dispatch-passwords.ss
View File

@ -10,14 +10,14 @@
"../servlet/basic-auth.ss"
"../private/response.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[interface-version dispatcher-interface-version/c]
[make (->* ()
(#:password-file path-string?
#:authentication-responder
(url? header? . -> . response?))
(values
(-> void)
dispatcher?))])
dispatcher/c))])
(define interface-version 'v1)
(define (make ; XXX Take authorized? function

4
collects/web-server/dispatchers/dispatch-pathprocedure.ss
View File

@ -7,8 +7,8 @@
"../private/request-structs.ss"
"../private/response-structs.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make (string? (request? . -> . response?) . -> . dispatcher?)])
[interface-version dispatcher-interface-version/c]
[make (string? (request? . -> . response?) . -> . dispatcher/c)])
(define interface-version 'v1)
(define ((make the-path procedure) conn req)

8
collects/web-server/dispatchers/dispatch-sequencer.ss
View File

@ -1,10 +1,8 @@
#lang scheme/base
(require mzlib/list
mzlib/contract)
#lang scheme
(require "dispatch.ss")
(provide/contract
[interface-version dispatcher-interface-version?])
(provide make)
[interface-version dispatcher-interface-version/c]
[make (() () #:rest (listof dispatcher/c) . ->* . dispatcher/c)])
(define interface-version 'v1)
(define ((make . dispatchers) conn req)

8
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -19,15 +19,15 @@
"../private/cache-table.ss"
"../private/util.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[interface-version dispatcher-interface-version/c]
[make (->* ((box/c cache-table?)
#:url->path url-path?)
(#:make-servlet-namespace make-servlet-namespace?
#:url->path url-path/c)
(#:make-servlet-namespace make-servlet-namespace/c
#:responders-servlet-loading (url? any/c . -> . response?)
#:responders-servlet (url? any/c . -> . response?)
#:timeouts-default-servlet number?)
(values (-> void)
dispatcher?))])
dispatcher/c))])
(define interface-version 'v1)
(define (make config:scripts

4
collects/web-server/dispatchers/dispatch-stat.ss
View File

@ -5,8 +5,8 @@
"../private/connection-manager.ss")
(provide/contract
[make-gc-thread (integer? . -> . thread?)]
[interface-version dispatcher-interface-version?]
[make (-> dispatcher?)])
[interface-version dispatcher-interface-version/c]
[make (-> dispatcher/c)])
(define (bytes->mb b)
(round (exact->inexact (/ b 1024 1024))))

4
collects/web-server/dispatchers/dispatch-timeout.ss
View File

@ -3,8 +3,8 @@
(require "dispatch.ss"
"../private/connection-manager.ss")
(provide/contract
[interface-version dispatcher-interface-version?]
[make (integer? . -> . dispatcher?)])
[interface-version dispatcher-interface-version/c]
[make (integer? . -> . dispatcher/c)])
(define interface-version 'v1)
(define ((make new-timeout) conn req)

12
collects/web-server/dispatchers/dispatch.ss
View File

@ -1,17 +1,17 @@
#lang scheme/base
(require mzlib/contract)
(require scheme/contract)
(require "../private/connection-manager.ss"
"../private/request-structs.ss")
(define dispatcher?
(define dispatcher/c
(connection? request? . -> . void))
(define (dispatcher-interface-version? v)
(and (symbol? v) (eq? v 'v1)))
(define dispatcher-interface-version/c
(symbols 'v1))
(define-struct exn:dispatcher ())
(define (next-dispatcher) (raise (make-exn:dispatcher)))
(provide/contract
[dispatcher? contract?]
[dispatcher-interface-version? (any/c . -> . boolean?)]
[dispatcher/c contract?]
[dispatcher-interface-version/c contract?]
[next-dispatcher (-> void)]
[struct exn:dispatcher ()])

8
collects/web-server/dispatchers/filesystem-map.ss
View File

@ -3,13 +3,13 @@
mzlib/list
mzlib/contract)
(require "../private/util.ss")
(define url-path?
(define url-path/c
((url?) . ->* . (path? (listof path-element?))))
(provide/contract
[url-path? contract?]
[make-url->path (path? . -> . url-path?)]
[make-url->valid-path (url-path? . -> . url-path?)])
[url-path/c contract?]
[make-url->path (path? . -> . url-path/c)]
[make-url->valid-path (url-path/c . -> . url-path/c)])
(define (build-path* . l)
(if (empty? l)

5
collects/web-server/insta/insta.ss
View File

@ -13,14 +13,15 @@
(define launch-browser? #t)
(provide/contract
(static-files-path ((or/c string? path?) . -> . void?)))
[static-files-path ((or/c string? path?) . -> . void?)])
(define (static-files-path path)
(set! extra-files-path
(if (path? path)
path
(string->path path))))
(provide no-web-browser)
(provide/contract
[no-web-browser (-> void)])
(define (no-web-browser)
(set! launch-browser? false))

1
collects/web-server/lang/abort-resume.ss
View File

@ -4,6 +4,7 @@
mzlib/serialize
"../private/define-closure.ss"
"../lang/web-cells.ss")
; XXX contract
(provide
;; AUXILLIARIES

4
collects/web-server/lang/anormal.ss
View File

@ -2,9 +2,11 @@
(require (for-template scheme/base)
syntax/kerncase
mzlib/list
scheme/contract
mzlib/plt-match
"util.ss")
(provide make-anormal-term)
(provide/contract
[make-anormal-term ((syntax? . -> . syntax?) . -> . (syntax? . -> . syntax?))])
; A-Normal Form
(define (id x) x)

4
collects/web-server/lang/defun.ss
View File

@ -2,11 +2,13 @@
(require (for-template scheme/base)
syntax/kerncase
syntax/free-vars
scheme/contract
mzlib/list
mzlib/plt-match
"util.ss"
"../private/closure.ss")
(provide defun)
(provide/contract
[defun (syntax? . -> . (values syntax? (listof syntax?)))])
; make-new-clouse-label : (syntax -> syntax) syntax -> syntax
(define (make-new-closure-label labeling stx)

4
collects/web-server/lang/elim-callcc.ss
View File

@ -1,10 +1,12 @@
#lang scheme/base
(require (for-template scheme/base)
syntax/kerncase
scheme/contract
"../lang/abort-resume.ss"
(for-template "../lang/abort-resume.ss")
"util.ss")
(provide elim-callcc)
(provide/contract
[elim-callcc (syntax? . -> . syntax?)])
(define (id x) x)

5
collects/web-server/lang/elim-letrec.ss
View File

@ -3,9 +3,12 @@
syntax/kerncase
mzlib/etc
mzlib/list
scheme/contract
(for-template "../lang/abort-resume.ss")
"util.ss")
(provide (all-defined-out))
(provide/contract
[elim-letrec ((listof syntax?) . -> . (syntax? . -> . syntax?))]
[elim-letrec-term (syntax? . -> . syntax?)])
; elim-letrec : (listof identifier-syntax?)[3] -> syntax?[2] -> syntax?[3]
; Eliminates letrec-values from syntax[2] and correctly handles references to

5
collects/web-server/lang/labels.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
#lang scheme
(require mzlib/md5)
(provide make-labeling)
(provide/contract
[make-labeling (bytes? . -> . (-> symbol?))])
;; REQUIREMENT: The label code must be non-numeric.
;; REQUIREMENT: The first numeric character following the label code

5
collects/web-server/lang/web-extras.ss
View File

@ -1,9 +1,12 @@
#lang scheme/base
(require net/url
scheme/contract
(for-template "web.ss")
"web.ss"
web-server/private/request-structs
"../servlet/helpers.ss")
(provide redirect/get)
(provide/contract
[redirect/get (-> request?)])
(define (redirect/get)
(send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily))))

5
collects/web-server/lang/web-param.ss
View File

@ -1,11 +1,12 @@
#lang scheme/base
(require (for-syntax scheme/base)
scheme/contract
"../private/closure.ss"
mzlib/list)
; XXX Add contract
(provide/contract
[web-parameter? (any/c . -> . boolean?)])
(provide make-web-parameter
web-parameter?
web-parameterize)
(define (web-parameter? any)

14
collects/web-server/lang/web.ss
View File

@ -1,6 +1,9 @@
#lang scheme
(require net/url
scheme/contract
scheme/serialize
web-server/private/request-structs
web-server/private/response-structs
web-server/private/define-closure
"../private/request-structs.ss"
"abort-resume.ss"
@ -17,6 +20,17 @@
send/suspend/url
send/suspend/dispatch)
; These contracts interfere with the continuation safety marks
#;(provide/contract
;; Server Interface
[initialize-servlet ((request? . -> . response?) . -> . (request? . -> . response?))]
;; Servlet Interface
[send/suspend/hidden ((url? list? . -> . response?) . -> . request?)]
[send/suspend/url ((url? . -> . response?) . -> . request?)]
[send/suspend/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response?)
. -> . any/c)])
;; initial-servlet : (request -> response) -> (request -> response?)
(define (initialize-servlet start)
(let ([params (current-parameterization)])

4
collects/web-server/managers/lru.ss
View File

@ -4,11 +4,11 @@
(require "manager.ss"
"../servlet/servlet-structs.ss")
(provide/contract
[create-LRU-manager (expiration-handler? number? number? (-> boolean?)
[create-LRU-manager (expiration-handler/c number? number? (-> boolean?)
#:initial-count number?
#:inform-p (number? . -> . void)
. -> . manager?)]
[make-threshold-LRU-manager (expiration-handler? number? . -> . manager?)])
[make-threshold-LRU-manager (expiration-handler/c number? . -> . manager?)])
;; Utility
(define (make-counter)

6
collects/web-server/managers/manager.ss
View File

@ -18,13 +18,13 @@
[struct manager ([create-instance ((-> void) . -> . number?)]
[adjust-timeout! (number? number? . -> . void)]
[clear-continuations! (number? . -> . void)]
[continuation-store! (number? any/c expiration-handler? . -> . (list/c number? number?))]
[continuation-store! (number? any/c expiration-handler/c . -> . (list/c number? number?))]
[continuation-lookup (number? number? number? . -> . any/c)])]
[struct (exn:fail:servlet-manager:no-instance exn:fail)
([message string?]
[continuation-marks continuation-mark-set?]
[expiration-handler expiration-handler?])]
[expiration-handler expiration-handler/c])]
[struct (exn:fail:servlet-manager:no-continuation exn:fail)
([message string?]
[continuation-marks continuation-mark-set?]
[expiration-handler expiration-handler?])])
[expiration-handler expiration-handler/c])])

2
collects/web-server/managers/none.ss
View File

@ -3,7 +3,7 @@
(require "manager.ss")
(require "../servlet/servlet-structs.ss")
(provide/contract
[create-none-manager (expiration-handler? . -> . manager?)])
[create-none-manager (expiration-handler/c . -> . manager?)])
(define-struct (none-manager manager) (instance-expiration-handler))
(define (create-none-manager

2
collects/web-server/managers/timeouts.ss
View File

@ -5,7 +5,7 @@
(require "../private/timer.ss"
"../servlet/servlet-structs.ss")
(provide/contract
[create-timeout-manager (expiration-handler? number? number? . -> . manager?)])
[create-timeout-manager (expiration-handler/c number? number? . -> . manager?)])
;; Utility
(define (make-counter)

6
collects/web-server/private/closure.ss
View File

@ -2,9 +2,11 @@
(require (for-template scheme/base)
(for-template mzlib/serialize)
mzlib/list
scheme/contract
mzlib/serialize)
(provide make-closure-definition-syntax
closure->deserialize-name)
(provide/contract
[closure->deserialize-name (serializable? . -> . symbol?)])
(provide make-closure-definition-syntax)
(define (closure->deserialize-name proc)
(cdr (first (third (serialize proc)))))

9
collects/web-server/private/dispatch-server-unit.ss
View File

@ -1,8 +1,6 @@
#lang scheme/unit
(require net/tcp-sig
mzlib/thread
mzlib/contract
mzlib/kw)
mzlib/thread)
(require "web-server-structs.ss"
"connection-manager.ss"
"dispatch-server-sig.ss")
@ -56,9 +54,8 @@
;; handle-connection : input-port output-port (input-port -> string string) -> void
;; returns immediately, spawning a thread to handle
(define/kw (handle-connection ip op
#:optional
[port-addresses tcp-addresses])
(define (handle-connection ip op
#:port-addresses [port-addresses tcp-addresses])
(define conn
(new-connection config:initial-connection-timeout
ip op (current-custodian) #f))

1
collects/web-server/private/mod-map.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require mzlib/list
mzlib/plt-match)
; XXX Contract?
(provide compress-serial
decompress-serial)

3
collects/web-server/private/request.ss
View File

@ -9,7 +9,8 @@
"../private/request-structs.ss")
(provide/contract
[rename ext:read-request read-request ((connection? number? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))])
[rename ext:read-request read-request
((connection? number? ((input-port?) . ->* . (string? string?))) . ->* . (request? boolean?))])
(define (ext:read-request conn host-port port-addresses)
(with-handlers ([exn? (lambda (exn)

11
collects/web-server/private/servlet.ss
View File

@ -1,12 +1,10 @@
#lang scheme/base
(require mzlib/contract)
(require scheme/contract)
(require "../managers/manager.ss"
"../private/request-structs.ss"
"../private/response-structs.ss")
(define servlet-prompt (make-continuation-prompt-tag 'servlet))
(provide servlet-prompt)
(define-struct (exn:fail:servlet:instance exn:fail) ()
#:mutable)
(define-struct servlet (custodian namespace manager handler)
@ -22,6 +20,7 @@
(servlet-manager (current-servlet)))
(provide/contract
[servlet-prompt continuation-prompt-tag?]
[struct (exn:fail:servlet:instance exn:fail)
([message string?]
[continuation-marks continuation-mark-set?])]
@ -32,7 +31,7 @@
[handler (request? . -> . response?)])]
[struct execution-context
([request request?])]
[current-servlet parameter?]
[current-servlet-instance-id parameter?]
[current-execution-context parameter?]
[current-servlet (parameter/c servlet?)]
[current-servlet-instance-id (parameter/c number?)]
[current-execution-context (parameter/c execution-context?)]
[current-servlet-manager (-> manager?)])

6
collects/web-server/private/session.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require mzlib/contract
(require scheme/contract
mzlib/list
net/url
"response-structs.ss"
@ -32,8 +32,8 @@
[url url?])]
[lookup-session ((listof string?) . -> . (or/c session? false/c))]
[install-session (session? (listof string?) . -> . void)]
[new-session (custodian? namespace? url? (listof string?) . -> . session?)])
(provide current-session)
[new-session (custodian? namespace? url? (listof string?) . -> . session?)]
[current-session (parameter/c session?)])
(define current-session (make-parameter #f))

2
collects/web-server/private/web-server-structs.ss
View File

@ -2,7 +2,6 @@
(require mzlib/contract)
(define current-server-custodian (make-parameter #f))
(provide current-server-custodian) ; parameter
;; make-servlet-custodian: -> custodian
;; create a custodian for the dynamic extent of a servlet continuation
@ -10,4 +9,5 @@
(make-custodian (current-server-custodian)))
(provide/contract
[current-server-custodian (parameter/c custodian?)]
[make-servlet-custodian (-> custodian?)])

1
collects/web-server/private/xexpr-extras.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require net/url
mzlib/plt-match)
; XXX contract
(provide xexpr+extras->xexpr)
(define xexpr+extras->xexpr

15
collects/web-server/scribblings/configuration.scrbl
View File

@ -162,12 +162,17 @@ This function writes a @scheme[configuration-table] to @scheme[path].
@scheme[make-servlet-namespace] procedure needed by the @scheme[make] functions
of @filepath{dispatchers/dispatch-servlets.ss} and @filepath{dispatchers/dispatch-lang.ss}.
@; XXX Define make-servlet-namespace?
@; XXX Use actual keyword argument syntax
@defthing[make-servlet-namespace/c contract?]{
Equivalent to
@schemeblock[
(->* ()
(#:additional-specs (listof module-path?))
namespace?)
].
}
@defproc[(make-make-servlet-namespace (#:to-be-copied-module-specs to-be-copied-module-specs (listof module-spec?)))
(key-> ([additional-specs (listof module-spec?)])
namespace?)]{
@defproc[(make-make-servlet-namespace (#:to-be-copied-module-specs to-be-copied-module-specs (listof module-path?)))
make-servlet-namespace/c]{
This function creates a function that when called will construct a new @scheme[namespace] that
has all the modules from @scheme[to-be-copied-module-specs] and @scheme[additional-specs], as well
as @scheme[mzscheme] and @scheme[mred], provided they are already attached

46
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -38,12 +38,12 @@ documentation will be useful.
@filepath{dispatchers/dispatch.ss} provides a few functions for dispatchers in general.
@defthing[dispatcher? contract?]{
@defthing[dispatcher/c contract?]{
Equivalent to @scheme[(connection? request? . -> . void)].
}
@defproc[(dispatcher-interface-version? (any any/c)) boolean?]{
Returns @scheme[#t] if @scheme[any] is @scheme['v1]. Returns @scheme[#f] otherwise.
@defproc[(dispatcher-interface-version/c (any any/c)) boolean?]{
Equivalent to @scheme[(symbols 'v1)]
}
@defstruct[exn:dispatcher ()]{
@ -55,7 +55,7 @@ documentation will be useful.
Raises a @scheme[exn:dispatcher]
}
As the @scheme[dispatcher?] contract suggests, a dispatcher is a function that takes a connection
As the @scheme[dispatcher/c] contract suggests, a dispatcher is a function that takes a connection
and request object and does something to them. Mostly likely it will generate
some response and output it on the connection, but it may do something
different. For example, it may apply some test to the request object, perhaps
@ -64,7 +64,7 @@ otherwise.
Consider the following example dispatcher, that captures the essence of URL rewriting:
@schemeblock[
(code:comment "(url? -> url?) dispatcher? -> dispatcher?")
(code:comment "(url? -> url?) dispatcher/c -> dispatcher/c")
(lambda (rule inner)
(lambda (conn req)
(code:comment "Call the inner dispatcher...")
@ -84,14 +84,14 @@ Consider the following example dispatcher, that captures the essence of URL rewr
@filepath{dispatchers/filesystem-map.ss} provides a means of mapping
URLs to paths on the filesystem.
@defthing[url-path? contract?]{
@defthing[url-path/c contract?]{
This contract is equivalent to @scheme[((url?) . ->* . (path? (listof path-element?)))].
The returned @scheme[path?] is the path on disk. The list is the list of
path elements that correspond to the path of the URL.}
@defproc[(make-url->path (base path?))
url-path?]{
The @scheme[url-path?] returned by this procedure considers the root
url-path/c]{
The @scheme[url-path/c] returned by this procedure considers the root
URL to be @scheme[base]. It ensures that @scheme[".."]s in the URL
do not escape the @scheme[base] and removes them silently otherwise.}
@ -112,8 +112,8 @@ URLs to paths on the filesystem.
@elem{defines a dispatcher constructor
that invokes a sequence of dispatchers until one applies.}]{
@defproc[(make (dispatcher dispatcher?) ...)
dispatcher?]{
@defproc[(make (dispatcher dispatcher/c) ...)
dispatcher/c]{
Invokes each @scheme[dispatcher], invoking the next if the first
calls @scheme[next-dispatcher]. If no @scheme[dispatcher] applies,
then it calls @scheme[next-dispatcher] itself.
@ -128,7 +128,7 @@ URLs to paths on the filesystem.
dispatcher.}]{
@defproc[(make [new-timeout integer?])
dispatcher?]{
dispatcher/c]{
Changes the timeout on the connection with @scheme[adjust-connection-timeout!]
called with @scheme[new-timeout].
}}
@ -139,7 +139,7 @@ URLs to paths on the filesystem.
@elem{defines a dispatcher constructor.}]{
@defproc[(make (proc (request? . -> . response?)))
dispatcher?]{
dispatcher/c]{
Constructs a dispatcher that calls @scheme[proc] on the request
object, and outputs the response to the connection.
}}
@ -152,8 +152,8 @@ URLs to paths on the filesystem.
that calls an underlying dispatcher
with all requests that pass a predicate.}]{
@defproc[(make (regex regexp?) (inner dispatcher?))
dispatcher?]{
@defproc[(make (regex regexp?) (inner dispatcher/c))
dispatcher/c]{
Calls @scheme[inner] if the URL path of the request, converted to
a string, matches @scheme[regex]. Otherwise, calls @scheme[next-dispatcher].
}}
@ -166,7 +166,7 @@ URLs to paths on the filesystem.
URL path.}]{
@defproc[(make (path string?) (proc (request? . -> . response?)))
dispatcher?]{
dispatcher/c]{
Checks if the request URL path as a string is equal to @scheme[path]
and if so, calls @scheme[proc] for a response.
}
@ -221,7 +221,7 @@ a URL that refreshes the password file, servlet cache, etc.}
@defproc[(make [#:format format format-req/c paren-format]
[#:log-path log-path path-string? "log"])
dispatcher?]{
dispatcher/c]{
Logs requests to @scheme[log-path] by using @scheme[format] to format the requests.
Then invokes @scheme[next-dispatcher].
}}
@ -238,7 +238,7 @@ a URL that refreshes the password file, servlet cache, etc.}
((url url?) (header header?) . -> . response?)
(gen-authentication-responder "forbidden.html")])
(values (-> void)
dispatcher?)]{
dispatcher/c)]{
The first returned value is a procedure that refreshes the password
file used by the dispatcher.
@ -267,8 +267,8 @@ a URL that refreshes the password file, servlet cache, etc.}
@elem{defines a dispatcher constructor
that calls a different dispatcher based upon the host requested.}]{
@defproc[(make (lookup-dispatcher (symbol? . -> . dispatcher?)))
dispatcher?]{
@defproc[(make (lookup-dispatcher (symbol? . -> . dispatcher/c)))
dispatcher/c]{
Extracts a host from the URL requested, or the Host HTTP header,
calls @scheme[lookup-dispatcher] with the host, and invokes the
returned dispatcher. If no host can be extracted, then @scheme['none]
@ -284,7 +284,7 @@ a URL that refreshes the password file, servlet cache, etc.}
@defproc[(make [#:url->path url->path url->path?]
[#:path->mime-type path->mime-type (path? . -> . bytes?) (lambda (path) TEXT/HTML-MIME-TYPE)]
[#:indices indices (listof string?) (list "index.html" "index.htm")])
dispatcher?]{
dispatcher/c]{
Uses @scheme[url->path] to extract a path from the URL in the request
object. If this path does not exist, then the dispatcher does not apply and
@scheme[next-dispatcher] is invoked.
@ -322,7 +322,7 @@ a URL that refreshes the password file, servlet cache, etc.}
integer?
30])
(values (-> void)
dispatcher?)]{
dispatcher/c)]{
The first returned value is a procedure that refreshes the servlet
code cache.
@ -354,7 +354,7 @@ a URL that refreshes the password file, servlet cache, etc.}
[#:responders-servlet responders-servlet
((url url?) (exn exn?) . -> . response?)
servlet-error-responder])
dispatcher?]{
dispatcher/c]{
If the request URL contains a serialized continuation, then it is invoked with the
request. Otherwise, @scheme[url->path] is used to resolve the URL to a path.
The path is evaluated as a module, in a namespace constructed by @scheme[make-servlet-namespace].
@ -376,6 +376,6 @@ a URL that refreshes the password file, servlet cache, etc.}
}
@defproc[(make)
dispatcher?]{
dispatcher/c]{
Returns a dispatcher that prints memory usage on every request.
}}

2
collects/web-server/scribblings/lang.scrbl
View File

@ -134,7 +134,7 @@ by the Web language API.
Note: The continuation is NOT stuffed.
}
@defproc[(send/suspend/dispatch [make-response (embed/url? . -> . response?)])
@defproc[(send/suspend/dispatch [make-response (embed/url/c . -> . response?)])
any/c]{
Calls @scheme[make-response] with a function that, when called with a procedure from
@scheme[request?] to @scheme[any/c] will generate a URL, that when invoked will call

14
collects/web-server/scribblings/managers.scrbl
View File

@ -26,7 +26,7 @@ the users and implementers of managers.
@defstruct[manager ([create-instance ((-> void) . -> . number?)]
[adjust-timeout! (number? number? . -> . void)]
[clear-continuations! (number? . -> . void)]
[continuation-store! (number? any/c expiration-handler? . -> . (list/c number? number?))]
[continuation-store! (number? any/c expiration-handler/c . -> . (list/c number? number?))]
[continuation-lookup (number? number? number? . -> . any/c)])]{
@scheme[create-instance] is called to initialize a instance, to hold the
continuations of one servlet session. It is passed
@ -49,13 +49,13 @@ the users and implementers of managers.
}
@defstruct[(exn:fail:servlet-manager:no-instance exn:fail)
([expiration-handler expiration-handler?])]{
([expiration-handler expiration-handler/c])]{
This exception should be thrown by a manager when an instance is looked
up that does not exist.
}
@defstruct[(exn:fail:servlet-manager:no-continuation exn:fail)
([expiration-handler expiration-handler?])]{
([expiration-handler expiration-handler/c])]{
This exception should be thrown by a manager when a continuation is
looked up that does not exist.
}
@ -68,7 +68,7 @@ the users and implementers of managers.
@filepath{managers/none.ss} defines a manager constructor:
@defproc[(create-none-manager (instance-expiration-handler expiration-handler?))
@defproc[(create-none-manager (instance-expiration-handler expiration-handler/c))
manager?]{
This manager does not actually store any continuation or instance data.
You could use it if you know your servlet does not use the continuation
@ -91,7 +91,7 @@ Web Language. (See @secref["lang"].)
@filepath{managers/timeouts.ss} defines a manager constructor:
@defproc[(create-timeout-manager [instance-exp-handler expiration-handler?]
@defproc[(create-timeout-manager [instance-exp-handler expiration-handler/c]
[instance-timeout number?]
[continuation-timeout number?])
manager?]{
@ -122,7 +122,7 @@ deployments of the @web-server .
@filepath{managers/lru.ss} defines a manager constructor:
@defproc[(create-LRU-manager
[instance-expiration-handler expiration-handler?]
[instance-expiration-handler expiration-handler/c]
[check-interval integer?]
[collect-interval integer?]
[collect? (-> boolean?)]
@ -155,7 +155,7 @@ deployments of the @web-server .
The recommended usage of this manager is codified as the following function:
@defproc[(make-threshold-LRU-manager
[instance-expiration-handler expiration-handler?]
[instance-expiration-handler expiration-handler/c]
[memory-threshold number?])
manager?]{
This creates an LRU manager with the following behavior:

2
collects/web-server/scribblings/servlet-env.scrbl
View File

@ -15,7 +15,7 @@ The @web-server provides a way to quickly configure and start a server instance.
[#:listen-ip listen-ip string? "127.0.0.1"]
[#:port port number? 8000]
[#:manager manager manager? default-threshold-LRU-manager]
[#:servlet-namespace servlet-namespace (listof require-spec?) empty]
[#:servlet-namespace servlet-namespace (listof module-path?) empty]
[#:server-root-path server-root-path path? default-server-root-path]
[#:extra-files-path extra-files-path path? (build-path server-root-path "htdocs")]
[#:servlets-root servlets-root path? (build-path server-root-path ".")]

16
collects/web-server/scribblings/servlet.scrbl
View File

@ -61,9 +61,9 @@ for use in servlets.
@defthing[url-transform? contract?]{Equivalent to @scheme[(k-url? . -> . k-url?)].}
@defthing[expiration-handler? contract?]{Equivalent to @scheme[(or/c false/c (request? . -> . response?))].}
@defthing[expiration-handler/c contract?]{Equivalent to @scheme[(or/c false/c (request? . -> . response?))].}
@defthing[embed/url? contract?]{Equivalent to @scheme[(((request? . -> . any/c)) (expiration-handler?) . opt-> . string?)].}
@defthing[embed/url/c contract?]{Equivalent to @scheme[(((request? . -> . any/c)) (expiration-handler/c) . opt-> . string?)].}
@; ------------------------------------------------------------
@section[#:tag "request-structs.ss"]{HTTP Requests}
@ -254,13 +254,13 @@ functions of interest for the servlet developer.}
Sends @scheme[response] to the client.
}
@defthing[current-servlet-continuation-expiration-handler parameter?]{
Holds the @scheme[expiration-handler?] to be used when a continuation
@defthing[current-servlet-continuation-expiration-handler (parameter/c expiration-handler/c)]{
Holds the @scheme[expiration-handler/c] to be used when a continuation
captured in this context is expired, then looked up.
}
@defproc[(send/suspend [make-response response-generator?]
[exp expiration-handler? (current-servlet-continuation-expiration-handler)])
[exp expiration-handler/c (current-servlet-continuation-expiration-handler)])
request?]{
Captures the current continuation, stores it with @scheme[exp] as the expiration
handler, and binds it to a URL. @scheme[make-response] is called with this URL and
@ -287,7 +287,7 @@ functions of interest for the servlet developer.}
}
@defproc[(send/forward [make-response response-generator?]
[exp expiration-handler? (current-servlet-continuation-expiration-handler)])
[exp expiration-handler/c (current-servlet-continuation-expiration-handler)])
request?]{
Calls @scheme[clear-continuation-table!], then @scheme[send/suspend].
}
@ -297,7 +297,7 @@ functions of interest for the servlet developer.}
Calls @scheme[clear-continuation-table!], then @scheme[send/back].
}
@defproc[(send/suspend/dispatch [make-response (embed/url? . -> . response?)])
@defproc[(send/suspend/dispatch [make-response (embed/url/c . -> . response?)])
any/c]{
Calls @scheme[make-response] with a function that, when called with a procedure from
@scheme[request?] to @scheme[any/c] will generate a URL, that when invoked will call
@ -323,7 +323,7 @@ functions of interest for the servlet developer.}
}
@; XXX Remove
@defthing[current-url-transform parameter?]{
@defthing[current-url-transform (parameter/c url-transform?)]{
Holds a @scheme[url-transform?] function that is called by
@scheme[send/suspend] to transform the URLs it generates.
}

21
collects/web-server/servlet-env.ss
View File

@ -2,12 +2,16 @@
; Also derived from planet/untyped/instaservlet
#lang scheme/base
(require (prefix-in net: net/sendurl)
scheme/contract
scheme/list)
(require web-server/web-server
web-server/managers/lru
web-server/managers/manager
web-server/private/servlet
web-server/configuration/namespace
web-server/private/cache-table
web-server/private/request-structs
web-server/private/response-structs
web-server/private/util
web-server/configuration/responders
web-server/dispatchers/dispatch
@ -35,7 +39,22 @@
(div ([class "title"]) "Server Stopped")
(p "Return to DrScheme.")))))))
(provide serve/servlet)
(provide/contract
[serve/servlet (((request? . -> . response?))
(#:launch-browser? boolean?
#:quit? boolean?
#:listen-ip string?
#:port number?
#:manager manager?
#:servlet-namespace (listof module-path?)
#:server-root-path path?
#:extra-files-path path?
#:servlets-root path?
#:file-not-found-path path?
#:mime-types-path path?
#:servlet-path path?)
. ->* .
void)])
(define (serve/servlet new-servlet
#:launch-browser?
[launch-browser? #t]

1
collects/web-server/servlet/helpers.ss
View File

@ -32,6 +32,7 @@
(pre ,(exn->string exn)))))))])
(thunk)))
; XXX contract
(provide
with-errors-to-browser)
(provide/contract

20
collects/web-server/servlet/servlet-structs.ss
View File

@ -1,27 +1,27 @@
#lang scheme/base
(require mzlib/contract)
(require scheme/contract)
(require "../private/request-structs.ss"
"../private/response-structs.ss")
(define k-url?
string?)
(define response-generator?
(define response-generator/c
(k-url? . -> . response?))
(define url-transform?
(define url-transform/c
(k-url? . -> . k-url?))
(define expiration-handler?
(define expiration-handler/c
(or/c false/c
(request? . -> . response?)))
(define embed/url?
(((request? . -> . any/c)) (expiration-handler?) . opt-> . string?))
(define embed/url/c
(((request? . -> . any/c)) (expiration-handler/c) . ->* . string?))
(provide/contract
[response-generator? contract?]
[response-generator/c contract?]
[k-url? (any/c . -> . boolean?)]
[url-transform? contract?]
[expiration-handler? contract?]
[embed/url? contract?])
[url-transform/c contract?]
[expiration-handler/c contract?]
[embed/url/c contract?])

12
collects/web-server/servlet/web.ss
View File

@ -2,7 +2,7 @@
(require net/url
mzlib/list
mzlib/plt-match
mzlib/contract
scheme/contract
mzlib/etc)
(require "../managers/manager.ss"
"../private/util.ss"
@ -67,17 +67,17 @@
in-url)))
(provide/contract
[current-url-transform parameter?]
[current-servlet-continuation-expiration-handler parameter?]
[current-url-transform (parameter/c url-transform/c)]
[current-servlet-continuation-expiration-handler (parameter/c expiration-handler/c)]
[redirect/get (-> request?)]
[redirect/get/forget (-> request?)]
[adjust-timeout! (number? . -> . void?)]
[clear-continuation-table! (-> void?)]
[send/back (response? . -> . void?)]
[send/finish (response? . -> . void?)]
[send/suspend ((response-generator?) (expiration-handler?) . opt-> . request?)]
[send/forward ((response-generator?) (expiration-handler?) . opt-> . request?)]
[send/suspend/dispatch ((embed/url? . -> . response?) . -> . any/c)])
[send/suspend ((response-generator/c) (expiration-handler/c) . ->* . request?)]
[send/forward ((response-generator/c) (expiration-handler/c) . ->* . request?)]
[send/suspend/dispatch ((embed/url/c . -> . response?) . -> . any/c)])
;; ************************************************************
;; EXPORTS

4
collects/web-server/web-config-unit.ss
View File

@ -14,14 +14,14 @@
(->* (path-string?)
(#:port (or/c false/c number?)
#:listen-ip (or/c false/c string?)
#:make-servlet-namespace make-servlet-namespace?)
#:make-servlet-namespace make-servlet-namespace/c)
unit?)]
[configuration-table-sexpr->web-config@
(->* (list?) ; XXX
(#:web-server-root path-string?
#:port (or/c false/c number?)
#:listen-ip (or/c false/c string?)
#:make-servlet-namespace make-servlet-namespace?)
#:make-servlet-namespace make-servlet-namespace/c)
unit?)])
; configuration-table->web-config@ : path -> configuration

6
collects/web-server/web-server.ss
View File

@ -13,7 +13,7 @@
(prefix-in http: "private/request.ss"))
(provide/contract
[serve
(->* (#:dispatch dispatcher?)
(->* (#:dispatch dispatcher/c)
(#:tcp@ unit?
#:port number?
#:listen-ip (or/c false/c string?)
@ -21,7 +21,7 @@
#:initial-connection-timeout number?)
(-> void))]
[serve/ports
(->* (#:dispatch dispatcher?)
(->* (#:dispatch dispatcher/c)
(#:tcp@ unit?
#:ports (listof number?)
#:listen-ip (or/c false/c string?)
@ -29,7 +29,7 @@
#:initial-connection-timeout number?)
(-> void))]
[serve/ips+ports
(->* (#:dispatch dispatcher?)
(->* (#:dispatch dispatcher/c)
(#:tcp@ unit?
#:ips+ports (listof (cons/c (or/c false/c string?) (listof number?)))
#:max-waiting number?