636 lines
25 KiB
Clojure
636 lines
25 KiB
Clojure
(ns auto-ap.ssr.utils
|
|
(:require [auto-ap.datomic :refer [all-schema conn]]
|
|
[auto-ap.logging :as alog]
|
|
[auto-ap.time :as atime]
|
|
[clj-time.coerce :as coerce]
|
|
[clj-time.core :as time]
|
|
[clojure.string :as str]
|
|
[datomic.api :as dc]
|
|
[hiccup2.core :as hiccup]
|
|
[hiccup.compiler :refer [HtmlRenderer render-html]]
|
|
[malli.core :as mc]
|
|
[malli.core :as m]
|
|
[malli.error :as me]
|
|
[malli.registry :as mr]
|
|
[malli.transform :as mt2]
|
|
[slingshot.slingshot :refer [throw+ try+]]
|
|
[taoensso.encore :refer [filter-vals]]))
|
|
|
|
(defrecord OOBElements [elements]
|
|
HtmlRenderer
|
|
(render-html [this]
|
|
(str/join "\n" (map render-html elements))))
|
|
|
|
(defn html-response [hiccup & {:keys [status headers oob] :or {status 200 headers {} oob []}}]
|
|
{:status status
|
|
:headers (into {"Content-Type" "text/html"}
|
|
headers)
|
|
:body (str
|
|
(hiccup/html
|
|
{}
|
|
hiccup)
|
|
"\n"
|
|
(str/join "\n"
|
|
(map (fn [o]
|
|
(hiccup/html
|
|
{}
|
|
o))
|
|
oob)))})
|
|
|
|
(defn modal-response [hiccup & {:as opts}]
|
|
(apply html-response
|
|
(into
|
|
[hiccup]
|
|
(mapcat identity
|
|
(-> opts
|
|
(update-in [:headers "hx-trigger"] (fn [ht] (str/join ", " (filter identity [ht "modalopen"]))))
|
|
(assoc-in [:headers "hx-retarget"] "#modal-content")
|
|
(assoc-in [:headers "hx-reswap"] "innerHTML"))))))
|
|
|
|
(defn modal-replace-response [hiccup & {:as opts}]
|
|
(apply html-response
|
|
(into
|
|
[hiccup]
|
|
(mapcat identity
|
|
(-> opts
|
|
(assoc-in [:headers "hx-trigger"] "modalswap")
|
|
(assoc-in [:headers "hx-retarget"] "#modal-content")
|
|
(assoc-in [:headers "hx-reswap"] "innerHTML"))))))
|
|
|
|
(defn next-step-modal-response [hiccup & {:as opts}]
|
|
(apply html-response
|
|
(into
|
|
[hiccup]
|
|
(mapcat identity
|
|
(-> opts
|
|
(assoc-in [:headers "hx-retarget"] "#modal-content")
|
|
(assoc-in [:headers "hx-reswap"] "innerHTML"))))))
|
|
|
|
|
|
|
|
(defn form-data->map [form-data]
|
|
(reduce-kv
|
|
(fn [acc k v]
|
|
(cond (and (string? v)
|
|
(empty? v))
|
|
acc
|
|
|
|
:else
|
|
(assoc-in acc (->> (str/split k #"_")
|
|
(mapv #(apply keyword (str/split % #"/"))))
|
|
v)))
|
|
{}
|
|
form-data))
|
|
|
|
(defn path->name [k]
|
|
(cond (keyword? k)
|
|
(str (namespace k) "/" (name k))
|
|
|
|
(seq k)
|
|
(str/join "_" (map path->name k))
|
|
:else k))
|
|
|
|
|
|
(defn forced-vector [x]
|
|
[:vector {:decode/json {:enter (fn [x]
|
|
(if (sequential? x)
|
|
x
|
|
[x]))}}
|
|
x])
|
|
|
|
(defn empty->nil [v]
|
|
(if (and (string? v) (clojure.string/blank? v))
|
|
nil
|
|
v))
|
|
|
|
(defn parse-empty-as-nil []
|
|
(mt2/transformer
|
|
{:decoders
|
|
{:map (fn [m]
|
|
(if (and (map? m) (not (seq (filter identity (vals m)))))
|
|
nil
|
|
m))
|
|
:string empty->nil
|
|
:double empty->nil
|
|
:int empty->nil
|
|
:long empty->nil
|
|
'nat-int? empty->nil}}))
|
|
|
|
(def raw-entity-id [nat-int? {:error/message "required"
|
|
:decode/arbitrary (fn [e]
|
|
(if (and (map? e) (:db/id e))
|
|
(:db/id e)
|
|
e))}])
|
|
|
|
(def entity-id (mc/schema [nat-int? {:error/message "required"
|
|
:decode/arbitrary (fn [e]
|
|
(if (and (map? e) (:db/id e))
|
|
(:db/id e)
|
|
e))}]))
|
|
|
|
(def temp-id (mc/schema [:string {:min 1}]))
|
|
(def money (mc/schema [:double]))
|
|
(def percentage (mc/schema [:double {:decode/string {:enter (fn [x]
|
|
(if (and (string? x) (re-find #"^\d+(\.\d+)?$" x))
|
|
(-> x (Double/parseDouble) (* 0.01))
|
|
x))}
|
|
:max 1.0
|
|
:error/message "1-100"}]))
|
|
|
|
(def regex (mc/schema [:fn {:error/message "not a regex"}
|
|
(fn check-regx [x]
|
|
(try
|
|
(and (string? x)
|
|
(. java.util.regex.Pattern (compile x java.util.regex.Pattern/CASE_INSENSITIVE)))
|
|
true
|
|
(catch Exception _
|
|
false)))]))
|
|
|
|
(def map->db-id-decoder
|
|
{:enter (fn [x]
|
|
(if (sequential? x)
|
|
x
|
|
(into []
|
|
(for [[k v] (sort-by (comp #(Long/parseLong %) first) x)]
|
|
v))))})
|
|
|
|
(defn many-entity [params & keys]
|
|
(mc/schema
|
|
[:vector (merge params {:decode/json map->db-id-decoder
|
|
:decode/arbitrary (fn [x]
|
|
(if (sequential? x)
|
|
x
|
|
[x]))})
|
|
(into [:map] keys)]))
|
|
|
|
(defn str->keyword [s]
|
|
(if (string? s)
|
|
(let [[ns k] (str/split s #"/")]
|
|
(if (and ns k)
|
|
(keyword ns k)
|
|
(keyword s)))
|
|
s))
|
|
|
|
(defn keyword->str [k]
|
|
(subs (str k) 1))
|
|
|
|
|
|
;; TODO make this bubble the form data automatically
|
|
(defn field-validation-error [m path & {:as data}]
|
|
(throw+ (ex-info m (merge data {:type :field-validation
|
|
:form-errors (assoc-in {} path [m])}))))
|
|
|
|
(defn form-validation-error [m & {:as data}]
|
|
(throw+ (ex-info m (merge data {:type :form-validation
|
|
:form-validation-errors [m]}))))
|
|
|
|
(def clj-date-schema
|
|
(mc/schema [:and [inst? {:date-format atime/normal-date
|
|
}]
|
|
[:fn
|
|
{:error/message "Invalid date"}
|
|
(fn [d]
|
|
(if d
|
|
(time/after? (coerce/to-date-time d)
|
|
(coerce/to-date-time #inst "2000-01-01"))
|
|
true))]
|
|
[:fn
|
|
{:error/message "Invalid date"}
|
|
(fn [d]
|
|
(if d
|
|
(time/before? (coerce/to-date-time d)
|
|
(time/plus (time/now) (time/years 2)))
|
|
true))]]))
|
|
|
|
(def date-transformer
|
|
(mt2/transformer
|
|
{:decoders
|
|
{'inst? {:compile (fn [schema _]
|
|
(let [properties (mc/properties schema)
|
|
format (:format properties atime/normal-date)]
|
|
(fn [m]
|
|
(if (string? m)
|
|
(coerce/to-date-time (atime/parse m format))
|
|
|
|
m))))}}
|
|
:encoders
|
|
{'inst?
|
|
{:compile (fn [schema _]
|
|
(let [properties (mc/properties schema)
|
|
format (:format properties atime/normal-date)]
|
|
(fn [m]
|
|
(cond
|
|
(inst? m)
|
|
(atime/unparse-local (coerce/to-date-time m) format)
|
|
|
|
(instance? org.joda.time.DateTime m)
|
|
(atime/unparse-local m format)
|
|
|
|
:else
|
|
m))))}}}))
|
|
|
|
(def date-range-transformer
|
|
(mt2/transformer {:decoders
|
|
{:map {:compile (fn [schema _]
|
|
(let [properties (mc/properties schema)]
|
|
(fn [m]
|
|
(if (:date-range properties)
|
|
(let [[date-range-key start-date-key end-date-key] (:date-range properties)
|
|
date-range-value (get m date-range-key)]
|
|
(if date-range-value
|
|
(-> (condp = date-range-value
|
|
"week"
|
|
(let [last-monday (coerce/to-date-time (atime/last-monday))]
|
|
(assoc m
|
|
start-date-key (time/plus last-monday (time/days -7))
|
|
end-date-key last-monday))
|
|
|
|
"month"
|
|
(assoc m
|
|
start-date-key (time/plus (time/now) (time/months -1))
|
|
end-date-key nil)
|
|
|
|
"year"
|
|
(assoc m
|
|
start-date-key (time/plus (time/now) (time/years -1))
|
|
end-date-key nil)
|
|
|
|
"all"
|
|
(assoc m start-date-key (time/plus (time/now) (time/years -6))
|
|
end-date-key nil)
|
|
|
|
m)
|
|
(dissoc date-range-key))
|
|
m))
|
|
m))))}}}))
|
|
|
|
(defn ->db-id [m]
|
|
(cond
|
|
(map? m)
|
|
(:db/id m)
|
|
(nat-int? m)
|
|
m
|
|
(and (string? m) (not-empty m))
|
|
(Long/parseLong m)
|
|
|
|
:else
|
|
m))
|
|
|
|
(def pull-transformer
|
|
(mt2/transformer {:decoders
|
|
{:entity-map
|
|
{:compile (fn [schema _]
|
|
(let [pull-expr (:pull (mc/properties schema))]
|
|
(if pull-expr
|
|
(fn pull-data [m]
|
|
(cond
|
|
(nat-int? m)
|
|
(dc/pull (dc/db conn) pull-expr m)
|
|
(and (string? m) (not-empty m))
|
|
(dc/pull (dc/db conn) pull-expr (Long/parseLong m))
|
|
:else
|
|
nil))
|
|
identity)))}}
|
|
:encoders
|
|
{:entity-map
|
|
{:compile (fn [schema _]
|
|
(let [pull-expr (:pull (mc/properties schema))]
|
|
(if pull-expr
|
|
(fn pull-data [m]
|
|
(cond
|
|
(map? m)
|
|
(:db/id m)
|
|
(nat-int? m)
|
|
m
|
|
(and (string? m) (not-empty m))
|
|
(Long/parseLong m)
|
|
|
|
:else
|
|
m))
|
|
identity)))}}}))
|
|
|
|
(def coerce-vector
|
|
(mt2/transformer {:decoders {:vector {:compile (fn [schema _]
|
|
(when (:coerce? (m/properties schema))
|
|
(fn [data]
|
|
(cond
|
|
(vector? data)
|
|
data
|
|
(sequential? data)
|
|
data
|
|
(and (map? data)
|
|
(every? #(try (Long/parseLong %) true (catch Exception _ false)) (keys data)))
|
|
(into [] (->> (keys data)
|
|
sort
|
|
(map data)))
|
|
(nil? data)
|
|
nil
|
|
:else
|
|
[data]))))}}}))
|
|
|
|
(defn wrap-merge-prior-hx [handler]
|
|
(fn [{:keys [headers] :as request}]
|
|
(let [is-htmx-that-should-inherit-url-parameters? (and (not (get headers "hx-boosted"))
|
|
(get headers "hx-request"))]
|
|
(alog/peek ::check {:enabled? is-htmx-that-should-inherit-url-parameters?
|
|
:params (:query-params request)})
|
|
|
|
(if is-htmx-that-should-inherit-url-parameters?
|
|
(handler (update request :query-params (fn [qp]
|
|
(->> (concat (:hx-query-params request) qp)
|
|
(into {})))))
|
|
(handler request)))))
|
|
|
|
|
|
(def dissoc-nil-transformer
|
|
(let [e {:map {:compile (fn [schema _]
|
|
(fn [data]
|
|
(if (map? data)
|
|
(filter-vals
|
|
(fn [x]
|
|
(not (nil? x)))
|
|
data)
|
|
data)))}}]
|
|
(mt2/transformer {:encoders e
|
|
:decoders e})))
|
|
|
|
(def main-transformer
|
|
(mt2/transformer
|
|
parse-empty-as-nil
|
|
date-transformer
|
|
(mt2/key-transformer {:encode keyword->str :decode str->keyword})
|
|
mt2/string-transformer
|
|
mt2/json-transformer
|
|
(mt2/transformer {:name :arbitrary})
|
|
coerce-vector
|
|
date-range-transformer
|
|
pull-transformer
|
|
mt2/default-value-transformer))
|
|
|
|
(defn strip [s]
|
|
(cond (and (string? s) (str/blank? s))
|
|
nil
|
|
|
|
(string? s)
|
|
(str/trim s)
|
|
|
|
:else
|
|
s))
|
|
(defn assert-schema [schema entity]
|
|
(when-not (mc/validate schema entity)
|
|
(throw (ex-info #_(->> (-> (mc/explain schema entity)
|
|
(me/humanize {:errors (assoc me/default-errors
|
|
::mc/missing-key {:error/message {:en "required"}})}))
|
|
(map (fn [[k v]]
|
|
(str (if (keyword? k)
|
|
(name k)
|
|
k) ": " (str/join ", " v))))
|
|
(str/join ", "))
|
|
"validation failed"
|
|
{:type :schema-validation
|
|
:decoded entity
|
|
:error {:explain (mc/explain schema entity)}}))))
|
|
|
|
|
|
(defn schema-enforce-request [{:keys [form-params query-params hx-query-params multipart-params params] :as request} & {:keys [form-schema multipart-schema hx-schema query-schema route-schema params-schema]}]
|
|
(let [request (try
|
|
(cond-> request
|
|
(and (:params request) params-schema)
|
|
(assoc :params
|
|
(mc/coerce
|
|
params-schema
|
|
(:params request)
|
|
main-transformer))
|
|
|
|
(and (:route-params request) route-schema)
|
|
(assoc :route-params
|
|
(mc/coerce
|
|
route-schema
|
|
(:route-params request)
|
|
main-transformer))
|
|
|
|
(and (:multipart-params request) multipart-schema)
|
|
(assoc :multipart-params
|
|
(mc/coerce
|
|
multipart-schema
|
|
(:multipart-params request)
|
|
main-transformer))
|
|
|
|
(and form-schema form-params)
|
|
(assoc :form-params
|
|
(mc/coerce
|
|
form-schema
|
|
form-params
|
|
main-transformer))
|
|
|
|
(and hx-schema hx-query-params)
|
|
(assoc :hx-query-params
|
|
(mc/coerce
|
|
hx-schema
|
|
hx-query-params
|
|
main-transformer))
|
|
|
|
|
|
(and query-schema query-params)
|
|
(assoc :query-params
|
|
(mc/coerce
|
|
query-schema
|
|
query-params
|
|
main-transformer)))
|
|
|
|
(catch Exception e
|
|
(alog/warn ::validation-error :error e)
|
|
(throw (ex-info (->> (-> e
|
|
(ex-data)
|
|
:data
|
|
:explain
|
|
(me/humanize {:errors (assoc me/default-errors
|
|
::mc/missing-key {:error/message {:en "required"}})}))
|
|
(map (fn [x]
|
|
(if (and (sequential? x)
|
|
(= (count x) 2))
|
|
(let [[k v] x]
|
|
(str (if (keyword? k)
|
|
(name k)
|
|
k) ": " (str/join ", " v))
|
|
(str x)))))
|
|
(str/join ", "))
|
|
{:type :schema-validation
|
|
:decoded (:value (:data (ex-data e)))
|
|
:error (:data (ex-data e))}))))]
|
|
request))
|
|
|
|
(defn wrap-schema-enforce [handler & {:keys [form-schema query-schema route-schema params-schema hx-schema multipart-schema]}]
|
|
(fn [request]
|
|
(handler (schema-enforce-request request
|
|
:hx-schema hx-schema
|
|
:multipart-schema multipart-schema
|
|
:form-schema form-schema
|
|
:query-schema query-schema
|
|
:route-schema route-schema
|
|
:params-schema params-schema))))
|
|
|
|
|
|
(defn schema-decode-request [{:keys [form-params query-params params] :as request} & {:keys [form-schema query-schema route-schema params-schema]}]
|
|
(let [request (cond-> request
|
|
(and (:params request) params-schema)
|
|
(assoc :params
|
|
(mc/decode
|
|
params-schema
|
|
(:params request)
|
|
main-transformer))
|
|
|
|
(and (:route-params request) route-schema)
|
|
(assoc :route-params
|
|
(mc/decode
|
|
route-schema
|
|
(:route-params request)
|
|
main-transformer))
|
|
|
|
(and form-schema form-params)
|
|
(assoc :form-params
|
|
(mc/decode
|
|
form-schema
|
|
form-params
|
|
main-transformer))
|
|
|
|
(and query-schema query-params)
|
|
(assoc :query-params
|
|
(mc/decode
|
|
query-schema
|
|
query-params
|
|
main-transformer)))]
|
|
request))
|
|
|
|
(defn wrap-schema-decode [handler & {:keys [form-schema query-schema route-schema params-schema]}]
|
|
(fn [request]
|
|
(handler (schema-decode-request request
|
|
:form-schema form-schema
|
|
:query-schema query-schema
|
|
:route-schema route-schema
|
|
:params-schema params-schema))))
|
|
|
|
(defn ref->enum-schema [n]
|
|
(into [:enum {:decode/string #(if (keyword? %)
|
|
%
|
|
(when (not-empty %)
|
|
(keyword n %)))
|
|
:encode/string #(if (keyword? %)
|
|
(name %)
|
|
%)}]
|
|
(for [{:db/keys [ident]} (all-schema)
|
|
:when (= n (namespace ident))]
|
|
ident)))
|
|
|
|
(defn ref->select-options [n & {:keys [allow-nil?]}]
|
|
(into (if allow-nil?
|
|
[["" ""]]
|
|
[])
|
|
(for [{:db/keys [ident]} (all-schema)
|
|
:when (= n (namespace ident))]
|
|
[(name ident) (str/replace (str/capitalize (name ident)) "-" " ")])))
|
|
|
|
(defn ref->radio-options [n & {:keys [allow-nil?]}]
|
|
(into (if allow-nil?
|
|
[{:value nil :content ""}]
|
|
[])
|
|
(for [{:db/keys [ident]} (all-schema)
|
|
:when (= n (namespace ident))]
|
|
{:value (name ident) :content (str/replace (str/capitalize (name ident)) "-" " ")})))
|
|
|
|
|
|
(defn wrap-form-4xx-2 [handler form-handler]
|
|
(fn [request]
|
|
(try+
|
|
(handler request)
|
|
(catch [:type :schema-validation] e
|
|
(let [humanized (-> e :error :explain (me/humanize {:errors (assoc me/default-errors
|
|
::mc/missing-key {:error/message {:en "required"}})}))
|
|
errors (map
|
|
(fn [e]
|
|
{:path (:in e)
|
|
:message (get-in humanized (:in e))})
|
|
(:errors (:explain (:error e))))]
|
|
(alog/warn ::form-4xx :errors errors
|
|
:data e)
|
|
(form-handler (assoc request
|
|
:form-params (:decoded e)
|
|
:field-validation-errors errors
|
|
:form-errors humanized)))
|
|
#_(html-response [:span.error-content.text-red-500 (:message &throw-context)]
|
|
:status 400))
|
|
(catch [:type :field-validation] e
|
|
(form-handler (assoc request
|
|
:form-params (or (:form e) ;; TODO is :form actually used?
|
|
(:form-params e)
|
|
(:form-params request)
|
|
)
|
|
:form-errors (:form-errors e))))
|
|
(catch [:type :form-validation] e
|
|
(form-handler (assoc request
|
|
:form-params (or (:form e) ;; TODO is :form actually used?
|
|
(:form-params e)
|
|
(:form-params request))
|
|
:form-validation-errors (:form-validation-errors e)
|
|
:form-errors {:errors (:form-validation-errors e)}))))))
|
|
|
|
|
|
(defn apply-middleware-to-all-handlers [key->handler f]
|
|
(->> key->handler
|
|
(reduce
|
|
(fn [key-handler [k v]]
|
|
(assoc key-handler k (f v)))
|
|
key->handler)))
|
|
|
|
(defn path->name2 [k & rest]
|
|
(let [k->n (fn [k]
|
|
(if (keyword? k)
|
|
(str (when (namespace k)
|
|
(str (namespace k) "/"))
|
|
(name k))
|
|
k))]
|
|
(str (k->n k)
|
|
(str/join ""
|
|
(map (fn [k]
|
|
(str "[" (k->n k) "]"))
|
|
rest)))))
|
|
|
|
|
|
(defn wrap-entity [handler path read]
|
|
(fn wrap-entity-request [request]
|
|
(let [entity (some->>
|
|
(get-in request path)
|
|
(#(if (string? %) (Long/parseLong %) %))
|
|
(dc/pull (dc/db conn) read))]
|
|
(handler (if entity
|
|
(assoc request
|
|
:entity entity)
|
|
request)))))
|
|
|
|
(mr/set-default-registry!
|
|
(mr/composite-registry
|
|
(mc/default-schemas)
|
|
{:entity-id entity-id
|
|
:entity-map
|
|
(mc/-simple-schema {:type :entity-map
|
|
:pred map?})
|
|
#_[:map {:name :entity-map} [:db/id nat-int?]]}))
|
|
|
|
(comment
|
|
|
|
(mc/coerce [:map [:x {:optional true} [:maybe [:entity-map {:pull '[:db/id]}]]]]
|
|
{:x nil :g 1}
|
|
main-transformer)
|
|
|
|
(mc/decode [:map [:x [:entity-map {:pull '[:db/id :db/ident]}]]]
|
|
{:x 87}
|
|
main-transformer))
|
|
|
|
(defn round-money [d]
|
|
(with-precision 2
|
|
(double (.setScale (bigdec d) 2 java.math.RoundingMode/HALF_UP))))
|
|
|
|
|
|
(defn wrap-implied-route-param [handler & {:as route-params}]
|
|
(fn [request]
|
|
(handler (update-in request [:route-params] merge route-params)))) |