Schema Bijections

schema_bijections.clj

;; example use at the bottom

(ns user
  (:require [schema.core :as s]
            [camel-snake-kebab.core :as csk]
            [plumbing.core :refer [for-map map-keys map-vals]]))
          
(defn key->keyword
  [k]
  (cond (keyword? k) k
        (s/optional-key? k) (:k k)
        :else (throw (ex-info "WTF? in key->keyword" {:k k}))))

(defn key-fmap
  [f k]
  ;; MONADS!
  (cond (keyword? k) (f k)
        (s/optional-key? k) (s/optional-key (f (:k k)))
        :else (throw (ex-info "WTF?" {:k k}))))


(defmulti jsonify-schema*
  "Returns [json-schema to-json from-json], where json-schema
  is a variant of the given schema that describes how it looks
  in json, and to-json and from-json are conversion functions."
  (fn [schema opts] (type schema)))

(defmethod jsonify-schema* :default
  [schema opts]
  (let [jsonify-schema* #(jsonify-schema* % opts)]
    (cond (and (map? schema) (not (record? schema)))
          (cond (every? #(or (keyword? %)
                             (and (s/optional-key? %)
                                  (keyword? (:k %))))
                        (keys schema))
                (let [recursion-by-internal-key
                      (->> schema
                           (map-keys key->keyword)
                           (map-vals jsonify-schema*))

                      key-to-json
                      (for-map [k (keys recursion-by-internal-key)]
                        k (-> k name (cond-> (:key-fn opts) ((:key-fn opts)))))

                      key-from-json
                      (for-map [[k v] key-to-json] v k)

                      json-schema
                      (for-map [[k _v] schema]
                        (let [k2 (key-fmap key-to-json k)]
                          (cond-> k2 (string? k2) (s/required-key)))
                        (first (recursion-by-internal-key (key->keyword k))))

                      to-json
                      (fn to-json [m]
                        (for-map [[k v] m
                                  :let [[_sch to] (get recursion-by-internal-key k)
                                        ;; I think this kind of checking can be handled
                                        ;; by schema proper once we rewrite this stuff in
                                        ;; a more integrated way
                                        k' (or (key-to-json k)
                                               (throw (ex-info "Value does not match schema!"
                                                               {:schema schema :value m})))]]
                          k' (to v)))

                      from-json
                      (fn from-json [m]
                        (for-map [[k v] m
                                  :let [k' (or (key-from-json k)
                                               (throw (ex-info "Value does not match schema!"
                                                               {:schema json-schema :value m})))
                                        [_sch _to from] (get recursion-by-internal-key k')]]
                          k' (from v)))]
                  [json-schema to-json from-json])

                (= 1 (count schema))
                (let [[[key-schema val-schema]] (seq schema)
                      [key-json-schema key-to-json key-from-json] (jsonify-schema* key-schema)
                      [val-json-schema val-to-json val-from-json] (jsonify-schema* val-schema)]
                  ;; this will go poorly if key-json-schema doesn't end
                  ;; up being String here, but I think we'll be fine for
                  ;; now
                  [{key-json-schema val-json-schema}
                   (fn to-json [m]
                     (for-map [[k v] m]
                       (key-to-json k)
                       (val-to-json v)))
                   (fn from-json [m]
                     (for-map [[k v] m]
                       (key-from-json k)
                       (val-from-json v)))]))

          (vector? schema)
          (do
            (assert (= 1 (count schema)) "Don't support tuple schemas yet")
            (let [[el-schema] schema
                  [el-json-schema el-to-json el-from-json] (jsonify-schema* el-schema)]
              [[el-json-schema] #(mapv el-to-json %) #(mapv el-from-json %)]))

          (= s/Keyword schema)
          [s/Str name keyword]

          (= java.util.UUID schema)
          [#"[0-9a-f]{8}-(?:[0-9a-f]{4}-){3}[0-9a-f]{12}"
           str
           #(java.util.UUID/fromString %)]

          :else
          [schema identity identity])))

(defn pluralable-query-param
  "Creates a collection schema for the given schema, to be used as a query parameter
  where multiple values might be supplied (which causes ring to deliver either a string
  or a vector of strings); the associated conversion functions will ensure that after
  parsing from json it is always a vector of values."
  [schema]
  (-> [schema]
      (vary-meta assoc :type ::pluralable-query-param)))

(defmethod jsonify-schema* ::pluralable-query-param
  [schema opts]
  (let [[sch to from] (jsonify-schema* (first schema) opts)]
    [(s/either sch [sch])
     (fn to-json
       [xs]
       (cond-> (mapv to xs)
         (= 1 (count xs))
         (first)))
     (fn from-json
       [x-or-xs]
       (-> x-or-xs
           (cond-> (not (vector? x-or-xs)) (vector))
           (->> (mapv from))))]))

(defn jsonify-schema
  "Wrapper for jsonify-schema* that supplies default options and wraps exceptions
  thrown in the conversion functions."
  ([schema] (jsonify-schema schema {:key-fn csk/->camelCase}))
  ([schema opts]
   (letfn [(wrap-errors [func]
             (fn [x]
               (try (func x)
                    (catch Throwable t
                      (throw (ex-info "Schema bijection error!"
                                      {:schema schema :data x}
                                      t))))))]
     (let [[sch to from] (jsonify-schema* schema opts)]
       [sch (wrap-errors to) (wrap-errors from)]))))
     
;; Example usage:

(def User
  {:first-name s/Str
   :last-name s/Str
   :id s/Uuid})
 
(let [[json-schema to-json from-json] (jsonify-schema User)]
  (def UserJSON json-schema)
  (def User->JSON to-json)
  (def User<-JSON from-json))
 
UserJSON
;; => {#schema.core.RequiredKey{:k "firstName"} java.lang.String,
;;     #schema.core.RequiredKey{:k "id"} #"[0-9a-f]{8}-(?:[0-9a-f]{4}-){3}[0-9a-f]{12}",
;;     #schema.core.RequiredKey{:k "lastName"} java.lang.String}

;; readability of ^that could be better

(def the-donald {:id #uuid "2d6f4693-8af4-47eb-8c13-7b8671dc26e1"
                 :first-name "Donald"
                 :last-name "Trump"})
               
(User->JSON the-donald)
;; => {"firstName" "Donald",
;;     "id" "2d6f4693-8af4-47eb-8c13-7b8671dc26e1",
;;     "lastName" "Trump"}

;; round-trips:
(-> the-donald User->JSON User<-JSON (= the-donald))
;; => true

key->keyword is s/explicit-schema-key.