From 533ba8f173125f2f34dd7ffc020b38fbb2121d50 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 15 Aug 2008 18:49:52 +0000 Subject: [PATCH] Improving cont serialization and s/s/d svn: r11277 --- .../htdocs/lang-servlets/add05.ss | 31 -------- collects/web-server/lang/abort-resume.ss | 20 ++++-- collects/web-server/lang/lang-api.ss | 4 +- collects/web-server/lang/stuff-url.ss | 71 ++++++++++--------- collects/web-server/lang/web-extras.ss | 13 +--- collects/web-server/lang/web.ss | 39 ++++------ collects/web-server/private/gzip.ss | 20 ++++++ collects/web-server/private/md5-store.ss | 22 ++++++ collects/web-server/private/util.ss | 11 ++- collects/web-server/scribblings/lang.scrbl | 24 +++---- collects/web-server/scribblings/private.scrbl | 12 ++++ .../tests/dispatchers/dispatch-lang-test.ss | 12 ++-- 12 files changed, 145 insertions(+), 134 deletions(-) delete mode 100644 collects/web-server/default-web-root/htdocs/lang-servlets/add05.ss create mode 100644 collects/web-server/private/gzip.ss create mode 100644 collects/web-server/private/md5-store.ss diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add05.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add05.ss deleted file mode 100644 index 2ea32c7c0d..0000000000 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add05.ss +++ /dev/null @@ -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"))))))) diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index c5a3d217a3..1e5ff5edf7 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -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) diff --git a/collects/web-server/lang/lang-api.ss b/collects/web-server/lang/lang-api.ss index 24205805ce..aeaf251aee 100644 --- a/collects/web-server/lang/lang-api.ss +++ b/collects/web-server/lang/lang-api.ss @@ -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") diff --git a/collects/web-server/lang/stuff-url.ss b/collects/web-server/lang/stuff-url.ss index 7181c9523e..0e02515a78 100644 --- a/collects/web-server/lang/stuff-url.ss +++ b/collects/web-server/lang/stuff-url.ss @@ -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)])) \ No newline at end of file diff --git a/collects/web-server/lang/web-extras.ss b/collects/web-server/lang/web-extras.ss index 32abc17302..10021c325a 100644 --- a/collects/web-server/lang/web-extras.ss +++ b/collects/web-server/lang/web-extras.ss @@ -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)))) diff --git a/collects/web-server/lang/web.ss b/collects/web-server/lang/web.ss index d564948756..4f2549d648 100644 --- a/collects/web-server/lang/web.ss +++ b/collects/web-server/lang/web.ss @@ -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 diff --git a/collects/web-server/private/gzip.ss b/collects/web-server/private/gzip.ss new file mode 100644 index 0000000000..10ac3ef9d7 --- /dev/null +++ b/collects/web-server/private/gzip.ss @@ -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)) \ No newline at end of file diff --git a/collects/web-server/private/md5-store.ss b/collects/web-server/private/md5-store.ss new file mode 100644 index 0000000000..c15a66ac92 --- /dev/null +++ b/collects/web-server/private/md5-store.ss @@ -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)))) diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss index 3182371845..4830ac89c0 100644 --- a/collects/web-server/private/util.ss +++ b/collects/web-server/private/util.ss @@ -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]) diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index 8df821d0ea..f65ec7c052 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.scrbl @@ -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?] )]{ diff --git a/collects/web-server/scribblings/private.scrbl b/collects/web-server/scribblings/private.scrbl index 9cfbb90c0b..49dd064fd9 100644 --- a/collects/web-server/scribblings/private.scrbl +++ b/collects/web-server/scribblings/private.scrbl @@ -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. +} diff --git a/collects/web-server/tests/dispatchers/dispatch-lang-test.ss b/collects/web-server/tests/dispatchers/dispatch-lang-test.ss index 5fbeecff74..6c6988f157 100644 --- a/collects/web-server/tests/dispatchers/dispatch-lang-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-lang-test.ss @@ -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"))))))