Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Many updates to hottop.util in an effort to fix github issue #4. Adde…

…d many

functions and tests.
  • Loading branch information...
commit 90c0180c525869005d5a8393e648b67088e5af43 1 parent 95480dd
@tmciver authored
Showing with 234 additions and 27 deletions.
  1. +139 −17 src/hottop/util.clj
  2. +95 −10 test/hottop/test/util.clj
View
156 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
@@ -51,27 +68,132 @@ 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- types-and-subtypes
+ "Returns a map of content type (major) to set of content subtypes for the
+given resource. For example, if the resource provides the following three
+content types: 'text/html', 'text/csv' and 'application/json', then the returned
+map will be:
+ {'text' #{'html' 'csv'}
+ 'application' #{'json'}}"
+ [resource]
+ (->> (:content-types-provided resource)
+ keys
+ (map #(str/split % #"/"))
+ (group-by first)
+ (map (fn [[type subtypes]]
+ [type (reduce (fn [res subtype]
+ (conj res (second subtype)))
+ #{} subtypes)]))
+ (into {})))
+
+(defn- types-and-subtypes2
+ "Returns a map of content type to set of content subtypes when given a
+collection of maps each with keys :type and :subtype."
+ [type-maps]
+ (->> (group-by :type type-maps)
+ (map (fn [[type typemaps]]
+ [type (reduce (fn [res typemap]
+ (conj res (:subtype typemap)))
+ #{} typemaps)]))
+ (into {})))
+
+(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."
+ [request resource]
+ (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 ^{:webmachine-node :c4} 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."
[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)]
+ (let [ ;;types-subtypes (types-and-subtypes resource)
+ accept-maps (doto (->> (parse-accept-header (get-in request [:headers "accept"]))
+ (sort-by :q >)) prn)
+ provided-maps (doto (provided-maps resource) prn)
+ ;; returns true if provided type map (pt) is acceptable when compared to
+ ;; to the given accepted type map (at)
+ acceptable? (fn [pt at] (and (not= (:q at) 0.0)
+ (or (= (:type at) "*")
+ (and (= (:type at) (:type pt))
+ (or (= (:subtype at) "*")
+ (= (:subtype at) (:subtype pt)))))))
+ acceptable-type? (fn [t] )
+ ;; filter out the provided maps that match an accept-map with a quality
+ ;; factor of zero
+ acceptable-maps (doto (filter (fn [pm]
+ (some (partial acceptable? pm)
+ accept-maps)) provided-maps) prn)
+ types-subtypes (doto (types-and-subtypes2 acceptable-maps) prn)
+ choose-type (fn [accepted-type provided-types]
+ (if (= accepted-type "*")
+ (rand-nth (seq provided-types))
+ (some #{accepted-type} provided-types)))
+ type (some (fn [{:keys [type subtype]}]
+ (let [provided-types (keys types-subtypes)
+ atype (choose-type type provided-types)
+ provided-subtypes (types-subtypes atype)
+ asubtype (choose-type subtype provided-subtypes)]
+ (when (and atype asubtype)
+ (str/join "/" [atype asubtype]))))
+ accept-maps)]
type))
(defn response?
View
105 test/hottop/test/util.clj
@@ -4,19 +4,44 @@
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
@@ -26,19 +51,79 @@
(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-types-and-subtypes
+ (let [res (-> base-resource
+ (add-view "text/html" identity)
+ (add-view "text/csv" identity)
+ (add-view "application/json" identity))]
+ (is (= (#'hottop.util/types-and-subtypes res)
+ {"text" #{"html" "csv"}
+ "application" #{"json"}}))))
+
+(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))
+ 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)))))
Please sign in to comment.
Something went wrong with that request. Please try again.