suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Purging usage of UTF8 strings and servlet-helpers; as well as expanding the lang-api

Browse Source 
svn: r6325
This commit is contained in:
Jay McCarthy 2007-05-25 23:24:32 +00:00
parent daec269009
commit 2bde2350ca
13 changed files with 148 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/web-server/prototype-web-server/dispatch-servlets2.ss
View File

@ -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"

18
collects/web-server/prototype-web-server/lang-api.ss
View File

@ -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")))
(all-from "lang-api/file-box.ss")
(all-from "lang-api/web-extras.ss")))

75
collects/web-server/prototype-web-server/lang-api/web-extras.ss Normal file
View File

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

43
collects/web-server/prototype-web-server/private/persistent-web-interaction.ss → collects/web-server/prototype-web-server/private/web.ss
View File

@ -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=<k>
(let ([bdgs (request-bindings req)])
(and (exists-binding? 'kont bdgs)
(deserialize
(read
(open-input-string
(extract-binding/single 'kont bdgs)))))))))
(match (bindings-assq #"kont" (request-bindings/raw req))
[(struct binding:form (id kont))
(deserialize (read (open-input-bytes kont)))]
[_ #f]))))

11
collects/web-server/prototype-web-server/servlets/add-param.ss
View File

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

9
collects/web-server/prototype-web-server/servlets/add-simple.ss
View File

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

9
collects/web-server/prototype-web-server/servlets/add.ss
View File

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

9
collects/web-server/prototype-web-server/servlets/add03.ss
View File

@ -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"))

9
collects/web-server/prototype-web-server/servlets/add04.ss
View File

@ -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"))

9
collects/web-server/prototype-web-server/servlets/add05.ss
View File

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

17
collects/web-server/prototype-web-server/servlets/quiz01.ss
View File

@ -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.

17
collects/web-server/prototype-web-server/servlets/quiz02.ss
View File

@ -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.

9
collects/web-server/prototype-web-server/servlets/toobig.ss
View File

@ -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