Permalink
Browse files

As a fix to http://planet.plt-scheme.org/trac/ticket/128, I added a n…

…otion of "response promises" and threaded this all the way up to the page interface so that now there is a #:redirect-to keyword arg which does the right thing with redirecting, even in the presence of cookies, sessions, etc
  • Loading branch information...
1 parent ca30785 commit e72e3be38c637abfdc0300956e88bec1825ca1a9 @vegashacker committed Nov 24, 2008
Showing with 85 additions and 18 deletions.
  1. +11 −2 page.scm
  2. +12 −8 session.scm
  3. +62 −8 web-support.scm
View
@@ -59,6 +59,8 @@
;; * #:raw-header is a list of strings which are inserted directly at the beginning of the
;; <head /> area of the page.
;; * #:doc-type should be #f or a str. If str, it is automatically "rawed".
+;; * #:redirect-to should be #f or a URI str. If str, the body is evaluated but not
+;; returned (since you are asking to redirect).
;;
(define (page #:doc-type (doc-type #f)
#:raw-header (raw-header '())
@@ -72,9 +74,16 @@
#:blank (blank #f)
#:plain-text (plain-text #f)
#:design (a-design #f)
+ #:redirect-to (redirect-to #f)
. body)
- (let ((returned-body (last body)))
- (cond ((response/full? returned-body) returned-body)
+ (let ((returned-body
+ (if (empty? body)
+ (if (not redirect-to)
+ (e "Unless you are doing a #:redirect-to, a body is required.")
+ #f)
+ (last body))))
+ (cond (redirect-to (response-promise-to-redirect redirect-to))
+ ((response/full? returned-body) returned-body)
(plain-text (basic-response (list returned-body)
;; Hey, this is probably where we go all unicode...
#:type #"text/plain; charset=us-ascii"))
View
@@ -80,18 +80,22 @@
(receive (fresh-sesh-id sesh-iden) (make-fresh-session)
(cookied-response "sesh" fresh-sesh-id
body ...))
- `(group ,body ...))))))
+ (let ((body-lst (list body ...)))
+ (or (single-response-promise-in-list body-lst)
+ `(group ,@body-lst))))))))
(define (cookied-response cookie-key-str cookie-val-str
#:expire-in (expire-in THIRTY_DAYS)
. content-lst)
- (list-response content-lst
- #:extras (list (make-header #"Set-Cookie"
- (string->bytes/utf-8
- (format "~A=~A; expires=~A; path=~A"
- cookie-key-str cookie-val-str
- (cookie-expiry-time expire-in)
- "/"))))))
+ (let ((headers (list (make-header #"Set-Cookie"
+ (string->bytes/utf-8
+ (format "~A=~A; expires=~A; path=~A"
+ cookie-key-str cookie-val-str
+ (cookie-expiry-time expire-in)
+ "/"))))))
+ (aif (single-response-promise-in-list content-lst)
+ (response-from-promise it #:headers headers)
+ (list-response content-lst #:extras headers))))
(define (cookie-expiry-time secs-from-now)
(date->string (time-utc->date (make-time 'time-utc 0
View
@@ -10,7 +10,7 @@
)
(provide request-all-bindings
- final-prep-of-response
+ ;; final-prep-of-response (via contract)
xexpr->de-grouped-xexprs
wrap-each-in-list
wrap-each-in-list-with-attrs
@@ -26,6 +26,13 @@
get-url
bindings/string
find-binding
+ ;; list-response (via contract)
+
+ response-promise?
+ ;; single-response-promise-in-list (via contract)
+ ;; response-promise-to-redirect (via contract)
+ ;; response-from-promise (via contract)
+
)
;;
@@ -100,15 +107,9 @@
(define (group-tag? xexpr)
(match xexpr ((list-rest 'group children) #t) (else #f)))
-(define (final-prep-of-response xexpr-or-response)
- (let ((result (xexpr->de-grouped-xexprs xexpr-or-response)))
- (if (and (length= result 1) (response? (first result)))
- (first result)
- (list-response result))))
-
(define (xexpr->de-grouped-xexprs xexpr)
(cond ((not xexpr) '())
- ((not (list? xexpr)) (list xexpr))
+ ((not (list? xexpr)) (list xexpr)) ; non-xexpr response case
((group-tag? xexpr) (append-map xexpr->de-grouped-xexprs (rest xexpr)))
(else (receive (tag attrs children) (xexpr->tag*attrs*children xexpr)
(list (create-xexpr tag attrs
@@ -196,3 +197,56 @@
(if exn-handler
(with-handlers ((exn:fail:network? exn-handler)) (thunk))
(thunk))))
+
+(define-struct response-promise (fn))
+
+;;
+;; response-promise-to-redirect
+;;
+;; A relatively low-level tool for "promising" to construct a redirect response. The issue
+;; is that at the time we know we want to redirect, we don't necessarily know all the
+;; headers that we might want to go into the redirect response. For example, a cookie
+;; may need to be set on the client. Response promises can never make it to the top-level
+;; (the web server), since they are a LeftParen concept only. Thus, the promises must
+;; be "response-from-promise"'d before that happens.
+;;
+(provide/contract (response-promise-to-redirect (-> string? response-promise?)))
+;;
+(define (response-promise-to-redirect redirect-to-uri)
+ (make-response-promise (lambda (#:headers (h '())) (redirect-to redirect-to-uri
+ #:headers h))))
+
+;;
+;; response-from-promise
+;;
+(provide/contract
+ (response-from-promise (->* (response-promise?) (#:headers (listof header?)) response?)))
+;;
+(define (response-from-promise r-p #:headers (headers '()))
+ ((response-promise-fn r-p) #:headers headers))
+
+;;
+;; single-response-promise-in-list
+;;
+(provide/contract
+ (single-response-promise-in-list (-> (listof any/c) (or/c #f response-promise?))))
+;;
+(define (single-response-promise-in-list lst)
+ (and-let* (((and (length= lst 1)))
+ (elt (first lst))
+ ((response-promise? (first lst))))
+ elt))
+
+;;
+;; final-prep-of-response
+;;
+(provide/contract
+ (final-prep-of-response (-> (or/c response? response-promise?) response?)))
+;;
+(define (final-prep-of-response response-or-promise)
+ (if (response-promise? response-or-promise)
+ (response-from-promise response-or-promise)
+ (let ((result (xexpr->de-grouped-xexprs response-or-promise)))
+ (if (and (length= result 1) (response? (first result)))
+ (first result)
+ (list-response result)))))

0 comments on commit e72e3be

Please sign in to comment.