Eclipse Public License - v 1.0
31 | 32 |THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 33 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR 34 | DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS 35 | AGREEMENT.
36 | 37 |1. DEFINITIONS
38 | 39 |"Contribution" means:
40 | 41 |a) in the case of the initial Contributor, the initial 42 | code and documentation distributed under this Agreement, and
43 |b) in the case of each subsequent Contributor:
44 |i) changes to the Program, and
45 |ii) additions to the Program;
46 |where such changes and/or additions to the Program 47 | originate from and are distributed by that particular Contributor. A 48 | Contribution 'originates' from a Contributor if it was added to the 49 | Program by such Contributor itself or anyone acting on such 50 | Contributor's behalf. Contributions do not include additions to the 51 | Program which: (i) are separate modules of software distributed in 52 | conjunction with the Program under their own license agreement, and (ii) 53 | are not derivative works of the Program.
54 | 55 |"Contributor" means any person or entity that distributes 56 | the Program.
57 | 58 |"Licensed Patents" mean patent claims licensable by a 59 | Contributor which are necessarily infringed by the use or sale of its 60 | Contribution alone or when combined with the Program.
61 | 62 |"Program" means the Contributions distributed in accordance 63 | with this Agreement.
64 | 65 |"Recipient" means anyone who receives the Program under 66 | this Agreement, including all Contributors.
67 | 68 |2. GRANT OF RIGHTS
69 | 70 |a) Subject to the terms of this Agreement, each 71 | Contributor hereby grants Recipient a non-exclusive, worldwide, 72 | royalty-free copyright license to reproduce, prepare derivative works 73 | of, publicly display, publicly perform, distribute and sublicense the 74 | Contribution of such Contributor, if any, and such derivative works, in 75 | source code and object code form.
76 | 77 |b) Subject to the terms of this Agreement, each 78 | Contributor hereby grants Recipient a non-exclusive, worldwide, 79 | royalty-free patent license under Licensed Patents to make, use, sell, 80 | offer to sell, import and otherwise transfer the Contribution of such 81 | Contributor, if any, in source code and object code form. This patent 82 | license shall apply to the combination of the Contribution and the 83 | Program if, at the time the Contribution is added by the Contributor, 84 | such addition of the Contribution causes such combination to be covered 85 | by the Licensed Patents. The patent license shall not apply to any other 86 | combinations which include the Contribution. No hardware per se is 87 | licensed hereunder.
88 | 89 |c) Recipient understands that although each Contributor 90 | grants the licenses to its Contributions set forth herein, no assurances 91 | are provided by any Contributor that the Program does not infringe the 92 | patent or other intellectual property rights of any other entity. Each 93 | Contributor disclaims any liability to Recipient for claims brought by 94 | any other entity based on infringement of intellectual property rights 95 | or otherwise. As a condition to exercising the rights and licenses 96 | granted hereunder, each Recipient hereby assumes sole responsibility to 97 | secure any other intellectual property rights needed, if any. For 98 | example, if a third party patent license is required to allow Recipient 99 | to distribute the Program, it is Recipient's responsibility to acquire 100 | that license before distributing the Program.
101 | 102 |d) Each Contributor represents that to its knowledge it 103 | has sufficient copyright rights in its Contribution, if any, to grant 104 | the copyright license set forth in this Agreement.
105 | 106 |3. REQUIREMENTS
107 | 108 |A Contributor may choose to distribute the Program in object code 109 | form under its own license agreement, provided that:
110 | 111 |a) it complies with the terms and conditions of this 112 | Agreement; and
113 | 114 |b) its license agreement:
115 | 116 |i) effectively disclaims on behalf of all Contributors 117 | all warranties and conditions, express and implied, including warranties 118 | or conditions of title and non-infringement, and implied warranties or 119 | conditions of merchantability and fitness for a particular purpose;
120 | 121 |ii) effectively excludes on behalf of all Contributors 122 | all liability for damages, including direct, indirect, special, 123 | incidental and consequential damages, such as lost profits;
124 | 125 |iii) states that any provisions which differ from this 126 | Agreement are offered by that Contributor alone and not by any other 127 | party; and
128 | 129 |iv) states that source code for the Program is available 130 | from such Contributor, and informs licensees how to obtain it in a 131 | reasonable manner on or through a medium customarily used for software 132 | exchange.
133 | 134 |When the Program is made available in source code form:
135 | 136 |a) it must be made available under this Agreement; and
137 | 138 |b) a copy of this Agreement must be included with each 139 | copy of the Program.
140 | 141 |Contributors may not remove or alter any copyright notices contained 142 | within the Program.
143 | 144 |Each Contributor must identify itself as the originator of its 145 | Contribution, if any, in a manner that reasonably allows subsequent 146 | Recipients to identify the originator of the Contribution.
147 | 148 |4. COMMERCIAL DISTRIBUTION
149 | 150 |Commercial distributors of software may accept certain 151 | responsibilities with respect to end users, business partners and the 152 | like. While this license is intended to facilitate the commercial use of 153 | the Program, the Contributor who includes the Program in a commercial 154 | product offering should do so in a manner which does not create 155 | potential liability for other Contributors. Therefore, if a Contributor 156 | includes the Program in a commercial product offering, such Contributor 157 | ("Commercial Contributor") hereby agrees to defend and 158 | indemnify every other Contributor ("Indemnified Contributor") 159 | against any losses, damages and costs (collectively "Losses") 160 | arising from claims, lawsuits and other legal actions brought by a third 161 | party against the Indemnified Contributor to the extent caused by the 162 | acts or omissions of such Commercial Contributor in connection with its 163 | distribution of the Program in a commercial product offering. The 164 | obligations in this section do not apply to any claims or Losses 165 | relating to any actual or alleged intellectual property infringement. In 166 | order to qualify, an Indemnified Contributor must: a) promptly notify 167 | the Commercial Contributor in writing of such claim, and b) allow the 168 | Commercial Contributor to control, and cooperate with the Commercial 169 | Contributor in, the defense and any related settlement negotiations. The 170 | Indemnified Contributor may participate in any such claim at its own 171 | expense.
172 | 173 |For example, a Contributor might include the Program in a commercial 174 | product offering, Product X. That Contributor is then a Commercial 175 | Contributor. If that Commercial Contributor then makes performance 176 | claims, or offers warranties related to Product X, those performance 177 | claims and warranties are such Commercial Contributor's responsibility 178 | alone. Under this section, the Commercial Contributor would have to 179 | defend claims against the other Contributors related to those 180 | performance claims and warranties, and if a court requires any other 181 | Contributor to pay any damages as a result, the Commercial Contributor 182 | must pay those damages.
183 | 184 |5. NO WARRANTY
185 | 186 |EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 187 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS 188 | OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, 189 | ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 190 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 191 | responsible for determining the appropriateness of using and 192 | distributing the Program and assumes all risks associated with its 193 | exercise of rights under this Agreement , including but not limited to 194 | the risks and costs of program errors, compliance with applicable laws, 195 | damage to or loss of data, programs or equipment, and unavailability or 196 | interruption of operations.
197 | 198 |6. DISCLAIMER OF LIABILITY
199 | 200 |EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT 201 | NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 202 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 203 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 204 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 205 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 206 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 207 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
208 | 209 |7. GENERAL
210 | 211 |If any provision of this Agreement is invalid or unenforceable under 212 | applicable law, it shall not affect the validity or enforceability of 213 | the remainder of the terms of this Agreement, and without further action 214 | by the parties hereto, such provision shall be reformed to the minimum 215 | extent necessary to make such provision valid and enforceable.
216 | 217 |If Recipient institutes patent litigation against any entity 218 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 219 | Program itself (excluding combinations of the Program with other 220 | software or hardware) infringes such Recipient's patent(s), then such 221 | Recipient's rights granted under Section 2(b) shall terminate as of the 222 | date such litigation is filed.
223 | 224 |All Recipient's rights under this Agreement shall terminate if it 225 | fails to comply with any of the material terms or conditions of this 226 | Agreement and does not cure such failure in a reasonable period of time 227 | after becoming aware of such noncompliance. If all Recipient's rights 228 | under this Agreement terminate, Recipient agrees to cease use and 229 | distribution of the Program as soon as reasonably practicable. However, 230 | Recipient's obligations under this Agreement and any licenses granted by 231 | Recipient relating to the Program shall continue and survive.
232 | 233 |Everyone is permitted to copy and distribute copies of this 234 | Agreement, but in order to avoid inconsistency the Agreement is 235 | copyrighted and may only be modified in the following manner. The 236 | Agreement Steward reserves the right to publish new versions (including 237 | revisions) of this Agreement from time to time. No one other than the 238 | Agreement Steward has the right to modify this Agreement. The Eclipse 239 | Foundation is the initial Agreement Steward. The Eclipse Foundation may 240 | assign the responsibility to serve as the Agreement Steward to a 241 | suitable separate entity. Each new version of the Agreement will be 242 | given a distinguishing version number. The Program (including 243 | Contributions) may always be distributed subject to the version of the 244 | Agreement under which it was received. In addition, after a new version 245 | of the Agreement is published, Contributor may elect to distribute the 246 | Program (including its Contributions) under the new version. Except as 247 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives no 248 | rights or licenses to the intellectual property of any Contributor under 249 | this Agreement, whether expressly, by implication, estoppel or 250 | otherwise. All rights in the Program not expressly granted under this 251 | Agreement are reserved.
252 | 253 |This Agreement is governed by the laws of the State of New York and 254 | the intellectual property laws of the United States of America. No party 255 | to this Agreement will bring a legal action under this Agreement more 256 | than one year after the cause of action arose. Each party waives its 257 | rights to a jury trial in any resulting litigation.
258 | 259 | 260 | 261 | 262 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject liberator "0.15.4-SNAPSHOT" 2 | :description "Liberator - A REST library for Clojure." 3 | :url "http://clojure-liberator.github.io/liberator" 4 | :dependencies [[org.clojure/clojure "1.8.0"] 5 | [org.clojure/data.json "0.2.6"] 6 | [org.clojure/data.csv "0.1.3"] 7 | [hiccup "1.0.5"]] ;; Used by code rendering default representations. 8 | :deploy-repositories [["releases" :clojars]] 9 | :lein-release {:deploy-via :clojars} 10 | 11 | :license {:name "Eclipse Public License - v 1.0" 12 | :url "http://www.eclipse.org/legal/epl-v10.html" 13 | :distribution :repo 14 | :comments "same as Clojure"} 15 | 16 | :scm {:connection "scm:git:https://github.com/clojure-liberator/liberator.git" 17 | :url "https://github.com/clojure-liberator/liberator"} 18 | 19 | :plugins [[lein-midje "3.2.1"] 20 | [lein-shell "0.5.0"]] 21 | 22 | :profiles {:dev {:dependencies [[ring/ring-jetty-adapter "1.5.1"] 23 | [ring-mock "0.1.5" :exclusions [ring/ring-codec]] 24 | [ring/ring-devel "1.5.1"] 25 | [midje "1.9.4"] 26 | [compojure "1.5.2"]]} 27 | :1.7 {:dependencies [[org.clojure/clojure "1.7.0" :upgrade? false]]} 28 | :1.8 {:dependencies [[org.clojure/clojure "1.8.0" :upgrade? false]]} 29 | :1.9 {:dependencies [[org.clojure/clojure "1.9.0" :upgrade? false]]} 30 | :1.10 {:dependencies [[org.clojure/clojure "1.10.0" :upgrade? false]]} 31 | 32 | :dl {:jvm-opts ["-Dclojure.compiler.direct-linking=true"]} 33 | :1.8dl [:1.8 :dl]} 34 | 35 | :aliases {"test-all" ["with-profile" "+1.7:+1.8:+1.8dl:+1.9:+1.10" "test"] 36 | "graph" ["do" 37 | ["run" "-m" "liberator.graph/generate-dot-file" "trace.dot"] 38 | ["shell" "dot" "-O" "-Tsvg" "trace.dot"] 39 | ["shell" "mv" "trace.dot.svg" "src/liberator/trace.svg"]]}) 40 | -------------------------------------------------------------------------------- /src/liberator/conneg.clj: -------------------------------------------------------------------------------- 1 | (ns liberator.conneg 2 | (:require [clojure.string :as string] 3 | [liberator.util :refer [protocol-exception]])) 4 | 5 | ;;; TODO: sort by level for text/html. Maybe also sort by charset. 6 | ;;; Finally, compare by precedence rules: 7 | ;;; 1. text/html;level=1 8 | ;;; 2. text/html 9 | ;;; 3. text/* 10 | ;;; 4. */* 11 | ;;; 12 | 13 | (def accept-fragment-re 14 | #"^\s*(\*|[^()<>@,;:\"/\[\]?={} ]+)/(\*|[^()<>@,;:\"/\[\]?={} ]+)$") 15 | 16 | (def accept-fragment-param-re 17 | #"([^()<>@,;:\"/\[\]?={} ]+)=([^()<>@,;:\"/\[\]?={} ]+|\"[^\"]*\")$") 18 | 19 | (defn- clamp [minimum maximum val] 20 | (->> val 21 | (min maximum) 22 | (max minimum))) 23 | 24 | (defn- parse-q [^String str] 25 | (Double/parseDouble str)) 26 | 27 | (defn- assoc-param [coll n v] 28 | (try 29 | (assoc coll 30 | (keyword n) 31 | (if (= "q" n) 32 | (clamp 0 1 (parse-q v)) 33 | v)) 34 | (catch Throwable e 35 | coll))) 36 | 37 | (defn params->map [params] 38 | (loop 39 | [p (first params) 40 | ps (rest params) 41 | acc {}] 42 | (let [x (when p 43 | (rest (re-matches accept-fragment-param-re p))) 44 | accumulated (if (= 2 (count x)) 45 | (assoc-param acc (first x) (second x)) 46 | acc)] 47 | (if (empty? ps) 48 | accumulated 49 | (recur 50 | (first ps) 51 | (rest ps) 52 | accumulated))))) 53 | 54 | (defn accept-fragment 55 | "Take something like 56 | \"text/html\" 57 | or 58 | \"image/*; q=0.8\" 59 | and return a map like 60 | {:type [\"image\" \"*\"] 61 | :q 0.8} 62 | 63 | If the fragment is invalid, nil is returned." 64 | 65 | ([f] 66 | (let [parts (string/split f #"\s*;\s*")] 67 | (when (not (empty? parts)) 68 | ;; First part will be a type. 69 | (let [type-str (first parts) 70 | type-pair (rest (re-matches accept-fragment-re type-str))] 71 | (when type-pair 72 | (assoc 73 | (params->map (rest parts)) 74 | :type type-pair))))))) 75 | 76 | (defn acceptable-type 77 | "Compare two type pairs. If the pairing is acceptable, 78 | return the most specific. 79 | E.g., for 80 | 81 | [\"text\" \"plain\"] [\"*\" \"*\"] 82 | 83 | returns 84 | 85 | [\"text\" \"plain\"]." 86 | [type-pair acceptable-pair] 87 | 88 | (cond 89 | (or (= type-pair acceptable-pair) 90 | (= ["*" "*"] acceptable-pair)) 91 | type-pair 92 | 93 | (= ["*" "*"] type-pair) 94 | acceptable-pair 95 | 96 | true 97 | ;; Otherwise, maybe one has a star. 98 | (let [[tmaj tmin] type-pair 99 | [amaj amin] acceptable-pair] 100 | (when (= tmaj amaj) 101 | (cond 102 | (= "*" tmin) 103 | acceptable-pair 104 | 105 | (= "*" amin) 106 | type-pair))))) 107 | 108 | (defn assoc-server-weight-fn [allowed-types] 109 | (let [server-fragments (map accept-fragment allowed-types)] 110 | (fn [accept-fragment] 111 | (if-let [sq (:q (first (filter #(acceptable-type (:type accept-fragment) (:type %)) server-fragments)))] 112 | (assoc accept-fragment :sq sq) 113 | accept-fragment)))) 114 | 115 | (defn sorted-accept [accepts-header allowed-types] 116 | (reverse 117 | (sort-by (juxt #(get %1 :q 1) #(get %1 :sq 1)) 118 | (map (assoc-server-weight-fn allowed-types) 119 | (map accept-fragment 120 | (string/split accepts-header #"[\s\n\r]*,[\s\n\r]*")))))) 121 | 122 | (defn allowed-types-filter [allowed-types] 123 | (fn [accept] 124 | (some (partial acceptable-type accept) 125 | allowed-types))) 126 | 127 | (defn- enpair 128 | "Ensure that a collection of types is a collection of pairs." 129 | [x] 130 | (filter identity 131 | (map (fn [y] (if (string? y) 132 | (:type (accept-fragment y)) 133 | y)) 134 | x))) 135 | 136 | (defn stringify [type] 137 | (reduce str (interpose "/" type))) 138 | 139 | (defn best-allowed-content-type 140 | "Return the first type in the Accept header that is acceptable. 141 | allowed-types is a set containing pairs (e.g., [\"text\" \"*\"]) 142 | or strings (e.g., \"text/plain\"). 143 | 144 | Definition of \"acceptable\": 145 | An Accept header fragment of \"text/*\" is acceptable when allowing 146 | \"text/plain\". 147 | An Accept header fragment of \"text/plain\" is acceptable when allowing 148 | \"text/*\"." 149 | 150 | ([accepts-header] 151 | (best-allowed-content-type accepts-header true)) 152 | ([accepts-header allowed-types] ; Set of strings or pairs. true/nil/:all for any. 153 | (let [sorted (map :type (sorted-accept accepts-header allowed-types))] 154 | (cond 155 | (contains? #{:all nil true} allowed-types) 156 | (first sorted) 157 | 158 | (fn? allowed-types) 159 | (some (enpair allowed-types) sorted) 160 | 161 | :otherwise 162 | (some (allowed-types-filter (enpair allowed-types)) sorted))))) 163 | 164 | (defn split-qval [caq] 165 | (let [[charset & params] (string/split caq #"[\s\r\n]*;[\s\r\n]*") 166 | parse (fn [s] 167 | (let [[param value] (string/split s #"[\s\r\n]*=")] 168 | (when (= "q" param) 169 | (try 170 | (Float/parseFloat value) 171 | (catch NumberFormatException e 0.001) 172 | (catch NullPointerException e 0.001))))) 173 | q (first (reverse (sort (filter (comp not nil?) 174 | (map parse params)))))] 175 | (when (and 176 | (not (nil? q)) 177 | (> q 1.0)) 178 | (throw (protocol-exception "Quality value of header exceeds 1"))) 179 | (when (and 180 | (not (nil? q)) 181 | (< q 0)) 182 | (throw (protocol-exception "Quality value of header is less than 0"))) 183 | [charset (or q 1)])) 184 | 185 | (defn parse-accepts-header [accepts-header] 186 | (->> (string/split accepts-header #"[\s\r\n]*,[\s\r\n]*") 187 | (map split-qval) 188 | (into {}))) 189 | 190 | (defn select-best [candidates score-fn] 191 | (->> candidates 192 | (map (juxt identity #(or (score-fn %) 0))) 193 | (sort-by second) 194 | ;; If a parameter has a quality value of 0, then content with 195 | ;; this parameter is `not acceptable' for the client 196 | (remove #(zero? (second %))) 197 | reverse 198 | (map first) ; extract winning option 199 | first)) 200 | 201 | 202 | ;; TODO Add tracing 203 | 204 | (defn best-allowed-charset [accepts-header available] 205 | (let [accepts (->> (string/split (string/lower-case accepts-header) #"[\s\r\n]*,[\s\r\n]*") 206 | (map split-qval) 207 | (into {}))] 208 | (select-best available 209 | (fn [charset] 210 | (let [charset (string/lower-case charset)] 211 | (or (get accepts charset) 212 | (get accepts "*") 213 | ;; "except for ISO-8859-1, which gets a quality 214 | ;; value of 1 if not explicitly mentioned" 215 | (if (= charset "iso-8859-1") 1 0))))))) 216 | 217 | (defn best-allowed-encoding [accepts-header available] 218 | (let [accepts (->> (string/split accepts-header #"[\s\r\n]*,[\s\r\n]*") 219 | (map split-qval) 220 | (into {}))] 221 | (or 222 | (select-best (concat available ["identity"]) 223 | (fn [encoding] 224 | (or (get accepts encoding) 225 | (get accepts "*")))) 226 | 227 | 228 | ;; The "identity" content-coding is always acceptable, unless 229 | ;; specifically refused because the Accept-Encoding field includes 230 | ;; "identity;q=0", or because the field includes "*;q=0" and does not 231 | ;; explicitly include the "identity" content-coding. If the 232 | ;; Accept-Encoding field-value is empty, then only the "identity" 233 | ;; encoding is acceptable. 234 | (if-not (or (zero? (get accepts "identity" 1)) 235 | (and (zero? (get accepts "*" 1)) 236 | (not (contains? accepts "identity")))) 237 | "identity")))) 238 | 239 | ;; 3.10 Language Tags (p28) 240 | ;; language-tag = primary-tag *( "-" subtag ) 241 | ;; primary-tag = 1*8ALPHA 242 | ;; subtag = 1*8ALPHA 243 | (defn remove-last-subtag [langtag] 244 | (->> (string/split langtag #"-") ; split into tags 245 | butlast ; remote the last subtag 246 | (interpose "-") (reduce str))) ; recompose 247 | 248 | 249 | ;; TODO What if no languages available? 250 | ;; "If no Content-Language is specified, the default is that the content is intended for all language audiences. This might mean that the sender does not consider it to be specific to any natural language, or that the sender does not know for which language it is intended." 251 | 252 | (defn best-allowed-language [accepts-header available] 253 | (let [accepts (->> (string/split accepts-header #"[\s\r\n]*,[\s\r\n]*") 254 | (map split-qval) 255 | (into {})) 256 | 257 | score (fn [langtag] 258 | (or 259 | ;; "A language-range matches a language-tag if it exactly equals the tag" 260 | (get accepts langtag) 261 | (->> langtag 262 | ;; "The language quality factor assigned to a 263 | ;; language-tag by the Accept-Language field is 264 | ;; the quality value of the longest language-range 265 | ;; in the field that matches the language-tag" 266 | (iterate remove-last-subtag) (take-while (comp not empty?)) 267 | (map #(get accepts %)) ; any score? 268 | (filter identity) 269 | first) ; partial match 270 | ;; "If no Content-Language is specified, the default is 271 | ;; that the content is intended for all language 272 | ;; audiences. This might mean that the sender does not 273 | ;; consider it to be specific to any natural language, 274 | ;; or that the sender does not know for which language 275 | ;; it is intended." 276 | (if (= "*" langtag) 0.01) 277 | 0))] 278 | (or 279 | (select-best available (fn [option] 280 | (cond 281 | (string? option) (score option) ; single langtag 282 | ;; "Multiple languages MAY be 283 | ;; listed for content that is intended for multiple audiences. For 284 | ;; example, a rendition of the "Treaty of Waitangi," presented 285 | ;; simultaneously in the original Maori and English versions, would 286 | ;; call for" 287 | ;; 288 | ;; Content-Language: mi, en 289 | (coll? option) (apply max (map score option)))))))) 290 | 291 | 292 | ;; TODO Have we considered the case where no accept-language tag is provided? (rfc 2616 is clear about this) 293 | ;; TODO As above but what about no accept-charset, no accept-encoding, no accept? 294 | -------------------------------------------------------------------------------- /src/liberator/core.clj: -------------------------------------------------------------------------------- 1 | (ns liberator.core 2 | (:require [liberator.conneg :as conneg] 3 | [liberator.representation :refer 4 | [Representation as-response ring-response]] 5 | [liberator.util :refer 6 | [as-date http-date parse-http-date 7 | combine make-function is-protocol-exception?]] 8 | [clojure.string :refer [join upper-case]]) 9 | (:import (clojure.lang ExceptionInfo))) 10 | 11 | (defmulti coll-validator 12 | "Return a function that evaluaties if the give argument 13 | a) is contained in a collection 14 | b) equals an argument 15 | c) when applied to a function evaluates as true" 16 | (fn [x] (cond 17 | (coll? x) :col 18 | (fn? x) :fn))) 19 | 20 | (defmethod coll-validator :col [xs] 21 | (fn [x] (some #{x} xs))) 22 | (defmethod coll-validator :fn [f] 23 | f) 24 | (defmethod coll-validator :default [x] 25 | (partial = x)) 26 | 27 | (defn console-logger [category values] 28 | #(apply println "LOG " category " " values)) 29 | 30 | (def ^:dynamic *loggers* nil) 31 | 32 | (defmacro with-logger [logger & body] 33 | `(binding [*loggers* (conj (or *loggers* []) ~logger)] 34 | ~@body)) 35 | 36 | (defmacro with-console-logger [& body] 37 | `(with-logger console-logger 38 | ~@body)) 39 | 40 | (defn atom-logger [atom] 41 | (fn [& args] 42 | (swap! atom conj args))) 43 | 44 | (defn log! [category & values] 45 | (doseq [l *loggers*] 46 | (l category values))) 47 | 48 | (declare if-none-match-exists?) 49 | 50 | (defn map-values [f m] 51 | (persistent! (reduce-kv (fn [out-m k v] (assoc! out-m k (f v))) (transient {}) m))) 52 | 53 | (defn request-method-in [& methods] 54 | #(some #{(:request-method (:request %))} methods)) 55 | 56 | (defn gen-etag [context] 57 | (if-let [f (get-in context [:resource :etag])] 58 | (if-let [etag-val (f context)] 59 | (format "\"%s\"" etag-val)))) 60 | 61 | (defn ^java.util.Date gen-last-modified [context] 62 | (if-let [f (get-in context [:resource :last-modified])] 63 | (if-let [lm-val (f context)] 64 | (as-date lm-val)))) 65 | 66 | (defn update-context [context context-update] 67 | (cond 68 | (map? context-update) (combine context context-update) 69 | (fn? context-update) (context-update) 70 | :otherwise context)) 71 | 72 | (declare handle-exception) 73 | 74 | (defn decide [name test then else {:keys [resource request] :as context}] 75 | (if (or test 76 | (contains? resource name)) 77 | (try 78 | (let [ftest (or (resource name) test) 79 | ftest (make-function ftest) 80 | fthen (make-function then) 81 | felse (make-function else) 82 | decision (ftest context) 83 | result (if (vector? decision) (first decision) decision) 84 | context-update (if (vector? decision) (second decision) decision) 85 | context (update-context context context-update)] 86 | (log! :decision name decision) 87 | ((if result fthen felse) context)) 88 | (catch Exception e 89 | (handle-exception (assoc context :exception e)))) 90 | {:status 500 :body (str "No handler found for key \"" name "\"." 91 | " Keys defined for resource are " (keys resource))})) 92 | 93 | (defn defdecision* 94 | [name test then else] 95 | `(defn ~name [~'context] 96 | (decide ~(keyword name) ~test ~then ~else ~'context))) 97 | 98 | (defmacro defdecision 99 | ([name then else] 100 | (defdecision* name nil then else)) 101 | ([name test then else] 102 | (defdecision* name test then else))) 103 | 104 | (defmacro defaction [name next] 105 | `(defdecision ~name ~next ~next)) 106 | 107 | 108 | (defn set-header-maybe [headers name value] 109 | (if-not (empty? value) 110 | (assoc headers name value) 111 | headers)) 112 | 113 | (defn build-vary-header [{:keys [media-type charset language encoding] :as representation}] 114 | (->> [(when-not (empty? media-type) "Accept") 115 | (when-not (empty? charset) "Accept-Charset") 116 | (when-not (empty? language) "Accept-Language") 117 | (when-not (or (empty? encoding) (= "identity" encoding)) "Accept-Encoding")] 118 | (remove nil?) 119 | (interpose ", ") 120 | (apply str))) 121 | 122 | (defn build-allow-header [resource] 123 | (join ", " (map (comp upper-case name) ((:allowed-methods resource))))) 124 | 125 | (defn build-options-headers [resource] 126 | (merge {"Allow" (build-allow-header resource)} 127 | (if (some #{:patch} ((:allowed-methods resource))) 128 | {"Accept-Patch" (join "," ((:patch-content-types resource)))} 129 | {}))) 130 | 131 | (defn run-handler [name status message 132 | {:keys [resource request representation] :as context}] 133 | (let [context 134 | (merge {:status status :message message} context) 135 | response 136 | (merge-with 137 | combine 138 | 139 | ;; Status 140 | {:status (:status context)} 141 | 142 | ;; ETags 143 | (when-let [etag (gen-etag context)] 144 | {:headers {"ETag" etag}}) 145 | 146 | ;; Last modified 147 | (when-let [last-modified (gen-last-modified context)] 148 | {:headers {"Last-Modified" (http-date last-modified)}}) 149 | 150 | ;; 201 created required a location header to be send 151 | (when (#{201 301 303 307} (:status context)) 152 | (if-let [f (or (get context :location) 153 | (get resource :location))] 154 | {:headers {"Location" (str ((make-function f) context))}})) 155 | 156 | 157 | (do 158 | (log! :handler (keyword name)) 159 | ;; Content negotiations 160 | (merge-with 161 | merge 162 | {:headers 163 | (-> {} 164 | (set-header-maybe "Content-Type" 165 | (str (:media-type representation) 166 | (when-let [charset (:charset representation)] 167 | (str ";charset=" charset)))) 168 | (set-header-maybe "Content-Language" (:language representation)) 169 | (set-header-maybe "Content-Encoding" 170 | (let [e (:encoding representation)] 171 | (if-not (= "identity" e) e))) 172 | (set-header-maybe "Vary" (build-vary-header representation)))} 173 | ;; Finally the result of the handler. We allow the handler to 174 | ;; override the status and headers. 175 | (when-let [result (if-let [handler (get resource (keyword name))] 176 | (handler context) 177 | (get context :message))] 178 | (let [as-response (:as-response resource)] 179 | (as-response result context))))))] 180 | (cond 181 | (or (= :options (:request-method request)) (= 405 (:status response))) 182 | (merge-with combine 183 | {:headers (build-options-headers resource)} 184 | response) 185 | (= :head (:request-method request)) 186 | (dissoc response :body) 187 | :else response))) 188 | 189 | (defmacro ^:private defhandler [name status message] 190 | `(defn ~name [context#] 191 | (run-handler '~name ~status ~message context#))) 192 | 193 | (defn header-exists? [header context] 194 | (get-in context [:request :headers header])) 195 | 196 | (defn if-match-star [context] 197 | (= "*" (get-in context [:request :headers "if-match"]))) 198 | 199 | (defn =method [method context] 200 | (= (get-in context [:request :request-method]) method)) 201 | 202 | (defmulti to-location type) 203 | 204 | (defmethod to-location String [uri] (ring-response {:headers {"Location" uri}})) 205 | 206 | (defmethod to-location clojure.lang.APersistentMap [this] this) 207 | 208 | (defmethod to-location java.net.URI [^java.net.URI uri] (to-location (.toString uri))) 209 | 210 | (defmethod to-location java.net.URL [^java.net.URL url] (to-location (.toString url))) 211 | 212 | (defmethod to-location nil [this] this) 213 | 214 | (defn- handle-moved [{resource :resource :as context}] 215 | (if-let [f (or (get context :location) 216 | (get resource :location))] 217 | (to-location ((make-function f) context)) 218 | {:status 500 219 | :body (format "Internal Server error: no location specified for status %s" (:status context))})) 220 | 221 | ;; Provide :see-other which returns a location or override :handle-see-other 222 | (defhandler handle-see-other 303 nil) 223 | 224 | (defhandler handle-ok 200 "OK") 225 | 226 | (defhandler handle-no-content 204 nil) 227 | 228 | (defhandler handle-multiple-representations 300 nil) ; nil body because the body is reserved to reveal the actual representations available. 229 | 230 | (defhandler handle-accepted 202 "Accepted") 231 | 232 | (defdecision multiple-representations? handle-multiple-representations handle-ok) 233 | 234 | (defdecision respond-with-entity? multiple-representations? handle-no-content) 235 | 236 | (defhandler handle-created 201 nil) 237 | 238 | (defdecision new? handle-created respond-with-entity?) 239 | 240 | (defdecision post-redirect? handle-see-other new?) 241 | 242 | (defdecision post-enacted? post-redirect? handle-accepted) 243 | 244 | (defdecision put-enacted? new? handle-accepted) 245 | 246 | (defhandler handle-not-found 404 "Resource not found.") 247 | 248 | (defhandler handle-gone 410 "Resource is gone.") 249 | 250 | (defaction post! post-enacted?) 251 | 252 | (defdecision can-post-to-missing? post! handle-not-found) 253 | 254 | (defdecision post-to-missing? (partial =method :post) 255 | can-post-to-missing? handle-not-found) 256 | 257 | (defhandler handle-moved-permanently 301 nil) 258 | 259 | (defhandler handle-moved-temporarily 307 nil) 260 | 261 | (defdecision can-post-to-gone? post! handle-gone) 262 | 263 | (defdecision post-to-gone? (partial =method :post) can-post-to-gone? handle-gone) 264 | 265 | (defdecision moved-temporarily? handle-moved-temporarily post-to-gone?) 266 | 267 | (defdecision moved-permanently? handle-moved-permanently moved-temporarily?) 268 | 269 | (defdecision existed? moved-permanently? post-to-missing?) 270 | 271 | (defhandler handle-conflict 409 "Conflict.") 272 | 273 | (defdecision patch-enacted? respond-with-entity? handle-accepted) 274 | 275 | (defaction patch! patch-enacted?) 276 | 277 | (defaction put! put-enacted?) 278 | 279 | (defdecision method-post? (partial =method :post) post! put!) 280 | 281 | (defdecision conflict? handle-conflict method-post?) 282 | 283 | (defhandler handle-not-implemented 501 "Not implemented.") 284 | 285 | (defdecision can-put-to-missing? conflict? handle-not-implemented) 286 | 287 | (defdecision put-to-different-url? handle-moved-permanently can-put-to-missing?) 288 | 289 | (defdecision method-put? (partial =method :put) put-to-different-url? existed?) 290 | 291 | (defhandler handle-precondition-failed 412 "Precondition failed.") 292 | 293 | (defdecision if-match-star-exists-for-missing? 294 | if-match-star 295 | handle-precondition-failed 296 | method-put?) 297 | 298 | (defhandler handle-not-modified 304 nil) 299 | 300 | (defdecision if-none-match? 301 | #(#{ :head :get} (get-in % [:request :request-method])) 302 | handle-not-modified 303 | handle-precondition-failed) 304 | 305 | (defdecision put-to-existing? (partial =method :put) 306 | conflict? multiple-representations?) 307 | 308 | (defdecision post-to-existing? (partial =method :post) 309 | conflict? put-to-existing?) 310 | 311 | (defdecision delete-enacted? respond-with-entity? handle-accepted) 312 | 313 | (defaction delete! delete-enacted?) 314 | 315 | (defdecision method-patch? (partial =method :patch) patch! post-to-existing?) 316 | 317 | (defdecision method-delete? 318 | (partial =method :delete) 319 | delete! 320 | method-patch?) 321 | 322 | (defdecision modified-since? 323 | (fn [context] 324 | (let [last-modified (gen-last-modified context)] 325 | [(or (not last-modified) (.after last-modified (::if-modified-since-date context))) 326 | {::last-modified last-modified}])) 327 | method-delete? 328 | handle-not-modified) 329 | 330 | (defdecision if-modified-since-valid-date? 331 | (fn [context] 332 | (if-let [date (parse-http-date (get-in context [:request :headers "if-modified-since"]))] 333 | {::if-modified-since-date date})) 334 | modified-since? 335 | method-delete?) 336 | 337 | (defdecision if-modified-since-exists? 338 | (partial header-exists? "if-modified-since") 339 | if-modified-since-valid-date? 340 | method-delete?) 341 | 342 | (defdecision etag-matches-for-if-none? 343 | (fn [context] 344 | (let [etag (gen-etag context)] 345 | [(= (get-in context [:request :headers "if-none-match"]) etag) 346 | {::etag etag}])) 347 | if-none-match? 348 | if-modified-since-exists?) 349 | 350 | (defdecision if-none-match-star? 351 | #(= "*" (get-in % [:request :headers "if-none-match"])) 352 | if-none-match? 353 | etag-matches-for-if-none?) 354 | 355 | (defdecision if-none-match-exists? (partial header-exists? "if-none-match") 356 | if-none-match-star? if-modified-since-exists?) 357 | 358 | (defdecision unmodified-since? 359 | (fn [context] 360 | (let [last-modified (gen-last-modified context)] 361 | [(and last-modified 362 | (.after last-modified 363 | (::if-unmodified-since-date context))) 364 | {::last-modified last-modified}])) 365 | handle-precondition-failed 366 | if-none-match-exists?) 367 | 368 | (defdecision if-unmodified-since-valid-date? 369 | (fn [context] 370 | (when-let [date (parse-http-date (get-in context [:request :headers "if-unmodified-since"]))] 371 | {::if-unmodified-since-date date})) 372 | unmodified-since? 373 | if-none-match-exists?) 374 | 375 | (defdecision if-unmodified-since-exists? (partial header-exists? "if-unmodified-since") 376 | if-unmodified-since-valid-date? if-none-match-exists?) 377 | 378 | (defdecision etag-matches-for-if-match? 379 | (fn [context] 380 | (let [etag (gen-etag context)] 381 | [(= etag (get-in context [:request :headers "if-match"])) 382 | {::etag etag}])) 383 | if-unmodified-since-exists? 384 | handle-precondition-failed) 385 | 386 | (defdecision if-match-star? 387 | if-match-star if-unmodified-since-exists? etag-matches-for-if-match?) 388 | 389 | (defdecision if-match-exists? (partial header-exists? "if-match") 390 | if-match-star? if-unmodified-since-exists?) 391 | 392 | (defdecision exists? if-match-exists? if-match-star-exists-for-missing?) 393 | 394 | (defhandler handle-unprocessable-entity 422 "Unprocessable entity.") 395 | (defdecision processable? exists? handle-unprocessable-entity) 396 | 397 | (defhandler handle-not-acceptable 406 "No acceptable resource available.") 398 | 399 | (defdecision encoding-available? 400 | (fn [ctx] 401 | (when-let [encoding (conneg/best-allowed-encoding 402 | (get-in ctx [:request :headers "accept-encoding"]) 403 | ((get-in ctx [:resource :available-encodings]) ctx))] 404 | {:representation {:encoding encoding}})) 405 | 406 | processable? handle-not-acceptable) 407 | 408 | (defmacro try-header [header & body] 409 | `(try ~@body 410 | (catch ExceptionInfo e# 411 | (if (is-protocol-exception? e#) 412 | (throw (ex-info (format "Malformed %s header" ~header) 413 | {:inner-exception e#})) 414 | (throw e#))))) 415 | 416 | (defdecision accept-encoding-exists? (partial header-exists? "accept-encoding") 417 | encoding-available? processable?) 418 | 419 | (defdecision charset-available? 420 | #(when-let [charset (conneg/best-allowed-charset 421 | (get-in % [:request :headers "accept-charset"]) 422 | ((get-in context [:resource :available-charsets]) context))] 423 | (if (= charset "*") 424 | true 425 | {:representation {:charset charset}})) 426 | accept-encoding-exists? handle-not-acceptable) 427 | 428 | (defdecision accept-charset-exists? (partial header-exists? "accept-charset") 429 | charset-available? accept-encoding-exists?) 430 | 431 | 432 | (defdecision language-available? 433 | #(when-let [lang (conneg/best-allowed-language 434 | (get-in % [:request :headers "accept-language"]) 435 | ((get-in context [:resource :available-languages]) context))] 436 | (if (= lang "*") 437 | true 438 | {:representation {:language lang}})) 439 | accept-charset-exists? handle-not-acceptable) 440 | 441 | (defdecision accept-language-exists? (partial header-exists? "accept-language") 442 | language-available? accept-charset-exists?) 443 | 444 | (defn negotiate-media-type [context] 445 | (try-header "Accept" 446 | (when-let [type (conneg/best-allowed-content-type 447 | (get-in context [:request :headers "accept"]) 448 | ((get-in context [:resource :available-media-types] (constantly "text/html")) context))] 449 | {:representation {:media-type (conneg/stringify type)}}))) 450 | 451 | (defdecision media-type-available? negotiate-media-type 452 | accept-language-exists? handle-not-acceptable) 453 | 454 | (defdecision accept-exists? 455 | #(if (header-exists? "accept" %) 456 | true 457 | ;; "If no Accept header field is present, then it is assumed that the 458 | ;; client accepts all media types" [p100] 459 | ;; in this case we do content-type negotiation using */* as the accept 460 | ;; specification 461 | (if-let [type (liberator.conneg/best-allowed-content-type 462 | "*/*" 463 | ((get-in context [:resource :available-media-types]) context))] 464 | [false {:representation {:media-type (liberator.conneg/stringify type)}}] 465 | false)) 466 | media-type-available? 467 | accept-language-exists?) 468 | 469 | (defhandler handle-options 200 nil) 470 | 471 | (defdecision is-options? #(= :options (:request-method (:request %))) handle-options accept-exists?) 472 | 473 | (defhandler handle-request-entity-too-large 413 "Request entity too large.") 474 | (defdecision valid-entity-length? is-options? handle-request-entity-too-large) 475 | 476 | (defhandler handle-unsupported-media-type 415 "Unsupported media type.") 477 | (defdecision known-content-type? valid-entity-length? handle-unsupported-media-type) 478 | 479 | (defdecision valid-content-header? known-content-type? handle-not-implemented) 480 | 481 | (defhandler handle-forbidden 403 "Forbidden.") 482 | (defdecision allowed? valid-content-header? handle-forbidden) 483 | 484 | (defhandler handle-unauthorized 401 "Not authorized.") 485 | (defdecision authorized? allowed? handle-unauthorized) 486 | 487 | (defhandler handle-malformed 400 "Bad request.") 488 | (defdecision malformed? handle-malformed authorized?) 489 | 490 | (defhandler handle-method-not-allowed 405 "Method not allowed.") 491 | (defdecision method-allowed? coll-validator malformed? handle-method-not-allowed) 492 | 493 | (defhandler handle-uri-too-long 414 "Request URI too long.") 494 | (defdecision uri-too-long? handle-uri-too-long method-allowed?) 495 | 496 | (defhandler handle-unknown-method 501 "Unknown method.") 497 | (defdecision known-method? uri-too-long? handle-unknown-method) 498 | 499 | (defhandler handle-service-not-available 503 "Service not available.") 500 | (defdecision service-available? known-method? handle-service-not-available) 501 | 502 | (defaction initialize-context service-available?) 503 | 504 | (defhandler handle-exception 500 "Internal server error.") 505 | 506 | (defn handle-exception-rethrow [{e :exception}] 507 | (throw e)) 508 | 509 | (defn test-request-method [valid-methods-key] 510 | (fn [{{m :request-method} :request 511 | {vm valid-methods-key} :resource 512 | :as ctx}] 513 | (some #{m} (vm ctx)))) 514 | 515 | (def default-functions 516 | { 517 | :initialize-context {} 518 | 519 | ;; Decisions 520 | :service-available? true 521 | 522 | :known-methods [:get :head :options :put :post :delete :trace :patch] 523 | :known-method? (test-request-method :known-methods) 524 | 525 | :uri-too-long? false 526 | 527 | :allowed-methods [:get :head] 528 | :method-allowed? (test-request-method :allowed-methods) 529 | 530 | :malformed? false 531 | ;; :encoding-available? true 532 | ;; :charset-available? true 533 | :authorized? true 534 | :allowed? true 535 | :valid-content-header? true 536 | :known-content-type? true 537 | :valid-entity-length? true 538 | :exists? true 539 | :existed? false 540 | :respond-with-entity? false 541 | :new? true 542 | :post-redirect? false 543 | :put-to-different-url? false 544 | :multiple-representations? false 545 | :conflict? false 546 | :can-post-to-missing? true 547 | :can-put-to-missing? true 548 | :moved-permanently? false 549 | :moved-temporarily? false 550 | :post-enacted? true 551 | :put-enacted? true 552 | :patch-enacted? true 553 | :delete-enacted? true 554 | :processable? true 555 | 556 | ;; Handlers 557 | :handle-ok "OK" 558 | :handle-see-other handle-moved 559 | :handle-moved-temporarily handle-moved 560 | :handle-moved-permanently handle-moved 561 | :handle-exception handle-exception-rethrow 562 | 563 | ;; Imperatives. Doesn't matter about decision outcome, both 564 | ;; outcomes follow the same route. 565 | :post! true 566 | :put! true 567 | :delete! true 568 | :patch! true 569 | 570 | ;; To support RFC5789 Patch, this is used for OPTIONS Accept-Patch 571 | ;; header 572 | :patch-content-types [] 573 | 574 | ;; The default function used extract a ring response from a handler's response 575 | :as-response (fn [data ctx] 576 | (when data (as-response data ctx))) 577 | 578 | ;; Directives 579 | :available-media-types [] 580 | 581 | ;; "If no Content-Language is specified, the default is that the 582 | ;; content is intended for all language audiences. This might mean 583 | ;; that the sender does not consider it to be specific to any 584 | ;; natural language, or that the sender does not know for which 585 | ;; language it is intended." 586 | :available-languages ["*"] 587 | :available-charsets ["UTF-8"] 588 | :available-encodings ["identity"]}) 589 | 590 | ;; resources are a map of implementation methods 591 | (defn run-resource [request kvs] 592 | (try 593 | (initialize-context {:request request 594 | :resource (map-values make-function (merge default-functions kvs)) 595 | :representation {}}) 596 | 597 | (catch ExceptionInfo e 598 | (if (is-protocol-exception? e) ; this indicates a client error 599 | {:status 400 600 | :headers {"Content-Type" "text/plain"} 601 | :body (.getMessage e) 602 | ::throwable e} ; ::throwable gets picked up by an error renderer 603 | (throw e))))) 604 | 605 | 606 | (defn get-options 607 | [kvs] 608 | (if (map? (first kvs)) 609 | (merge (first kvs) (apply hash-map (rest kvs))) 610 | (apply hash-map kvs))) 611 | 612 | (defn resource [& kvs] 613 | (fn [request] 614 | (run-resource request (get-options kvs)))) 615 | 616 | (defmacro defresource [name & resource-decl] 617 | (let [[docstring resource-decl] (if (string? (first resource-decl)) 618 | [(first resource-decl) (rest resource-decl)] 619 | [nil resource-decl]) 620 | [args kvs] (if (vector? (first resource-decl)) 621 | [(first resource-decl) (rest resource-decl)] 622 | [nil resource-decl]) 623 | ;; Rather than call `resource` directly, create an anonymous 624 | ;; function in the caller's namespace for better debugability. 625 | resource-fn `(fn [request#] 626 | (run-resource request# (get-options (list ~@kvs))))] 627 | (if args 628 | (if docstring 629 | `(defn ~name ~docstring [~@args] ~resource-fn) 630 | `(defn ~name [~@args] ~resource-fn)) 631 | (if docstring 632 | `(def ~name ~docstring ~resource-fn) 633 | `(def ~name ~resource-fn))))) 634 | 635 | (defn by-method 636 | "returns a handler function that uses the request method to 637 | lookup a function from the map and delegates to it. 638 | 639 | Example: 640 | 641 | (by-method {:get \"This is the entity\" 642 | :delete \"Entity was deleted successfully.\"})" 643 | [map] 644 | (fn [ctx] ((make-function (get map (get-in ctx [:request :request-method]) ctx)) ctx))) 645 | -------------------------------------------------------------------------------- /src/liberator/dev.clj: -------------------------------------------------------------------------------- 1 | (ns liberator.dev 2 | (:use hiccup.core 3 | hiccup.page 4 | [liberator.core :only [defresource]]) 5 | (:require [liberator.core :as core] 6 | [clojure.string :as string] 7 | [clojure.data.json :as json] 8 | [ring.util.response :as response] 9 | [clojure.string :as s]) 10 | (:import java.util.Date)) 11 | 12 | (def mount-url "/x-liberator/requests/") 13 | 14 | (defonce logs (atom nil)) 15 | 16 | (defn next-id [] (apply str (take 5 (repeatedly 17 | #(rand-nth "abcdefghijklmnopqrstuvwzxy0123456789"))))) 18 | 19 | (def log-size 100) 20 | 21 | (defn save-log! [id msg] 22 | (swap! logs #(->> (conj % [id msg]) 23 | (take log-size) 24 | (doall)))) 25 | 26 | (defn- with-slash [^String s] (if (.endsWith s "/") s (str s "/"))) 27 | 28 | (def ^:dynamic *current-id* nil) 29 | 30 | (defn seconds-ago [^Date d] 31 | (int (/ (- ( System/currentTimeMillis) (.getTime d)) 1000))) 32 | 33 | (defn log-by-id [id] 34 | (first (filter (fn [[aid _]] (= id aid)) @logs))) 35 | 36 | ;; see graph/clean-id, unitfy 37 | (defn- clean-id [str] 38 | (clojure.string/replace (or str "") #"[^a-zA-Z0-9_]+" "")) 39 | 40 | (defn result->bool [r] 41 | (if (vector? r) (first r) 42 | r)) 43 | 44 | (defn hl-result [r] 45 | (if (result->bool r) 46 | "hl-true" 47 | "hl-false")) 48 | 49 | (defresource log-handler [id] 50 | :available-media-types ["text/html" "application/json"] 51 | :exists? (fn [ctx] (if-let [l (log-by-id id)] (assoc ctx ::log l))) 52 | :handle-ok 53 | (fn [{[_ [d r log]] ::log {media-type :media-type} :representation}] 54 | (condp = media-type 55 | "text/html" 56 | (html5 57 | [:head 58 | [:title "Liberator Request Trace #" id " at " d]] 59 | [:script 60 | (s/join "\n" 61 | ["" 62 | "function insertStyle() {" 63 | "var svg = document.getElementById(\"trace\").contentDocument;\n" 64 | "var style = svg.createElementNS(\"http://www.w3.org/2000/svg\",\"style\"); " 65 | (str "style.textContent = '" 66 | (clojure.string/replace 67 | (slurp (clojure.java.io/resource "liberator/trace.css")) 68 | #"[\r\n]" " ") "'; ") 69 | "var root = svg.getElementsByTagName(\"svg\")[0];" 70 | "root.appendChild(style); " 71 | "root.setAttribute(\"width\", \"100%\"); root.setAttribute(\"height\", \"100%\"); " 72 | (s/join "\n" 73 | (map (fn [[l [n r]]] 74 | (format 75 | "svg.getElementById(\"%s\").setAttribute(\"class\", svg.getElementById(\"%s\").getAttribute(\"class\") + \" %s\"); " (clean-id n) (clean-id n) (hl-result r))) log)) 76 | 77 | (s/join "\n" 78 | (map (fn [[[l1 [n1 r1]] [lr2 [n2 r2]]]] 79 | (let [id (format "%s_%s" (clean-id n1) (clean-id n2))] 80 | (format 81 | "svg.getElementById(\"%s\").setAttribute(\"class\", svg.getElementById(\"%s\").getAttribute(\"class\") + \" %s\");" id id (if (result->bool r1) "hl-true" "hl-false")))) 82 | (map vector log (rest log)))) 83 | 84 | "};" 85 | "setTimeout(function(){insertStyle()}, 500);" 86 | "setTimeout(function(){insertStyle()}, 1000);" 87 | "setTimeout(function(){insertStyle()}, 5000);" 88 | 89 | ""])] 90 | [:body 91 | [:a {:href mount-url} "List of all traces"] 92 | [:h1 "Liberator Request Trace #" id " at " d " (" (seconds-ago d) "s ago)"] 93 | [:h2 "Request was "" [:span {:style "text-transform: uppercase"} 94 | (:request-method r)] " " [:span (:uri r)] """] 95 | [:h3 "Parameters"] 96 | [:dl (mapcat (fn [[k v]] [[:dt (h k)] [:dd (h v)]]) (:params r))] 97 | [:h3 "Headers"] 98 | [:dl (mapcat (fn [[k v]] [[:dt (h k)] [:dd (h v)]]) (:headers r))] 99 | [:h3 "Trace"] 100 | [:ol (map (fn [[l [n r]]] [:li (h l) ": " (h n) " " 101 | (if (nil? r) [:em "nil"] (h (pr-str r)))]) log)] 102 | [:div {:style "text-align: center;"} 103 | [:object {:id "trace" :data (str mount-url "trace.svg") :width "90%" 104 | :style "border: 1px solid #666;"}]] 105 | 106 | 107 | [:h3 "Full Request"] 108 | [:pre [:tt (h (with-out-str (clojure.pprint/pprint r)))]]]) 109 | "application/json" 110 | (with-out-str 111 | (json/write {:date (str d) 112 | :request {:method (:request-method r) 113 | :uri (:uri r) 114 | :parameters (:params r) 115 | :headers (:headers r)} 116 | :trace log} *out*)))) 117 | 118 | :handle-not-found 119 | (fn [ctx] 120 | (html5 [:head [:title "Liberator Request Trace #" id " not found."]] 121 | [:body [:h1 "Liberator Request Trace #" id " not found."] 122 | [:p "The requested trace was not found. Maybe it is expired."] 123 | [:p "You can access a " [:a {:href mount-url} "list of traces"] "."]]))) 124 | 125 | (defresource list-handler 126 | :available-media-types ["text/html"] 127 | :handle-ok (fn [_] 128 | (html5 129 | [:head 130 | [:title "Liberator Request Traces"]] 131 | [:body 132 | [:h1 "Liberator Request Traces"] 133 | (if (empty? @logs) 134 | [:div 135 | [:p "No request traces have been recorded, yet."] 136 | [:p "wrap your handler with " [:code "wrap-trace-ui"] " to enable logging." 137 | "The link to the log will be available as a " [:code "Link"] 138 | " header in the http response."]] 139 | [:ol (map (fn [[id [d {:keys [request-method uri]} log]]] 140 | [:ul 141 | [:a {:href (h (str (with-slash mount-url) id))} 142 | [:span (h request-method)] " " [:span (h uri)]] 143 | [:span " at " [:span (h d)] " " [:span "(" (seconds-ago d) "s ago)"]]]) @logs)])]))) 144 | 145 | (defn css-url [] (str (with-slash mount-url) "styles.css")) 146 | 147 | (defn include-trace-css [] 148 | (include-css (css-url))) 149 | 150 | (defn trace-url 151 | "Build the url under which the trace information can be found for the 152 | given trace id" 153 | [id] 154 | (str (with-slash mount-url) id)) 155 | 156 | (defn current-trace-url 157 | "Return the url under with the trace of the current request can be accessed" 158 | [] 159 | (trace-url *current-id*)) 160 | 161 | (defn include-trace-panel 162 | "Create a html snippet with a link to the current requests' trace" 163 | [] 164 | (html 165 | [:div {:id "x-liberator-trace"} 166 | [:a {:href (current-trace-url)} (str "Liberator Request Trace #" *current-id*)]])) 167 | 168 | (defresource styles 169 | :available-media-types ["text/css"] 170 | :handle-ok "#x-liberator-trace { 171 | display:block; 172 | 173 | position:absolute; 174 | top:0; 175 | right:0; 176 | 177 | margin-top: 1em; 178 | margin-right: 1em; 179 | padding: 0 1em; 180 | color: #333; 181 | background-color: #f0f0f0; 182 | font-size: 12px; 183 | border: 1px solid #999; 184 | border-radius: .3em; 185 | text-align: center; 186 | }" 187 | :etag "1") 188 | 189 | (def trace-id-header "X-Liberator-Trace-Id") 190 | 191 | (def trace-svg (clojure.java.io/resource "liberator/trace.svg")) 192 | 193 | (defn- handle-and-add-trace-link [handler req] 194 | (let [resp (handler req)] 195 | (if-let [id (get-in resp [:headers trace-id-header])] 196 | (update-in resp [:headers "Link"] 197 | #(if %1 [%1 %2] %2) 198 | (format "; rel=x-liberator-trace" (trace-url id))) 199 | resp))) 200 | 201 | (defn- wrap-trace-ui [handler] 202 | (let [base-url (with-slash mount-url)] 203 | (fn [req] 204 | (if (.startsWith (:uri req) base-url) 205 | (let [subpath (s/replace (:uri req) base-url "")] 206 | (case subpath 207 | "trace.svg" (response/content-type (response/url-response trace-svg) "image/svg+xml") 208 | "styles.css" (styles req) 209 | "" (list-handler req) 210 | ((log-handler subpath) req))) 211 | 212 | (handle-and-add-trace-link handler req))))) 213 | 214 | (defn- wrap-trace-header [handler] 215 | (fn [req] 216 | (let [resp (handler req)] 217 | (if-let [id (get-in resp [:headers trace-id-header])] 218 | (let [[_ [_ _ l]] (log-by-id id)] 219 | (assoc-in resp [:headers "X-Liberator-Trace"] 220 | (map #(s/join " " %) l))) 221 | resp)))) 222 | 223 | (defn- cond-wrap [fn expr wrapper] 224 | (if expr (wrapper fn) fn)) 225 | 226 | (defn wrap-trace 227 | "Wraps a ring handler such that a request trace is generated. 228 | 229 | Supported options: 230 | 231 | :ui - Include link to a resource that dumps the current request 232 | :header - Include full trace in response header" 233 | [handler & opts] 234 | (-> 235 | (fn [request] 236 | (let [request-log (atom [])] 237 | (binding [*current-id* (next-id)] 238 | (core/with-logger (core/atom-logger request-log) 239 | (let [resp (handler request)] 240 | (if-not (empty? @request-log) 241 | (do 242 | (save-log! *current-id* 243 | [(Date.) 244 | (select-keys request [:request-method :uri :headers :params]) 245 | @request-log]) 246 | (assoc-in resp [:headers trace-id-header] *current-id*)) 247 | resp)))))) 248 | (cond-wrap (some #{:ui} opts) wrap-trace-ui) 249 | (cond-wrap (some #{:header} opts) wrap-trace-header))) 250 | -------------------------------------------------------------------------------- /src/liberator/graph.clj: -------------------------------------------------------------------------------- 1 | (ns liberator.graph) 2 | 3 | (defn extract 4 | ([_ name then else] [name then else]) 5 | ([_ name test then else] [name then else])) 6 | 7 | (defn clean-id [str] 8 | (clojure.string/replace str #"[^a-zA-Z0-9_]+" "")) 9 | 10 | (defn to-graph [[& args]] 11 | (condp = (first args) 12 | 'defdecision 13 | (let [[name then else] (apply extract args)] 14 | (format (str "\"%s\" [id = \"%s\"] \n " 15 | "\"%s\" -> \"%s\" [label = \"true\", id = \"%s\"] \n" 16 | "\"%s\" -> \"%s\" [label = \"false\", id = \"%s\"]\n") 17 | name (clean-id name) 18 | name then (clean-id (str name "_" then)) 19 | name else (clean-id (str name "_" else)))) 20 | 'defaction 21 | (let [[_ name then] args] 22 | (format (str "\"%s\"[shape=\"ellipse\" id = \"%s\"];\n" 23 | "\"%s\"-> \"%s\" [id = \"%s\"] \n") 24 | name (clean-id name) 25 | name then (clean-id (str name "_" then)))) 26 | 'defhandler 27 | (let [[_ name status message] args 28 | color (cond 29 | (>= status 500) "#e31a1c" 30 | (>= status 400) "#fb9a99" 31 | (>= status 300) "#fbdf6f" 32 | (>= status 200) "#b2df8a" 33 | (>= status 100) "#a6cee3" 34 | :else "#ffffff")] 35 | (format "\"%s\"[id=\"%s\" label=\"%s\\n%s\" style=\"filled\" fillcolor=\"%s\"];\n" 36 | name (clean-id name) status (clojure.string/replace name #"^handle-" "") color)) 37 | nil)) 38 | 39 | (defn rank-max [names] 40 | (str "subgraph {\nrank=max;\n" 41 | (apply str (interpose "-> \n" (map #(format "\"%s\"" %) names))) 42 | ";\n}\n")) 43 | 44 | (defn rank-same [names] 45 | (str "subgraph {\nrank=same;\n" 46 | (apply str (interpose ";\n" (map #(format "\"%s\"" %) names))) 47 | ";\n}\n")) 48 | 49 | (defn rank-handler-groups [handlers] 50 | (->> handlers 51 | (group-by (fn [[name status]] (int (/ status 100)))) 52 | vals 53 | (map (fn [sg] (map first sg))) 54 | (map rank-same) 55 | (apply str) 56 | )) 57 | 58 | (defn parse-source-definitions [] 59 | (let [nodes (let [pr (java.io.PushbackReader. 60 | (clojure.java.io/reader "src/liberator/core.clj")) 61 | eof (Object.)] 62 | (take-while #(not= eof %) (repeatedly #(read pr false eof)))) 63 | decisions (->> nodes 64 | (filter #(= 'defdecision (first %))) 65 | (map second)) 66 | handlers (->> nodes 67 | (filter #(= 'defhandler (first %))) 68 | (map (fn [[_ name status _]] [name status]))) 69 | actions (->> nodes 70 | (filter #(= 'defaction (first %))) 71 | (map second))] 72 | {:nodes nodes 73 | :decisions decisions 74 | :handlers handlers 75 | :actions actions})) 76 | 77 | (defn generate-graph-dot [] 78 | (let [{:keys [nodes handlers actions]} (parse-source-definitions)] 79 | (->> nodes 80 | (map to-graph) 81 | (filter identity) 82 | (concat (rank-handler-groups handlers)) 83 | (concat (rank-same (remove #{'initialize-context} actions))) 84 | (apply str) 85 | (format (str "digraph{\nid=\"trace\"; size=\"1000,1000\"; page=\"1000,1000\";\n\n" 86 | "edge[fontname=\"sans-serif\"]\n" 87 | "node[shape=\"box\", splines=ortho fontname=\"sans-serif\"]\n\n" 88 | "%s" 89 | "\n}"))))) 90 | 91 | (defn generate-dot-file [f] 92 | (spit f (generate-graph-dot))) 93 | 94 | -------------------------------------------------------------------------------- /src/liberator/representation.clj: -------------------------------------------------------------------------------- 1 | (ns liberator.representation 2 | (:require 3 | [clojure.data.json :as json] 4 | [clojure.data.csv :as csv] 5 | [clojure.string :refer [split trim]] 6 | [liberator.util :as util] 7 | [hiccup.core :refer [html]] 8 | [hiccup.page :refer [html5 xhtml]])) 9 | 10 | ;; This namespace provides default 'out-of-the-box' web representations 11 | ;; for many IANA mime-types. 12 | 13 | (defmacro ->when [form pred & term] 14 | `(if ~pred (-> ~form ~@term) ~form)) 15 | 16 | (defprotocol Representation 17 | (as-response [_ {representation :representation :as context}] 18 | "Coerce to a standard Ring response (a map 19 | containing :status, :headers and :body). Developers can call 20 | as-response directly, usually when they need to augment the context. It 21 | does all the charset conversion and encoding and returns are Ring 22 | response map so no further post-processing of the response will be 23 | carried out.")) 24 | 25 | (defn default-dictionary [k lang] 26 | (if (instance? clojure.lang.Named k) 27 | (name k) 28 | (str k))) 29 | 30 | (defn html-table [data fields lang dictionary] 31 | [:div [:table 32 | [:thead 33 | [:tr 34 | (for [field fields] [:th (or (dictionary field lang) 35 | (default-dictionary field lang))])]] 36 | [:tbody (for [row data] 37 | [:tr 38 | (for [field fields] 39 | [:td (if-let [s (get row field)] 40 | (if (re-matches #"https?://.*" (str s)) 41 | [:a {:href s} s] 42 | s) 43 | "")])])]]]) 44 | 45 | (defmulti render-map-generic "dispatch on media type" 46 | (fn [data context] (get-in context [:representation :media-type]))) 47 | 48 | (defmethod render-map-generic "text/plain" 49 | [data {:keys [dictionary language] :or {dictionary default-dictionary} :as context}] 50 | (->> data 51 | (map (fn [[k v]] (str (dictionary k language) "=" v))) 52 | (interpose "\r\n") 53 | (apply str))) 54 | 55 | (defn- render-map-csv [data sep] 56 | (with-out-str 57 | (csv/write-csv *out* [["name" "value"]] :newline :cr+lf :separator sep) 58 | (csv/write-csv *out* (seq data) :newline :cr+lf :separator sep))) 59 | 60 | (defmethod render-map-generic "text/csv" [data context] 61 | (render-map-csv data \,)) 62 | 63 | (defmethod render-map-generic "text/tab-separated-values" [data context] 64 | (render-map-csv data \tab)) 65 | 66 | (defmethod render-map-generic "application/json" [data context] 67 | (json/write-str data)) 68 | 69 | (defn render-as-clojure [data] 70 | (binding [*print-dup* true] 71 | (pr-str data))) 72 | 73 | (defn render-as-edn [data] 74 | (pr-str data)) 75 | 76 | (defmethod render-map-generic "application/clojure" [data context] 77 | (render-as-clojure data)) 78 | 79 | (defmethod render-map-generic "application/edn" [data context] 80 | (render-as-edn data)) 81 | 82 | (defn- render-map-html-table 83 | [data 84 | {{:keys [media-type language] :as representation} :representation 85 | :keys [dictionary fields] :or {dictionary default-dictionary} 86 | :as context} mode] 87 | (let [content 88 | [:div [:table 89 | 90 | [:tbody (for [[key value] data] 91 | [:tr 92 | [:th (or (dictionary key language) (default-dictionary key language))] 93 | [:td value]])]]]] 94 | (condp = mode 95 | :html (html content) 96 | :xhtml (xhtml content)))) 97 | 98 | 99 | (defmethod render-map-generic "text/html" [data context] 100 | (render-map-html-table data context :html)) 101 | 102 | (defmethod render-map-generic "application/xhtml+xml" [data context] 103 | (render-map-html-table data context :html)) 104 | 105 | (defmulti render-seq-generic (fn [data context] (get-in context [:representation :media-type]))) 106 | 107 | (defn render-seq-html-table 108 | [data 109 | {{:keys [media-type language] :as representation} :representation 110 | :keys [dictionary fields] :or {dictionary default-dictionary 111 | fields (keys (first data))} 112 | :as context} mode] 113 | (let [content (html-table data fields language dictionary)] 114 | (condp = mode 115 | :html (html content) 116 | :xhtml (xhtml content)))) 117 | 118 | 119 | (defmethod render-seq-generic "text/html" [data context] 120 | (render-seq-html-table data context :html)) 121 | 122 | (defmethod render-seq-generic "application/xhtml+xml" [data context] 123 | (render-seq-html-table data context :html)) 124 | 125 | (defmethod render-seq-generic "application/json" [data _] 126 | (json/write-str data)) 127 | 128 | (defmethod render-seq-generic "application/clojure" [data _] 129 | (render-as-clojure data)) 130 | 131 | (defmethod render-seq-generic "application/edn" [data _] 132 | (render-as-edn data)) 133 | 134 | (defn render-seq-csv 135 | [data 136 | {{:keys [language] :as representation} :representation 137 | :keys [dictionary fields] :or {dictionary default-dictionary 138 | fields (keys (first data))} 139 | :as context} sep] 140 | (let [sw (java.io.StringWriter.)] 141 | (csv/write-csv sw [(map #(or (dictionary % language) 142 | (default-dictionary % language)) fields)] 143 | :newline :cr+lf :separator sep) 144 | (csv/write-csv sw (map (apply juxt (map (fn [x] (fn [m] (get m x))) fields)) data) 145 | :newline :cr+lf :separator sep) 146 | (str sw))) 147 | 148 | (defmethod render-seq-generic "text/csv" [data context] 149 | (render-seq-csv data context \,)) 150 | 151 | (defmethod render-seq-generic "text/tab-separated-values" [data context] 152 | (render-seq-csv data context \tab)) 153 | 154 | (defmethod render-seq-generic "text/plain" [data context] 155 | (clojure.string/join "\r\n\r\n" 156 | (map #(render-map-generic % context) 157 | data))) 158 | 159 | (defmulti render-item (fn [m media-type] (type m))) 160 | 161 | (defmethod render-item clojure.lang.Associative [m media-type] 162 | (render-map-generic m media-type)) 163 | 164 | (defmethod render-item clojure.lang.Seqable [m media-type] 165 | (render-seq-generic m media-type)) 166 | 167 | (defmethod render-seq-generic :default 168 | [data {{:keys [language media-type] :as representation} :representation :as context}] 169 | (if media-type 170 | {:status 500 :body 171 | (format "Cannot render sequential data as %s (language: %s)" media-type language)} 172 | (render-seq-generic data (assoc-in context [:representation :media-type] 173 | "application/json")))) 174 | 175 | (defn in-charset [^String string ^String charset] 176 | (if (and charset (not (.equalsIgnoreCase charset "UTF-8"))) 177 | (java.io.ByteArrayInputStream. 178 | (.getBytes string (java.nio.charset.Charset/forName charset))) 179 | 180 | ;; "If no Accept-Charset header is present, the default is that 181 | ;; any character set is acceptable." (p101). In the case of Strings, it is unnecessary to convert to a byte stream now, and doing so might even make things harder for test-suites, so we just return the string. 182 | string)) 183 | 184 | 185 | 186 | ;; Representation embodies all the rules as to who should encode the content. 187 | ;; The aim is to do more for developer's who don't want to, while seeding control for developers who need it. 188 | ;; 189 | ;; Representation is a lot like compojure.response.Renderable, but it has to deal with automatic rendering of common Clojure datatypes, charset conversion and encoding. 190 | ;; 191 | ;; TODO This needs to be extended by NIO classes: CharBuffer, ByteBuffer, exploiting CharSetEncoder, etc.. 192 | (extend-protocol Representation 193 | 194 | nil 195 | (as-response [this _] nil) ; accept defaults 196 | 197 | clojure.lang.Sequential 198 | (as-response [data context] 199 | (as-response (render-seq-generic data context) context)) 200 | 201 | clojure.lang.MapEquivalence 202 | (as-response [this context] 203 | (as-response (render-map-generic this context) context)) 204 | 205 | ;; If a string is returned, we should carry out the conversion of both the charset and the encoding. 206 | String 207 | (as-response [this {representation :representation}] 208 | (let [charset (get representation :charset "UTF-8")] 209 | {:body 210 | (in-charset this charset) 211 | :headers {"Content-Type" (format "%s;charset=%s" (get representation :media-type "text/plain") charset)}})) 212 | 213 | ;; If an input-stream is returned, we have no way of telling whether it's been encoded properly (charset and encoding), so we have to assume it is, given that we told the developer what representation was negotiated. 214 | java.io.File 215 | (as-response [this _] {:body this}) 216 | 217 | ;; We assume the input stream is already in the requested 218 | ;; charset. Decoding and encoding an existing charset unnecessarily 219 | ;; would be expensive. 220 | java.io.InputStream 221 | (as-response [this {representation :representation}] 222 | (let [charset (get representation :charset "UTF-8")] 223 | {:body this 224 | :headers {"Content-Type" (format "%s;charset=%s" (get representation :media-type "text/plain") charset)}}))) 225 | 226 | ;; define a wrapper to tell a generic Map from a Ring response map 227 | ;; and to return a ring response as the representation 228 | (defrecord RingResponse [ring-response value] 229 | Representation 230 | (as-response [_ context] 231 | (let [base (when value (as-response value context))] 232 | (util/combine base ring-response)))) 233 | 234 | (defn ring-response 235 | "Returns the given map as a ring response. The map is not converted 236 | with `as-response`. 237 | 238 | An optional representation value will be converted to a ring-response 239 | using `as-response` as usual and the ring-response parameter will be 240 | merged over it. 241 | 242 | The merge is done with `liberator.core/combine` and thus merges 243 | recursively. 244 | 245 | Example: 246 | 247 | A handler returns 248 | 249 | (ring-response {:foo :bar} 250 | {:status 999 251 | :headers {\"X-Custom\" \"value\"}) 252 | 253 | The final response will have the overriden status code 999 and a 254 | custom header set. Assuming the negotiated content type was 255 | application/json the response will be 256 | 257 | {:headers {\"Content-Type\" \"application/json\" 258 | \"X-Custom\" \"value\"} 259 | :status 999 260 | :body \"{'foo': 'bar'}\"} " 261 | ([ring-response-map] (ring-response nil ring-response-map)) 262 | ([value ring-response-map] (->RingResponse ring-response-map value))) 263 | 264 | (defn- content-type [ctx] 265 | (get-in ctx [:request :headers "content-type"])) 266 | 267 | (defn- encoding [ctx] 268 | (or 269 | (second (flatten (re-seq #"charset=([^;]+)" (content-type ctx)))) 270 | "ISO-8859-1")) 271 | 272 | (defmulti parse-request-entity 273 | (fn [ctx] 274 | (when-let [media-type (content-type ctx)] 275 | (-> media-type 276 | (split #"\s*;\s*") 277 | first)))) 278 | 279 | (defmethod parse-request-entity "application/json" [ctx] 280 | (if-let [body (:body (:request ctx))] 281 | {:request-entity (json/read-str (slurp body :encoding (encoding ctx)) :key-fn keyword)} 282 | true)) 283 | 284 | (defmethod parse-request-entity :default [ctx] 285 | (if-let [body (:body (:request ctx))] 286 | {:request-entity body} 287 | true)) 288 | 289 | (defn parsable-content-type? 290 | "Tells if the request has a content-type that can be parsed by 291 | the default implementation for :processable?" 292 | [ctx] 293 | (contains? (methods parse-request-entity) (content-type ctx))) 294 | -------------------------------------------------------------------------------- /src/liberator/trace.css: -------------------------------------------------------------------------------- 1 | .node.hl-true:not([id^="handle"]) polygon { fill: #ccffcc; stroke: #00dd00; } 2 | .node.hl-true polygon { stroke-width: 3;} 3 | .node.hl-true text { fill: #003300; } 4 | .edge.hl-true path { stroke: #00cc00; stroke-width: 3;} 5 | .edge.hl-true polygon { fill: #00cc00; stroke: #00cc00; stroke-width: 3;} 6 | .edge.hl-true text { fill: #00cc00; } 7 | 8 | .node.hl-false:not([id^="handle"]) polygon { fill: #ffcccc; stroke: #dd0000; } 9 | .node.hl-false polygon { stroke-width: 3;} 10 | .node.hl-false text { fill: #330000; } 11 | .edge.hl-false path { stroke: #dd0000; stroke-width: 3;} 12 | .edge.hl-false polygon { fill: #dd0000; stroke: #dd0000; stroke-width: 3;} 13 | .edge.hl-false text { fill: #dd0000; } -------------------------------------------------------------------------------- /src/liberator/util.clj: -------------------------------------------------------------------------------- 1 | (ns liberator.util 2 | (:import java.util.TimeZone 3 | java.text.SimpleDateFormat 4 | java.util.Locale 5 | java.util.Date)) 6 | 7 | (defn make-function [x] 8 | (if (or (fn? x) 9 | (instance? clojure.lang.MultiFn x) 10 | (keyword? x)) 11 | x 12 | (constantly x))) 13 | 14 | (defn apply-if-function [function-or-value request] 15 | (if (fn? function-or-value) 16 | (function-or-value request) 17 | function-or-value)) 18 | 19 | (defprotocol DateCoercions 20 | (as-date [_])) 21 | 22 | (extend-protocol DateCoercions 23 | java.util.Date 24 | (as-date [this] this) 25 | Long 26 | (as-date [millis-since-epoch] 27 | (java.util.Date. millis-since-epoch)) 28 | nil 29 | (as-date [this] nil)) 30 | 31 | (defn ^SimpleDateFormat http-date-format [] 32 | (let [df (new SimpleDateFormat 33 | "EEE, dd MMM yyyy HH:mm:ss z" 34 | Locale/US)] 35 | (do (.setTimeZone df (TimeZone/getTimeZone "GMT")) 36 | df))) 37 | 38 | (defn relative-date [^long future] 39 | (Date. (+ (System/currentTimeMillis) future))) 40 | 41 | (defn http-date [date] 42 | (format "%s" (.format (http-date-format) date))) 43 | 44 | (defn parse-http-date [date-string] 45 | (if (nil? date-string) 46 | nil 47 | (try 48 | (.parse (http-date-format) date-string) 49 | (catch java.text.ParseException e nil)))) 50 | 51 | (defn by-method [& kvs] 52 | (fn [ctx] 53 | (let [m (apply hash-map kvs) 54 | method (get-in ctx [:request :request-method])] 55 | (if-let [fd (make-function (or (get m method) (get m :any)))] (fd ctx))))) 56 | 57 | ;; A more sophisticated update of the request than a simple merge 58 | ;; provides. This allows decisions to return maps which modify the 59 | ;; original request in the way most probably intended rather than the 60 | ;; over-destructive default merge. 61 | (defn combine 62 | "Merge two values such that two maps a merged, two lists, two 63 | vectors and two sets are concatenated. 64 | 65 | Maps will be merged with maps. The map values will be merged 66 | recursively with this function. 67 | 68 | Lists, Vectors and Sets will be concatenated with values that are 69 | `coll?` and will preserve their type. 70 | 71 | For other combination of types the new value will be returned. 72 | 73 | If the newval has the metadata attribute `:replace` then it will 74 | replace the value regardless of the type." 75 | [curr newval] 76 | (cond 77 | (-> newval meta :replace) newval 78 | (and (map? curr) (map? newval)) (merge-with combine curr newval) 79 | (and (list? curr) (coll? newval)) (apply list (concat curr newval)) 80 | (and (vector? curr) (coll? newval)) (into curr newval) 81 | (and (set? curr) (coll? newval)) (into curr newval) 82 | :otherwise newval)) 83 | 84 | (defn is-protocol-exception? 85 | "Detects if given exception is a protocol exception." 86 | [exception] 87 | (= (:type (ex-data exception)) :protocol)) 88 | 89 | (defn protocol-exception 90 | "Creates new protocol exception" 91 | [msg] 92 | (ex-info msg 93 | {:type :protocol})) 94 | -------------------------------------------------------------------------------- /test/checkers.clj: -------------------------------------------------------------------------------- 1 | (ns checkers 2 | "contains midje checkers to test ring responses" 3 | (:use midje.sweet 4 | [clojure.string :only (lower-case)])) 5 | 6 | (defchecker ignore-case [expected] 7 | (fn [actual] (or (and (nil? actual) (nil? expected)) 8 | (= (lower-case actual) (lower-case expected))))) 9 | 10 | (defchecker is-status [code] 11 | (contains {:status code})) 12 | 13 | (defchecker body [expected] 14 | (contains {:body expected})) 15 | 16 | (defchecker no-body [] 17 | (fn [actual] (nil? (:body actual)))) 18 | 19 | (defchecker header-value [header expected] 20 | (contains {:headers (contains {header expected})})) 21 | 22 | (defchecker content-type [expected] 23 | (header-value "Content-Type" expected)) 24 | 25 | (def OK (is-status 200)) 26 | (def CREATED (is-status 201)) 27 | (def ACCEPTED (is-status 202)) 28 | (def NO-CONTENT (every-checker (is-status 204) (no-body))) 29 | 30 | (defn status-location [status location] 31 | (every-checker (is-status status) 32 | (header-value "Location" location))) 33 | 34 | (defn status-location [status location] 35 | (every-checker 36 | (is-status status) 37 | (header-value "Location" location))) 38 | 39 | (defn MOVED-PERMANENTLY [location] (status-location 301 location)) 40 | (defn SEE-OTHER [location] (status-location 303 location)) 41 | (def NOT-MODIFIED (is-status 304)) 42 | (defn MOVED-TEMPORARILY [location] (status-location 307 location)) 43 | 44 | (def NOT-FOUND (is-status 404)) 45 | (def CONFLICT (is-status 409)) 46 | (def GONE (is-status 410)) 47 | (def PRECONDITION-FAILED (is-status 412)) 48 | (def UNPROCESSABLE (is-status 422)) 49 | 50 | (def INTERNAL-SERVER-ERROR (is-status 500)) 51 | (def NOT-IMPLEMENTED (is-status 501)) 52 | -------------------------------------------------------------------------------- /test/test.clj: -------------------------------------------------------------------------------- 1 | (ns test 2 | (:use [liberator.core] 3 | [compojure.core :only [context ANY routes defroutes]] 4 | [hiccup.core] 5 | [ring.adapter.jetty] 6 | [ring.middleware.stacktrace :only (wrap-stacktrace)] 7 | [ring.middleware.reload :only (wrap-reload)]) 8 | 9 | (:import java.io.InputStreamReader) 10 | (:import [java.security MessageDigest])) 11 | 12 | 13 | 14 | (defn sha [text] 15 | (->> text 16 | .getBytes 17 | (.digest (MessageDigest/getInstance "SHA")) 18 | (map #(format "%02x" %)) 19 | (apply str))) 20 | 21 | (def products (ref [])) 22 | 23 | (defn has? [key val] 24 | #(when (= val (% key)) %)) 25 | 26 | (defn product-by-id [id] 27 | (some (has? :id id) @products)) 28 | 29 | (defn max-id [ps] 30 | (apply max (conj (map :id ps) 0))) 31 | 32 | (defn add-product [title] 33 | (dosync 34 | (let [next-id (inc (max-id @products))] 35 | (alter products #(conj % { :id next-id :title title })) 36 | next-id))) 37 | 38 | (defn remove-product-by-id [id] 39 | (dosync 40 | (let [oldps @products] 41 | (= oldps (alter products (fn [ps] (remove (has? :id id) ps))))))) 42 | 43 | (defn update-product-with-id [id title] 44 | (dosync 45 | (alter products (fn [ps] (conj (remove (has? :id id) ps) { :id id :title title}))))) 46 | 47 | (defn all-products [] @products) 48 | 49 | (def hello-resource 50 | (resource 51 | :to_html (fn [_ req _] 52 | (let [who (-> req :route-params :*)] 53 | (str "hello, " (if (empty? who) "stranger" who) "."))))) 54 | 55 | (def products-resource 56 | (resource 57 | :method-allowed? #(some #{(% :request-method)} [:get :post]) 58 | :content-types-provided { "text/html" :to_html, "text/plain" :to_text } 59 | :created (fn [_ req _] (str "Product " (add-product (slurp (:body req))) " created.")) 60 | :to_html (fn [_ req _] 61 | (html [:html 62 | [:head [:title "All Products"]] 63 | [:body [:h1 "All Products"] 64 | [:ul (map (fn [p] [:li [:a { :href (p :id)} (p :title)]]) 65 | (all-products))]]])) 66 | :to_text (fn [_ req _] 67 | (apply str (map #(str (% :id) ": " (% :title) "\n") (all-products)))))) 68 | 69 | (def product-resource 70 | (resource 71 | :method-allowed? #(some #{(% :request-method)} [:get :delete :put ]) 72 | :content-types-provided { "text/html" :to_html, "text/plain" :to_text } 73 | :exists? (fn [req] (if-let [id (read-string (-> req :route-params :id))] 74 | (if-let [product (product-by-id id)] 75 | { ::product product }) 76 | nil)) 77 | :conflict? (fn [req] (let [id (read-string (-> req :route-params :id))] 78 | (dosync 79 | (when (product-by-id id) 80 | (update-product-with-id id (slurp (:body req)))) 81 | false))) 82 | :etag (fn [req] (sha (str (-> req ::product :title)))) 83 | :delete-enacted? (fn [req] (remove-product-by-id (read-string (-> req :route-params :id)))) 84 | :to_html (fn [rmap req status] 85 | (let [product (req ::product)] 86 | (html [:h1 (product :id)] [:p (product :title)]))) 87 | :to_text (fn [rmap req status] 88 | (let [product (req ::product)] 89 | (str (product :id) ": " (product :title)))))) 90 | 91 | 92 | (defroutes my-app 93 | (ANY "/hello/*" hello-resource) 94 | (ANY "/products/" products-resource) 95 | (ANY "/products/:id" product-resource) 96 | (ANY "/echo/:foo" [] (resource 97 | :content-types-provided 98 | { "text/plain" 99 | (fn [_ req _] 100 | (with-out-str (clojure.pprint/pprint 101 | (dissoc req :servlet-request)))), 102 | "text/html" 103 | (fn [_ req _] 104 | (html [:pre 105 | (h (with-out-str (clojure.pprint/pprint 106 | (dissoc req :servlet-request))))]))})) 107 | (ANY "*" [] {:status 404 :body "Resource not found"})) 108 | 109 | (def handler 110 | (-> my-app 111 | wrap-reload 112 | wrap-stacktrace)) 113 | 114 | (defn main [] 115 | (do 116 | (run-jetty #'handler {:port 3000 :join? false}))) 117 | 118 | 119 | -------------------------------------------------------------------------------- /test/test_conditionals.clj: -------------------------------------------------------------------------------- 1 | (ns test-conditionals 2 | (:use [liberator.core :only [resource request-method-in 3 | with-console-logger]] 4 | midje.sweet 5 | checkers 6 | liberator.util 7 | [ring.mock.request :only [request header]])) 8 | 9 | (defn if-modified-since [req value] 10 | (header req "if-modified-since" value)) 11 | 12 | (defn if-unmodified-since [req value] 13 | (header req "if-unmodified-since" value)) 14 | 15 | (defn if-match [req value] 16 | (header req "if-match" (if (= "*" value) value (str "\"" value "\"")))) 17 | 18 | (defn if-none-match [req value] 19 | (header req "if-none-match" (if (= "*" value) value (str "\"" value "\"")))) 20 | 21 | 22 | ;; get requests 23 | 24 | (facts "get requests" 25 | (facts "if-modified-since true" 26 | (let [resp ((resource :exists? true 27 | :handle-ok "OK" 28 | :last-modified (as-date 1001)) 29 | (-> (request :get "/") 30 | (if-modified-since (http-date (as-date 1000)))))] 31 | (fact resp => OK) 32 | (fact resp => (body "OK")) 33 | (fact resp => (header-value "Last-Modified" (http-date (as-date 1000)))))) 34 | 35 | (facts "if-modified-since false" 36 | (let [resp ((resource :exists? true 37 | :last-modified (as-date 1000)) 38 | (-> (request :get "/") 39 | (if-modified-since (http-date (as-date 1000)))))] 40 | (fact resp => NOT-MODIFIED) 41 | (fact resp => (no-body)) 42 | (fact resp => (header-value "Last-Modified" (http-date (as-date 1000)))))) 43 | 44 | (facts "if-modified-since false due to missing last-modified" 45 | (let [resp ((resource :exists? true) 46 | (-> (request :get "/") 47 | (if-modified-since (http-date (as-date 1000)))))] 48 | (fact resp => OK) 49 | (fact resp => (body "OK")))) 50 | 51 | (facts "if-unmodified-since true" 52 | (let [resp ((resource :exists? true 53 | :last-modified (as-date 1000) 54 | :handle-precondition-failed "precondition failed") 55 | (-> (request :get "/") 56 | (if-unmodified-since (http-date (as-date 900)))))] 57 | (fact resp => PRECONDITION-FAILED) 58 | (fact resp => (body "precondition failed")))) 59 | 60 | (facts "if-unmodified-since false" 61 | (let [resp ((resource :exists? true 62 | :last-modified (as-date 1000) 63 | :handle-ok "OK") 64 | (-> (request :get "/") 65 | (if-unmodified-since (http-date (as-date 1000)))))] 66 | (fact resp => OK) 67 | (fact resp => (body "OK")))) 68 | 69 | (facts "if-match true" 70 | (let [resp ((resource :exists? true 71 | :etag (constantly "TAG1") 72 | :handle-ok "OK") 73 | (-> (request :get "/") 74 | (if-match "TAG1")))] 75 | (fact resp => OK) 76 | (fact resp => (body "OK")) 77 | (fact resp => (header-value "ETag" "\"TAG1\"")))) 78 | 79 | (facts "if-match false" 80 | (let [resp ((resource :exists? true 81 | :etag (constantly "TAG1") 82 | :handle-ok "OK") 83 | (-> (request :get "/") 84 | (if-match "TAG2")))] 85 | (fact resp => PRECONDITION-FAILED))) 86 | 87 | (facts "if-none-match true" 88 | (let [resp ((resource :exists? true 89 | :etag (constantly "TAG1") 90 | :handle-ok "OK") 91 | (-> (request :get "/") 92 | (if-none-match "TAG1")))] 93 | (fact resp => NOT-MODIFIED))) 94 | 95 | (facts "if-none-match false" 96 | (let [resp ((resource :exists? true 97 | :etag (constantly "TAG2") 98 | :handle-ok "T2") 99 | (-> (request :get "/") 100 | (if-none-match "TAG1")))] 101 | (fact resp => OK)))) 102 | 103 | 104 | ;; put and post requests 105 | (tabular 106 | (facts "conditional request for post and put" 107 | (facts "if-modified-since true" 108 | (let [resp ((resource :exists? true 109 | :method-allowed? (request-method-in ?method) 110 | :handle-created "CREATED" 111 | :last-modified (as-date 1001)) 112 | (-> (request ?method "/") 113 | (if-modified-since (http-date (as-date 1000)))))] 114 | (fact resp => CREATED) 115 | (fact resp => (body "CREATED")))) 116 | 117 | (facts "if-modified-since false" 118 | (let [resp ((resource :exists? true 119 | :method-allowed? (request-method-in ?method) 120 | :handle-not-modified "NM" 121 | :last-modified (as-date 100000)) 122 | (-> (request ?method "/") 123 | (if-modified-since (http-date (as-date 200000)))))] 124 | (fact resp => NOT-MODIFIED) 125 | (fact resp => (body "NM")))) 126 | 127 | (facts "if-unmodified-since false" 128 | (let [resp ((resource :exists? true 129 | :method-allowed? (request-method-in ?method) 130 | :handle-accepted "A" 131 | :last-modified (as-date 200000)) 132 | (-> (request ?method "/") 133 | (if-unmodified-since (http-date (as-date 100000)))))] 134 | (fact resp => PRECONDITION-FAILED))) 135 | 136 | (facts "if-unmodified-since true" 137 | (let [resp ((resource :exists? true 138 | :method-allowed? (request-method-in ?method) 139 | :handle-created "CREATED" 140 | :last-modified (as-date 100000)) 141 | (-> (request ?method "/") 142 | (if-unmodified-since (http-date (as-date 200000)))))] 143 | (fact resp => CREATED) 144 | (fact resp => (body "CREATED")))) 145 | 146 | (facts "if-unmodified-since with last-modified changes due do post" 147 | (let [resp ((resource :exists? true 148 | :method-allowed? (request-method-in ?method) 149 | :post! (fn [ctx] {::LM 1001}) 150 | :handle-created "CREATED" 151 | :last-modified (fn [ctx] (as-date (get ctx ::LM 1000)))) 152 | (-> (request ?method "/") 153 | (if-unmodified-since (http-date (as-date 1000)))))] 154 | (fact resp => CREATED) 155 | (fact resp => (body "CREATED")) 156 | (fact resp => (header-value "Last-Modified" (http-date (as-date 1001)))))) 157 | 158 | (facts "if-match true" 159 | (let [resp ((resource :exists? true 160 | :method-allowed? (request-method-in ?method) 161 | :handle-created "CREATED" 162 | :etag (constantly "TAG1")) 163 | (-> (request ?method "/") 164 | (if-match "TAG1")))] 165 | (fact resp => CREATED) 166 | (fact resp => (body "CREATED")))) 167 | 168 | (facts "if-match false" 169 | (let [resp ((resource :exists? true 170 | :method-allowed? (request-method-in ?method) 171 | :handle-precondition-failed "PF" 172 | :etag (constantly "TAG1")) 173 | (-> (request ?method "/") 174 | (if-match "TAG2")))] 175 | (fact resp => PRECONDITION-FAILED) 176 | (fact resp => (body "PF")))) 177 | 178 | (facts "if-none-match true" 179 | (let [resp ((resource :exists? true 180 | :method-allowed? (request-method-in ?method) 181 | :handle-created "CREATED" 182 | :etag (constantly "TAG1")) 183 | (-> (request ?method "/") 184 | (if-none-match "TAG1")))] 185 | (fact resp => PRECONDITION-FAILED))) 186 | 187 | (facts "if-none-match false" 188 | (let [resp ((resource :exists? true 189 | :method-allowed? (request-method-in ?method) 190 | :etag (constantly "TAG1")) 191 | (-> (request ?method "/") 192 | (if-none-match "TAG2")))] 193 | (fact resp => CREATED)))) 194 | 195 | ?method 196 | :put 197 | :post) 198 | 199 | 200 | 201 | (facts "if-match * false on unexisting" 202 | (tabular 203 | (let [resp ((resource :method-allowed? true 204 | :exists? false 205 | :etag (constantly "TAG1")) 206 | (-> (request ?method "/") 207 | (if-match "*")))] 208 | (fact resp => PRECONDITION-FAILED)) 209 | ?method 210 | :get 211 | :post 212 | :put 213 | :delete)) 214 | 215 | (facts "if-none-match * false on existing" 216 | (tabular 217 | (let [resp ((resource :method-allowed? true 218 | :exists? true 219 | :etag (constantly "TAG1")) 220 | (-> (request ?method "/") 221 | (if-none-match "*")))] 222 | (if (= ?method :get) 223 | (fact resp => NOT-MODIFIED) 224 | (fact resp => PRECONDITION-FAILED))) 225 | ?method 226 | :get 227 | :post 228 | :put 229 | :delete)) 230 | -------------------------------------------------------------------------------- /test/test_conneg.clj: -------------------------------------------------------------------------------- 1 | (ns test-conneg 2 | (:require [clojure.string :as string]) 3 | (:use liberator.conneg 4 | checkers 5 | midje.sweet)) 6 | 7 | (facts "charsets" 8 | (tabular (fact (best-allowed-charset accept available) => (ignore-case negotiated)) 9 | 10 | accept available negotiated 11 | 12 | "iso-8859-5, unicode-1-1;q=0.8" ["iso-8859-5" "unicode-1-1"] "iso-8859-5" 13 | 14 | "iso-8859-15;q=1, utf-8;q=0.8, utf-16;q=0.6, iso-8859-1;q=0.8" ["iso-8859-15" "utf-16"] "iso-8859-15" 15 | 16 | ;; p102: "The special value \"*\", if present in the Accept-Charset 17 | ;; field, matches every character set (including ISO-8859-1) which is 18 | ;; not mentioned elsewhere in the Accept-Charset field. If no \"*\" 19 | ;; is present in an Accept-Charset field, then all character sets not 20 | ;; explicitly mentioned get a quality value of 0, except for 21 | ;; ISO-8859-1, which gets a quality value of 1 if not explicitly 22 | ;; mentioned." 23 | 24 | ;; iso-8859-1 gets the highest score because there is no * so it gets a quality value of 1 25 | "iso-8859-15;q=0.6, utf-16;q=0.9" ["iso-8859-1" "iso-8859-15" "utf-16"] "iso-8859-1" 26 | 27 | ;; utf-16 gets the highest score because there is no * but iso-8859-1 is mentioned at a lower score 28 | "iso-8859-15;q=0.6, utf-16;q=0.9, iso-8859-1;q=0.1" ["iso-8859-1" "iso-8859-15" "utf-16"] "utf-16" 29 | 30 | "iso-8859-15;q=0.6, *;q=0.8, utf-16;q=0.9" ["iso-8859-15" "utf-16"] "utf-16" 31 | 32 | ;; ASCII should be returned because it matches *, which gives it a 0.8 score, higher than iso-8859-15 33 | "iso-8859-15;q=0.6, *;q=0.8, utf-16;q=0.9" ["iso-8859-15" "ASCII"] "ASCII" 34 | 35 | ;; iso-8859-1 is always available unless score set to 0 36 | "ascii;q=0.5" ["ascii" "ISO-8859-1"] "ISO-8859-1" 37 | 38 | ;; Nothing is returned because ASCII is gets a score of 0 39 | "iso-8859-15;q=0.6, utf-16;q=0.9" ["ASCII"] nil 40 | 41 | ;; test some exotic formatting variants, not complete, though. 42 | "iso-8859-15,\n\rASCII" ["ASCII"] "ASCII" 43 | 44 | ;; charset must be compared case insensitively 45 | "ASCII" ["ascii"] "ascii")) 46 | 47 | (facts "encoding negotiation" 48 | (tabular (fact (best-allowed-encoding accept available) => negotiated) 49 | accept available negotiated 50 | "compress;q=0.4, gzip;q=0.2" ["compress" "gzip"] "compress" 51 | "compress;q=0.4, gzip;q=0.8" ["compress" "gzip"] "gzip" 52 | "identity, compress;q=0.4, gzip;q=0.8" ["compress" "gzip"] "identity" 53 | "compress" ["gzip"] "identity" 54 | "identity" ["gzip"] "identity" 55 | "identity;q=0, bzip;q=0.1" ["gzip"] nil 56 | "*;q=0, bzip;q=0.1" ["gzip"] nil 57 | "*;q=0, identity;q=0.1" ["gzip"] "identity")) 58 | 59 | ;; Language negotiation (14.4) 60 | (facts "encoding language" 61 | (tabular (fact (best-allowed-language accept available) => negotiated) 62 | ;; 14.4 Accept-Language 63 | 64 | ;; 14.12 Content-Language (p118) 65 | 66 | ;; p103 :- 67 | ;; Accept-Language: da, en-gb;q=0.8, en;q=0.7 68 | ;; 69 | ;; would mean: "I prefer Danish, but will accept British English and 70 | ;; other types of English." A language-range matches a language-tag if 71 | ;; it exactly equals the tag... 72 | 73 | accept available negotiated 74 | "da, en-gb;q=0.8, en;q=0.7" #{"da" "en-gb" "en"} "da" 75 | "da, en-gb;q=0.8, en;q=0.7" #{"en-gb" "en"} "en-gb" 76 | 77 | ;; ... or if it exactly equals a prefix of the tag such that the first tag 78 | ;; character following the prefix is "-". 79 | "da, en-gb;q=0.8, en;q=0.7" #{"en"} "en" 80 | "da, en-gb;q=0.8" #{"en-cockney"} nil 81 | "da, en-gb;q=0.8, en;q=0.7" #{"en-cockney"} "en-cockney" ; at q=0.7 82 | 83 | ;; TODO 84 | ;; The special range "*", if present in the Accept-Language field, 85 | ;; matches every tag not matched by any other range present in the 86 | ;; Accept-Language field. 87 | 88 | 89 | ;; Multiple languages MAY be 90 | ;; listed for content that is intended for multiple audiences. For 91 | ;; example, a rendition of the "Treaty of Waitangi," presented 92 | ;; simultaneously in the original Maori and English versions, would 93 | ;; call for 94 | ;; 95 | ;; Content-Language: mi, en 96 | "da, mi;q=0.8" #{["mi" "en"]} ["mi" "en"])) -------------------------------------------------------------------------------- /test/test_defresource.clj: -------------------------------------------------------------------------------- 1 | (ns test-defresource 2 | (:require [midje.sweet :refer [facts fact]] 3 | [liberator.core :refer [defresource resource]] 4 | [ring.mock.request :refer [request header]])) 5 | 6 | (defmulti with-multimethod* identity) 7 | 8 | (defmethod with-multimethod* :default [_] 9 | "with-multimethod") 10 | 11 | (defresource with-multimethod 12 | :handle-ok with-multimethod*) 13 | 14 | (defmulti with-service-available?-multimethod* 15 | (comp :service-available? :request)) 16 | 17 | (defmethod with-service-available?-multimethod* :available [_] true) 18 | 19 | (defmethod with-service-available?-multimethod* :not-available [_] false) 20 | 21 | (defresource with-decisions-multimethod 22 | :service-available? with-service-available?-multimethod* 23 | :handle-ok (fn [_] "with-service-available?-multimethod")) 24 | 25 | (defresource with-docstring 26 | "This is a fancy docstring." 27 | :handle-ok (fn [_] "OK")) 28 | 29 | (defresource without-param 30 | :handle-ok (fn [_] (format "The text is %s" "test"))) 31 | 32 | (defresource parameter [txt] 33 | :handle-ok (fn [_] (format "The text is %s" txt)) 34 | :available-media-types ["application/xml"]) 35 | 36 | (def standard-config 37 | {:available-media-types ["application/json"]}) 38 | 39 | (defresource with-options 40 | standard-config 41 | :handle-ok (fn [_] (format "The text is %s" "this"))) 42 | 43 | (defresource with-options-and-params [txt] 44 | standard-config 45 | :handle-ok (fn [_] (format "The text is %s" txt)) 46 | :available-media-types ["application/xml"]) ;; this actually overrides the standard-config 47 | 48 | (defresource with-options-only 49 | standard-config) 50 | 51 | (defn parametrized-config 52 | [media-type] 53 | {:available-media-types [media-type]}) 54 | 55 | (defresource with-options-parametrized-config [media-type txt] 56 | (parametrized-config media-type) 57 | :handle-ok (fn [_] (format "The text is %s" txt))) 58 | 59 | (defresource non-anamorphic-request [request] 60 | :handle-ok (str request)) 61 | 62 | (facts "about defresource" 63 | (fact "a docstring can be optionally provided" 64 | (with-docstring {:request-method :get}) 65 | => {:headers {"Content-Type" "text/plain;charset=UTF-8"}, :body "OK", :status 200}) 66 | (fact "its simple form should behave as it always has" 67 | (without-param {:request-method :get}) 68 | => {:headers {"Content-Type" "text/plain;charset=UTF-8"}, :body "The text is test", :status 200} 69 | ((parameter "a test") {:request-method :get}) 70 | => {:headers {"Vary" "Accept", "Content-Type" "application/xml;charset=UTF-8"}, :body "The text is a test", :status 200}) 71 | (fact "when provided a standard config, it should add this to the keyword list" 72 | (with-options {:request-method :get}) 73 | => {:headers {"Vary" "Accept", "Content-Type" "application/json;charset=UTF-8"}, :body "The text is this", :status 200} 74 | ((with-options-and-params "something") {:request-method :get}) 75 | => {:headers {"Vary" "Accept", "Content-Type" "application/xml;charset=UTF-8"}, :body "The text is something", :status 200}) 76 | (fact "it should also work with a function providing the standard config" 77 | ((with-options-parametrized-config "application/json" "a poem") {:request-method :get}) 78 | => {:headers {"Vary" "Accept", "Content-Type" "application/json;charset=UTF-8"}, :body "The text is a poem", :status 200}) 79 | (fact "it should work with only a standard config" 80 | (with-options-only {:request-method :get}) 81 | => {:headers {"Vary" "Accept", "Content-Type" "application/json;charset=UTF-8"}, :body "OK", :status 200}) 82 | (fact "should allow multi methods as handlers" 83 | (with-multimethod {:request-method :get}) 84 | => {:headers {"Content-Type" "text/plain;charset=UTF-8"}, :body "with-multimethod", :status 200}) 85 | (fact "should allow multi methods as decisions" 86 | (with-decisions-multimethod {:request-method :get :service-available? :available}) 87 | => {:headers {"Content-Type" "text/plain;charset=UTF-8"}, :body "with-service-available?-multimethod", :status 200}) 88 | (fact "should allow multi methods as decisions alternate path" 89 | (with-decisions-multimethod {:request-method :get :service-available? :not-available}) 90 | => {:headers {"Content-Type" "text/plain;charset=UTF-8"}, :body "Service not available.", :status 503}) 91 | (fact "should allow 'request' to be used as a resource parameter name, this was a bug at a time." 92 | (:body ((non-anamorphic-request "test") {:request-method :get})) 93 | => "test")) 94 | 95 | 96 | (def fn-with-options 97 | (resource 98 | standard-config 99 | :handle-ok (fn [_] (format "The text is %s" "this")))) 100 | 101 | (def fn-with-options-only 102 | (resource 103 | standard-config)) 104 | 105 | (def fn-with-options-and-parametrized-config 106 | (resource 107 | (parametrized-config "application/json") 108 | :handle-ok (fn [_] (format "The text is %s" "this")))) 109 | 110 | (facts "using resource function" 111 | (fact "when provided a standard config, it should add this to the keyword list" 112 | (fn-with-options {:request-method :get}) 113 | => {:headers {"Vary" "Accept", "Content-Type" "application/json;charset=UTF-8"}, :body "The text is this", :status 200} 114 | (fn-with-options-and-parametrized-config {:request-method :get}) 115 | => {:headers {"Vary" "Accept", "Content-Type" "application/json;charset=UTF-8"}, :body "The text is this", :status 200}) 116 | (fn-with-options-only {:request-method :get}) 117 | => {:headers {"Vary" "Accept", "Content-Type" "application/json;charset=UTF-8"}, :body "OK", :status 200}) 118 | -------------------------------------------------------------------------------- /test/test_errors.clj: -------------------------------------------------------------------------------- 1 | (ns test-errors 2 | (:use liberator.core 3 | [liberator.representation :only [ring-response]] 4 | midje.sweet 5 | checkers 6 | [ring.mock.request :only [request header]])) 7 | 8 | (facts "default exception handler rethrows exception" 9 | (fact ((resource :exists? (fn [_] (throw (RuntimeException. "test")))) 10 | (request :get "/")) => (throws RuntimeException "test"))) 11 | 12 | (facts "custom exception handler is invoked" 13 | (let [resp ((resource :exists? (fn [_] (throw (RuntimeException. "foo"))) 14 | :handle-exception (fn [{ex :exception}] 15 | (str "error: " (.getMessage ex)))) 16 | (request :get "/"))] 17 | (fact resp => INTERNAL-SERVER-ERROR) 18 | (fact resp => (body #"error: foo")))) 19 | 20 | (facts "custom exception handler can return ring response" 21 | (let [resp ((resource :exists? (fn [_] (throw (RuntimeException. "foo"))) 22 | :handle-exception (fn [_] 23 | (ring-response {:status 555 :body "bar"}))) 24 | (request :get "/"))] 25 | (fact resp => (is-status 555)) 26 | (fact resp => (body "bar")))) 27 | 28 | (facts "custom exception handler is converted to response" 29 | (let [resp ((resource :available-media-types ["application/edn"] 30 | :exists? (fn [_] (throw (RuntimeException. "foo"))) 31 | :handle-exception "baz") 32 | (request :get "/"))] 33 | (fact resp => INTERNAL-SERVER-ERROR) 34 | (fact resp => (body "baz")) 35 | (fact resp => (content-type #"application/edn;charset=.*")))) 36 | 37 | (facts "custom exception handler content-type is negotiated" 38 | (let [resp ((resource :available-media-types ["application/edn" "text/plain"] 39 | :exists? (fn [_] (throw (RuntimeException. "foo"))) 40 | :handle-exception "baz") 41 | (-> (request :get "/") 42 | (header "Accept" "text/plain")))] 43 | (fact resp => INTERNAL-SERVER-ERROR) 44 | (fact resp => (body "baz")) 45 | (fact resp => (content-type #"text/plain;charset=.*")))) 46 | 47 | (facts "custom exception handler content-type is not negotiated prior to media-type-available? and defaults to text/plain" 48 | (let [resp ((resource :available-media-types ["application/edn" "foo/bar"] 49 | :service-available? (fn [_] (throw (RuntimeException. "foo"))) 50 | :handle-exception "baz") 51 | (-> (request :get "/") 52 | (header "Accept" "text/plain")))] 53 | (fact resp => INTERNAL-SERVER-ERROR) 54 | (fact resp => (body "baz")) 55 | (fact resp => (content-type #"text/plain;charset=.*")))) 56 | 57 | (facts "custom exception handler not invoked if handler throws exception" 58 | (let [res (resource :service-available? (fn [_] (throw (RuntimeException. "error in service-available"))) 59 | :handle-exception (fn [_] (throw (RuntimeException. "error in handle-exception"))))] 60 | (fact (res (-> (request :get "/") 61 | (header "Accept" "text/plain"))) => (throws #"handle-exception")))) 62 | -------------------------------------------------------------------------------- /test/test_execution_model.clj: -------------------------------------------------------------------------------- 1 | (ns test-execution-model 2 | (:use 3 | midje.sweet 4 | [ring.mock.request :only [request header]] 5 | [liberator.core :only [defresource resource]] 6 | [liberator.representation :only [ring-response]])) 7 | 8 | 9 | (facts "truethy return values" 10 | (fact (-> (request :get "/") 11 | ((resource :exists? true))) 12 | => (contains {:status 200})) 13 | (fact (-> (request :get "/") 14 | ((resource :exists? 1))) 15 | => (contains {:status 200})) 16 | (fact "map merged with context" 17 | (-> (request :get "/") 18 | ((resource :exists? {:a 1} 19 | :handle-ok #(ring-response %)))) 20 | => (contains {:a 1})) 21 | (fact "vector and map merged with context" 22 | (-> (request :get "/") 23 | ((resource :exists? [true {:a 1}] 24 | :handle-ok #(ring-response %)))) 25 | => (contains {:a 1 :status 200})) 26 | (fact "vector concated to context value" 27 | (-> (request :get "/") 28 | ((resource :service-available? {:a [1]} 29 | :exists? {:a [2]} 30 | :handle-ok #(ring-response %)))) 31 | => (contains {:a [1 2] :status 200})) 32 | (fact "function returned as context is evaluated" 33 | (-> (request :get "/") 34 | ((resource :service-available? {:a [1]} 35 | :exists? (fn [ctx] #(assoc ctx :a [2])) 36 | :handle-ok #(ring-response %)))) 37 | => (contains {:a [2] :status 200}))) 38 | 39 | (facts "falsey return values" 40 | (fact (-> (request :get "/") 41 | ((resource :exists? false))) 42 | => (contains {:status 404})) 43 | (fact (-> (request :get "/") 44 | ((resource :exists? nil))) 45 | => (contains {:status 404})) 46 | (fact "vector and map merged with context" 47 | (-> (request :get "/") 48 | ((resource :exists? [false {:a 1}] 49 | :handle-not-found #(ring-response %)))) 50 | => (contains {:a 1 :status 404}))) 51 | 52 | (facts "handler functions" 53 | (fact "handler is a function" 54 | (-> (request :get "/") 55 | ((resource :exists? false 56 | :handle-not-found (fn [ctx] "not found")))) 57 | => (contains {:status 404 :body "not found"})) 58 | (fact "keyword as handler" 59 | (-> (request :get "/") 60 | ((resource :exists? {:some-key "foo"} 61 | :handle-ok :some-key))) 62 | => (contains {:status 200 :body "foo"})) 63 | (fact "default handler uses message key" 64 | (-> (request :get "/") 65 | ((resource :exists? [false {:message "absent"}]))) 66 | => (contains {:status 404 :body "absent"})) 67 | (fact "decisions can override status" 68 | (-> (request :get "/") 69 | ((resource :exists? [false {:status 444 :message "user defined status code"}]))) 70 | => (contains {:status 444 :body "user defined status code"}))) 71 | 72 | (facts "context merge leaves nested objects intact (see #206)" 73 | (fact "using etag and if-match" 74 | (-> (request :put "/") 75 | (header "if-match" "\"1\"") 76 | ((resource :allowed-methods [:put] 77 | :available-media-types ["application/edn"] 78 | :malformed? [false {:my-entity {:deeply [:nested :object]}}] 79 | :handle-created :my-entity 80 | :etag "1"))) 81 | => (contains {:status 201, :body "{:deeply [:nested :object]}"})) 82 | (fact "using if-unmodified-since" 83 | (-> (request :put "/") 84 | (header "if-unmodified-since" "Tue, 15 Nov 1994 12:45:26 GMT") 85 | ((resource :allowed-methods [:put] 86 | :available-media-types ["application/edn"] 87 | :malformed? [false {:my-entity {:deeply [:nested :object]}}] 88 | :handle-created :my-entity 89 | :last-modified (java.util.Date. 0)))) 90 | => (contains {:status 201, :body "{:deeply [:nested :object]}"}))) 91 | -------------------------------------------------------------------------------- /test/test_flow.clj: -------------------------------------------------------------------------------- 1 | (ns test-flow 2 | (:use liberator.core 3 | [liberator.representation :only (ring-response)] 4 | midje.sweet 5 | checkers 6 | [ring.mock.request :only [request header]])) 7 | 8 | (facts "customize the initial context" 9 | (let [resp ((resource :initialize-context {::field "some initial context"} 10 | :handle-ok ::field) (request :get "/"))] 11 | (fact resp => (body "some initial context")))) 12 | 13 | (facts "GET Requests" 14 | (facts "get existing resource" 15 | (let [resp ((resource :exists? true :handle-ok "OK") (request :get "/"))] 16 | (fact resp => OK) 17 | (fact resp => (body "OK")))) 18 | 19 | (facts "get unexisting resource" 20 | (let [resp ((resource :exists? false :handle-not-found "NOT-FOUND") (request :get "/"))] 21 | (fact resp => NOT-FOUND) 22 | (fact resp => (body "NOT-FOUND")))) 23 | 24 | (facts "get on moved temporarily" 25 | (let [resp ((resource :exists? false 26 | :existed? true 27 | :moved-temporarily? {:location "http://new.example.com/"}) 28 | (request :get "/"))] 29 | (fact resp => (MOVED-TEMPORARILY "http://new.example.com/")))) 30 | 31 | (facts "get on moved temporarily with custom handler" 32 | (let [resp ((resource :exists? false 33 | :existed? true 34 | :moved-temporarily? {:location "http://new.example.com/"} 35 | :handle-moved-temporarily "Temporary redirection...") 36 | (request :get "/"))] 37 | (fact resp => (MOVED-TEMPORARILY "http://new.example.com/")) 38 | (fact resp => (body "Temporary redirection...")))) 39 | 40 | (facts "get on moved permantently" 41 | (let [resp ((resource :exists? false :existed? true 42 | :moved-permanently? true 43 | :location "http://other.example.com/") 44 | (request :get "/"))] 45 | (fact resp => (MOVED-PERMANENTLY "http://other.example.com/")))) 46 | 47 | (facts "get on moved permantently with custom response" 48 | (let [resp ((resource :exists? false :existed? true 49 | :moved-permanently? {:location "http://other.example.com/"} 50 | :handle-moved-permanently "Not here, there!") 51 | (request :get "/"))] 52 | (fact resp => (MOVED-PERMANENTLY "http://other.example.com/")) 53 | (fact resp => (body "Not here, there!")))) 54 | 55 | (facts "get on moved permantently with custom response and explicit header" 56 | (let [resp ((resource :exists? false :existed? true 57 | :moved-permanently? true 58 | :handle-moved-permanently (ring-response {:body "Not here, there!" 59 | :headers {"Location" "http://other.example.com/"}})) 60 | (request :get "/"))] 61 | (fact resp => (MOVED-PERMANENTLY "http://other.example.com/")) 62 | (fact resp => (body "Not here, there!")))) 63 | 64 | (facts "get on moved permantently with automatic response" 65 | (let [resp ((resource :exists? false :existed? true 66 | :moved-permanently? true 67 | :location "http://other.example.com/") 68 | (request :get "/"))] 69 | (fact resp => (MOVED-PERMANENTLY "http://other.example.com/"))))) 70 | 71 | (facts "POST Requests" 72 | (let [r (resource :allowed-methods [:post] 73 | :exists? true 74 | :handle-created "Created") 75 | resp (r (request :post "/"))] 76 | (fact "Post to existing" resp => CREATED) 77 | (fact "Body of 201" resp => (body "Created"))) 78 | 79 | (let [r (resource :allowed-methods [:post] 80 | :exists? true 81 | :post-enacted? true 82 | :post-redirect? {:location "http://example.com/foo"}) 83 | resp (r (request :post "/"))] 84 | (fact "Post completed to existing resource and redirect" resp => (SEE-OTHER "http://example.com/foo"))) 85 | 86 | (let [r (resource :allowed-methods [:post] 87 | :exists? true 88 | :post-enacted? true) 89 | resp (r (request :post "/"))] 90 | (fact "Post completed to existing resource" resp => CREATED)) 91 | 92 | (let [r (resource :allowed-methods [:post] 93 | :exists? true 94 | :post-enacted? true 95 | :new? false 96 | :respond-with-entity? false) 97 | resp (r (request :post "/"))] 98 | (fact "Post completed to existing resource with new? and respond-with-entity? as false" resp => NO-CONTENT)) 99 | 100 | (let [r (resource :allowed-methods [:post] 101 | :exists? true 102 | :post-enacted? false) 103 | resp (r (request :post "/"))] 104 | (fact "Post in progress to existing resource" resp => ACCEPTED)) 105 | 106 | (let [r (resource :allowed-methods [:post] 107 | :exists? true 108 | :conflict? true) 109 | resp (r (request :post "/"))] 110 | (fact "Post to existing with conflict" resp => CONFLICT)) 111 | 112 | (let [r (resource :allowed-methods [:post] 113 | :exists? true 114 | :post-redirect? {:location "http://example.com/foo"}) 115 | resp (r (request :post "/")) ] 116 | (fact "Post to existing resource and redirect" resp => (SEE-OTHER "http://example.com/foo"))) 117 | 118 | (let [r (resource :allowed-methods [:post] 119 | :exists? false 120 | :post-redirect? true 121 | :can-post-to-missing? true 122 | :location "http://example.com/foo") 123 | resp (r (request :post "/")) ] 124 | (fact "Post to missing can redirect" resp => (SEE-OTHER "http://example.com/foo"))) 125 | 126 | (let [r (resource :allowed-methods [:post] 127 | :exists? false 128 | :location "foo" 129 | :can-post-to-missing? true) 130 | resp (r (request :post "/")) ] 131 | (fact "Post to missing if post to missing is allowed" resp => CREATED) 132 | (fact "Location is set" resp => (contains {:headers (contains {"Location" "foo"})}))) 133 | 134 | (let [r (resource :allowed-methods [:post] 135 | :exists? false 136 | :can-post-to-missing? false 137 | :handle-not-found "not-found") 138 | resp (r (request :post "/")) ] 139 | (fact "Post to missing can give 404" resp => NOT-FOUND) 140 | (fact "Body of 404" resp => (body "not-found"))) 141 | 142 | (let [r (resource :allowed-methods [:post] 143 | :exists? true 144 | :can-post-to-missing? false) 145 | resp (r (request :post "/")) ] 146 | (fact "Post to existing if post to missing forbidden is allowed" resp => CREATED))) 147 | 148 | (facts "PUT requests" 149 | (let [r (resource :allowed-methods [:put] 150 | :exists? false 151 | :can-put-to-missing? false) 152 | resp (r (request :put "/"))] 153 | (fact "Put to missing can give 501" resp => NOT-IMPLEMENTED)) 154 | 155 | (let [r (resource :allowed-methods [:put] 156 | :exists? false 157 | :can-put-to-missing? true) 158 | resp (r (request :put "/"))] 159 | (fact "Put to missing can give 201" resp => CREATED)) 160 | 161 | (let [r (resource :allowed-methods [:put] 162 | :exists? true 163 | :conflict? true) 164 | resp (r (request :put "/"))] 165 | (fact "Put to existing with conflict" resp => CONFLICT)) 166 | 167 | (let [r (resource :allowed-methods [:put] 168 | :processable? false) 169 | resp (r (request :put "/"))] 170 | (fact "Unprocessable can give 422" resp => UNPROCESSABLE)) 171 | 172 | (let [r (resource :allowed-methods [:put] 173 | :exists? true 174 | :put-enacted? true) 175 | resp (r (request :put "/"))] 176 | (fact "Put to existing completed" resp => CREATED)) 177 | 178 | (let [r (resource :allowed-methods [:put] 179 | :exists? true 180 | :put-enacted? true 181 | :new? false 182 | :respond-with-entity? false) 183 | resp (r (request :put "/"))] 184 | (fact "Put to existing resource with new? and respond-with-entity? as false" resp => NO-CONTENT)) 185 | 186 | (let [r (resource :allowed-methods [:put] 187 | :exists? true 188 | :put-enacted? false) 189 | resp (r (request :put "/"))] 190 | (fact "Put in progress to existing resource" resp => ACCEPTED))) 191 | 192 | (facts "HEAD requests" 193 | (facts "on existing resource" 194 | (let [resp ((resource :exists? true :handle-ok "OK") (request :head "/"))] 195 | (fact resp => OK) 196 | (fact resp => (content-type "text/plain;charset=UTF-8")) 197 | (fact resp => (no-body)))) 198 | 199 | (facts "unexisting resource" 200 | (let [resp ((resource :exists? false :handle-not-found "NOT-FOUND") (request :head "/"))] 201 | (fact resp => NOT-FOUND) 202 | (fact resp => (no-body)))) 203 | 204 | (facts "on moved temporarily" 205 | (let [resp ((resource :exists? false 206 | :existed? true 207 | :moved-temporarily? true 208 | :location "http://new.example.com/") 209 | (request :get "/"))] 210 | (fact resp => (MOVED-TEMPORARILY "http://new.example.com/")) 211 | (fact resp => (no-body))))) 212 | -------------------------------------------------------------------------------- /test/test_get_put.clj: -------------------------------------------------------------------------------- 1 | (ns test-get-put 2 | (:use liberator.core 3 | midje.sweet 4 | checkers 5 | [ring.mock.request :only [request header]])) 6 | 7 | ;; tests for a resource where you can put something and get 8 | ;; it back later. Will use the content-type of the PUT body 9 | ;; Generates last-modified header for conditional requests. 10 | 11 | (def things (ref nil)) 12 | 13 | (def thing-resource 14 | (resource 15 | ;; early lookup 16 | :service-available? (fn [ctx] {::r (get @things (get-in ctx [:request :uri]))}) 17 | :method-allowed? (request-method-in :get :put :delete) 18 | ;; lookup media types of the requested resource 19 | :available-media-types #(if-let [m (get-in % [::r :media-type])] [m]) 20 | ;; the resource exists if a value is stored in @things at the uri 21 | ;; store the looked up value at key ::r in the context 22 | :exists? ::r 23 | ;; ...it existed if the stored value is nil (and not some random 24 | ;; Objeced we use as a setinel) 25 | :existed? #(nil? (get @things (get-in % [:request :uri]) (Object.))) 26 | ;; use the previously stored value at ::r 27 | :handle-ok #(get-in % [::r :content]) 28 | ;; update the representation 29 | :put! #(dosync 30 | (alter things assoc-in 31 | [(get-in % [:request :uri])] 32 | {:content (get-in % [:request :body]) 33 | :media-type (get-in % [:request :headers "content-type"] 34 | "application/octet-stream") 35 | :last-modified (java.util.Date. (long 1e9))})) 36 | ;; ...store a nil value to marke the resource as gone 37 | :delete! #(dosync (alter things assoc (get-in % [:request :uri]) nil)) 38 | :last-modified #(get-in % [::r :last-modified]))) 39 | 40 | (facts 41 | (let [resp (thing-resource (request :get "/r1"))] 42 | (fact "get => 404" resp => NOT-FOUND)) 43 | (let [resp (thing-resource (-> (request :put "/r1") 44 | (assoc :body "r1") 45 | (header "content-type" "text/plain")))] 46 | (fact "put => 201" resp => CREATED)) 47 | (let [resp (thing-resource (-> (request :get "/r1")))] 48 | (fact "get => 200" resp => OK) 49 | (fact "get body is what was put before" 50 | resp => (body "r1")) 51 | (fact "content type is set correcty" 52 | resp => (content-type "text/plain;charset=UTF-8")) 53 | (fact "last-modified header is set" 54 | resp => (header-value "Last-Modified" "Mon, 12 Jan 1970 13:46:40 GMT"))) 55 | (let [resp (thing-resource (-> (request :delete "/r1")))] 56 | (fact "delete" resp => NO-CONTENT)) 57 | (let [resp (thing-resource (request :get "/r1"))] 58 | (fact "get => gone" resp => GONE))) 59 | -------------------------------------------------------------------------------- /test/test_get_put_patch.clj: -------------------------------------------------------------------------------- 1 | (ns test-get-put-patch 2 | (:use liberator.core 3 | midje.sweet 4 | checkers 5 | [ring.mock.request :only [request header]])) 6 | 7 | ;; tests for a resource where you can put something and get 8 | ;; it back later. Will use the content-type of the PUT body 9 | ;; Generates last-modified header for conditional requests. 10 | 11 | (def things (atom nil)) 12 | 13 | (def thing-resource 14 | (resource 15 | :allowed-methods [:delete :get :head :options :patch :put] 16 | ;; early lookup 17 | :service-available? (fn [ctx] {::r (get @things (get-in ctx [:request :uri]))}) 18 | ;; lookup media types of the requested resource 19 | :available-media-types #(if-let [m (get-in % [::r :media-type])] [m]) 20 | ;; the resource exists if a value is stored in @things at the uri 21 | ;; store the looked up value at key ::r in the context 22 | :exists? ::r 23 | ;; ...it existed if the stored value is nil (and not some random 24 | ;; Objeced we use as a setinel) 25 | :existed? #(nil? (get @things (get-in % [:request :uri]) (Object.))) 26 | ;; use the previously stored value at ::r 27 | :handle-ok #(get-in % [::r :content]) 28 | ;; special switch to test `:patch-enacted?` 29 | :patch-enacted? #(not (-> % :request ::delay)) 30 | ;; update the representation 31 | :patch! #(swap! things assoc-in 32 | [(get-in % [:request :uri])] 33 | {:content (get-in % [:request :body]) 34 | :media-type "text/plain" 35 | :last-modified (java.util.Date.)}) 36 | :patch-content-types ["application/example"] 37 | :put! #(swap! things assoc-in 38 | [(get-in % [:request :uri])] 39 | {:content (get-in % [:request :body]) 40 | :media-type (get-in % [:request :headers "content-type"] 41 | "application/octet-stream") 42 | :last-modified (java.util.Date.)}) 43 | ;; ...store a nil value to marke the resource as gone 44 | :delete! #(swap! things assoc (get-in % [:request :uri]) nil) 45 | :last-modified #(get-in % [::r :last-modified]))) 46 | 47 | (facts 48 | (let [resp (thing-resource (request :get "/r1"))] 49 | (fact "get => 404" resp => NOT-FOUND)) 50 | (let [resp (thing-resource (-> (request :put "/r1") 51 | (assoc :body "r1") 52 | (header "content-type" "text/plain")))] 53 | (fact "put => 201" resp => CREATED)) 54 | (let [resp (thing-resource (-> (request :get "/r1")))] 55 | (fact "get => 200" resp => OK) 56 | (fact "get body is what was put before" 57 | resp => (body "r1")) 58 | (fact "content type is set correctly" 59 | resp => (content-type "text/plain;charset=UTF-8")) 60 | (fact "last-modified header is set" 61 | (nil? (get (:headers resp) "Last-Modified")) => false)) 62 | (let [resp (thing-resource (-> (request :options "/r1")))] 63 | (fact "allowed patch content types" 64 | (get (:headers resp) "Accept-Patch") => "application/example") 65 | (fact "expected options response - Allow header" 66 | (get (:headers resp) "Allow") => "DELETE, GET, HEAD, OPTIONS, PATCH, PUT") 67 | (fact "get => 200" resp => OK) 68 | (fact "last-modified header is set" 69 | (nil? (get (:headers resp) "Last-Modified")) => false)) 70 | (let [resp (thing-resource (-> (request :patch "/r1") 71 | (assoc :body "Some patch implementation.") 72 | (header "content-type" "application/example")))] 73 | (fact "put => 204" resp => NO-CONTENT)) 74 | (let [resp (thing-resource (-> (request :patch "/r1") 75 | (assoc ::delay true) 76 | (assoc :body "Some patch implementation.") 77 | (header "content-type" "application/example")))] 78 | (fact "put => 202" resp => ACCEPTED)) 79 | (let [resp (thing-resource (-> (request :get "/r1")))] 80 | (fact "get => 200" resp => OK) 81 | (fact "get body is what was patched in" 82 | resp => (body "Some patch implementation.")) 83 | (fact "content type is set correctly" 84 | resp => (content-type "text/plain;charset=UTF-8")) 85 | (fact "last-modified header is set" 86 | (nil? (get (:headers resp) "Last-Modified")) => false)) 87 | (let [resp (thing-resource (-> (request :delete "/r1")))] 88 | (fact "delete" resp => NO-CONTENT)) 89 | (let [resp (thing-resource (request :get "/r1"))] 90 | (fact "get => gone" resp => GONE))) 91 | -------------------------------------------------------------------------------- /test/test_handler_context.clj: -------------------------------------------------------------------------------- 1 | (ns test-handler-context 2 | (:use 3 | midje.sweet 4 | [ring.mock.request :only [request header]] 5 | [liberator.core :only [defresource resource]] 6 | [liberator.representation :only [ring-response]])) 7 | 8 | (defn ^:private negotiate [header-key resource-key representation-key available accepted] 9 | (-> (request :get "") 10 | (#(if accepted (header % header-key accepted) %)) 11 | ((resource resource-key available 12 | :handle-ok (fn [{representation :representation}] 13 | (representation representation-key)))) 14 | ((fn [resp] (if (= 200 (:status resp)) 15 | (:body resp) 16 | (:status resp)))))) 17 | 18 | (facts "Single header negotiation" 19 | (facts "Media type negotitation" 20 | (tabular 21 | (negotiate "Accept" :available-media-types :media-type ?available ?accepted) => ?negotiated 22 | ?available ?accepted ?negotiated 23 | [] "text/html" 406 24 | ["text/html" "text/plain"] nil "text/html" 25 | ["text/html"] "text/html" "text/html" 26 | ["text/html" "text/plain"] "text/html" "text/html" 27 | ["text/html" "text/plain"] "text/html,text/foo" "text/html" 28 | ["text/html" "text/plain"] "text/html;q=0.1,text/plain" "text/plain" 29 | ["text/html" "text/plain"] "text/html;q=0.3,text/plain;q=0.2" "text/html")) 30 | 31 | (facts "Language negotitation" 32 | (facts "Only primary tag" 33 | (tabular 34 | (negotiate "Accept-Language" :available-languages :language ?available ?accepted) => ?negotiated 35 | ?available ?accepted ?negotiated 36 | [] "en" 406 37 | ["en"] "en;q=garbage" "en" 38 | ["en"] "en;q=" "en" 39 | ["en"] "en" "en" 40 | ["en" "de"] "en;q=garabage,de;q=0.8" "de" 41 | ["en" "de"] "de" "de" 42 | ["en" "de"] "de,fr" "de" 43 | ["en" "de"] "de;q=0.1,en" "en" 44 | ["en" "de"] "de;q=0.3,en;q=0.2;fr=0.9;la" "de" 45 | ["en" "de"] "de;q=0.3,en;q=0.2;fr=0.9;la" "de")) 46 | 47 | (future-facts "with subtag" 48 | (tabular 49 | (negotiate "Accept-Language" :available-languages :language ?available ?accepted) => ?negotiated 50 | ?available ?accepted ?negotiated 51 | [] "en-GB" 406 52 | ["en"] "en-GB" "en" 53 | ["en-GB" "de"] "de" "de" 54 | ["en" "de-AT"] "de,fr" "de" 55 | ["en-US" "de"] "de;q=0.1,en" "en" 56 | ["en-US" "en-GB"] "en-US" "en-US" 57 | ["en-US" "en-GB"] "en" "en"))) 58 | 59 | 60 | (facts "Charset negotitation" 61 | (tabular 62 | (negotiate "Accept-Charset" :available-charsets :charset ?available ?accepted) => ?negotiated 63 | ?available ?accepted ?negotiated 64 | [] "ascii" 406 65 | ["utf-8"] "ascii" 406 66 | ["utf-8"] "utf-8;q=0.7)" "utf-8" 67 | ["utf-8"] "utf-8" "utf-8" 68 | ["ascii" "utf-8"] "ascii;q=0.7),utf-8" "utf-8" 69 | ["ascii" "utf-8"] "utf-8" "utf-8" 70 | ["ascii" "utf-8"] "utf-8,fr" "utf-8" 71 | ["ascii" "utf-8"] "ascii;q=0.1,utf-8" "utf-8" 72 | ["ascii" "utf-8"] "utf-8;q=0.3,ascii;q=0.2;iso8859-1=0.9;iso-8859-2" "utf-8")) 73 | 74 | (facts "Encoding negotitation" 75 | (tabular 76 | (negotiate "Accept-Encoding" :available-encodings :encoding ?available ?accepted) => ?negotiated 77 | ?available ?accepted ?negotiated 78 | [] "gzip" "identity" 79 | ["gzip"] "gzip" "gzip" 80 | ["gzip"] "gzip;q=foo" "gzip" 81 | ["compress"] "gzip" "identity" 82 | ["gzip" "compress"] "compress" "compress" 83 | ["gzip" "compress"] "compress;q=0.A,gzip;q=0.1" "gzip" 84 | ["gzip" "compress"] "compress,fr" "compress" 85 | ["gzip" "compress"] "compress;q=0.1,gzip" "gzip" 86 | ["gzip" "compress"] "compress;q=0.3,gzip;q=0.2;fr=0.9;la" "compress"))) 87 | -------------------------------------------------------------------------------- /test/test_override_as_response.clj: -------------------------------------------------------------------------------- 1 | (ns test-override-as-response 2 | (:use 3 | midje.sweet 4 | [ring.mock.request :only [request header]] 5 | [liberator.core :only [defresource resource]] 6 | [liberator.representation :as rep])) 7 | 8 | 9 | (facts "as-response can be overriden" 10 | (fact "custom as-reponse's ring response is not coerced into content-type" 11 | ((resource :available-media-types ["application/json"] 12 | :handle-ok (fn [_] "some string") 13 | :as-response (fn [d ctx] {:status 666 :body d})) 14 | 15 | (request :get "/")) 16 | => (contains {:body "some string" 17 | :headers (contains {"Content-Type" "application/json"}) 18 | :status 666})) 19 | 20 | (fact "necessary headers are added" 21 | ((resource :available-media-types ["application/json"] 22 | :handle-ok (fn [_] "some string") 23 | :as-response (fn [d ctx] {:body d})) 24 | (request :get "/")) 25 | => (contains {:headers (contains {"Content-Type" "application/json" 26 | "Vary" "Accept"}) 27 | :status 200 28 | :body "some string"})) 29 | 30 | (fact "custom as-reponse can call default as-response" 31 | ((resource :available-media-types ["text/plain"] 32 | :handle-ok (fn [_] "some text") 33 | :as-response (fn [d ctx] (assoc-in (rep/as-response d ctx) 34 | [:headers "X-FOO"] "BAR"))) 35 | (request :get "/")) 36 | => (contains {:body "some text" 37 | :headers (contains {"X-FOO" "BAR"}) 38 | :status 200})) 39 | 40 | (fact "custom as-response works with default handlers" 41 | ((resource :available-media-types ["text/plain"] 42 | :as-response (fn [d ctx] {:foo :bar})) 43 | (-> (request :get "/") 44 | (header "Accept" "foo/bar"))) 45 | => (contains {:foo :bar }))) 46 | -------------------------------------------------------------------------------- /test/test_representation.clj: -------------------------------------------------------------------------------- 1 | (ns test-representation 2 | (:require [midje.sweet :refer :all] 3 | [liberator.representation :refer :all] 4 | [liberator.core :refer :all] 5 | [checkers :refer :all] 6 | [ring.mock.request :as mock] 7 | [clojure.data.json :as json])) 8 | 9 | ;; test for issue #19 10 | ;; https://github.com/clojure-liberator/liberator/pull/19 11 | 12 | (defn- pr-str-dup [x] 13 | (binding [*print-dup* true] 14 | (pr-str x))) 15 | 16 | (facts "Can produce representations from map" 17 | (let [entity (sorted-map :foo "bar" :baz "qux")] 18 | (tabular "Various media types are supported" 19 | (as-response entity {:representation {:media-type ?media-type :charset "UTF-8"}}) 20 | => {:body ?body :headers { "Content-Type" (str ?media-type ";charset=UTF-8")}} 21 | ?media-type ?body 22 | "text/csv" "name,value\r\n:baz,qux\r\n:foo,bar\r\n" 23 | "text/tab-separated-values" "name\tvalue\r\n:baz\tqux\r\n:foo\tbar\r\n" 24 | "text/plain" "baz=qux\r\nfoo=bar" 25 | "text/html" (str "| baz | qux |
|---|---|
| foo | bar |
| bar | foo |
|---|---|
| 2 | 1 |
| 3 | 2 |