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

Clarifying API

Browse Source 
svn: r6408
This commit is contained in:
Jay McCarthy 2007-05-30 15:54:37 +00:00
parent 03836a6825
commit 46d1b3d234
5 changed files with 154 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -8,8 +8,11 @@
"../private/web-server-structs.ss"
"../private/connection-manager.ss"
"../private/response.ss"
"../request-structs.ss"
"../servlet-structs.ss"
"../response-structs.ss"
"../servlet.ss"
"../servlet/web-cells.ss"
"../servlet/web.ss"
"../private/configuration.ss"
"../private/util.ss"
"../managers/manager.ss"

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

@ -2,6 +2,7 @@
(require (lib "url.ss" "net")
"../request-structs.ss"
"../response-structs.ss"
"../servlet/helpers.ss"
"private/abort-resume.ss"
"private/web.ss"
"lang-api/web-cells.ss"
@ -11,7 +12,8 @@
(provide (all-from-except mzscheme #%module-begin)
(all-from (lib "url.ss" "net"))
(all-from "../request-structs.ss")
(all-from "../response-structs.ss")
(all-from "../response-structs.ss")
(all-from "../servlet/helpers.ss")
(all-from "private/abort-resume.ss")
(all-from "private/web.ss")
(all-from "lang-api/web-cells.ss")

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

@ -1,23 +1,9 @@
(module web-extras mzscheme
(require (lib "url.ss" "net")
"../private/web.ss"
(only "../../servlet/helpers.ss"
extract-user-pass
redirect-to
permanently
temporarily
see-other
request-bindings
request-headers))
"../../servlet/helpers.ss")
(provide send/suspend/dispatch
redirect/get
extract-user-pass
redirect-to
permanently
temporarily
see-other
request-bindings
request-headers)
redirect/get)
(define-syntax send/suspend/dispatch
(syntax-rules ()

143
collects/web-server/servlet.ss
View File

@ -1,151 +1,20 @@
(module servlet mzscheme
(require (lib "contract.ss")
(lib "etc.ss")
(lib "xml.ss" "xml"))
(require "managers/manager.ss"
"private/servlet.ss"
"private/url.ss"
"servlet/helpers.ss"
(require "servlet/helpers.ss"
"servlet/web-cells.ss"
"servlet/bindings.ss"
"servlet/basic-auth.ss"
"servlet/servlet-url.ss"
"servlet/web.ss"
"response-structs.ss"
"request-structs.ss"
"servlet-structs.ss")
(provide (all-from "servlet/web-cells.ss")
(provide (all-from "servlet/web.ss")
(all-from "servlet/web-cells.ss")
(all-from "servlet/helpers.ss")
(all-from "servlet/servlet-url.ss")
(all-from "servlet-structs.ss")
(all-from "servlet/bindings.ss")
(all-from "servlet/basic-auth.ss")
(all-from "response-structs.ss")
(all-from "request-structs.ss"))
;; ************************************************************
;; HELPERS
;; replace-procedures : (proc -> url) xexpr/callbacks? -> xexpr?
;; Change procedures to the send/suspend of a k-url
(define (xexpr/callback->xexpr p->a p-exp)
(cond
[(list? p-exp) (map (lambda (p-e) (xexpr/callback->xexpr p->a p-e))
p-exp)]
[(procedure? p-exp) (p->a p-exp)]
[else p-exp]))
;; Weak contracts: the input is checked in output-response, and a message is
;; sent directly to the client (Web browser) instead of the terminal/log.
(provide/contract
[xexpr/callback->xexpr (embed/url? xexpr/callback? . -> . xexpr?)]
; XXX contract
[current-url-transform parameter?]
; XXX contract
[current-servlet-continuation-expiration-handler parameter?]
[redirect/get (-> request?)]
[redirect/get/forget (-> request?)]
[adjust-timeout! (number? . -> . void?)]
[clear-continuation-table! (-> void?)]
[send/back (any/c . -> . void?)]
[send/finish (any/c . -> . void?)]
[send/suspend ((response-generator?) (expiration-handler?) . opt-> . request?)]
[send/forward ((response-generator?) (expiration-handler?) . opt-> . request?)]
[send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)]
[send/suspend/callback (xexpr/callback? . -> . any/c)])
;; ************************************************************
;; EXPORTS
;; current-url-transform : string? -> string?
(define (default-url-transformer x) x)
(define current-url-transform
(make-parameter default-url-transformer))
;; current-servlet-continuation-expiration-handler : request -> response
(define current-servlet-continuation-expiration-handler
(make-parameter #f))
;; adjust-timeout! : sec -> void
;; adjust the timeout on the servlet
(define (adjust-timeout! secs)
((manager-adjust-timeout! (current-servlet-manager)) (get-current-servlet-instance-id) secs))
;; ext:clear-continuations! -> void
(define (clear-continuation-table!)
((manager-clear-continuations! (current-servlet-manager)) (get-current-servlet-instance-id)))
;; send/back: response -> void
;; send a response and don't clear the continuation table
(define (send/back resp)
(define ctxt (thread-cell-ref current-execution-context))
((execution-context-suspend ctxt) resp))
;; send/finish: response -> void
;; send a response and clear the continuation table
(define (send/finish resp)
(clear-continuation-table!)
; If we readjust the timeout to something small, the session will expire shortly
; we cannot wait for send/back to return, because it doesn't
; Also, we cannot get the initial-connection-timeout variable from here
; In the future, we should use the servlet's specific default-timeout
(adjust-timeout! 10)
(send/back resp))
;; send/suspend: (url -> response) [(request -> response)] -> request
;; send a response and apply the continuation to the next request
(define send/suspend
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(with-frame-after
(let/cc k
(define instance-id (get-current-servlet-instance-id))
(define ctxt (thread-cell-ref current-execution-context))
(define k-embedding ((manager-continuation-store! (current-servlet-manager))
instance-id
(make-custodian-box (current-custodian) k)
expiration-handler))
(define k-url ((current-url-transform)
(embed-ids
(list* instance-id k-embedding)
(request-uri (execution-context-request ctxt)))))
(send/back (response-generator k-url))))))
;; send/forward: (url -> response) [(request -> response)] -> request
;; clear the continuation table, then behave like send/suspend
(define send/forward
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(clear-continuation-table!)
(send/suspend response-generator expiration-handler)))
;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request
;; send/back a response generated from a procedure that may convert
;; procedures to continuation urls
(define (send/suspend/dispatch response-generator)
; This restores the tail position.
; Note: Herman's syntactic strategy would fail without the new-request capture.
; (Moving this to the tail-position is not possible anyway, by the way.)
(let ([thunk
(let/cc k0
(send/back
(response-generator
(opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)])
(let/ec k1
(let ([new-request (send/suspend k1 expiration-handler)])
(k0 (lambda () (proc new-request)))))))))])
(thunk)))
;; send/suspend/callback : xexpr/callback? -> void
;; send/back a response with callbacks in it; send/suspend those callbacks.
(define (send/suspend/callback p-exp)
(send/suspend/dispatch
(lambda (embed/url)
(xexpr/callback->xexpr embed/url p-exp))))
;; ************************************************************
;; HIGHER-LEVEL EXPORTS
(define ((make-redirect/get send/suspend))
(send/suspend (lambda (k-url) (redirect-to k-url temporarily))))
; redirect/get : -> request
(define redirect/get (make-redirect/get send/suspend))
(define redirect/get/forget (make-redirect/get send/forward)))
(all-from "request-structs.ss")
(all-from "servlet-structs.ss")))

139
collects/web-server/servlet/web.ss Normal file
View File

@ -0,0 +1,139 @@
(module web mzscheme
(require (lib "contract.ss")
(lib "etc.ss")
(lib "xml.ss" "xml"))
(require "../managers/manager.ss"
"../private/servlet.ss"
"../private/url.ss"
"../servlet/helpers.ss"
"../servlet/web-cells.ss"
"../request-structs.ss"
"../servlet-structs.ss")
;; ************************************************************
;; HELPERS
;; replace-procedures : (proc -> url) xexpr/callbacks? -> xexpr?
;; Change procedures to the send/suspend of a k-url
(define (xexpr/callback->xexpr p->a p-exp)
(cond
[(list? p-exp) (map (lambda (p-e) (xexpr/callback->xexpr p->a p-e))
p-exp)]
[(procedure? p-exp) (p->a p-exp)]
[else p-exp]))
;; Weak contracts: the input is checked in output-response, and a message is
;; sent directly to the client (Web browser) instead of the terminal/log.
(provide/contract
[xexpr/callback->xexpr (embed/url? xexpr/callback? . -> . xexpr?)]
; XXX contract
[current-url-transform parameter?]
; XXX contract
[current-servlet-continuation-expiration-handler parameter?]
[redirect/get (-> request?)]
[redirect/get/forget (-> request?)]
[adjust-timeout! (number? . -> . void?)]
[clear-continuation-table! (-> void?)]
[send/back (any/c . -> . void?)]
[send/finish (any/c . -> . void?)]
[send/suspend ((response-generator?) (expiration-handler?) . opt-> . request?)]
[send/forward ((response-generator?) (expiration-handler?) . opt-> . request?)]
[send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)]
[send/suspend/callback (xexpr/callback? . -> . any/c)])
;; ************************************************************
;; EXPORTS
;; current-url-transform : string? -> string?
(define (default-url-transformer x) x)
(define current-url-transform
(make-parameter default-url-transformer))
;; current-servlet-continuation-expiration-handler : request -> response
(define current-servlet-continuation-expiration-handler
(make-parameter #f))
;; adjust-timeout! : sec -> void
;; adjust the timeout on the servlet
(define (adjust-timeout! secs)
((manager-adjust-timeout! (current-servlet-manager)) (get-current-servlet-instance-id) secs))
;; ext:clear-continuations! -> void
(define (clear-continuation-table!)
((manager-clear-continuations! (current-servlet-manager)) (get-current-servlet-instance-id)))
;; send/back: response -> void
;; send a response and don't clear the continuation table
(define (send/back resp)
(define ctxt (thread-cell-ref current-execution-context))
((execution-context-suspend ctxt) resp))
;; send/finish: response -> void
;; send a response and clear the continuation table
(define (send/finish resp)
(clear-continuation-table!)
; If we readjust the timeout to something small, the session will expire shortly
; we cannot wait for send/back to return, because it doesn't
; Also, we cannot get the initial-connection-timeout variable from here
; In the future, we should use the servlet's specific default-timeout
(adjust-timeout! 10)
(send/back resp))
;; send/suspend: (url -> response) [(request -> response)] -> request
;; send a response and apply the continuation to the next request
(define send/suspend
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(with-frame-after
(let/cc k
(define instance-id (get-current-servlet-instance-id))
(define ctxt (thread-cell-ref current-execution-context))
(define k-embedding ((manager-continuation-store! (current-servlet-manager))
instance-id
(make-custodian-box (current-custodian) k)
expiration-handler))
(define k-url ((current-url-transform)
(embed-ids
(list* instance-id k-embedding)
(request-uri (execution-context-request ctxt)))))
(send/back (response-generator k-url))))))
;; send/forward: (url -> response) [(request -> response)] -> request
;; clear the continuation table, then behave like send/suspend
(define send/forward
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(clear-continuation-table!)
(send/suspend response-generator expiration-handler)))
;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request
;; send/back a response generated from a procedure that may convert
;; procedures to continuation urls
(define (send/suspend/dispatch response-generator)
; This restores the tail position.
; Note: Herman's syntactic strategy would fail without the new-request capture.
; (Moving this to the tail-position is not possible anyway, by the way.)
(let ([thunk
(let/cc k0
(send/back
(response-generator
(opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)])
(let/ec k1
(let ([new-request (send/suspend k1 expiration-handler)])
(k0 (lambda () (proc new-request)))))))))])
(thunk)))
;; send/suspend/callback : xexpr/callback? -> void
;; send/back a response with callbacks in it; send/suspend those callbacks.
(define (send/suspend/callback p-exp)
(send/suspend/dispatch
(lambda (embed/url)
(xexpr/callback->xexpr embed/url p-exp))))
;; ************************************************************
;; HIGHER-LEVEL EXPORTS
(define ((make-redirect/get send/suspend))
(send/suspend (lambda (k-url) (redirect-to k-url temporarily))))
; redirect/get : -> request
(define redirect/get (make-redirect/get send/suspend))
(define redirect/get/forget (make-redirect/get send/forward)))