Skip to content

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also .

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also .
...
  • 2 commits
  • 2 files changed
  • 0 commit comments
  • 1 contributor
Showing with 167 additions and 39 deletions.
  1. +76 −24 src/hottop/util.clj
  2. +91 −15 test/hottop/test/util.clj
View
100 src/hottop/util.clj
@@ -9,21 +9,27 @@
(map str/trim (str/split s re)))
(defn- accept-segment-to-map
- "Takes an string representing an Accept- segment and returns a map containing
+ "Takes a string representing an Accept- segment and returns a map containing
at least key :type. If there are parameters present in the Accept segment,
their names will be placed in the map as keyword with their corresponding
values. For example, the common 'q value' will have key :q in the map."
[accept-seg-str]
- (let [[type & parameters] (split-and-trim accept-seg-str #";")]
- (apply merge {:type type}
+ (let [[type & parameters] (split-and-trim accept-seg-str #";")
+ [type subtype] (split-and-trim type #"/")]
+ (apply merge {:type type :subtype subtype}
(for [param parameters]
(let [[k v] (split-and-trim param #"=")]
{(keyword k) v})))))
+(defn- type-map-to-content-str
+ "Returns a media type string based on the given accept map."
+ [accept-map]
+ (str/join "/" [(:type accept-map) (:subtype accept-map)]))
+
(defn parse-accept-header
"Parses an Accept- header string into a seq of maps which have at least the
- :type and :q keys. Any other parameters in the Accept string will be given
- keys that are keywords of their names with their corresponding values."
+ :type, :subtype and :q keys. Any other parameters in the Accept string will be
+ given keys that are keywords of their names with their corresponding values."
[accept-str]
(let [accept-segs (split-and-trim accept-str #",")]
(->> accept-segs
@@ -32,6 +38,17 @@
(let [q (Double/parseDouble q)]
(assoc m :q q)))))))
+(defn- provided-maps
+ "Returns a set of maps with keys :type and :subtype based on the content types
+ listed in the :content-types-provided map of the given resource."
+ [resource]
+ (->> resource
+ :content-types-provided
+ keys
+ (map #(str/split % #"/"))
+ (map (fn [t] {:type (first t) :subtype (second t)}))
+ set))
+
(defn allow-header-str
"Returns a string of a comma-separated list (with spaces) of the methods
(upper-cased) supported by the given resource. This string is intended to be
@@ -42,37 +59,72 @@
keys
(map name)
(map str/upper-case)
- (interpose ", ")
- (apply str)))
+ (str/join ", ")))
(defn accepts-html?
"Returns truthy if the request indicates that it will accept a response in
HTML format (the Accept header contains one or both of 'text/html' or
'application/xhtml+xml'), falsey otherwise."
[request]
(when-let [{{accept-str "accept"} :headers} request]
- (let [accept-types (map :type (parse-accept-header accept-str))]
+ (let [accept-types (map type-map-to-content-str (parse-accept-header accept-str))]
(some #{"text/html" "application/xhtml+xml"} accept-types))))
-(defn ^{:webmachine-node :c4} optimal-media-type
+(defn- at-accepts-pt?
+ "Returns true if provided-type map (pt) is acceptable when compared to the
+ given accepted-type map (at) irrespective of at's q value."
+ [at pt]
+ (or (= (:type at) "*")
+ (and (= (:type at) (:type pt))
+ (or (= (:subtype at) "*")
+ (= (:subtype at) (:subtype pt))))))
+
+(defn- group-by-provided-types
+ "Returns a map with provide-type maps as keys and the set of accept-type maps
+that 'accept' it as values."
+ [accept-maps provided-maps]
+ (reduce (fn [res [at pt]]
+ (if (at-accepts-pt? at pt)
+ (let [ats (or (res pt) #{})]
+ (assoc res pt (conj ats at)))
+ res))
+ {}
+ (for [at accept-maps
+ pt provided-maps]
+ [at pt])))
+
+(defn optimal-media-type
"Returns a string representing the optimal client-requested media type or nil
if there isn't one. See RFC 2046 (http://tools.ietf.org/html/rfc2046) or
-http://en.wikipedia.org/wiki/MIME_type for examples of media type strings.
-
- WARNING! This function is broken. Specifically, type/* media types in
- the Accept header are not handled."
+http://en.wikipedia.org/wiki/MIME_type for examples of media type strings."
[request resource]
- (let [ct-provided (set (keys (:content-types-provided resource)))
- accept-maps (->> (parse-accept-header (get-in request [:headers "accept"]))
- (filter #(not (= 0 (:q %))))
- (sort-by :q >))
- type (some #(let [type (:type %)]
- (if (or (= type "*")
- (= type "*/*"))
- (first ct-provided)
- (some #{type} ct-provided)))
- accept-maps)]
- type))
+ (let [accept-maps (parse-accept-header (get-in request [:headers "accept"]))
+ wanted? (fn [at] (> (:q at) 0.0))
+ separate (juxt filter remove)
+ ;; split the accept maps into those with q values greater than zero
+ ;; (wanted-types) and those with q equal to zero (unwanted-types).
+ [wanted-types unwanted-types] (separate wanted? accept-maps)
+ ;; keep only the :type and :subtype keys of unwanted-types (so that we
+ ;; can subtract these types from the provided types)
+ unwanted-types (map #(select-keys % [:type :subtype]) unwanted-types)
+ ;; create a set of provided maps with the unwanted types removed
+ provided-maps (-> (provided-maps resource)
+ set
+ (set/difference unwanted-types))
+ ;; create a map of provided-type to set of accept types that accept it
+ pt-to-at (group-by-provided-types wanted-types provided-maps)
+ ;; assoc into each provided type the maximum q value from the accept
+ ;; types that accept it
+ types (reduce (fn [types [pt ats]]
+ (let [mx (apply max (map :q ats))]
+ (conj types (assoc pt :q mx))))
+ []
+ pt-to-at)]
+ (when (seq types)
+ (->> types
+ (sort-by :q >)
+ first
+ type-map-to-content-str))))
(defn response?
"Returns truthy if argument is a map that contains the key :status, false
View
106 test/hottop/test/util.clj
@@ -4,41 +4,117 @@
hottop.util
hottop.resource))
+(deftest test-accept-segment-to-map
+ (let [segment "text/html;level=1;q=0.7"
+ segment-map (#'hottop.util/accept-segment-to-map segment)]
+ (is (= segment-map
+ {:type "text"
+ :subtype "html"
+ :level "1"
+ :q "0.7"}))))
+
+(deftest test-accept-map-to-type-str
+ (let [segment "text/html;level=1;q=0.7"
+ segment-map (#'hottop.util/accept-segment-to-map segment)
+ type-str (#'hottop.util/type-map-to-content-str segment-map)]
+ (is (= type-str "text/html"))))
+
(deftest test-parse-accept-header
(testing "Test Accept headers"
(is (= (parse-accept-header "text/*;q=0.3, text/html;q=0.7, text/html;level=1, text/html;level=2;q=0.4, */*;q=0.5")
- [{:q 0.3, :type "text/*"}
- {:q 0.7, :type "text/html"}
- {:q 1.0, :level "1", :type "text/html"}
- {:q 0.4, :level "2", :type "text/html"}
- {:q 0.5, :type "*/*"}])))
+ [{:q 0.3, :type "text" :subtype "*"}
+ {:q 0.7, :type "text" :subtype "html"}
+ {:q 1.0, :level "1", :type "text" :subtype "html"}
+ {:q 0.4, :level "2", :type "text" :subtype "html"}
+ {:q 0.5, :type "*" :subtype "*"}])))
(testing "Test Accept-Encoding headers"
(is (= (parse-accept-header "gzip;q=1.0, identity; q=0.5, *;q=0")
- [{:q 1.0, :type "gzip"}
- {:q 0.5, :type "identity"}
- {:q 0.0, :type "*"}]))))
+ [{:q 1.0, :type "gzip" :subtype nil}
+ {:q 0.5, :type "identity" :subtype nil}
+ {:q 0.0, :type "*" :subtype nil}]))))
+
+(deftest test-provided-maps
+ (let [res (-> base-resource
+ (add-view "text/html" identity)
+ (add-view "text/csv" identity)
+ (add-view "application/json" identity))]
+ (is (= (#'hottop.util/provided-maps res)
+ #{{:type "text" :subtype "html"}
+ {:type "text" :subtype "csv"}
+ {:type "application" :subtype "json"}}))))
(deftest test-allow-header-str
(let [resource (-> base-resource
- (assoc-in [:methods :get] (constantly "Hello!"))
- (assoc-in [:methods :post] (constantly "Hello!"))
- (assoc-in [:methods :put] (constantly "Hello!")))]
+ (add-method-handler :get (constantly "Hello!"))
+ (add-method-handler :post (constantly "Hello!"))
+ (add-method-handler :put (constantly "Hello!")))]
(is (= (allow-header-str resource)
"PUT, POST, GET"))))
+(deftest test-accepts-html?
+ (let [req1 (-> (request :get "/test")
+ (header "Accept" "text/html"))
+ req2 (-> (request :get "/test")
+ (header "Accept" "text/csv"))
+ req3 (-> (request :get "/test")
+ (header "Accept" "application/xhtml+xml"))
+ req4 (-> (request :get "/test")
+ (header "Accept" "text/*"))]
+ (is (accepts-html? req1))
+ (is (not (accepts-html? req2)))
+ (is (accepts-html? req3))
+ (is (not (accepts-html? req4)))))
+
+(deftest test-at-accepts-pt?
+ (let [pts1 [{:type "text" :subtype "html"}
+ {:type "text" :subtype "csv"}
+ {:type "text" :subtype "plain"}]
+ pts2 [{:type "text" :subtype "html"}
+ {:type "image" :subtype "png"}
+ {:type "application" :subtype "json"}]
+ at1 {:type "text" :subtype "*"}
+ at2 {:type "text" :subtype "html" :q 0.0}
+ at3 {:type "*" :subtype "*"}]
+ (is (every? (partial #'hottop.util/at-accepts-pt? at1) pts1))
+ (is (#'hottop.util/at-accepts-pt? at2 (first pts1)))
+ (is (every? (partial #'hottop.util/at-accepts-pt? at3) pts2))))
+
(deftest test-optimal-media-type
(testing "Test Acceptable Media Types"
(let [request1 (-> (request :get "/test")
(header "Accept" "text/html"))
request2 (-> (request :get "/test")
(header "Accept" "text/csv"))
+ request3 (-> (request :get "/test")
+ (header "Accept" "text/*"))
+ request4 (-> (request :get "/test")
+ (header "Accept" "*/*"))
+ request5 (-> (request :get "/test")
+ (header "Accept" "image/jpeg;q=0, image/*"))
resource1 (create-readonly-html-resource (constantly "hello!"))
resource2 (-> base-resource
- (assoc-in [:methods :get] (constantly "hello."))
- (assoc-in [:content-types-provided "text/csv"] identity))
+ (add-method-handler :get (constantly "hello."))
+ (add-view "text/csv" identity))
+ resource3 (-> base-resource
+ (add-view "image/jpeg" identity)
+ (add-view "image/png" identity))
omt1 (optimal-media-type request1 resource1)
omt2 (optimal-media-type request2 resource1)
- omt3 (optimal-media-type request2 resource2)]
+ omt3 (optimal-media-type request2 resource2)
+ omt4 (optimal-media-type request3 resource2)
+ omt5 (optimal-media-type request5 resource3)
+ omt6 (optimal-media-type request4 resource2)]
(is (= omt1 "text/html"))
(is (nil? omt2))
- (is (= omt3 "text/csv")))))
+ (is (= omt3 "text/csv"))
+ (is (= omt4 "text/csv"))
+ (is (= omt5 "image/png"))
+ (is (= omt6 "text/csv")))))
+
+(deftest test-response?
+ (let [resp1 {:status 200 :body "Hello World!"}
+ resp2 {:a 1 :b 2}
+ resp3 'hello]
+ (is (response? resp1))
+ (is (not (response? resp2)))
+ (is (not (response? resp3)))))

No commit comments for this range

Something went wrong with that request. Please try again.