From 9f2e7f04ad12ff9f87dea9341ffa3ef39f27491d Mon Sep 17 00:00:00 2001
From: David Thomas Hume <dth@dthu.me>
Date: Thu, 13 Mar 2014 08:26:23 +0000
Subject: [PATCH 1/3] Added basic perforate benchmark based on the "things"
 resource from test_get_put.clj

---
 benchmarks/things_bench.clj      | 56 ++++++++++++++++++++++++++++++++
 project.clj                      |  8 ++++-
 src/liberator/core.clj           |  6 ++--
 src/liberator/representation.clj |  2 +-
 src/liberator/util.clj           |  4 +--
 5 files changed, 69 insertions(+), 7 deletions(-)
 create mode 100644 benchmarks/things_bench.clj

diff --git a/benchmarks/things_bench.clj b/benchmarks/things_bench.clj
new file mode 100644
index 0000000..5f26417
--- /dev/null
+++ b/benchmarks/things_bench.clj
@@ -0,0 +1,56 @@
+(ns things-bench
+  (:require [liberator.core :refer (defresource request-method-in)]
+            [liberator.representation :refer (ring-response)]
+            [perforate.core :refer :all]
+            [ring.mock.request :refer (request header)])
+  (:import [java.security MessageDigest]))
+
+(defresource thing-resource
+  [things]
+  ;; early lookup   
+  :service-available? (fn [ctx] {::r (get @things (get-in ctx [:request :uri]))})
+  :method-allowed? (request-method-in :get :put :delete)
+  ;; lookup media types of the requested resource
+  :available-media-types #(if-let [m (get-in % [::r :media-type])] [m])
+  ;; the resource exists if a value is stored in @things at the uri
+  ;; store the looked up value at key ::r in the context
+  :exists? #(get % ::r)
+  ;; ...it existed if the stored value is nil (and not some random
+  ;; Objeced we use as a setinel)
+  :existed? #(nil? (get @things (get-in % [:request :uri]) (Object.)))
+  ;; use the previously stored value at ::r
+  :handle-ok #(get-in % [::r :content])
+  ;; update the representation
+  :put! #(dosync
+          (alter things assoc-in
+                 [(get-in % [:request :uri])]
+                 {:content (get-in % [:request :body])
+                  :media-type (get-in % [:request :headers "content-type"]
+                                      "application/octet-stream")
+                  :last-modified (java.util.Date.)}))
+  ;; ...store a nil value to marke the resource as gone
+  :delete! #(dosync (alter things assoc (get-in % [:request :uri]) nil))
+  :last-modified #(get-in % [::r :last-modified]))
+
+(defgoal things-bench "'Things' Resource benchmarks")
+
+(defcase things-bench "Things"
+  []
+  (let [t-r (thing-resource (ref nil))]
+    (let [resp (t-r (request :get "/r1"))]
+      (-> resp :status (= 404) assert))
+    (let [resp (t-r (-> (request :put "/r1")
+                                   (assoc :body "r1")
+                                   (header "content-type" "text/plain")))]
+      (-> resp :status (= 201) assert))
+    (let [resp (t-r (-> (request :get "/r1")))]
+      (-> resp :status (= 200) assert)
+      (-> resp :body (= "r1") assert)
+      (-> resp (get-in [:headers "Content-Type"])
+          (= "text/plain;charset=UTF-8")
+          assert))
+    (let [resp (t-r (-> (request :delete "/r1")))]
+      (-> resp :status (= 204) assert)
+      (-> resp :body nil? assert))
+    (let [resp (t-r (request :get "/r1"))]
+      (-> resp :status (= 410) assert))))
diff --git a/project.clj b/project.clj
index cb91a0c..b58c005 100644
--- a/project.clj
+++ b/project.clj
@@ -16,7 +16,8 @@
         :url "https://github.com/clojure-liberator/liberator"}
 
   :plugins [[lein-midje "3.1.3" :exclusions [leiningen-core]]
-            [lein-ring "0.8.10" :exclusions [org.clojure/clojure]]]
+            [lein-ring "0.8.10" :exclusions [org.clojure/clojure]]
+            [perforate "0.3.3"]]
 
   :profiles {:dev {:dependencies [[ring/ring-jetty-adapter "1.2.1" :exclusions [joda-time]]
                                   [ring-mock "0.1.2"]
@@ -33,6 +34,11 @@
   :source-paths ["src"]
   :test-paths ["test"]
 
+  :perforate
+  {:environments [{:name :core
+                   :profiles [:dev :1.5]
+                   :namespaces [things-bench]}]}
+
   :ring {:handler examples.server/handler
          :adapter {:port 8000}}
 
diff --git a/src/liberator/core.clj b/src/liberator/core.clj
index 0700ad2..6a8390c 100644
--- a/src/liberator/core.clj
+++ b/src/liberator/core.clj
@@ -206,7 +206,7 @@
 
 (defmethod to-location clojure.lang.APersistentMap [this] this)
 
-(defmethod to-location java.net.URL [url] (to-location (.toString url)))
+(defmethod to-location java.net.URL [^java.net.URL url] (to-location (.toString url)))
 
 (defmethod to-location nil [this] this)
 
@@ -310,7 +310,7 @@
 
 (defdecision modified-since?
   (fn [context]
-    (let [last-modified (gen-last-modified context)]
+    (let [^java.util.Date last-modified (gen-last-modified context)]
       [(and last-modified (.after last-modified (::if-modified-since-date context)))
        {::last-modified last-modified}]))
   method-delete?
@@ -346,7 +346,7 @@
 
 (defdecision unmodified-since?
   (fn [context]
-    (let [last-modified (gen-last-modified context)]
+    (let [^java.util.Date last-modified (gen-last-modified context)]
       [(and last-modified
             (.after last-modified
                     (::if-unmodified-since-date context)))
diff --git a/src/liberator/representation.clj b/src/liberator/representation.clj
index 4baed21..030c7fb 100644
--- a/src/liberator/representation.clj
+++ b/src/liberator/representation.clj
@@ -179,7 +179,7 @@
     (render-seq-generic data (assoc-in context [:representation :media-type]
                                        "application/json"))))
 
-(defn in-charset [string charset]
+(defn in-charset [^String string ^String charset]
   (if (and charset (not (.equalsIgnoreCase charset "UTF-8")))
     (java.io.ByteArrayInputStream.
      (.getBytes string (java.nio.charset.Charset/forName charset)))
diff --git a/src/liberator/util.clj b/src/liberator/util.clj
index 4538e78..640bd4e 100644
--- a/src/liberator/util.clj
+++ b/src/liberator/util.clj
@@ -24,7 +24,7 @@
   nil
   (as-date [this] nil))
 
-(defn http-date-format []
+(defn ^SimpleDateFormat http-date-format []
   (let [df (new SimpleDateFormat
                 "EEE, dd MMM yyyy HH:mm:ss z"
                 Locale/US)]
@@ -32,7 +32,7 @@
         df)))
 
 (defn relative-date [future]
-  (Date. (+ (System/currentTimeMillis) future)))
+  (Date. (long (+ (System/currentTimeMillis) future))))
 
 (defn http-date [date]
   (format "%s" (.format (http-date-format) date)))

From 4ccd31304a0091a1563779a4f8e02d9fa89d701e Mon Sep 17 00:00:00 2001
From: David Thomas Hume <dth@dthu.me>
Date: Sun, 16 Mar 2014 10:24:54 +0000
Subject: [PATCH 2/3] Added core.async resource support; resource functions may
 now return a channel, in which case resource execution will return a default
 response containing a :body whose value is a channel onto which the eventual
 response will be placed.

---
 benchmarks/things_bench.clj |  93 ++++++++-----
 project.clj                 |   6 +-
 src/liberator/async.clj     | 100 ++++++++++++++
 src/liberator/core.clj      | 253 +++++++++++++++++++++---------------
 test/test_async.clj         |  54 ++++++++
 5 files changed, 368 insertions(+), 138 deletions(-)
 create mode 100644 src/liberator/async.clj
 create mode 100644 test/test_async.clj

diff --git a/benchmarks/things_bench.clj b/benchmarks/things_bench.clj
index 5f26417..0afdc33 100644
--- a/benchmarks/things_bench.clj
+++ b/benchmarks/things_bench.clj
@@ -1,47 +1,50 @@
 (ns things-bench
-  (:require [liberator.core :refer (defresource request-method-in)]
+  (:require [liberator.async :refer (go?)]
+            [liberator.core :refer (resource request-method-in)]
             [liberator.representation :refer (ring-response)]
             [perforate.core :refer :all]
             [ring.mock.request :refer (request header)])
   (:import [java.security MessageDigest]))
 
-(defresource thing-resource
-  [things]
-  ;; early lookup   
-  :service-available? (fn [ctx] {::r (get @things (get-in ctx [:request :uri]))})
-  :method-allowed? (request-method-in :get :put :delete)
-  ;; lookup media types of the requested resource
-  :available-media-types #(if-let [m (get-in % [::r :media-type])] [m])
-  ;; the resource exists if a value is stored in @things at the uri
-  ;; store the looked up value at key ::r in the context
-  :exists? #(get % ::r)
-  ;; ...it existed if the stored value is nil (and not some random
-  ;; Objeced we use as a setinel)
-  :existed? #(nil? (get @things (get-in % [:request :uri]) (Object.)))
-  ;; use the previously stored value at ::r
-  :handle-ok #(get-in % [::r :content])
-  ;; update the representation
-  :put! #(dosync
-          (alter things assoc-in
-                 [(get-in % [:request :uri])]
-                 {:content (get-in % [:request :body])
-                  :media-type (get-in % [:request :headers "content-type"]
-                                      "application/octet-stream")
-                  :last-modified (java.util.Date.)}))
-  ;; ...store a nil value to marke the resource as gone
-  :delete! #(dosync (alter things assoc (get-in % [:request :uri]) nil))
-  :last-modified #(get-in % [::r :last-modified]))
+(defn things-resource
+  [base things]
+  (resource
+   base
+   ;; early lookup   
+   :service-available? (fn [ctx] {::r (get @things (get-in ctx [:request :uri]))})
+   :method-allowed? (request-method-in :get :put :delete)
+   ;; lookup media types of the requested resource
+   :available-media-types #(if-let [m (get-in % [::r :media-type])] [m])
+   ;; the resource exists if a value is stored in @things at the uri
+   ;; store the looked up value at key ::r in the context
+   :exists? #(get % ::r)
+   ;; ...it existed if the stored value is nil (and not some random
+   ;; Objeced we use as a setinel)
+   :existed? #(nil? (get @things (get-in % [:request :uri]) (Object.)))
+   ;; use the previously stored value at ::r
+   :handle-ok #(get-in % [::r :content])
+   ;; update the representation
+   :put! #(dosync
+           (alter things assoc-in
+                  [(get-in % [:request :uri])]
+                  {:content (get-in % [:request :body])
+                   :media-type (get-in % [:request :headers "content-type"]
+                                       "application/octet-stream")
+                   :last-modified (java.util.Date.)}))
+   ;; ...store a nil value to marke the resource as gone
+   :delete! #(dosync (alter things assoc (get-in % [:request :uri]) nil))
+   :last-modified #(get-in % [::r :last-modified])))
 
 (defgoal things-bench "'Things' Resource benchmarks")
 
-(defcase things-bench "Things"
-  []
-  (let [t-r (thing-resource (ref nil))]
+(defn run-things
+  [{:keys [read-response resource-fn]}]
+  (let [t-r (comp read-response resource-fn)]
     (let [resp (t-r (request :get "/r1"))]
       (-> resp :status (= 404) assert))
     (let [resp (t-r (-> (request :put "/r1")
-                                   (assoc :body "r1")
-                                   (header "content-type" "text/plain")))]
+                        (assoc :body "r1")
+                        (header "content-type" "text/plain")))]
       (-> resp :status (= 201) assert))
     (let [resp (t-r (-> (request :get "/r1")))]
       (-> resp :status (= 200) assert)
@@ -54,3 +57,29 @@
       (-> resp :body nil? assert))
     (let [resp (t-r (request :get "/r1"))]
       (-> resp :status (= 410) assert))))
+
+(defcase things-bench "Things Sync"
+  []
+  (run-things {:read-response identity
+               :resource-fn
+               (things-resource
+                {:authorized? 
+                 (request-method-in :get :put :delete)}
+                (ref nil))}))
+
+(defcase things-bench "Things Async"
+  []
+  (let [things (ref nil)]
+    (run-things {:read-response #(-> % :body clojure.core.async/<!!)
+                 :resource-fn
+                 (things-resource
+                  {:async? true
+                   :authorized? 
+                   (fn [ctx]
+                     (go?
+                      ;; this is just to ensure that _something_ happens
+                      ;; in the go block
+                      #(some #{(:request-method (:request %))}
+                             [:get :put :delete])))}
+                  things)})))
+
diff --git a/project.clj b/project.clj
index b58c005..40e7ec4 100644
--- a/project.clj
+++ b/project.clj
@@ -1,6 +1,7 @@
 (defproject liberator "0.12.0-SNAPSHOT"
   :description "Liberator - A REST library for Clojure."
-  :dependencies [[org.clojure/clojure "1.4.0"]
+  :dependencies [[org.clojure/clojure "1.5.1"]
+                 [org.clojure/core.async "0.1.267.0-0d7780-alpha"]
                  [org.clojure/tools.trace "0.7.3"]
                  [org.clojure/tools.logging "0.2.3"]
                  [org.clojure/data.json "0.2.1"]
@@ -27,7 +28,6 @@
                                   [compojure "1.0.2" :exclusions [org.clojure/tools.macro]]
                                   [org.clojure/clojurescript "0.0-1450"]]
                    :source-paths [ "src" "examples/clj"]}
-             :1.4 {:dependencies [[org.clojure/clojure "1.4.0"]]}
              :1.5 {:dependencies [[org.clojure/clojure "1.5.1"]]}
              :1.6 {:dependencies [[org.clojure/clojure "1.6.0-beta1"]]}}
 
@@ -43,4 +43,4 @@
          :adapter {:port 8000}}
 
   :aliases {"examples" ["run" "-m" "examples.server"]
-            "test-all" ["with-profile" "+1.4:+1.5:+1.6" "test"]})
+            "test-all" ["with-profile" "+1.5:+1.6" "test"]})
diff --git a/src/liberator/async.clj b/src/liberator/async.clj
new file mode 100644
index 0000000..7b1662f
--- /dev/null
+++ b/src/liberator/async.clj
@@ -0,0 +1,100 @@
+;; Copyright (c) Philipp Meier (meier@fnogol.de). All rights reserved.
+;; The use and distribution terms for this software are covered by the Eclipse
+;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which
+;; can be found in the file epl-v10.html at the root of this distribution. By
+;; using this software in any fashion, you are agreeing to be bound by the
+;; terms of this license. You must not remove this notice, or any other, from
+;; this software.
+
+(ns liberator.async
+  (:require [clojure.core.async :as async :refer [go <!]]
+            [clojure.core.async.impl.protocols :as async-p]))
+
+(def channel?
+  "Returns true if argument is a core.async channel"
+  (partial satisfies? async-p/Channel))
+
+(defmacro go?
+  "A `go` block which will catch any thrown `Throwable` instances
+and yield them as the value of the block channel."
+  [& body]
+  `(async/go
+     (try
+       ~@body
+       (catch Throwable e# e#))))
+
+(defn rethrow-exceptions
+  [maybe-e]
+  (if (instance? Throwable maybe-e)
+    (throw maybe-e)
+    maybe-e))
+
+(defmacro <?
+  "Read a value from the channel found by evaluating `expr` and, if it is
+a `Throwable` instance, then throw it, otherwise return it. Must be used
+inside a `go` block."
+  [expr]
+  `(rethrow-exceptions (async/<! ~expr)))
+
+(defn async-response
+  "If `r` has a `:body` which is a core.async channel, then returns that
+channel, else returns `nil`."
+  [r]
+  (let [b (and r (:body r))]
+    (when (channel? b)
+      b)))
+
+(defn async-middleware
+  "Utility for constructing ring middleware out of a pair of `:request` and
+`:response` handling functions (such as those found in ring core). Returns
+a function which can be used to wrap handlers in the resulting middleware.
+Note that neither `:request` and `:response` can itself return a core.async
+channel; if you need to write async aware middleware then you don't need this
+function!"
+  [& {:keys [request response]
+      :or {request identity response nil}}]
+  (fn [handler]
+    (fn [req]
+      (let [resp (-> req request handler)]
+        (if (and response (async-response resp))
+          (update-in resp [:body] (partial async/map< response))
+          resp)))))
+
+(defmacro <val?
+  "Evaluate `expr` and, if it is a channel, read a value from it with `<?`
+and yield it as the result, otherwise return the value of `expr`.
+Must be used inside a `go` block (at least when the result of `expr` is a
+channel)."
+  [expr]
+  `(let [v# ~expr]
+     (if (channel? v#)
+       (<? v#)
+       v#)))
+
+(defmacro <let?
+  "Optimistic mixed blocking and non-blocking version of `let*`. Used to write
+code which receives functions which may be either blocking or non blocking,
+and needs to itself become either blocking or non blocking. This allows
+liberator to optionally work with core.async without forcing it on clients,
+and without requiring two sets of parallel APIs etc. (at the price of a
+rather ugly macro).
+
+Establishes `bindings` as if by `let*`. If any of the resulting bindings
+are a channel, then a `go` block is initiated, the results of any channel
+bindings are read inside the block and rebound, and `body` is executed
+in the scope of the resulting bindings.
+
+If none of the resulting bindings from the first step are channels
+then `body` is executed in the scope of these bindings (no go block)."
+  [bindings & body]
+  (let [bind-map (apply hash-map bindings)
+        bind-keys (-> bind-map keys vec)
+        bind-gs (vec (for [k bind-keys] (gensym)))]
+    `(let* [do-body# (fn ~bind-keys ~@body)
+            ~@(mapcat (fn [gs k] [gs (get bind-map k)])
+                      bind-gs bind-keys)]
+       (if (some channel? ~bind-gs)
+         (go?
+          (<val?
+           (do-body# ~@(for [gs bind-gs] `(<val? ~gs)))))
+         (do-body# ~@bind-gs)))))
diff --git a/src/liberator/core.clj b/src/liberator/core.clj
index 6a8390c..8406799 100644
--- a/src/liberator/core.clj
+++ b/src/liberator/core.clj
@@ -7,7 +7,9 @@
 ;; this software.
 
 (ns liberator.core
-  (:require [liberator.conneg :as conneg])
+  (:require [clojure.core.async :refer [map<]]
+            [liberator.conneg :as conneg]
+            [liberator.async :refer [channel? <let?]])
   (:use
    [liberator.util :only [parse-http-date http-date as-date make-function]]
    [liberator.representation :only [Representation as-response ring-response]]
@@ -61,11 +63,13 @@
 
 (defn gen-etag [context]
   (if-let [f (get-in context [:resource :etag])]
-    (format "\"%s\"" (f context))))
+    (<let? [etag (f context)]
+      (format "\"%s\"" etag))))
 
 (defn gen-last-modified [context]
   (if-let [f (get-in context [:resource :last-modified])]
-    (as-date (f context))))
+    (<let? [lm (f context)]
+      (as-date lm))))
 
 ;; A more sophisticated update of the request than a simple merge
 ;; provides.  This allows decisions to return maps which modify the
@@ -81,16 +85,19 @@
 (defn decide [name test then else {:keys [resource request] :as context}]
   (if (or (fn? test) (contains? resource name)) 
     (let [ftest (or (resource name) test)
-	  ftest (make-function ftest)
-	  fthen (make-function then)
-	  felse (make-function else)
-	  decision (ftest context)
-	  result (if (vector? decision) (first decision) decision)
-	  context-update (if (vector? decision) (second decision) decision)
-	  context (if (map? context-update)
-                    (combine context context-update) context)]
-      (log! :decision name decision)
-      ((if result fthen felse) context))
+          ftest (make-function ftest)
+          fthen (make-function then)
+          felse (make-function else)]
+      (<let? [decision (ftest context)]
+        (let [result (if (vector? decision) (first decision) decision)
+              context-update (if (vector? decision)
+                               (second decision)
+                               decision)
+              context (if (map? context-update)
+                        (combine context context-update)
+                        context)]
+          (log! :decision name decision)
+          ((if result fthen felse) context))))
     {:status 500 :body (str "No handler found for key \""  name "\"."
                             " Keys defined for resource are " (keys resource))}))
 
@@ -126,66 +133,86 @@
 (defn build-allow-header [resource]
   (clojure.string/join ", " (map (comp clojure.string/upper-case name) ((:allowed-methods resource)))))
 
-(defn run-handler [name status message
-                   {:keys [resource request representation] :as context}]
-  (let [context
-        (merge {:status status :message message} context)
-        response 
+(defn build-handler-response
+  [handler-response {:keys [resource representation] :as context}]
+  (merge-with
+   merge
+   {:headers
+    (-> {} 
+        (set-header-maybe "Content-Type"
+                          (str (:media-type representation)
+                               (when-let [charset (:charset representation)] (str ";charset=" charset))))
+        (set-header-maybe "Content-Language" (:language representation))
+        (set-header-maybe "Content-Encoding"
+                          (let [e (:encoding representation)]
+                            (if-not (= "identity" e) e)))
+        (set-header-maybe "Vary" (build-vary-header representation)))}
+   ;; Finally the result of the handler.  We allow the handler to
+   ;; override the status and headers.
+   ;;
+   ;; The rules about who should take responsibility for encoding
+   ;; the response are defined in the BodyResponse protocol.
+   ((:as-response resource) handler-response context)))
+
+(defn build-default-handler-response
+  [name status {:keys [message] :as context}]
+  (do
+    (log! :handler (keyword name) "(default implementation)")
+    {:status status 
+     :headers {"Content-Type" "text/plain"} 
+     :body (if (fn? message) (message context) message)}))
+
+(defn finalize-response
+  [name status etag last-modified location handler-response
+   {:keys [request resource] :as context}]
+  (let [response
         (merge-with
          combine
-
          ;; Status
          {:status status}
-
          ;; ETags
-         (when-let [etag (gen-etag context)]
+         (when etag
            {:headers {"ETag" etag}})
-         
          ;; Last modified
-         (when-let [last-modified (gen-last-modified context)]
+         (when last-modified
            {:headers {"Last-Modified" (http-date last-modified)}})
-
          ;; 201 created required a location header to be send
-         (when (= 201 status)
-           (if-let [f (or (get context :location)
-                          (get resource :location))]
-             {:headers {"Location" (str ((make-function f) context))}}))
-     
-         (if-let [handler (get resource (keyword name))]
-           (do
-             (log! :handler (keyword name))
-             ;; Content negotiations         
-             (merge-with
-              merge
-              {:headers
-               (-> {} 
-                   (set-header-maybe "Content-Type"
-                                     (str (:media-type representation)
-                                          (when-let [charset (:charset representation)] (str ";charset=" charset))))
-                   (set-header-maybe "Content-Language" (:language representation))
-                   (set-header-maybe "Content-Encoding"
-                                     (let [e (:encoding representation)]
-                                       (if-not (= "identity" e) e)))
-                   (set-header-maybe "Vary" (build-vary-header representation)))}
-              ;; Finally the result of the handler.  We allow the handler to
-              ;; override the status and headers.
-              (let [handler-response (handler context)
-                    ring-response ((:as-response resource) handler-response context)]
-                ring-response)))
-
+         (when location
+           {:headers {"Location" (str location)}})
+         ;; Handler
+         (if handler-response
+           (build-handler-response handler-response context)
            ;; If there is no handler we just return the information we
            ;; have so far.
-           (let [message (get context :message)]
-             (do (log! :handler (keyword name) "(default implementation)")
-                 {:status status 
-                  :headers {"Content-Type" "text/plain"} 
-                  :body (if (fn? message) (message context) message)}))))]
+           (build-default-handler-response name status context)))]
     (cond
-      (or (= :options (:request-method request)) (= 405 (:status response)))
-        (merge-with merge {:headers {"Allow" (build-allow-header resource)}} response)
-      (= :head (:request-method request))
-        (dissoc response :body)
-      :else response)))
+     (or (= :options (:request-method request)) (= 405 (:status response)))
+     (merge-with merge {:headers {"Allow" (build-allow-header resource)}} response)
+     
+     (= :head (:request-method request))
+     (dissoc response :body)
+     
+     :else response)))
+
+(defn run-handler [name status message
+                   {:keys [resource request representation] :as context}]
+  (let [context (merge {:status status :message message} context)]
+    (<let? [etag (gen-etag context)
+            last-modified (gen-last-modified context)
+            location
+            (when (= 201 status)
+              (if-let [f (or (get context :location)
+                             (get resource :location))]
+                ((make-function f) context)))
+            handler-response
+            (if-let [handler (get resource (keyword name))]
+              (do
+                (log! :handler (keyword name))
+                (handler context)))]
+           (finalize-response name status
+                              etag last-modified
+                              location handler-response
+                              context))))
 
 (defmacro ^:private defhandler [name status message]
   `(defn ~name [context#]
@@ -310,7 +337,7 @@
 
 (defdecision modified-since?
   (fn [context]
-    (let [^java.util.Date last-modified (gen-last-modified context)]
+    (<let? [^java.util.Date last-modified (gen-last-modified context)]
       [(and last-modified (.after last-modified (::if-modified-since-date context)))
        {::last-modified last-modified}]))
   method-delete?
@@ -330,7 +357,7 @@
 
 (defdecision etag-matches-for-if-none?
   (fn [context]
-    (let [etag (gen-etag context)]
+    (<let? [etag (gen-etag context)]
       [(= (get-in context [:request :headers "if-none-match"]) etag)
        {::etag etag}]))
   if-none-match?
@@ -346,7 +373,7 @@
 
 (defdecision unmodified-since?
   (fn [context]
-    (let [^java.util.Date last-modified (gen-last-modified context)]
+    (<let? [^java.util.Date last-modified (gen-last-modified context)]
       [(and last-modified
             (.after last-modified
                     (::if-unmodified-since-date context)))
@@ -366,7 +393,7 @@
 
 (defdecision etag-matches-for-if-match?
   (fn [context]
-    (let [etag (gen-etag context)]
+    (<let? [etag (gen-etag context)]
       [(= etag (get-in context [:request :headers "if-match"]))
        (assoc context ::etag etag)]))
   if-unmodified-since-exists?
@@ -387,11 +414,11 @@
 
 (defdecision encoding-available? 
   (fn [ctx]
-    (when-let [encoding (conneg/best-allowed-encoding
-                         (get-in ctx [:request :headers "accept-encoding"])
-                         ((get-in ctx [:resource :available-encodings]) ctx))]
-      {:representation {:encoding encoding}}))
-
+    (<let? [ae ((get-in ctx [:resource :available-encodings]) ctx)]
+      (when-let [encoding (conneg/best-allowed-encoding
+                           (get-in ctx [:request :headers "accept-encoding"])
+                           ae)]
+        {:representation {:encoding encoding}})))
   processable? handle-not-acceptable)
 
 (defmacro try-header [header & body]
@@ -404,13 +431,15 @@
   encoding-available? processable?)
 
 (defdecision charset-available?
-  #(try-header "Accept-Charset"
-               (when-let [charset (conneg/best-allowed-charset
-                                   (get-in % [:request :headers "accept-charset"])
-                                   ((get-in context [:resource :available-charsets]) context))]
-                 (if (= charset "*")
-                   true
-                   {:representation {:charset charset}})))
+  #(<let? [ac ((get-in context [:resource :available-charsets]) context)]
+     (try-header
+      "Accept-Charset"
+      (when-let [charset (conneg/best-allowed-charset
+                          (get-in % [:request :headers "accept-charset"])
+                          ac)]
+        (if (= charset "*")
+          true
+          {:representation {:charset charset}}))))
   accept-encoding-exists? handle-not-acceptable)
 
 (defdecision accept-charset-exists? (partial header-exists? "accept-charset")
@@ -418,24 +447,29 @@
 
 
 (defdecision language-available?
-  #(try-header "Accept-Language"
-               (when-let [lang (conneg/best-allowed-language
-                                (get-in % [:request :headers "accept-language"]) 
-                                ((get-in context [:resource :available-languages]) context))]
-                 (if (= lang "*")
-                   true
-                   {:representation {:language lang}})))
+  #(<let? [al ((get-in context [:resource :available-languages]) context)]
+     (try-header
+      "Accept-Language"
+      (when-let [lang (conneg/best-allowed-language
+                       (get-in % [:request :headers "accept-language"]) 
+                       al)]
+        (if (= lang "*")
+          true
+          {:representation {:language lang}}))))
   accept-charset-exists? handle-not-acceptable)
 
 (defdecision accept-language-exists? (partial header-exists? "accept-language")
   language-available? accept-charset-exists?)
 
 (defn negotiate-media-type [context]
-  (try-header "Accept"
-              (when-let [type (conneg/best-allowed-content-type 
-                               (get-in context [:request :headers "accept"]) 
-                               ((get-in context [:resource :available-media-types] (constantly "text/html")) context))]
-                {:representation {:media-type (conneg/stringify type)}})))
+  (<let? [amt ((get-in context [:resource :available-media-types]
+                       (constantly "text/html")) context)]
+    (try-header
+     "Accept"
+     (when-let [type (conneg/best-allowed-content-type 
+                      (get-in context [:request :headers "accept"]) 
+                      amt)]
+       {:representation {:media-type (conneg/stringify type)}}))))
 
 (defdecision media-type-available? negotiate-media-type
   accept-language-exists? handle-not-acceptable)
@@ -447,11 +481,12 @@
      ;; client accepts all media types" [p100]
      ;; in this case we do content-type negotiaion using */* as the accept
      ;; specification
-     (if-let [type (liberator.conneg/best-allowed-content-type 
-                    "*/*"
-                    ((get-in context [:resource :available-media-types]) context))]
-       [false {:representation {:media-type (liberator.conneg/stringify type)}}]
-       false))
+     (<let? [amt ((get-in context [:resource :available-media-types]) context)]
+       (if-let [type (liberator.conneg/best-allowed-content-type 
+                      "*/*"
+                      amt)]
+         [false {:representation {:media-type (liberator.conneg/stringify type)}}]
+         false)))
   media-type-available?
   accept-language-exists?)
 
@@ -488,6 +523,8 @@
 (defhandler handle-service-not-available 503 "Service not available.")
 (defdecision service-available? known-method? handle-service-not-available)
 
+(defdecision async? service-available? service-available?)
+
 (defn test-request-method [valid-methods-key]
   (fn [{{m :request-method} :request
        {vm valid-methods-key} :resource
@@ -497,6 +534,7 @@
 (def default-functions 
   {
    ;; Decisions
+   :async?                    false
    :service-available?        true
 
    :known-methods             [:get :head :options :put :post :delete :trace]
@@ -558,19 +596,28 @@
    :available-charsets        ["UTF-8"]
    :available-encodings       ["identity"]})
 
+(defn exception->response
+  [maybe-e]
+  (if (instance? ProtocolException maybe-e)
+    {:status 400
+     :headers {"Content-Type" "text/plain"}
+     :body (.getMessage maybe-e)
+     ::throwable maybe-e}
+    maybe-e))
+
 ;; resources are a map of implementation methods
 (defn run-resource [request kvs]
   (try
-    (service-available? {:request request
-                         :resource
-                         (map-values make-function (merge default-functions kvs))
-                         :representation {}})
-    
+    (let [response
+          (async? {:request request
+                   :resource
+                   (map-values make-function (merge default-functions kvs))
+                   :representation {}})]
+      (if (channel? response)
+        {:body (map< exception->response response)}
+        response))
     (catch ProtocolException e         ; this indicates a client error
-      {:status 400
-       :headers {"Content-Type" "text/plain"}
-       :body (.getMessage e)
-       ::throwable e}))) ; ::throwable gets picked up by an error renderer
+      (exception->response e))))       ; ::throwable gets picked up by an error renderer
 
 
 (defn get-options
diff --git a/test/test_async.clj b/test/test_async.clj
new file mode 100644
index 0000000..2ffb593
--- /dev/null
+++ b/test/test_async.clj
@@ -0,0 +1,54 @@
+(ns test-async
+  (:use clojure.test)
+  (:use liberator.core)
+  (:require [clojure.core.async :refer (<!! timeout)]
+            [liberator.async :refer (go? <?)])
+  (:import (javax.xml.ws ProtocolException)))
+
+(deftest test-handle-async-post
+  (let [res (resource 
+       :async? true
+       :exists? (fn [_] (go? (<? (timeout 5)) false))
+	   :method-allowed? [:post]
+	   :can-post-to-missing? true
+	   :post-is-create? true
+       :post-redirect? true
+       :post! (fn [ctx] (go? (<? (timeout 5)) true))
+	   :location "new-path")
+    resp (<!! (:body (res {:request-method :post :header {}})))]
+    (testing "post creates path"
+      (is (= 303 (resp :status)))
+      (is (= "new-path" (get-in resp [:headers "Location"]))))))
+
+(deftest test-handle-exception
+  (let [res (resource
+       :async? true
+       :exists?
+       (fn [_]
+         (go? (throw (IllegalArgumentException. "Something went wrong"))))
+	   :method-allowed? [:post]
+	   :can-post-to-missing? true
+	   :post-is-create? true
+       :post-redirect? true
+	   :location "new-path")
+    resp (<!! (:body (res {:request-method :post :header {}})))]
+    (testing "exception thrown"
+      (is (instance? Exception resp)))))
+
+(deftest test-handle-protocol-exception
+  (let [res (resource
+       :async? true
+       :exists?
+       (fn [_]
+         (go? (throw (ProtocolException. "ProtocolException"))))
+	   :method-allowed? [:post]
+	   :can-post-to-missing? true
+	   :post-is-create? true
+       :post-redirect? true
+	   :location "new-path")
+    resp (<!! (:body (res {:request-method :post :header {}})))]
+    (testing "protocol exceptions return error response"
+      (is (= 400 (resp :status))
+          (= "ProtocolException" (resp :body))))))
+
+

From 8e533d1d83c52ec32ee3fdd64268ed2d4f929048 Mon Sep 17 00:00:00 2001
From: David Thomas Hume <dth@dthu.me>
Date: Tue, 25 Mar 2014 17:23:25 +0000
Subject: [PATCH 3/3] Fixed up trace support to work in async mode

---
 src/liberator/async.clj |  8 +++---
 src/liberator/dev.clj   | 59 ++++++++++++++++++++++++++++-------------
 src/liberator/graph.clj |  2 +-
 src/liberator/trace.css |  4 +--
 src/liberator/trace.svg | 24 ++++++++++++-----
 5 files changed, 65 insertions(+), 32 deletions(-)

diff --git a/src/liberator/async.clj b/src/liberator/async.clj
index 7b1662f..6728e93 100644
--- a/src/liberator/async.clj
+++ b/src/liberator/async.clj
@@ -72,14 +72,14 @@ channel)."
        v#)))
 
 (defmacro <let?
-  "Optimistic mixed blocking and non-blocking version of `let*`. Used to write
+  "Optimistic mixed blocking and non-blocking version of `let`. Used to write
 code which receives functions which may be either blocking or non blocking,
 and needs to itself become either blocking or non blocking. This allows
 liberator to optionally work with core.async without forcing it on clients,
 and without requiring two sets of parallel APIs etc. (at the price of a
 rather ugly macro).
 
-Establishes `bindings` as if by `let*`. If any of the resulting bindings
+Establishes `bindings` as if by `let`. If any of the resulting bindings
 are a channel, then a `go` block is initiated, the results of any channel
 bindings are read inside the block and rebound, and `body` is executed
 in the scope of the resulting bindings.
@@ -90,10 +90,10 @@ then `body` is executed in the scope of these bindings (no go block)."
   (let [bind-map (apply hash-map bindings)
         bind-keys (-> bind-map keys vec)
         bind-gs (vec (for [k bind-keys] (gensym)))]
-    `(let* [do-body# (fn ~bind-keys ~@body)
+    `(let [do-body# (fn ~bind-keys ~@body)
             ~@(mapcat (fn [gs k] [gs (get bind-map k)])
                       bind-gs bind-keys)]
-       (if (some channel? ~bind-gs)
+       (if (or ~@(for [gs bind-gs] `(channel? ~gs)))
          (go?
           (<val?
            (do-body# ~@(for [gs bind-gs] `(<val? ~gs)))))
diff --git a/src/liberator/dev.clj b/src/liberator/dev.clj
index c3bc6e2..ea7f55e 100644
--- a/src/liberator/dev.clj
+++ b/src/liberator/dev.clj
@@ -6,6 +6,8 @@
         [liberator.core :only [defresource]]
         [clojure.string :only [join]])
   (:require [liberator.core :as core]
+            [liberator.async :refer [async-response]]
+            [clojure.core.async :refer [map<]]
             [clojure.string :as string]
             [clojure.data.json :as json])
   (:import java.util.Date))
@@ -185,6 +187,14 @@
 
 (def trace-svg (clojure.java.io/resource "liberator/trace.svg"))
 
+(defn- wrap-trace-ui-response
+  [resp]
+  (if-let [id (get-in resp [:headers trace-id-header])]
+    (update-in resp [:headers "Link"]
+               #(if %1 [%1 %2] %2)
+               (format "</%s>; rel=x-liberator-trace" (trace-url id)))
+    resp))
+
 (defn- wrap-trace-ui [handler]
   (let [base-url (with-slash mount-url)]
     (routes
@@ -196,24 +206,40 @@
      (ANY base-url [] list-handler)
      (fn [req]
        (let [resp (handler req)]
-         (if-let [id (get-in resp [:headers trace-id-header])]
-           (update-in resp [:headers "Link"]
-                      #(if %1 [%1 %2] %2)
-                      (format "</%s>; rel=x-liberator-trace" (trace-url id)))
-           resp))))))
+         (if (async-response resp)
+           (update-in resp [:body]
+                      (partial map< wrap-trace-ui-response))
+           (wrap-trace-ui-response resp)))))))
+
+(defn- wrap-trace-header-response
+  [resp]
+  (if-let [id (get-in resp [:headers trace-id-header])]
+    (let [[_ [_ _ l]] (log-by-id id)]
+      (assoc-in resp [:headers "X-Liberator-Trace"]
+                (map #(clojure.string/join " " %) l)))
+    resp))
 
 (defn- wrap-trace-header [handler]
   (fn [req]
     (let [resp (handler req)]
-      (if-let [id (get-in resp [:headers trace-id-header])]
-        (let [[_ [_ _ l]] (log-by-id id)]
-          (assoc-in resp [:headers "X-Liberator-Trace"]
-                    (map #(clojure.string/join " " %) l)))
-        resp))))
+      (if (async-response resp)
+        (update-in resp [:body] (partial map< wrap-trace-header-response))
+        (wrap-trace-header-response resp)))))
 
 (defn- cond-wrap [fn expr wrapper]
   (if expr (wrapper fn) fn))
 
+(defn wrap-trace-response
+  [request-log request response]
+  (if-not (empty? @request-log)
+    (do
+      (save-log! *current-id*
+                 [(Date.)
+                  (select-keys request [:request-method :uri :headers])
+                  @request-log])
+      (assoc-in response [:headers trace-id-header] *current-id*))
+    response))
+
 (defn wrap-trace
   "Wraps a ring handler such that a request trace is generated.
 
@@ -228,13 +254,10 @@
        (binding [*current-id* (next-id)]
          (core/with-logger (core/atom-logger request-log)
            (let [resp (handler request)]
-             (if-not (empty? @request-log)
-               (do
-                 (save-log! *current-id*
-                            [(Date.)
-                             (select-keys request [:request-method :uri :headers])
-                             @request-log])
-                 (assoc-in resp [:headers trace-id-header] *current-id*))
-               resp))))))
+             (if (async-response resp)
+               (->> (partial wrap-trace-response request-log request)
+                    (partial map<)
+                    (update-in resp [:body]))
+               (wrap-trace-response request-log request resp)))))))
    (cond-wrap (some #{:ui} opts) wrap-trace-ui)
    (cond-wrap (some #{:header} opts) wrap-trace-header)))
diff --git a/src/liberator/graph.clj b/src/liberator/graph.clj
index 68e4b45..2b7d630 100644
--- a/src/liberator/graph.clj
+++ b/src/liberator/graph.clj
@@ -81,7 +81,7 @@
          (concat (rank-handler-groups handlers))
          (concat (rank-same actions))
          (apply str)
-         (format "digraph{\nid=\"trace\"; size=\"1000,1000\"; page=\"1000,1000\";\n\nnode[shape=\"box\", splines=ortho]\n\"start\"[id=\"start\" shape=circle];\n\"start\" -> \"service-available?\" [id=start_serviceavailable]\n%s\n}"))))
+         (format "digraph{\nid=\"trace\"; size=\"1000,1000\"; page=\"1000,1000\";\n\nnode[shape=\"box\", splines=ortho]\n\"start\"[id=\"start\" shape=circle];\n\"start\" -> \"async?\" [id=start_async]\n%s\n}"))))
 
 (defn generate-graph-dot-file [f]
   (spit f (generate-graph-dot)))
diff --git a/src/liberator/trace.css b/src/liberator/trace.css
index 1e464d6..f5e91e5 100644
--- a/src/liberator/trace.css
+++ b/src/liberator/trace.css
@@ -1,7 +1,7 @@
 #start.node ellipse { stroke: #0000dd; fill: rgba(0,221,0,0.1); stroke-width: 3;}
 #start.node ellipse { stroke: #0000dd; fill: rgba(0,221,0,0.1); stroke-width: 3;}
-#start_serviceavailable path { stroke: #0000dd; stroke-width: 3;}
-#start_serviceavailable polygon { fill: #0000dd; stroke: #0000dd; stroke-width: 3;}
+#start_async path { stroke: #0000dd; stroke-width: 3;}
+#start_async polygon { fill: #0000dd; stroke: #0000dd; stroke-width: 3;}
 
 .node.hl-true polygon { stroke: #0000dd; stroke-width: 3;}
 .node.hl-true text { fill: #0000dd; }
diff --git a/src/liberator/trace.svg b/src/liberator/trace.svg
index 1730bbf..903f03b 100644
--- a/src/liberator/trace.svg
+++ b/src/liberator/trace.svg
@@ -15,15 +15,25 @@
 <text text-anchor="middle" x="679" y="-3912.4" font-family="Times,serif" font-size="14.00">start</text>
 </g>
 <!-- service&#45;available? -->
-<g id="serviceavailable" class="node"><title>service&#45;available?</title>
+<g id="async" class="node"><title>async?</title>
 <polygon fill="none" stroke="black" points="737.281,-3852 620.719,-3852 620.719,-3816 737.281,-3816 737.281,-3852"/>
-<text text-anchor="middle" x="679" y="-3828.4" font-family="Times,serif" font-size="14.00">service&#45;available?</text>
+<text text-anchor="middle" x="679" y="-3828.4" font-family="Times,serif" font-size="14.00">async?</text>
 </g>
-<!-- start&#45;&gt;service&#45;available? -->
-<g id="start_serviceavailable" class="edge"><title>start&#45;&gt;service&#45;available?</title>
+<!-- start&#45;&gt;async? -->
+<g id="start_async" class="edge"><title>start&#45;&gt;async?</title>
 <path fill="none" stroke="black" d="M679,-3890.15C679,-3881.25 679,-3871.34 679,-3862.4"/>
 <polygon fill="black" stroke="black" points="682.5,-3862.11 679,-3852.11 675.5,-3862.11 682.5,-3862.11"/>
 </g>
+<!-- service&#45;available? -->
+<g id="serviceavailable" class="node"><title>service&#45;available?</title>
+<polygon fill="none" stroke="black" points="737.281,-3752 620.719,-3752 620.719,-3716 737.281,-3716 737.281,-3752"/>
+<text text-anchor="middle" x="679" y="-3728.4" font-family="Times,serif" font-size="14.00">service&#45;available?</text>
+</g>
+<!-- start&#45;&gt;service&#45;available? -->
+<g id="async_serviceavailable" class="edge"><title>async&#45;&gt;service&#45;available?</title>
+<path fill="none" stroke="black" d="M679,-3816.15C679,-3781.25 679,-3771.34 679,-3762.4"/>
+<polygon fill="black" stroke="black" points="682.5,-3762.11 679,-3752.11 675.5,-3762.11 682.5,-3762.11"/>
+</g>
 <!-- handle&#45;service&#45;not&#45;available -->
 <g id="handleservicenotavailable" class="node"><title>handle&#45;service&#45;not&#45;available</title>
 <polygon fill="#e31a1c" stroke="black" points="132.534,-773.602 -0.534469,-773.602 -0.534469,-732.398 132.534,-732.398 132.534,-773.602"/>
@@ -32,7 +42,7 @@
 </g>
 <!-- service&#45;available?&#45;&gt;handle&#45;service&#45;not&#45;available -->
 <g id="serviceavailable_handleservicenotavailable" class="edge"><title>service&#45;available?&#45;&gt;handle&#45;service&#45;not&#45;available</title>
-<path fill="none" stroke="black" d="M620.501,-3830.69C467.278,-3823.86 66,-3800.67 66,-3745 66,-3745 66,-3745 66,-845 66,-824.625 66,-801.685 66,-783.934"/>
+<path fill="none" stroke="black" d="M620.501,-3730.69C467.278,-3723.86 66,-3700.67 66,-3645 66,-3645 66,-3645 66,-845 66,-824.625 66,-801.685 66,-783.934"/>
 <polygon fill="black" stroke="black" points="69.5001,-783.882 66,-773.882 62.5001,-783.882 69.5001,-783.882"/>
 <text text-anchor="middle" x="79.2139" y="-2298.4" font-family="Times,serif" font-size="14.00">false</text>
 </g>
@@ -43,9 +53,9 @@
 </g>
 <!-- service&#45;available?&#45;&gt;known&#45;method? -->
 <g id="serviceavailable_knownmethod" class="edge"><title>service&#45;available?&#45;&gt;known&#45;method?</title>
-<path fill="none" stroke="black" d="M737.33,-3830.16C1008.11,-3816.97 2141.25,-3761.79 2422.57,-3748.09"/>
+<path fill="none" stroke="black" d="M737.33,-3730.16C1008.11,-3716.97 2141.25,-3761.79 2422.57,-3748.09"/>
 <polygon fill="black" stroke="black" points="2422.79,-3751.58 2432.61,-3747.6 2422.45,-3744.59 2422.79,-3751.58"/>
-<text text-anchor="middle" x="1754.88" y="-3783.4" font-family="Times,serif" font-size="14.00">true</text>
+<text text-anchor="middle" x="1754.88" y="-3753.4" font-family="Times,serif" font-size="14.00">true</text>
 </g>
 <!-- post! -->
 <g id="trace_node5" class="node"><title>post!</title>