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

stuffers

Browse Source 
svn: r13474
This commit is contained in:
Jay McCarthy 2009-02-06 23:23:21 +00:00
parent 6a41a09fb6
commit fe078ee54b
24 changed files with 606 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/web-server/all-web-server-tests.ss
View File

@ -8,6 +8,7 @@
"http/all-http-tests.ss"
"private/all-private-tests.ss"
"servlet/all-servlet-tests.ss"
"stuffers-test.ss"
"servlet-env-test.ss")
(provide all-web-server-tests)
@ -15,6 +16,7 @@
(test-suite
"Web Server"
all-http-tests
all-stuffers-tests
all-configuration-tests
all-dispatchers-tests
all-lang-tests

3
collects/tests/web-server/lang/stuff-url-test.ss
View File

@ -1,12 +1,13 @@
#lang scheme/base
(require web-server/lang/stuff-url
web-server/stuffers
(planet "test.ss" ("schematics" "schemeunit.plt" 2))
net/url
mzlib/serialize
"../util.ss")
(provide stuff-url-tests)
(define uri0 (string->url "www.google.com"))
(define uri0 (string->url "www.google.com"))
(define test-stuffer serialize-stuffer)

103
collects/tests/web-server/stuffers-test.ss Normal file
View File

@ -0,0 +1,103 @@
#lang scheme
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
web-server/stuffers
web-server/private/servlet
web-server/http
net/url
scheme/serialize)
(provide all-stuffers-tests)
(define (stuffer-test s)
(define x (string->bytes/utf-8 (number->string (random 1000))))
(check-equal? ((stuffer-out s) ((stuffer-in s) x))
x))
(define (store-test s)
(define x (string->bytes/utf-8 (number->string (random 1000))))
(define y (string->bytes/utf-8 (number->string (random 1000))))
(check-equal? (begin ((store-write s) x y)
((store-read s) x))
y))
(define prep-stuffer
(make-stuffer
(lambda (v) (bytes-append #"20" v))
(lambda (v) (subbytes v 2))))
(define (context-wrap thnk)
(parameterize ([current-execution-context
(make-execution-context
(make-request #"GET" (string->url "http://www.google.com")
empty empty
#"" "127.0.0.1" 80
"127.0.0.1"))])
(thnk)))
(define all-stuffers-tests
(test-suite
"Stuffers"
(test-suite "stuffer"
(test-case "id-stuffer" (stuffer-test id-stuffer))
(test-case "stuffer-compose" (stuffer-test (stuffer-compose id-stuffer id-stuffer)))
(test-case "stuffer-compose" (stuffer-test (stuffer-compose prep-stuffer id-stuffer)))
(test-case "stuffer-compose" (stuffer-test (stuffer-compose id-stuffer prep-stuffer)))
(test-case "stuffer-compose" (stuffer-test (stuffer-compose prep-stuffer prep-stuffer)))
(test-case "stuffer-sequence" (stuffer-test (stuffer-sequence id-stuffer id-stuffer)))
(test-case "stuffer-sequence" (stuffer-test (stuffer-sequence prep-stuffer id-stuffer)))
(test-case "stuffer-sequence" (stuffer-test (stuffer-sequence id-stuffer prep-stuffer)))
(test-case "stuffer-sequence" (stuffer-test (stuffer-sequence prep-stuffer prep-stuffer)))
(test-case "stuffer-if" (stuffer-test (stuffer-if (lambda (v) #t) id-stuffer)))
(test-case "stuffer-if" (stuffer-test (stuffer-if (lambda (v) #f) id-stuffer)))
(test-case "stuffer-if" (stuffer-test (stuffer-if (lambda (v) #t) prep-stuffer)))
(test-case "stuffer-if" (stuffer-test (stuffer-if (lambda (v) #f) prep-stuffer)))
(test-case "stuffer-chain" (stuffer-test (stuffer-chain)))
(test-case "stuffer-chain" (stuffer-test (stuffer-chain (lambda (v) #f))))
(test-case "stuffer-chain" (stuffer-test (stuffer-chain (lambda (v) #f) prep-stuffer)))
(test-case "stuffer-chain" (stuffer-test (stuffer-chain prep-stuffer (lambda (v) #f) prep-stuffer))))
(test-suite "base64"
(test-case "base64-stuffer" (stuffer-test base64-stuffer)))
(test-suite "gzip"
(test-case "gzip-stuffer" (stuffer-test gzip-stuffer)))
(test-suite "serialize"
(test-case "serialize-stuffer" (stuffer-test serialize-stuffer)))
(test-suite "store"
(test-case "dir-store" (store-test (dir-store (find-system-path 'temp-dir)))))
(test-suite "hash"
(test-case "md5-stuffer" (stuffer-test (md5-stuffer (find-system-path 'temp-dir)))))
(test-suite "stuff-url"
(test-case "make-default-stuffer"
(context-wrap
(lambda ()
(stuffer-test (make-default-stuffer (find-system-path 'temp-dir))))))
(test-case "is-url-too-big?"
(context-wrap
(lambda ()
(check-false (is-url-too-big? (make-bytes 1 65))))))
(test-case "is-url-too-big?"
(context-wrap
(lambda ()
(check-false (is-url-too-big? (make-bytes 10 65))))))
(test-case "is-url-too-big?"
(context-wrap
(lambda ()
(check-false (is-url-too-big? (make-bytes 100 65))))))
(test-case "is-url-too-big?"
(context-wrap
(lambda ()
(check-false (is-url-too-big? (make-bytes 1000 65))))))
(test-case "is-url-too-big?"
(context-wrap
(lambda ()
(check-not-false (is-url-too-big? (make-bytes 3000 65)))))))))

34
collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss Normal file
View File

@ -0,0 +1,34 @@
#lang web-server
(define interface-version 'stateless)
(define stuffer
(stuffer-chain
serialize-stuffer
(md5-stuffer (build-path (find-system-path 'home-dir) ".urls"))))
(provide start interface-version stuffer)
;; 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
(bytes->string/utf-8
(binding:form-value
(bindings-assq #"number"
(request-bindings/raw req)))))))
(define (start initial-request)
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(+ (gn "first") (gn "second")))))))

2
collects/web-server/lang/lang-api.ss
View File

@ -1,6 +1,7 @@
#lang scheme
(require net/url
web-server/http
web-server/stuffers
web-server/lang/abort-resume
web-server/lang/web
web-server/lang/web-cells
@ -9,6 +10,7 @@
(provide (except-out (all-from-out scheme) #%module-begin)
(all-from-out net/url
web-server/http
web-server/stuffers
web-server/lang/abort-resume
web-server/lang/web
web-server/lang/web-cells

152
collects/web-server/lang/stuff-url.ss
View File

@ -1,110 +1,27 @@
#lang scheme
(require net/url
scheme/serialize
web-server/private/md5-store
web-server/private/gzip
web-server/private/servlet
web-server/stuffers/stuffer
web-server/stuffers/serialize
web-server/stuffers/gzip
web-server/stuffers/base64
web-server/stuffers/hash
web-server/http
"../private/util.ss"
"../private/url-param.ss"
"../private/mod-map.ss")
;; NEW
; A stuffer is
; - in : any -> bytes
; - out : bytes -> any
; such that
; out (in x) = x
; in (out x) = x
(define-struct stuffer (in out))
(define id-stuffer
(make-stuffer
(lambda (v) v)
(lambda (v) v)))
(define serialize-stuffer
(make-stuffer
(lambda (v) (write/bytes (compress-serial (serialize v))))
(lambda (v) (deserialize (decompress-serial (read/bytes v))))))
(define gzip-stuffer
(make-stuffer gzip/bytes gunzip/bytes))
(require net/base64)
(define base64-stuffer
(make-stuffer base64-encode base64-decode))
(define-struct store (write read))
(define (dir-store home)
(make-store
(lambda (key value)
(with-output-to-file
(build-path home (format "~a" key))
(lambda ()
(write value))
#:exists 'replace))
(lambda (key)
(with-input-from-file
(build-path home (format "~a" key))
(lambda () (read))))))
(define (hash-stuffer hash store)
(make-stuffer
(lambda (v)
(define hv (hash v))
((store-write store) hv v)
hv)
(lambda (hv)
((store-read store) hv))))
(require file/md5)
(define (md5-stuffer home)
(hash-stuffer md5 (dir-store home)))
(define (stuffer-compose g f)
(make-stuffer
(lambda (v)
((stuffer-in g) ((stuffer-in f) v)))
(lambda (v)
((stuffer-out f) ((stuffer-out g) v)))))
(define (stuffer-sequence f g)
(stuffer-compose g f))
(define (stuffer-if c f)
(make-stuffer
(lambda (v)
(if (c v)
(bytes-append #"1" ((stuffer-in f) v))
(bytes-append #"0" v)))
(lambda (tv)
(define tag (subbytes tv 0 1))
(define v (subbytes tv 1))
(if (bytes=? tag #"1")
((stuffer-out f) v)
v))))
(define (stuffer-chain . ss)
(match ss
[(list)
id-stuffer]
[(list-rest f ss)
(cond
[(stuffer? f)
(stuffer-sequence
f (apply stuffer-chain ss))]
[(procedure? f)
(stuffer-if
f (apply stuffer-chain ss))])]))
web-server/private/url-param)
(define (is-url-too-big? v)
(define uri
(request-uri (execution-context-request (current-execution-context))))
(url-too-big?
(do-url-stuff uri v)))
(request-uri
(execution-context-request
(current-execution-context))))
(> (string-length
(url->string
(insert-in-uri uri v)))
; http://www.boutell.com/newfaq/misc/urllength.html
2048))
(define default-stuffer
(define (make-default-stuffer home)
(stuffer-chain
serialize-stuffer
is-url-too-big?
@ -112,17 +29,20 @@
gzip-stuffer
base64-stuffer)
is-url-too-big?
(md5-stuffer (md5-home))))
(md5-stuffer home)))
(define default-stuffer
(make-default-stuffer
(build-path (find-system-path 'home-dir) ".urls")))
(define URL-KEY "c")
(define (do-url-stuff uri c)
(define (insert-in-uri uri c)
(insert-param uri URL-KEY (bytes->string/utf-8 c)))
(define (stuff-url stuffer uri c)
(do-url-stuff
uri
((stuffer-in stuffer) c)))
(insert-in-uri
uri ((stuffer-in stuffer) c)))
(define (stuffed-url? uri)
(string? (extract-param uri URL-KEY)))
@ -133,25 +53,9 @@
(extract-param uri URL-KEY))))
(provide/contract
[struct stuffer
([in (any/c . -> . bytes?)]
[out (bytes? . -> . any/c)])]
[id-stuffer stuffer?]
[serialize-stuffer stuffer?]
[default-stuffer stuffer?])
;; OLD
(provide/contract
[max-url-length (parameter/c number?)]
[url-too-big? (url? . -> . boolean?)]
[stuff-url (stuffer? url? serializable? . -> . url?)]
[default-stuffer (stuffer/c serializable? bytes?)]
[make-default-stuffer (path-string? . -> . (stuffer/c serializable? bytes?))]
[is-url-too-big? (bytes? . -> . boolean?)]
[stuff-url ((stuffer/c serializable? bytes?) url? serializable? . -> . url?)]
[stuffed-url? (url? . -> . boolean?)]
[unstuff-url (stuffer? url? . -> . serializable?)])
; http://www.boutell.com/newfaq/misc/urllength.html
(define max-url-length
(make-parameter 2048))
(define (url-too-big? uri)
((string-length (url->string uri)) . > . (max-url-length)))
[unstuff-url ((stuffer/c serializable? bytes?) url? . -> . serializable?)])

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

@ -5,10 +5,10 @@
web-server/http
web-server/managers/manager
web-server/private/define-closure
web-server/private/servlet
"abort-resume.ss"
"stuff-url.ss"
"../private/url-param.ss")
web-server/private/servlet
web-server/stuffers/stuffer
web-server/lang/abort-resume
web-server/lang/stuff-url)
(define-struct (stateless-servlet servlet) (stuffer))
@ -24,7 +24,7 @@
(provide/contract
[make-stateless-servlet
(custodian? namespace? manager? path-string? (request? . -> . response/c)
stuffer? . -> . stateless-servlet?)])
(stuffer/c serializable? bytes?) . -> . stateless-servlet?)])
; These contracts interfere with the continuation safety marks
#;(provide/contract
@ -57,10 +57,11 @@
(define (send/suspend/hidden page-maker)
(send/suspend
(lambda (k)
(let ([p-cont (serialize k)])
(page-maker
(request-uri (execution-context-request (current-execution-context)))
`(input ([type "hidden"] [name "kont"] [value ,(format "~s" p-cont)])))))))
(define stuffer (stateless-servlet-stuffer (current-servlet)))
(define p-cont ((stuffer-in stuffer) k))
(page-maker
(request-uri (execution-context-request (current-execution-context)))
`(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
@ -85,16 +86,17 @@
;; request->continuation: req -> continuation
;; decode the continuation from the hidden field of a request
(define (request->continuation req)
(define stuffer (stateless-servlet-stuffer (current-servlet)))
(or
; Look in url for c=<k>
(let* ([req-url (request-uri req)]
[stuffer (stateless-servlet-stuffer (current-servlet))])
(let ([req-url (request-uri req)])
(and (stuffed-url? req-url)
(unstuff-url stuffer req-url)))
; Look in query for kont=<k>
(match (bindings-assq #"kont" (request-bindings/raw req))
[(struct binding:form (id kont))
(deserialize (read (open-input-bytes kont)))]
((stuffer-out stuffer)
(read (open-input-bytes kont)))]
[_ #f])))
(provide/contract

22
collects/web-server/private/md5-store.ss
View File

@ -1,22 +0,0 @@
#lang scheme
(require file/md5)
(provide/contract
[md5-home (parameter/c path-string?)]
[md5-store (bytes? . -> . bytes?)]
[md5-lookup (bytes? . -> . bytes?)])
(define md5-home (make-parameter (build-path (find-system-path 'home-dir) ".urls")))
(define (md5-store bs)
(define hash (md5 bs))
(with-output-to-file
(build-path (md5-home) (format "~a" hash))
(lambda ()
(write bs))
#:exists 'replace)
hash)
(define (md5-lookup hash)
(with-input-from-file
(build-path (md5-home) (format "~a" hash))
(lambda () (read))))

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

@ -4,8 +4,7 @@
web-server/http)
(define servlet-prompt (make-continuation-prompt-tag 'servlet))
(define-struct servlet (custodian namespace manager directory handler)
#:mutable)
(define-struct servlet (custodian namespace manager directory [handler #:mutable]))
(define-struct execution-context (request))
(define current-servlet (make-parameter #f))

1
collects/web-server/scribblings/dummy-stateless-servlet.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(define interface-version #f)
(define stuffer #f)
(define start #f)
(provide (all-defined-out))

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

@ -36,14 +36,12 @@
@defproc[(send/suspend/hidden [response-generator (url? xexpr/c . -> . response/c)])
request?]{
Captures the current continuation. Serializes it and generates an INPUT
form that includes the serialization as a hidden form.
Captures the current continuation. Serializes it and stuffs it into a hidden INPUT
form element.
Calls @scheme[response-generator] with this URL and form field and delivers
the response to the client. If the URL is invoked with form data containing
the hidden form,
the request is returned to this continuation.
Note: The continuation is NOT stuffed.
}
@defproc[(send/suspend/dispatch [make-response (embed/url/c . -> . response/c)])
@ -59,50 +57,4 @@
)]{
See @schememodname[web-server/servlet/web].}
}
@; ------------------------------------------------------------
@;{
@section[#:tag "lang/stuff-url.ss"]{Stuff URL}
@(require (for-label web-server/lang/stuff-url))
@defmodule[web-server/lang/stuff-url]{
@filepath{lang/stuff-url.ss} provides an interface for "stuffing"
serializable values into URLs. Currently there is a particular
hard-coded behavior, but we hope to make it more flexible in
the future.
@defproc[(stuff-url [v serializable?]
[u url?])
url?]{
Returns a URL based on @scheme[u] with @scheme[v] serialized and "stuffed" into it.
The following steps are applied until the URL is short enough to be accepted by IE.
@itemize[
@item{Put the plain-text serialization in the URL.}
@item{Compress the serialization with @schememodname[file/gzip] into the URL.}
@item{Compute the MD5 of the compressed seralization and write it to
@filepath{$HOME/.urls/M} where `M' is the MD5. `M' is then
placed in the URL}
]
}
@defproc[(stuffed-url? [u url?])
boolean?]{
Checks if @scheme[u] appears to be produced by @scheme[stuff-url].
}
@defproc[(unstuff-url [u url?])
serializable?]{
Extracts the value previously serialized into @scheme[u] by @scheme[stuff-url].
}
In the future, we will offer the facilities to:
@itemize[
@item{Optionally use the content-addressed storage.}
@item{Use different hashing algorithms for the CAS.}
@item{Encrypt the serialized value.}
@item{Only use the CAS if the URL would be too long. (URLs may only be 1024 characters.)}
]
}
;}
}

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

@ -11,6 +11,8 @@
web-server/configuration/configuration-table
web-server/configuration/responders
web-server/dispatchers/dispatch-log
scheme/serialize
web-server/stuffers
scheme/list))
@defmodule[web-server/servlet-env]{
@ -97,6 +99,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
"^~a$"
(regexp-quote servlet-path)))]
[#:stateless? stateless? boolean? #f]
[#:stuffer stuffer (stuffer/c serializable? bytes?) default-stuffer]
[#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))]
[#:servlet-namespace servlet-namespace (listof module-path?) empty]
[#:server-root-path server-root-path path-string? default-server-root-path]
@ -124,7 +127,8 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
If @scheme[quit?] is true, then the URL @filepath["/quit"] ends the server.
If @scheme[stateless?] is true, then the servlet is run as a stateless @schememodname[web-server] module.
If @scheme[stateless?] is true, then the servlet is run as a stateless @schememod[web-server] module and @scheme[stuffer] is used
as the @tech{stuffer}.
Advanced users may need the following options:
@ -162,6 +166,7 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
[start (request? . -> . response/c)]
[#:regexp regexp regexp? #rx""]
[#:stateless? stateless? boolean? #f]
[#:stuffer stuffer (stuffer/c serializable? bytes?) default-stuffer]
[#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))]
[#:namespace namespace (listof module-path?) empty]
[#:current-directory servlet-current-directory path-string? (current-directory)])
@ -173,7 +178,8 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server,
The dispatcher responds to requests that match @scheme[regexp]. The current directory
of servlet execution is @scheme[servlet-current-directory].
If @scheme[stateless?] is true, then the servlet is run as a stateless @schememodname[web-server] module.
If @scheme[stateless?] is true, then the servlet is run as a stateless @schememod[web-server] module and @scheme[stuffer] is used
as the @tech{stuffer}.
The servlet is loaded with @scheme[manager] as its continuation manager. (The default manager limits the amount of memory to 64 MB and
deals with memory pressure as discussed in the @scheme[make-threshold-LRU-manager] documentation.)

14
collects/web-server/scribblings/stateless-servlet.scrbl
View File

@ -4,13 +4,21 @@
@title[#:tag "stateless-servlets"]{Stateless Servlets}
@(require (for-label web-server/http
"dummy-stateless-servlet.ss")) @; to give a binding context
scheme/serialize
web-server/stuffers
(except-in "dummy-stateless-servlet.ss" stuffer))) @; to give a binding context
@declare-exporting[#:use-sources (web-server/scribblings/dummy-stateless-servlet)]
@defthing[interface-version (one-of/c 'stateless)]{
This indicates that the servlet is a stateless servlet.
}
@defthing[stuffer (stuffer/c serializable? bytes?)]{
This is the @scheme[stuffer] that will be used for the servlet.
If it is not provided, it defaults to @scheme[default-stuffer].
}
@defproc[(start [initial-request request?])
response/c]{
This function is called when an instance of this servlet is started.
@ -21,6 +29,10 @@ An example @scheme['stateless] servlet module:
@schememod[
web-server
(define interface-version 'stateless)
(define stuffer
(stuffer-chain
serialize-stuffer
(md5-stuffer (build-path (find-system-path 'home-dir) ".urls"))))
(define (start req)
`(html (body (h2 "Look ma, no state!"))))
]

196
collects/web-server/scribblings/stuffers.scrbl Normal file
View File

@ -0,0 +1,196 @@
#lang scribble/doc
@(require "web-server.ss")
@(require
(for-label
web-server/stuffers/stuffer
web-server/stuffers/base64
web-server/stuffers/gzip
web-server/stuffers/hash
web-server/stuffers/serialize
web-server/stuffers/store
(only-in web-server/lang/stuff-url
default-stuffer
make-default-stuffer
is-url-too-big?)))
@title[#:tag "stuffers.ss"]{Stuffers}
@defmodule[web-server/stuffers]
The @schememod[web-server] module language provides serializable continuations.
The serialization functionality is abstracted into @deftech{stuffers} that control how it operates.
You can supply your own (built with these functions) when you write a stateless servlet.
@section{Basic Combinators}
@defmodule[web-server/stuffers/stuffer]{
@defstruct[stuffer ([in (any/c . -> . any/c)]
[out (any/c . -> . any/c)])]{
A @tech{stuffer} is essentially an invertible function captured in this structure.
The following should hold:
@schemeblock[
(out (in x)) = x
(in (out x)) = x
]
}
@defproc[(stuffer/c [dom any/c] [rng any/c])
contract?]{
Constructs a contract for a @tech{stuffer} where @scheme[in] has
the contract @scheme[(dom . -> . rng)] and @scheme[out] has the contract
@scheme[(rng . -> . dom)].
}
@defthing[id-stuffer (stuffer/c any/c any/c)]{
The identitiy @tech{stuffer}.
}
@defproc[(stuffer-compose [g (stuffer any/c any/c)]
[f (stuffer any/c any/c)])
(stuffer any/c any/c)]{
Composes @scheme[f] and @scheme[g], i.e., applies @scheme[f] then @scheme[g] for @scheme[in]
and @scheme[g] then @scheme[f] for @scheme[out].
}
@defproc[(stuffer-sequence [f (stuffer any/c any/c)]
[g (stuffer any/c any/c)])
(stuffer any/c any/c)]{
@scheme[stuffer-compose] with arguments swapped.
}
@defproc[(stuffer-if [c (bytes? . -> . boolean?)]
[f (stuffer bytes? bytes?)])
(stuffer bytes? bytes?)]{
Creates a @tech{stuffer} that stuffs with @scheme[f] if @scheme[c] is true on the input
to @scheme[in]. Similarly, applies @scheme[f] during @scheme[out] if it was applied during
@scheme[in] (which is recorded by prepending a byte.)
}
@defproc[(stuffer-chain [x (or/c stuffer? (bytes? . -> . boolean?))]
...)
stuffer?]{
Applies @scheme[stuffer-sequence] and @scheme[stuffer-if] to successive tails of @scheme[x].
}
}
@section{Serialization}
@(require (for-label scheme/serialize
web-server/private/util))
@defmodule[web-server/stuffers/serialize]{
@defthing[serialize-stuffer (stuffer/c serializable? bytes?)]{
A @tech{stuffer} that uses @scheme[serialize] and @scheme[write/bytes] and @scheme[deserialize] and @scheme[read/bytes].
}
}
@section{Base64 Encoding}
@(require (for-label net/base64))
@defmodule[web-server/stuffers/base64]{
@defthing[base64-stuffer (stuffer/c bytes? bytes?)]{
A @tech{stuffer} that uses @scheme[base64-encode] and @scheme[base64-decode].
Useful for getting URL-safe bytes.
}
}
@section{GZip Compression}
@(require (for-label file/gzip file/gunzip))
@defmodule[web-server/stuffers/gzip]{
@defthing[gzip-stuffer (stuffer/c bytes? bytes?)]{
A @tech{stuffer} that uses @schememodname[file/gzip] and @schememodname[file/gunzip].
Note: You should probably compose this with @scheme[base64-stuffer] to get URL-safe bytes.
}
}
@section{Key/Value Storage}
The @schememodname[web-server/stuffers/hash] @tech{stuffers} rely on a key/value store.
@defmodule[web-server/stuffers/store]{
@defstruct[store ([write (bytes? bytes? . -> . void)]
[read (bytes? . -> . bytes?)])]{
The following should hold:
@schemeblock[
(begin (write k v) (read k)) = v
]
}
@defproc[(dir-store [root path-string?])
store?]{
A store that stores key @scheme[key]'s value in a file located at @scheme[(build-path root (bytes->string/utf-8 key))].
}
It should be easy to use this interface to create store for databases, like SQLite, CouchDB, or BerkeleyDB.
}
@section{Hash-addressed Storage}
@(require (for-label file/md5))
@defmodule[web-server/stuffers/hash]{
@defthing[hash/c contract?]{
Equivalent to @scheme[(bytes? . -> . bytes?)].
}
@defproc[(hash-stuffer [H hash/c]
[store store?])
(stuffer/c bytes? bytes?)]{
A content-addressed storage @tech{stuffer} that stores input bytes, @scheme[input], in @scheme[store] with the key @scheme[(H input)]
and returns the key. Similarly, on @scheme[out] the original bytes are looked up.
}
@defproc[(md5-stuffer [root path-string?])
(stuffer/c bytes? bytes?)]{
Equivalent to @scheme[(hash-stuffer md5 (dir-store root))]
}
}
@section{Helpers}
@defmodule[web-server/lang/stuff-url]{
@defproc[(is-url-too-big? [v bytes?])
boolean?]{
Determines if stuffing @scheme[v] into the current servlet's URL would result in a URL that is too big for Internet Explorer.
(@link["http://www.boutell.com/newfaq/misc/urllength.html"]{IE only supports URLs up to 2048 characters.}).
}
@defproc[(make-default-stuffer [root path-string?])
(stuffer/c serializable? bytes?)]{
Constructs a @tech{stuffer} that serializes, then if the URL is too big, compresses (and base64-encodes), if the URL is still too big
then it stores it in an MD5-indexed database rooted at @scheme[root].
Equivalent to:
@schemeblock[
(stuffer-chain
serialize-stuffer
is-url-too-big?
(stuffer-chain
gzip-stuffer
base64-stuffer)
is-url-too-big?
(md5-stuffer root))
]
}
@defthing[default-stuffer (stuffer/c serializable? bytes?)]{
Equivalent to @scheme[(make-default-stuffer
(build-path (find-system-path 'home-dir) ".urls"))].
}
}

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

@ -33,6 +33,7 @@ This API provides:
@itemize{
@item{@schememodname[net/url],}
@item{@schememodname[web-server/http],}
@item{@schememodname[web-server/stuffers],}
@item{@schememodname[web-server/lang/abort-resume],}
@item{@schememodname[web-server/lang/web],}
@item{@schememodname[web-server/lang/web-cells],}
@ -167,3 +168,4 @@ things in the Web Language, they are sensitive to source code modification.
@include-section["formlets.scrbl"]
@include-section["templates.scrbl"]
@include-section["managers.scrbl"]
@include-section["stuffers.scrbl"]

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

@ -5,6 +5,7 @@
scheme/contract
scheme/list
scheme/unit
scheme/serialize
net/tcp-unit
net/tcp-sig
scheme/runtime-path
@ -14,6 +15,7 @@
web-server/managers/manager
web-server/configuration/namespace
web-server/http
web-server/stuffers
web-server/configuration/responders
web-server/private/mime-types
web-server/servlet/setup
@ -48,6 +50,7 @@
#:current-directory path-string?
#:namespace (listof module-path?)
#:stateless? boolean?
#:stuffer (stuffer/c serializable? bytes?)
#:manager manager?)
. ->* .
dispatcher/c)]
@ -71,6 +74,7 @@
#:servlet-namespace (listof module-path?)
#:server-root-path path-string?
#:stateless? boolean?
#:stuffer (stuffer/c serializable? bytes?)
#:extra-files-paths (listof path-string?)
#:servlets-root path-string?
#:servlet-current-directory path-string?
@ -101,6 +105,8 @@
[servlet-namespace empty]
#:stateless?
[stateless? #f]
#:stuffer
[stuffer default-stuffer]
#:manager
[manager
(make-threshold-LRU-manager
@ -123,7 +129,7 @@
#:additional-specs
default-module-specs)])
(if stateless?
(make-stateless.servlet servlet-current-directory start)
(make-stateless.servlet servlet-current-directory stuffer start)
(make-v2.servlet servlet-current-directory manager start)))])
(set-box! servlet-box servlet)
servlet))))))
@ -210,6 +216,8 @@
[servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))]
#:stateless?
[stateless? #f]
#:stuffer
[stuffer default-stuffer]
#:servlet-namespace
[servlet-namespace empty]
@ -245,6 +253,7 @@
#:regexp servlet-regexp
#:namespace servlet-namespace
#:stateless? stateless?
#:stuffer stuffer
#:current-directory servlet-current-directory
#:manager manager)
(let-values ([(clear-cache! url->servlet)

22
collects/web-server/servlet/setup.ss
View File

@ -1,10 +1,10 @@
#lang scheme/base
(require mzlib/plt-match
scheme/contract)
(require web-server/managers/manager
#lang scheme
(require scheme/serialize
web-server/managers/manager
web-server/managers/timeouts
web-server/managers/none
web-server/lang/stuff-url
web-server/stuffers/stuffer
(only-in web-server/lang/web
initialize-servlet
make-stateless-servlet)
@ -67,14 +67,14 @@
(parameterize ([current-servlet-instance-id instance-id])
(handler req))))))
(define (make-stateless.servlet directory start)
(define (make-stateless.servlet directory stuffer start)
(define ses
(make-stateless-servlet
(current-custodian) (current-namespace)
(create-none-manager (lambda (req) (error "No continuations!")))
directory
(lambda (req) (error "Session not initialized"))
default-stuffer))
stuffer))
(parameterize ([current-directory directory]
[current-servlet ses])
(set-servlet-handler! ses (initialize-servlet start)))
@ -110,7 +110,7 @@
(provide/contract
[make-v1.servlet (path-string? integer? (request? . -> . response/c) . -> . servlet?)]
[make-v2.servlet (path-string? manager? (request? . -> . response/c) . -> . servlet?)]
[make-stateless.servlet (path-string? (request? . -> . response/c) . -> . servlet?)]
[make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) (request? . -> . response/c) . -> . servlet?)]
[default-module-specs (listof (or/c resolved-module-path? module-path?))])
(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
@ -162,8 +162,12 @@
(let ([start (contract (request? . -> . response/c)
(dynamic-require module-name 'start)
pos-blame neg-blame
(mk-loc "start"))])
(make-stateless.servlet (directory-part a-path) start))]))]
(mk-loc "start"))]
[stuffer (contract (stuffer/c serializable? bytes?)
(dynamic-require module-name 'stuffer (lambda () default-stuffer))
pos-blame neg-blame
(mk-loc "stuffer"))])
(make-stateless.servlet (directory-part a-path) stuffer start))]))]
[else
(make-v1.servlet (directory-part a-path) timeouts-default-servlet
(v0.response->v1.lambda

19
collects/web-server/stuffers.ss Normal file
View File

@ -0,0 +1,19 @@
#lang scheme
(require web-server/stuffers/stuffer
web-server/stuffers/base64
web-server/stuffers/gzip
web-server/stuffers/hash
web-server/stuffers/serialize
web-server/stuffers/store
(only-in web-server/lang/stuff-url
default-stuffer
make-default-stuffer
is-url-too-big?))
(provide
(all-from-out web-server/stuffers/stuffer
web-server/stuffers/base64
web-server/stuffers/gzip
web-server/stuffers/hash
web-server/stuffers/serialize
web-server/stuffers/store
web-server/lang/stuff-url))

9
collects/web-server/stuffers/base64.ss Normal file
View File

@ -0,0 +1,9 @@
#lang scheme
(require web-server/stuffers/stuffer
net/base64)
(define base64-stuffer
(make-stuffer base64-encode base64-decode))
(provide/contract
[base64-stuffer (stuffer/c bytes? bytes?)])

9
collects/web-server/stuffers/gzip.ss Normal file
View File

@ -0,0 +1,9 @@
#lang scheme
(require web-server/private/gzip
web-server/stuffers/stuffer)
(define gzip-stuffer
(make-stuffer gzip/bytes gunzip/bytes))
(provide/contract
[gzip-stuffer (stuffer/c bytes? bytes?)])

24
collects/web-server/stuffers/hash.ss Normal file
View File

@ -0,0 +1,24 @@
#lang scheme
(require web-server/stuffers/stuffer
web-server/stuffers/store
file/md5)
(define hash/c
(bytes? . -> . bytes?))
(define (hash-stuffer hash store)
(make-stuffer
(lambda (v)
(define hv (hash v))
((store-write store) hv v)
hv)
(lambda (hv)
((store-read store) hv))))
(define (md5-stuffer home)
(hash-stuffer md5 (dir-store home)))
(provide/contract
[hash/c contract?]
[hash-stuffer (hash/c store? . -> . (stuffer/c bytes? bytes?))]
[md5-stuffer (path-string? . -> . (stuffer/c bytes? bytes?))])

13
collects/web-server/stuffers/serialize.ss Normal file
View File

@ -0,0 +1,13 @@
#lang scheme
(require scheme/serialize
web-server/stuffers/stuffer
"../private/util.ss"
"../private/mod-map.ss")
(define serialize-stuffer
(make-stuffer
(lambda (v) (write/bytes (compress-serial (serialize v))))
(lambda (v) (deserialize (decompress-serial (read/bytes v))))))
(provide/contract
[serialize-stuffer (stuffer/c serializable? bytes?)])

20
collects/web-server/stuffers/store.ss Normal file
View File

@ -0,0 +1,20 @@
#lang scheme
(define-struct store (write read))
(define (dir-store home)
(make-store
(lambda (key value)
(with-output-to-file
(build-path home (bytes->string/utf-8 key))
(lambda ()
(write value))
#:exists 'replace))
(lambda (key)
(with-input-from-file
(build-path home (bytes->string/utf-8 key))
(lambda () (read))))))
(provide/contract
[struct store ([write (bytes? bytes? . -> . void)]
[read (bytes? . -> . bytes?)])]
[dir-store (path-string? . -> . store?)])

80
collects/web-server/stuffers/stuffer.ss Normal file
View File

@ -0,0 +1,80 @@
#lang scheme
(define-struct stuffer (in out))
(define (stuffer/c dom rng)
(define in (dom . -> . rng))
(define in-proc (contract-proc in))
(define out (rng . -> . dom))
(define out-proc (contract-proc out))
(make-proj-contract
(build-compound-type-name 'stuffer/c in out)
(λ (pos-blame neg-blame src-info orig-str)
(define in-app (in-proc pos-blame neg-blame src-info orig-str))
(define out-app (out-proc pos-blame neg-blame src-info orig-str))
(λ (val)
(unless (stuffer? val)
(raise-contract-error
val
src-info
pos-blame
'ignored
orig-str
"expected <stuffer>, given: ~e"
val))
(make-stuffer
(in-app (stuffer-in val))
(out-app (stuffer-out val)))))
stuffer?))
(define id-stuffer
(make-stuffer
(lambda (v) v)
(lambda (v) v)))
(define (stuffer-compose g f)
(make-stuffer
(lambda (v)
((stuffer-in g) ((stuffer-in f) v)))
(lambda (v)
((stuffer-out f) ((stuffer-out g) v)))))
(define (stuffer-sequence f g)
(stuffer-compose g f))
(define (stuffer-if c f)
(make-stuffer
(lambda (v)
(if (c v)
(bytes-append #"1" ((stuffer-in f) v))
(bytes-append #"0" v)))
(lambda (tv)
(define tag (subbytes tv 0 1))
(define v (subbytes tv 1))
(if (bytes=? tag #"1")
((stuffer-out f) v)
v))))
(define (stuffer-chain . ss)
(match ss
[(list)
id-stuffer]
[(list-rest f ss)
(cond
[(stuffer? f)
(stuffer-sequence
f (apply stuffer-chain ss))]
[(procedure? f)
(stuffer-if
f (apply stuffer-chain ss))])]))
(define-values (alpha beta gamma) (values any/c any/c any/c))
(provide/contract
[struct stuffer
([in (any/c . -> . any/c)]
[out (any/c . -> . any/c)])]
[stuffer/c (any/c any/c . -> . contract?)]
[id-stuffer (stuffer/c alpha alpha)]
[stuffer-compose ((stuffer/c beta gamma) (stuffer/c alpha beta) . -> . (stuffer/c alpha gamma))]
[stuffer-sequence ((stuffer/c alpha beta) (stuffer/c beta gamma) . -> . (stuffer/c alpha gamma))]
[stuffer-if ((bytes? . -> . boolean?) (stuffer/c bytes? bytes?) . -> . (stuffer/c bytes? bytes?))]
[stuffer-chain (() () #:rest (listof (or/c stuffer? (bytes? . -> . boolean?))) . ->* . stuffer?)])