From d0318270a4168e2827a4c80e70fd970bdc43e405 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 24 May 2007 16:39:30 +0000 Subject: [PATCH] Recovering bitrot, adding features and fixes svn: r6269 --- .../prototype-web-server/abort-resume.ss | 123 +++++++---- .../prototype-web-server/closure.ss | 90 +++++--- .../prototype-web-server/define-closure.ss | 5 +- .../prototype-web-server/defunctionalize.ss | 6 +- .../prototype-web-server/elim-call-cc.ss | 8 +- .../prototype-web-server/elim-letrec.ss | 18 +- .../prototype-web-server/expander.ss | 4 +- .../hardcoded-configuration.ss | 205 +++++++++--------- .../prototype-web-server/interaction.ss | 3 +- .../prototype-web-server/normalizer.ss | 21 +- .../persistent-expander.ss | 5 +- .../persistent-interaction.ss | 3 +- .../persistent-web-interaction.ss | 57 ++++- .../web-server/prototype-web-server/run.ss | 33 +++ .../web-server/prototype-web-server/server.ss | 204 +++++++---------- .../prototype-web-server/servlets/add01.ss | 6 +- .../prototype-web-server/servlets/add02.ss | 7 +- .../prototype-web-server/servlets/add03.ss | 6 +- .../prototype-web-server/servlets/add04.ss | 5 +- .../prototype-web-server/servlets/add05.ss | 49 +++++ .../prototype-web-server/servlets/quiz-lib.ss | 3 +- .../prototype-web-server/servlets/quiz01.ss | 2 +- .../prototype-web-server/servlets/quiz02.ss | 2 +- .../prototype-web-server/servlets/toobig.ss | 37 ++++ .../prototype-web-server/session.ss | 16 +- .../prototype-web-server/stuff-url.ss | 140 ++++++++++-- .../prototype-web-server/syntax-utils.ss | 9 +- .../tests/certify-error2.ss | 2 + .../tests/language-tester.ss | 2 +- .../tests/persistent-interaction-tests.ss | 2 +- .../tests/stuff-url-tests.ss | 4 +- .../prototype-web-server/tests/suite.ss | 40 ++-- .../tests/test-normalizer.ss | 8 +- .../web-server/prototype-web-server/utils.ss | 11 +- .../prototype-web-server/web-interaction.ss | 28 ++- .../prototype-web-server/xexpr-extras.ss | 14 ++ 36 files changed, 745 insertions(+), 433 deletions(-) create mode 100644 collects/web-server/prototype-web-server/run.ss create mode 100644 collects/web-server/prototype-web-server/servlets/add05.ss create mode 100644 collects/web-server/prototype-web-server/servlets/toobig.ss create mode 100644 collects/web-server/prototype-web-server/tests/certify-error2.ss create mode 100644 collects/web-server/prototype-web-server/xexpr-extras.ss diff --git a/collects/web-server/prototype-web-server/abort-resume.ss b/collects/web-server/prototype-web-server/abort-resume.ss index 21cddc51f3..3c10310440 100644 --- a/collects/web-server/prototype-web-server/abort-resume.ss +++ b/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 @@ -22,91 +25,126 @@ ) (provide current-abort-continuation) - - ;; ********************************************************************** - ;; ********************************************************************** - ;; AUXILLIARIES + ;; ********************************************************************** + ;; ********************************************************************** + ;; 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?)]) - ;(printf "sl = ~s~n" sl) - (if (andmap (lambda (x) x) sl) - (reverse (continuation-mark-set->list cm the-cont-key)) - (error "Attempt to capture a continuation from within an unsafe context")))) + [sl (reverse (continuation-mark-set->list cm safe-call?))]) + (if (andmap (lambda (x) + (if (pair? x) + (car x) + 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 - [(null? frames) val] - [else - (let ([f (car frames)]) - (f (with-continuation-mark the-cont-key f (resume (cdr frames) val))))])) + #;(printf "~S~n" `(resume ,frames ,val)) + (match frames + [(list) + (apply values 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 () [(_ expr) #'((let/cc abort-k (set-box! current-abort-continuation abort-k) - (lambda () expr)))])) - + (lambda () expr)))])) ;; a serializable undefined value (define-serializable-struct undef ()) - (define the-undef (make-undef)) - - + (define the-undef (make-undef)) ;; ********************************************************************** ;; ********************************************************************** - ;; "SERVLET" INTERFACE - + ;; "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))]) - (lambda (x) (abort (lambda () (resume current-marks x))))))) - - (define-closure kont (x) (current-marks) - (abort (lambda () (resume current-marks x)))) + (continuation-mark-set->list* (current-continuation-marks) (list the-cont-key the-save-cm-key)))]) + (lambda x (abort (lambda () (resume current-marks x))))))) + + (define-closure kont x (wcs current-marks) + (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 - ((lambda (k) (abort (lambda () (response-maker k)))) - (let ([current-marks (activation-record-list)]) - (make-kont (lambda () current-marks)))))) - - + (with-continuation-mark safe-call? '(#t send/suspend) + (let ([current-marks (activation-record-list)] + [wcs (capture-web-cell-set)]) + ((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))))))) ;; ********************************************************************** ;; ********************************************************************** @@ -119,11 +157,10 @@ ;; dispatch: request -> response ;; lookup the continuation for this request and invoke it - (define (dispatch req) + (define (dispatch req) (abort/cc (cond [(decode-continuation req) => (lambda (k) (k req))] [else - (error "no continuation associated with the provided request")]))) - ) \ No newline at end of file + (error "no continuation associated with the provided request")])))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/closure.ss b/collects/web-server/prototype-web-server/closure.ss index 5911371c13..63a72f6deb 100644 --- a/collects/web-server/prototype-web-server/closure.ss +++ b/collects/web-server/prototype-web-server/closure.ss @@ -2,23 +2,29 @@ (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) - (datum->syntax-object - id - (string->symbol - (format "web-deserialize-info:~a" (syntax-e id))) - id)) + (datum->syntax-object + id + (string->symbol + (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)))))]) + (datum->syntax-object + tag (string->symbol (format str (syntax-object->datum tag)))))]) (let ([deserialize-info:CLOSURE (make-deserialize-name tag)]) (with-syntax ([CLOSURE:serialize-info (make-id "~a:serialize-info")] [make-CLOSURE (make-id "make-~a")] @@ -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 () (make-CLOSURE)) - #`(lambda #,fvars (make-CLOSURE (lambda () (values #,@fvars))))) + (lambda args + (apply #,(if (null? 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) - #'(make-CLOSURE (lambda () (error "closure not initialized"))))]) + (syntax/loc proc (make-CLOSURE)) + (syntax/loc proc (make-CLOSURE (lambda () (error "closure not initialized")))))]) (values new-closure #,(if (null? fvars) - #'void - #'(lambda (clsr) - (set-CLOSURE-env! new-closure (CLOSURE-env clsr))))))))) + (syntax/loc proc void) + (syntax/loc proc + (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)) - #'(lambda (clsr) + (syntax/loc proc (lambda (clsr) (vector))) + (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) - #'() - #'(CLOSURE-env set-CLOSURE-env!))) + (quasisyntax/loc proc + (define-values (struct:CLOSURE make-CLOSURE CLOSURE? + #,@(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) - #,proc-body) - #`(lambda (clsr #,@formals) + (quasisyntax/loc proc + (lambda (clsr . args) + (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) - #'() - #'((lambda (clsr) (CLOSURE-ref clsr 0)) - (lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env)))))))))))))) \ No newline at end of file + (syntax/loc proc ()) + (syntax/loc proc + ((lambda (clsr) (CLOSURE-ref clsr 0)) + (lambda (clsr new-env) (CLOSURE-set! clsr 0 new-env)))))))))))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/define-closure.ss b/collects/web-server/prototype-web-server/define-closure.ss index d6b5f184f6..4a944ae940 100644 --- a/collects/web-server/prototype-web-server/define-closure.ss +++ b/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))]))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/defunctionalize.ss b/collects/web-server/prototype-web-server/defunctionalize.ss index a6e80ccb73..1b9d3fcd7f 100644 --- a/collects/web-server/prototype-web-server/defunctionalize.ss +++ b/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) diff --git a/collects/web-server/prototype-web-server/elim-call-cc.ss b/collects/web-server/prototype-web-server/elim-call-cc.ss index 86cb7a058a..edae35f308 100644 --- a/collects/web-server/prototype-web-server/elim-call-cc.ss +++ b/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]))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/elim-letrec.ss b/collects/web-server/prototype-web-server/elim-letrec.ss index c9722af9af..21e7818589 100644 --- a/collects/web-server/prototype-web-server/elim-letrec.ss +++ b/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)] - [(lambda (formals ...) body) - (with-syntax ([body (recertify #'body expr)]) - #`(lambda (formals ...) #,(elim-letrec/ids #'body ids)))] + (raise-syntax-error #f "elim-letrec: Not all letrec-values-expressions supported" expr)] + [(lambda (formals ...) body-expr ...) + (with-syntax ([(body-expr ...) (recertify* (syntax->list #'(body-expr ...)) expr)]) + #`(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) diff --git a/collects/web-server/prototype-web-server/expander.ss b/collects/web-server/prototype-web-server/expander.ss index 2c73edd508..8c8a69674f 100644 --- a/collects/web-server/prototype-web-server/expander.ss +++ b/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)]))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/hardcoded-configuration.ss b/collects/web-server/prototype-web-server/hardcoded-configuration.ss index 8625eb8571..36b3817472 100644 --- a/collects/web-server/prototype-web-server/hardcoded-configuration.ss +++ b/collects/web-server/prototype-web-server/hardcoded-configuration.ss @@ -1,6 +1,6 @@ (module hardcoded-configuration mzscheme - (require (lib "configuration-structures.ss" "web-server") - (lib "util.ss" "web-server") + (require (lib "configuration-structures.ss" "web-server" "private") + (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,102 +46,109 @@ (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")) + + (define hardcoded-host + ; host = (make-host (listof str) (str str sym url str -> str) + ; passwords resopnders timeouts paths) + (make-host + + ;; indices + (list "index.html" "index.htm") + + ;; log-format + 'none + + ;; log-message + "log" + + ;; passwords + "passwords" + + (make-responders + + ;; servlet: url tst -> response + (lambda (url exn) + ; more here - use separate log file + ;(printf "Servlet exception:\n~s\n" (exn-message exn)) + ((error-display-handler) + (format "Servlet exception:\n~a\n" (exn-message exn)) + exn) + (error-response 500 "Servlet error" servlet-error-file)) + + ;; servlet-loading: url tst -> response + ; more here - parameterize error based on a configurable file, perhaps? + ; This is slightly tricky since the (interesting) content comes from the exception. + (lambda (url exn) + ((error-display-handler) + (format "Servlet loading exception:\n~a\n" (exn-message exn)) + exn) + (make-response/full 500 "Servlet didn't load" + (current-seconds) + #"text/plain" ;TEXT/HTML-MIME-TYPE + '() ; check + (list "Servlet didn't load.\n" + (exn->string exn)))) + + ;; authentication: url (cons sym str) -> response + (lambda (uri recommended-header) + (error-response 401 "Authorization Required" access-denied-file + recommended-header)) + + ;; servlets-refreshed: -> response + (lambda () + (error-response 200 "Servlet cache refreshed" servlet-refresh-file)) + + ;; passwords-refreshed: -> response + (lambda () + (error-response 200 "Passwords refreshed" password-refresh-file)) + + ;; file-not-found: url->response + (lambda (url) + (error-response 404 "File not found" file-not-found-file)) + + ;; protocol: string -> response + (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) + (make-timeouts + ; default-servlet-timeout + 60 + ;password-connection-timeout + 300 + ; servlet-connection-timeout + 86400 + ; file-per-byte-connection-timeout + 1/20 + ; file-base-connection-timeout + 30) + + ; paths = (make-paths str^6) + (make-paths + ; configuration-root + (build-path server-root-path "conf") + ; host-root + (build-path server-root-path "default-web-root") + ; log-file-path + "log" + ; file-root + (build-path server-root-path "htdocs") + ; servlet-root + (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")))) ;; config:virtual-hosts: alpha -> 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 - - ;; indices - (list "index.html" "index.htm") - - ;; log-message - (lambda (str0 str1 sym0 url0 str2) - (error "log-message not implemented")) - - ;; passwords - '() - - (make-responders - - ;; servlet: url tst -> response - (lambda (url exn) - ; more here - use separate log file - ;(printf "Servlet exception:\n~s\n" (exn-message exn)) - ((error-display-handler) - (format "Servlet exception:\n~a\n" (exn-message exn)) - exn) - (error-response 500 "Servlet error" servlet-error-file)) - - ;; servlet-loading: url tst -> response - ; more here - parameterize error based on a configurable file, perhaps? - ; This is slightly tricky since the (interesting) content comes from the exception. - (lambda (url exn) - ((error-display-handler) - (format "Servlet loading exception:\n~a\n" (exn-message exn)) - exn) - (make-response/full 500 "Servlet didn't load" - (current-seconds) - #"text/plain" ;TEXT/HTML-MIME-TYPE - '() ; check - (list "Servlet didn't load.\n" - (exn->string exn)))) - - ;; authentication: url (cons sym str) -> response - (lambda (uri recommended-header) - (error-response 401 "Authorization Required" access-denied-file - recommended-header)) - - ;; servlets-refreshed: -> response - (lambda () - (error-response 200 "Servlet cache refreshed" servlet-refresh-file)) - - ;; passwords-refreshed: -> response - (lambda () - (error-response 200 "Passwords refreshed" password-refresh-file)) - - ;; file-not-found: url->response - (lambda (url) - (error-response 404 "File not found" file-not-found-file)) - - ;; protocol: string -> response - (lambda (error-message) - (error-response 400 "Malformed Request" protocol-file)) - - ) - - ; timeouts = (make-timeouts nat^5) - (make-timeouts - ; default-servlet-timeout - 60 - ;password-connection-timeout - 300 - ; servlet-connection-timeout - 86400 - ; file-per-byte-connection-timeout - 1/20 - ; file-base-connection-timeout - 30) - - ; paths = (make-paths str^6) - (make-paths - ; configuration-root - (build-path server-root-path "conf") - ; host-root - (build-path server-root-path "default-web-root") - ; log-file-path - "log" - ; file-root - (build-path server-root-path "htdocs") - ; servlet-root - (build-path "~" "plt-exp" "collects" "prototype-web-server" "servlets") - ; password-authentication - (build-path server-root-path "passwords")) - )]) - - (lambda (ignore) - hardcoded-host))) - ) \ No newline at end of file + (lambda (ignore) + hardcoded-host))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/interaction.ss b/collects/web-server/prototype-web-server/interaction.ss index 71f3559505..3421e308e9 100644 --- a/collects/web-server/prototype-web-server/interaction.ss +++ b/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) - ) \ No newline at end of file + send/suspend)) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/normalizer.ss b/collects/web-server/prototype-web-server/normalizer.ss index 5297872894..142006c10f 100644 --- a/collects/web-server/prototype-web-server/normalizer.ss +++ b/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))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/persistent-expander.ss b/collects/web-server/prototype-web-server/persistent-expander.ss index 42ac5c1b27..ce245cdc8a 100644 --- a/collects/web-server/prototype-web-server/persistent-expander.ss +++ b/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)])) - - ) - \ No newline at end of file + (raise-syntax-error #f "extra body expression, or expression out of order" stx)]))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/persistent-interaction.ss b/collects/web-server/prototype-web-server/persistent-interaction.ss index abb045e942..caf3dc39ae 100644 --- a/collects/web-server/prototype-web-server/persistent-interaction.ss +++ b/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) - ) \ No newline at end of file + send/suspend)) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/persistent-web-interaction.ss b/collects/web-server/prototype-web-server/persistent-web-interaction.ss index 458c813072..b9cf5f8a9d 100644 --- a/collects/web-server/prototype-web-server/persistent-web-interaction.ss +++ b/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= (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= (let ([bdgs (request-bindings req)]) (and (exists-binding? 'kont bdgs) (deserialize (read (open-input-string - (extract-binding/single 'kont bdgs)))))))) - ) \ No newline at end of file + (extract-binding/single 'kont bdgs))))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/run.ss b/collects/web-server/prototype-web-server/run.ss new file mode 100644 index 0000000000..f34a61ce8a --- /dev/null +++ b/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))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/server.ss b/collects/web-server/prototype-web-server/server.ss index 629861cac8..4b1071fc0f 100644 --- a/collects/web-server/prototype-web-server/server.ss +++ b/collects/web-server/prototype-web-server/server.ss @@ -1,27 +1,35 @@ (module server mzscheme - (require (lib "connection-manager.ss" "web-server") - (lib "request-parsing.ss" "web-server") - (lib "response.ss" "web-server") - ;(lib "util.ss" "web-server") + (require (lib "connection-manager.ss" "web-server" "private") + (lib "request.ss" "web-server" "private") + (lib "response.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 "configuration-structures.ss" "web-server") - + (lib "plt-match.ss") + (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" - "session.ss" - ) - - (provide serve) - - (define myprint printf) - + "hardcoded-configuration.ss") + + (provide serve dispatch) + + (define myprint printf #;(lambda _ (void))) + (define thread-connection-state (make-thread-cell #f)) (define-struct connection-state (conn req)) (define top-cust (current-custodian)) - + ;; ************************************************************ ;; serve: -> -> void ;; start the server and return a thunk to shut it down @@ -41,7 +49,7 @@ (server-loop get-ports))))) (lambda () (custodian-shutdown-all the-server-custodian)))) - + ;; ************************************************************ ;; server-loop: (-> i-port o-port) -> void ;; start a thread to handle each incoming connection @@ -56,7 +64,7 @@ (new-connection config:initial-connection-timeout ip op (current-custodian) #f))))))) (loop))) - + ;; ************************************************************ ;; serve-connection: connection -> void ;; respond to all requests on this connection @@ -79,39 +87,26 @@ (cond [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 "") - (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") - - (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)) - - + (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))) + ;; ************************************************************ ;; ************************************************************ ;; SERVING SERVLETS - + ;; servlet-content-producer: connection request host -> void (define (servlet-content-producer conn req host-info) (myprint "servlet-content-producer~n") @@ -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 @@ -145,64 +136,43 @@ (resume-session session-id host-info))] [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)) - + ;; resume-session? url -> (union number #f) ;; 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)]) - (and str - (let ([param-match (match-url-params str)]) - (and (not (null? param-match)) - (string->number (car param-match))))))) - + (let ([k-params (filter match-url-params + (apply append + (map path/param-param (url-path a-url))))]) + (myprint "resume-session?: ~S~n" k-params) + (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) (let ([l (filter path/param? (url-path a-url))]) (and (not (null? l)) (path/param-param (car l))))) - + ;(resume-session? (string->url "http://localhost:9000/;123")) ;(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,18 +191,30 @@ [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)) ((responders-file-not-found (host-responders host-info)) uri) (request-method (connection-state-req (thread-cell-ref thread-connection-state)))))))) - + (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 (let ([get-name @@ -241,7 +223,7 @@ spec ((current-module-name-resolver) spec #f #f)))]) (map get-name to-be-copied-module-specs))) - + (define (make-servlet-namespace) (let ([server-namespace (current-namespace)] [new-namespace (make-namespace)]) @@ -249,27 +231,11 @@ (for-each (lambda (name) (namespace-attach-module server-namespace name)) 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)) - ((session-handler ses) - (connection-state-req (thread-cell-ref thread-connection-state)))))))] + (xexpr+extras->xexpr + ((session-handler ses) + (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 - (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))))])) - - ) + (begin-session host-info)]))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/servlets/add01.ss b/collects/web-server/prototype-web-server/servlets/add01.ss index 25c450266d..20fd7c7b0d 100644 --- a/collects/web-server/prototype-web-server/servlets/add01.ss +++ b/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 "url.ss" "net") - ) + (lib "request.ss" "web-server" "private") + (lib "request-structs.ss" "web-server") + (lib "url.ss" "net")) (define (dispatch req) (let* ([uri (request-uri req)] diff --git a/collects/web-server/prototype-web-server/servlets/add02.ss b/collects/web-server/prototype-web-server/servlets/add02.ss index d16f722287..2fcff81f46 100644 --- a/collects/web-server/prototype-web-server/servlets/add02.ss +++ b/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"))))))) - - ) \ No newline at end of file + (+ (gn "first") (gn "second")))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/servlets/add03.ss b/collects/web-server/prototype-web-server/servlets/add03.ss index b154342e0c..9d3369ec75 100644 --- a/collects/web-server/prototype-web-server/servlets/add03.ss +++ b/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"))))))) - ) \ No newline at end of file + (+ (gn "first") (gn "second")))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/servlets/add04.ss b/collects/web-server/prototype-web-server/servlets/add04.ss index 7d430248d6..4b016416d6 100644 --- a/collects/web-server/prototype-web-server/servlets/add04.ss +++ b/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"))))))) - ) \ No newline at end of file + (+ (gn "first") (gn "second")))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/servlets/add05.ss b/collects/web-server/prototype-web-server/servlets/add05.ss new file mode 100644 index 0000000000..f010a962dc --- /dev/null +++ b/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")))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/servlets/quiz-lib.ss b/collects/web-server/prototype-web-server/servlets/quiz-lib.ss index 86a756cf76..56628c107b 100644 --- a/collects/web-server/prototype-web-server/servlets/quiz-lib.ss +++ b/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) diff --git a/collects/web-server/prototype-web-server/servlets/quiz01.ss b/collects/web-server/prototype-web-server/servlets/quiz01.ss index 57410dac86..27203ff63b 100644 --- a/collects/web-server/prototype-web-server/servlets/quiz01.ss +++ b/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 diff --git a/collects/web-server/prototype-web-server/servlets/quiz02.ss b/collects/web-server/prototype-web-server/servlets/quiz02.ss index 7d5d0b975a..116fd87695 100644 --- a/collects/web-server/prototype-web-server/servlets/quiz02.ss +++ b/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 diff --git a/collects/web-server/prototype-web-server/servlets/toobig.ss b/collects/web-server/prototype-web-server/servlets/toobig.ss new file mode 100644 index 0000000000..21f52eb1fd --- /dev/null +++ b/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))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/session.ss b/collects/web-server/prototype-web-server/session.ss index 14c962d433..9bb2c378df 100644 --- a/collects/web-server/prototype-web-server/session.ss +++ b/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)))) - - ) - - - - \ No newline at end of file + (url-fragment in-url))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/stuff-url.ss b/collects/web-server/prototype-web-server/stuff-url.ss index e5f420074c..3b972e62fc 100644 --- a/collects/web-server/prototype-web-server/stuff-url.ss +++ b/collects/web-server/prototype-web-server/stuff-url.ss @@ -1,6 +1,12 @@ (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) - '((lib "abort-resume.ss" "prototype-web-server") . web-deserialize-info:kont) + (if (symbol? n-or-k) + `((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))]) @@ -172,23 +238,70 @@ (when (> (string-length (url->string result-uri)) 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)]) + [qry (url-query req-url)]) (recover-serial mod-path (find-binding 'c qry) (map (lambda (elt) - (if (string=? elt "k") 'k - (string->number elt))) + (define nelt (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))])) - ) \ No newline at end of file + [else (find-binding key (cdr qry))]))) diff --git a/collects/web-server/prototype-web-server/syntax-utils.ss b/collects/web-server/prototype-web-server/syntax-utils.ss index 3b778cc986..1e0e7fd0ec 100644 --- a/collects/web-server/prototype-web-server/syntax-utils.ss +++ b/collects/web-server/prototype-web-server/syntax-utils.ss @@ -11,10 +11,8 @@ ;; (listof syntax) syntax -> syntax ;; recertify a list of syntax parts given the whole (define (recertify* exprs old-expr) - (map - (lambda (expr) - (syntax-recertify expr old-expr (current-code-inspector) #f)) - exprs)) + (map (lambda (expr) (recertify expr old-expr)) + exprs)) ;; generate-formal: -> identifier (define (generate-formal sym-name) @@ -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))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/certify-error2.ss b/collects/web-server/prototype-web-server/tests/certify-error2.ss new file mode 100644 index 0000000000..378ad57509 --- /dev/null +++ b/collects/web-server/prototype-web-server/tests/certify-error2.ss @@ -0,0 +1,2 @@ +(module certify-error2 "../persistent-interaction.ss" + (or #f #t)) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/language-tester.ss b/collects/web-server/prototype-web-server/tests/language-tester.ss index c5855d9106..b5ed8c7b72 100644 --- a/collects/web-server/prototype-web-server/tests/language-tester.ss +++ b/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))))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/persistent-interaction-tests.ss b/collects/web-server/prototype-web-server/tests/persistent-interaction-tests.ss index 3537a9de30..df13c1a146 100644 --- a/collects/web-server/prototype-web-server/tests/persistent-interaction-tests.ss +++ b/collects/web-server/prototype-web-server/tests/persistent-interaction-tests.ss @@ -287,7 +287,7 @@ (let ([ignore (start-interaction car)]) (let ([result (+ (gn "first") (gn "second"))]) (let ([ignore (printf "The answer is: ~s~n" result)]) - result)))))]) + result)))))]) (let* ([first-key (test-m06.1 '(dispatch-start 'foo))] [second-key (test-m06.1 `(dispatch (list (deserialize (serialize ,first-key)) 1)))] diff --git a/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss b/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss index e48db6985d..7cd125a1f6 100644 --- a/collects/web-server/prototype-web-server/tests/stuff-url-tests.ss +++ b/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 diff --git a/collects/web-server/prototype-web-server/tests/suite.ss b/collects/web-server/prototype-web-server/tests/suite.ss index 813bd4bc3a..b240b5eda9 100644 --- a/collects/web-server/prototype-web-server/tests/suite.ss +++ b/collects/web-server/prototype-web-server/tests/suite.ss @@ -1,20 +1,20 @@ -(require (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 1)) - (planet "test.ss" ("schematics" "schemeunit.plt" 1 1)) - "persistent-close-tests.ss" - "test-normalizer.ss" - "closure-tests.ss" - "labels-tests.ss" - "persistent-interaction-tests.ss" - "stuff-url-tests.ss") - -(test/graphical-ui - (make-test-suite - "Main Tests for Prototype Web Server" - persistent-close-suite - stuff-url-suite - test-normalizer-suite - closure-tests-suite - labels-tests-suite - persistent-interaction-suite - )) - +(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" + "closure-tests.ss" + "labels-tests.ss" + "persistent-interaction-tests.ss" + "stuff-url-tests.ss") + + (test/graphical-ui + (make-test-suite + "Main Tests for Prototype Web Server" + persistent-close-suite + stuff-url-suite + test-normalizer-suite + closure-tests-suite + labels-tests-suite + persistent-interaction-suite + ))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/tests/test-normalizer.ss b/collects/web-server/prototype-web-server/tests/test-normalizer.ss index 4a06d77496..c3fa793f86 100644 --- a/collects/web-server/prototype-web-server/tests/test-normalizer.ss +++ b/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" - (exn-message the-exn)))]) + (and (regexp-match "normalize: Not all lambda-expressions supported" + (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))))))) diff --git a/collects/web-server/prototype-web-server/utils.ss b/collects/web-server/prototype-web-server/utils.ss index f02556d32f..16878bd40e 100644 --- a/collects/web-server/prototype-web-server/utils.ss +++ b/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 diff --git a/collects/web-server/prototype-web-server/web-interaction.ss b/collects/web-server/prototype-web-server/web-interaction.ss index b605f21fb8..1dbab43d33 100644 --- a/collects/web-server/prototype-web-server/web-interaction.ss +++ b/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))]) - (let ([url-path-suffix (split-url-path ses-uri req-uri)]) - (and url-path-suffix - (not (null? url-path-suffix)) - (hash-table-get k-table - (string->number (car url-path-suffix)) - (lambda () #f)))))) + (define ses-uri (session-url (current-session))) + (define url-path-suffix (split-url-path ses-uri req-uri)) + (if ((length url-path-suffix) . >= . 1) + (let ([k-id (string->number (first url-path-suffix))]) + (hash-table-get k-table k-id + (lambda () + (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)))) - ) \ No newline at end of file + (url-fragment uri))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/xexpr-extras.ss b/collects/web-server/prototype-web-server/xexpr-extras.ss new file mode 100644 index 0000000000..02bdf34370 --- /dev/null +++ b/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]))) + \ No newline at end of file