From 4f952a65d2a01b7ec967b89c4f07a1449980865e Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 6 Feb 2009 19:58:50 +0000 Subject: [PATCH] abstracting stuffing svn: r13469 --- .../tests/web-server/lang/stuff-url-test.ss | 14 +- collects/web-server/lang/stuff-url.ss | 179 ++++++++++++++---- collects/web-server/lang/web.ss | 43 +++-- collects/web-server/scribblings/lang.scrbl | 2 + collects/web-server/servlet/setup.ss | 14 +- 5 files changed, 184 insertions(+), 68 deletions(-) diff --git a/collects/tests/web-server/lang/stuff-url-test.ss b/collects/tests/web-server/lang/stuff-url-test.ss index 319b009e3a..b2c8fcb86c 100644 --- a/collects/tests/web-server/lang/stuff-url-test.ss +++ b/collects/tests/web-server/lang/stuff-url-test.ss @@ -8,9 +8,11 @@ (define uri0 (string->url "www.google.com")) +(define test-stuffer serialize-stuffer) + (define (stuff-unstuff svl uri) - (let ([result-uri (stuff-url svl uri)]) - (unstuff-url result-uri))) + (let ([result-uri (stuff-url test-stuffer uri svl)]) + (unstuff-url test-stuffer result-uri))) (define (cidentity v) (deserialize (stuff-unstuff (serialize v) uri0))) @@ -37,10 +39,10 @@ (test-suite "stuffed-url? works" (test-case "Not stuffed URL" (check-false (stuffed-url? uri0))) - (test-case "Integers" (check-true (stuffed-url? (stuff-url (serialize 3) uri0)))) - (test-case "Symbols" (check-true (stuffed-url? (stuff-url (serialize 'foo) uri0)))) - (test-case "Strings" (check-true (stuffed-url? (stuff-url (serialize "Bar") uri0)))) - (test-case "Vectors" (check-true (stuffed-url? (stuff-url (serialize (vector 3 1 4)) uri0))))) + (test-case "Integers" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize 3))))) + (test-case "Symbols" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize 'foo))))) + (test-case "Strings" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize "Bar"))))) + (test-case "Vectors" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize (vector 3 1 4))))))) (test-case "Using stuff-url with lang.ss" diff --git a/collects/web-server/lang/stuff-url.ss b/collects/web-server/lang/stuff-url.ss index 3c435f4a0c..5693cf61d4 100644 --- a/collects/web-server/lang/stuff-url.ss +++ b/collects/web-server/lang/stuff-url.ss @@ -3,16 +3,151 @@ scheme/serialize web-server/private/md5-store web-server/private/gzip + web-server/private/servlet + 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))])])) + +(define (is-url-too-big? v) + (define uri + (request-uri (execution-context-request (current-execution-context)))) + (url-too-big? + (do-url-stuff uri v))) + +(define default-stuffer + (stuffer-chain + serialize-stuffer + is-url-too-big? + (stuffer-chain + gzip-stuffer + base64-stuffer) + is-url-too-big? + (md5-stuffer (md5-home)))) + +(define URL-KEY "c") + +(define (do-url-stuff 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))) + +(define (stuffed-url? uri) + (string? (extract-param uri URL-KEY))) + +(define (unstuff-url stuffer uri) + ((stuffer-out stuffer) + (string->bytes/utf-8 + (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 (serializable? url? . -> . url?)] + [stuff-url (stuffer? url? serializable? . -> . url?)] [stuffed-url? (url? . -> . boolean?)] - [unstuff-url (url? . -> . serializable?)]) + [unstuff-url (stuffer? url? . -> . serializable?)]) ; http://www.boutell.com/newfaq/misc/urllength.html (define max-url-length @@ -20,43 +155,3 @@ (define (url-too-big? uri) ((string-length (url->string uri)) . > . (max-url-length))) - -;; stuff-url: serial url -> url -;; encode in the url -(require net/base64) -(define (stuff-url c uri) - (let* ([cb (c->bytes c)] - [cb-uri (insert-param uri "c" (bytes->string/utf-8 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 (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 uri) - (cond - [(extract-param uri "c") - => (compose bytes->c 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)])) diff --git a/collects/web-server/lang/web.ss b/collects/web-server/lang/web.ss index 38e4baacb0..5552da0102 100644 --- a/collects/web-server/lang/web.ss +++ b/collects/web-server/lang/web.ss @@ -3,31 +3,39 @@ scheme/contract scheme/serialize 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") +(define-struct (stateless-servlet servlet) (stuffer)) + (provide ;; Server Interface - initialize-servlet + initialize-servlet ;; Servlet Interface send/suspend/hidden send/suspend/url send/suspend/dispatch) +(provide/contract + [make-stateless-servlet + (custodian? namespace? manager? path-string? (request? . -> . response/c) + stuffer? . -> . stateless-servlet?)]) + ; These contracts interfere with the continuation safety marks #;(provide/contract - ;; Server Interface - [initialize-servlet ((request? . -> . response/c) . -> . (request? . -> . response/c))] - - ;; Servlet Interface - [send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)] - [send/suspend/url ((url? . -> . response/c) . -> . request?)] - [send/suspend/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c) - . -> . any/c)]) + ;; Server Interface + [initialize-servlet ((request? . -> . response/c) . -> . (request? . -> . response/c))] + + ;; Servlet Interface + [send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)] + [send/suspend/url ((url? . -> . response/c) . -> . request?)] + [send/suspend/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c) + . -> . any/c)]) ;; initial-servlet : (request -> response) -> (request -> response/c) (define (initialize-servlet start) @@ -59,13 +67,16 @@ (define (send/suspend/url page-maker) (send/suspend (lambda (k) + (define stuffer (stateless-servlet-stuffer (current-servlet))) (page-maker - (stuff-url k - (request-uri (execution-context-request (current-execution-context)))))))) + (stuff-url stuffer + (request-uri (execution-context-request (current-execution-context))) + k))))) (define-closure embed/url (proc) (k) - (stuff-url (kont-append-fun k proc) - (request-uri (execution-context-request (current-execution-context))))) + (stuff-url (stateless-servlet-stuffer (current-servlet)) + (request-uri (execution-context-request (current-execution-context))) + (kont-append-fun k proc))) (define (send/suspend/dispatch response-generator) (send/suspend (lambda (k) @@ -76,10 +87,10 @@ (define (request->continuation req) (or ; Look in url for c= - (let ([req-url (request-uri req)]) + (let* ([req-url (request-uri req)] + [stuffer (stateless-servlet-stuffer (current-servlet))]) (and (stuffed-url? req-url) - (unstuff-url - req-url))) + (unstuff-url stuffer req-url))) ; Look in query for kont= (match (bindings-assq #"kont" (request-bindings/raw req)) [(struct binding:form (id kont)) diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index 35a9cdedc8..40efa6dbfc 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.scrbl @@ -62,6 +62,7 @@ See @schememodname[web-server/servlet/web].} } @; ------------------------------------------------------------ +@;{ @section[#:tag "lang/stuff-url.ss"]{Stuff URL} @(require (for-label web-server/lang/stuff-url)) @@ -104,3 +105,4 @@ In the future, we will offer the facilities to: @item{Only use the CAS if the URL would be too long. (URLs may only be 1024 characters.)} ] } +;} \ No newline at end of file diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index 2d6578686a..b1b7a7f85d 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -4,8 +4,10 @@ (require web-server/managers/manager web-server/managers/timeouts web-server/managers/none + web-server/lang/stuff-url (only-in web-server/lang/web - initialize-servlet) + initialize-servlet + make-stateless-servlet) web-server/http web-server/servlet/web web-server/configuration/namespace @@ -67,11 +69,12 @@ (define (make-stateless.servlet directory start) (define ses - (make-servlet + (make-stateless-servlet (current-custodian) (current-namespace) (create-none-manager (lambda (req) (error "No continuations!"))) directory - (lambda (req) (error "Session not initialized")))) + (lambda (req) (error "Session not initialized")) + default-stuffer)) (parameterize ([current-directory directory] [current-servlet ses]) (set-servlet-handler! ses (initialize-servlet start))) @@ -92,11 +95,14 @@ web-server/servlet/web-cells:module-path)) (define-runtime-module-path web-server/lang/web-cells:module-path web-server/lang/web-cells) +(define-runtime-module-path web-server/lang/web:module-path web-server/lang/web) (define-runtime-module-path web-server/lang/abort-resume:module-path web-server/lang/abort-resume) (define lang-module-specs (list web-server/lang/web-cells:module-path #;web-server/lang/abort-resume:module-path ; XXX Enabling results in error - 'web-server/lang/abort-resume)) + 'web-server/lang/abort-resume + #;web-server/lang/web:module-path ; XXX Enabling results in error + 'web-server/lang/web)) (define default-module-specs (append common-module-specs servlet-module-specs