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

Adding the proto back in

Browse Source 
svn: r6268
This commit is contained in:
Jay McCarthy 2007-05-24 16:26:52 +00:00
parent 7e1e1dcf3d
commit ecbf609a28
46 changed files with 4561 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
collects/web-server/prototype-web-server/abort-resume.ss Normal file
View File

@ -0,0 +1,129 @@
(module abort-resume mzscheme
(require "define-closure.ss"
(lib "serialize.ss"))
(provide
;; AUXILLIARIES
abort
resume
the-cont-key
safe-call?
abort/cc
the-undef
activation-record-list
;; "SERVLET" INTERFACE
start-interaction
send/suspend
;; "CLIENT" INTERFACE
dispatch-start
dispatch
)
(provide current-abort-continuation)
;; **********************************************************************
;; **********************************************************************
;; AUXILLIARIES
(define-struct mark-key ())
(define the-cont-key (make-mark-key))
(define safe-call? (make-mark-key))
;; current-continuation-as-list: -> (listof value)
;; check the safety marks and return the list of marks representing the continuation
(define (activation-record-list)
(let* ([cm (current-continuation-marks)]
[sl (continuation-mark-set->list cm safe-call?)])
;(printf "sl = ~s~n" sl)
(if (andmap (lambda (x) x) sl)
(reverse (continuation-mark-set->list cm the-cont-key))
(error "Attempt to capture a continuation from within an unsafe context"))))
;; BUGBUG this isn't thread safe
(define current-abort-continuation
(box #f))
;; abort: ( -> alpha) -> alpha
;; erase the stack and apply a thunk
(define (abort thunk)
(let ([abort-k (unbox current-abort-continuation)])
(abort-k thunk)))
;; resume: (listof (value -> value)) value -> value
;; resume a computation given a value and list of frame procedures
(define (resume frames val)
(cond
[(null? frames) val]
[else
(let ([f (car frames)])
(f (with-continuation-mark the-cont-key f (resume (cdr frames) val))))]))
(define-syntax (abort/cc stx)
(syntax-case stx ()
[(_ expr)
#'((let/cc abort-k
(set-box! current-abort-continuation abort-k)
(lambda () expr)))]))
;; a serializable undefined value
(define-serializable-struct undef ())
(define the-undef (make-undef))
;; **********************************************************************
;; **********************************************************************
;; "SERVLET" INTERFACE
(define decode-continuation
(lambda (k-val)
(error "interactive module not initialized")))
(define (start-continuation val)
(error "interactive module not initialized"))
;; start-interaction: (request -> continuation) -> request
;; register the decode proc and start the interaction with the current-continuation
(define (start-interaction decode)
(set! decode-continuation decode)
((lambda (k0) (abort (lambda () (set! start-continuation k0))))
(let ([current-marks
(reverse
(continuation-mark-set->list (current-continuation-marks) the-cont-key))])
(lambda (x) (abort (lambda () (resume current-marks x)))))))
(define-closure kont (x) (current-marks)
(abort (lambda () (resume current-marks x))))
;; send/suspend: (continuation -> response) -> request
;; produce the current response and wait for the next request
(define (send/suspend response-maker)
(with-continuation-mark safe-call? #t
((lambda (k) (abort (lambda () (response-maker k))))
(let ([current-marks (activation-record-list)])
(make-kont (lambda () current-marks))))))
;; **********************************************************************
;; **********************************************************************
;; "CLIENT" INTERFACE
;; dispatch-start: request -> reponse
;; pass the initial request to the starting interaction point
(define (dispatch-start req0)
(abort/cc (start-continuation req0)))
;; dispatch: request -> response
;; lookup the continuation for this request and invoke it
(define (dispatch req)
(abort/cc
(cond
[(decode-continuation req)
=> (lambda (k) (k req))]
[else
(error "no continuation associated with the provided request")])))
)

4
collects/web-server/prototype-web-server/client.ss Normal file
View File

@ -0,0 +1,4 @@
(module client mzscheme
(require "abort-resume.ss")
(provide dispatch-start
dispatch))

112
collects/web-server/prototype-web-server/closure.ss Normal file
View File

@ -0,0 +1,112 @@
(module closure mzscheme
(require-for-template mzscheme
(lib "serialize.ss")
(lib "etc.ss"))
(provide make-closure-definition-syntax)
(define myprint printf)
;; borrowed this from Matthew's code
;; creates the deserialize-info identifier
(define (make-deserialize-name id)
(datum->syntax-object
id
(string->symbol
(format "web-deserialize-info:~a" (syntax-e id)))
id))
(define (make-closure-definition-syntax tag formals fvars proc-body)
(let ([make-id (lambda (str)
(datum->syntax-object
tag (string->symbol (format str (syntax-object->datum tag)))))])
(let ([deserialize-info:CLOSURE (make-deserialize-name tag)])
(with-syntax ([CLOSURE:serialize-info (make-id "~a:serialize-info")]
[make-CLOSURE (make-id "make-~a")]
[CLOSURE? (make-id "~a?")]
[CLOSURE-ref (make-id "~a-ref")]
[CLOSURE-set! (make-id "~a-set!")]
[CLOSURE-env (make-id "~a-env")]
[set-CLOSURE-env! (make-id "set-~a-env!")]
[struct:CLOSURE (make-id "struct:~a")])
(values
#'make-CLOSURE
(list
#`(define #,deserialize-info:CLOSURE
(make-deserialize-info
;; make-proc: value ... -> CLOSURE
#,(if (null? fvars)
#'(lambda () (make-CLOSURE))
#`(lambda #,fvars (make-CLOSURE (lambda () (values #,@fvars)))))
;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void))
(lambda ()
(let ([new-closure
#,(if (null? fvars)
#'(make-CLOSURE)
#'(make-CLOSURE (lambda () (error "closure not initialized"))))])
(values
new-closure
#,(if (null? fvars)
#'void
#'(lambda (clsr)
(set-CLOSURE-env! new-closure (CLOSURE-env clsr)))))))))
#`(provide #,deserialize-info:CLOSURE)
#`(define CLOSURE:serialize-info
(make-serialize-info
;; to-vector: CLOSURE -> vector
#,(if (null? fvars)
#'(lambda (clsr) (vector))
#'(lambda (clsr)
(call-with-values
(lambda () ((CLOSURE-env clsr)))
vector)))
;; The serializer id: --------------------
;(syntax deserialize-info:CLOSURE)
;; I still don't know what to put here.
;; oh well.
;(quote-syntax #,(syntax deserialize-info:CLOSURE))
(let ([b (identifier-binding (quote-syntax #,deserialize-info:CLOSURE))])
(if (list? b)
(cons '#,deserialize-info:CLOSURE (caddr b))
'#,deserialize-info:CLOSURE))
;; can-cycle?
#t
;; Directory for last-ditch resolution --------------------
(or (current-load-relative-directory) (current-directory))
))
#`(define-values (struct:CLOSURE make-CLOSURE CLOSURE? #,@(if (null? fvars)
#'()
#'(CLOSURE-env set-CLOSURE-env!)))
(let-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!)
(make-struct-type '#,tag ;; the tag goes here
#f ; no super type
#,(if (null? fvars) 0 1)
0 ; number of auto-fields
#f ; auto-v
; prop-vals:
(list (cons prop:serializable CLOSURE:serialize-info))
#f ; inspector
;; the struct apply proc:
#,(if (null? fvars)
#`(lambda (clsr #,@formals)
#,proc-body)
#`(lambda (clsr #,@formals)
(let-values ([#,fvars ((CLOSURE-env clsr))])
#,proc-body)))
)])
(values struct:CLOSURE make-CLOSURE CLOSURE?
#,@(if (null? fvars)
#'()
#'((lambda (clsr) (CLOSURE-ref clsr 0))
(lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env))))))))))))))

15
collects/web-server/prototype-web-server/define-closure.ss Normal file
View File

@ -0,0 +1,15 @@
(module define-closure mzscheme
(require-for-syntax "closure.ss")
(require-for-template mzscheme)
(provide define-closure)
(define-syntax (define-closure stx)
(syntax-case stx ()
[(_ tag (formals ...) (free-vars ...) body)
(let-values ([(make-CLOSURE closure-definitions)
(make-closure-definition-syntax
#'tag
(syntax->list #'(formals ...))
(syntax->list #'(free-vars ...))
#'body)])
#`(begin #,@closure-definitions))])))

202
collects/web-server/prototype-web-server/defunctionalize.ss Normal file
View File

@ -0,0 +1,202 @@
(module defunctionalize mzscheme
(require (lib "list.ss")
"closure.ss"
"syntax-utils.ss")
(require-for-template mzscheme)
(provide defunctionalize-definition
defunctionalize)
;; **************************************************
;; LANGUAGE
;;
;; program ::= definition* expr
;;
;; definition ::= (define-values (var) expr)
;;
;; expr ::= w
;; | E[redex]
;;
;; redex ::= (if w expr)
;; | (if w expr expr)
;; | (#%app w w...)
;;
;; E ::= []
;; | (let-values ([(f) (lambda (var) expr)])
;; (#%app f (w-c-m f E)))
;;
;; w ::= var | (#%top . var) | value
;;
;; value ::= (#%datum . datum)
;; | (lambda (var ...) expr)
;; defunctionalize-definition: definition (-> symbol) -> (listof definition)
;; remove lambdas from a definition
(define (defunctionalize-definition def labeling)
(syntax-case def ()
[(define-values (var ...) expr)
(with-syntax ([expr (recertify #'expr def)])
(let-values ([(new-expr defs) (defunctionalize #'expr labeling)])
(append defs (list #`(define-values (var ...) #,new-expr)))))]
[else
(raise-syntax-error #f "defunctionalize-definition dropped through" def)]))
;; defunctionalize: expr (-> symbol) -> (values expr (listof definition))
;; remove lambdas from an expression
(define (defunctionalize expr labeling)
(syntax-case expr (if #%app lambda let-values #%top #%datum with-continuation mark quote)
[(if test-expr csq-expr)
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
(let-values ([(new-test-expr test-defs) (defunctionalize #'test-expr labeling)]
[(new-csq-expr csq-defs) (defunctionalize #'csq-expr labeling)])
(values
#`(if #,new-test-expr #,new-csq-expr)
(append test-defs csq-defs))))]
[(if test-expr csq-expr alt-expr)
(with-syntax ([(tst-expr csq-expr alt-expr) (recertify* (list #'tst-expr #'csq-expr #'alt-expr) expr)])
(let-values ([(new-test-expr test-defs) (defunctionalize #'test-expr labeling)]
[(new-csq-expr csq-defs) (defunctionalize #'csq-expr labeling)]
[(new-alt-expr alt-defs) (defunctionalize #'alt-expr labeling)])
(values #`(if #,new-test-expr #,new-csq-expr #,new-alt-expr)
(append test-defs csq-defs alt-defs))))]
[(#%app exprs ...)
(with-syntax ([(exprs ...) (recertify* (syntax->list #'(exprs ...)) expr)])
(let-values ([(new-exprs defs) (defunctionalize* (syntax->list #'(exprs ...)) labeling)])
(values
#`(#%app #,@new-exprs)
defs)))]
[(let-values ([(f) rhs])
(#%app f-apply (with-continuation-mark ignore-key f-mark body-expr)))
;; (and (bound-identifier=? #'f #'f-apply) (bound-identifier=? #'f #'f-mark))
(with-syntax ([(rhs f-apply ignore-key f-mark body-expr)
(recertify* (syntax->list #'(rhs f-apply ignore-key f-mark body-expr)) expr)])
(let-values ([(new-rhs rhs-defs) (defunctionalize #'rhs labeling)]
[(new-body-expr body-defs) (defunctionalize #'body-expr labeling)])
(values
#`(let ([f #,new-rhs])
(f-apply (with-continuation-mark ignore-key f-mark #,new-body-expr)))
(append rhs-defs body-defs))))]
[(let-values ([(f) rhs]) (#%app f-apply body-expr))
(with-syntax ([(rhs f-apply body-expr) (recertify* (syntax->list #'(rhs f-apply body-expr) expr))])
(let-values ([(new-rhs rhs-defs) (defunctionalize #'rhs labeling)]
[(new-body-expr body-defs) (defunctionalize #'body-expr labeling)])
(values
#`(let ([f #,new-rhs])
(f-apply #,new-body-expr))
(append rhs-defs body-defs))))]
[(lambda (formals ...) body-expr)
(with-syntax ([body-expr (recertify #'body-expr expr)])
(let-values ([(new-body-expr body-defs) (defunctionalize #'body-expr labeling)])
(let ([fvars (free-vars expr)]
[tag (labeling)])
(let-values ([(make-CLOSURE closure-definitions)
(make-closure-definition-syntax tag (syntax->list #'(formals ...)) fvars new-body-expr)])
(values
(if (null? fvars)
#`(#,make-CLOSURE)
#`(#,make-CLOSURE (lambda () (values #,@fvars))))
(append body-defs
closure-definitions))))))]
[(with-continuation-mark safe-call? b-val body-expr)
(with-syntax ([body-expr (recertify #'body-expr expr)])
(let-values ([(new-body-expr body-defs) (defunctionalize #'body-expr labeling)])
(values
#`(with-continuation-mark safe-call? b-val #,new-body-expr)
body-defs)))]
[(#%top . var) (values expr '())]
[(#%datum . var) (values expr '())]
[(quote datum) (values expr '())]
[var (identifier? #'var) (values expr '())]
[_else
(raise-syntax-error #f "defunctionalize: dropped through" expr)]))
;; defunctionalize*: (listof expr) (-> symbol) -> (values (listof expr) (listof definition))
;; remove lambdas from a whole list of expressions
(define (defunctionalize* exprs labeling)
(cond
[(null? exprs) (values '() '())]
[else
(let-values ([(first-new-expr first-defs) (defunctionalize (car exprs) labeling)]
[(rest-new-exprs rest-defs) (defunctionalize* (cdr exprs) labeling)])
(values
(cons first-new-expr rest-new-exprs)
(append first-defs rest-defs)))]))
;; free-vars: expr -> (listof identifier)
;; Find the free variables in an expression
(define (free-vars expr)
(syntax-case expr (if #%app lambda let #%top #%datum with-continuation-mark quote)
[(if test-expr csq-expr)
(union (free-vars #'test-expr)
(free-vars #'csq-expr))]
[(if test-expr csq-expr alt-expr)
(union (free-vars #'test-expr)
(union (free-vars #'csq-expr)
(free-vars #'alt-expr)))]
[(#%app exprs ...)
(free-vars* (syntax->list #'(exprs ...)))]
[(let-values ([(f) rhs])
(#%app f-apply (with-continuation-mark ignore-key f-mark body-expr)))
;; (and (bound-identifier=? #'f #'f-apply) (bound-identifier=? #'f #'f-mark))
(union (free-vars #'rhs)
(set-diff (free-vars #'body-expr) (list #'f)))]
[(let-values ([(f) rhs]) (#%app f-apply body-expr))
(union (free-vars #'rhs)
(set-diff (free-vars #'body-expr) (list #'f)))]
[(lambda (formals ...) body-expr)
(set-diff (free-vars #'body-expr) (syntax->list #'(formals ...)))]
[(with-continuation-mark safe-call? b-val body-expr)
(free-vars #'body-expr)]
[(#%top . var) '()]
[(#%datum . var) '()]
[(quote datum) '()]
[var (identifier? #'var)
(let ([i-bdg (identifier-binding #'var)])
(cond
[(eqv? 'lexical (identifier-binding #'var))
(list #'var)]
[else '()]))]
[_else
(raise-syntax-error #f "free-vars: dropped through" expr)]))
;; free-vars*: (listof expr) -> (listof identifier)
;; union the free variables that occur in several expressions
(define (free-vars* exprs)
(foldl
(lambda (expr acc) (union (free-vars expr) acc))
'() exprs))
;; union: (listof identifier) (listof identifier) -> (listof identifier)
;; produce the set-theoretic union of two lists
(define (union l1 l2)
(cond
[(null? l1) l2]
[else (insert (car l1) (union (cdr l1) l2))]))
;; insert: symbol (listof identifier) -> (listof symbol)
;; insert a symbol into a list without creating a duplicate
(define (insert sym into)
(cond
[(null? into) (list sym)]
[(bound-identifier=? sym (car into)) into]
[else (cons (car into) (insert sym (cdr into)))]))
;; set-diff: (listof identifier) (listof identifier) -> (listof identifier)
;; produce the set-theoretic difference of two lists
(define (set-diff s1 s2)
(cond
[(null? s2) s1]
[else (set-diff (sans s1 (car s2)) (cdr s2))]))
;; sans: (listof identifier) symbol -> (listof identifier)
;; produce the list sans the symbol
(define (sans s elt)
(cond
[(null? s) '()]
[(bound-identifier=? (car s) elt)
(cdr s)] ;; if we maintain the no-dupe invariant then we don't need to recur
[else (cons (car s)
(sans (cdr s) elt))]))
)

347
collects/web-server/prototype-web-server/doc.txt Normal file
View File

@ -0,0 +1,347 @@
_prototype-web-server_
_Overview_
The prototype is intended to completely decouple the continuation mechanism
for servlets from the rest of the server. The prototype-server knows
nothing about continuations. Instead, the prototype-server provides a
simple session-based model akin to traditional CGI.
See prototype-web-server/servlets/add01.ss for an example session-based
servlet.
See Web Interactive Language, and Interactive Language for understanding
how continuations are used with the prototype-web-server.
_Configuring the prototype-server_
Eliminated the dependency on web-server/configuration.ss and simply
hard-coded the configuration in:
prototype-web-server/hardcoded-configuration.ss
_Running the prototype-server_
> serve
;; serve: -> -> void
;; start the server and return a thunk to shut it down.
_Loading Servlets_
Steps:
1. The URL is decoded. If the URL encodes a session-id, then the server
looks up the session in the session table. If the session structure is
found in the table, then the session-handler is called with the request
to generate the response. If no session is found an error page is
generated.
2. If the URL does not encode a session-id, then the servlet path is
resolved to find an executable (see path resolution.) If no executable
is found, an error page is generated.
3. If an executable is found a new session-structure is created. A unique
session-id is generated for the session and all subsequent requests for
this session should encode this id. A new custodian, new namespace, and
a default handler are created for the session. The simplified url-path
that located the servlet is used as the path in the session-url.
4. The servlet executable should be a module. The servlet is then invoked
via dynamic-require within the new session-namespace. During this
invocation, the servlet should make a call to start-session in order to
install the session handler for the servlet. After the module is
invoked, the session handler is called with the initial request.
_Path Resolution_
Steps:
1. The url-path is simplified:
(i) All path/params are removed from the url path and replaced with
their corresponding path/param-path.
(ii) Empty strings that show up as file names in the url-path are removed
from the path, so that e.g. a path that looks like "foo////bar"
would be simplified to "foo/bar".
(iii) All ".."'s are removed from the path by replacing them with 'up.
(iv) The path is simplified with respect to the root directory in order
to prevent path chasing. I.e. if surplus ".." pile up they are
discarded.
2. The path is appended to the servlet-path of the virtual-host that is
handling the request.
3. The shortest prefix of the path from step 2 that specifies a servlet
file is then computed. The resulting servlet file is the one.
4. The same prefix in step 3, but without the servlet-path part, is used
for the url-path in the session-url. The session-id will be encoded in
this path.
_Sessions_
_session.ss_
The prototype web-server creates a session each time a particular servlet
is loaded. A servlet is loaded when the URL specifying the servlets
filename does not encode a session id. A new namespace is created and
stored as part of the session. The servlet is then dynamic-required using
the new namespace. The module session.ss is attached to the servlets
namespace.
NOTE: The session is analogous to the "servlet-instance" in the current
web-server.
The servlet-writer should be aware of the following provides from
session.ss:
[struct session ([id number?]
[cust custodian?]
[namespace namespace?]
[handler (request? . -> . response?)]
[url url?])]
> session-id
A number that identifies the session. This number is encoded in the URL and
used by the server to lookup the correct session for an incoming
request. session-id's are encoded using a path/param.
> session-custodian
The custodian that manages the session.
NOTE: Sessions currently do NOT time out. Ultimately I will need to add a
timeout mechanism for sessions so that they don't pile up and consume
memory. This is the same as the servlet-timeout.
> session-namespace
The namespace in which the servlet runs.
NOTE: Each session gets its own namespace. It is presently NOT easy for two
sessions to share state.
REQUIREMENT: Need a mechanism for sessions to share state through a common
module. This includes sessions corresponding to different servlets.
> session-handler
The session handler consumes a request and produces a response. All
requests for the session go through the session handler. The
session-handler is installed via a call to start-session.
> session-url
The minimal url that refers to the servlet file. It is minimal in the sense
that the url-path is the shortest path that would resolve to the
servlet. This url-path also encodes the session id.
> current-session
This parameter is set by the web-server and stores the value of the current
session.
> lookup-session
(number? . -> . (union session? boolean?))
lookup-session is used internally by the web-server to lookup a session
once the session-id is decoded from the URL.
> new-session
(custodian? namespace? url? . -> . session?)
new-session is used internally by the web-server to create a new session
when a servlet is loaded.
> start-session
((request? . -> . response?) . -> . any)
start-session installs the session-handler for a servlets session. Start
session should be called by the servlet exactly once before any responses
are generated.
_utils.ss_
> split-url-path
;; url url -> (union (listof string) #f)
Useful when using the servlet-path to encode additional arguments to the
server. Servlet writers should use this to recover the suffix of the
url-path occurring after the servlet file.
> url->servlet-path
url->servlet-path: path url -> (values (union path #f)
(union (listof url->string) #f)
(union (listof string) #f))
Used by the server during servlet-path resolution.
> make-session-url
url (listof string) -> url
Used internally by the server to create the session-url when loading a
servlet.
_Interaction Language_
The interaction language creates a module with multiple interaction
points. The interaction point serves as a synchronization mechanism between
the module and the outside world. When an interaction point is encountered,
a response is generated by the module and then execution halts. Execution
may be resumed later when a request is passed to the module. The
interactive language, by itself does not restrict the number of times an
interaction point can be resumed.
The syntax of an interactive module is as follows:
program ::= definition* expr
definition ::= (define-values (var) expr)
expr ::= var
| (lambda (var ...) expr)
| (if expr expr)
| (if expr expr expr)
| (let-values ([(var)] expr) expr)
| (#%app expr ...)
| (#%datum . datum)
| (#%top . var)
| (begin expr ...)
NOTE: The body of the module (excluding requires) is first expanded to
core-mzscheme forms before execution.
NOTE: The interaction language is implemented using non-native
continuations. I.e. occurrences of call/cc within the program are replaced
by a new version when the module is expanded.
_Creating an Interactive Module_
An interactive module is created by specifying "interaction.ss" as the language
for a module.
Example:
(module my-module "interaction.ss"
...)
The writer of an interactive module may then specify interaction points
using the interface provided by interaction.ss
_interaction.ss_
> start-interaction
(request -> continuation) -> request
start-interaction establishes the initial interaction point for the
interactive module and registers a procedure to be used for decoding
requests. start-interaction stores the continuation of the call to
start-interaction. This continuation is resumed using the client interface
to the interactive module (see below.)
Example:
(module m01 "../interaction.ss"
(define (id x) x)
(+ (* 1 2) (* 3 4) (start-interaction id)))
> send/suspend
(continuation -> response) -> request
Captures the continuation of the call to send/suspend and passes this as
the argument to send/suspend. Execution then halts until the continuation
is resumed via the client interface to the interactive module (see below.)
_client.ss_
> dispatch-start
request -> response
Pass the initial request to the interactive module. After the module is
required, it should eventually make a call to start-interaction. After
start-interaction is called, execution will halt until dispatch-start is
called. When dispatch-start is called, the request is passed to the
continuation of the call to start-interaction. The response produced is the
response produced by the next interaction point of the module or, when no
subsequent interaction point is encountered, is the result of evaluating
the module's body expression.
> dispatch
request -> response
Resumes execution at the interaction point encoded in the request. When
dispatch is called, the request handler installed via the last call to
start-interaction is applied to the request, producing a continuation and
then the resulting continuation is applied to the request. The response
produced is the response produced by the next interaction point of the
module or, when no subsequent interaction point is encountered, is the
result of evaluating the module's body expression.
When only "one-shot" continuations are needed, make multiple calls to
start-interaction.
Example:
(module m02 "../interaction.ss"
(define (id x) x)
(+ (start-interaction id)
(start-interaction id)))
(require m02)
(void? (dispatch-start 1))
(= 3 (dispatch-start 2))
(= 0 (dispatch-start -1))
In the next example, send/suspend is used to establish re-usable
interaction points. An auxiliary module, table, is used to store
continuations so that they may be used multiple times. Keys are associated
with continuations in a hash table. The module body evaluates to a number,
while interaction points within the computation yield the continuation key
corresponding to that particular continuation. So a response is either a
number or a key. A request consists of a key paired with a number. The
initial request is ignored.
Example:
(module table mzscheme
(provide store-k
lookup-k)
(define the-table (make-hash-table))
;; store-k: continuation -> symbol
(define (store-k k)
(let ([key (string->symbol (symbol->string (gensym 'key)))])
(hash-table-put! the-table key k)
key))
;; lookup-key: (list symbol number) -> continuation
(define (lookup-k key-pair)
(hash-table-get the-table (car key-pair) (lambda () #f))))
(module m06 "../interaction.ss"
(require table)
;; gn: string -> number
;; Get a number from the client.
(define (gn which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
(store-k k))))))
;; get two numbers from the client and produce their sum
(let ([ignore (start-interaction lookup-k)])
(let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result))))
(require m06)
;; client code.
(let* ([first-key (dispatch-start 'foo)]
[second-key (dispatch `(,first-key 1))]
[third-key (dispatch `(,first-key -7))])
(values
(= 3 (dispatch `(,second-key 2)))
(= 4 (dispatch `(,second-key 3)))
(zero? (dispatch `(,second-key -1)))
(= -7 (dispatch `(,third-key 0)))
(zero? (dispatch `(,third-key 7)))))
_Web Interaction Language_
_web-interaction.ss_
Use this language for writing servlets.
> start-servlet
-> request
Set the initial interaction point for the servlet. This analogous to
start-interaction the request handler is built-in and decodes the
continuation-id from the URL. The return value of start-servlet is the
initial HTTP request.
> send/suspend
(url -> response) -> request
Send a response to the client and wait for the request. The continuation of
the call to send/suspend is encoded in the URL that is passed to the
argument of send/suspend. The argument should produce a request (usually an
xexpr).
See collects/prototype-web-server/servlets/
for examples of servlets written using the "web-interaction.ss" language.

122
collects/web-server/prototype-web-server/elim-call-cc.ss Normal file
View File

@ -0,0 +1,122 @@
(module elim-call-cc mzscheme
(require "syntax-utils.ss")
(require-for-template "abort-resume.ss" mzscheme)
(provide elim-call/cc-from-definition
elim-call/cc)
;; **************************************************
;; LANGUAGE
;;
;; program ::= definition* expr
;;
;; definition ::= (define-values (var) expr)
;;
;; expr ::= w
;; | (if w expr)
;; | (if w expr expr)
;; | (#%app w expr) ;where expr != w
;; | (#%app w w ...)
;; | (#%app call/cc w)
;;
;; w ::= var | (#%top . var) | value
;; value ::= (#%datum . datum)
;; | (lambda (var ...) expr)
;; id: alpha -> alpha
(define (id x) x)
;; elim-call/cc: expr -> expr
;; eliminate call/cc from an expression
(define (elim-call/cc expr)
(elim-call/cc/mark expr id))
;; elim-call/cc/mark: expr (expr -> expr) -> expr
;; eliminate call/cc from an expression given a mark frame function
(define (elim-call/cc/mark expr markit)
(syntax-case expr (if #%app call/cc #%top #%datum lambda quote)
[(if w e)
(with-syntax ([(w e) (recertify* (list #'w #'e) expr)])
(markit #`(if #,(elim-call/cc #'w) #,(elim-call/cc #'e))))]
[(if w e0 e1)
(with-syntax ([(w e0 e1) (recertify* (list #'w #'e0 #'e1) expr)])
(markit #`(if #,(elim-call/cc #'w)
#,(elim-call/cc #'e0)
#,(elim-call/cc #'e1))))]
[(#%app call/cc w)
(with-syntax ([w (recertify #'w expr)])
(let-values ([(cm ref-to-cm) (generate-formal 'current-marks)]
[(x ref-to-x) (generate-formal 'x)])
(markit #`(#%app #,(elim-call/cc #'w)
(#%app (lambda (#,cm)
(lambda (#,x)
(#%app abort
(lambda () (#%app resume #,ref-to-cm #,ref-to-x)))))
(#%app activation-record-list))))))]
;; this is (w e) where e is not a w. (w w) handled in next case.
;; m00.4 in persistent-interaction-tests.ss tests this distinction
[(#%app w (#%app . stuff))
(with-syntax ([e #'(#%app . stuff)])
(with-syntax ([(w e) (recertify* (list #'w #'e) expr)])
(syntax-case #'w (lambda)
[(lambda (formals ...) body)
(let ([w-prime (datum->syntax-object #f (gensym 'f))])
#`(let-values ([(#,w-prime) #,(elim-call/cc #'w)])
#,(markit
#`(#%app #,w-prime
#,(elim-call/cc/mark
#'e
(lambda (x)
#`(with-continuation-mark the-cont-key #,w-prime #,x)))))))]
[_else
(let ([w-prime (elim-call/cc #'w)])
(markit
#`(#%app #,w-prime
#,(elim-call/cc/mark
#'e
(lambda (x)
#`(with-continuation-mark the-cont-key #,w-prime #,x))))))])))]
[(#%app w rest ...)
(with-syntax ([(w rest ...) (recertify* (syntax->list #'(w rest ...)) expr)])
(markit
#`(with-continuation-mark safe-call? #f
(#%app #,(mark-lambda-as-safe (elim-call/cc #'w))
#,@(map
(lambda (an-expr)
(mark-lambda-as-safe
(elim-call/cc
an-expr)))
(syntax->list #'(rest ...)))))))]
[(#%top . var) expr]
[(#%datum . d) expr]
[(lambda (formals ...) body)
(with-syntax ([body (recertify #'body expr)])
#`(lambda (formals ...) #,(elim-call/cc #'body)))]
[(quote datum) expr]
[x (symbol? (syntax-object->datum #'x)) expr]
[_else
(raise-syntax-error #f "elim-call/cc/mark dropped through" expr)]))
;; elim-call/cc-from-definition: definition -> definition
;; produce a transformed defintion
(define (elim-call/cc-from-definition def)
(syntax-case def ()
[(define-values (var ...) expr)
#`(define-values (var ...) #,(mark-lambda-as-safe (elim-call/cc #'expr)))]
[else
(raise-syntax-error #f "elim-call/cc-from-definition dropped through" def)]))
;; mark-lambda-as-safe: w -> w
;; If w is a lambda-expression then add #t to the safety mark, otherwise no mark
(define (mark-lambda-as-safe w)
(syntax-case w (lambda)
[(lambda (formals ...) body)
#`(lambda (formals ...)
(with-continuation-mark safe-call? #t
body))]
[_else w]))
)

144
collects/web-server/prototype-web-server/elim-letrec.ss Normal file
View File

@ -0,0 +1,144 @@
(module elim-letrec mzscheme
(require "syntax-utils.ss")
(require-for-template "abort-resume.ss" mzscheme)
(provide elim-letrec
elim-letrec-from-definition)
;; **************************************************
;; SOURCE LANGUAGE
;;
;; program ::= definition* expr
;;
;; definition ::= (define-values (var ...) expr)
;;
;; expr ::= var
;; | (letrec-values ([(var) expr] ...) expr)
;; | (lambda (var ...) expr)
;; | (if expr expr)
;; | (if expr expr expr)
;; | (let-values ([(var ...)] expr) expr)
;; | (#%app expr ...)
;; | (#%datum . datum)
;; | (#%top . var)
;; | (begin expr ...)
;;
;; NOTES: (1) Assumes fully expanded code.
;; (2) For now just single vars on the RHS of a letrec values.
;; **************************************************
;; TARGET LANGUAGE
;;
;; program ::= definition* expr
;;
;; definition ::= (define-values (var ...) expr)
;;
;; expr ::= var
;; | (lambda (var ...) expr)
;; | (if expr expr)
;; | (if expr expr expr)
;; | (let-values ([(var ...)] expr) expr)
;; | (#%app expr ...)
;; | (#%datum . datum)
;; | (#%top . var)
;; | (begin expr ...)
;; elim-letrec-from-definition: definition -> expr
(define (elim-letrec-from-definition def)
(syntax-case def (define-values)
[(define-values (ids ...) body-expr)
#`(define-values (ids ...) #,(elim-letrec #'body-expr))]
[_else
(raise-syntax-error #f "elim-letrec-from-definition: dropped through" def)]))
;; elim-letrec: source-expr -> target-expr
;; eliminate all occurences of letrec-values from the source expression
(define (elim-letrec src-expr)
(elim-letrec/ids src-expr '()))
;; elim-letrec/ids: source-expr (listof identifier) -> target-expr
;; eliminate letrec-values and make substitutions for the indicated ids
;; substitute x ---> (unbox x), (set! x expr) (set-box! x expr)
(define (elim-letrec/ids expr ids)
(syntax-case expr (lambda letrec-values if let-values #%app #%datum #%top quote begin set!)
[(letrec-values ([(vars) rhss] ...) body-expr)
(with-syntax ([(body-expr rhss ...) (recertify* (syntax->list #'(body-expr rhss ...)) expr)])
(let ([ids (append (syntax->list #'(vars ...)) ids)])
(with-syntax ([(new-rhss ...)
(map
(lambda (rhs)
(elim-letrec/ids rhs ids))
(syntax->list #'(rhss ...)))]
[new-body (elim-letrec/ids #'body-expr ids)])
#`(let-values ([(vars ...) (#%app values
#,@(map
(lambda (x) #'(#%app box the-undef))
(syntax->list #'(vars ...))))])
(begin
(#%app set-box! vars new-rhss) ...
new-body)))))]
[(letrec-values . anything)
(raise-syntax-error #f "Not all letrec-values-expressions supported" expr)]
[(lambda (formals ...) body)
(with-syntax ([body (recertify #'body expr)])
#`(lambda (formals ...) #,(elim-letrec/ids #'body ids)))]
[(lambda . anything)
(raise-syntax-error #f "Not all lambda-expressions supported" expr)]
[(if tst-expr csq-expr)
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
#`(if #,(elim-letrec/ids #'tst-expr ids)
#,(elim-letrec/ids #'csq-expr ids)))]
[(if tst-expr csq-expr alt-expr)
(with-syntax ([(tst-expr csq-expr alt-expr) (recertify* (list #'tst-expr #'csq-expr #'alt-expr) expr)])
#`(if #,(elim-letrec/ids #'tst-expr ids)
#,(elim-letrec/ids #'csq-expr ids)
#,(elim-letrec/ids #'alt-expr ids)))]
[(let-values ([(varss ...) rhs-exprs] ...) body-exprs ...)
(with-syntax ([(rhs-exprs ...) (recertify* (syntax->list #'(rhs-exprs ...)) expr)]
[(body-exprs ...) (recertify* (syntax->list #'(body-exprs ...)) expr)])
(let ([elim-letrec* (lambda (an-expr) (elim-letrec/ids an-expr ids))])
(with-syntax ([(new-rhs-exprs ...)
(map elim-letrec* (syntax->list #'(rhs-exprs ...)))]
[(new-body-exprs ...)
(map elim-letrec* (syntax->list #'(body-exprs ...)))])
#`(let-values ([(varss ...) new-rhs-exprs] ...) new-body-exprs ...))))]
[(#%app expr-rator expr-rands ...)
(with-syntax ([(expr-rator expr-rands ...) (recertify* (syntax->list #'(expr-rator expr-rands ...)) expr)])
#`(#%app #,(elim-letrec/ids #'expr-rator ids)
#,@(map
(lambda (expr-rand)
(elim-letrec/ids expr-rand ids))
(syntax->list #'(expr-rands ...)))))]
[(set! id rhs-expr)
(with-syntax ([id (recertify #'id expr)])
(if (bound-identifier-member? #'id ids)
#`(#%app set-box! id #,(elim-letrec/ids #'rhs-expr ids))
#`(set! id #,(elim-letrec/ids #'rhs-expr ids))))]
[(#%datum . datum) expr]
[(#%top . var) expr]
[(begin rest-expr ...)
(with-syntax ([(rest-expr ...) (recertify* (syntax->list #'(rest-expr ...)) expr)])
#`(begin
#,@(map
(lambda (an-expr)
(elim-letrec/ids an-expr ids))
(syntax->list #'(rest-expr ...)))))]
[(quote datum) expr]
[id
(if (bound-identifier-member? #'id ids)
#'(#%app unbox id)
#'id)]
[_else
(raise-syntax-error #f "eliminate-letrec: unsupported form" expr)]))
(define myprint printf)
;; bound-identifier-member?: identifier (listof identifier) -> boolean
;; is the given identifier in the list according to bound-identifier=?
(define (bound-identifier-member? id ids)
(ormap
(lambda (an-id)
(bound-identifier=? id an-id))
ids))
)

90
collects/web-server/prototype-web-server/expander.ss Normal file
View File

@ -0,0 +1,90 @@
(module expander mzscheme
(require "abort-resume.ss")
(require-for-syntax (lib "kerncase.ss" "syntax")
"normalizer.ss"
"elim-call-cc.ss")
(provide lang-module-begin)
(provide (all-from "abort-resume.ss"))
;; lang-module-begin
;; Does the normal module-begin stuff, except it hands off all
;; module forms to a collect macro.
(define-syntax (lang-module-begin stx)
(syntax-case stx ()
[(_ form ...)
#`(#%plain-module-begin
;#,(datum->syntax-object stx '(require-for-syntax mzscheme))
(collect () (form ...)))]))
;; collect
;; (collect (def/expr ...) (module-form ...))
;; collect expands each module-form until it can recognize what kind of form it is.
;; If it's a define-syntaxes, require, require-for-syntax, or provide form,
;; it lets it "pass through" the collect macro to be executed by the primitive module
;; expander. If it's a define-values form, it expands the body and then reconstructs a
;; define-values form to put in the def/exprs list. If it's any other kind of form, it
;; fully expands the form and puts it on the def/exprs list.
;;
;; The fully expanded definitions and expressions are then passed (in the original
;; order) to the transform macro.
(define-syntax (collect stx)
(define (module-identifier-member id ids)
(cond [(null? ids) #f]
[(module-identifier=? id (car ids)) ids]
[else (module-identifier-member id (cdr ids))]))
(syntax-case stx ()
[(_ rev-def/exprs (form0 . forms))
(let ([expand-context (syntax-local-context)]
[stop-list (list*
#'require
#'require-for-syntax
#'provide
(kernel-form-identifier-list #'here))])
(let ([e-form0 (local-expand #'form0 expand-context stop-list)])
(syntax-case e-form0 (begin define-values)
[(keyword . _)
(and (identifier? #'keyword)
(module-identifier-member #'keyword
(list #'require #'require-for-syntax
#'provide #'define-syntaxes)))
#`(begin #,e-form0 (collect rev-def/exprs forms))]
[(begin e-form ...)
#`(collect rev-def/exprs (e-form ... . forms))]
[(define-values (id ...) expr)
(andmap identifier? (syntax->list #'(id ...)))
(let ([e-expr (local-expand #'expr 'expression (list #'#%top))])
#`(begin
(collect [(define-values (id ...) #,e-expr) . rev-def/exprs]
forms)))]
[expr
(let ([e-expr (local-expand #'expr 'expression (list #'#%top))])
#`(collect [#,e-expr . rev-def/exprs] forms))])))]
[(_ rev-def/exprs ())
(with-syntax ([(def/expr ...) (reverse (syntax->list #'rev-def/exprs))])
#'(transform () (def/expr ...)))]))
;; **********************************************************************
;; **********************************************************************
;; transform
;; This macro is where you put your transformations. Each def/expr is core mzscheme.
;; Furthermore, no def/expr is a define-syntaxes, require etc form.
(define-syntax (transform stx)
(syntax-case stx (define-values lambda)
[(_ rev-defs [(define-values (var) (lambda (formals ...) proc-body)) . rest])
#'(transform [(define-values (var) (lambda (formals ...) proc-body)) . rev-defs]
rest)]
[(_ rev-defs [body-expr])
#`(begin
#,@(map
(lambda (def)
(elim-call/cc-from-definition
(normalize-definition def)))
(reverse (syntax->list #'rev-defs)))
(abort/cc #,(elim-call/cc (normalize-term #'body-expr))))]
[(_ rev-defs [])
(raise-syntax-error #f "module has no body expression" stx)]
[_else
(raise-syntax-error #f "extra body expression, or expression out of order" stx)]))
)

86
collects/web-server/prototype-web-server/file-vector.ss Normal file
View File

@ -0,0 +1,86 @@
(module file-vector mzscheme
(require (lib "serialize.ss"))
(provide deserialize-info:file-vector
struct:file-vector
make-file-vector
file-vector?
file-vector-ref
file-vector-set!)
(define deserialize-info:file-vector
(make-deserialize-info
;; make-proc: symbol -> file-vector
(lambda (file-tag)
(let ([vals
(vector->list
(call-with-input-file (symbol->string file-tag)
(lambda (i-port)
(deserialize (read i-port)))))])
(apply make-file-vector (cons file-tag vals))))
;; cycle-make-proc: -> (values file-vector (file-vector -> void))
(lambda ()
(let ([new-file-vector
(make-file-vector #f #f)])
(values
new-file-vector
(lambda (fv)
(set-file-vector-tag! new-file-vector (file-vector-tag fv))
(set-file-vector-vec! new-file-vector (file-vector-vec fv))))))))
(define file-vector:serialize-info
(make-serialize-info
;; to-vector: file-vector -> (vectorof symbol)
(lambda (fv)
(call-with-output-file (symbol->string (file-vector-tag fv))
(lambda (o-port)
(write (serialize (file-vector-vec fv)) o-port))
'replace)
(make-vector 1 (file-vector-tag fv)))
;; The serializer id: --------------------
(syntax deserialize-info:file-vector)
;; can-cycle?
#t
;; Directory for last-ditch resolution --------------------
(or (current-load-relative-directory) (current-directory))))
(define-values (struct:file-vector make-file-vector file-vector? file-vector-ref file-vector-set!
file-vector-tag set-file-vector-tag!
file-vector-vec set-file-vector-vec!)
(let-values ([(struct:file-vector make-fv-struct file-vector? fv-struct-ref fv-struct-set!)
(make-struct-type 'struct:file-vector ;; the tag goes here
#f ; no super type
2
0 ; number of auto-fields
#f ; auto-v
; prop-vals:
(list (cons prop:serializable file-vector:serialize-info))
#f ; inspector
;; the struct apply proc:
#f)])
(values struct:file-vector
(lambda (tag . vals)
(make-fv-struct tag (list->vector vals)))
file-vector?
(lambda (fv n)
(vector-ref (fv-struct-ref fv 1) n))
(lambda (fv n val)
(vector-set! (fv-struct-ref fv 1) n val))
(lambda (fv)
(fv-struct-ref fv 0))
(lambda (fv new-tag)
(fv-struct-set! fv 0 new-tag))
(lambda (fv)
(fv-struct-ref fv 1))
(lambda (fv new-vec)
(fv-struct-set! fv 1 new-vec))))))

147
collects/web-server/prototype-web-server/hardcoded-configuration.ss Normal file
View File

@ -0,0 +1,147 @@
(module hardcoded-configuration mzscheme
(require (lib "configuration-structures.ss" "web-server")
(lib "util.ss" "web-server")
(lib "response.ss" "web-server"))
(provide config:port
config:max-waiting
config:listen-ip
config:initial-connection-timeout
config:virtual-hosts
)
;; ************************************************************
;; HARDCODED CONFIGURATION STUFF
(define config:port 8000)
(define config:max-waiting 20)
(define config:listen-ip #f)
(define config:initial-connection-timeout 30)
;; ************************************************************
;; HARDCODED HOST
; error-response : nat str str [(cons sym str) ...] -> response
; more here - cache files with a refresh option.
; The server should still start without the files there, so the
; configuration tool still runs. (Alternatively, find an work around.)
(define (error-response code short text-file . extra-headers)
(make-response/full code short
(current-seconds) TEXT/HTML-MIME-TYPE
extra-headers
(list (read-file text-file))))
; read-file : str -> str
(define (read-file path)
(call-with-input-file path
(lambda (in) (read-string (file-size path) in))))
;; error files:
(define server-root-path (build-path "~" "plt-exp" "collects" "web-server" "default-web-root"))
(define default-host-path (build-path server-root-path "conf"))
(define servlet-error-file (build-path default-host-path "servlet-error.html"))
(define access-denied-file (build-path default-host-path "forbidden.html"))
(define servlet-refresh-file (build-path default-host-path "servlet-refresh.html"))
(define password-refresh-file (build-path default-host-path "passwords-refresh.html"))
(define file-not-found-file (build-path default-host-path "not-found.html"))
(define protocol-file (build-path default-host-path "protocol-error.html"))
;; config:virtual-hosts: alpha -> host
;; return a default host structure
(define config:virtual-hosts
(let ([hardcoded-host
; host = (make-host (listof str) (str str sym url str -> str)
; passwords resopnders timeouts paths)
(make-host
;; indices
(list "index.html" "index.htm")
;; log-message
(lambda (str0 str1 sym0 url0 str2)
(error "log-message not implemented"))
;; passwords
'()
(make-responders
;; servlet: url tst -> response
(lambda (url exn)
; more here - use separate log file
;(printf "Servlet exception:\n~s\n" (exn-message exn))
((error-display-handler)
(format "Servlet exception:\n~a\n" (exn-message exn))
exn)
(error-response 500 "Servlet error" servlet-error-file))
;; servlet-loading: url tst -> response
; more here - parameterize error based on a configurable file, perhaps?
; This is slightly tricky since the (interesting) content comes from the exception.
(lambda (url exn)
((error-display-handler)
(format "Servlet loading exception:\n~a\n" (exn-message exn))
exn)
(make-response/full 500 "Servlet didn't load"
(current-seconds)
#"text/plain" ;TEXT/HTML-MIME-TYPE
'() ; check
(list "Servlet didn't load.\n"
(exn->string exn))))
;; authentication: url (cons sym str) -> response
(lambda (uri recommended-header)
(error-response 401 "Authorization Required" access-denied-file
recommended-header))
;; servlets-refreshed: -> response
(lambda ()
(error-response 200 "Servlet cache refreshed" servlet-refresh-file))
;; passwords-refreshed: -> response
(lambda ()
(error-response 200 "Passwords refreshed" password-refresh-file))
;; file-not-found: url->response
(lambda (url)
(error-response 404 "File not found" file-not-found-file))
;; protocol: string -> response
(lambda (error-message)
(error-response 400 "Malformed Request" protocol-file))
)
; timeouts = (make-timeouts nat^5)
(make-timeouts
; default-servlet-timeout
60
;password-connection-timeout
300
; servlet-connection-timeout
86400
; file-per-byte-connection-timeout
1/20
; file-base-connection-timeout
30)
; paths = (make-paths str^6)
(make-paths
; configuration-root
(build-path server-root-path "conf")
; host-root
(build-path server-root-path "default-web-root")
; log-file-path
"log"
; file-root
(build-path server-root-path "htdocs")
; servlet-root
(build-path "~" "plt-exp" "collects" "prototype-web-server" "servlets")
; password-authentication
(build-path server-root-path "passwords"))
)])
(lambda (ignore)
hardcoded-host)))
)

4
collects/web-server/prototype-web-server/info.ss Normal file
View File

@ -0,0 +1,4 @@
(module info (lib "infotab.ss" "setup")
(define name "Prototype Web Server")
(define doc.txt "doc.txt"))

7
collects/web-server/prototype-web-server/interaction.ss Normal file
View File

@ -0,0 +1,7 @@
(module interaction mzscheme
(require "expander.ss")
(provide (all-from-except mzscheme #%module-begin)
(rename lang-module-begin #%module-begin)
start-interaction
send/suspend)
)

92
collects/web-server/prototype-web-server/labels.ss Normal file
View File

@ -0,0 +1,92 @@
(module labels mzscheme
(require (lib "md5.ss")
(lib "etc.ss"))
(provide make-labeling
delete-tag-list!)
;; REQUIREMENT: The label code must be non-numeric.
;; REQUIREMENT: The first numeric character following the label code
;; indicates the start of the unique suffix identifying
;; the closure struct type.
;; add1/string: string -> string
;; a successor function on strings
(define (add1/string str)
(cond
[(regexp-match "$^" str)
=> (lambda (x) "b")]
[(regexp-match "z(.*)" str)
=> (lambda (m) (string-append "A" (cadr m)))]
[(regexp-match "Z(.*)" str)
=> (lambda (m) (string-append "a" (add1/string (cadr m))))]
[else
(format "~a~a"
(integer->char (add1 (char->integer (string-ref str 0))))
(substring str 1))]))
(define tag-file-path (this-expression-source-directory))
(define default-file-name ".tag-list")
(define file-system-mutex (make-semaphore 1))
;; read-tag-list: string -> (listof (list bytes string))
;; read the tag list from the file system
(define (read-tag-list filename)
(if (file-exists? (build-path tag-file-path filename))
(call-with-input-file (build-path tag-file-path filename)
read)
'()))
;; save-tag-list!: (listof (list bytes string)) string -> (listof (list bytes string))
;; save the tag list in the file system
(define (save-tag-list! new-list filename)
(call-with-output-file (build-path tag-file-path filename)
(lambda (o-port)
(write new-list o-port))
'replace))
;; delete-tag-list!: [filename] -> void
;; delete a file containing a tag-list
(define delete-tag-list!
(case-lambda
[(filename)
(when (file-exists? (build-path tag-file-path filename))
(delete-file (build-path tag-file-path filename)))]
[() (delete-tag-list! default-file-name)]))
;; lookup-tag: bytes string -> string
;; lookup a tag in the-tag-table
(define (lookup-tag pgm filename)
(let* ([the-tag-list (read-tag-list filename)]
[hash-code (md5 pgm)]
[new-tag
(if (null? the-tag-list) "a"
(add1/string (cadar the-tag-list)))])
(let loop ([l the-tag-list])
(cond
[(null? l)
(save-tag-list!
(cons (list hash-code new-tag)
the-tag-list)
filename)
new-tag]
[(bytes=? hash-code (caar l))
(cadar l)]
[else (loop (cdr l))]))))
;; make-labeling: bytes -> (-> symbol)
;; produce the labeling function for a particular program
(define make-labeling
(case-lambda
[(pgm) (make-labeling pgm default-file-name)]
[(pgm filename)
(dynamic-wind
(lambda () (semaphore-wait file-system-mutex))
(lambda ()
(let ([tag (lookup-tag pgm filename)]
[count 0])
(lambda ()
(begin0
(string->symbol (format "~a~a" tag count))
(set! count (add1 count))))))
(lambda () (semaphore-post file-system-mutex)))]))
)

161
collects/web-server/prototype-web-server/normalizer.ss Normal file
View File

@ -0,0 +1,161 @@
(module normalizer mzscheme
(require "syntax-utils.ss")
(require-for-template mzscheme)
(provide normalize-term
normalize-definition
)
;; **************************************************
;; SOURCE LANGUAGE
;;
;; program ::= definition* expr
;;
;; definition ::= (define-values (var ...) expr)
;;
;; expr ::= var
;; | (lambda (var ...) expr)
;; | (if expr expr)
;; | (if expr expr expr)
;; | (let-values ([(var)] expr) expr)
;; | (let-values ([(var ...)] expr) expr)
;; | (let-values ([(var ...)] expr) expr ...)
;; | (#%app expr ...)
;; | (#%datum . datum)
;; | (#%top . var)
;; | (begin expr ...)
;; | (values expr ...)
;; **************************************************
;; TARGET LANGUAGE
;;
;; program ::= definition* expr
;;
;; definition ::= (define-values (var ...) expr)
;;
;; expr ::= w | r | (#%app (lambda (var) expr) r)
;;
;; r ::= (if w expr)
;; | (if w expr expr)
;; | (#%app w w ...)
;;
;; w ::= var | (#%top . var) | value
;; value ::= (#%datum . datum)
;; | (lambda (var ...) expr)
;; **************************************************
;; **************************************************
;; id: alpha -> alpha
;; the identity function
(define (id x) x)
;; normalize-definition: definition -> expr
(define (normalize-definition def)
(syntax-case def (define-values)
[(define-values (ids ...) body-expr)
(with-syntax ([body-expr (recertify #'body-expr def)])
#`(define-values (ids ...) #,(normalize-term #'body-expr)))]
[_else
(raise-syntax-error #f "normalize-definition: dropped through" def)]))
;; normalize-term: source-expr -> target-expr
;; transform a term into an application chain
(define (normalize-term src-expr)
(normalize id src-expr))
;; normalize: (w -> target-expr) source-expr -> target-expr
;; normalize an expression given as a context and sub-expression
(define (normalize ctxt expr)
(syntax-case expr (lambda if let-values #%app #%datum #%top quote begin)
[(lambda (formals ...) body)
(with-syntax ([body (recertify #'body expr)])
(ctxt #`(lambda (formals ...) #,(normalize-term #'body))))]
[(lambda . anything)
(raise-syntax-error #f "Not all lambda-expressions supported" expr)]
[(if tst-expr csq-expr)
(with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
(normalize
(compose ctxt
(lambda (val)
#`(if #,val #,(normalize-term #'csq-expr))))
#'tst-expr))]
[(if tst-expr csq-expr alt-expr)
(with-syntax ([(tst-expr csq-expr alt-expr) (recertify* (list #'tst-expr #'csq-expr #'alt-expr) expr)])
(normalize
(compose ctxt
(lambda (val)
#`(if #,val
#,(normalize-term #'csq-expr)
#,(normalize-term #'alt-expr))))
#'tst-expr))]
[(let-values ([(var) rhs-expr]) body)
(with-syntax ([(rhs-expr body) (recertify* (list #'rhs-expr #'body) expr)])
(normalize ctxt #'(#%app (lambda (var) body) rhs-expr)))]
[(let-values ([(vars ...) rhs-expr]) body)
(with-syntax ([(rhs-expr body) (recertify* (list #'rhs-expr #'body) expr)])
(normalize ctxt #'(#%app call-with-values
(lambda () rhs-expr)
(lambda (vars ...) body))))]
[(let-values ([(vars ...) rhs-expr]) body-expr rest-body-exprs ...)
(with-syntax ([(rhs-expr body-expr rest-body-exprs ...)
(recertify* (syntax->list #'(rhs-expr body-expr rest-body-exprs ...)) expr)])
(normalize ctxt #'(let-values ([(vars ...) rhs-expr])
(let-values ([(throw-away) body-expr]) rest-body-exprs ...))))]
[(#%app expr-rator expr-rands ...)
(with-syntax ([(expr-rator expr-rands ...)
(recertify* (syntax->list #'(expr-rator expr-rands ...)) expr)])
(normalize
(lambda (val0)
(normalize*
(compose ctxt
(lambda (rest-vals)
#`(#%app #,val0 #,@rest-vals)))
(syntax->list #'(expr-rands ...))))
#'expr-rator))]
[(#%datum . datum) (ctxt expr)]
[(#%top . var) (ctxt expr)]
[(begin) (normalize ctxt #'(#%app (#%top . void)))]
[(begin last-expr)
(with-syntax ([last-expr (recertify #'last-expr expr)])
(normalize ctxt #'last-expr))]
[(begin first-expr rest-exprs ...)
(with-syntax ([(first-expr rest-exprs ...)
(recertify* (syntax->list #'(first-expr rest-exprs ...)) expr)])
(normalize ctxt #'(let-values ([(throw-away) first-expr])
(begin rest-exprs ...))))]
[(quote datum) (ctxt expr)]
[x (identifier? #'x)
(ctxt expr)]
[_else
(raise-syntax-error #f "normalize: unsupported form" expr)]))
;; normalize*: ((listof w) -> target-expr) (listof source-expr) -> target-expr
;; normalize an expression given as a context and list of sub-expressions
(define (normalize* multi-ctxt exprs)
(cond
[(null? exprs) (multi-ctxt '())]
[else
(normalize
(lambda (val)
(normalize*
(lambda (rest-vals)
(multi-ctxt (cons val rest-vals)))
(cdr exprs)))
(car exprs))]))
;; a context is either
;; frame
;; (compose context frame)
;; a frame is either
;; w -> target-redex
;; (listof w) -> target-redex
;; compose: (w -> target-expr) (alpha -> target-redex) -> (alpha -> target-expr)
;; compose a context with a frame
(define (compose ctxt frame)
(if (eq? ctxt id) frame
(lambda (val)
(let-values ([(x ref-to-x) (generate-formal 'x)])
#`(#%app (lambda (#,x) #,(ctxt ref-to-x)) #,(frame val))))))
)

123
collects/web-server/prototype-web-server/persistent-close.ss Normal file
View File

@ -0,0 +1,123 @@
(module persistent-close mzscheme
(require-for-template mzscheme)
(require-for-syntax (lib "kerncase.ss" "syntax"))
(require "file-vector.ss")
(provide close/file)
(define-for-syntax (index-of id ids)
(let loop ([idx 0] [ids ids])
(cond
[(null? ids) #f]
[(bound-identifier=? id (car ids)) idx]
[else (loop (add1 idx) (cdr ids))])))
;; replace/fvector-refs: id (listof id) expr -> expr
;; replace uses of id with appropriate file-vector refs
(define-for-syntax (replace/fvector-refs fvec-id ids expr)
(kernel-syntax-case expr #t
[(lambda formals body-exprs ...)
#`(lambda formals
#,@(map
(lambda (body-expr)
(replace/fvector-refs fvec-id ids body-expr))
(syntax->list #'(body-exprs ...))))]
[(case-lambda (formals bodiess ...) ...)
#`(case-lambda
#,@(map
(lambda (formal bodies)
(with-syntax ([(bodies ...) bodies])
#`(formal #,@(map
(lambda (body)
(replace/fvector-refs fvec-id ids body))
(syntax->list #'(bodies ...))))))
(syntax->list #'(formals ...))
(syntax->list #'((bodiess ...) ...))))]
[(if tst csq)
#`(if #,(replace/fvector-refs fvec-id ids #'tst)
#,(replace/fvector-refs fvec-id ids #'csq))]
[(if tst csq alt)
#`(if #,(replace/fvector-refs fvec-id ids #'tst)
#,(replace/fvector-refs fvec-id ids #'csq)
#,(replace/fvector-refs fvec-id ids #'alt))]
[(begin exprs ...)
#`(begin #,@(map
(lambda (expr)
(replace/fvector-refs fvec-id ids expr))
(syntax->list #'(exprs ...))))]
[(begin0 expr0 exprs ...)
#`(begin0 #,(replace/fvector-refs fvec-id ids #'expr0)
#,@(map
(lambda (expr)
(replace/fvector-refs fvec-id ids expr))
(syntax->list #'(exprs ...))))]
[(let-values (((varss ...) rhss) ...) exprs ...)
#`(let-values (#,(map
(lambda (vars rhs)
#`[#,vars #,(replace/fvector-refs fvec-id ids rhs)])
(syntax->list #'((varss ...) ...))
(syntax->list #'(rhss ...))))
#,@(map
(lambda (expr)
(replace/fvector-refs fvec-id ids expr)
(syntax->list #'(exprs ...)))))]
[(letrec-values (((varss ...) rhss) ...) exprs ...)
#`(letrec-values (#,(map
(lambda (vars rhs)
#`[#,vars #,(replace/fvector-refs fvec-id ids rhs)])
(syntax->list #'((varss ...) ...))
(syntax->list #'(rhss ...))))
#,@(map
(lambda (expr)
(replace/fvector-refs fvec-id ids expr))
(syntax->list #'(exprs ...))))]
[(set! var rhs)
(cond
[(index-of #'var ids)
=> (lambda (idx)
#`(file-vector-set! #,fvec-id #,idx #,(replace/fvector-refs fvec-id ids #'rhs)))]
[else
#`(set! var (replace/fvector-refs fvec-id ids #'rhs))])]
[(quote datum) expr]
[(quote-syntax datum) expr]
[(with-continuation-mark key val body)
#`(with-continuation-mark #,(replace/fvector-refs fvec-id ids #'key)
#,(replace/fvector-refs fvec-id ids #'val)
#,(replace/fvector-refs fvec-id ids #'body))]
[(#%app exprs ...)
#`(#%app #,@(map
(lambda (expr)
(replace/fvector-refs fvec-id ids expr))
(syntax->list #'(exprs ...))))]
[(#%datum . datum) expr]
[(#%top . variable) expr]
[var
(cond
[(index-of #'var ids)
=> (lambda (idx)
#`(file-vector-ref #,fvec-id #,idx))]
[else #'var])]))
;; (replace vector-expr (identifier ...) body-expr)
;; body-expr should be fully expanded.
(define-syntax (replace stx)
(syntax-case stx ()
[(_ fvec-expr (ids ...) body-exprs ...)
(with-syntax ([fvec (datum->syntax-object #'_ 'fvec)])
#`(let ([fvec fvec-expr])
#,@(map
(lambda (body-expr)
(replace/fvector-refs #'fvec (syntax->list #'(ids ...)) body-expr))
(syntax->list #'(body-exprs ...)))))]
[_else
(raise-syntax-error #f "replace: bad syntax" stx)]))
(define-syntax (close/file stx)
(syntax-case stx ()
[(_ file-tag (ids ...) body-exprs ...)
(syntax-case (local-expand #'(let-values ([(ids ...) (values ids ...)]) body-exprs ...)
'expression '()) (#%app)
[(let-values ([(ids ...) (#%app values ref-vals ...)]) new-body-exprs ...)
#'(replace (make-file-vector file-tag ref-vals ...) (ids ...) new-body-exprs ...)])]
[_else
(raise-syntax-error #f "close/file: bad syntax" stx)])))

115
collects/web-server/prototype-web-server/persistent-expander.ss Normal file
View File

@ -0,0 +1,115 @@
(module persistent-expander mzscheme
(require "abort-resume.ss")
(require-for-syntax (lib "kerncase.ss" "syntax")
(lib "list.ss")
"labels.ss"
"elim-letrec.ss"
"normalizer.ss"
"elim-call-cc.ss"
"defunctionalize.ss")
(provide lang-module-begin)
(provide (all-from "abort-resume.ss"))
;; lang-module-begin
;; Does the normal module-begin stuff, except it hands off all
;; module forms to a collect macro.
(define-syntax (lang-module-begin stx)
(syntax-case stx ()
[(_ form ...)
#`(#%plain-module-begin
;#,(datum->syntax-object stx '(require-for-syntax mzscheme))
(collect () (form ...)))]))
;; collect
;; (collect (def/expr ...) (module-form ...))
;; collect expands each module-form until it can recognize what kind of form it is.
;; If it's a define-syntaxes, require, require-for-syntax, or provide form,
;; it lets it "pass through" the collect macro to be executed by the primitive module
;; expander. If it's a define-values form, it expands the body and then reconstructs a
;; define-values form to put in the def/exprs list. If it's any other kind of form, it
;; fully expands the form and puts it on the def/exprs list.
;;
;; The fully expanded definitions and expressions are then passed (in the original
;; order) to the transform macro.
(define-syntax (collect stx)
(define (module-identifier-member id ids)
(cond [(null? ids) #f]
[(module-identifier=? id (car ids)) ids]
[else (module-identifier-member id (cdr ids))]))
(syntax-case stx ()
[(_ rev-def/exprs (form0 . forms))
(let ([expand-context (syntax-local-context)]
[stop-list (list*
#'require
#'require-for-syntax
#'provide
(kernel-form-identifier-list #'here))])
(let ([e-form0 (local-expand #'form0 expand-context stop-list)])
(syntax-case e-form0 (begin define-values)
[(keyword . _)
(and (identifier? #'keyword)
(module-identifier-member #'keyword
(list #'require #'require-for-syntax
#'provide #'define-syntaxes)))
#`(begin #,e-form0 (collect rev-def/exprs forms))]
[(begin e-form ...)
#`(collect rev-def/exprs (e-form ... . forms))]
[(define-values (id ...) expr)
(andmap identifier? (syntax->list #'(id ...)))
(let ([e-expr (local-expand #'expr 'expression (list #'#%top))])
#`(begin
(collect [(define-values (id ...) #,e-expr) . rev-def/exprs]
forms)))]
[expr
(let ([e-expr (local-expand #'expr 'expression (list #'#%top))])
#`(collect [#,e-expr . rev-def/exprs] forms))])))]
[(_ rev-def/exprs ())
(with-syntax ([(def/expr ...) (reverse (syntax->list #'rev-def/exprs))])
#'(transform () (def/expr ...)))]))
;; **********************************************************************
;; **********************************************************************
; (define-for-syntax myprint printf)
;; transform
;; This macro is where you put your transformations. Each def/expr is core mzscheme.
;; Furthermore, no def/expr is a define-syntaxes, require etc form.
(define-syntax (transform stx)
(syntax-case stx (define-values lambda)
[(_ rev-defs [(define-values (var) (lambda (formals ...) proc-body)) . rest])
#'(transform [(define-values (var) (lambda (formals ...) proc-body)) . rev-defs]
rest)]
[(_ rev-defs [body-expr])
(let* ([base-labeling (make-labeling (string->bytes/utf-8 (format "~a" (syntax-object->datum stx))))]
[make-labeler (lambda (tag)
(lambda ()
(datum->syntax-object tag (base-labeling))))])
(let ([new-defs (foldl
(lambda (first rest)
(append
(defunctionalize-definition
(elim-call/cc-from-definition
(normalize-definition
(elim-letrec-from-definition first)))
(make-labeler first))
rest))
'()
(syntax->list #'rev-defs))])
(let-values ([(new-body-expr body-defs)
(defunctionalize
(elim-call/cc
(normalize-term
(elim-letrec #'body-expr)))
(make-labeler #'body-expr))])
#`(begin
#,@new-defs
#,@body-defs
(abort/cc #,new-body-expr)))))]
[(_ rev-defs [])
(raise-syntax-error #f "module has no body expression" stx)]
[_else
(raise-syntax-error #f "extra body expression, or expression out of order" stx)]))
)

7
collects/web-server/prototype-web-server/persistent-interaction.ss Normal file
View File

@ -0,0 +1,7 @@
(module persistent-interaction mzscheme
(require "persistent-expander.ss")
(provide (all-from-except mzscheme #%module-begin)
(rename lang-module-begin #%module-begin)
start-interaction
send/suspend)
)

66
collects/web-server/prototype-web-server/persistent-web-interaction.ss Normal file
View File

@ -0,0 +1,66 @@
(module persistent-web-interaction mzscheme
(require (rename "persistent-expander.ss" send/suspend0 send/suspend)
(all-except "persistent-expander.ss" send/suspend)
"session.ss"
"stuff-url.ss"
(lib "servlet-helpers.ss" "web-server")
(lib "serialize.ss")
(lib "url.ss" "net")
)
(provide (all-from-except mzscheme #%module-begin)
(rename lang-module-begin #%module-begin)
send/suspend/hidden
send/suspend/url
start-servlet)
;; start-servlet: -> request
;; set the initial interaction point for the servlet
(define (start-servlet)
(start-session dispatch)
(start-interaction
(lambda (req)
(or (request->continuation req)
(lambda (req) (dispatch-start req))))))
;; send/suspend/hidden: (url input-field -> response) -> request
;; like send/suspend except the continuation is encoded in a hidden field
(define (send/suspend/hidden page-maker)
(send/suspend0
(lambda (k)
(let ([p-cont (serialize k)])
(page-maker
(session-url (current-session))
`(input ([type "hidden"][name "kont"][value ,(format "~s" p-cont)])))))))
;; send/suspend/url: (url -> response) -> request
;; like send/suspend except the continuation is encoded in the url
(define (send/suspend/url page-maker)
(let ([ses (current-session)])
(send/suspend0
(lambda (k)
(page-maker
(stuff-url (serialize k)
(session-url ses)
(session-mod-path ses)))))))
;; request->continuation: req -> continuation
;; decode the continuation from the hidden field of a request
(define (request->continuation req)
(or
(let* ([ses (current-session)]
[req-url (request-uri req)]
[qry (url-query req-url)]
[l-code (find-binding 'c qry)])
(and l-code
(deserialize
(unstuff-url
req-url (session-url ses)
(session-mod-path ses)))))
(let ([bdgs (request-bindings req)])
(and (exists-binding? 'kont bdgs)
(deserialize
(read
(open-input-string
(extract-binding/single 'kont bdgs))))))))
)

303
collects/web-server/prototype-web-server/server.ss Normal file
View File

@ -0,0 +1,303 @@
(module server mzscheme
(require (lib "connection-manager.ss" "web-server")
(lib "request-parsing.ss" "web-server")
(lib "response.ss" "web-server")
;(lib "util.ss" "web-server")
(lib "url.ss" "net")
(lib "string.ss")
(lib "list.ss")
(lib "configuration-structures.ss" "web-server")
"utils.ss"
"hardcoded-configuration.ss"
"session.ss"
)
(provide serve)
(define myprint printf)
(define thread-connection-state (make-thread-cell #f))
(define-struct connection-state (conn req))
(define top-cust (current-custodian))
;; ************************************************************
;; serve: -> -> void
;; start the server and return a thunk to shut it down
(define (serve . port)
(let ([the-server-custodian (make-custodian)])
(start-connection-manager the-server-custodian)
(parameterize ([current-custodian the-server-custodian])
(let ([get-ports
(let ([listener (tcp-listen (if (not (null? port))
(car port)
config:port)
config:max-waiting
#t config:listen-ip)])
(lambda () (tcp-accept listener)))])
(thread
(lambda ()
(server-loop get-ports)))))
(lambda ()
(custodian-shutdown-all the-server-custodian))))
;; ************************************************************
;; server-loop: (-> i-port o-port) -> void
;; start a thread to handle each incoming connection
(define (server-loop get-ports)
(let loop ()
(let ([connection-cust (make-custodian)])
(parameterize ([current-custodian connection-cust])
(let-values ([(ip op) (get-ports)])
(thread
(lambda ()
(serve-connection
(new-connection config:initial-connection-timeout
ip op (current-custodian) #f)))))))
(loop)))
;; ************************************************************
;; serve-connection: connection -> void
;; respond to all requests on this connection
(define (serve-connection conn)
(myprint "serve-connection~n")
(let connection-loop ()
(let-values ([(req close?) (read-request (connection-i-port conn))])
(let* ([host (get-host (request-uri req) (request-headers req))]
[host-conf (config:virtual-hosts host)])
(set-connection-close?! conn close?)
(dispatch conn req host-conf)
(adjust-connection-timeout! conn config:initial-connection-timeout)
; TODO: track down bus-error here
; 1. uncomment next line
; 2. comment-out cond expression
; 3. use error-servlet01.ss
;; TODO: while I think of it. The session object needs
;; to be guarded by a mutex.
;(kill-connection! conn)
(cond
[close? (kill-connection! conn)]
[else (connection-loop)])))))
;; get-host : Url (listof (cons Symbol String)) -> String
;; host names are case insesitive---Internet RFC 1034
(define DEFAULT-HOST-NAME "<none>")
(define (get-host uri headers)
(let ([lower!
(lambda (s)
(string-lowercase! s #;(bytes->string/utf-8 s))
s)])
(cond
[(url-host uri) => lower!]
[(assq 'host headers)
=>
(lambda (h) (lower! (bytes->string/utf-8 (cdr h))))]
[else DEFAULT-HOST-NAME])))
;; ************************************************************
;; dispatch: connection request host -> void
;; trivial dispatcher
(define (dispatch conn req host-info)
(myprint "dispatch~n")
(adjust-connection-timeout!
conn
(timeouts-servlet-connection (host-timeouts host-info)))
;; more here - make timeouts proportional to size of bindings
(servlet-content-producer conn req host-info))
;; ************************************************************
;; ************************************************************
;; SERVING SERVLETS
;; servlet-content-producer: connection request host -> void
(define (servlet-content-producer conn req host-info)
(myprint "servlet-content-producer~n")
(let ([meth (request-method req)])
(if (eq? meth 'head)
(output-response/method
conn
(make-response/full
200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE
'() (list "ignored"))
meth)
(let ([uri (request-uri req)])
(set-request-bindings!
req
(read-bindings/handled conn meth uri (request-headers req)
host-info))
(thread-cell-set! thread-connection-state
(make-connection-state conn req))
(with-handlers ([void
(lambda (the-exn)
(output-response/method
(connection-state-conn (thread-cell-ref thread-connection-state))
((responders-servlet-loading (host-responders host-info))
uri the-exn)
(request-method
(connection-state-req
(thread-cell-ref thread-connection-state)))))])
(cond
[(resume-session? uri)
=> (lambda (session-id)
(resume-session session-id host-info))]
[else
(begin-session host-info)]))))))
;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
;; read the bindings and handle any exceptions
(define (read-bindings/handled conn meth uri headers host-info)
(with-handlers ([exn? (lambda (e)
(output-response/method
conn
;((responders-protocol (host-responders host-info))
; (exn-message e))
((responders-servlet-loading (host-responders
host-info))
uri e)
meth)
'())])
(read-bindings conn meth uri headers)))
;; Parameter Parsing
;; old style: ;id15*0
;(define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*(.*)"))
;; encodes a simple number:
(define URL-PARAMS:REGEXP (regexp "[0-9]*"))
(define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
;; resume-session? url -> (union number #f)
;; Determine if the url encodes a session-id and extract it
(define (resume-session? a-url)
(myprint "resume-session?: url-string = ~s~n" (url->string a-url))
(let ([str (url->param a-url)])
(and str
(let ([param-match (match-url-params str)])
(and (not (null? param-match))
(string->number (car param-match)))))))
;; url->param: url -> (union string #f)
(define (url->param a-url)
(let ([l (filter path/param? (url-path a-url))])
(and (not (null? l))
(path/param-param (car l)))))
;(resume-session? (string->url "http://localhost:9000/;123"))
;(resume-session? (string->url "http://localhost:9000/;foo"))
;(resume-session? (string->url "http://localhost:9000/foo/bar"))
;; ************************************************************
;; directory-part: path -> path
(define (directory-part a-path)
(let-values ([(base name must-be-dir?) (split-path a-path)])
base))
;; begin-session: connection request host-info
(define (begin-session host-info)
(myprint "begin-session~n")
(let ([uri (request-uri (connection-state-req (thread-cell-ref thread-connection-state)))])
(let-values ([(a-path url-servlet-path url-path-suffix)
(url->servlet-path
(paths-servlet (host-paths host-info))
uri)])
(myprint "a-path = ~s~n" a-path)
(if a-path
(parameterize ([current-directory (directory-part a-path)])
(let* ([cust (make-custodian top-cust)]
[ns (make-servlet-namespace)]
[ses (new-session cust ns (make-session-url uri url-servlet-path) a-path)])
(parameterize ([current-custodian cust]
[current-namespace ns]
[current-session ses])
(let* ([module-name `(file ,(path->string a-path))])
(dynamic-require module-name #f)))
(resume-session (session-id ses) host-info)))
(output-response/method
(connection-state-conn (thread-cell-ref thread-connection-state))
((responders-file-not-found (host-responders host-info)) uri)
(request-method (connection-state-req (thread-cell-ref thread-connection-state))))))))
(define to-be-copied-module-specs
'(mzscheme
(lib "session.ss" "prototype-web-server")
(lib "request-parsing.ss" "web-server")))
;; get the names of those modules.
(define to-be-copied-module-names
(let ([get-name
(lambda (spec)
(if (symbol? spec)
spec
((current-module-name-resolver) spec #f #f)))])
(map get-name to-be-copied-module-specs)))
(define (make-servlet-namespace)
(let ([server-namespace (current-namespace)]
[new-namespace (make-namespace)])
(parameterize ([current-namespace new-namespace])
(for-each (lambda (name) (namespace-attach-module server-namespace name))
to-be-copied-module-names)
new-namespace)))
;; ripped this off from url-unit.ss
(define (url-path->string strs)
(apply
string-append
(let loop ([strs strs])
(cond
[(null? strs) '()]
[else (list* "/"
(maybe-join-params (car strs))
(loop (cdr strs)))]))))
;; needs to unquote things!
(define (maybe-join-params s)
(cond
[(string? s) s]
[else (path/param-path s)]))
;; ************************************************************
;; resume-session: connection request number host-info
(define (resume-session ses-id host-info)
(myprint "resume-session: ses-id = ~s~n" ses-id)
(cond
[(lookup-session ses-id)
=> (lambda (ses)
(parameterize ([current-custodian (session-cust ses)]
[current-session ses])
(with-handlers ([void
(lambda (the-exn)
(output-response/method
(connection-state-conn (thread-cell-ref thread-connection-state))
((responders-servlet (host-responders host-info))
(request-uri
(connection-state-req
(thread-cell-ref thread-connection-state)))
the-exn)
(request-method
(connection-state-req (thread-cell-ref thread-connection-state)))))])
(output-response
(connection-state-conn (thread-cell-ref thread-connection-state))
((session-handler ses)
(connection-state-req (thread-cell-ref thread-connection-state)))))))]
[else
;; TODO: should just start a new session here.
(output-response/method
(connection-state-conn (thread-cell-ref thread-connection-state))
((responders-file-not-found (host-responders host-info))
(request-uri (connection-state-req (thread-cell-ref thread-connection-state))))
(request-method
(connection-state-req (thread-cell-ref thread-connection-state))))]))
)

42
collects/web-server/prototype-web-server/servlets/add01.ss Normal file
View File

@ -0,0 +1,42 @@
(module add01 mzscheme
(require (lib "session.ss" "prototype-web-server")
(lib "request-parsing.ss" "web-server")
(lib "url.ss" "net")
)
(define (dispatch req)
(let* ([uri (request-uri req)]
[qry (url-query uri)])
(cond
[(assoc 'second qry)
=> (lambda (a-pair)
`(html (head (title "Answer Page"))
(body
(h1 "Answer Page")
(p ,(format "The answer is: ~a"
(+ (string->number (cdr a-pair))
(string->number (cdr (assoc 'first qry)))))))))]
[(assoc 'first qry)
=> (lambda (a-pair)
`(html (head (title "Second Page"))
(body
(h1 "Second Page")
(form ([action ,(url->string uri)]
[method "get"] [enctype "application/x-www-form-urlencoded"])
"Enter the second number to add: "
(input ([type "hidden"] [name "first"] [value ,(cdr a-pair)]))
(input ([type "text"] [name "second"] [value ""]))
(input ([type "submit"] [name "enter"] [value "Enter"]))))))]
[else
`(html (head (title "Hello"))
(body
(h1 "Hello World!")
(form ([action ,(url->string (session-url (current-session)))]
[method "get"] [enctype "application/x-www-form-urlencoded"])
"Enter the first number to add: "
(input ([type "text"] [name "first"] [value ""]))
(input ([type "submit"] [name "enter"] [value "Enter"])))))])))
(start-session dispatch))

29
collects/web-server/prototype-web-server/servlets/add02.ss Normal file
View File

@ -0,0 +1,29 @@
(module add02 "../web-interaction.ss"
(require (lib "url.ss" "net")
(lib "request-parsing.ss" "web-server"))
;; get-number-from-user: string -> number
;; ask the user for a number
(define (gn msg)
(let ([req
(send/suspend
(lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "get"]
[enctype "application/x-www-form-urlencoded"])
,(format "Enter the ~a number to add: " msg)
(input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"])))))))])
(string->number
(cdr (assoc 'number (url-query (request-uri req)))))))
(let ([initial-request (start-servlet)])
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(+ (gn "first") (gn "second")))))))
)

31
collects/web-server/prototype-web-server/servlets/add03.ss Normal file
View File

@ -0,0 +1,31 @@
(module add03 "../persistent-web-interaction.ss"
(require (lib "url.ss" "net")
(lib "servlet-helpers.ss" "web-server"))
;; get-number-from-user: string -> number
;; ask the user for a number
(define (gn msg)
(let ([req
(send/suspend/hidden
(lambda (ses-url k-hidden)
`(hmtl (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string ses-url)]
[method "post"]
[enctype "application/x-www-form-urlencoded"])
,(format "Enter the ~a number to add: " msg)
(input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"]))
,k-hidden)))))])
(string->number
(extract-binding/single
'number
(request-bindings req)))))
(let ([initial-request (start-servlet)])
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(+ (gn "first") (gn "second")))))))
)

30
collects/web-server/prototype-web-server/servlets/add04.ss Normal file
View File

@ -0,0 +1,30 @@
(module add04 (lib "persistent-web-interaction.ss" "prototype-web-server")
(require (lib "url.ss" "net")
(lib "servlet-helpers.ss" "web-server"))
;; get-number-from-user: string -> number
;; ask the user for a number
(define (gn msg)
(let ([req
(send/suspend/url
(lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "post"]
[enctype "application/x-www-form-urlencoded"])
,(format "Enter the ~a number to add: " msg)
(input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"])))))))])
(string->number
(extract-binding/single
'number
(request-bindings req)))))
(let ([initial-request (start-servlet)])
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(+ (gn "first") (gn "second")))))))
)

16
collects/web-server/prototype-web-server/servlets/check-dir.ss Normal file
View File

@ -0,0 +1,16 @@
(module check-dir "../web-interaction.ss"
(require (lib "url.ss" "net"))
(define (directory-page n)
(let ([throw-away
(send/suspend
(lambda (k-url)
`(html (head (title ,(format "Page ~a" n)))
(body
(h1 ,(format "Page ~a" n))
(h2 ,(format "The current directory: ~a" (current-directory)))
(p "Click " (a ([href ,(url->string k-url)]) "here") " to continue.")))))])
(directory-page (add1 n))))
(let ([req0 (start-servlet)])
(directory-page 1)))

90
collects/web-server/prototype-web-server/servlets/quiz-lib.ss Normal file
View File

@ -0,0 +1,90 @@
(module quiz-lib mzscheme
(require (lib "serialize.ss")
(lib "url.ss" "net")
)
(provide (struct mc-question (cue answers correct-answer))
make-cue-page
quiz)
(define-serializable-struct mc-question (cue answers correct-answer))
;; answer-rows: mc-question -> (listof `(tr ...))
;; format the answers as rows for an html table
(define (answer-rows mc-q)
(let loop ([i 0] [ans-strs (mc-question-answers mc-q)])
(cond
[(null? ans-strs) '()]
[else
(cons `(tr (td (input ([type "radio"]
[name "answs"]
[value ,(number->string i)])
,(car ans-strs))))
(loop (add1 i) (cdr ans-strs)))])))
;; make-cue-page: mc-question -> url hidden-field -> html-page
;; generate the page for the question
(define (make-cue-page mc-q)
(lambda (ses-url k-hidden)
`(hmtl (head (title "Question"))
(body
(form ([action ,(url->string ses-url)] [method "post"]
[enctype "application/x-www-form-urlencoded"])
,(mc-question-cue mc-q)
(table () ,@(answer-rows mc-q))
(input ([type "submit"]))
,k-hidden)))))
(define quiz
(list
(make-mc-question
"How old is the earth?"
(list
"6004 years"
"4.55 billion years"
"200,000 years")
1)
(make-mc-question
"Do bears like honey?"
(list "yes" "no")
0)
(make-mc-question
"How tall is the empire state building?"
(list "1,206 feet"
"511 meters"
"1,454 feet"
"107 floors")
2)
(make-mc-question
"What is the ultimate answer?"
(list "10" "true" "64" "42")
3)
(make-mc-question
"Where do babies come from?"
(list
"The cabbage patch"
"The stork"
"A watermelon seed"
"Wal-Mart")
1)
(make-mc-question
"Who was the first president of the United States?"
(list
"Thomas Jefferson"
"Theodore Roosevelt"
"George Washington"
"Douglas Fairbanks"
"John Adams"
)
2)
(make-mc-question
"What makes the world go 'round?"
(list
"money"
"love"
"angular momentum"
"sex")
0)
))
)

46
collects/web-server/prototype-web-server/servlets/quiz01.ss Normal file
View File

@ -0,0 +1,46 @@
(module quiz01 (lib "persistent-web-interaction.ss" "prototype-web-server")
(require "quiz-lib.ss"
(lib "url.ss" "net")
(lib "servlet-helpers.ss" "web-server"))
;; get-answer: mc-question -> number
;; get an answer for a multiple choice question
(define (get-answer mc-q)
(let* ([req
(send/suspend/hidden (make-cue-page mc-q))]
[bdgs (request-bindings req)])
(if (exists-binding? 'answs bdgs)
(string->number
(extract-binding/single
'answs bdgs))
-1)))
;; get-answers: (listof mc-question) -> (listof number)
;; get answers for all of the quiz questions.
(define (get-answers mc-qs)
(cond
[(null? mc-qs) '()]
[else
(cons
(get-answer (car mc-qs))
(get-answers (cdr mc-qs)))]))
;; tally-results: (listof mc-question) (listof number) -> number
;; count the number of correct answers
(define (tally-results mc-qs answs)
(cond
[(null? mc-qs) 0]
[(= (car answs)
(mc-question-correct-answer (car mc-qs)))
(add1 (tally-results (cdr mc-qs) (cdr answs)))]
[else (tally-results (cdr mc-qs) (cdr answs))]))
(let ([initial-request (start-servlet)])
`(html (head (title "Final Page"))
(body
(h1 "Quiz Results")
(p ,(format "You got ~a correct out of ~a questions."
(tally-results quiz (get-answers quiz))
(length quiz)))
(p "Thank you for taking the quiz"))))
)

45
collects/web-server/prototype-web-server/servlets/quiz02.ss Normal file
View File

@ -0,0 +1,45 @@
(module quiz02 (lib "persistent-web-interaction.ss" "prototype-web-server")
(require "quiz-lib.ss"
(lib "servlet-helpers.ss" "web-server"))
;; get-answer: mc-question -> number
;; get an answer for a multiple choice question
(define (get-answer mc-q)
(let* ([req
(send/suspend/hidden (make-cue-page mc-q))]
[bdgs (request-bindings req)])
(if (exists-binding? 'answs bdgs)
(string->number
(extract-binding/single
'answs bdgs))
-1)))
;; get-answers: (-> (listof mc-question)) -> (listof number)
;; get answers for all of the quiz questions.
(define (get-answers get-mc-qs)
(cond
[(null? (get-mc-qs)) '()]
[else
(cons
(get-answer (car (get-mc-qs)))
(get-answers (lambda () (cdr (get-mc-qs)))))]))
;; tally-results: (listof mc-question) (listof number) -> number
;; count the number of correct answers
(define (tally-results mc-qs answs)
(cond
[(null? mc-qs) 0]
[(= (car answs)
(mc-question-correct-answer (car mc-qs)))
(add1 (tally-results (cdr mc-qs) (cdr answs)))]
[else (tally-results (cdr mc-qs) (cdr answs))]))
(let ([initial-request (start-servlet)])
`(html (head (title "Final Page"))
(body
(h1 "Quiz Results")
(p ,(format "You got ~a correct out of ~a questions."
(tally-results quiz (get-answers (lambda () quiz)))
(length quiz)))
(p "Thank you for taking the quiz"))))
)

98
collects/web-server/prototype-web-server/session.ss Normal file
View File

@ -0,0 +1,98 @@
(module session mzscheme
(require (lib "contract.ss")
(lib "url.ss" "net")
(lib "request-parsing.ss" "web-server")
(lib "response.ss" "web-server"))
(require-for-syntax (lib "url.ss" "net"))
(provide current-session)
(define-struct session (id cust namespace handler url mod-path))
(provide/contract
[struct session ([id number?]
[cust custodian?]
[namespace namespace?]
[handler (request? . -> . response?)]
[url url?]
[mod-path path?])]
[lookup-session (number? . -> . (union session? boolean?))]
[new-session (custodian? namespace? url? path? . -> . session?)]
[start-session ((request? . -> . response?) . -> . any)])
(define current-session (make-parameter #f))
;; new-session-id: -> number
(define new-session-id
(let ([ses-id 0])
(lambda ()
(set! ses-id (add1 ses-id))
ses-id)))
(define the-session-table (make-hash-table))
;; new-session: namespace path -> session
(define (new-session cust ns uri mod-path)
(let ([new-id (new-session-id)])
(make-session
new-id
cust
ns
(lambda (req) (error "session not initialized"))
(encode-session uri new-id)
mod-path)))
;; start-session: (request -> response) -> void
;; register the session handler.
(define (start-session handler)
(let ([ses (current-session)])
(let ([params (current-parameterization)])
(set-session-handler!
ses
(lambda (req)
(call-with-parameterization params (lambda () (handler req))))))
(hash-table-put! the-session-table (session-id ses) ses)))
;; lookup-session: number -> (union session #f)
(define (lookup-session ses-id)
(hash-table-get the-session-table ses-id (lambda () #f)))
;; encode-session: url number -> url
(define (encode-session a-url ses-id)
(insert-param a-url (number->string ses-id)))
;; insert-param: url string -> string
;; add a path/param to the path in a url
;; (assumes that there is only one path/param)
(define (insert-param in-url new-param-str)
(replace-path
(lambda (old-path)
(if (null? old-path)
(list (make-path/param "" new-param-str))
(let* ([car-old-path (car old-path)])
(cons (make-path/param (if (path/param? car-old-path)
(path/param-path car-old-path)
car-old-path)
new-param-str)
(cdr old-path)))))
in-url))
;; replace-path: (url-path -> url-path) url -> url
;; make a new url by replacing the path part of a url with a function
;; of the url's old path
;; also remove the query
(define (replace-path proc in-url)
(let ([new-path (proc (url-path in-url))])
(make-url
(url-scheme in-url)
(url-user in-url)
(url-host in-url)
(url-port in-url)
new-path
(url-query in-url)
(url-fragment in-url))))
)

201
collects/web-server/prototype-web-server/stuff-url.ss Normal file
View File

@ -0,0 +1,201 @@
(module stuff-url mzscheme
(require (lib "url.ss" "net")
"utils.ss")
;; before reading this, familiarize yourself with serializable values
;; covered in ch 36 in the MzScheme manual.
;; To keep things small, only serialize closure structures. Furthermore,
;; any such structures must come from the current servlet. One exception is
;; the kont structure.
;; The structure-type list (module map) will be replaced by a list of numbers. For example,
;; if the third element of the list is 19, then the third structure type is
;; the same as the 19th closure type defined in the servlet module.
;; The list described above may also contain the symbol 'k, if kont is *not*
;; at position 0 in the original module map.
;; The labeling code is the symbol prefix that is created by labels.ss. If the
;; servlet is changed in some non-trivial way (i.e. not whitespace or comment),
;; then a new labeling code will be created for the servlet. Thus the labeling code
;; must be kept as part of the URL. URLs with old labeling codes will simply not
;; work since the refactored module will not export any identifiers based off the
;; old labeling.
;; ****************************************
;; FUTURE DESIGN
;; To eliminate the single module requirement, create a global module map at compile time.
;; The global map must handle all struct types from any required modules. Then re-write
;; the serialized value (+ any graph and fixups) substituting the global numbers for the
;; local numbers.
;; Once the local value (+ any graph and fixups) have been translated to use the global map
;; then the local map can be eliminated. The labeling code must still be preserved in the
;; URL. Now the labeling code should identify the global map. Hmm... in this model the labeling
;; code should somehow reflect any changes to the global map.
;; ****************************************
;; URL LAYOUT
;; The mod-map will be encoded in the URL path. The graph, fixups and serial will be
;; encoded in the query.
;; The first path element following the servlet file-name will be the labeling code.
;; The remaining path elements will encode the mod-map, now represented as a list of
;; numbers.
;; The query will contain bindings for at least one and as many as three keys:
;; g -- the graph
;; f -- the fixups
;; v -- the main serial value.
;; If the graph and fixups are trivial, then they will be omitted from the query.
(provide stuff-url
unstuff-url
find-binding)
;; url-parts: module-path serial -> string (listof (union number 'k)) s-expr s-expr s-expr
;; compute the parts for the url:
;; labeling code
;; simplified mod-map encoding
;; graph
;; fixups
;; main serial
(define (url-parts mod-path sv)
(let* ([mod-map (cadr sv)]
[lab-code (get-labeling-code mod-path mod-map)]
[simple-map (simplify-module-map mod-path lab-code mod-map)])
(values lab-code simple-map
(list-ref sv 3)
(list-ref sv 4)
(list-ref sv 5))))
;; recover-serial: module-path (listof (union number 'k)) s-expr s-expr s-expr -> serial
;; recover the serializable value from parts
(define (recover-serial mod-path label-code simple-map graph fixups main-serial)
(list (length simple-map)
(reconstruct-mod-map mod-path label-code simple-map)
(length graph)
graph fixups main-serial))
;; reconstruct-mod-map: module-path string (listof (union number 'k)) -> module-map
;; reconstruct the module map from the simple map
(define (reconstruct-mod-map mod-path label-code simple-map)
(map
(lambda (n-or-k)
(if (eqv? n-or-k 'k)
'((lib "abort-resume.ss" "prototype-web-server") . web-deserialize-info:kont)
(cons
mod-path
(string->symbol
(format "web-deserialize-info:~a~a"
label-code
n-or-k)))))
simple-map))
;; get-labeling-code: module-path module-map -> string
;; pull the labeling code out of the module map
(define (get-labeling-code pth mod-map)
(let loop ([mod-map mod-map])
(cond
[(null? mod-map)
(error "couldn't find labeling code")]
[(and (same-module? pth (caar mod-map))
(match-labeling-code (cdar mod-map)))
=> (lambda (lcode) lcode)]
[else (loop (cdr mod-map))])))
(define WEB-DESERIALIZE-INFO-REGEXP (regexp "web-deserialize-info:([a-zA-Z]*)(.*)"))
;; match-labeling-code: symbol -> string
;; pull the labeling code out of the symbol
(define (match-labeling-code sym)
(let ([match? (regexp-match WEB-DESERIALIZE-INFO-REGEXP (symbol->string sym))])
(and match? (cadr match?))))
;; match-label: symbol -> number
;; pull the closure number out of the symbol
(define (match-label sym)
(let ([match? (regexp-match WEB-DESERIALIZE-INFO-REGEXP (symbol->string sym))])
(and match? (string->number (caddr match?)))))
;; simplify-module-map: module-path string module-map -> (listof (union number 'k))
;; convert the module-map into a simple list
(define (simplify-module-map pth labeling-code mod-map)
(let loop ([mm mod-map])
(cond
[(null? mm) '()]
[(and (same-module? pth (caar mm))
(match-label (cdar mm)))
=> (lambda (lab) (cons lab (loop (cdr mm))))]
[(same-module? '(lib "abort-resume.ss" "prototype-web-server") (caar mm))
(cons 'k (loop (cdr mm)))]
[else
(error "cannot construct abreviated module map" mod-map)])))
;; same-module?: module-path module-path -> boolean
;; do the module paths specify the same module?
(define (same-module? path-str mod-path)
(eqv? ((current-module-name-resolver) path-str #f #f)
((current-module-name-resolver) mod-path #f #f)))
;; stuff-url: serial url path -> url
;; encode in the url
(define (stuff-url svl uri pth)
(let-values ([(l-code simple-mod-map graph fixups sv)
(url-parts pth svl)])
(let ([new-query
`(,(cons 'c l-code)
,@(if (null? graph) '()
(cons 'g (format "~s" graph)))
,@(if (null? fixups) '()
(cons 'f (format "~s" fixups)))
,(cons 'v (format "~s" sv)))])
(let ([result-uri
(make-url
(url-scheme uri)
(url-user uri)
(url-host uri)
(url-port uri)
(append (url-path uri)
(map
(lambda (n-or-sym) (format "~a" n-or-sym))
simple-mod-map))
new-query
(url-fragment uri))])
(begin0
result-uri
(when (> (string-length (url->string result-uri))
1024)
(error "the url is too big: " (url->string result-uri))))))))
;; unstuff-url: url url path -> serial
;; decode from the url and reconstruct the serial
(define (unstuff-url req-url ses-url mod-path)
(let ([suff (split-url-path ses-url req-url)]
[qry (url-query req-url)])
(recover-serial
mod-path
(find-binding 'c qry)
(map
(lambda (elt)
(if (string=? elt "k") 'k
(string->number elt)))
suff)
(or (find-binding 'g qry) '())
(or (find-binding 'f qry) '())
(find-binding 'v qry))))
;; find-binding: symbol (list (cons symbol string)) -> (union string #f)
;; find the binding in the query or return false
(define (find-binding key qry)
(cond
[(null? qry) #f]
[(eqv? key (caar qry))
(read (open-input-string (cdar qry)))]
[else (find-binding key (cdr qry))]))
)

30
collects/web-server/prototype-web-server/syntax-utils.ss Normal file
View File

@ -0,0 +1,30 @@
(module syntax-utils mzscheme
(require-for-template mzscheme)
(provide recertify
recertify*
generate-formal)
;; syntax syntax -> syntax
(define (recertify expr old-expr)
(syntax-recertify expr old-expr (current-code-inspector) #f))
;; (listof syntax) syntax -> syntax
;; recertify a list of syntax parts given the whole
(define (recertify* exprs old-expr)
(map
(lambda (expr)
(syntax-recertify expr old-expr (current-code-inspector) #f))
exprs))
;; generate-formal: -> identifier
(define (generate-formal sym-name)
(let ([name (datum->syntax-object #f (gensym sym-name))])
(with-syntax ([(lambda (formal) ref-to-formal)
(if (syntax-transforming?)
(local-expand #`(lambda (#,name) #,name) 'expression '())
#`(lambda (#,name) #,name))])
(values #'formal #'ref-to-formal))))
)

116
collects/web-server/prototype-web-server/tests/closure-tests.ss Normal file
View File

@ -0,0 +1,116 @@
(module closure-tests mzscheme
(provide closure-tests-suite)
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(lib "serialize.ss")
(lib "match.ss")
"../define-closure.ss")
(define-closure id (x) () x)
(define-closure add-y (x) (y) (+ x y))
(define-closure even-p (n) (odd-p) (or (zero? n)
(odd-p (sub1 n))))
(define-closure odd-p (n) (even-p) (or (= 1 n)
(even-p (sub1 n))))
(define even-p (make-even-p (lambda () odd-p)))
(define odd-p (make-odd-p (lambda () even-p)))
;; an interpreter
(define-closure the-empty-env (var) ()
(error "unbound symbol: " var))
(define-closure extended-env (v) (env var val)
(if (eqv? v var) val
(env v)))
(define-serializable-struct proc (var body env))
(define-closure clsr:evaluate (expr env) (evaluate eval-app)
(match expr
[('lambda (var) body) (make-proc var body env)]
[(expr1 expr2)
(let ([val1 (evaluate expr1 env)]
[val2 (evaluate expr2 env)])
(eval-app val1 val2))]
[(? number? n) n]
[var (env var)]))
(define-closure clsr:eval-app (val1 val2) (evaluate)
(cond
[(proc? val1)
(evaluate (proc-body val1)
(make-extended-env
(lambda () (values (proc-env val1) (proc-var val1) val2))))]
[else
(error "stuck term: " (list val1 val2))]))
(define evaluate (make-clsr:evaluate (lambda () (values evaluate eval-app))))
(define eval-app (make-clsr:eval-app (lambda () evaluate)))
(define closure-tests-suite
(make-test-suite
"Tests for closure.ss"
(make-test-case
"serialize id procedure"
(assert = 7 ((deserialize (serialize (make-id))) 7)))
(make-test-case
"id procedure"
(assert = 7 ((make-id) 7)))
(make-test-case
"add-y procedure"
(assert = 2 ((make-add-y (lambda () 1)) 1)))
(make-test-case
"serialize the add-y procedure"
(assert = 2 ((deserialize (serialize (make-add-y (lambda () 1)))) 1)))
(make-test-case
"even-p procedure"
(assert-true (even-p 8)))
(make-test-case
"serialize the even-p procedure"
(assert-true ((deserialize (serialize even-p)) 64)))
(make-test-case
"simple interpreter case"
(assert = 3 (evaluate 3 (make-the-empty-env))))
(make-test-case
"serialize simple interpreter case"
(assert = 3 ((deserialize (serialize evaluate))
3
(deserialize (serialize (make-the-empty-env))))))
(make-test-case
"apply identity"
(assert = 3 (evaluate '((lambda (x) x) 3) (make-the-empty-env))))
(make-test-case
"serialize environments"
(let* ([e0 (make-the-empty-env)]
[e1 (make-extended-env (lambda () (values e0 'x 1)))]
[e2 (make-extended-env (lambda () (values e1 'y 2)))]
[e3 (make-extended-env (lambda () (values e2 'z 3)))]
[e4 (make-extended-env (lambda () (values e3 'x 4)))]
[e5 (make-extended-env (lambda () (values e4 'y 5)))]
[e6 (make-extended-env (lambda () (values e5 'z 6)))]
[env3 (deserialize (serialize e3))]
[env5 (deserialize (serialize e5))]
[env6 (deserialize (serialize e6))])
(assert = 1 (env3 'x))
(assert = 2 (env3 'y))
(assert = 3 (env3 'z))
(assert = 4 (env5 'x))
(assert = 5 (env5 'y))
(assert = 3 (env5 'z))
(assert = 4 (env6 'x))
(assert = 5 (env6 'y))
(assert = 6 (env6 'z))))
)))

140
collects/web-server/prototype-web-server/tests/interaction-tests.ss Normal file
View File

@ -0,0 +1,140 @@
(require "../client.ss")
;; ****************************************
;; ****************************************
;; BASIC TESTS
(module m00 "../interaction.ss"
(define (id x) x)
(id (start-interaction id)))
(require m00)
(= 7 (dispatch-start 7))
(= 8 (dispatch-start 8))
(module m01 "../interaction.ss"
(define (id x) x)
(+ (* 1 2) (* 3 4) (start-interaction id)))
(require m01)
(= 14 (dispatch-start 0))
(= 20 (dispatch-start 6))
;; start-interaction may be called mutitple times
;; each call overwrites the previous interaction
;; continuation with the latest one.
(module m02 "../interaction.ss"
(define (id x) x)
(+ (start-interaction id)
(start-interaction id)))
(require m02)
(void? (dispatch-start 1))
(= 3 (dispatch-start 2))
(= 0 (dispatch-start -1))
;; ****************************************
;; ****************************************
;; TESTS INVOLVING CALL/CC
(module m03 "../interaction.ss"
(define (f x)
(let/cc k
(+ 2 4 (k 3) 6 8)))
(f (start-interaction (lambda (x) x))))
(require m03)
(= 3 (dispatch-start 'foo))
(= 3 (dispatch-start 7))
;; in the following test, if you modify
;; resume to print the "stack" you will
;; see that this is not tail recursive
(module m04 "../interaction.ss"
(define (mult ln)
(let/cc k
(cond
[(null? ln) 1]
[(zero? (car ln)) (k 0)]
[else
(* (car ln)
(mult (cdr ln)))])))
(mult (start-interaction (lambda (x) x))))
(require m04)
(= 0 (dispatch-start (list 1 2 3 4 5 6 7 0 8 9)))
(= 120 (dispatch-start (list 1 2 3 4 5)))
;; this version captures the continuation
;; outside the recursion and should be tail
;; recursive. A "stack trace" reveals this
;; as expected.
(module m05 "../interaction.ss"
(provide mult)
(define (mult ln)
(let/cc escape
(mult/escape escape ln)))
(define (mult/escape escape ln)
(cond
[(null? ln) 1]
[(zero? (car ln)) (escape 0)]
[else
(* (car ln)
(mult/escape escape (cdr ln)))]))
(mult (start-interaction (lambda (x) x))))
(require m05)
(= 0 (dispatch-start (list 1 2 3 0 4 5 6)))
(= 120 (dispatch-start (list 1 2 3 4 5)))
;; ****************************************
;; ****************************************
;; TESTS INVOLVING send/suspend
(module table01 mzscheme
(provide store-k
lookup-k)
(define the-table (make-hash-table))
(define (store-k k)
(let ([key (string->symbol (symbol->string (gensym 'key)))])
(hash-table-put! the-table key k)
key))
(define (lookup-k key-pair)
(printf "key-pair = ~s~n" key-pair)
(hash-table-get the-table (car key-pair) (lambda () #f))))
(module m06 "../interaction.ss"
(require table01)
(define (gn which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
(store-k k))))))
(let ([ignore (start-interaction lookup-k)])
(let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result))))
(require m06)
(let* ([first-key (dispatch-start 'foo)]
[second-key (dispatch `(,first-key 1))]
[third-key (dispatch `(,first-key -7))])
(values
(= 3 (dispatch `(,second-key 2)))
(= 4 (dispatch `(,second-key 3)))
(zero? (dispatch `(,second-key -1)))
(= -7 (dispatch `(,third-key 0)))
(zero? (dispatch `(,third-key 7)))))

116
collects/web-server/prototype-web-server/tests/labels-tests.ss Normal file
View File

@ -0,0 +1,116 @@
(module labels-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(planet "util.ss" ("schematics" "schemeunit.plt" 1))
(lib "etc.ss")
"../labels.ss")
(require/expose "../labels.ss" (add1/string))
(define THE-TEST-FILENAME "labels-test-file")
(provide labels-tests-suite)
(define l1 (make-labeling #"foo" THE-TEST-FILENAME))
(define l2 (make-labeling #"foo" THE-TEST-FILENAME))
(define l3 (make-labeling #"bar" THE-TEST-FILENAME))
(define l4 (make-labeling #"baz" THE-TEST-FILENAME))
(define race-test-file "race-test-file")
(define (genbytes)
(string->bytes/utf-8
(symbol->string (gensym))))
(define-struct cell (sema ival new-val))
(define (create-cell ival)
(make-cell (make-semaphore) ival #f))
;; race?: (listof alpha) (alpha -> beta) ((listof beta) -> boolean)) -> boolean
;; compute a list of values in parallel and determine if the result indicates a
;; race condition.
(define (race? initial-vals make-new-val check-new-vals)
(let ([cells (map create-cell initial-vals)])
(for-each
(lambda (cell)
(thread
(lambda ()
(dynamic-wind
void
(lambda () (set-cell-new-val! cell (make-new-val (cell-ival cell))))
(lambda () (semaphore-post (cell-sema cell)))))))
cells)
(for-each
(lambda (cell)
(semaphore-wait (cell-sema cell)))
cells)
(with-handlers ([void
(lambda (the-exn) #t)])
(check-new-vals (map cell-new-val cells)))))
(define (make-labeling-race? n)
(delete-tag-list! race-test-file)
(race? (build-list n (lambda (i) (genbytes)))
(lambda (some-bytes)
(make-labeling some-bytes race-test-file))
(lambda (labelings)
(let loop ([label 0]
[labelings labelings])
(if (null? labelings)
#f
(let ([new-label ((car labelings))])
(or (eqv? new-label label)
(loop new-label (cdr labelings)))))))))
(define (delete-tag-list!-race? n)
(race? (build-list n (lambda (i) #"foo"))
(lambda (some-bytes)
(delete-tag-list! race-test-file)
(make-labeling some-bytes race-test-file))
(lambda (labelings)
(let* ([syms (map (lambda (l) (l)) labelings)]
[sym0 (car syms)])
(not
(andmap
(lambda (sym)
(eqv? sym0 sym))
syms))))))
(define labels-tests-suite
(make-test-suite
"Tests for labels.ss"
(make-test-case
"Test the tag incrementing scheme"
(assert string=? "b" (add1/string ""))
(assert string=? "A" (add1/string "z"))
(assert string=? "B" (add1/string "A"))
(assert string=? "b" (add1/string "a"))
(assert string=? "ab" (add1/string "Z"))
(assert string=? "aab" (add1/string "ZZ"))
(assert string=? "Azz" (add1/string "zzz"))
(assert string=? "aaaab" (add1/string "ZZZZ"))
(assert string=? "baaab" (add1/string "aaaab")))
(make-test-case
"The same program produces the same labeling"
(assert-eqv? (l1) (l2))
(assert-eqv? (l1) (l2)))
(make-test-case
"Different programs produce different labelings"
(assert-false (eqv? (l3) (l4))))
(make-test-case
"Check for race condition on make-labeling"
(assert-false (make-labeling-race? 256)))
(make-test-case
"Check for race condition on delete-tag-list!"
(assert-false (delete-tag-list!-race? 256)))
)))

29
collects/web-server/prototype-web-server/tests/language-tester.ss Normal file
View File

@ -0,0 +1,29 @@
(module language-tester mzscheme
(provide make-module-eval
make-eval/mod-path)
(define-syntax (make-module-eval m-expr)
(syntax-case m-expr (module)
[(_ (module m-id . rest))
#'(let ([ns (make-namespace)])
(parameterize ([current-namespace ns])
(eval '(require "../client.ss"
(lib "serialize.ss")))
(eval '(module m-id . rest))
(eval '(require m-id)))
(lambda (s-expr)
(parameterize ([current-namespace ns])
(eval s-expr))))]
[else
(raise-syntax-error #f "make-module-evel: dropped through" m-expr)]))
(define (make-eval/mod-path pth)
(let ([ns (make-namespace)])
(parameterize ([current-namespace ns])
(eval `(require (lib "client.ss" "prototype-web-server")
(lib "serialize.ss")
,pth))
(lambda (expr)
(parameterize ([current-namespace ns])
(eval expr)))))))

52
collects/web-server/prototype-web-server/tests/misc05.ss Normal file
View File

@ -0,0 +1,52 @@
(require "../client.ss"
(lib "serialize.ss"))
(module m08 "../persistent-interaction.ss"
(define (id x) x)
(define (gn which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let ([ignore (start-interaction car)])
(letrec ([f (let ([n (gn "first")])
(lambda (m) (+ n m)))]
[g (let ([n (gn "second")])
(lambda (m) (+ n (f m))))])
(let ([result (g (gn "third"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result)))))
(require m08)
;; trace *without* serialization
(define k0 (dispatch-start 'foo))
(define k1 (dispatch (list k0 1)))
(serialize k1)
(define k2 (dispatch (list k1 2)))
(serialize k1)
(= 6 (dispatch (list k2 3)))
(= 9 (dispatch (list k2 6)))
(serialize k2)
(define k1.1 (dispatch (list k0 -1)))
(define k2.1 (dispatch (list k1.1 -2)))
(zero? (dispatch (list k2.1 3)))
(= 6 (dispatch (list k2 3)))
(serialize k2)
(serialize k1)
;; trace *with* serialization
(define k0 (serialize (dispatch-start 'foo)))
(define k1 (serialize (dispatch (list (deserialize k0) 1))))
(define k2 (serialize (dispatch (list (deserialize k1) 2))))
(= 6 (dispatch (list (deserialize k2) 3)))
(= 9 (dispatch (list (deserialize k2) 6)))
k2
(define k1.1 (serialize (dispatch (list (deserialize k0) -1))))
(define k2.1 (serialize (dispatch (list (deserialize k1.1) -2))))
(zero? (dispatch (list (deserialize k2.1) 3)))
(= 6 (dispatch (list (deserialize k2) 3)))
k2

15
collects/web-server/prototype-web-server/tests/modules/mm00.ss Normal file
View File

@ -0,0 +1,15 @@
(module mm00 (lib "persistent-interaction.ss" "prototype-web-server")
(define (gn which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let* ([ignore (start-interaction car)]
[ans (+ (gn "first")
(gn "second")
(gn "third"))])
(printf "The answer is: ~s~n" ans)
ans))

11
collects/web-server/prototype-web-server/tests/modules/mm01.ss Normal file
View File

@ -0,0 +1,11 @@
(module mm01 (lib "persistent-interaction.ss" "prototype-web-server")
(define (gn which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let ([ignore (start-interaction car)])
(gn "first")))

38
collects/web-server/prototype-web-server/tests/persistent-close-tests.ss Normal file
View File

@ -0,0 +1,38 @@
(module persistent-close-tests mzscheme
(require (lib "file-vector.ss" "prototype-web-server")
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(lib "serialize.ss")
(lib "persistent-close.ss" "prototype-web-server"))
(provide persistent-close-suite)
(define persistent-close-suite
(make-test-suite
"tests for persistent-close.ss"
(make-test-case
"file-vector references"
(let ([fv (make-file-vector 'foo 1 2 3)])
(assert = 1 (file-vector-ref fv 0))
(assert = 2 (file-vector-ref fv 1))
(assert = 3 (file-vector-ref fv 2))
(file-vector-set! fv 0 -1)
(file-vector-set! fv 1 -2)
(file-vector-set! fv 2 -3)
(assert = -1 (file-vector-ref fv 0))
(assert = -2 (file-vector-ref fv 1))
(assert = -3 (file-vector-ref fv 2))))
(make-test-case
"serializing file vectors"
(let* ([fv (make-file-vector 'foo -1 -2 -3)]
[fv2 (deserialize (serialize fv))])
(assert = -1 (file-vector-ref fv2 0))
(assert = -2 (file-vector-ref fv2 1))
(assert = -3 (file-vector-ref fv2 2))))
(make-test-case
"close/file test"
(let ([x 7] [y 8])
(assert = 7 (close/file 'f1 (x y) x))
(assert = 15 (close/file 'f2 (x y) (+ x y))))))))

501
collects/web-server/prototype-web-server/tests/persistent-interaction-tests.ss Normal file
View File

@ -0,0 +1,501 @@
(module persistent-interaction-tests mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
"language-tester.ss")
(provide persistent-interaction-suite)
(define (catch-unsafe-context-exn thunk)
(with-handlers ([void
(lambda (the-exn)
(or
(and
(regexp-match ".*Attempt to capture a continuation from within an unsafe context$"
(exn-message the-exn))
#t)
(raise the-exn)))])
(and (thunk) #f)))
(define persistent-interaction-suite
(make-test-suite
"Test the persistent interaction language"
;; ****************************************
;; ****************************************
;; BASIC TESTS
(make-test-suite
"Basic Tests"
(make-test-case
"Function application with single argument in tail position"
(let ([test-m00.4
(make-module-eval
(module m00.4 "../persistent-interaction.ss"
(define (id x) x)
(let ([f (let ([m 7]) m)])
(+ f (start-interaction id)))))])
(assert = 8 (test-m00.4 '(dispatch-start 1)))))
(make-test-case
"start-interaction in argument position of a function call"
(let ([test-m00.3
(make-module-eval
(module m00.3 "../persistent-interaction.ss"
(define (id x) x)
(define (foo x) 'foo)
(foo (start-interaction id))))])
(assert eqv? 'foo (test-m00.3 '(dispatch-start 7)))))
(make-test-case
"identity interaction, dispatch-start called multiple times"
(let ([test-m00
(make-module-eval
(module m00 "../persistent-interaction.ss"
(define (id x) x)
(id (start-interaction id))))])
(assert = 7 (test-m00 '(dispatch-start 7)))
(assert eqv? 'foo (test-m00 '(dispatch-start 'foo)))))
(make-test-case
"start-interaction in argument position of a primitive"
(let ([test-m00.1
(make-module-eval
(module m00.1 "../persistent-interaction.ss"
(define (id x) x)
(+ 1 (start-interaction id))))])
(assert = 2 (test-m00.1 '(dispatch-start 1)))))
(make-test-case
"dispatch-start called multiple times for s-i in non-trivial context"
(let ([test-m00.2
(make-module-eval
(module m00.2 "../persistent-interaction.ss"
(define (id x) x)
(+ (+ 1 1) (start-interaction id))))])
(assert = 14 (test-m00.2 '(dispatch-start 12)))
(assert = 20 (test-m00.2 '(dispatch-start 18)))))
(make-test-case
"start-interaction in third position"
(let ([test-m01
(make-module-eval
(module m01 "../persistent-interaction.ss"
(define (id x) x)
(+ (* 1 2) (* 3 4) (start-interaction id))))])
(assert = 14 (test-m01 '(dispatch-start 0)))
(assert = 20 (test-m01 '(dispatch-start 6)))))
(make-test-case
"quasi-quote with splicing: need to recertify context for qq-append"
(let ([test-m01.1
(make-module-eval
(module m01.1 "../persistent-interaction.ss"
(define (id x) x)
`(,@(list 1 2 (start-interaction id)))))])
(assert equal? (list 1 2 3) (test-m01.1 '(dispatch-start 3)))
(assert equal? (list 1 2 'foo) (test-m01.1 '(dispatch-start 'foo)))))
(make-test-case
"recertify context test (1)"
(let ([test-m01.2
(make-module-eval
(module m01.1 "../persistent-interaction.ss"
`(foo ,@(list 1 2 3))))])
(assert-true #t)))
(make-test-case
"recertify context test (2)"
(let ([test-m01.3
(make-module-eval
(module m01.3 "../persistent-interaction.ss"
(lambda (n)
`(n ,@(list 1 2 3)))))])
(assert-true #t)))
(make-test-case
"recertify context test (3)"
(let ([test-m01.4
(make-module-eval
(module m1 "../persistent-interaction.ss"
(define (bar n)
`(n ,@(list 1 2 3)))
(bar 7)))])
(assert-true #t)))
;; start-interaction may be called mutitple times
;; each call overwrites the previous interaction
;; continuation with the latest one.
(make-test-case
"start-interaction called twice, dispatch-start will invoke different continuations"
(let ([test-m02
(make-module-eval
(module m02 "../persistent-interaction.ss"
(define (id x) x)
(+ (start-interaction id)
(start-interaction id))))])
(assert-true (void? (test-m02 '(dispatch-start 1))))
(assert = 3 (test-m02 '(dispatch-start 2)))
(assert = 0 (test-m02 '(dispatch-start -1))))))
;; ****************************************
;; ****************************************
;; TESTS INVOLVING CALL/CC
(make-test-suite
"Tests Involving call/cc"
(make-test-case
"continuation invoked in non-trivial context from within proc"
(let ([test-m03
(make-module-eval
(module m03 "../persistent-interaction.ss"
(define (f x)
(let/cc k
(+ 2 4 (k 3) 6 8)))
(f (start-interaction (lambda (x) x)))))])
(assert = 3 (test-m03 '(dispatch-start 'foo)))
(assert = 3 (test-m03 '(dispatch-start 7)))))
;; in the following test, if you modify
;; resume to print the "stack" you will
;; see that this is not tail recursive
(make-test-case
"non-tail-recursive 'escaping' continuation"
(let ([test-m04
(make-module-eval
(module m04 "../persistent-interaction.ss"
(define (mult ln)
(let/cc k
(cond
[(null? ln) 1]
[(zero? (car ln)) (k 0)]
[else
(* (car ln)
(mult (cdr ln)))])))
(mult (start-interaction (lambda (x) x)))))])
(assert = 0 (test-m04 '(dispatch-start (list 1 2 3 4 5 6 7 0 8 9))))
(assert = 120 (test-m04 '(dispatch-start (list 1 2 3 4 5))))))
;; this version captures the continuation
;; outside the recursion and should be tail
;; recursive. A "stack trace" reveals this
;; as expected.
(make-test-case
"tail-recursive escaping continuation"
(let ([test-m05
(make-module-eval
(module m05 "../persistent-interaction.ss"
(provide mult)
(define (mult ln)
(let/cc escape
(mult/escape escape ln)))
(define (mult/escape escape ln)
(cond
[(null? ln) 1]
[(zero? (car ln)) (escape 0)]
[else
(* (car ln)
(mult/escape escape (cdr ln)))]))
(mult (start-interaction (lambda (x) x)))))])
(assert = 0 (test-m05 '(dispatch-start (list 1 2 3 0 4 5 6))))
(assert = 120 (test-m05 '(dispatch-start (list 1 2 3 4 5)))))))
;; ****************************************
;; ****************************************
;; TESTS INVOLVING send/suspend
(make-test-suite
"Tests Involving send/suspend"
(make-test-case
"curried add with send/suspend"
(let ([table-01-eval
(make-module-eval
(module table01 mzscheme
(provide store-k
lookup-k)
(define the-table (make-hash-table))
(define (store-k k)
(let ([key (string->symbol (symbol->string (gensym 'key)))])
(hash-table-put! the-table key k)
key))
(define (lookup-k key-pair)
(hash-table-get the-table (car key-pair) (lambda () #f)))))])
(table-01-eval
'(module m06 "../persistent-interaction.ss"
(require table01)
(define (gn which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
(store-k k))))))
(let ([ignore (start-interaction lookup-k)])
(let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result)))))
(table-01-eval '(require m06))
(let* ([first-key (table-01-eval '(dispatch-start 'foo))]
[second-key (table-01-eval `(dispatch '(,first-key 1)))]
[third-key (table-01-eval `(dispatch '(,first-key -7)))])
(assert = 3 (table-01-eval `(dispatch '(,second-key 2))))
(assert = 4 (table-01-eval `(dispatch '(,second-key 3))))
(assert-true (zero? (table-01-eval `(dispatch '(,second-key -1)))))
(assert = -7 (table-01-eval `(dispatch '(,third-key 0))))
(assert-true (zero? (table-01-eval `(dispatch '(,third-key 7))))))))
(make-test-case
"curried with send/suspend and serializaztion"
(let ([test-m06.1
(make-module-eval
(module m06.1 (lib "persistent-interaction.ss" "prototype-web-server")
(define (id x) x)
(define (gn which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let ([ignore (start-interaction car)])
(let ([result (+ (gn "first") (gn "second"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result)))))])
(let* ([first-key (test-m06.1 '(dispatch-start 'foo))]
[second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))]
[third-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) -7)))])
(values
(assert = 3 (test-m06.1 `(dispatch (list ,second-key 2))))
(assert = 4 (test-m06.1 `(dispatch (list ,second-key 3))))
(assert-true (zero? (test-m06.1 `(dispatch (list ,second-key -1)))))
(assert = -7 (test-m06.1 `(dispatch (list ,third-key 0))))
(assert-true (zero? (test-m06.1 `(dispatch (list ,third-key 7)))))))))
)
;; ****************************************
;; ****************************************
;; TESTS INVOLVING LETREC
(make-test-suite
"Tests Involving letrec"
(make-test-case
"mutually recursive even? and odd?"
(let ([test-m07
(make-module-eval
(module m07 "../persistent-interaction.ss"
(define (id x) x)
(letrec ([even? (lambda (n)
(or (zero? n)
(odd? (sub1 n))))]
[odd? (lambda (n)
(and (not (zero? n))
(even? (sub1 n))))])
(even? (start-interaction id)))))])
(assert-true (test-m07 '(dispatch-start 0)))
(assert-true (test-m07 '(dispatch-start 16)))
(assert-false (test-m07 '(dispatch-start 1)))
(assert-false (test-m07 '(dispatch-start 7)))))
(make-test-case
"send/suspend on rhs of letrec binding forms"
(let ([test-m08
(make-module-eval
(module m08 "../persistent-interaction.ss"
(define (id x) x)
(define (gn which)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "Please send the ~a number.~n" which)])
k)))))
(let ([ignore (start-interaction car)])
(letrec ([f (let ([n (gn "first")])
(lambda (m) (+ n m)))]
[g (let ([n (gn "second")])
(lambda (m) (+ n (f m))))])
(let ([result (g (gn "third"))])
(let ([ignore (printf "The answer is: ~s~n" result)])
result))))))])
(let* ([k0 (test-m08 '(serialize (dispatch-start 'foo)))]
[k1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) 1))))]
[k2 (test-m08 `(serialize (dispatch (list (deserialize ',k1) 2))))])
(assert = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3))))
(assert = 9 (test-m08 `(dispatch (list (deserialize ',k2) 6))))
(let* ([k1.1 (test-m08 `(serialize (dispatch (list (deserialize ',k0) -1))))]
[k2.1 (test-m08 `(serialize (dispatch (list (deserialize ',k1.1) -2))))])
(assert-true (zero? (test-m08 `(dispatch (list (deserialize ',k2.1) 3)))))
(assert = 6 (test-m08 `(dispatch (list (deserialize ',k2) 3))))))))
)
;; ****************************************
;; ****************************************
;; TEST UNSAFE CONTEXT CONDITION
(make-test-suite
"Unsafe Context Condition Tests"
(make-test-case
"simple attempt to capture a continuation from an unsafe context"
(let ([nta-eval
(make-module-eval
(module nta mzscheme
(provide non-tail-apply)
(define (non-tail-apply f . args)
(let ([result (apply f args)])
(printf "result = ~s~n" result)
result))))])
(nta-eval '(module m09 "../persistent-interaction.ss"
(require nta)
(define (id x) x)
(let ([ignore (start-interaction id)])
(non-tail-apply (lambda (x) (let/cc k (k x))) 7))))
(nta-eval '(require m09))
(assert-true (catch-unsafe-context-exn
(lambda () (nta-eval '(dispatch-start 'foo)))))))
(make-test-case
"sanity-check: capture continuation from safe version of context"
(let ([m10-eval
(make-module-eval
(module m10 "../persistent-interaction.ss"
(define (id x) x)
(define (nta f arg)
(let ([result (f arg)])
(printf "result = ~s~n" result)
result))
(let ([ignore (start-interaction id)])
(nta (lambda (x) (let/cc k (k x))) 7))))])
(assert = 7 (m10-eval '(dispatch-start 'foo)))))
(make-test-case
"attempt continuation capture from standard call to map"
(let ([m11-eval
(make-module-eval
(module m11 "../persistent-interaction.ss"
(define (id x) x)
(let ([ignore (start-interaction id)])
(map
(lambda (x) (let/cc k k))
(list 1 2 3)))))])
(assert-true (catch-unsafe-context-exn
(lambda () (m11-eval '(dispatch-start 'foo)))))))
;; if the continuation-capture is attempted in tail position then we
;; should be just fine.
(make-test-case
"continuation capture from tail position of untranslated procedure"
(let ([ta-eval
(make-module-eval
(module ta mzscheme
(provide tail-apply)
(define (tail-apply f . args)
(apply f args))))])
(ta-eval '(module m12 "../persistent-interaction.ss"
(require ta)
(define (id x) x)
(+ (start-interaction id)
(tail-apply (lambda (x) (let/cc k (k x))) 1))))
(ta-eval '(require m12))
(assert = 2 (ta-eval '(dispatch-start 1)))))
(make-test-case
"attempt send/suspend from standard call to map"
(let ([m13-eval
(make-module-eval
(module m11 "../persistent-interaction.ss"
(define (id x) x)
(let ([ignore (start-interaction car)])
(map
(lambda (n) (send/suspend
(lambda (k)
(let ([ignore (printf "n = ~s~n" n)])
k))))
(list 1 2 3)))))])
(assert-true (catch-unsafe-context-exn
(lambda () (m13-eval '(dispatch-start 'foo)))))))
(make-test-case
"attempt send/suspend from tail position of untranslated procedure"
(let ([ta-eval
(make-module-eval
(module ta mzscheme
(provide tail-apply)
(define (tail-apply f . args)
(apply f args))))])
(ta-eval '(module m14 "../persistent-interaction.ss"
(require ta)
(let ([ignore (start-interaction car)])
(+ 1 (tail-apply
(lambda (n)
(cadr
(send/suspend
(lambda (k)
(let ([ignore (printf "n = ~s~n" n)])
k))))) 7)))))
(ta-eval '(require m14))
(let ([k0 (ta-eval '(dispatch-start 'foo))])
(assert = 3 (ta-eval `(dispatch (list ,k0 2))))
(assert = 0 (ta-eval `(dispatch (list ,k0 -1)))))))
))))

3
collects/web-server/prototype-web-server/tests/start-server.ss Normal file
View File

@ -0,0 +1,3 @@
(require "../server.ss")
(define shutdown (serve 9000))

72
collects/web-server/prototype-web-server/tests/stuff-url-tests.ss Normal file
View File

@ -0,0 +1,72 @@
(module stuff-url-tests mzscheme
(require (lib "stuff-url.ss" "prototype-web-server")
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
(planet "util.ss" ("schematics" "schemeunit.plt" 1))
(lib "url.ss" "net")
(lib "file.ss")
"language-tester.ss")
(require/expose (lib "stuff-url.ss" "prototype-web-server")
(same-module? url-parts recover-serial))
(provide stuff-url-suite)
(define uri0 (string->url "www.google.com"))
(define (simplify-unsimplify svl pth)
(let-values ([(l-code simple-mod-map graph fixups sv)
(url-parts pth svl)])
(recover-serial
pth
l-code
simple-mod-map graph fixups sv)))
(define (stuff-unstuff svl uri mod-path)
(let ([result-uri (stuff-url svl uri mod-path)])
(unstuff-url result-uri uri mod-path)))
(define stuff-url-suite
(make-test-suite
"Tests for stuff-url.ss"
(make-test-case
"Test same-module?"
(assert-true
(same-module? (build-path "~/plt-exp/collects/prototype-web-server/abort-resume.ss")
'(lib "abort-resume.ss" "prototype-web-server")))
(assert-true
(same-module? (build-absolute-path (current-directory) "../abort-resume.ss")
'(lib "abort-resume.ss" "prototype-web-server")))
(assert-true
(same-module?
'(lib "abort-resume.ss" "prototype-web-server")
'(lib "./abort-resume.ss" "prototype-web-server"))))
(make-test-case
"compose url-parts and recover-serial (1)"
(let* ([ev (make-eval/mod-path "modules/mm00.ss")]
[k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) "modules/mm00.ss")]
[k1 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k0) 1))))
"modules/mm00.ss")]
[k2 (simplify-unsimplify (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
"modules/mm00.ss")])
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3)))))))
(make-test-case
"compose url-parts and recover-serial (2)"
(let* ([ev (make-eval/mod-path "modules/mm01.ss")]
[k0 (simplify-unsimplify (ev '(serialize (dispatch-start 'foo))) "modules/mm01.ss")])
(assert-true (= 7 (ev `(dispatch (list (deserialize ',k0) 7)))))))
(make-test-case
"compose stuff-url and unstuff-url and recover the serial"
(let* ([ev (make-eval/mod-path "modules/mm00.ss")]
[k0 (stuff-unstuff (ev '(serialize (dispatch-start 'foo))) uri0 "modules/mm00.ss")]
[k1 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k0) 1))))
uri0 "modules/mm00.ss")]
[k2 (stuff-unstuff (ev `(serialize (dispatch (list (deserialize ',k1) 2))))
uri0 "modules/mm00.ss")])
(assert-true (= 6 (ev `(dispatch (list (deserialize ',k2) 3))))))))))

20
collects/web-server/prototype-web-server/tests/suite.ss Normal file
View File

@ -0,0 +1,20 @@
(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1))
(planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
"persistent-close-tests.ss"
"test-normalizer.ss"
"closure-tests.ss"
"labels-tests.ss"
"persistent-interaction-tests.ss"
"stuff-url-tests.ss")
(test/graphical-ui
(make-test-suite
"Main Tests for Prototype Web Server"
persistent-close-suite
stuff-url-suite
test-normalizer-suite
closure-tests-suite
labels-tests-suite
persistent-interaction-suite
))

340
collects/web-server/prototype-web-server/tests/test-normalizer.ss Normal file
View File

@ -0,0 +1,340 @@
(module test-normalizer mzscheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
"../normalizer.ss")
(provide test-normalizer-suite)
(define (empty-env var)
(error "empty environment"))
(define (extend env vars vals)
(lambda (var0)
(let loop ([vars vars]
[vals vals])
(cond
[(null? vars) (env var0)]
[(eqv? var0 (car vars))
(car vals)]
[else (loop (cdr vars) (cdr vals))]))))
;; alpha=/env: environment target-expr target-expr -> boolean
;; are two target expressions alpha-equivalent?
(define (alpha=/env env1 env2 expr1 expr2)
(syntax-case expr1 (if #%app)
[(if tst1 csq1)
(syntax-case expr2 (if)
[(if tst2 csq2) (and (alpha=/env env1 env2 #'tst1 #'tst2)
(alpha=/env env1 env2 #'csq1 #'csq2))]
[_else #f])]
[(if tst1 csq1 alt1)
(syntax-case expr2 (if)
[(if tst2 csq2 alt2) (and (alpha=/env env1 env2 #'tst1 #'tst2)
(alpha=/env env1 env2 #'csq1 #'csq2)
(alpha=/env env1 env2 #'alt1 #'alt2))]
[_else #f])]
[(#%app rator1 rands1 ...)
(syntax-case expr2 (#%app)
[(#%app rator2 rands2 ...)
(and (alpha=/env env1 env2 #'rator1 #'rator2)
(let loop ([rs1 (syntax->list #'(rands1 ...))]
[rs2 (syntax->list #'(rands2 ...))])
(or (and (null? rs1)
(null? rs2))
(and (alpha=/env env1 env2 (car rs1) (car rs2))
(loop (cdr rs1) (cdr rs2))))))]
[_else #f])]
[_else (w-alpha=/env env1 env2 expr1 expr2)]))
;; w-alpha=/env: env target-expr target-expr -> boolean
;; are two target vars or vals alpha-equivalent?
(define (w-alpha=/env env1 env2 expr1 expr2)
(syntax-case expr1 (#%top #%datum lambda quote)
[(#%top . var1)
(syntax-case expr2 (#%top)
[(#%top . var2)
(eqv? (syntax-object->datum #'var1)
(syntax-object->datum #'var2))]
[_else #f])]
[(#%datum . datum1)
(syntax-case expr2 (#%datum)
[(#%datum . datum2)
(let ([dat1 (syntax-object->datum #'datum1)]
[dat2 (syntax-object->datum #'datum2)])
(eqv? dat1 dat2))]
[_else #f])]
[(quote datum1)
(syntax-case expr2 (quote)
[(quote datum2)
(let ([dat1 (syntax-object->datum #'datum1)]
[dat2 (syntax-object->datum #'datum2)])
(equal? dat1 dat2))]
[_else #f])]
[(lambda (formals1 ...) body1)
(syntax-case expr2 (lambda)
[(lambda (formals2 ...) body2)
(let ([syms (map gensym (syntax->symbols #'(formals1 ...)))])
(and (= (length syms) (length (syntax->list #'(formals2 ...))))
(alpha=/env
(extend env1 (syntax->symbols #'(formals1 ...)) syms)
(extend env2 (syntax->symbols #'(formals2 ...)) syms)
#'body1 #'body2)))]
[_else #f])]
[x1 (symbol? (syntax-object->datum #'x1))
(syntax-case expr2 ()
[x2 (symbol? (syntax-object->datum #'x2))
(or (module-identifier=? #'x1 #'x2)
(eqv? (env1 (syntax-object->datum #'x1))
(env2 (syntax-object->datum #'x2))))]
[_else #f])]
[_else #f]))
;; convert syntax into a list of symbols
(define (syntax->symbols stx)
(syntax-case stx ()
[(vars ...)
(map
(lambda (s)
(syntax-object->datum s))
(syntax->list #'(vars ...)))]))
;; alph=: target-expr target-expr -> boolean
;; are two target expressions alpha-equivalent?
(define (alpha= expr1 expr2)
(alpha=/env empty-env empty-env expr1 expr2))
(define-syntax (check-unsupported-lambda stx)
(syntax-case stx ()
[(_ expr)
#'(with-handlers ([(lambda (x) #t)
(lambda (the-exn)
(string=? "lambda: Not all lambda-expressions supported"
(exn-message the-exn)))])
expr)]))
(define-syntax (check-unsupported-let stx)
(syntax-case stx ()
[(_ expr)
#'(with-handlers ([(lambda (x) #t)
(lambda (the-exn)
(string=? "let-values: Not all let-values-expressions supported"
(exn-message the-exn)))])
expr)]))
;; **************************************************
;; **************************************************
;; ACTUAL TESTS
(define test-normalizer-suite
(make-test-suite
"Tests for Normalization Phase"
(make-test-suite
"Base Cases"
(make-test-case
"Top level identifier"
(assert alpha= (normalize-term (expand (syntax car)))
(expand (syntax car))))
(make-test-case
"Simple arithmetic expression"
(assert alpha= (normalize-term (expand (syntax (+ 1 1))))
(expand (syntax (+ 1 1)))))
(make-test-case
"lambda-expression with constant body"
(assert alpha= (normalize-term (expand (syntax (lambda (x) 3))))
(expand (syntax (lambda (x) 3)))))
(make-test-case
"lambda-expression with var-ref body"
(assert alpha= (normalize-term (expand (syntax (lambda (x) x))))
(expand (syntax (lambda (x) x)))))
(make-test-case
"lambda-expression/constant-body/multiple formals"
(assert alpha= (normalize-term (expand (syntax (lambda (x y z) 3))))
(expand (syntax (lambda (x y z) 3)))))
(make-test-case
"one-armed-if"
(assert alpha= (normalize-term (expand (syntax (if #t 1))))
(expand (syntax (if #t 1)))))
(make-test-case
"two-armed-if"
(assert alpha= (normalize-term (expand (syntax (if #t 1 2))))
(expand (syntax (if #t 1 2)))))
(make-test-case
"let/var-ref in body"
(assert alpha= (normalize-term (expand (syntax (let ([x 1]) x))))
(expand (syntax ((lambda (x) x) 1)))))
(make-test-case
"call to void"
(assert alpha= (normalize-term (expand (syntax (void))))
(expand (syntax (void)))))
(make-test-case
"primitive application/multiple arguments"
(assert alpha= (normalize-term (expand (syntax (+ 1 2 3))))
(expand (syntax (+ 1 2 3)))))
(make-test-case
"empty-list"
(assert alpha= (normalize-term (expand (syntax ())))
(expand (syntax ()))))
(make-test-case
"qoted list of constants"
(assert alpha= (normalize-term (expand (syntax '(1 2 3))))
(expand (syntax '(1 2 3))))))
(make-test-suite
"Inductive Cases"
(make-test-case
"nested primitive applications with multiple arguments"
(assert alpha= (normalize-term (expand (syntax (* (+ 1 2) 3))))
(expand (syntax ((lambda (x) (* x 3)) (+ 1 2))))))
(make-test-case
"one-armed if with prim-app in test posn"
(assert alpha= (normalize-term (expand (syntax (if (+ 1 2) 3))))
(expand (syntax ((lambda (x) (if x 3)) (+ 1 2))))))
(make-test-case
"two-armed if with prim-app in test posn"
(assert alpha= (normalize-term (expand (syntax (if (+ 1 2) 3 4))))
(expand (syntax ((lambda (x) (if x 3 4)) (+ 1 2))))))
(make-test-case
"nested single argument primitive applications"
(assert alpha= (normalize-term (expand (syntax (* (+ 1)))))
(expand (syntax ((lambda (x0) (* x0)) (+ 1))))))
(make-test-case
"deeply nested primitive applications"
(assert alpha= (normalize-term (expand (syntax (* (+ (+ (+ 1 2) 3) 4) (+ 5 6)))))
(expand (syntax ((lambda (x0)
((lambda (x1)
((lambda (x2)
((lambda (x3) (* x2 x3))
(+ 5 6)))
(+ x1 4)))
(+ x0 3)))
(+ 1 2))))))
(make-test-case
"deeply nested primitive applications"
(assert alpha= (normalize-term (expand (syntax (* (+ 1 2) (+ 1 (+ 2 (+ 3 4)))))))
(expand (syntax ((lambda (x0)
((lambda (x1)
((lambda (x2)
((lambda (x3)
(* x0 x3))
(+ 1 x2)))
(+ 2 x1)))
(+ 3 4)))
(+ 1 2))))))
(make-test-case
"if nested in test position"
(assert alpha= (normalize-term (expand (syntax (if (if #t #f #t) #t #t))))
(expand (syntax ((lambda (x) (if x #t #t)) (if #t #f #t))))))
(make-test-case
"procedure/body has nested if"
(assert alpha= (normalize-term (expand (syntax (lambda (x) (if (if x 1 2) 3 4)))))
(expand (syntax (lambda (x)
((lambda (y0) (if y0 3 4))
(if x 1 2)))))))
(make-test-case
"constant 0-arg procedure application"
(assert alpha= (normalize-term (expand (syntax ((lambda () 3)))))
(expand (syntax ((lambda () 3))))))
(make-test-case
"if with function application in test"
(assert alpha= (normalize-term (expand (syntax (if ((lambda () 7)) 1 2))))
(expand (syntax ((lambda (x) (if x 1 2))
((lambda () 7)))))))
(make-test-case
"if with lambda-expression in consequent and alternative"
(assert alpha= (normalize-term (expand (syntax ((if #t (lambda () 1) (lambda () 2))))))
(expand (syntax ((lambda (x) (x)) (if #t (lambda () 1) (lambda () 2)))))))
(make-test-case
"call/cc with value argument"
(assert alpha= (normalize-term (expand (syntax (call/cc (lambda (x) x)))))
(expand (syntax (call/cc (lambda (x) x))))))
(make-test-case
"call/cc with complex expression in argument"
(assert alpha= (normalize-term (expand (syntax (call/cc (f (g 7))))))
(expand (syntax ((lambda (x0)
((lambda (x1) (call/cc x1))
(f x0)))
(g 7)))))))
(make-test-suite
"Check that certain errors are raised"
(make-test-case
"multiple body expressions in lambda"
(assert-true (check-unsupported-lambda
(normalize-term (expand (syntax (lambda (x y z) 3 4)))))))
(make-test-case
"zero-or-more argument lambda"
(assert-true (check-unsupported-lambda
(normalize-term (expand (syntax (lambda x x)))))))
; this is supported now
#; (make-test-case
"multi-valued let-values"
(assert-true (check-unsupported-let
(normalize-term (expand (syntax (let-values ([(x y) (values 1 2)]) (+ x y))))))))
; this is supported now
#; (make-test-case
"let/multiple clauses before body"
(assert-true (check-unsupported-let
(normalize-term (expand (syntax (let ([x 1] [y 2]) (+ x y)))))))))
(make-test-suite
"Miscellaneous tests"
(make-test-case
"empty begin"
(assert alpha= (normalize-term (expand (syntax (begin))))
(syntax (#%app (#%top . void)))))
(make-test-case
"begin with one expression"
(assert alpha= (normalize-term (expand (syntax (begin 1))))
(syntax (#%datum . 1))))
(make-test-case
"begin with multiple expressions"
(assert alpha= (normalize-term (expand (syntax (begin 1 2 3))))
(normalize-term (expand (syntax (let ([throw-away 1])
(let ([throw-away 2])
3)))))))
(make-test-case
"cond expression"
(assert-true
(and
(with-handlers ([(lambda (x) #t)
(lambda (the-exn) #f)])
(normalize-term
(expand
(syntax
(cond
[(null? l) 1]
[(zero? (car l)) (k 0)]
[else
(* (car l) (cdr l))])))))
#t)))))))

107
collects/web-server/prototype-web-server/utils.ss Normal file
View File

@ -0,0 +1,107 @@
(module utils mzscheme
(require (lib "url.ss" "net"))
(provide url->servlet-path
make-session-url
split-url-path)
;; make-session-url: url (listof string) -> url
;; produce a new url for this session:
;; Minimal path to the servlet.
;; No query.
;; No fragment.
(define (make-session-url uri new-path)
(make-url
(url-scheme uri)
(url-user uri)
(url-host uri)
(url-port uri)
new-path
'()
#f
))
;; build-root-path: -> path
;; build the root path for whatever this OS is
(define (build-root-path)
(let loop ([prev (simplify-path (build-path 'same))]
[next (simplify-path (build-path 'up))])
(if (equal? prev next)
prev
(loop next
(simplify-path (build-path next 'up))))))
(define the-root-path (build-root-path))
;; simplify-url-path: url -> (listof string)
;; take the dots out of the url-path
;; Note: we simplify the url path relative to a hypothetical root,
;; so that a malicious url can't cause the server to chase ".."
;; up beyond the legitimate servlet root.
(define (simplify-url-path uri)
(path->list
(simplify-path
(apply build-path
(cons the-root-path
(map
(lambda (str)
(if (string=? str "")
'same
str))
(map
(lambda (path-elt)
(if (path/param? path-elt)
(path/param-path path-elt)
path-elt))
(url-path uri))))))))
;; path->list pth
;; convert an absolute path to a list of strings
(define (path->list pth)
(reverse
(let path->list ([pth pth])
(let-values ([(base name must-be-dir?) (split-path pth)])
(if base
(cons (path->string name) (path->list base))
'())))))
;; url->servlet-path: path url -> (values (union path #f)
;; (union (listof url->string) #f)
;; (union (listof string) #f))
;; Given a servlet directory and url, find a servlet.
;; The first value is the servlet path.
;; The second value is the prefix of the url-path used to find the servlet.
;; The third value is the remaining suffix of the url-path.
(define (url->servlet-path servlet-dir uri)
(printf " current-directory = ~s~n" (current-directory))
(let loop ([base-path servlet-dir]
[servlet-path '()]
[path-list (simplify-url-path uri)])
(if
(null? path-list)
(values #f #f #f)
(let* ([next-path-segment (car path-list)]
[new-base (build-path base-path next-path-segment)])
(printf " new-base = ~s~n" new-base)
(cond
[(file-exists? new-base)
(values new-base
(reverse (cons next-path-segment servlet-path))
(cdr path-list))]
[else (loop new-base
(cons next-path-segment servlet-path)
(cdr path-list))])))))
;; split-url-path: url url -> (union (listof string) #f)
;; the first url's path is a prefix of the path of the second
;; find the suffix and return it as a list of strings
(define (split-url-path pref-url suff-url)
(let loop ([pref-path (simplify-url-path pref-url)]
[suff-path (simplify-url-path suff-url)])
(cond
[(null? pref-path) suff-path]
[(string=? (car pref-path) (car suff-path))
(loop (cdr pref-path) (cdr suff-path))]
[else
(error "split-url-path: first path is not a preffix of the second")])))
)

67
collects/web-server/prototype-web-server/web-interaction.ss Normal file
View File

@ -0,0 +1,67 @@
(module web-interaction mzscheme
(require (rename "expander.ss" send/suspend0 send/suspend)
(all-except "expander.ss" send/suspend)
"utils.ss"
"session.ss"
(lib "request-parsing.ss" "web-server")
(lib "url.ss" "net"))
(provide (all-from-except mzscheme #%module-begin)
(rename lang-module-begin #%module-begin)
send/suspend
start-servlet)
;; start-servlet: -> request
;; set the initial interaction point for the servlet
(define (start-servlet)
(start-session dispatch)
(start-interaction
(lambda (req)
(or (url/id->continuation (request-uri req))
(lambda (req) (dispatch-start req))))))
;; send/suspend: (url -> response) -> request
;; the usual send/suspend
(define (send/suspend page-maker)
(send/suspend0
(lambda (k)
(page-maker (encode-k-id-in-url k)))))
;; **********************************************************************
;; **********************************************************************
;; CONTINUATION TABLES
(define k-table (make-hash-table))
;; continuation->number: continuation -> number
;; store a continuation and provide the key
(define continuation->number
(let ([n 0])
(lambda (k)
(set! n (add1 n))
(hash-table-put! k-table n k)
n)))
;; url/id->continuation: url -> (union continuation #f)
;; extract the key from the url and then lookup the continuation
(define (url/id->continuation req-uri)
(let ([ses-uri (session-url (current-session))])
(let ([url-path-suffix (split-url-path ses-uri req-uri)])
(and url-path-suffix
(not (null? url-path-suffix))
(hash-table-get k-table
(string->number (car url-path-suffix))
(lambda () #f))))))
;; encode-k-id-in-url: continuation -> url
;; encode a continuation id in a url
(define (encode-k-id-in-url k)
(let ([uri (session-url (current-session))])
(make-url
(url-scheme uri)
(url-user uri)
(url-host uri)
(url-port uri)
(append (url-path uri) (list (number->string (continuation->number k))))
(url-query uri)
(url-fragment uri))))
)