backport coercion

src/compojure/api/coercion.clj

@@ -0,0 +1,99 @@
+(ns compojure.api.coercion
+  (:require [clojure.walk :as walk]
+            [compojure.api.exception :as ex]
+            [compojure.api.request :as request]
+            [compojure.api.coercion.core :as cc]
+            ;; side effects
+            compojure.api.coercion.register-schema
+            compojure.api.coercion.register-spec)
+  (:import (compojure.api.coercion.core CoercionError)))
+
+(def default-coercion :schema)
+
+(defn set-request-coercion [request coercion]
+  (assoc request ::request/coercion coercion))
+
+(defn get-request-coercion [request]
+  (if-let [entry (find request ::request/coercion)]
+    (val entry)
+    default-coercion))
+
+(defn resolve-coercion [coercion]
+  (cond
+    (nil? coercion) nil
+    (keyword? coercion) (cc/named-coercion coercion)
+    (satisfies? cc/Coercion coercion) coercion
+    :else (throw (ex-info (str "invalid coercion " coercion) {:coercion coercion}))))
+
+(defn get-apidocs [maybe-coercion spec info]
+  (if-let [coercion (resolve-coercion maybe-coercion)]
+    (cc/get-apidocs coercion spec info)))
+
+(defn coerce-request! [model in type keywordize? open? request]
+  (let [transform (if keywordize? walk/keywordize-keys identity)
+        value (transform (in request))]
+    (if-let [coercion (-> request
+                          (get-request-coercion)
+                          (resolve-coercion))]
+      (let [model (if open? (cc/make-open coercion model) model)
+            format (some-> request :muuntaja/request :format)
+            result (cc/coerce-request coercion model value type format request)]
+        (if (instance? CoercionError result)
+          (throw (ex-info
+                   (str "Request validation failed: " (pr-str result))
+                   (merge
+                     (into {} result)
+                     {:type ::ex/request-validation
+                      :coercion coercion
+                      :value value
+                      :in [:request in]
+                      :request request})))
+          result))
+      value)))
+
+(defn coerce-response! [request {:keys [status body] :as response} responses]
+  (if-let [model (or (:schema (get responses status))
+                     (:schema (get responses :default)))]
+    (if-let [coercion (-> request
+                          (get-request-coercion)
+                          (resolve-coercion))]
+      (let [format (or (-> response :muuntaja/content-type)
+                       (some-> request :muuntaja/response :format))
+            accept? (cc/accept-response? coercion model)]
+        (if accept?
+          (let [result (cc/coerce-response coercion model body :response format response)]
+            (if (instance? CoercionError result)
+              (throw (ex-info
+                       (str "Response validation failed: " (pr-str result))
+                       (merge
+                         (into {} result)
+                         {:type ::ex/response-validation
+                          :coercion coercion
+                          :value body
+                          :in [:response :body]
+                          :request request
+                          :response response})))
+              (assoc response
+                :compojure.api.meta/serializable? true
+                :body result)))
+          response))
+      response)
+    response))
+
+;;
+;; middleware
+;;
+
+(defn wrap-coerce-response [handler responses]
+  (fn
+    ([request]
+     (coerce-response! request (handler request) responses))
+    ([request respond raise]
+     (handler
+       request
+       (fn [response]
+         (try
+           (respond (coerce-response! request response responses))
+           (catch Exception e
+             (raise e))))
+       raise))))

src/compojure/api/coercion/register_schema.clj

@@ -0,0 +1,8 @@
+(ns compojure.api.coercion.register-schema
+  (:require [compojure.api.coercion.core :as cc]))
+
+(defmethod cc/named-coercion :schema [_] 
+  (deref
+    (or (resolve 'compojure.api.coercion.schema/default-coercion)
+        (do (require 'compojure.api.coercion.schema)
+            (resolve 'compojure.api.coercion.schema/default-coercion)))))

src/compojure/api/coercion/register_spec.clj

@@ -0,0 +1,8 @@
+(ns compojure.api.coercion.register-spec
+  (:require [compojure.api.coercion.core :as cc]))
+
+(defmethod cc/named-coercion :spec [_]
+  (deref
+    (or (resolve 'compojure.api.coercion.spec/default-coercion)
+        (do (require 'compojure.api.coercion.spec)
+            (resolve 'compojure.api.coercion.spec/default-coercion)))))

src/compojure/api/coercion/schema.clj

@@ -5,7 +5,9 @@
             [compojure.api.coercion.core :as cc]
             [clojure.walk :as walk]
             [schema.core :as s]
-            [compojure.api.common :as common])
+            [compojure.api.common :as common]
+            ;; side effects
+            compojure.api.coercion.register-schema)
   (:import (java.io File)
            (schema.core OptionalKey RequiredKey)
            (schema.utils ValidationError NamedError)))
@@ -84,5 +86,3 @@
   (->SchemaCoercion :schema options))
 
 (def default-coercion (create-coercion default-options))
-
-(defmethod cc/named-coercion :schema [_] default-coercion)

src/compojure/api/coercion/spec.clj

@@ -0,0 +1,153 @@
+(ns compojure.api.coercion.spec
+  (:require [schema.core]
+            [clojure.spec.alpha :as s]
+            [spec-tools.core :as st]
+            [spec-tools.data-spec :as ds]
+            [clojure.walk :as walk]
+            [compojure.api.coercion.core :as cc]
+            [spec-tools.swagger.core :as swagger]
+            [compojure.api.common :as common]
+            ;; side effects
+            compojure.api.coercion.register-spec)
+  (:import (clojure.lang IPersistentMap)
+           (schema.core RequiredKey OptionalKey)
+           (spec_tools.core Spec)
+           (spec_tools.data_spec Maybe)))
+
+(def string-transformer
+  (st/type-transformer
+    st/string-transformer
+    st/strip-extra-keys-transformer
+    {:name :string}))
+
+(def json-transformer
+  (st/type-transformer
+    st/json-transformer
+    st/strip-extra-keys-transformer
+    {:name :json}))
+
+(defn default-transformer
+  ([] (default-transformer :default))
+  ([name] (st/type-transformer {:name name})))
+
+(defprotocol Specify
+  (specify [this name]))
+
+(extend-protocol Specify
+  IPersistentMap
+  (specify [this name]
+    (-> (->>
+          (walk/postwalk
+            (fn [x]
+              (if (and (map? x) (not (record? x)))
+                (->> (for [[k v] (dissoc x schema.core/Keyword)
+                           :let [k (cond
+                                     ;; Schema required
+                                     (instance? RequiredKey k)
+                                     (ds/req (schema.core/explicit-schema-key k))
+
+                                     ;; Schema options
+                                     (instance? OptionalKey k)
+                                     (ds/opt (schema.core/explicit-schema-key k))
+
+                                     :else
+                                     k)]]
+                       [k v])
+                     (into {}))
+                x))
+            this)
+          (ds/spec name))
+        (dissoc :name)))
+
+  Maybe
+  (into-spec [this name]
+    (ds/spec name this))
+
+  Spec
+  (specify [this _] this)
+
+  Object
+  (specify [this _]
+    (st/create-spec {:spec this})))
+
+(def memoized-specify
+  (common/fifo-memoize #(specify %1 (keyword "spec" (name (gensym "")))) 1000))
+
+(defn maybe-memoized-specify [spec]
+  (if (keyword? spec)
+    (specify spec nil)
+    (memoized-specify spec)))
+
+(defn stringify-pred [pred]
+  (str (if (instance? clojure.lang.LazySeq pred)
+         (seq pred)
+         pred)))
+
+(defmulti coerce-response? identity :default ::default)
+(defmethod coerce-response? ::default [_] true)
+
+(defrecord SpecCoercion [name options]
+  cc/Coercion
+  (get-name [_] name)
+
+  (get-apidocs [_ _ {:keys [parameters responses] :as info}]
+    (cond-> (dissoc info :parameters :responses)
+            parameters (assoc
+                         ::swagger/parameters
+                         (into
+                           (empty parameters)
+                           (for [[k v] parameters]
+                             [k (maybe-memoized-specify v)])))
+            responses (assoc
+                        ::swagger/responses
+                        (into
+                          (empty responses)
+                          (for [[k response] responses]
+                            [k (update response :schema #(some-> % maybe-memoized-specify))])))))
+
+  (make-open [_ spec] spec)
+
+  (encode-error [_ error]
+    (let [problems (-> error :problems ::s/problems)]
+      (-> error
+          (update :spec (comp str s/form))
+          (assoc :problems (mapv #(update % :pred stringify-pred) problems)))))
+
+  (coerce-request [_ spec value type format _]
+    (let [spec (maybe-memoized-specify spec)
+          type-options (options type)]
+      (if-let [transformer (or (get (get type-options :formats) format)
+                               (get type-options :default))]
+        (let [coerced (st/coerce spec value transformer)]
+          (if (s/valid? spec coerced)
+            coerced
+            (let [conformed (st/conform spec coerced transformer)]
+              (if (s/invalid? conformed)
+                (let [problems (st/explain-data spec coerced transformer)]
+                  (cc/map->CoercionError
+                    {:spec spec
+                     :problems problems}))
+                (s/unform spec conformed)))))
+        value)))
+
+  (accept-response? [_ spec]
+    (boolean (coerce-response? spec)))
+
+  (coerce-response [this spec value type format request]
+    (cc/coerce-request this spec value type format request)))
+
+(def default-options
+  {:body {:default (default-transformer)
+          :formats {"application/json" json-transformer
+                    "application/msgpack" json-transformer
+                    "application/x-yaml" json-transformer}}
+   :string {:default string-transformer}
+   :response {:default (default-transformer)
+              :formats {"application/json" (default-transformer :json)
+                        "application/msgpack" (default-transformer :json)
+                        "application/x-yaml" (default-transformer :json)}}})
+
+(defn create-coercion [options]
+  (->SpecCoercion :spec options))
+
+(def default-coercion (create-coercion default-options))