abstracting stuffing

svn: r13469

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)])
+  (let ([result-uri (stuff-url test-stuffer uri svl)])
-    (unstuff-url result-uri)))
+    (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 "Integers" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize 3)))))
-    (test-case "Symbols" (check-true (stuffed-url? (stuff-url (serialize 'foo) uri0))))
+    (test-case "Symbols" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize 'foo)))))
-    (test-case "Strings" (check-true (stuffed-url? (stuff-url (serialize "Bar") uri0))))
+    (test-case "Strings" (check-true (stuffed-url? (stuff-url test-stuffer uri0 (serialize "Bar")))))
-    (test-case "Vectors" (check-true (stuffed-url? (stuff-url (serialize (vector 3 1 4)) uri0)))))
+    (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"

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)]))

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
+   ;; Server Interface
- [initialize-servlet ((request? . -> . response/c) . -> . (request? . -> . response/c))]
+   [initialize-servlet ((request? . -> . response/c) . -> . (request? . -> . response/c))]
- 
+   
- ;; Servlet Interface
+   ;; Servlet Interface
- [send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)]
+   [send/suspend/hidden ((url? list? . -> . response/c) . -> . request?)]
- [send/suspend/url ((url? . -> . response/c) . -> . request?)]
+   [send/suspend/url ((url? . -> . response/c) . -> . request?)]
- [send/suspend/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c)
+   [send/suspend/dispatch ((((request? . -> . any/c) . -> . url?) . -> . response/c)
-                         . -> . any/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
+      (stuff-url stuffer 
-                 (request-uri (execution-context-request (current-execution-context))))))))
+                 (request-uri (execution-context-request (current-execution-context)))
+                 k)))))
 
 (define-closure embed/url (proc) (k)
-  (stuff-url (kont-append-fun k proc)
+  (stuff-url (stateless-servlet-stuffer (current-servlet))
-             (request-uri (execution-context-request (current-execution-context)))))
+             (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=<k>
-   (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
+          (unstuff-url stuffer req-url)))
-           req-url)))
    ; Look in query for kont=<k>
    (match (bindings-assq #"kont" (request-bindings/raw req))
      [(struct binding:form (id kont))

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.)}
 ]
 }
+;}

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