From d7c9b2b771f5ae8969975aaedca478ef98962cd7 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 2 Mar 2009 22:00:15 +0000
Subject: [PATCH] helper function

svn: r13898
---
 collects/web-server/http/response-structs.ss | 26 ++++++++++++++------
 collects/web-server/scribblings/http.scrbl   | 17 ++++++++++++-
 2 files changed, 35 insertions(+), 8 deletions(-)

diff --git a/collects/web-server/http/response-structs.ss b/collects/web-server/http/response-structs.ss
index 32ba8d11d3..04c51915df 100644
--- a/collects/web-server/http/response-structs.ss
+++ b/collects/web-server/http/response-structs.ss
@@ -1,6 +1,5 @@
-#lang scheme/base
-(require mzlib/contract
-         scheme/list
+#lang scheme
+(require scheme
          xml
          web-server/private/xexpr
          web-server/http/request-structs)
@@ -70,9 +69,18 @@
     [else
      (normalize-response
       close?
-      (make-response/full 
-       200 #"Okay" (current-seconds) TEXT/HTML-MIME-TYPE empty
-       (list (string->bytes/utf-8 (xexpr->string resp)))))]))
+      (make-xexpr-response resp))]))
+
+(define (make-xexpr-response
+         xexpr
+         #:code [code 200] 
+         #:message [message #"Okay"]
+         #:seconds [seconds (current-seconds)]
+         #:mime-type [mime-type TEXT/HTML-MIME-TYPE]
+         #:headers [hdrs empty])
+  (make-response/full 
+   code message seconds mime-type hdrs
+   (list (string->bytes/utf-8 (xexpr->string xexpr)))))
 
 (provide/contract
  [struct response/basic
@@ -94,7 +102,11 @@
           [seconds number?]
           [mime bytes?]
           [headers (listof header?)]
-          [generator ((() (listof bytes?) . ->* . any) . -> . any)])]
+          [generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])]
  [response/c contract?]
+ [make-xexpr-response 
+  ((pretty-xexpr/c)
+   (#:code number? #:message bytes? #:seconds number? #:mime-type bytes? #:headers (listof header?))
+   . ->* . response/full?)]
  [normalize-response (boolean? response/c . -> . (or/c response/full? response/incremental?))]
  [TEXT/HTML-MIME-TYPE bytes?])
diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl
index 755edde3ad..f72d5e8d09 100644
--- a/collects/web-server/scribblings/http.scrbl
+++ b/collects/web-server/scribblings/http.scrbl
@@ -13,6 +13,7 @@ The @web-server implements many HTTP RFCs that are provided by this module.
 @; ------------------------------------------------------------
 @section[#:tag "request-structs.ss"]{Requests}
 @(require (for-label web-server/http/request-structs
+                     xml
                      scheme/match))
 
 @defmodule[web-server/http/request-structs]{
@@ -198,7 +199,7 @@ Here is an example typical of what you will find in many applications:
 }
 
 @defstruct[(response/incremental response/basic)
-           ([generator ((() (listof bytes?) . ->* . any) . -> . any)])]{
+           ([generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])]{
  As with @scheme[response/basic], except with @scheme[generator] as a function that is
  called to generate the response body, by being given an @scheme[output-response] function
  that outputs the content it is called with.
@@ -224,6 +225,20 @@ Here is an example typical of what you will find in many applications:
                              xexpr/c)].
 }
 
+@defproc[(make-xexpr-response [xexpr xexpr/c]
+                              [#:code code number? 200]
+                              [#:message message bytes? #"Okay"]
+                              [#:seconds seconds number? (current-seconds)]
+                              [#:mime-type mime-type bytes? TEXT/HTML-MIME-TYPE]
+                              [#:headers headers (listof header?) empty])
+         response/full?]{
+ Equivalent to
+ @schemeblock[
+(make-response/full 
+   code message seconds mime-type headers
+   (list (string->bytes/utf-8 (xexpr->string xexpr))))
+]}
+                         
 @defproc[(normalize-response [close? boolean?] [response response/c])
          (or/c response/full? response/incremental?)]{
  Coerces @scheme[response] into a full response, filling in additional details where appropriate.