From 2bde2350caa15213fb90919c289c715fc2d80473 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 25 May 2007 23:24:32 +0000 Subject: [PATCH] Purging usage of UTF8 strings and servlet-helpers; as well as expanding the lang-api svn: r6325 --- .../dispatch-servlets2.ss | 6 +- .../prototype-web-server/lang-api.ss | 18 +++-- .../lang-api/web-extras.ss | 75 +++++++++++++++++++ .../{persistent-web-interaction.ss => web.ss} | 43 ++++------- .../servlets/add-param.ss | 11 ++- .../servlets/add-simple.ss | 9 +-- .../prototype-web-server/servlets/add.ss | 9 +-- .../prototype-web-server/servlets/add03.ss | 9 +-- .../prototype-web-server/servlets/add04.ss | 9 +-- .../prototype-web-server/servlets/add05.ss | 9 +-- .../prototype-web-server/servlets/quiz01.ss | 17 ++--- .../prototype-web-server/servlets/quiz02.ss | 17 ++--- .../prototype-web-server/servlets/toobig.ss | 9 +-- 13 files changed, 148 insertions(+), 93 deletions(-) create mode 100644 collects/web-server/prototype-web-server/lang-api/web-extras.ss rename collects/web-server/prototype-web-server/private/{persistent-web-interaction.ss => web.ss} (73%) diff --git a/collects/web-server/prototype-web-server/dispatch-servlets2.ss b/collects/web-server/prototype-web-server/dispatch-servlets2.ss index 2c376fae2e..ad707b3f09 100644 --- a/collects/web-server/prototype-web-server/dispatch-servlets2.ss +++ b/collects/web-server/prototype-web-server/dispatch-servlets2.ss @@ -2,8 +2,8 @@ (require (lib "kw.ss") "../private/configuration.ss" (lib "connection-manager.ss" "web-server" "private") - (lib "response.ss" "web-server") - (lib "servlet-helpers.ss" "web-server" "private") + (lib "request-structs.ss" "web-server") + (lib "response-structs.ss" "web-server") (lib "response.ss" "web-server" "private") (lib "util.ss" "web-server" "private") (lib "url.ss" "net") @@ -13,7 +13,7 @@ (lib "session.ss" "web-server" "prototype-web-server" "private") (only (lib "abort-resume.ss" "web-server" "prototype-web-server" "private") run-start) - (only "private/persistent-web-interaction.ss" + (only "private/web.ss" start-servlet) (lib "web-cells.ss" "web-server" "prototype-web-server" "lang-api") "xexpr-extras.ss" diff --git a/collects/web-server/prototype-web-server/lang-api.ss b/collects/web-server/prototype-web-server/lang-api.ss index baed042c96..61bdd6170b 100644 --- a/collects/web-server/prototype-web-server/lang-api.ss +++ b/collects/web-server/prototype-web-server/lang-api.ss @@ -1,12 +1,20 @@ (module lang-api mzscheme - (require "private/abort-resume.ss" - "private/persistent-web-interaction.ss" + (require (lib "request-structs.ss" "web-server") + (lib "response-structs.ss" "web-server") + (lib "url.ss" "net") + "private/abort-resume.ss" + "private/web.ss" "lang-api/web-cells.ss" "lang-api/web-param.ss" - "lang-api/file-box.ss") + "lang-api/file-box.ss" + "lang-api/web-extras.ss") (provide (all-from-except mzscheme #%module-begin) + (all-from (lib "request-structs.ss" "web-server")) + (all-from (lib "response-structs.ss" "web-server")) + (all-from (lib "url.ss" "net")) (all-from "private/abort-resume.ss") - (all-from "private/persistent-web-interaction.ss") + (all-from "private/web.ss") (all-from "lang-api/web-cells.ss") (all-from "lang-api/web-param.ss") - (all-from "lang-api/file-box.ss"))) \ No newline at end of file + (all-from "lang-api/file-box.ss") + (all-from "lang-api/web-extras.ss"))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/lang-api/web-extras.ss b/collects/web-server/prototype-web-server/lang-api/web-extras.ss new file mode 100644 index 0000000000..305a71280a --- /dev/null +++ b/collects/web-server/prototype-web-server/lang-api/web-extras.ss @@ -0,0 +1,75 @@ +(module web-extras mzscheme + (require (lib "contract.ss") + (lib "etc.ss") + (lib "plt-match.ss") + (lib "base64.ss" "net") + (lib "request-structs.ss" "web-server") + (lib "response-structs.ss" "web-server") + (lib "url.ss" "net") + "../private/web.ss") + (provide send/suspend/dispatch + redirect/get) + + (define-syntax send/suspend/dispatch + (syntax-rules () + [(_ response-generator) + (extract-proc/url + (send/suspend/url + (lambda (k-url) + (response-generator + (lambda (proc) + (embed-proc/url k-url proc))))))])) + + (define (redirect/get) + (send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily)))) + + ; redirection-status = (make-redirection-status nat str) + (define-struct redirection-status (code message)) + + (define permanently (make-redirection-status 301 "Moved Permanently")) + (define temporarily (make-redirection-status 302 "Moved Temporarily")) + (define see-other (make-redirection-status 303 "See Other")) + + ; : str [redirection-status] -> response + (define redirect-to + (opt-lambda (uri [perm/temp permanently]) + (make-response/full (redirection-status-code perm/temp) + (redirection-status-message perm/temp) + (current-seconds) #"text/html" + `((Location . ,uri)) (list)))) + + ; make-html-response/incremental : ((string -> void) -> void) -> response/incremental + (define (make-html-response/incremental chunk-maker) + (make-response/incremental + 200 "Okay" (current-seconds) #"text/html" '() + chunk-maker)) + + ; Authentication + ; basic-auth-extract-user-pass : (listof (cons sym bytes)) -> (or/c #f (cons str str)) + ;; Notes (GregP) + ;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1) + ;; e.g. an authorization header will look like this: + ;; Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ== + ;; 2. Headers should be read as bytes and then translated to unicode as appropriate. + ;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes + (define (basic-auth-extract-user-pass headers) + (match (headers-assq* #"Authorization" headers) + [#f #f] + [(struct header (_ basic-credentials)) + (cond + [(and (regexp-match #rx#"^Basic .*" + basic-credentials) + (regexp-match #rx"([^:]*):(.*)" + (base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials))))) + => (lambda (user-pass) + (cons (cadr user-pass) (caddr user-pass)))] + [else #f])])) + + (provide/contract + ; XXX contract maybe + [basic-auth-extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))] + [make-html-response/incremental (((string? . -> . void) . -> . void) . -> . response/incremental?)] + [redirect-to ((string?) (redirection-status?) . opt-> . response/full?)] + [permanently redirection-status?] + [temporarily redirection-status?] + [see-other redirection-status?])) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/private/persistent-web-interaction.ss b/collects/web-server/prototype-web-server/private/web.ss similarity index 73% rename from collects/web-server/prototype-web-server/private/persistent-web-interaction.ss rename to collects/web-server/prototype-web-server/private/web.ss index e5247b0d48..fe8f6b0bbb 100644 --- a/collects/web-server/prototype-web-server/private/persistent-web-interaction.ss +++ b/collects/web-server/prototype-web-server/private/web.ss @@ -1,17 +1,16 @@ -(module persistent-web-interaction mzscheme - (require (rename "abort-resume.ss" send/suspend0 send/suspend) +(module web mzscheme + (require (lib "serialize.ss") + (lib "plt-match.ss") + (lib "url.ss" "net") + (lib "request-structs.ss" "web-server") + (rename "abort-resume.ss" send/suspend0 send/suspend) (all-except "abort-resume.ss" send/suspend) "session.ss" - "stuff-url.ss" - (lib "servlet-helpers.ss" "web-server" "private") - (lib "serialize.ss") - (lib "url.ss" "net")) + "stuff-url.ss") (provide send/suspend/hidden send/suspend/url - send/suspend/dispatch extract-proc/url embed-proc/url - redirect/get start-servlet) ;; start-servlet: -> request @@ -63,9 +62,10 @@ (define (extract-proc/url request) (define req-url (request-uri request)) (define binds (url-query req-url)) - (if (exists-binding? embed-label binds) + (define maybe-embedding (assq embed-label binds)) + (if maybe-embedding (let* ([ses (current-session)] - [superkont-url (string->url (extract-binding/single embed-label binds))] + [superkont-url (string->url (cdr maybe-embedding))] [proc (deserialize (unstuff-url superkont-url (session-url ses) @@ -73,19 +73,6 @@ (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) @@ -101,9 +88,7 @@ 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 + (match (bindings-assq #"kont" (request-bindings/raw req)) + [(struct binding:form (id kont)) + (deserialize (read (open-input-bytes kont)))] + [_ #f])))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/servlets/add-param.ss b/collects/web-server/prototype-web-server/servlets/add-param.ss index 4fb3acdb8a..62720a3931 100644 --- a/collects/web-server/prototype-web-server/servlets/add-param.ss +++ b/collects/web-server/prototype-web-server/servlets/add-param.ss @@ -1,8 +1,6 @@ (module add-param (lib "lang.ss" "web-server" "prototype-web-server") - (require (lib "url.ss" "net") - (lib "servlet-helpers.ss" "web-server" "private")) (provide start) - + (define msg (make-parameter "unknown")) (define (gn) @@ -20,9 +18,10 @@ (input ([type "text"] [name "number"] [value ""])) (input ([type "submit"])))))))] [num (string->number - (extract-binding/single - 'number - (request-bindings req)))]) + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req)))))]) (printf "gn ~a ~a~n" (msg) num) num)) diff --git a/collects/web-server/prototype-web-server/servlets/add-simple.ss b/collects/web-server/prototype-web-server/servlets/add-simple.ss index 7fcff778cc..7c99e65735 100644 --- a/collects/web-server/prototype-web-server/servlets/add-simple.ss +++ b/collects/web-server/prototype-web-server/servlets/add-simple.ss @@ -1,6 +1,4 @@ (module add-simple (lib "lang.ss" "web-server" "prototype-web-server") - (require (lib "url.ss" "net") - (lib "servlet-helpers.ss" "web-server" "private")) (provide start) (define msg (make-web-parameter "unknown")) @@ -20,9 +18,10 @@ (input ([type "text"] [name "number"] [value ""])) (input ([type "submit"])))))))] [num (string->number - (extract-binding/single - 'number - (request-bindings req)))]) + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req)))))]) (printf "gn ~a ~a~n" (msg) num) num)) diff --git a/collects/web-server/prototype-web-server/servlets/add.ss b/collects/web-server/prototype-web-server/servlets/add.ss index ae80d87d5a..84726a5cca 100644 --- a/collects/web-server/prototype-web-server/servlets/add.ss +++ b/collects/web-server/prototype-web-server/servlets/add.ss @@ -1,6 +1,4 @@ (module add (lib "lang.ss" "web-server" "prototype-web-server") - (require (lib "url.ss" "net") - (lib "servlet-helpers.ss" "web-server" "private")) (provide start) ;; get-number-from-user: string -> number @@ -20,9 +18,10 @@ (input ([type "text"] [name "number"] [value ""])) (input ([type "submit"])))))))] [num (string->number - (extract-binding/single - 'number - (request-bindings req)))]) + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req)))))]) (printf "gn ~a ~a~n" msg num) num)) diff --git a/collects/web-server/prototype-web-server/servlets/add03.ss b/collects/web-server/prototype-web-server/servlets/add03.ss index f5dcdfc4e8..81a081312a 100644 --- a/collects/web-server/prototype-web-server/servlets/add03.ss +++ b/collects/web-server/prototype-web-server/servlets/add03.ss @@ -1,6 +1,4 @@ (module add03 (lib "lang.ss" "web-server" "prototype-web-server") - (require (lib "url.ss" "net") - (lib "servlet-helpers.ss" "web-server" "private")) (provide start) ;; get-number-from-user: string -> number @@ -19,9 +17,10 @@ (input ([type "submit"])) ,k-hidden)))))]) (string->number - (extract-binding/single - 'number - (request-bindings req))))) + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req))))))) (define (start initial-request) `(html (head (title "Final Page")) diff --git a/collects/web-server/prototype-web-server/servlets/add04.ss b/collects/web-server/prototype-web-server/servlets/add04.ss index 9790fec723..8b069e3d79 100644 --- a/collects/web-server/prototype-web-server/servlets/add04.ss +++ b/collects/web-server/prototype-web-server/servlets/add04.ss @@ -1,6 +1,4 @@ (module add04 (lib "lang.ss" "web-server" "prototype-web-server") - (require (lib "url.ss" "net") - (lib "servlet-helpers.ss" "web-server" "private")) (provide start) ;; get-number-from-user: string -> number @@ -18,9 +16,10 @@ (input ([type "text"] [name "number"] [value ""])) (input ([type "submit"])))))))]) (string->number - (extract-binding/single - 'number - (request-bindings req))))) + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req))))))) (define (start initial-request) `(html (head (title "Final Page")) diff --git a/collects/web-server/prototype-web-server/servlets/add05.ss b/collects/web-server/prototype-web-server/servlets/add05.ss index 88cf8c16c0..02fa674cf9 100644 --- a/collects/web-server/prototype-web-server/servlets/add05.ss +++ b/collects/web-server/prototype-web-server/servlets/add05.ss @@ -1,6 +1,4 @@ (module add05 (lib "lang.ss" "web-server" "prototype-web-server") - (require (lib "url.ss" "net") - (lib "servlet-helpers.ss" "web-server" "private")) (provide start) ;; get-number-from-user: string -> number @@ -16,9 +14,10 @@ k-url (lambda (req) (string->number - (extract-binding/single - 'number - (request-bindings req))))))] + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req))))))))] [method "post"] [enctype "application/x-www-form-urlencoded"]) ,(format "Enter the ~a number to add: " msg) diff --git a/collects/web-server/prototype-web-server/servlets/quiz01.ss b/collects/web-server/prototype-web-server/servlets/quiz01.ss index 199ea59284..2a1be07c6d 100644 --- a/collects/web-server/prototype-web-server/servlets/quiz01.ss +++ b/collects/web-server/prototype-web-server/servlets/quiz01.ss @@ -1,19 +1,16 @@ (module quiz01 (lib "lang.ss" "web-server" "prototype-web-server") - (require "quiz-lib.ss" - (lib "servlet-helpers.ss" "web-server" "private")) + (require "quiz-lib.ss") (provide start) ;; get-answer: mc-question -> number ;; get an answer for a multiple choice question (define (get-answer mc-q) - (let* ([req - (send/suspend/hidden (make-cue-page mc-q))] - [bdgs (request-bindings req)]) - (if (exists-binding? 'answs bdgs) - (string->number - (extract-binding/single - 'answs bdgs)) - -1))) + (string->number + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"answs" + (request-bindings/raw + (send/suspend/hidden (make-cue-page mc-q)))))))) ;; get-answers: (listof mc-question) -> (listof number) ;; get answers for all of the quiz questions. diff --git a/collects/web-server/prototype-web-server/servlets/quiz02.ss b/collects/web-server/prototype-web-server/servlets/quiz02.ss index feb888e616..f6556c0067 100644 --- a/collects/web-server/prototype-web-server/servlets/quiz02.ss +++ b/collects/web-server/prototype-web-server/servlets/quiz02.ss @@ -1,19 +1,16 @@ (module quiz02 (lib "lang.ss" "web-server" "prototype-web-server") - (require "quiz-lib.ss" - (lib "servlet-helpers.ss" "web-server" "private")) + (require "quiz-lib.ss") (provide start) ;; get-answer: mc-question -> number ;; get an answer for a multiple choice question (define (get-answer mc-q) - (let* ([req - (send/suspend/hidden (make-cue-page mc-q))] - [bdgs (request-bindings req)]) - (if (exists-binding? 'answs bdgs) - (string->number - (extract-binding/single - 'answs bdgs)) - -1))) + (string->number + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"answs" + (request-bindings/raw + (send/suspend/hidden (make-cue-page mc-q)))))))) ;; get-answers: (-> (listof mc-question)) -> (listof number) ;; get answers for all of the quiz questions. diff --git a/collects/web-server/prototype-web-server/servlets/toobig.ss b/collects/web-server/prototype-web-server/servlets/toobig.ss index 124af0c76a..70000bf8f1 100644 --- a/collects/web-server/prototype-web-server/servlets/toobig.ss +++ b/collects/web-server/prototype-web-server/servlets/toobig.ss @@ -1,6 +1,4 @@ (module toobig (lib "lang.ss" "web-server" "prototype-web-server") - (require (lib "url.ss" "net") - (lib "servlet-helpers.ss" "web-server" "private")) (provide start) (define (get-n) @@ -16,9 +14,10 @@ (input ([type "text"] [name "number"] [value ""])) (input ([type "submit"])))))))]) (string->number - (extract-binding/single - `number - (request-bindings req))))) + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req))))))) (define (get-bytes) (let* ([the-bytes