initial commit

js/ajax/core.cljs

@@ -0,0 +1,460 @@
+(ns ajax.core
+  (:require goog.net.EventType
+            goog.net.ErrorCode
+            [goog.net.XhrIo :as xhr]
+            [goog.net.XhrManager :as xhrm]
+            [goog.Uri :as uri]
+            [goog.json :as goog-json]
+            [goog.Uri.QueryData :as query-data]
+            [goog.json.Serializer]
+            [goog.events :as events]
+            [goog.structs :as structs]
+            [cljs.reader :as reader]
+            [clojure.string :as str]
+            [cognitect.transit :as t])
+  (:require-macros [ajax.macros :as m]
+                   [poppea :as p]))
+
+(defprotocol AjaxImpl
+  "An abstraction for a javascript class that implements
+   Ajax calls."
+  (-js-ajax-request [this uri method body headers handler opts]
+    "Makes an actual ajax request.  All parameters except opts
+     are in JS format.  Should return an AjaxRequest."))
+
+(defprotocol AjaxRequest
+  "An abstraction for a running ajax request."
+  (-abort [this]
+    "Aborts a running ajax request, if possible."))
+
+(defprotocol DirectlySubmittable
+  "A marker interface for types that can be directly sent to XhrIo.")
+
+(defprotocol AjaxResponse
+  "An abstraction for an ajax response."
+  (-status [this]
+    "Returns the HTTP Status of the response as an integer.")
+  (-status-text [this]
+    "Returns the HTTP Status Text of the response as a string.")
+  (-body [this]
+    "Returns the response body as a string or as type specified in response-format
+    such as a blob or arraybuffer.")
+  (-get-response-header [this header]
+    "Gets the specified response header (specified by a string) as a string.")
+  (-was-aborted [this]
+    "Was the response aborted."))
+
+(m/register-directly-submittable js/FormData js/ArrayBufferView
+                                 js/Blob js/Document)
+
+(defn submittable? [params]
+  (or (satisfies? DirectlySubmittable params)
+      (string? params)))
+
+(extend-type goog.net.XhrIo
+  AjaxImpl
+  (-js-ajax-request
+    [this uri method body headers handler
+     {:keys [timeout with-credentials]
+      :or {with-credentials false
+           timeout 0}}]
+    (doto this
+      (events/listen goog.net.EventType/COMPLETE
+                     #(handler (.-target %)))
+      (.setTimeoutInterval timeout)
+      (.setWithCredentials with-credentials)
+      (.send uri method body (clj->js headers))))
+  AjaxRequest
+  (-abort [this] (.abort this goog.net.ErrorCode/ABORT))
+  AjaxResponse
+  (-body [this] (.getResponseText this))
+  (-status [this] (.getStatus this))
+  (-status-text [this] (.getStatusText this))
+  (-get-response-header [this header]
+    (.getResponseHeader this header))
+  (-was-aborted [this]
+    (= (.getLastErrorCode this) goog.net.ErrorCode/ABORT)))
+
+(defn ready-state
+  [e]
+  ({0 :not-initialized
+    1 :connection-established
+    2 :request-received
+    3 :processing-request
+    4 :response-ready} (.-readyState (.-target e))))
+
+(extend-type js/XMLHttpRequest
+  AjaxImpl
+  (-js-ajax-request
+    [this uri method body headers handler
+     {:keys [timeout with-credentials response-format]
+      :or {with-credentials false
+           timeout 0}}]
+    (set! (.-withCredentials this) with-credentials)
+    (set! (.-onreadystatechange this) #(when (= :response-ready (ready-state %)) (handler this)))
+    (.open this method uri true)
+    (set! (.-timeout this) timeout)
+                                        ; IE8 needs timeout to be set between open and send
+                                        ; https://msdn.microsoft.com/en-us/library/cc304105(v=vs.85).aspx
+    (when-let [response-type (:type response-format)]
+      (set! (.-responseType this) (name response-type)))
+    (doseq [[k v] headers]
+      (.setRequestHeader this k v))
+    (.send this (or body ""))
+    this)
+  AjaxRequest
+  (-abort [this] (.abort this))
+  AjaxResponse
+  (-body [this] (.-response this))
+  (-status [this] (.-status this))
+  (-status-text [this] (.-statusText this))
+  (-get-response-header [this header]
+    (.getResponseHeader this header))
+  (-was-aborted [this] (= 0 (.-readyState this))))
+
+(extend-type goog.net.XhrManager
+  AjaxImpl
+  (-js-ajax-request
+    [this uri method body headers handler
+     {:keys [id timeout priority max-retries]}]
+    (.send this id uri method body (clj->js headers)
+           priority handler max-retries)))
+
+(defn abort ([this] (-abort this)))
+
+(defn success? [status]
+  (some #{status} [200 201 202 204 205 206]))
+
+;;; Standard Formats
+
+(defn read-edn [xhrio]
+  (reader/read-string (-body xhrio)))
+
+(defn edn-response-format
+  ([] {:read read-edn
+       :description "EDN"
+       :content-type "application/edn"})
+  ([opts] (edn-response-format)))
+
+(defn edn-request-format []
+  {:write pr-str
+   :content-type "application/edn"})
+
+(p/defn-curried transit-write
+  [writer params]
+  (t/write writer params))
+
+(defn transit-request-format
+  ([] (transit-request-format {}))
+  ([{:keys [type writer] :as opts}]
+     (let [writer (or writer (t/writer (or type :json) opts))]
+       {:write (transit-write writer)
+        :content-type "application/transit+json"})))
+
+(p/defn-curried transit-read [reader raw xhrio]
+  (let [text (-body xhrio)
+        data (t/read reader text)]
+    (if raw data (js->clj data))))
+
+(defn transit-response-format
+  ([] (transit-response-format {}))
+  ([{:keys [type reader raw] :as opts}]
+   (let [reader (or reader (t/reader (or type :json) opts))]
+     {:read (transit-read reader raw)
+      :description "Transit"
+      :content-type "application/transit+json"})))
+
+(defn params-to-str [params]
+  (if params
+    (-> params
+        clj->js
+        structs/Map.
+        query-data/createFromMap
+        .toString)))
+
+(defn url-request-format []
+  {:write params-to-str
+   :content-type "application/x-www-form-urlencoded"})
+
+(defn raw-response-format
+  ([] {:read -body :description "raw text" :content-type "*/*"})
+  ([opts] (raw-response-format)))
+
+(defn write-json [data]
+  (.serialize (goog.json.Serializer.) (clj->js data)))
+
+(defn json-request-format []
+  {:write write-json
+   :content-type "application/json"})
+
+(p/defn-curried json-read [prefix raw keywords? xhrio]
+  (let [text (-body xhrio)
+        text (if (and prefix (= 0 (.indexOf text prefix)))
+               (.substring text (.length prefix))
+               text)
+        json (goog-json/parse text)]
+    (if raw
+      json
+      (js->clj json :keywordize-keys keywords?))))
+
+(defn json-response-format
+  "Returns a JSON response format.  Options include
+   :keywords? Returns the keys as keywords
+   :prefix A prefix that needs to be stripped off.  This is to
+   combat JSON hijacking.  If you're using JSON with GET request,
+   you should think about using this.
+   http://stackoverflow.com/questions/2669690/why-does-google-prepend-while1-to-their-json-responses
+   http://haacked.com/archive/2009/06/24/json-hijacking.aspx"
+  ([] (json-response-format {}))
+  ([{:keys [prefix keywords? raw]}]
+     {:read (json-read prefix raw keywords?)
+      :description (str "JSON"
+                        (if prefix (str " prefix '" prefix "'"))
+                        (if keywords? " keywordize"))
+      :content-type "application/json"}))
+
+;;; Detection and Accept Code
+
+(def default-formats
+  [json-response-format
+   edn-response-format
+   transit-response-format
+   ["text/plain" raw-response-format]
+   ["text/html" raw-response-format]
+   raw-response-format])
+
+(p/defn-curried get-format [opts format-entry]
+  (cond (vector? format-entry) (get-format opts
+                                           (second format-entry))
+        (map? format-entry) format-entry
+        ; Must be a format generating function
+        :else (format-entry opts)))
+
+(p/defn-curried accept-entry [opts format-entry]
+  (or (if (vector? format-entry)
+        (first format-entry)
+        (:content-type (get-format opts format-entry)))
+      "*/*"))
+
+(p/defn-curried detect-content-type [content-type opts format-entry]
+  (let [accept (accept-entry opts format-entry)]
+    (or (= accept "*/*")
+        (>= (.indexOf content-type accept) 0))))
+
+(defn get-default-format [xhrio {:keys [response-format] :as opts}]
+  (let [f (detect-content-type
+           (or (-get-response-header xhrio "Content-Type") "")
+           opts)]
+    (->> response-format
+         (filter f)
+         first
+         (get-format opts))))
+
+(p/defn-curried detect-response-format-read
+  [opts xhrio]
+  ((:read (get-default-format xhrio opts)) xhrio))
+
+(defn accept-header [{:keys [response-format] :as opts}]
+  (if (vector? response-format)
+    (str/join ", " (map (accept-entry opts) response-format))
+    (accept-entry opts response-format)))
+
+(defn detect-response-format
+  ([] (detect-response-format {:response-format default-formats}))
+  ([opts]
+     (let [accept (accept-header opts)]
+       {:read (detect-response-format-read opts)
+        :format (str "(from " accept ")")
+        :content-type accept})))
+
+;;; AJAX calls
+
+(defn get-response-format [{:keys [response-format] :as opts}]
+  (cond
+   (vector? response-format) (detect-response-format opts)
+   (map? response-format) response-format
+   (ifn? response-format) {:read response-format
+                           :description "custom"
+                           :content-type "*/*"}
+   :else (throw (js/Error. (str "unrecognized response format: " response-format)))))
+
+(defn exception-response [e status {:keys [description]} xhrio]
+  (let [response {:status status
+                  :failure :error
+                  :response nil}
+        status-text (str (.-message e)
+                         "  Format should have been "
+                         description)
+        parse-error (assoc response
+                      :status-text status-text
+                      :failure :parse
+                      :original-text (-body xhrio))]
+    (if (success? status)
+      parse-error
+      (assoc response
+        :status-text (-status-text xhrio)
+        :parse-error parse-error))))
+
+(defn fail [status status-text failure & params]
+  (let [response {:status status
+                  :status-text status-text
+                  :failure failure}]
+    [false (reduce conj
+                   response
+                   (map vec (partition 2 params)))]))
+
+(defn interpret-response [{:keys [read] :as format} xhrio]
+  (try
+    (let [status (-status xhrio)
+          fail (partial fail status)]
+      (case status
+        -1 (if (-was-aborted xhrio)
+             (fail "Request aborted by client." :aborted)
+             (fail "Request timed out." :timeout))
+        204 [true nil]         ; 204 and 205 should have empty responses
+        205 [true nil]
+        (try
+          (let [response (read xhrio)]
+            (if (success? status)
+              [true response]
+              (fail (-status-text xhrio) :error :response response)))
+          (catch js/Object e
+            [false (exception-response e status format xhrio)]))))
+    (catch js/Object e
+                                        ; These errors should never happen
+      (fail 0 (.-message e) :exception :exception e))))
+
+(defn no-format [xhrio]
+  (throw (js/Error. "No response format was supplied.")))
+
+(defn uri-with-params [uri params]
+  (if params
+    (str uri
+         (if (re-find #"\?" uri) "&" "?") ; add & if uri contains ?
+         (params-to-str params))
+    uri))
+
+(defn get-request-format [format]
+  (cond
+   (map? format) format
+   (ifn? format) {:write format :content-type "text/plain"}
+   :else nil))
+
+(defn normalize-method [method]
+  (if (keyword? method)
+    (str/upper-case (name method))
+    method))
+
+(defn process-inputs [{:keys [uri method format params headers]}
+                      {:keys [content-type]}]
+  (let [headers (merge {"Accept" content-type}
+                       (or headers {}))]
+    (if (= (normalize-method method) "GET")
+      [(uri-with-params uri params) nil headers]
+      (let [{:keys [write content-type]}
+            (get-request-format format)
+            body (cond
+                  (not (nil? write)) (write params)
+                  (submittable? params) params
+                  :else (throw (js/Error. (str "unrecognized request format: " format))))
+            content-type (if content-type
+                           {"Content-Type" (str content-type "; charset=utf-8")})
+            headers (merge headers content-type)]
+        [uri body headers]))))
+
+(p/defn-curried js-handler [response-format handler xhrio]
+  (let [response
+        (interpret-response response-format xhrio)]
+    (handler response)))
+
+(defn base-handler [response-format {:keys [handler]}]
+  (if handler
+    (js-handler response-format handler)
+    (throw (js/Error. "No ajax handler provided."))))
+
+(defn ajax-request
+  [{:keys [method api] :as opts}]
+  (let [response-format (get-response-format opts)
+        method (normalize-method method)
+        [uri body headers] (process-inputs opts response-format)
+        handler (base-handler response-format opts)
+        api (or api (new goog.net.XhrIo))]
+    (-js-ajax-request api uri method body
+                      headers handler opts)))
+
+;;; "Easy" API beyond this point
+
+(defn keyword-request-format [format format-params]
+  (cond
+   (map? format) format
+   (fn? format) {:write format}
+   (nil? format) (transit-request-format format-params)
+   :else (case format
+           :transit (transit-request-format format-params)
+           :json (json-request-format)
+           :edn (edn-request-format)
+           :raw (url-request-format)
+           :url (url-request-format)
+           nil)))
+
+(defn keyword-response-format-2 [format format-params]
+  (cond
+   (vector? format) [(first format)
+                  (keyword-response-format-2 (second format)
+                                             format-params)]
+   (map? format) format
+   (fn? format) {:read format :description "custom"}
+   (nil? format) (detect-response-format)
+   :else (case format
+           :transit (transit-response-format format-params)
+           :json (json-response-format format-params)
+           :edn (edn-response-format)
+           :raw (raw-response-format)
+           :detect (detect-response-format)
+           nil)))
+
+(defn keyword-response-format [format format-params]
+  (if (vector? format)
+    (->> format
+         (map #(keyword-response-format-2 % format-params))
+         (apply vector))
+    (keyword-response-format-2 format format-params)))
+
+(p/defn-curried transform-handler
+  [{:keys [handler error-handler finally]} [ok result]]
+  (if-let [h (if ok handler error-handler)]
+    (h result))
+  (when (fn? finally)
+    (finally)))
+
+(defn transform-opts [{:keys [method format response-format params]
+                       :as opts}]
+  "Note that if you call GET, POST et al, this function gets
+   called and will include JSON and EDN code in your JS.
+   If you don't want this to happen, use ajax-request directly
+   (and use advanced optimisation)."
+  (let [needs-format
+        (not (or (submittable? params)
+                 (= method "GET")))
+        rf (if (or format needs-format)
+             (keyword-request-format format opts))]
+    (assoc opts
+      :handler (transform-handler opts)
+      :format rf
+      :response-format (keyword-response-format response-format opts))))
+
+(defn easy-ajax-request [uri method opts]
+  (-> opts
+      (assoc :uri uri
+             :method method)
+      ajax.core/transform-opts
+      ajax.core/ajax-request))
+
+(m/easy-api GET)
+(m/easy-api HEAD)
+(m/easy-api POST)
+(m/easy-api PUT)
+(m/easy-api DELETE)
+(m/easy-api OPTIONS)
+(m/easy-api TRACE)
+(m/easy-api PATCH)