A way of enforcing transactions

transact.clj

(ns datomscript.model
  (:require #?@(:clj [[datomic.api :as d]
                      [clojure.tools.logging :as log]])
            #?@(:cljs [[datascript.core :as d]])
            [clojure.string :as string]
            [clojure.walk :as walk]))

(def vconcat (comp vec concat))

(defn get-model [models model-type]  
  (get models (keyword (namespace model-type))))

(defn nameify [model]
  (keyword (name (:name model)) "model"))

(defn merge-opts [schema opts]
  (merge schema
         (let [opts' (into #{} opts) ]
           (cond-> {}
             (:fulltext opts') (assoc :db/fulltext true)
             (:component opts') (assoc :db/isComponent true)
             (:nohistory opts') (assoc :db/noHistory true)))))

(defn merge-enums [schema enums]
  (let [ns (name (:ns enums))
        part (:part enums)]    
    (reduce
     (fn [e v]
       (conj e
             {:db/id (d/tempid (or part :db.part/user))
              :db/ident (if (namespace v)
                          v
                          (keyword ns (name v)))}))
     schema
     (:values enums))))

(defn pull-entity-model [entity model]
  (reduce-kv
   (fn [pull k field-map]
     (if (= (:type field-map) :ref)
       {:model/type (:model/type entity)}
       (get entity k)))
   {}
   (:fields model)))

(defn validate-ref-field [field test-value]  
  (if (= (:ref field) :any)
    true
    (let [ref-models (map #(keyword (name %) "model") (if (keyword? (:ref field))
                                                        [(:ref field)]
                                                        (:ref field)))]      
      (or     
       (boolean (get (into #{} ref-models) (:model/type test-value)))
       (str test-value " was not a valid ref model " (pr-str (:ref field)))))))

(defn validate-enum-field [field test-value]
  (let [n (get-in field [:enum :ns])
        enums (into #{} (map (fn [e] (if (namespace e)
                                       e
                                       (keyword (name n) (name e))))
                             (get-in field [:enum :values])))]
    (if (get enums test-value)
      true
      (str test-value " was not a valid enum " (pr-str enums)))))

(defn validate-field [field test-value]  
  (if test-value
    (case (:type field)
      :ref (validate-ref-field field test-value)
      :enum (validate-enum-field field test-value)
      (if-let [validation-fn (:validation field)]
        (if (validation-fn test-value)
          true
          (str test-value (or (:invalid-msg field) " is invalid")))
        true))
    (if (:optional? field)
      true
      "Required Field")))

(defn validate-cardinality-many [field values]
  (let [results (map #(validate-field field %) values)]
    (if (every? true? results)
      true
      (string/join " " (remove true? results)))))

(defn validate-fields [fields test-value]
  (merge
   (into {} (zipmap (remove (into #{} (keys fields)) (into #{} (keys test-value)))
                    (repeat "Is not a valid key")))
   (reduce-kv
    (fn [errs field-name field-value]
      (let [tv (get test-value field-name)            
            v (if (vector? tv)
                (validate-cardinality-many field-value tv)
                (validate-field field-value tv))]
        (if (true? v)
          errs
          (assoc errs field-name v))))
    {}
    fields)))

(defn gather-handlers [models handler-key]
  (reduce
   (fn [acc model]
     (if-let [handlers (get model handler-key)]
       (reduce-kv (fn [new-handler k v] (update new-handler k (fnil conj []) v)) acc handlers)       
       acc))
   {}
   models))

(defn delta-key [{:keys [old new]}]
  (cond
    (and (nil? old) new) [(:model/type new) :added]
    (and old new) [(:model/type new) :updated]
    (and old (nil? new)) [(:model/type old) :removed]))

(defn deltas-reducing [{:keys [tx-map deltas handlers]}]
  (reduce
   (fn [txes delta]
     (let [[model-type status :as delta-key'] (delta-key delta)
           handler-fns (->> [(get handlers delta-key')
                             (get handlers [model-type :*])
                             (get handlers [:* status])
                             (get handlers [:* :*])]
                            (filter seq)
                            (mapcat identity))]       
       (reduce (fn [txes handler-fn]                 
                 (vconcat txes (handler-fn tx-map delta)))
               txes handler-fns )))
   []
   deltas))

(defn append-post-tx-data [{:keys [post-tx-handlers tx-data deltas tx-report] :as tx-map}]  
  (assoc
   tx-map :tx-data
   (vconcat
    tx-data
    (deltas-reducing {:deltas deltas
                      :tx-map tx-map
                      :handlers post-tx-handlers}))))

(defn permission-validation [{:keys [permissions tx-data deltas] :as tx-map}]  
  (let [errs (deltas-reducing {:deltas deltas
                               :tx-map tx-map
                               :handlers permissions})]
    (when (seq errs)
      (throw (ex-info (pr-str "There was a permission error" errs)
                      {:message "There was a permission error"
                       :details errs})))
    tx-map))

#?(:clj
   (defn schemafy-datomic [model]
     (let [name' (name (:name model))]       
       (vconcat
        (reduce-kv
         (fn [s field-name {:keys [type enum cardinality unique doc opts] :as field-map}]            
           (vec
            (concat
             s
             (cond-> [(cond-> {:db.install/_attribute :db.part/db
                               :db/id (d/tempid :db.part/db)
                               :db/ident (keyword name' (name field-name))
                               :db/cardinality (if (= cardinality :many)
                                                 :db.cardinality/many
                                                 :db.cardinality/one)
                               :db/valueType (keyword "db.type" (if (= type :enum)
                                                                  "ref"
                                                                  (name type)))}
                        unique (assoc :db/unique (keyword "db.unique" (name unique)))
                        doc (assoc :db/doc doc)
                        opts (merge-opts opts))]              
               (= type :enum) (merge-enums enum )))))
         []
         (into {} (remove (fn [[k v]] (namespace k)) (:fields model))))
        [{:db/id (d/tempid :db.part/user)
          :db/ident (keyword name' "model")}]))))

#?(:clj
   (def type-schema
     {:db.install/_attribute :db.part/db
      :db/id (d/tempid :db.part/db)
      :db/ident :model/type
      :db/cardinality :db.cardinality/one
      :db/valueType :db.type/ref
      :db/doc "The model type definition"}))

(defn schemafy-as-map [model]
  (let [name' (name (:name model))]       
    (reduce-kv
     (fn [s field-name {:keys [type cardinality unique] :as field-map}]
       (assoc
        s
        (keyword name' (name field-name))
        (cond-> {:db/cardinality (if (= cardinality :many)
                                   :db.cardinality/many
                                   :db.cardinality/one)
                 :db/valueType (keyword "db.type" (name type))}
          unique (assoc :db/unique (keyword "db.unique" (name unique))))
        ))
     {}
     (into {} (remove (fn [[k v]] (namespace k)) (:fields model)))
     )))

#?(:clj
   (defn entity->delta
     [{:keys [db-after db-before tx-data]} {:keys [eid status]}]
     (let [model-type (:model/type
                       (if (= status :removed)
                         (d/entity db-before eid)
                         (d/entity db-after eid)))]
       (reduce
        (fn [entity [_ a v tx added?]]
          (let [attr-ent (d/entity db-after a)
                attr-name (:db/ident attr-ent )                
                path [(if added? :new :old) attr-name]
                val (if (= (:db/valueType attr-ent) :db.type/ref)
                      (if-let [val-enum (:db/ident (d/entity (if added?
                                                               db-after
                                                               db-before) v))]
                        val-enum
                        v)
                      v)
                cardinality (:db/cardinality db-after)]
            (if (= cardinality :db.cardinality/many)
              (update-in entity path conj val)
              (assoc-in entity path val))))
        (cond-> {:old nil
                 :new nil}
          (= status :added) (assoc-in [:new :db/id] eid)
          (= status :updated) (merge {:new {:db/id eid}
                                      :old {:db/id eid}})
          (= status :removed) (assoc-in [:old :db/id] eid))
        (filter (fn [[e]] (= eid e)) tx-data)))))

#?(:clj
   (defn add-deltas
     [{{:keys [db-after db-before] :as tx-report} :tx-report :as tx-map}]     
     (assoc tx-map :deltas
            (map (fn [[e status]]
                   (let [{:keys [old new] :as deltas}
                         ,(entity->delta
                           tx-report {:status status
                                      :eid e})
                         entity (d/entity (if (= status :removed)
                                            db-before
                                            db-after)
                                          e)]
                     (cond
                       ;; Have to potentially deal with a model update change
                       ;; where the model must be checked as if it was added
                       (and (= status :updated)
                            (not= (:model/type old))
                            (not= (:model/type new)))
                       ,{:old nil
                         :new (d/touch entity)}
                       ;; Make sure the model types are included
                       (= status :updated)
                       ,{:old (assoc old :model/type (:model/type entity))
                         :new (assoc new :model/type (:model/type entity))}
                       :else deltas)))
                 (:entities tx-map)))))

#?(:clj
   (defn classify-entities [{:keys [db-before db-after tx-data]}]
     (d/q '[:find ?e ?entity-type
            :in $dbb $dba % [?e ...]
            :where
            ($dbb entity-exists? ?e ?in-before?)
            ($dba entity-exists? ?e ?in-after?)
            ($dba classify-type ?in-before? ?in-after? ?entity-type)]
          db-before
          db-after
          '[[(entity-exists? ?e ?exists?)
             [?e]                    
             [(ground true) ?exists?]]
            [(entity-exists? ?e ?exists?)
             (not [?e])                    
             [(ground false) ?exists?]]
            [(classify-type ?in-before? ?in-after? ?type)
             [(= ?in-before? false)]
             [(= ?in-after? true)]          
             [(ground :added) ?type]]
            [(classify-type ?in-before? ?in-after? ?type)
             [(= ?in-before? true)]
             [(= ?in-after? true)]          
             [(ground :updated) ?type]]
            [(classify-type ?in-before? ?in-after? ?type)
             [(= ?in-before? true)]
             [(= ?in-after? false)]          
             [(ground :removed) ?type]]]
          tx-data)))

#?(:clj 
   (defn add-entities
     [{{:keys [tempids tx-data db-before db-after] :as tx-report} :tx-report :as transact-map}]
     (->> (assoc tx-report :tx-data (into #{} (map (fn [[e]] e) tx-data)))
          classify-entities
          (assoc transact-map :entities))))

#?(:clj
   (defn model-with-ref-types [{:keys [model-value db model]}]
     (reduce-kv
      (fn [mv k v]        
        (assoc mv k
               (if (= (get-in model [:fields k :type]) :ref)
                 {:model/type (:model/type (d/entity db v))}
                 v)))
      {}
      model-value)))

#?(:clj
   (defn schema-validation-added [{:keys [models model-value db]} ]     
     (if-let [model-type (:model/type model-value)]       
       (if-let [model (get-model models model-type)]
         (let [test-value (model-with-ref-types
                           {:model model
                            :db db
                            :model-value model-value})               
               errors (validate-fields
                       (:fields model)
                       (dissoc test-value :model/type :db/id))]           
           (when (seq errors)             
             (assoc errors :db/id (:db/id model-value))))
         {:db/id (:db/id model-value)
          :model/type (format "The %s is not a valid model" model-type)})
       {:db/id (:db/id model-value)
        :model/type "You must specify a model type"})))

#?(:clj
   (defn schema-validation-updated
     [{:keys [models new-model-value old-model-value db]} ]
     (if-let [model-type (:model/type new-model-value)]       
       (if-let [model (get-model models model-type)]
         (let [model-fields (:fields model)
               new-value (model-with-ref-types
                          {:model model
                           :db db
                           :model-value new-model-value})
               changed-keys (remove
                             #{:model/type :db/id}
                             (into
                              #{} (concat
                                   (keys new-value) (keys old-model-value))))               
               errors (reduce
                       (fn [errs k]
                         (let [val (validate-field
                                    (get model-fields k)
                                    (get new-value k))]
                           (if (true? val)
                             errs
                             (assoc errs k val ))))
                       {} changed-keys)]           
           (when (seq errors)
             (assoc errors :db/id (:db/id new-model-value))))
         {:db/id (:db/id new-model-value)
          :model/type (format "The %s is not a valid model" model-type)})
       {:db/id (:db/id new-model-value)
        :model/type "You must specify a model type"})))

#?(:clj
   (defn schema-validation
     [{{:keys [db-after] :as tx-report} :tx-report
       models :models
       deltas :deltas
       :as tx-map}]     
     (let [errs (vec
                 (filter
                  identity
                  (map
                   (fn [{:keys [old new]}]                     
                     (cond
                       (and (nil? old) new) (schema-validation-added
                                             {:model-value new
                                              :models models
                                              :db db-after})
                       (and old new) (schema-validation-updated
                                      {:old-model-value old
                                       :new-model-value new
                                       :models models
                                       :db db-after})))
                   deltas)))]       
       (if (seq errs)         
         (throw (ex-info (pr-str "There was a validation error" errs)
                         {:message "There was a schema validation error"
                          :details errs}))
         tx-map))))

#?(:clj
   (defn classify-tx-report [{:keys [tempids tx-data db-before db-after]}]
     (d/q '[:find ?e ?a ?v ?attr ?val ?entity-type ?cardinality ?attr-val-type-name ?added?
            :in $dbb $dba % [[?e ?a ?v ?t ?added?]]
            :where
            ($dbb entity-exists? ?e ?in-before?)
            ($dba entity-exists? ?e ?in-after?)
            ($dba classify-type ?in-before? ?in-after? ?entity-type)            
            [$dba ?a :db/ident ?attr]         
            [$dba ?a :db/valueType ?attr-val-type]
            [$dba ?attr-val-type :db/ident ?attr-val-type-name]
            [$dba ?a :db/cardinality ?c]
            [$dba ?c :db/ident ?cardinality]
            ($dba classify-val ?attr-val-type-name ?v ?val)]
          db-before
          db-after
          '[[(entity-exists? ?e ?exists?)
             [?e]                    
             [(ground true) ?exists?]]
            [(entity-exists? ?e ?exists?)
             (not [?e])                    
             [(ground false) ?exists?]]
            [(classify-type ?in-before? ?in-after? ?type)
             [(= ?in-before? false)]
             [(= ?in-after? true)]          
             [(ground :added) ?type]]
            [(classify-type ?in-before? ?in-after? ?type)
             [(= ?in-before? true)]
             [(= ?in-after? true)]          
             [(ground :updated) ?type]]
            [(classify-type ?in-before? ?in-after? ?type)
             [(= ?in-before? true)]
             [(= ?in-after? false)]          
             [(ground :removed) ?type]]
            [(classify-val ?attr-type ?v ?val)
             [(= ?attr-type :db.type/ref)]
             [?v :db/ident ?val]]
            [(classify-val ?attr-type ?v ?val)
             [(= ?attr-type :db.type/ref)]
             (not [?v :db/ident])
             [(identity ?v) ?val]]
            [(classify-val ?attr-type ?v ?val)
             [(not= :db.type/ref ?attr-type)]
             [(identity ?v) ?val]]]
          tx-data)))

(defn schemafy [model]
  #?(:clj (schemafy-datomic model))
  #?(:cljs (schemafy-as-map model)))

(defn raise-validation-errors [errs]
  (when (seq errs)    
    (throw (ex-info (str "Validation Error" (pr-str errs))
                    {:message "There was a validation error"
                     :details errs}))))

(defn resolve-model [model models]
  (let [model-name (:name model)]
    (assoc model :fields
           (reduce-kv (fn [m field-name field-value ]
                        (assoc m (if-not (namespace field-name)
                                   (keyword (name model-name) (name field-name))
                                   field-name)
                               (if (namespace field-name)
                                 (get-in models [field-value :fields (keyword (name field-name))])
                                 field-value)))
                      {}
                      (:fields model)))))

(defn model-map [models]
  (let [model-map' (reduce
                    (fn [mm m]
                      (assoc mm (:name m) m))
                    {}
                    models)]    
    (reduce-kv
     (fn [resolved-models model-name model-def]
       (assoc resolved-models model-name (resolve-model model-def model-map')))
     {}
     model-map')))

#?(:clj
   (defn get-model-and-type [ent models]
     (let [model-type (if-let [t (:model/type ent)]
                        t
                        (throw
                         (ex-info
                          "Type Error"
                          {:message "The model type was removed"})))
           model (if-let [m (get models (keyword (namespace model-type)))]
                   m
                   (throw (ex-info
                           "Model Error"
                           {:message
                            (format
                             "There does not exist %s model"
                             model-type)})))]
       {:model model
        :model-type model-type})))

#?(:clj
   (defn typeof-attr [attr-value val]
     (cond
       (and (= attr-value :db.type/ref)
            (not (keyword? val)))
       ,:ref
       (and (= attr-value :db.type/ref)
            (keyword? val))
       ,:enum
       :else :val)))



#?(:clj
   (defn verify-domain-update-added [{:keys [db models tx]}]
     (let [[e a v attr val entity-type cardinality attr-type added?] tx
           a-type (typeof-attr attr-type val)
           ent (d/entity db e)
           {:keys [model-type model]} (get-model-and-type ent models)           
           new-val (if (= a-type :ref)
                     (d/pull db [:model/type] v)
                     val)]
       (raise-validation-errors
        (if (not= attr :model/type)
          (validate-field (get-in model [:fields attr]) new-val)
          (validate-fields (pull-entity-model ent model)))))))

#?(:clj
   (defn verify-domain-update-removed [{:keys [db models tx]}]     
     (let [[e a v attr val entity-type cardinality attr-type added?] tx
           {:keys [model-type model]} (get-model-and-type (d/entity db e) models)]       
       (when (or (nil? (get-in model [:fields attr :optional?]))
                 (= attr :model/type))
         (throw (ex-info
                 "Required Key"
                 {:message (format "You can't remove the required key %s" attr)
                  :details {model-type {attr 'required-key}}}))))))

#?(:clj
   (defn verify-domain-update [{:keys [db models tx] :as args}]
     (let [[e a v attr val entity-type cardinality attr-type added?] tx]
       ;; Ignore the removal portion of a two step update       
       (cond
         added? (verify-domain-update-added args)
         (not (get (d/entity db e) attr)) (verify-domain-update-removed args)))))

#?(:clj
   (defn update-new-entity [{:keys [db models tx new]} ]
     (let [[e a v attr val entity-type cardinality attr-type added?] tx]       
       (update-in new [e attr] (fn [old-val]
                                 (let [a-type (typeof-attr attr-type val) 
                                       new-val (if (= a-type :ref)
                                                 (d/pull db [:model/type] v)
                                                 val)]
                                   (if (= cardinality :db.cardinality/many)
                                     (conj old-val new-val)
                                     new-val)))))))

#?(:clj
   (defn verify-new-entity [{:keys [e ev db models]}]  
     (let [{:keys [model-type model]} (get-model-and-type (d/entity db e) models)]       
       (raise-validation-errors (validate-fields (:fields model) (dissoc ev :model/type))))))

#?(:clj
   (defn verify-domain-txes [tx-report-classification db models]     
     (doseq [[e ev]
             ,(reduce
               (fn [acc [e a v attr val entity-type cardinality attr-type added? :as tx]]
                 (cond
                   (= entity-type :added)
                   ,(update-new-entity {:new acc :db db :tx tx :models models})
                   (= entity-type :updated)
                   ,(do
                      (verify-domain-update {:db db :tx tx :models models})
                      acc)
                   ;; If the entity was removed, not a domain validation
                   ;; question                         
                   :else acc))
               {}
               tx-report-classification)]
       (verify-new-entity {:e e :ev ev :db db :models models}))))

#?(:clj
   (defn add-audit-to-tx-data [{:keys [tx-data access-token] :as tx-map}]
     (assoc
      tx-map :tx-data
      (conj tx-data (cond-> {:db/id (d/tempid :db.part/tx)
                             :model/type :tx-audit/model
                             :tx-audit/token (:db/id access-token)
                             :tx-audit/source :tx-audit.source/system}) ))))

#?(:clj
   (defn add-tx-report [{:keys [tx-data access-token conn] :as transact-map}]
     (assoc transact-map :tx-report (d/with (d/db conn) tx-data))))

#?(:clj
   (defn resolve-tmp-ids
     [{{:keys [tempids db-after] :as tx-report} :tx-report tmpids :tmpids :as tx-map}]     
     (reduce
      (fn [acc id]        
        (let [db-id (d/resolve-tempid db-after tempids id)]          
          (assoc acc id (:resource/eid (d/entity db-after db-id)))))
      {}
      tmpids)))

#?(:clj
   (defn resolve-id-namespace [tmpid]
     (-> tmpid first second)))

#?(:clj
   (defn find-tmp-ids [tx-data & [include-tx?]]
     (let [tmpids (atom [])
           _ (walk/postwalk
              (fn [d]
                (when (= (type d) datomic.db.DbId)
                  (let [ns (resolve-id-namespace d)
                        use-id? (if (= ns :db.part/tx)
                                  include-tx?                                  
                                  true)
                        _ (when use-id?
                            (swap! tmpids conj d))]))
                d)      
              tx-data)]       
       (into #{} @tmpids))))

#?(:clj
   (defn collect-tmp-ids [{:keys [tx-data] :as tx-map}]     
     (assoc tx-map :tmpids (find-tmp-ids tx-data))))

#?(:clj
   (defn db-id->tmp-id
     [{:keys [tx-data] {:keys [tempids db-after]} :tx-report :as tx-map}]
     (let [tmpids (find-tmp-ids tx-data true)]
       (assoc tx-map
              :db-id->tmp-id
              (reduce
               (fn [acc tmpid]
                 (assoc acc (d/resolve-tempid db-after tempids tmpid) tmpid ))
               {}
               tmpids)))))

#?(:clj
   (defn transact! [{:keys [tx-data conn] :as tx-map}]     
     (assoc tx-map :tx-report @(d/transact conn tx-data))))

#?(:clj
   (defn transact-fn [models]
     (let [base-params {:models (model-map models)
                        :post-tx-handlers (gather-handlers models :post-tx-handlers)
                        :permission-handlers (gather-handlers models :permission-handlers)}]
       (fn [{:keys [tx-data conn skip-permissions? access-token]}]
         (cond-> (assoc base-params
                        :conn conn
                        :tx-data tx-data
                        :access-token access-token)
           true add-audit-to-tx-data
           true add-tx-report
           true add-entities
           true add-deltas
           true schema-validation
           (not skip-permissions?) permission-validation
           true db-id->tmp-id
           true append-post-tx-data
           true transact!
           true collect-tmp-ids
           true resolve-tmp-ids
           )))))

(comment
  
  ;; om create access token
  ;; Send anonymous data
  ;; Create access token
  ;; Create anonymous user

  ;; Create company using the access token
  ;; The company and identities should be set
  ;; Should allow a claim of an access token to get it set on the company

  ;; Invite a user
  ;; Should actually create the user and the access token for them
  ;; The permission grant should connect the user to the employees

  ;; validate/fn
  ;; db/fn that should validate based on queries
  ;; Should be able to pass query and params
  ;; params should be a list.  Going to apply query using the db.
  ;; Should be an expected value
  ;; If the validation function does not equal the expected value, then it
  ;; will raise the exception (which will be passed into the function)

  ;; tx-data

  ;; transact-fn
  ;; Takes a models map, creates the permissions, schema validation and
  ;; post-tx-handlers
  ;; Returns a function which should take:
  ;; tx-data, conn, access token and a tmpids (map from om id to {:db/id db-id :resource/eid eid})  
  ;; Add the access token and the tx audit before giving to permission-validation
  ;; skip-permissions?
  ;; Will then run the with transaction, place reslt in tx-report of the map
  

  ;; filter-fn

  ;; Should take an access token first

  ;; The first function should examine the entity for a model type
  ;; Reject if no type on it
  ;; Should never be able to get a password hash, so always exclude
  ;; that attribute
  ;; If has type, should dispatch to the permission read function of
  ;; the model type
  
  (gather-post-tx
   {:post-tx-handlers
    (post-tx-handlers
     [{:post-tx-handlers {[:* :*] (fn [_ _] [{:db/id :aardvark}])
                          [:* :added] (fn [_ _] [{:db/id :aardvark5}])
                          [:x :*] (fn [_ _] [{:db/id :aardvark6}])}}
      {:post-tx-handlers {[:* :*] (fn [_ _] [{:db/id :aardvark83}])
                          [:y :*] (fn [_ _] [{:db/id :aardvark77}])}}] )
    :deltas [{:old nil
              :new {:db/id 55
                    :model/type :x}}
             {:old nil
              :new {:db/id 55
                    :model/type :y}}]})
  


  
  
  )