Merge pull request #172 from clojure-liberator/representation-in-ring…

…-response

Add value parameter to ring-response

CHANGES.markdown

@@ -2,6 +2,11 @@
 
 # New in 0.12.3
 
+* Optionally a value can be specified for ring-response
+  together with a ring map. This value is coerced to a response
+  like liberator does by default while the ring map makes it
+  possible to override whatever part of the response.
+
 ## Bugs fixed
 
 * #169 Always call as-response, even for default handlers

examples/clj/examples.clj

@@ -4,7 +4,7 @@
             [clojure.data.json :as json]
             [liberator.dev :as dev])
   (:use [liberator.core :only [defresource request-method-in]]
-        [liberator.representation :only [Representation]]
+        [liberator.representation :only [Representation ring-response]]
         [compojure.core :only [context ANY routes defroutes]]
         [hiccup.page :only [html5]]
         [clojure.string :only [split]]
@@ -49,7 +49,9 @@
 
 ;; Olympics
 (defresource olympic-games-index
-  :handle-ok (fn [_] (olympics/get-olympic-games-index)))
+  :available-media-types ["text/html" "application/xhtml+xml;q=0.8" "*/*;q=0.6"]
+  :handle-ok (fn [_] (ring-response (olympics/get-olympic-games-index)
+                                    {:headers {"Cache-Control" "public,max-age=60s"}})))
 
 ;; We define a view that will pull in 
 (defrecord OlympicsHtmlPage [main]

src/liberator/core.clj

@@ -1,9 +1,10 @@
 (ns liberator.core
-  (:require [liberator.conneg :as conneg])
-  (:use
-   [liberator.util :only [parse-http-date http-date as-date make-function]]
-   [liberator.representation :only [Representation as-response ring-response]]
-   [clojure.string :only [join upper-case]])
+  (:require [liberator.conneg :as conneg]
+            [liberator.representation :refer
+             [Representation as-response ring-response]]
+            [liberator.util :refer
+             [as-date http-date parse-http-date combine make-function]]
+            [clojure.string :refer [join upper-case]])
   (:import (javax.xml.ws ProtocolException)))
 
 (defmulti coll-validator
@@ -61,17 +62,6 @@
     (if-let [lm-val (f context)]
       (as-date lm-val))))
 
-;; A more sophisticated update of the request than a simple merge
-;; provides.  This allows decisions to return maps which modify the
-;; original request in the way most probably intended rather than the
-;; over-destructive default merge.
-(defn combine [curr newval]
-  (cond
-   (and (map? curr) (map? newval)) (merge-with combine curr newval)
-   (and (list? curr) (list? newval)) (concat curr newval)
-   (and (vector? curr) (vector? newval)) (vec (concat curr newval))
-   :otherwise newval))
-
 (defn update-context [context context-update]
   (cond
    (map? context-update) (combine context context-update)

src/liberator/representation.clj

@@ -1,10 +1,10 @@
 (ns liberator.representation
   (:require
    [clojure.data.json :as json]
-   [clojure.data.csv :as csv])
-  (:use
-   [hiccup.core :only [html]]
-   [hiccup.page :only [html5 xhtml]]))
+   [clojure.data.csv :as csv]
+   [liberator.util :as util]
+   [hiccup.core :refer [html]]
+   [hiccup.page :refer [html5 xhtml]]))
 
 ;; This namespace provides default 'out-of-the-box' web representations
 ;; for many IANA mime-types.
@@ -227,10 +227,44 @@
        :headers {"Content-Type" (format "%s;charset=%s" (get representation :media-type "text/plain") charset)}})))
 
 ;; define a wrapper to tell a generic Map from a Ring response map
-;; to return a ring response as the representation
-(defrecord RingResponse [response]
+;; and to return a ring response as the representation
+(defrecord RingResponse [ring-response value]
   Representation
-  (as-response [this context]
-    response))
+  (as-response [_ context]
+    (let [base (when value (as-response value context))]
+      (util/combine base ring-response))))
+
+(defn ring-response
+  "Returns the given map as a ring response. The map is not converted
+  with `as-response`.
+
+  An optional representation value will be converted to a ring-response
+  using `as-response` as usual  and the ring-response parameter will be
+  merged over it.
+
+  The merge is done with `liberator.core/combine` and thus merges
+  recursively.
+
+  Example:
+
+  A handler returns
+
+    (ring-response {:foo :bar}
+                   {:status 999
+                    :headers {\"X-Custom\" \"value\"})
+
+  The final response will have the overriden status code 999 and a
+  custom header set. Assuming the negotiated content type was
+  application/json the response will be
+
+    {:headers {\"Content-Type\" \"application/json\"
+               \"X-Custom\" \"value\"}
+     :status 999
+     :body \"{'foo': 'bar'}\"} "
+  ([ring-response-map] (ring-response nil ring-response-map))
+  ([value ring-response-map] (->RingResponse ring-response-map value)))
 
-(defn ring-response [map] (->RingResponse map))
+;; Copyright (c) Philipp Meier (meier@fnogol.de). All rights reserved.
+;; The use and distribution terms for this software are covered by the Eclipse
+;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which
+;; can be found in the file epl-v10.html at the root of this distribution. By

src/liberator/util.clj

@@ -40,7 +40,7 @@
 (defn parse-http-date [date-string]
   (if (nil? date-string)
     nil
-    (try 		      
+    (try
       (.parse (http-date-format) date-string)
       (catch java.text.ParseException e nil))))
 
@@ -49,3 +49,31 @@
     (let [m (apply hash-map kvs)
           method (get-in ctx [:request :request-method])]
       (if-let [fd (make-function (or (get m method) (get m :any)))] (fd ctx)))))
+
+;; A more sophisticated update of the request than a simple merge
+;; provides.  This allows decisions to return maps which modify the
+;; original request in the way most probably intended rather than the
+;; over-destructive default merge.
+(defn combine
+  "Merge two values such that two maps a merged, two lists, two
+  vectors and two sets are concatenated.
+
+  Maps will be merged with maps. The map values will be merged
+  recursively with this function.
+
+  Lists, Vectors and Sets will be concatenated with values that are
+  `coll?` and will preserve their type.
+
+  For other combination of types the new value will be returned.
+
+  If the newval has the metadata attribute `:replace` then it will
+  replace the value regardless of the type."
+  [curr newval]
+  (cond
+   (-> newval meta :replace) newval
+   (and (map? curr) (map? newval)) (merge-with combine curr newval)
+   (and (list? curr) (coll? newval)) (concat curr newval)
+   (and (vector? curr) (coll? newval)) (concat curr newval)
+   (and (set? curr) (coll? newval)) (set (concat curr newval))
+   :otherwise newval))
+

test/test_representation.clj

@@ -1,7 +1,6 @@
 (ns test-representation
-  (:use
-   midje.sweet
-   [liberator.representation]))
+  (:require [midje.sweet :refer :all]
+            [liberator.representation :refer :all]))
 
 ;; test for issue #19
 ;; https://github.com/clojure-liberator/liberator/pull/19
@@ -48,3 +47,33 @@
                   "application/edn" (pr-str entity))))
 
 
+(facts "Can give ring response map to override response values"
+   (facts "returns single ring response unchanged"
+     (let [response {:status 123 
+                     :headers {"Content-Type" "application/json;charset=UTF-8"
+                               "X-Foo" "Bar"}
+                     :body "123" }]
+       (as-response (ring-response response) {}) => response))
+   (facts "delegates to default response generation when value is given"
+         (fact "for strings"
+           (as-response (ring-response "foo" {}) {}) => (as-response "foo" {}))
+         (fact "for maps"
+           (let [ctx {:representation {:media-type "application/json"}}]
+             (as-response (ring-response {:a 1} {}) ctx)
+             => (as-response {:a 1} ctx))))
+       (facts "lets override response attributes"
+         (fact "all attributes"
+           (let [overidden {:body "body"
+                           :headers ["Content-Type" "application/foo"]
+                           :status 999}]
+           (as-response (ring-response "foo" overidden)
+                        {:status 200}) => overidden))
+         (facts "some attributes"
+           (facts "status"
+             (as-response (ring-response "foo" {:status 999}) {:status 200})
+             => (contains {:status 999}))
+           (facts "header merged"
+             (as-response (ring-response "foo" {:headers {"X-Foo" "bar"}})
+               {:status 200})
+             => (contains {:headers {"X-Foo" "bar"
+                                     "Content-Type" "text/plain;charset=UTF-8"}})))))

test/test_util.clj

@@ -0,0 +1,53 @@
+(ns test-util
+  (:require [liberator.util :refer :all]
+            [midje.sweet :refer :all]))
+
+(facts "combine function"
+  (facts "simple combinations"
+    (fact "merges map" (combine {:a 1} {:b 2}) => {:a 1 :b 2})
+    (fact "concats list" (combine '(1 2) #{3 4}) => '(1 2 3 4))
+    (fact "concats vector" (combine [1 2] '(3 4)) => [1 2 3 4])
+    (fact "concats set" (combine #{1 2} [3 4]) => #{1 2 3 4})
+    (facts "replaces other types"
+      (fact (combine 123 456) => 456)
+      (fact (combine "abc" 123 => 123))
+      (fact (combine [] "abc" => "abc")))
+    (facts "replaces for different types"
+      (fact (combine [1 2 3] 1) => 1)
+      (fact  (combine '(1 2 3) 1) => 1)
+      (fact  (combine {1 2 3 4} 1) => 1)))
+  (facts "prevent merge with meta :replace"
+    (fact "replaces map" (combine {:a 1} ^:replace {:b 2}) => {:b 2})
+    (fact "replaces list" (combine '(1 2) ^:replace #{3 4}) => #{3 4})
+    (fact "replaces vector"
+      (combine [1 2] (with-meta (list 3 4) {:replace true})) => '(3 4))
+    (fact "replaces set" (combine #{1 2} ^:replace [3 4]) => [3 4]))
+  (facts "deep merges"
+    (fact "map values are recursively merged"
+      (combine {:a [1]
+                :b '(2)
+                :c {:x [3]}
+                :d 4
+                :e [:nine]}
+               {:a '(5)
+                :b #{6}
+                :c {:x [7]}
+                :d 8
+                :e ^:replace [:ten]})
+      => {:a [1 5]
+          :b '(2 6)
+          :c {:x [3 7]}
+          :d 8
+          :e [:ten]}))
+  (facts "response updates"
+    (combine {:status 200
+              :body "foo"
+              :headers {"Content-Type" "text/plain"
+                        "X-Dummy" ["banana" "apple"]}}
+             {:headers {"Content-Type" "text/something+plain"
+                        "X-Dummy" ["peach"]}})
+    => {:status 200
+        :body "foo"
+        :headers {"Content-Type" "text/something+plain"
+                  "X-Dummy" ["banana" "apple" "peach"]}}))
+