├── .gitignore
├── .travis.yml
├── .github
└── workflows
│ ├── clojure.yml
│ └── clj-kondo.yml
├── LICENSE
├── RELEASE.markdown
├── src
└── liberator
│ ├── trace.css
│ ├── util.clj
│ ├── graph.clj
│ ├── dev.clj
│ ├── conneg.clj
│ ├── representation.clj
│ └── core.clj
├── test
├── test_resource.clj
├── test_resource_definition.clj
├── checkers.clj
├── test_override_as_response.clj
├── test_util.clj
├── test_get_put.clj
├── test_errors.clj
├── test_handler_context.clj
├── test_execution_model.clj
├── test.clj
├── test_get_put_patch.clj
├── test_conneg.clj
├── test_response.clj
├── test_defresource.clj
├── test_representation.clj
├── test_conditionals.clj
└── test_flow.clj
├── README.markdown
├── project.clj
├── CHANGES.markdown
└── epl-v10.html
/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | \#*#
3 | classes
4 | lib/
5 | /pom.xml
6 | .lein*
7 | /target
8 | _site
9 | profiles.clj
10 | .nrepl-port
11 | trace.dot
12 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: clojure
2 | lein: lein
3 | script: lein test-all
4 | jdk:
5 | - openjdk8
6 | - openjdk9
7 | - openjdk10
8 | - openjdk11
9 | - openjdk-ea
10 | - oraclejdk8
11 | - oraclejdk9
12 | - oraclejdk11
13 | branches:
14 | except:
15 | - gh-pages
16 |
--------------------------------------------------------------------------------
/.github/workflows/clojure.yml:
--------------------------------------------------------------------------------
1 | name: Clojure CI
2 |
3 | on: [push]
4 |
5 | jobs:
6 | build:
7 |
8 | runs-on: ubuntu-latest
9 |
10 | steps:
11 | - uses: actions/checkout@v1
12 | - name: Install dependencies
13 | run: lein deps
14 | - name: Run tests
15 | run: lein test-all
16 |
--------------------------------------------------------------------------------
/.github/workflows/clj-kondo.yml:
--------------------------------------------------------------------------------
1 | name: CLJ-Kondo
2 |
3 | on: [push]
4 |
5 | jobs:
6 | build:
7 |
8 | runs-on: ubuntu-latest
9 |
10 | steps:
11 | - uses: actions/checkout@v1
12 | - uses: DeLaGuardo/clojure-lint-action@master
13 | with:
14 | clj-kondo-args: --lint src
15 | github_token: ${{ secrets.GITHUB_TOKEN }}
16 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) The Liberator developers. All rights reserved.
2 |
3 | The use and distribution terms for this software are covered by the Eclipse
4 | Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which
5 | can be found in the file epl-v10.html at the root of this distribution. By
6 | using this software in any fashion, you are agreeing to be bound by the
7 | terms of this license. You must not remove this notice, or any other, from
8 | this software.
9 |
10 |
--------------------------------------------------------------------------------
/RELEASE.markdown:
--------------------------------------------------------------------------------
1 | How to release to clojars:
2 |
3 | Ensure you have committed
4 |
5 | git status
6 |
7 | Get a list of tags.
8 |
9 | git tag -l
10 |
11 | Decide on the next one and tag
12 |
13 | git tag 1.0
14 |
15 | Build the jar and the Maven pom.xml
16 |
17 | lein jar
18 | lein pom
19 |
20 | Push the code and tags
21 |
22 | git push --tags
23 |
24 | Release to clojars
25 |
26 | scp target/liberator-1.0.jar pom.xml clojars@clojars.org:
27 |
28 |
29 |
--------------------------------------------------------------------------------
/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; }
--------------------------------------------------------------------------------
/test/test_resource.clj:
--------------------------------------------------------------------------------
1 | (ns test-resource
2 | (:use clojure.test)
3 | (:use liberator.core))
4 |
5 | (def url "http://clojure-liberator.github.io")
6 |
7 | (deftest test-handle-post
8 | (doseq [location [url
9 | (java.net.URL. url)
10 | (java.net.URI. url)]]
11 | (let [res (resource
12 | :method-allowed? [:post]
13 | :can-post-to-missing? true
14 | :post-is-create? true
15 | :post-redirect? true
16 | :location location)
17 | resp (res {:request-method :post :header {}})]
18 | (testing "post creates path"
19 | (is (= 303 (resp :status)))
20 | (is (= url (get-in resp [:headers "Location"])))))))
21 |
--------------------------------------------------------------------------------
/test/test_resource_definition.clj:
--------------------------------------------------------------------------------
1 | (ns test-resource-definition
2 | (:use liberator.core
3 | midje.sweet))
4 |
5 | ;; test cases for different resource definitions
6 |
7 | (defn dump-representation [parameter] #(get-in % [:representation parameter] "-"))
8 |
9 | (fact "default media-type negotiation uses :available-media-types"
10 | (let [r (resource :available-media-types ["text/html"]
11 | :handle-ok (dump-representation :media-type))]
12 | (r {:request-method :get :headers {"accept" "text/html"}})
13 | => (contains {:body "text/html"})))
14 |
15 | (fact "custom media-type negotiation with :media-type-available?"
16 | (let [r (resource :media-type-available?
17 | (fn [ctx]
18 | {:representation {:media-type "text/html"}})
19 | :handle-ok (dump-representation :media-type))]
20 | (r {:request-method :get :headers {"accept" "text/html"}})
21 | => (contains {:body "text/html"})))
22 |
23 | (fact "custom media-type negotiation with :media-type-available?"
24 | (let [r (resource :media-type-available?
25 | (fn [ctx]
26 | {:representation {:media-type "text/html"}})
27 | :handle-ok (dump-representation :media-type))]
28 | (r {:request-method :get :headers {"accept" "text/html"}})
29 | => (contains {:body "text/html"})))
30 |
31 | (fact "default language negotiation uses :available-languages"
32 | (let [r (resource :available-languages ["en" "de" "fr"]
33 | :handle-ok (dump-representation :language))]
34 | (r {:request-method :get :headers {"accept-language" "fr"}})
35 | => (contains {:body "fr"})))
--------------------------------------------------------------------------------
/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 |
--------------------------------------------------------------------------------
/README.markdown:
--------------------------------------------------------------------------------
1 | # Liberator [](https://travis-ci.org/clojure-liberator/liberator) [](http://clojars.org/liberator)
2 |
3 | Liberator is a Clojure library for building RESTful applications.
4 |
5 | ## Quick Links
6 |
7 | You can find documentation at http://clojure-liberator.github.io/liberator
8 |
9 | If you have any questions, visit our fine google group at https://groups.google.com/forum/#!forum/clojure-liberator
10 |
11 | ### Similar projects
12 |
13 | Liberator used to be known as compojure-rest. It got renamed in July 2012.
14 |
15 | Liberator is loosely modeled after webmachine and shares the same aims as Bishop.
16 |
17 | ## Warming up
18 |
19 | ### Dependencies
20 |
21 | The examples in this document rely on you installing [leiningen 2](http://leiningen.org).
22 |
23 | We'll also use ```curl``` for testing. If you don't have curl installed (ie. you're using Windows), there's some Clojure tests you can use instead.
24 |
25 | ### Running the examples
26 |
27 | A set of examples is included.
28 |
29 | If you want to see the examples in a browser, run
30 |
31 | lein examples
32 |
33 | This will start a web server on port 8000 (but you can specify a alternative port with an argument, eg. ```lein examples 8001```). Alternatively you can run the web server with ```lein ring server```).
34 |
35 | ### Ensuring the tests pass
36 |
37 | Liberator uses [Midje](https://github.com/marick/Midje/) for testing. You can run all the tests like this :-
38 |
39 | lein midje
40 |
41 | # Documentation
42 |
43 | Documentation and a tutorial can be found on [http://clojure-liberator.github.io](http://clojure-liberator.github.io).
44 |
45 | # License
46 |
47 | Liberator is licensed under EPL 1.0 (see file epl-v10.html).
48 |
--------------------------------------------------------------------------------
/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 |
--------------------------------------------------------------------------------
/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 |
--------------------------------------------------------------------------------
/test/test_util.clj:
--------------------------------------------------------------------------------
1 | (ns test-util
2 | (:require [liberator.util :refer :all]
3 | [midje.sweet :refer :all]))
4 |
5 | (facts "combine function"
6 | (facts "simple combinations"
7 | (fact "merges map" (combine {:a 1} {:b 2}) => {:a 1 :b 2})
8 | (fact "returns a map" (combine {:a 1} {:b 2}) => map?)
9 | (fact "concats list" (combine '(1 2) [3 4]) => '(1 2 3 4))
10 | (fact "returns a list" (combine '(1 2) [3 4]) => list?)
11 | (fact "concats vector" (combine [1 2] '(3 4)) => [1 2 3 4])
12 | (fact "returns a vector" (combine [1 2] '(3 4)) => vector?)
13 | (fact "concats set" (combine #{1 2} [3 4]) => #{1 2 3 4})
14 | (fact "returns a set" (combine #{1 2} [3 4]) => set?)
15 | (facts "replaces other types"
16 | (fact (combine 123 456) => 456)
17 | (fact (combine "abc" 123) => 123)
18 | (fact (combine [] "abc") => "abc"))
19 | (facts "replaces for different types"
20 | (fact (combine [1 2 3] 1) => 1)
21 | (fact (combine '(1 2 3) 1) => 1)
22 | (fact (combine {1 2 3 4} 1) => 1)))
23 | (facts "prevent merge with meta :replace"
24 | (fact "replaces map" (combine {:a 1} ^:replace {:b 2}) => {:b 2})
25 | (fact "replaces list" (combine '(1 2) ^:replace #{3 4}) => #{3 4})
26 | (fact "replaces vector"
27 | (combine [1 2] (with-meta (list 3 4) {:replace true})) => '(3 4))
28 | (fact "replaces set" (combine #{1 2} ^:replace [3 4]) => [3 4]))
29 | (facts "deep merges"
30 | (fact "map values are recursively merged"
31 | (combine {:a [1]
32 | :b '(2)
33 | :c {:x [3]}
34 | :d 4
35 | :e [:nine]}
36 | {:a '(5)
37 | :b #{6}
38 | :c {:x [7]}
39 | :d 8
40 | :e ^:replace [:ten]})
41 | => {:a [1 5]
42 | :b '(2 6)
43 | :c {:x [3 7]}
44 | :d 8
45 | :e [:ten]}))
46 | (facts "response updates"
47 | (combine {:status 200
48 | :body "foo"
49 | :headers {"Content-Type" "text/plain"
50 | "X-Dummy" ["banana" "apple"]}}
51 | {:headers {"Content-Type" "text/something+plain"
52 | "X-Dummy" ["peach"]}})
53 | => {:status 200
54 | :body "foo"
55 | :headers {"Content-Type" "text/something+plain"
56 | "X-Dummy" ["banana" "apple" "peach"]}}))
57 |
--------------------------------------------------------------------------------
/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 |
--------------------------------------------------------------------------------
/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/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 |
--------------------------------------------------------------------------------
/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 |
--------------------------------------------------------------------------------
/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_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.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_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_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_response.clj:
--------------------------------------------------------------------------------
1 | (ns test-response
2 | (:use
3 | midje.sweet
4 | [ring.mock.request :only [request header]]
5 | [compojure.core :only [context ANY]]
6 | [liberator.core :only [defresource resource run-handler]]
7 | [liberator.representation :only [ring-response as-response]]
8 | [checkers]))
9 |
10 | (facts "Content negotiation"
11 | (tabular "Content-Type header is added automatically"
12 | (-> (request :get "/")
13 | (header "Accept" ?accept)
14 | ((resource :available-media-types [?available] :handle-ok "ok")))
15 | => (content-type (str ?expected ";charset=UTF-8"))
16 | ?accept ?available ?expected
17 | "text/html" "text/html" "text/html"
18 | "text/plain" "text/plain" "text/plain"
19 | "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8" "text/html" "text/html"
20 | "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8" "text/html" "text/html"))
21 |
22 | ;; TODO: Add tests for ETag.
23 |
24 | (facts "Vary header is added automatically"
25 | (tabular "Parameter negotiation is added to vary header"
26 | (-> (run-handler "handle-ok" 200 "ok"
27 | {:resource {:handle-ok (fn [_] "body")
28 | :as-response as-response}
29 | :representation ?representation})
30 | (get-in [:headers "Vary"])) => ?vary
31 | ?representation ?vary
32 | {} nil
33 | {:media-type "x"} "Accept"
34 | {:media-type ""} nil
35 | {:language "x"} "Accept-Language"
36 | {:language nil} nil
37 | {:charset "ASCII"} "Accept-Charset"
38 | {:encoding "x"} "Accept-Encoding"
39 | {:media-type "m"
40 | :language "l"
41 | :charset "ASCII"
42 | :encoding "x"} "Accept, Accept-Charset, Accept-Language, Accept-Encoding"
43 | {:media-type "m"
44 | :charset "ASCII"
45 | :encoding "x"} "Accept, Accept-Charset, Accept-Encoding")
46 |
47 |
48 | (fact "Vary header can be overriden by handler"
49 | (-> (run-handler "handle-ok" 200 "ok"
50 | {:resource {:handle-ok (fn [c] (ring-response
51 | {:body "ok" :headers {"Vary" "*"}}))
52 | :as-response as-response}
53 | :representation {:media-type "text/plain"}})
54 | (get-in [:headers "Vary"]))
55 | => "*"))
56 |
57 | (facts "Adding `Allow` header automatically"
58 |
59 | (fact "done for `OPTIONS` request"
60 | (-> (request :options "/")
61 | ((resource :handle-ok "ok" :allowed-methods [:get :head :options])))
62 | => (header-value "Allow" "GET, HEAD, OPTIONS"))
63 |
64 | (fact "Accept-Patch check for `OPTIONS` request"
65 | (-> (request :options "/")
66 | ((resource :handle-ok "ok" :allowed-methods [:get :head :options :patch]
67 | :patch-content-types ["application/json-patch+json"])))
68 | => (header-value "Accept-Patch" "application/json-patch+json"))
69 |
70 | (fact "done when method is not allowed"
71 | (-> (request :post "/")
72 | ((resource :handle-ok "ok" :allowed-methods [:get :head :options])))
73 | => (header-value "Allow", "GET, HEAD, OPTIONS"))
74 |
75 | (fact "not done when header already exists"
76 | (-> (request :options "/")
77 | ((resource :handle-options (ring-response {:headers {"Allow" "GET"}})
78 | :allowed-methods [:get :head :options])))
79 | => (header-value "Allow", "GET"))
80 |
81 | (fact "not done any other time"
82 | (-> (request :get "/")
83 | ((resource :handle-ok "ok")))
84 | => (fn [c] (not (contains? (:headers c) "Allow"))))
85 | )
86 |
87 |
88 | (facts "Options can return a body"
89 | (fact "return a simple response"
90 | (-> (request :options "/")
91 | ((resource :allowed-methods [:get :options]
92 | :handle-ok "ok"
93 | :handle-options "options")))
94 | => (body "options"))
95 | (fact "return a ring response"
96 | (let [resp (-> (request :options "/")
97 | ((resource :allowed-methods [:get :options]
98 | :available-media-types ["text/plain" "text/html"]
99 | :handle-ok "ok"
100 | :handle-options (fn [ctx]
101 | ;; workaround until issue #152 is fixed
102 | (-> "options"
103 | (as-response (assoc-in ctx [:representation :media-type]
104 | "text/plain"))
105 | (assoc-in [:headers "X-Foo"] "bar")
106 | (ring-response))))))]
107 | resp => (body "options")
108 | resp) => (header-value "X-Foo" "bar")))
109 |
--------------------------------------------------------------------------------
/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 |
--------------------------------------------------------------------------------
/CHANGES.markdown:
--------------------------------------------------------------------------------
1 | # Changelog
2 |
3 | # Unreleased changes
4 |
5 | ## Changes
6 |
7 | * Return 304 not modified if request contains a if-modified-since
8 | header and the resource does not specify modification date. This
9 | is a better default for clients that do no handle resources without
10 | a modification date well.
11 |
12 | ## Bugs fixes
13 |
14 | # New in 0.15.3
15 |
16 | * Remove old examples. These dependet on an ancient clojurescript
17 | version which blocked updating some dependencies
18 | * Update clojure versions in the build matrix.
19 | * Allow `defresource` to have a docstring (#305)
20 | * Improve `liberator.util/combine` to not return lazy sequences (#304)
21 |
22 | ## Bugs fixed
23 |
24 | * Use minimum quality value when one provided is malformed (#199)
25 |
26 | # New in 0.15.2
27 |
28 | ## Bugs fixed
29 |
30 | * Log sequence could grow beyond limit (#295)
31 | * Removed javax.xml.ws dependency (#290)
32 |
33 | # New in 0.15.1
34 |
35 | ## Bugs fixed
36 |
37 | * A default value for :patch-enacted? was missing.
38 |
39 | # New in 0.15.0
40 |
41 | * Drop support for clojure versions 1.6 and ealier.
42 | * Bump dependency revision to non-ancient versions.
43 | * Drop dependency on compojure except for examples.
44 | * #201 Add support for using a java.net.URI instance to specify
45 | a Location for `moved` handlers
46 | * Posting to an existing resource checks for conflicts.
47 | * Add `:post-enacted?`, `:put-enacted?` and `:patch-enacted?`
48 | which return status 202 accepted if false.
49 | * Add leiningen alias `graph` to generate `trace.svg`
50 | * Add lein profile `1.9a` to test compatibility with clojure 1.9 alphas
51 |
52 | # New in 0.14.1
53 |
54 | * Improved highlighting of tracing view
55 |
56 | ## Bugs fixed
57 |
58 | * #253 fix highlighting in tracing view broken since 0.14.0
59 |
60 | # New in 0.14.0
61 |
62 | * The `defresource` macro no longer implicitly binds `request`.
63 |
64 | * Values can be added to the context at the beginning of the execution
65 | flow using the :initialize-context action.
66 | * If no handler is specified, the key :message is looked up from the
67 | context to create a default response.
68 | * JSON body can be parsed into :request-entity by setting
69 | representation/parse-request-entity for :processable?
70 | parse-request-entity is a multimethod which can be extended for
71 | additional media types.
72 |
73 | ## Bugs fixed
74 |
75 | * #76 Nullpointer with post options
76 | * Allow decisions to override status in context
77 | * Support multimethods as decision functions.
78 |
79 | # New in 0.13
80 |
81 | * Optionally a value can be specified for ring-response
82 | together with a ring map. This value is coerced to a response
83 | like liberator does by default while the ring map makes it
84 | possible to override whatever part of the response.
85 | * For status 201, 301, 303 and 307 the location header is added
86 | automatically. This used to be the case only for 201.
87 |
88 | ## Bugs fixed
89 |
90 | * #169 Always call as-response, even for default handlers
91 | * #206 avoid undesired deep merge of context
92 |
93 | # New in 0.12.2
94 |
95 | ## Bugs fixed
96 |
97 | * #162 This release actually contains the changes announced for 0.12.1
98 | Due to whatever reason the revision in clojars did not match
99 | what was tagged as 0.12.1 in the git repository.
100 |
101 | # New in 0.12.1
102 |
103 | ## Bugs fixed
104 |
105 | * Fix a regression and make default `:handle-exception` rethrow the
106 | exception. This matches the behaviour before 0.12.0
107 | * Update the decision graph to include new paths after PATCH
108 | support was added.
109 |
110 | # New in 0.12.0
111 |
112 | * Support for PATCH method, thanks to Davig Park
113 | * Add `:handle-exception` which is invoked when decision
114 | functions or handlers throw an exception.
115 |
116 | # New in 0.11.1
117 |
118 | ## Bugs fixed
119 |
120 | * #138 context update deeply merges values. Support workaround
121 | by enabling to evaluate a returned 0-ary function
122 |
123 | # New in 0.11.0
124 |
125 | * #97 Adds support for a default resource definition map parameter
126 | that simlpifies the reuse of resource definitions. This also
127 | adresses #95, however in a different way than it was proposed.
128 | * #100 resources can specify :as-response to plug in custom
129 | implementations
130 |
131 | ## Changes
132 |
133 | * Bumps version of hiccup to 1.0.3
134 | * Bumps plugin versions to prepare compatibility with 1.6
135 | - lein-midje -> 3.1.3
136 | - lein-ring -> 0.8.10
137 | - ring-devel -> 1.2.1
138 | - ring-jetty-adapter -> 1.2.1
139 | * Adds lein alias to run tests with different clojure versions
140 |
141 | ## Bugs fixed
142 |
143 | # New in 0.10.0
144 |
145 | ## Bugs fixed
146 |
147 | * Reenable suppport for keyword as a handler function
148 | * #71 Add locations header to 201 created
149 | * #65 Make sure svg path is highlighted
150 | * #77 Multiple link header values as vector
151 | * #49 OPTIONS should return 200 OK and "Allow" header
152 | * #50 HTTP 405 response must include an Allow-Header
153 | * #68 handle-options sends 201 created and not 200 or 204
154 |
155 | # New in 0.9.0
156 |
157 | * Improved documentation
158 | * Add support for 422 unprocessable entity via processable?
159 |
160 | ## Changes
161 |
162 | * Rename decision if-none-match to if-none-match?
163 | * UTF-8 is now the default charset for Representations
164 | * Adds web console for traces, include trace link header
165 | * Add "ETag" and "Last-Modified" automatically
166 | * Add "Vary" automatically
167 | * Add declaration :available-media-types?
168 | * Add support for HEAD request
169 | * Rework redirecting handlers. Now supports pickup of redirect
170 | location from context key :location
171 | * Extractor for graphivz dot file that reads core.clj
172 | * Bump hiccup dependency to 1.0.2
173 | * Add can-put-to-missing?
174 | * Fix representation render-map-csv
175 | * Make liberator build with lein 2.0.0RC1 (manage dependencies)
176 | * Drop unnecessary methods from Representation
177 | * Dispatch Representation on MapEquivalence and Sequential which
178 | increased robustness
179 | * Fixes to HTML Table representation (missing tr)
180 | * Render Clojure Representation using \*print-dup\*
181 | * Support "application/edn" representation
182 |
183 | ## Bugs fixed
184 |
185 | * #28 Head requests
186 | * Do not re-use generated ETag and Last-Modified during request
187 | because they can have changed after post! et. al.
188 | * Handlers for redirect status work now reliably
189 | * Fix Postbox example using value, not function for post!
190 |
191 | # New in 0.8.0
192 |
193 | ## Changes
194 |
195 | * Include olympics example data with source
196 |
197 | ## Bugs fixes
198 | * Handle line-break and whitespace in Accept headers
199 | * Ignore case in character set negotiation
200 | * #12 String representation sets character set
201 | * #9 Missing media-type for "hello george" example
202 | * #11
203 | * #14 Use newer org.clojure:data.csv
204 |
205 | # New in 0.7.0
206 |
207 | Revision 0.7.0 has been accidently skipped
208 |
--------------------------------------------------------------------------------
/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 ""
26 | "| baz | qux |
|---|
"
27 | "| foo | bar |
|---|
"
28 | "
"
43 | "| bar | foo |
|---|
"
44 | ""
45 | "| 2 | 1 |
"
46 | "| 3 | 2 |
"
47 | ""
48 | "
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 |
--------------------------------------------------------------------------------
/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 |
--------------------------------------------------------------------------------