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

Improving cont serialization and s/s/d

Browse Source 
svn: r11277
This commit is contained in:
Jay McCarthy 2008-08-15 18:49:52 +00:00
parent b9d99f69fa
commit 533ba8f173
12 changed files with 145 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/web-server/default-web-root/htdocs/lang-servlets/add05.ss
View File

@ -1,31 +0,0 @@
#lang web-server
(provide start)
;; get-number-from-user: string -> number
;; ask the user for a number
(define (gn msg)
(extract-proc/url
(send/suspend/url
(lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string
(embed-proc/url
k-url
(lambda (req)
(string->number
(bytes->string/utf-8
(binding:form-value
(bindings-assq #"number"
(request-bindings/raw req))))))))]
[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"])))))))))
(define (start initial-request)
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a" (+ (gn "first") (gn "second")))))))

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

@ -16,6 +16,7 @@
the-undef
activation-record-list
current-saved-continuation-marks-and
kont-append-fun
;; "SERVLET" INTERFACE
send/suspend
@ -37,12 +38,12 @@
(reverse
(list* (cons key val)
(filter (lambda (k*v) (not (equal? key (car k*v))))
(let-values ([(current)
(continuation-mark-set->list (current-continuation-marks web-prompt)
the-save-cm-key)])
(if (empty? current)
empty
(first current)))))))
(let-values ([(current)
(continuation-mark-set->list (current-continuation-marks web-prompt)
the-save-cm-key)])
(if (empty? current)
empty
(first current)))))))
;; current-continuation-as-list: -> (listof value)
;; check the safety marks and return the list of marks representing the continuation
@ -129,6 +130,13 @@
(restore-web-cell-set! wcs)
(resume current-marks x))))
(define (kont-append-fun k f)
(define-values (wcs current-marks) ((kont-env k)))
(make-kont
(lambda ()
(values wcs
(append current-marks (list (vector f #f)))))))
;; send/suspend: (continuation -> response) -> request
;; produce the current response and wait for the next request
(define (send/suspend response-maker)

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

@ -1,4 +1,4 @@
#lang scheme/base
#lang scheme
(require net/url
"../private/request-structs.ss"
"../private/response-structs.ss"
@ -9,7 +9,7 @@
"web-param.ss"
"file-box.ss"
"web-extras.ss")
(provide (except-out (all-from-out scheme/base) #%module-begin)
(provide (except-out (all-from-out scheme) #%module-begin)
(all-from-out net/url)
(all-from-out "../private/request-structs.ss")
(all-from-out "../private/response-structs.ss")

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

@ -1,50 +1,57 @@
#lang scheme/base
(require mzlib/contract
net/url
mzlib/serialize
#lang scheme
(require net/url
scheme/serialize
web-server/private/md5-store
web-server/private/gzip
"../private/util.ss"
"../private/url-param.ss"
"../private/mod-map.ss")
; XXX url: first try continuation, then turn into hash
; XXX different ways to hash, different ways to store (maybe cookie?)
(provide/contract
[url-too-big? (url? . -> . boolean?)]
[stuff-url (serializable? url? . -> . url?)]
[stuffed-url? (url? . -> . boolean?)]
[unstuff-url (url? . -> . serializable?)])
; XXX Abstract this
(require mzlib/md5)
(define (md5-store str)
(define hash (md5 (string->bytes/utf-8 str)))
(with-output-to-file
(build-path (find-system-path 'home-dir) ".urls" (format "~a" hash))
(lambda ()
(write str))
#:exists 'replace)
(bytes->string/utf-8 hash))
(define (md5-lookup hash)
(with-input-from-file
(build-path (find-system-path 'home-dir) ".urls" (format "~a" hash))
(lambda () (read))))
(define (url-too-big? uri)
((string-length (url->string uri)) . > . 1024))
;; stuff-url: serial url -> url
;; encode in the url
(define (stuff-url svl uri)
(define result-uri
(insert-param uri "c" (md5-store (write/string (compress-serial (serialize svl))))))
(when (> (string-length (url->string result-uri))
1024)
(error "the url is too big: " (url->string result-uri)))
result-uri)
(require net/base64)
(define (stuff-url c uri)
(let* ([cb (c->bytes c)]
[cb-uri (insert-param uri "c" (bytes->string/utf-8 (base64-encode cb)))])
(if (url-too-big? cb-uri)
(let* ([cc (gzip/bytes cb)]
[cc-uri (insert-param uri "cc" (bytes->string/utf-8 (base64-encode cc)))])
(if (url-too-big? cc-uri)
(let* ([hc (md5-store cc)]
[hc-uri (insert-param uri "hc" (bytes->string/utf-8 hc))])
(if (url-too-big? hc-uri)
(error 'stuff-url "Continuation too big: ~a" c)
hc-uri))
cc-uri))
cb-uri)))
(define (stuffed-url? uri)
(and (extract-param uri "c")
(and (or (extract-param uri "c")
(extract-param uri "cc")
(extract-param uri "hc"))
#t))
(define (c->bytes c)
(write/bytes (compress-serial (serialize c))))
(define (bytes->c b)
(deserialize (decompress-serial (read/bytes b))))
;; unstuff-url: url -> serial
;; decode from the url and reconstruct the serial
(define (unstuff-url req-url)
(deserialize (decompress-serial (read/string (md5-lookup (extract-param req-url "c"))))))
(define (unstuff-url uri)
(cond
[(extract-param uri "c")
=> (compose bytes->c base64-decode string->bytes/utf-8)]
[(extract-param uri "cc")
=> (compose bytes->c gunzip/bytes base64-decode string->bytes/utf-8)]
[(extract-param uri "hc")
=> (compose bytes->c gunzip/bytes md5-lookup string->bytes/utf-8)]))

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

@ -3,18 +3,7 @@
(for-template "web.ss")
"web.ss"
"../servlet/helpers.ss")
(provide send/suspend/dispatch
redirect/get)
(define-syntax send/suspend/dispatch
(syntax-rules ()
[(_ response-generator)
(extract-proc/url
(send/suspend/url
(lambda (k-url)
(response-generator
(lambda (proc)
(embed-proc/url k-url proc))))))]))
(provide redirect/get)
(define (redirect/get)
(send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily))))

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

@ -1,7 +1,7 @@
#lang scheme/base
(require mzlib/serialize
mzlib/plt-match
net/url
#lang scheme
(require net/url
scheme/serialize
web-server/private/define-closure
"../private/request-structs.ss"
"abort-resume.ss"
"../private/session.ss"
@ -15,8 +15,7 @@
;; Servlet Interface
send/suspend/hidden
send/suspend/url
extract-proc/url
embed-proc/url)
send/suspend/dispatch)
;; initial-servlet : (request -> response) -> (request -> response?)
(define (initialize-servlet start)
@ -53,27 +52,13 @@
(stuff-url k
(session-url (current-session)))))))
; XXX Don't use stuff-url, but use the other serialize thing
(define embed-label "superkont")
(define (embed-proc/url k-url proc)
(define superkont-url
(stuff-url proc
(session-url (current-session))))
(define result-uri
(insert-param k-url embed-label
(url->string superkont-url)))
(begin0 result-uri
(when (> (string-length (url->string result-uri))
1024)
(error "the url is too big: " (url->string result-uri)))))
(define (extract-proc/url request)
(define req-url (request-uri request))
(define maybe-embedding (extract-param req-url embed-label))
(if maybe-embedding
(let ([proc (unstuff-url
(string->url maybe-embedding))])
(proc request))
(error 'send/suspend/dispatch "No ~a: ~S!" embed-label)))
(define-closure embed/url (proc) (k)
(stuff-url (kont-append-fun k proc)
(session-url (current-session))))
(define (send/suspend/dispatch response-generator)
(send/suspend
(lambda (k)
(response-generator (make-embed/url (lambda () k))))))
;; request->continuation: req -> continuation
;; decode the continuation from the hidden field of a request

20
collects/web-server/private/gzip.ss Normal file
View File

@ -0,0 +1,20 @@
#lang scheme
(require file/gzip
file/gunzip)
(provide/contract
[gzip/bytes (bytes? . -> . bytes?)]
[gunzip/bytes (bytes? . -> . bytes?)])
(define (gzip/bytes b)
(define gzb-p (open-output-bytes))
(gzip-through-ports
(open-input-bytes b)
gzb-p #f (current-seconds))
(get-output-bytes gzb-p))
(define (gunzip/bytes gzb)
(define b-p (open-output-bytes))
(gunzip-through-ports
(open-input-bytes gzb) b-p)
(get-output-bytes b-p))

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

@ -0,0 +1,22 @@
#lang scheme
(require file/md5)
(provide/contract
[md5-home (parameter/c path?)]
[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))))

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

@ -28,7 +28,9 @@
[exn->string ((or/c exn? any/c) . -> . string?)]
[build-path-unless-absolute (path-string? path-string? . -> . path?)]
[read/string (string? . -> . serializable?)]
[write/string (serializable? . -> . string?)])
[write/string (serializable? . -> . string?)]
[read/bytes (bytes? . -> . serializable?)]
[write/bytes (serializable? . -> . bytes?)])
(define (pretty-print-invalid-xexpr exn xexpr)
(define code (exn:invalid-xexpr-code exn))
@ -51,6 +53,13 @@
(write v str)
(get-output-string str))
(define (read/bytes bs)
(read (open-input-bytes bs)))
(define (write/bytes v)
(define by (open-output-bytes))
(write v by)
(get-output-bytes by))
; explode-path* : path? -> (listof path?)
(define (explode-path* p)
(let loop ([p p] [r empty])

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

@ -134,18 +134,12 @@ by the Web language API.
Note: The continuation is NOT stuffed.
}
@defproc[(embed-proc/url [k-url url?]
[proc (request? . -> . any/c)])
url?]{
Serializes and stuffs @scheme[proc] into @scheme[k-url]. For use with
@scheme[extract-proc/url].
}
@defproc[(extract-proc/url [req request?])
@defproc[(send/suspend/dispatch [make-response (embed/url? . -> . response?)])
any/c]{
Inspects the URL of @scheme[req] and attempts to extract the procedure
embedded with @scheme[embed-proc/url]. If successful, it is invoked with
@scheme[req] as an argument.
Calls @scheme[make-response] with a function that, when called with a procedure from
@scheme[request?] to @scheme[any/c] will generate a URL, that when invoked will call
the function with the @scheme[request?] object and return the result to the caller of
@scheme[send/suspend/dispatch].
}
@; ------------------------------------------------------------
@ -192,13 +186,11 @@ In the future, we will offer the facilities to:
@defmodule[web-server/lang/web-extras]{The
@schememodname[web-server/lang/web-extras] library provides
@scheme[send/suspend/dispatch] and @scheme[redirect/get] as
@schememodname[web-server/servlet/web], except they use
@scheme[embed-proc/url] plus @scheme[extract-proc/url] and
@scheme[send/suspend/url], respectively.}
@scheme[redirect/get] as
@schememodname[web-server/servlet/web] except it uses
@scheme[send/suspend/url].}
@deftogether[(
@defform[(send/suspend/dispatch response-proc-expr)]
@defproc[(redirect/get) request?]
)]{

12
collects/web-server/scribblings/private.scrbl
View File

@ -419,3 +419,15 @@ needs. They are provided by @filepath{private/util.ss}.
string?]{
@scheme[write]s @scheme[v] to a string and returns it.
}
@subsection{Bytes}
@defproc[(read/bytes [b bytes?])
serializable?]{
@scheme[read]s a value from @scheme[b] and returns it.
}
@defproc[(write/bytes [v serializable?])
bytes?]{
@scheme[write]s @scheme[v] to a bytes and returns it.
}

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

@ -119,11 +119,7 @@
(test-add-two-numbers
"add04.ss - s/s/u"
(build-path example-servlets "add04.ss"))
(test-add-two-numbers
"add05.ss - extract-proc/url and embed-proc/url"
(build-path example-servlets "add05.ss"))
(build-path example-servlets "add04.ss"))
(test-add-two-numbers
"add06.ss - send/suspend/dispatch"
@ -153,7 +149,8 @@
(let* ([d (mkd (build-path example-servlets "quiz01.ss"))]
[last
(foldl (lambda (_ k)
(first ((sxpath "//form/@action/text()") (call d k (list (make-binding:form #"answer" #"0"))))))
(first ((sxpath "//form/@action/text()")
(call d k (list (make-binding:form #"answer" #"0"))))))
url0
(build-list 7 (lambda (i) i)))])
(first ((sxpath "//h1/text()") (call d last (list (make-binding:form #"answer" #"0"))))))
@ -163,7 +160,8 @@
(let* ([d (mkd (build-path example-servlets "quiz02.ss"))]
[last
(foldl (lambda (_ k)
(first ((sxpath "//form/@action/text()") (call d k (list (make-binding:form #"answer" #"0"))))))
(first ((sxpath "//form/@action/text()")
(call d k (list (make-binding:form #"answer" #"0"))))))
url0
(build-list 7 (lambda (i) i)))])
(first ((sxpath "//h1/text()") (call d last (list (make-binding:form #"answer" #"0"))))))