Recovering bitrot, adding features and fixes

svn: r6269

collects/web-server/prototype-web-server/abort-resume.ss

@@ -1,12 +1,15 @@
 (module abort-resume mzscheme
   (require "define-closure.ss"
-           (lib "serialize.ss"))
+           (lib "plt-match.ss")
+           (lib "serialize.ss")
+           (lib "web-cells.ss" "newcont"))
   (provide
    
    ;; AUXILLIARIES
    abort
    resume
    the-cont-key
+   the-save-cm-key
    safe-call?
    abort/cc
    the-undef
@@ -26,39 +29,72 @@
   ;; **********************************************************************
   ;; **********************************************************************
   ;; AUXILLIARIES  
-  
   (define-struct mark-key ())
   (define the-cont-key (make-mark-key))
+  (define the-save-cm-key (make-mark-key))
   (define safe-call? (make-mark-key))
   
   ;; current-continuation-as-list: -> (listof value)
   ;; check the safety marks and return the list of marks representing the continuation
   (define (activation-record-list)
     (let* ([cm (current-continuation-marks)]
-           [sl (continuation-mark-set->list cm safe-call?)])
+           [sl (reverse (continuation-mark-set->list cm safe-call?))])
-      ;(printf "sl = ~s~n" sl)
+      (if (andmap (lambda (x)
-      (if (andmap (lambda (x) x) sl)
+                    (if (pair? x)
-          (reverse (continuation-mark-set->list cm the-cont-key))
+                        (car x)
-          (error "Attempt to capture a continuation from within an unsafe context"))))
+                        x))
+                  sl)
+          (begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm)
+                 #;(printf "MSG CMs: ~S~n" (continuation-mark-set->list* cm (list 'msg the-cont-key the-save-cm-key)))
+                 (reverse (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key))))
+          (error "Attempt to capture a continuation from within an unsafe context:" sl))))
   
-  ;; BUGBUG this isn't thread safe
+  ;; XXX BUGBUG this isn't thread safe
   (define current-abort-continuation
-    (box #f))
+    (box 
+     (lambda _
+       (error 'abort-resume "current-abort-continuation uninitialized"))))
   
   ;; abort: ( -> alpha) -> alpha
   ;; erase the stack and apply a thunk
   (define (abort thunk)
     (let ([abort-k (unbox current-abort-continuation)])
+      #;(printf "abort ~S ~S~n" abort-k thunk)
       (abort-k thunk)))
   
   ;; resume: (listof (value -> value)) value -> value
   ;; resume a computation given a value and list of frame procedures
   (define (resume frames val)
-    (cond
+    #;(printf "~S~n" `(resume ,frames ,val))
-      [(null? frames) val]
+    (match frames
-      [else
+      [(list)
-       (let ([f (car frames)])
+       (apply values val)]
-         (f (with-continuation-mark the-cont-key f (resume (cdr frames) val))))]))
+      [(list-rest f fs)
+       (match f
+         [(vector #f #f)
+          (error 'resume "Empty frame!")]
+         [(vector f #f)
+          (call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val)))
+                            f)]
+         [(vector #f (list-rest cm-key cm-val))
+          (with-continuation-mark the-save-cm-key (cons cm-key cm-val)
+            (with-continuation-mark cm-key cm-val
+              (resume fs val)))]
+         [(vector f cm)
+          (resume (list* (vector f #f) (vector #f cm) fs) val)])]))
+  
+  ;; rebuild-cms : frames (-> value) -> value
+  (define (rebuild-cms frames thunk)
+    #;(printf "~S~n" `(rebuild-cms ,frames ,thunk))
+    (match frames
+      [(list) 
+       (thunk)]
+      [(list-rest f fs)
+       (match f
+         [(vector f #f)
+          (rebuild-cms fs thunk)]
+         [(vector f (list-rest cm-key cm-val))
+          (with-continuation-mark cm-key cm-val (rebuild-cms fs thunk))])]))
   
   (define-syntax (abort/cc stx)
     (syntax-case stx ()
@@ -67,46 +103,48 @@
             (set-box! current-abort-continuation abort-k)
             (lambda () expr)))]))  
   
-  
   ;; a serializable undefined value
   (define-serializable-struct undef ())
   (define the-undef (make-undef))    
   
-  
-  
   ;; **********************************************************************
   ;; **********************************************************************
   ;; "SERVLET" INTERFACE  
-  
   (define decode-continuation
     (lambda (k-val)
-      (error "interactive module not initialized")))
+      (error "interactive module not initialized: decode")))
   
   (define (start-continuation val)
-    (error "interactive module not initialized"))
+    (error "interactive module not initialized: start"))
   
   ;; start-interaction: (request -> continuation) -> request
   ;; register the decode proc and start the interaction with the current-continuation
   (define (start-interaction decode)
     (set! decode-continuation decode)
-    ((lambda (k0) (abort (lambda () (set! start-continuation k0))))
+    ((lambda (k0) 
+       (abort (lambda () (set! start-continuation k0))))
      (let ([current-marks
             (reverse
-             (continuation-mark-set->list (current-continuation-marks) the-cont-key))])
+             (continuation-mark-set->list* (current-continuation-marks) (list the-cont-key the-save-cm-key)))])
-       (lambda (x) (abort (lambda () (resume current-marks x)))))))
+       (lambda x (abort (lambda () (resume current-marks x)))))))
   
-  (define-closure kont (x) (current-marks)
+  (define-closure kont x (wcs current-marks)
-    (abort (lambda () (resume current-marks x))))
+    (abort (lambda ()
+             ; Restoring the web-cells is separate from the continuation
+             (restore-web-cell-set! wcs)
+             (resume current-marks x))))
   
   ;; send/suspend: (continuation -> response) -> request
   ;; produce the current response and wait for the next request
   (define (send/suspend response-maker)
-    (with-continuation-mark safe-call? #t
+    (with-continuation-mark safe-call? '(#t send/suspend)
-      ((lambda (k) (abort (lambda () (response-maker k))))
+      (let ([current-marks (activation-record-list)]
-       (let ([current-marks (activation-record-list)])
+            [wcs (capture-web-cell-set)])
-         (make-kont (lambda () current-marks))))))
+        ((lambda (k) 
-  
+           (abort (lambda ()
-  
+                    ; Since we escaped from the previous context, we need to re-install the user's continuation-marks
+                    (rebuild-cms current-marks (lambda () (response-maker k))))))
+         (make-kont (lambda () (values wcs current-marks)))))))
   
   ;; **********************************************************************
   ;; **********************************************************************
@@ -125,5 +163,4 @@
        [(decode-continuation req)
         => (lambda (k) (k req))]
        [else
-        (error "no continuation associated with the provided request")])))
+        (error "no continuation associated with the provided request")]))))
-  )

collects/web-server/prototype-web-server/closure.ss

@@ -2,10 +2,16 @@
   (require-for-template mzscheme
                         (lib "serialize.ss")
                         (lib "etc.ss"))
-  (provide make-closure-definition-syntax) 
+  (require (lib "list.ss")
+           (lib "serialize.ss"))
+  (provide make-closure-definition-syntax
+           closure->deserialize-name) 
   
   (define myprint printf)
   
+  (define (closure->deserialize-name proc)
+    (cdr (first (second (serialize proc)))))
+  
   ;; borrowed this from Matthew's code
   ;; creates the deserialize-info identifier
   (define (make-deserialize-name id)
@@ -15,7 +21,7 @@
       (format "web-deserialize-info:~a" (syntax-e id)))
      id))
   
-  (define (make-closure-definition-syntax tag formals fvars proc-body)
+  (define (make-closure-definition-syntax tag fvars proc)
     (let ([make-id (lambda (str)
                      (datum->syntax-object
                       tag (string->symbol (format str (syntax-object->datum tag)))))])
@@ -29,41 +35,48 @@
                       [set-CLOSURE-env! (make-id "set-~a-env!")]
                       [struct:CLOSURE (make-id "struct:~a")])
           (values 
-           #'make-CLOSURE
+           (syntax/loc proc make-CLOSURE)
            (list
-            #`(define #,deserialize-info:CLOSURE
+            (quasisyntax/loc proc 
+              (define #,deserialize-info:CLOSURE
                 (make-deserialize-info
                  
                  ;; make-proc: value ... -> CLOSURE
-                 #,(if (null? fvars)
+                 (lambda args
-                       #'(lambda () (make-CLOSURE))
+                   (apply #,(if (null? fvars)
-                       #`(lambda #,fvars (make-CLOSURE (lambda () (values #,@fvars)))))
+                                (syntax/loc proc (lambda () (make-CLOSURE)))
+                                (quasisyntax/loc proc (lambda #,fvars (make-CLOSURE (lambda () (values #,@fvars))))))
+                          args))
                  
                  ;; cycle-make-proc: -> (values CLOSURE (CLOSURE -> void))
                  (lambda ()
                    (let ([new-closure
                           #,(if (null? fvars)
-                                #'(make-CLOSURE)
+                                (syntax/loc proc (make-CLOSURE))
-                                #'(make-CLOSURE (lambda () (error "closure not initialized"))))])
+                                (syntax/loc proc (make-CLOSURE (lambda () (error "closure not initialized")))))])
                      (values
                       new-closure
                       #,(if (null? fvars)
-                            #'void
+                            (syntax/loc proc void)
-                            #'(lambda (clsr)
+                            (syntax/loc proc 
-                                (set-CLOSURE-env! new-closure (CLOSURE-env clsr)))))))))
+                              (lambda (clsr)
+                                (set-CLOSURE-env! new-closure (CLOSURE-env clsr)))))))))))
             
-            #`(provide #,deserialize-info:CLOSURE)
+            (quasisyntax/loc proc 
+              (provide #,deserialize-info:CLOSURE))
             
-            #`(define CLOSURE:serialize-info
+            (quasisyntax/loc proc 
+              (define CLOSURE:serialize-info
                 (make-serialize-info
                  
                  ;; to-vector: CLOSURE -> vector
                  #,(if (null? fvars)
-                       #'(lambda (clsr) (vector))
+                       (syntax/loc proc (lambda (clsr) (vector)))
-                       #'(lambda (clsr)
+                       (syntax/loc proc
+                         (lambda (clsr)
                            (call-with-values
                             (lambda () ((CLOSURE-env clsr)))
-                            vector)))
+                            vector))))
                  
                  ;; The serializer id: --------------------
                  ;(syntax deserialize-info:CLOSURE)
@@ -80,11 +93,13 @@
                  
                  ;; Directory for last-ditch resolution --------------------
                  (or (current-load-relative-directory) (current-directory))
-                 ))
+                 )))
             
-            #`(define-values (struct:CLOSURE make-CLOSURE CLOSURE? #,@(if (null? fvars)
+            (quasisyntax/loc proc
-                                                                          #'()
+              (define-values (struct:CLOSURE make-CLOSURE CLOSURE? 
-                                                                          #'(CLOSURE-env set-CLOSURE-env!)))
+                                             #,@(if (null? fvars)
+                                                    (syntax/loc proc ())
+                                                    (syntax/loc proc (CLOSURE-env set-CLOSURE-env!))))
                 (let-values ([(struct:CLOSURE make-CLOSURE CLOSURE? CLOSURE-ref CLOSURE-set!)
                               (make-struct-type '#,tag ;; the tag goes here
                                                 #f  ; no super type
@@ -99,14 +114,17 @@
                                                 
                                                 ;; the struct apply proc:
                                                 #,(if (null? fvars)
-                                                      #`(lambda (clsr #,@formals)
+                                                      (quasisyntax/loc proc
-                                                          #,proc-body)
+                                                        (lambda (clsr . args)
-                                                      #`(lambda (clsr #,@formals)
+                                                          (apply #,proc args)))
+                                                      (quasisyntax/loc proc
+                                                        (lambda (clsr . args)
                                                           (let-values ([#,fvars ((CLOSURE-env clsr))])
-                                                            #,proc-body)))
+                                                            (apply #,proc args)))))
                                                 )])
                   (values struct:CLOSURE make-CLOSURE CLOSURE?
                           #,@(if (null? fvars)
-                                 #'()
+                                 (syntax/loc proc ())
-                                 #'((lambda (clsr) (CLOSURE-ref clsr 0))
+                                 (syntax/loc proc
-                                    (lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env))))))))))))))
+                                   ((lambda (clsr) (CLOSURE-ref clsr 0))
+                                    (lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env))))))))))))))))

collects/web-server/prototype-web-server/define-closure.ss

@@ -5,11 +5,10 @@
   
   (define-syntax (define-closure stx)
     (syntax-case stx ()
-      [(_ tag (formals ...) (free-vars ...) body)
+      [(_ tag formals (free-vars ...) body)
        (let-values ([(make-CLOSURE closure-definitions)
                      (make-closure-definition-syntax
                       #'tag
-                      (syntax->list #'(formals ...))
                       (syntax->list #'(free-vars ...))
-                      #'body)])
+                      #`(lambda formals body))])
          #`(begin #,@closure-definitions))])))

collects/web-server/prototype-web-server/defunctionalize.ss

@@ -43,7 +43,7 @@
   ;; defunctionalize: expr (-> symbol) -> (values expr (listof definition))
   ;; remove lambdas from an expression
   (define (defunctionalize expr labeling)
-    (syntax-case expr (if #%app lambda let-values #%top #%datum with-continuation mark quote)
+    (syntax-case expr (if #%app lambda let-values #%top #%datum with-continuation-mark quote)
       [(if test-expr csq-expr)
        (with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
          (let-values ([(new-test-expr test-defs) (defunctionalize #'test-expr labeling)]
@@ -66,7 +66,6 @@
             defs)))]
       [(let-values ([(f) rhs])
          (#%app f-apply (with-continuation-mark ignore-key f-mark body-expr)))
-       ;; (and (bound-identifier=? #'f #'f-apply) (bound-identifier=? #'f #'f-mark))
        (with-syntax ([(rhs f-apply ignore-key f-mark body-expr)
                       (recertify* (syntax->list #'(rhs f-apply ignore-key f-mark body-expr)) expr)])
          (let-values ([(new-rhs rhs-defs) (defunctionalize #'rhs labeling)]
@@ -89,7 +88,8 @@
            (let ([fvars (free-vars expr)]
                  [tag (labeling)])
              (let-values ([(make-CLOSURE closure-definitions)
-                           (make-closure-definition-syntax tag (syntax->list #'(formals ...)) fvars new-body-expr)])
+                           (make-closure-definition-syntax tag fvars
+                                                           #`(lambda (formals ...) #,new-body-expr))])
                (values
                 (if (null? fvars)
                     #`(#,make-CLOSURE)

collects/web-server/prototype-web-server/elim-call-cc.ss

@@ -113,10 +113,4 @@
        #`(lambda (formals ...)
            (with-continuation-mark safe-call? #t
              body))]
-      [_else w]))
+      [_else w])))
-  )
-
-
-
-
-

collects/web-server/prototype-web-server/elim-letrec.ss

@@ -34,7 +34,7 @@
   ;; definition ::= (define-values (var ...) expr)
   ;;
   ;; expr ::= var
-  ;;       |  (lambda (var ...) expr)
+  ;;       |  (lambda (var ...) expr ...)
   ;;       |  (if expr expr)
   ;;       |  (if expr expr expr)
   ;;       |  (let-values ([(var ...)] expr) expr)
@@ -78,12 +78,16 @@
                    (#%app set-box! vars new-rhss) ...
                    new-body)))))]
       [(letrec-values . anything)
-       (raise-syntax-error #f "Not all letrec-values-expressions supported" expr)]
+       (raise-syntax-error #f "elim-letrec: Not all letrec-values-expressions supported" expr)]
-      [(lambda (formals ...) body)
+      [(lambda (formals ...) body-expr ...)
-       (with-syntax ([body (recertify #'body expr)])
+       (with-syntax ([(body-expr ...) (recertify* (syntax->list #'(body-expr ...)) expr)])
-         #`(lambda (formals ...) #,(elim-letrec/ids #'body ids)))]
+         #`(lambda (formals ...)
+             #,@(map
+                 (lambda (an-expr)
+                   (elim-letrec/ids an-expr ids))
+                 (syntax->list #'(body-expr ...)))))]
       [(lambda . anything)
-       (raise-syntax-error #f "Not all lambda-expressions supported" expr)]
+       (raise-syntax-error #f "elim-letrec: Not all lambda-expressions supported" expr)]
       [(if tst-expr csq-expr)
        (with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
          #`(if #,(elim-letrec/ids #'tst-expr ids)
@@ -129,7 +133,7 @@
            #'(#%app unbox id)
            #'id)]
       [_else
-       (raise-syntax-error #f "eliminate-letrec: unsupported form" expr)]))
+       (raise-syntax-error #f "elim-letrec: unsupported form" expr)]))
   
   (define myprint printf)
   

collects/web-server/prototype-web-server/expander.ss

@@ -85,6 +85,4 @@
       [(_ rev-defs [])
        (raise-syntax-error #f "module has no body expression" stx)]
       [_else
-       (raise-syntax-error #f "extra body expression, or expression out of order" stx)]))
+       (raise-syntax-error #f "extra body expression, or expression out of order" stx)])))
-
-  )

collects/web-server/prototype-web-server/hardcoded-configuration.ss

@@ -1,6 +1,6 @@
 (module hardcoded-configuration mzscheme
-  (require (lib "configuration-structures.ss" "web-server")
+  (require (lib "configuration-structures.ss" "web-server" "private")
-           (lib "util.ss" "web-server")
+           (lib "util.ss" "web-server" "private")
            (lib "response.ss" "web-server"))
   
   (provide config:port
@@ -8,7 +8,7 @@
            config:listen-ip
            config:initial-connection-timeout
            config:virtual-hosts
-           )
+           hardcoded-host)
   
   ;; ************************************************************
   ;; HARDCODED CONFIGURATION STUFF
@@ -37,7 +37,7 @@
       (lambda (in) (read-string (file-size path) in))))
   
   ;; error files:
-  (define server-root-path (build-path "~" "plt-exp" "collects" "web-server" "default-web-root"))
+  (define server-root-path (build-path "~" "Development" "plt" "default-web-root"))
   (define default-host-path (build-path server-root-path "conf"))
   
   (define servlet-error-file (build-path default-host-path "servlet-error.html"))
@@ -46,11 +46,9 @@
   (define password-refresh-file (build-path default-host-path "passwords-refresh.html"))
   (define file-not-found-file (build-path default-host-path "not-found.html"))
   (define protocol-file (build-path default-host-path "protocol-error.html"))
+  (define collect-garbage-file (build-path default-host-path "collect-garbage.html"))
   
-  ;; config:virtual-hosts: alpha -> host
+  (define hardcoded-host
-  ;; return a default host structure
-  (define config:virtual-hosts
-    (let ([hardcoded-host
     ; host = (make-host (listof str) (str str sym url str -> str)
     ;                   passwords resopnders timeouts paths)
     (make-host
@@ -58,12 +56,14 @@
      ;; indices
      (list "index.html" "index.htm")
      
+     ;; log-format
+     'none
+     
      ;; log-message
-            (lambda (str0 str1 sym0 url0 str2)
+     "log"
-              (error "log-message not implemented"))
      
      ;; passwords
-            '()
+     "passwords"
      
      (make-responders
       
@@ -111,6 +111,10 @@
       (lambda (error-message)
         (error-response 400 "Malformed Request" protocol-file))
       
+      ;; collect-garbage: -> response
+      (lambda ()
+        (error-response 200 "Collected Garbage" collect-garbage-file))
+      
       )
      
      ; timeouts = (make-timeouts nat^5)
@@ -137,11 +141,14 @@
       ; file-root
       (build-path server-root-path "htdocs")
       ; servlet-root
-             (build-path "~" "plt-exp" "collects" "prototype-web-server" "servlets")
+      (build-path "~" "Development" "Projects" "exp" "prototype-web-server")
+      ; mime-types
+      (build-path server-root-path "mime.types")             
       ; password-authentication
-             (build-path server-root-path "passwords"))
+      (build-path server-root-path "passwords"))))
-            )])
   
+  ;; config:virtual-hosts: alpha -> host
+  ;; return a default host structure
+  (define config:virtual-hosts
     (lambda (ignore)
       hardcoded-host)))
-  )

collects/web-server/prototype-web-server/interaction.ss

@@ -3,5 +3,4 @@
   (provide (all-from-except mzscheme #%module-begin)
            (rename lang-module-begin #%module-begin)
            start-interaction
-           send/suspend)
+           send/suspend))
-  )

collects/web-server/prototype-web-server/normalizer.ss

@@ -2,8 +2,7 @@
   (require "syntax-utils.ss")
   (require-for-template mzscheme)
   (provide normalize-term
-           normalize-definition
+           normalize-definition)
-           )
   ;; **************************************************
   ;; SOURCE LANGUAGE
   ;;
@@ -12,9 +11,11 @@
   ;; definition ::= (define-values (var ...) expr)
   ;;
   ;; expr ::= var
-  ;;       |  (lambda (var ...) expr)
+  ;;       |  (lambda (var ...) expr ...)
   ;;       |  (if expr expr)
   ;;       |  (if expr expr expr)
+  ;;       |  (let-values () expr)
+  ;;       |  (let-values () expr ...)
   ;;       |  (let-values ([(var)] expr) expr)
   ;;       |  (let-values ([(var ...)] expr) expr)
   ;;       |  (let-values ([(var ...)] expr) expr ...)
@@ -69,8 +70,10 @@
       [(lambda (formals ...) body)
        (with-syntax ([body (recertify #'body expr)])
          (ctxt #`(lambda (formals ...) #,(normalize-term #'body))))]
+      [(lambda (formals ...) bodies ...)
+       (normalize ctxt #'(lambda (formals ...) (begin bodies ...)))]
       [(lambda . anything)
-       (raise-syntax-error #f "Not all lambda-expressions supported" expr)]
+       (raise-syntax-error #f "normalize: Not all lambda-expressions supported" expr)]
       [(if tst-expr csq-expr)
        (with-syntax ([(tst-expr csq-expr) (recertify* (list #'tst-expr #'csq-expr) expr)])
          (normalize
@@ -87,6 +90,12 @@
                            #,(normalize-term #'csq-expr)
                            #,(normalize-term #'alt-expr))))
           #'tst-expr))]
+      [(let-values () body)
+       (normalize ctxt (recertify #'body expr))]
+      [(let-values () body-expr rest-body-exprs ...)
+       (with-syntax ([(body-expr rest-body-exprs ...)
+                      (recertify* (syntax->list #'(body-expr rest-body-exprs ...)) expr)])
+         (normalize ctxt #'(let-values ([(throw-away) body-expr]) rest-body-exprs ...)))]
       [(let-values ([(var) rhs-expr]) body)
        (with-syntax ([(rhs-expr body) (recertify* (list #'rhs-expr #'body) expr)])
          (normalize ctxt #'(#%app (lambda (var) body) rhs-expr)))]
@@ -156,6 +165,4 @@
     (if (eq? ctxt id) frame
         (lambda (val)
           (let-values ([(x ref-to-x) (generate-formal 'x)])
-            #`(#%app (lambda (#,x) #,(ctxt ref-to-x)) #,(frame val))))))
+            #`(#%app (lambda (#,x) #,(ctxt ref-to-x)) #,(frame val)))))))
-  )
-

collects/web-server/prototype-web-server/persistent-expander.ss

@@ -109,7 +109,4 @@
        [(_ rev-defs [])
         (raise-syntax-error #f "module has no body expression" stx)]
        [_else
-        (raise-syntax-error #f "extra body expression, or expression out of order" stx)]))
+        (raise-syntax-error #f "extra body expression, or expression out of order" stx)])))
-   
-   )
- 

collects/web-server/prototype-web-server/persistent-interaction.ss

@@ -3,5 +3,4 @@
   (provide (all-from-except mzscheme #%module-begin)
            (rename lang-module-begin #%module-begin)
            start-interaction
-           send/suspend)
+           send/suspend))
-  )

collects/web-server/prototype-web-server/persistent-web-interaction.ss

@@ -3,21 +3,25 @@
            (all-except "persistent-expander.ss" send/suspend)
            "session.ss"
            "stuff-url.ss"
-           (lib "servlet-helpers.ss" "web-server")
+           (lib "servlet-helpers.ss" "web-server" "private")
            (lib "serialize.ss")
-           (lib "url.ss" "net")
+           (lib "url.ss" "net"))
-           )
   
   (provide (all-from-except mzscheme #%module-begin)
            (rename lang-module-begin #%module-begin)
            send/suspend/hidden
            send/suspend/url
+           send/suspend/dispatch
+           extract-proc/url embed-proc/url
+           redirect/get
            start-servlet)
   
   ;; start-servlet: -> request
   ;; set the initial interaction point for the servlet
   (define (start-servlet)
+    (printf "start-session~n")
     (start-session dispatch)
+    (printf "start-interaction~n")
     (start-interaction
      (lambda (req)
        (or (request->continuation req)
@@ -31,7 +35,7 @@
        (let ([p-cont (serialize k)])
          (page-maker
           (session-url (current-session))
-          `(input ([type "hidden"][name "kont"][value ,(format "~s" p-cont)])))))))
+          `(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
@@ -44,10 +48,51 @@
                      (session-url ses)
                      (session-mod-path ses)))))))
   
+  (define embed-label 'superkont)  
+  (define (embed-proc/url k-url proc)
+    (define ses (current-session))
+    (define superkont-url
+      (stuff-url (serialize proc)                                              
+                 (session-url ses)
+                 (session-mod-path ses)))
+    (define result-uri
+      (extend-url-query 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 binds (url-query req-url))
+    (if (exists-binding? embed-label binds)
+        (let* ([ses (current-session)]
+               [superkont-url (string->url (extract-binding/single embed-label binds))]
+               [proc (deserialize 
+                      (unstuff-url
+                       superkont-url (session-url ses)
+                       (session-mod-path ses)))])
+          (proc request))
+        (error 'send/suspend/dispatch "No ~a: ~S!" embed-label binds)))
+  
+  (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))))))]))  
+  
+  (define (redirect/get)
+    (send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily))))
+  
   ;; request->continuation: req -> continuation
   ;; decode the continuation from the hidden field of a request
   (define (request->continuation req)
     (or
+     ; Look in url for c=<k>
      (let* ([ses (current-session)]
             [req-url (request-uri req)]
             [qry (url-query req-url)]
@@ -57,10 +102,10 @@
              (unstuff-url
               req-url (session-url ses)
               (session-mod-path ses)))))
+     ; Look in query for kont=<k>
      (let ([bdgs (request-bindings req)])
        (and (exists-binding? 'kont bdgs)
             (deserialize
              (read
               (open-input-string
-               (extract-binding/single 'kont bdgs))))))))
+               (extract-binding/single 'kont bdgs)))))))))
-  )

collects/web-server/prototype-web-server/run.ss

@@ -0,0 +1,33 @@
+(module run mzscheme
+  (require (lib "unit.ss")
+           (lib "tcp-sig.ss" "net"))
+  (require (lib "dispatch-server-sig.ss" "web-server" "private")
+           (lib "dispatch-server-unit.ss" "web-server" "private")
+           (lib "request.ss" "web-server" "private")
+           (lib "configuration-structures.ss" "web-server" "private")
+           (prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers"))
+           (prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers")))
+  (require "hardcoded-configuration.ss"
+           (prefix prototype: "server.ss"))
+
+  (define port 8080)
+  (define listen-ip #f)
+  (define max-waiting 40)
+  (define initial-connection-timeout 60)
+  (define host-info hardcoded-host)
+  (define dispatch
+    (sequencer:make
+     (lambda (conn req)
+       (prototype:dispatch conn req host-info))
+     (files:make #:htdocs-path (paths-htdocs (host-paths host-info))
+                   #:mime-types-path (paths-mime-types (host-paths host-info))
+                   #:indices (host-indices host-info)
+                   #:file-not-found-responder (responders-file-not-found (host-responders host-info)))))
+  
+  (define-values/invoke-unit
+    dispatch-server@
+    (import tcp^ dispatch-server-config^)
+    (export dispatch-server^))
+  
+  (define shutdown (serve))
+  (semaphore-wait (make-semaphore 0)))

collects/web-server/prototype-web-server/server.ss

@@ -1,22 +1,30 @@
 (module server mzscheme
-  (require (lib "connection-manager.ss" "web-server")
+  (require (lib "connection-manager.ss" "web-server" "private")
-           (lib "request-parsing.ss" "web-server")
+           (lib "request.ss" "web-server" "private")
            (lib "response.ss" "web-server")
-           ;(lib "util.ss" "web-server")
+           (lib "servlet-helpers.ss" "web-server" "private")
+           (lib "response.ss" "web-server" "private")
+           (lib "util.ss" "web-server" "private")
            (lib "url.ss" "net")
-           (lib "string.ss")
            (lib "list.ss")
-
+           (lib "plt-match.ss")           
-           (lib "configuration-structures.ss" "web-server")
+           (lib "configuration-structures.ss" "web-server" "private")
-
+           (lib "dispatch.ss" "web-server" "dispatchers")
+           (lib "session.ss" "prototype-web-server")
+           (only (lib "abort-resume.ss" "prototype-web-server")
+                 abort/cc
+                 safe-call?
+                 the-cont-key)
+           (only (lib "persistent-web-interaction.ss" "prototype-web-server")
+                 start-servlet)           
+           (lib "web-cells.ss" "newcont")
+           "xexpr-extras.ss"
            "utils.ss"
-           "hardcoded-configuration.ss"
+           "hardcoded-configuration.ss")
-           "session.ss"
-           )
   
-  (provide serve)
+  (provide serve dispatch)
   
-  (define myprint printf)
+  (define myprint printf #;(lambda _ (void)))
   
   (define thread-connection-state (make-thread-cell #f))
   (define-struct connection-state (conn req))
@@ -80,33 +88,20 @@
             [close? (kill-connection! conn)]
             [else (connection-loop)])))))
   
-  ;; get-host : Url (listof (cons Symbol String)) -> String
-  ;; host names are case insesitive---Internet RFC 1034
-  (define DEFAULT-HOST-NAME "<none>")
-  (define (get-host uri headers)
-    (let ([lower!
-           (lambda (s)
-             (string-lowercase! s #;(bytes->string/utf-8 s))
-             s)])
-      (cond
-        [(url-host uri) => lower!]
-        [(assq 'host headers)
-         =>
-         (lambda (h) (lower! (bytes->string/utf-8 (cdr h))))]
-        [else DEFAULT-HOST-NAME])))
-
   ;; ************************************************************
   ;; dispatch: connection request host -> void
   ;; trivial dispatcher
   (define (dispatch conn req host-info)
+    (define-values (uri method path) (decompose-request req))
     (myprint "dispatch~n")
-
+    (if (regexp-match #rx"^/servlets" path)
+        (begin
           (adjust-connection-timeout!
            conn
            (timeouts-servlet-connection (host-timeouts host-info)))
           ;; more here - make timeouts proportional to size of bindings
           (servlet-content-producer conn req host-info))    
-
+        (next-dispatcher)))
   
   ;; ************************************************************
   ;; ************************************************************
@@ -124,10 +119,6 @@
             '() (list "ignored"))
            meth)
           (let ([uri (request-uri req)])
-            (set-request-bindings!
-             req
-             (read-bindings/handled conn meth uri (request-headers req)
-                                    host-info))
             (thread-cell-set! thread-connection-state
                               (make-connection-state conn req))
             (with-handlers ([void
@@ -146,31 +137,10 @@
                 [else
                  (begin-session host-info)]))))))
   
-  ;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
-  ;; read the bindings and handle any exceptions
-  (define (read-bindings/handled conn meth uri headers host-info)
-    (with-handlers ([exn? (lambda (e)
-                            (output-response/method
-                             conn
-                             ;((responders-protocol (host-responders host-info))
-                             ; (exn-message e))
-                             ((responders-servlet-loading (host-responders
-                                                           host-info))
-                              uri e)
-
-
-                             meth)
-                            '())])
-      (read-bindings conn meth uri headers)))
-
   ;; Parameter Parsing
   
-  ;; old style: ;id15*0
-  ;(define URL-PARAMS:REGEXP (regexp "([^\\*]*)\\*(.*)"))
-
   ;; encodes a simple number:
-  (define URL-PARAMS:REGEXP (regexp "[0-9]*"))
+  (define URL-PARAMS:REGEXP (regexp "([0-9]+)"))
-
   
   (define (match-url-params x) (regexp-match URL-PARAMS:REGEXP x))
   
@@ -178,11 +148,18 @@
   ;; Determine if the url encodes a session-id and extract it
   (define (resume-session? a-url)
     (myprint "resume-session?: url-string = ~s~n" (url->string a-url))
-    (let ([str (url->param a-url)])
+    (let ([k-params (filter match-url-params
-      (and str
+                            (apply append
-           (let ([param-match (match-url-params str)])
+                                   (map path/param-param (url-path a-url))))])
-             (and (not (null? param-match))
+      (myprint "resume-session?: ~S~n" k-params)
-                  (string->number (car param-match)))))))
+      (if (empty? k-params)
+          #f
+          (match (match-url-params (first k-params))
+            [(list _ n)
+             (myprint "resume-session?: Found ~a~n" n)
+             (string->number n)]
+            [_
+             #f]))))
   
   ;; url->param: url -> (union string #f)
   (define (url->param a-url)
@@ -194,15 +171,8 @@
   ;(resume-session? (string->url "http://localhost:9000/;foo"))
   ;(resume-session? (string->url "http://localhost:9000/foo/bar"))
   
-
-  
   ;; ************************************************************
   
-  ;; directory-part: path -> path
-  (define (directory-part a-path)
-    (let-values ([(base name must-be-dir?) (split-path a-path)])
-      base))  
-  
   ;; begin-session: connection request host-info
   (define (begin-session host-info)
     (myprint "begin-session~n")
@@ -221,7 +191,17 @@
                                [current-namespace ns]
                                [current-session ses])
                   (let* ([module-name `(file ,(path->string a-path))])
-                    (dynamic-require module-name #f)))
+                    (myprint "dynamic-require ...~n")
+                    (with-handlers ([exn:fail:contract?
+                                     (lambda _
+                                       (dynamic-require module-name #f))])
+                      (let ([start (dynamic-require module-name 'start)])
+                        (abort/cc 
+                         (with-continuation-mark safe-call? '(#t start)
+                           (start
+                            (with-continuation-mark the-cont-key start
+                              (start-servlet)))))))))
+                (myprint "resume-session~n")
                 (resume-session (session-id ses) host-info)))
             (output-response/method
              (connection-state-conn (thread-cell-ref thread-connection-state))
@@ -230,8 +210,10 @@
   
   (define to-be-copied-module-specs
     '(mzscheme
+      (lib "web-cells.ss" "newcont")
+      (lib "abort-resume.ss" "prototype-web-server")
       (lib "session.ss" "prototype-web-server")
-      (lib "request-parsing.ss" "web-server")))
+      (lib "request.ss" "web-server" "private")))
   
   ;; get the names of those modules.
   (define to-be-copied-module-names
@@ -250,26 +232,10 @@
                   to-be-copied-module-names)
         new-namespace)))
   
-  ;; ripped this off from url-unit.ss
-  (define (url-path->string strs)
-    (apply
-     string-append
-     (let loop ([strs strs])
-       (cond
-         [(null? strs) '()]
-         [else (list* "/"
-                      (maybe-join-params (car strs))
-                      (loop (cdr strs)))]))))
-
-  ;; needs to unquote things!
-  (define (maybe-join-params s)
-    (cond
-      [(string? s) s]
-      [else (path/param-path s)]))
-
   ;; ************************************************************
   ;; resume-session: connection request number host-info
   (define (resume-session ses-id host-info)
+    ; XXX Check if session is for same servlet!
     (myprint "resume-session: ses-id = ~s~n" ses-id)
     (cond
       [(lookup-session ses-id)
@@ -287,17 +253,13 @@
                                    the-exn)
                                   (request-method
                                    (connection-state-req (thread-cell-ref thread-connection-state)))))])
+                (printf "session-handler ~S~n" (session-handler ses))
                 (output-response
                  (connection-state-conn (thread-cell-ref thread-connection-state))
+                 (xexpr+extras->xexpr
                   ((session-handler ses)
-                  (connection-state-req (thread-cell-ref thread-connection-state)))))))]
+                   (connection-state-req (thread-cell-ref thread-connection-state))))))))]
       [else
+       (myprint "resume-session: Unknown ses~n")
        ;; TODO: should just start a new session here.
-       (output-response/method
+       (begin-session host-info)])))
-        (connection-state-conn (thread-cell-ref thread-connection-state))
-        ((responders-file-not-found (host-responders host-info))
-         (request-uri (connection-state-req (thread-cell-ref thread-connection-state))))
-        (request-method
-         (connection-state-req (thread-cell-ref thread-connection-state))))]))
-
-  )

collects/web-server/prototype-web-server/servlets/add01.ss

@@ -1,8 +1,8 @@
 (module add01 mzscheme
   (require (lib "session.ss" "prototype-web-server")
-           (lib "request-parsing.ss" "web-server")
+           (lib "request.ss" "web-server" "private")
-           (lib "url.ss" "net")
+           (lib "request-structs.ss" "web-server")
-           )
+           (lib "url.ss" "net"))
 
   (define (dispatch req)
     (let* ([uri (request-uri req)]

collects/web-server/prototype-web-server/servlets/add02.ss

@@ -1,6 +1,7 @@
 (module add02 "../web-interaction.ss"
   (require (lib "url.ss" "net")
-           (lib "request-parsing.ss" "web-server"))
+           (lib "request.ss" "web-server" "private")
+           (lib "request-structs.ss" "web-server"))
   
   ;; get-number-from-user: string -> number
   ;; ask the user for a number
@@ -24,6 +25,4 @@
            (body
             (h1 "Final Page")
             (p ,(format "The answer is ~a"
-                        (+ (gn "first") (gn "second")))))))
+                        (+ (gn "first") (gn "second"))))))))
-  
-  )

collects/web-server/prototype-web-server/servlets/add03.ss

@@ -1,6 +1,7 @@
 (module add03 "../persistent-web-interaction.ss"
   (require (lib "url.ss" "net")
-           (lib "servlet-helpers.ss" "web-server"))
+           (lib "servlet-helpers.ss" "web-server" "private")
+           (lib "request-structs.ss" "web-server"))
   
   ;; get-number-from-user: string -> number
   ;; ask the user for a number
@@ -27,5 +28,4 @@
            (body
             (h1 "Final Page")
             (p ,(format "The answer is ~a"
-                        (+ (gn "first") (gn "second")))))))
+                        (+ (gn "first") (gn "second"))))))))
-  )

collects/web-server/prototype-web-server/servlets/add04.ss

@@ -1,6 +1,6 @@
 (module add04 (lib "persistent-web-interaction.ss" "prototype-web-server")
   (require (lib "url.ss" "net")
-           (lib "servlet-helpers.ss" "web-server"))
+           (lib "servlet-helpers.ss" "web-server" "private"))
   
   ;; get-number-from-user: string -> number
   ;; ask the user for a number
@@ -26,5 +26,4 @@
            (body
             (h1 "Final Page")
             (p ,(format "The answer is ~a"
-                        (+ (gn "first") (gn "second")))))))
+                        (+ (gn "first") (gn "second"))))))))
-  )

collects/web-server/prototype-web-server/servlets/add05.ss

@@ -0,0 +1,49 @@
+(module add05 (lib "persistent-web-interaction.ss" "prototype-web-server")
+  (require (lib "url.ss" "net")
+           (lib "servlet-helpers.ss" "web-server" "private"))
+  
+  ;; 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
+                                     (extract-binding/single
+                                      'number
+                                      (request-bindings 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 (gn msg)
+    (send/suspend/dispatch
+     (lambda (embed/url)
+       `(hmtl (head (title ,(format "Get ~a number" msg)))
+              (body
+               (form ([action ,(url->string 
+                                (embed/url
+                                 (lambda (req)
+                                   (string->number
+                                    (extract-binding/single
+                                     'number
+                                     (request-bindings 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"]))))))))
+  
+  (let ([initial-request (start-servlet)])
+    `(html (head (title "Final Page"))
+           (body
+            (h1 "Final Page")
+            (p ,(format "The answer is ~a" (+ (gn "first") (gn "second"))))))))

collects/web-server/prototype-web-server/servlets/quiz-lib.ss

@@ -1,7 +1,6 @@
 (module quiz-lib mzscheme
   (require (lib "serialize.ss")
-           (lib "url.ss" "net")
+           (lib "url.ss" "net"))
-           )
   (provide (struct mc-question (cue answers correct-answer))
            make-cue-page
            quiz)

collects/web-server/prototype-web-server/servlets/quiz01.ss

@@ -1,7 +1,7 @@
 (module quiz01 (lib "persistent-web-interaction.ss" "prototype-web-server")
   (require "quiz-lib.ss"
            (lib "url.ss" "net")
-           (lib "servlet-helpers.ss" "web-server"))
+           (lib "servlet-helpers.ss" "web-server" "private"))
   
   ;; get-answer: mc-question -> number
   ;; get an answer for a multiple choice question

collects/web-server/prototype-web-server/servlets/quiz02.ss

@@ -1,6 +1,6 @@
 (module quiz02 (lib "persistent-web-interaction.ss" "prototype-web-server")
   (require "quiz-lib.ss"
-           (lib "servlet-helpers.ss" "web-server"))
+           (lib "servlet-helpers.ss" "web-server" "private"))
   
   ;; get-answer: mc-question -> number
   ;; get an answer for a multiple choice question

collects/web-server/prototype-web-server/servlets/toobig.ss

@@ -0,0 +1,37 @@
+(module toobig (lib "persistent-web-interaction.ss" "prototype-web-server")
+  (require (lib "url.ss" "net")
+           (lib "servlet-helpers.ss" "web-server" "private"))
+  
+  (define (get-n)
+    (let ([req
+           (send/suspend/url
+            (lambda (k-url)
+              `(html (head (title "How many bytes?"))
+                     (body
+                      (form ([action ,(url->string k-url)]
+                             [method "POST"]
+                             [enctype "application/x-www-form-urlencoded"])
+                            "How many bytes? (Try 1024)"
+                            (input ([type "text"] [name "number"] [value ""]))
+                            (input ([type "submit"])))))))])
+      (string->number
+       (extract-binding/single
+        `number
+        (request-bindings req)))))
+  
+  (define (get-bytes)
+    (let* ([the-bytes
+            (make-bytes (get-n) (char->integer #\!))]
+           [req
+            (send/suspend/url
+             (lambda (k-url)
+               `(html (head (title "How are these bytes?"))
+                      (body
+                       (h3 ,(bytes->string/utf-8 the-bytes))
+                       (a ([href ,(url->string k-url)]) "OK!")))))])
+      the-bytes))
+  
+  (let ([initial-request (start-servlet)])
+    `(html (head (title "You got here!"))
+           (body
+            (h1 ,(bytes->string/utf-8 (get-bytes)))))))

collects/web-server/prototype-web-server/session.ss

@@ -1,9 +1,8 @@
 (module session mzscheme
   (require (lib "contract.ss")
            (lib "url.ss" "net")
-           (lib "request-parsing.ss" "web-server")
+           (lib "request-structs.ss" "web-server")
            (lib "response.ss" "web-server"))
-  (require-for-syntax (lib "url.ss" "net"))
   (provide current-session)
   
   (define-struct session (id cust namespace handler url mod-path))
@@ -67,12 +66,12 @@
     (replace-path
      (lambda (old-path)
        (if (null? old-path)
-           (list (make-path/param "" new-param-str))
+           (list (make-path/param "" (list new-param-str)))
            (let* ([car-old-path (car old-path)])
              (cons (make-path/param (if (path/param? car-old-path)
                                         (path/param-path car-old-path)
                                         car-old-path)
-                                    new-param-str)
+                                    (list new-param-str))
                    (cdr old-path)))))
      in-url))
   
@@ -87,12 +86,7 @@
        (url-user in-url)
        (url-host in-url)
        (url-port in-url)
+       #t
        new-path
        (url-query in-url)
-       (url-fragment in-url))))
+       (url-fragment in-url)))))
-
-  )
-  
-    
-
-  

collects/web-server/prototype-web-server/stuff-url.ss

@@ -1,7 +1,13 @@
 (module stuff-url mzscheme
   (require (lib "url.ss" "net")
+           (lib "list.ss")
+           (lib "plt-match.ss")
            "utils.ss")
   
+  ; XXX url: first try continuation, then turn into hash
+  
+  ; XXX different ways to hash, different ways to store (maybe cookie?)
+
   ;; before reading this, familiarize yourself with serializable values
   ;; covered in ch 36 in the MzScheme manual.
   
@@ -56,9 +62,68 @@
   ;; If the graph and fixups are trivial, then they will be omitted from the query.
   
   (provide stuff-url
+           extend-url-query
            unstuff-url
            find-binding)
   
+  (define (read/string str)
+    (read (open-input-string str)))
+  (define (write/string v)
+    (define str (open-output-string))
+    (write v str)
+    (get-output-string str))
+  
+  ;; compress-mod-map : (listof (cons mod-spec symbol)) -> (listof (cons (or mod-spec number) symbol))
+  (define (compress-mod-map mm)
+    (compress-mod-map/seen empty mm))
+  
+  (define (lookup-seen ms seen)
+    (match seen
+      [(list)
+       (values #f (list ms))]
+      [(list-rest ms+ seen+)
+       (if (equal? ms ms+)
+           (values 0 (list* ms+ seen+))
+           (let-values ([(i seen++) (lookup-seen ms seen+)])
+             (values (if i (add1 i) #f) (list* ms+ seen++))))]))
+  
+  (define (compress-mod-map/seen seen mm)
+    (match mm
+      [(list) 
+       (list)]
+      [(list-rest (list-rest mod-spec sym) mm)
+       (define-values (i seen+) (lookup-seen mod-spec seen))
+       (if i
+           (list* (cons i sym) (compress-mod-map/seen seen+ mm))
+           (list* (cons mod-spec sym) (compress-mod-map/seen seen+ mm)))]))
+  
+  ;; decompress-mod-map : (listof (cons (or mod-spec number) symbol)) -> (listof (cons mod-spec symbol))
+  (define (decompress-mod-map cmm)
+    (decompress-mod-map/seen empty cmm))
+    
+  (define (decompress-mod-map/seen seen cmm)
+    (match cmm
+      [(list)
+       (list)]
+      [(list-rest (list-rest mod-spec-or-n sym) cmm)
+       (if (number? mod-spec-or-n)
+           (list* (cons (list-ref seen mod-spec-or-n) sym)
+                  (decompress-mod-map/seen seen cmm))
+           (list* (cons mod-spec-or-n sym)
+                  (decompress-mod-map/seen (append seen (list mod-spec-or-n)) cmm)))]))
+  
+  ; compress-serial : serial -> serial (with compressed mod-map)
+  (define compress-serial
+    (match-lambda
+      [(list e0 mm e2 e3 e4 e5)
+       (list e0 (compress-mod-map mm) e2 e3 e4 e5)]))
+  
+  ; decompress-serial : serial (with compressed mod-map) -> serial
+  (define decompress-serial
+    (match-lambda
+      [(list e0 cmm e2 e3 e4 e5)
+       (list e0 (decompress-mod-map cmm) e2 e3 e4 e5)]))
+  
   ;; url-parts: module-path serial -> string (listof (union number 'k)) s-expr s-expr s-expr
   ;; compute the parts for the url:
   ;;   labeling code
@@ -88,8 +153,8 @@
   (define (reconstruct-mod-map mod-path label-code simple-map)
     (map
      (lambda (n-or-k)
-       (if (eqv? n-or-k 'k)
+       (if (symbol? n-or-k)
-           '((lib "abort-resume.ss" "prototype-web-server") . web-deserialize-info:kont)
+           `((lib "abort-resume.ss" "prototype-web-server") . ,n-or-k)
            (cons
             mod-path
             (string->symbol
@@ -123,7 +188,7 @@
     (let ([match? (regexp-match WEB-DESERIALIZE-INFO-REGEXP (symbol->string sym))])
       (and match? (string->number (caddr match?)))))
   
-  ;; simplify-module-map: module-path string module-map -> (listof (union number 'k))
+  ;; simplify-module-map: module-path string module-map -> (listof (union number symbol))
   ;; convert the module-map into a simple list
   (define (simplify-module-map pth labeling-code mod-map)
     (let loop ([mm mod-map])
@@ -133,7 +198,7 @@
               (match-label (cdar mm)))
          => (lambda (lab) (cons lab (loop (cdr mm))))]
         [(same-module? '(lib "abort-resume.ss" "prototype-web-server") (caar mm))
-         (cons 'k (loop (cdr mm)))]
+         (cons (cdar mm) (loop (cdr mm)))]
         [else
          (error "cannot construct abreviated module map" mod-map)])))
   
@@ -145,15 +210,15 @@
   
   ;; stuff-url: serial url path -> url
   ;; encode in the url
-  (define (stuff-url svl uri pth)
+  #;(define (stuff-url svl uri pth)
     (let-values ([(l-code simple-mod-map graph fixups sv)
                   (url-parts pth svl)])
       (let ([new-query
              `(,(cons 'c l-code)
                 ,@(if (null? graph) '()
-                      (cons 'g (format "~s" graph)))
+                      (list (cons 'g (format "~s" graph))))
                 ,@(if (null? fixups) '()
-                      (cons 'f (format "~s" fixups)))
+                      (list (cons 'f (format "~s" fixups))))
                 ,(cons 'v (format "~s" sv)))])
         (let ([result-uri
                (make-url
@@ -161,9 +226,10 @@
                 (url-user uri)
                 (url-host uri)
                 (url-port uri)
+                #t
                 (append (url-path uri)
                         (map
-                         (lambda (n-or-sym) (format "~a" n-or-sym))
+                         (lambda (n-or-sym) (make-path/param (format "~a" n-or-sym) empty))
                          simple-mod-map))
                 new-query
                 (url-fragment uri))])
@@ -173,9 +239,53 @@
                      1024)
               (error "the url is too big: " (url->string result-uri))))))))
   
+  (require (lib "md5.ss"))
+  (define (md5-store str)
+    (define hash (md5 (string->bytes/utf-8 str)))
+    (with-output-to-file
+        (format "/Users/jay/Development/plt/urls/~a" hash)
+      (lambda ()
+        (write str))
+      'replace)
+    (bytes->string/utf-8 hash))
+  (define (md5-lookup hash)
+    (with-input-from-file
+        (format "/Users/jay/Development/plt/urls/~a" hash)
+      (lambda () (read))))
+  
+  (define (stuff-url svl uri pth)
+    #;(printf "stuff: ~s~n" svl)
+    (let ([result-uri
+           (make-url
+            (url-scheme uri)
+            (url-user uri)
+            (url-host uri)
+            (url-port uri)
+            #t
+            (url-path uri)
+            (list (cons 'c (md5-store (write/string (compress-serial svl)))))
+            (url-fragment uri))])
+      (begin0
+        result-uri
+        (when (> (string-length (url->string result-uri))
+                 1024)
+          (error "the url is too big: " (url->string result-uri))))))
+  
+  (define (extend-url-query uri key val)
+    (make-url
+     (url-scheme uri)
+     (url-user uri)
+     (url-host uri)
+     (url-port uri)
+     #t
+     (url-path uri)
+     (list* (cons key val)
+            (url-query uri))
+     (url-fragment uri)))
+    
   ;; unstuff-url: url url path -> serial
   ;; decode from the url and reconstruct the serial
-  (define (unstuff-url req-url ses-url mod-path)
+  #;(define (unstuff-url req-url ses-url mod-path)
     (let ([suff (split-url-path ses-url req-url)]
           [qry (url-query req-url)])      
       (recover-serial
@@ -183,12 +293,15 @@
        (find-binding 'c qry)
        (map
         (lambda (elt)
-          (if (string=? elt "k") 'k
+          (define nelt (string->number elt))
-              (string->number elt)))
+          (if (not nelt) (string->symbol elt)
+              nelt))
         suff)
        (or (find-binding 'g qry) '())
        (or (find-binding 'f qry) '())
        (find-binding 'v qry))))
+  (define (unstuff-url req-url ses-url mod-path)
+    (decompress-serial (read/string (md5-lookup (find-binding 'c (url-query req-url))))))
   
   ;; find-binding: symbol (list (cons symbol string)) -> (union string #f)
   ;; find the binding in the query or return false
@@ -197,5 +310,4 @@
       [(null? qry) #f]
       [(eqv? key (caar qry))
        (read (open-input-string (cdar qry)))]
-      [else (find-binding key (cdr qry))]))
+      [else (find-binding key (cdr qry))])))
-  )

collects/web-server/prototype-web-server/syntax-utils.ss

@@ -11,9 +11,7 @@
   ;; (listof syntax) syntax -> syntax
   ;; recertify a list of syntax parts given the whole
   (define (recertify* exprs old-expr)
-    (map
+    (map (lambda (expr) (recertify expr old-expr))
-     (lambda (expr)
-       (syntax-recertify expr old-expr (current-code-inspector) #f))
          exprs))
   
   ;; generate-formal: -> identifier
@@ -23,8 +21,7 @@
                      (if (syntax-transforming?)
                          (local-expand #`(lambda (#,name) #,name) 'expression '())
                          #`(lambda (#,name) #,name))])
-        (values #'formal #'ref-to-formal))))
+        (values #'formal #'ref-to-formal)))))
-    )
   
   
   

collects/web-server/prototype-web-server/tests/certify-error2.ss

@@ -0,0 +1,2 @@
+(module certify-error2 "../persistent-interaction.ss"
+  (or #f #t))

collects/web-server/prototype-web-server/tests/language-tester.ss

@@ -23,7 +23,7 @@
       (parameterize ([current-namespace ns])
         (eval `(require (lib "client.ss" "prototype-web-server")
                         (lib "serialize.ss")
-                        ,pth))
+                        (file ,pth)))
       (lambda (expr)
         (parameterize ([current-namespace ns])
           (eval expr)))))))

collects/web-server/prototype-web-server/tests/stuff-url-tests.ss

@@ -33,11 +33,11 @@
       "Test same-module?"
       
       (assert-true
-       (same-module? (build-path "~/plt-exp/collects/prototype-web-server/abort-resume.ss")
+       (same-module? `(file ,(build-path "~/Development/Projects/exp/prototype-web-server/abort-resume.ss"))
                      '(lib "abort-resume.ss" "prototype-web-server")))
       
       (assert-true
-       (same-module? (build-absolute-path (current-directory) "../abort-resume.ss")
+       (same-module? `(file ,(build-absolute-path (current-directory) "../abort-resume.ss"))
                      '(lib "abort-resume.ss" "prototype-web-server")))
       
       (assert-true

collects/web-server/prototype-web-server/tests/suite.ss

@@ -1,4 +1,5 @@
-(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1))
+(module suite mzscheme
+  (require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1))
            (planet "test.ss" ("schematics" "schemeunit.plt" 1 1))
            "persistent-close-tests.ss"
            "test-normalizer.ss"
@@ -7,7 +8,7 @@
            "persistent-interaction-tests.ss"
            "stuff-url-tests.ss")
   
-(test/graphical-ui
+  (test/graphical-ui
    (make-test-suite
     "Main Tests for Prototype Web Server"
     persistent-close-suite
@@ -16,5 +17,4 @@
     closure-tests-suite
     labels-tests-suite
     persistent-interaction-suite
-  ))
+    )))
-

collects/web-server/prototype-web-server/tests/test-normalizer.ss

@@ -106,8 +106,9 @@
       [(_ expr)
        #'(with-handlers ([(lambda (x) #t)
                           (lambda (the-exn)
-                            (string=? "lambda: Not all lambda-expressions supported"
+                            (and (regexp-match "normalize: Not all lambda-expressions supported"
-                                      (exn-message the-exn)))])
+                                               (exn-message the-exn))
+                                 #t))])
            expr)]))
   
   (define-syntax (check-unsupported-let stx)
@@ -282,7 +283,8 @@
      (make-test-suite
       "Check that certain errors are raised"
       
-      (make-test-case
+      ; this is supported now
+      #;(make-test-case
        "multiple body expressions in lambda"
        (assert-true (check-unsupported-lambda
                      (normalize-term (expand (syntax (lambda (x y z) 3 4)))))))

collects/web-server/prototype-web-server/utils.ss

@@ -1,5 +1,6 @@
 (module utils mzscheme
-  (require (lib "url.ss" "net"))
+  (require (lib "url.ss" "net")
+           (lib "list.ss"))
   (provide url->servlet-path
            make-session-url
            split-url-path)
@@ -15,7 +16,9 @@
      (url-user uri)
      (url-host uri)
      (url-port uri)
-     new-path
+     #t
+     (map (lambda (p) (make-path/param p empty))
+          new-path)
      '()
      #f
      ))
@@ -73,7 +76,7 @@
   ;;   The second value is the prefix of the url-path used to find the servlet.
   ;;   The third value is the remaining suffix of the url-path.
   (define (url->servlet-path servlet-dir uri)
-    (printf "   current-directory = ~s~n" (current-directory))
+    #;(printf "   current-directory = ~s~n" (current-directory))
     (let loop ([base-path servlet-dir]
                [servlet-path '()]
                [path-list (simplify-url-path uri)])
@@ -82,7 +85,7 @@
        (values #f #f #f)
        (let* ([next-path-segment (car path-list)]
               [new-base (build-path base-path next-path-segment)])
-         (printf "   new-base = ~s~n" new-base)
+         #;(printf "   new-base = ~s~n" new-base)
          (cond
            [(file-exists? new-base)
             (values new-base

collects/web-server/prototype-web-server/web-interaction.ss

@@ -3,7 +3,8 @@
            (all-except "expander.ss" send/suspend)
            "utils.ss"
            "session.ss"
-           (lib "request-parsing.ss" "web-server")
+           (lib "list.ss")
+           (lib "request-structs.ss" "web-server")
            (lib "url.ss" "net"))
   
   (provide (all-from-except mzscheme #%module-begin)
@@ -38,19 +39,24 @@
     (let ([n 0])
       (lambda (k)
         (set! n (add1 n))
+        (printf "Adding ~a to ~S~n" n (hash-table-map k-table (lambda (k v) k)))
         (hash-table-put! k-table n k)
+        (printf "Now: ~S~n" (hash-table-map k-table (lambda (k v) k)))
         n)))
   
   ;; url/id->continuation: url -> (union continuation #f)
   ;; extract the key from the url and then lookup the continuation
   (define (url/id->continuation req-uri)
-    (let ([ses-uri (session-url (current-session))])
+    (define ses-uri (session-url (current-session)))
-      (let ([url-path-suffix (split-url-path ses-uri req-uri)])
+    (define url-path-suffix (split-url-path ses-uri req-uri))
-        (and url-path-suffix
+    (if ((length url-path-suffix) . >= . 1)
-             (not (null? url-path-suffix))
+        (let ([k-id (string->number (first url-path-suffix))])
-             (hash-table-get k-table
+          (hash-table-get k-table k-id 
-                             (string->number (car url-path-suffix))
+                          (lambda ()
-                             (lambda () #f))))))
+                            (printf "continuation ~a not found in ~S~n" 
+                                    k-id (hash-table-map k-table (lambda (k v) k)))
+                            #f)))
+        #f))
   
   ;; encode-k-id-in-url: continuation -> url
   ;; encode a continuation id in a url
@@ -61,7 +67,7 @@
        (url-user uri)
        (url-host uri)
        (url-port uri)
-       (append (url-path uri) (list (number->string (continuation->number k))))
+       #t
+       (append (url-path uri) (list (make-path/param (number->string (continuation->number k)) empty)))
        (url-query uri)
-       (url-fragment uri))))
+       (url-fragment uri)))))
-  )

collects/web-server/prototype-web-server/xexpr-extras.ss

@@ -0,0 +1,14 @@
+(module xexpr-extras mzscheme
+  (require (lib "url.ss" "net")
+           (lib "plt-match.ss"))  
+  (provide xexpr+extras->xexpr)
+  
+  (define xexpr+extras->xexpr
+    (match-lambda
+      [(list xe ...)
+       (map xexpr+extras->xexpr xe)]
+      [(and url (? url?))
+       (url->string url)]
+      [x
+       x])))
+