├── .clj-kondo └── config.edn ├── .gitignore ├── LICENSE ├── README.md ├── deps.edn ├── resources └── sql │ ├── firebird.sql │ ├── postgres.sql │ └── specomatic-generic.sql ├── src └── specomatic_db │ ├── access_control.clj │ ├── core.clj │ ├── core │ └── impl.clj │ ├── db │ ├── conversion.clj │ ├── firebird │ │ ├── conversion.clj │ │ ├── migration.clj │ │ ├── mutation.clj │ │ ├── sql.clj │ │ └── util.clj │ ├── generic.clj │ ├── migration.clj │ ├── mutation.clj │ ├── postgres │ │ ├── migration.clj │ │ ├── mutation.clj │ │ ├── sql.clj │ │ └── util.clj │ ├── sql.clj │ └── type.clj │ ├── etype_def.clj │ ├── field_def.clj │ ├── registry.clj │ ├── schema.clj │ ├── seql.clj │ ├── spec.clj │ └── util.clj ├── test-common └── specomatic_db │ └── test │ ├── config.clj │ └── schema.clj ├── test.sh ├── test └── specomatic_db │ ├── access_control_test.clj │ ├── core_test.clj │ └── db │ └── firebird_test.clj └── tests.edn /.clj-kondo/config.edn: -------------------------------------------------------------------------------- 1 | {:lint-as {nedap.speced.def/defn clojure.core/defn} 2 | :linters {:missing-docstring {:level :warning} 3 | :unsorted-required-namespaces {:level :warning} 4 | :single-key-in {:level :warning} 5 | :shadowed-var {:level :warning}}} 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /node_modules 2 | /target 3 | /public/js 4 | /.clj-kondo/.cache 5 | .cpcache 6 | .shadow-cljs 7 | .nrepl-port 8 | junit.xml 9 | yarn.lock 10 | yarn-error.log 11 | package-lock.json 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2022 PrimeTeach AG 2 | 3 | Permission to use, copy, modify, and distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # specomatic-db 2 | 3 | [![cljdoc badge](https://cljdoc.org/badge/com.primeteach/specomatic-db)](https://cljdoc.org/d/com.primeteach/specomatic-db) 4 | [![Clojars Project](https://img.shields.io/clojars/v/com.primeteach/specomatic-db.svg)](https://clojars.org/com.primeteach/specomatic-db) 5 | 6 | Define your entities and relationships using [clojure.spec](https://clojure.org/guides/spec) and / or [specomatic](https://github.com/primeteach/specomatic), get an immutable SQL database that understands [seql](https://github.com/exoscale/seql) and supports access control. 7 | 8 | ## Introduction 9 | 10 | Specomatic-db builds on the abstract base library [specomatic](https://github.com/primeteach/specomatic). The core concept is the specomatic-db schema that extends the specomatic schema with persistence-specific information. 11 | 12 | From the schema, specomatic-db creates an immutable SQL database (with full historisation) and a [seql](https://github.com/exoscale/seql) schema. Entities and their history are retrieved using seql and persisted with a CRUD-flavored mutation system. Both retrieving and persisting can be restricted by attribute- and permission-based access control rules. 13 | 14 | ## Design goals 15 | 16 | * Use [clojure.spec](https://clojure.org/guides/spec) definitions as the basis of the schema 17 | * Liberation from repetitive parts of SQL for CRUD as well as schema migrations 18 | * Make it easy to use plain SQL where necessary 19 | * Cross-RDBMS historisation 20 | * Cross-RDBMS access control 21 | * Support existing database schemas 22 | 23 | ## Overview 24 | 25 | `specomatic-db.core` is the main namespace for consumers of specomatic-db. It contains functions for retrieving and persisting entities, as well as initialising the database. 26 | 27 | The functions in the `specomatic-db.registry` namespace query the clojure.spec registry (via specomatic) to generate the schema. 28 | 29 | The functions in the `specomatic-db.schema`, `specomatic-db.etype-def` and `specomatic-db.field-def` namespaces are pure functions that take the schema or parts of it as a first parameter and answer questions about it. These namespaces are extensions of `specomatic.core`, `specomatic.etype-def` and `specomatic.field-def`. 30 | 31 | PostgreSQL and (for historical reasons) Firebird are supported. Other backends can be added by implementing the multimethods in `specomatic-db.db.migration`, `specomatic-db.db.mutation` and `specomatic-db.db.sql`. 32 | 33 | ## Defining the schema 34 | 35 | The main way to define entity types is by using clojure.spec and the `defent` macro. See [the section on entity types in the specomatic README](https://github.com/primeteach/specomatic#entity-types) for a more detailed explanation of `defent` and other ways to define entity types. 36 | 37 | Relationships are specified using relational fields, mainly via `specomatic.spec/reference` and `specomatic.spec/reference-coll` macros. For a more detailed explanation and other ways to define relationships, see [the section on relationships in the specomatic README](https://github.com/primeteach/specomatic#relationships) 38 | 39 | The following example schema defines some entities and relationships for the cinema domain. 40 | 41 | ```clojure 42 | (s/def :spec/review-stars (s/int-in 1 6)) 43 | (s/def ::name string?) 44 | (s/def ::title string?) 45 | (s/def ::release-year integer?) 46 | (s/def ::stars :spec/review-stars) 47 | 48 | (sr/defent ::actor :req [:name]) 49 | 50 | (sr/defent ::director :req [:name]) 51 | 52 | (s/def :movie/actors (sp/references ::actor)) 53 | (s/def :movie/directors (sp/references ::director)) 54 | 55 | (sr/defent ::movie 56 | :req [:title :release-year] 57 | :opt [:actors :directors]) 58 | 59 | (s/def :review/movie (sp/reference ::movie)) 60 | (s/def :review/reviewer (sp/reference ::reviewer)) 61 | 62 | (sr/defent ::review :req [:movie :reviewer :stars :title]) 63 | 64 | 65 | (s/def :paragraph/review (sp/reference ::review)) 66 | (s/def :paragraph/content string?) 67 | 68 | (sr/defent ::paragraph :req [:content :review]) 69 | 70 | (sr/defent ::reviewer :req [:name]) 71 | ``` 72 | 73 | ## Setup 74 | 75 | To work with this, construct an environment and initialize the database: 76 | 77 | ```clojure 78 | (require '[specomatic-db.core :as sdb]) 79 | (require '[specomatic-db.registry :as sdb-registry]) 80 | 81 | ;; Query the spec registry to derive a specomatic config (including the specomatic-db schema as its main part) 82 | ;; from the above specs 83 | 84 | (def config (sdb-registry/config ['schema-ns])) 85 | 86 | (def env 87 | {:jdbc next-jdbc-connectable 88 | :config config 89 | :user {:root? true}) ; skip access control 90 | 91 | ;; Validate the schema and initialize the database, applying all necessary migrations 92 | 93 | (sdb/init! env) 94 | ``` 95 | 96 | ## Migrations 97 | 98 | The above `sdb/init!` has already applied migrations and a table exists for every entity type in the the database. This can be skipped by passing `{:skip-migration? true}` as a second argument. If corresponding tables already exist in the database, any missing fields are created. Nothing is removed from the database schema. 99 | 100 | Instead of directly applying migrations on initialisation, they can be generated from `migration/diff-schema` 101 | ```clojure 102 | (require '[specomatic-db.db.migration :as migration]) 103 | 104 | (migration/diff-schema next-jdbc-map (:schema config)) 105 | ``` 106 | This returns a map of entity types as keys and maps of `:constraints sqlvecs :main sqlvecs}` as values. 107 | 108 | PostgreSQL and Firebird drivers are implemented. 109 | 110 | ## Queries 111 | 112 | For querying, specomatic-db builds on the excellent [seql](https://github.com/exoscale/seql) library. 113 | 114 | The following examples use the data from the `specomatic-db.core-test` integration tests, inserted by `insert-all!`. 115 | 116 | ```clojure 117 | (sdb/query env ::reviewer) ;; default fields, no conditions 118 | 119 | => (#:reviewer{:name "Jane", :id 1} #:reviewer{:name "John", :id 2}) 120 | 121 | (sdb/query env ::reviewer [:reviewer/name]) ;; restrict fields 122 | 123 | => (#:reviewer{:name "Jane"} #:reviewer{:name "John"}) 124 | 125 | (sdb/query env 126 | ::movie 127 | ;; more interesting seql to combine multiple relationships 128 | [:movie/title :movie/release-year {:movie/directors [:director/name {:director/user [:user/username]}]} 129 | {:movie/actors [:actor/name]}] 130 | ;; a vector of HoneySQL conditions, automatically joined by :and 131 | [[:= :director/name ["The Wachowskis"]] 132 | [:and [:< :movie/release-year 2000] 133 | [:like :movie/title "%Matrix%"]]] 134 | 135 | => (#:movie{:title "The Matrix", 136 | :release-year 1999, 137 | :directors [#:director{:name "The Wachowskis", 138 | :user #:user{:username "the-wachowskis"}}], 139 | :actors [#:actor{:name "Keanu Reeves"} 140 | #:actor{:name "Laurence Fishburne"}]}) 141 | 142 | ;; Single entities can also be queried by id: 143 | 144 | (sdb/by-id env ::schema/reviewer 1 [:reviewer/name]) 145 | 146 | => #:reviewer{:name "Jane"} 147 | ``` 148 | 149 | ## Mutations 150 | 151 | Mutations are performed by `create!`, `update!`, and `delete!`. 152 | 153 | `save!` calls `update!` if the entity has a non-nil id, `create!` if it has not. 154 | 155 | Mutations always return the transaction id `:tx/id` (see Historisation) 156 | 157 | ```clojure 158 | (sdb/create! env ::schema/user {:user/username "robert"}) 159 | 160 | => {:user/username "robert", :user/id 5, :tx/id 18} 161 | 162 | (sdb/update! env ::schema/user {:user/id 5 :user/username "bob"}) 163 | 164 | => {:user/id 5, :user/username "bob", :tx/id 19} 165 | 166 | (sdb/delete! env ::schema/user 5) 167 | 168 | => {:id 5, :tx/id 20} 169 | ``` 170 | 171 | ### Nested mutations 172 | 173 | `create!` and `update!` can save contents of relational fields. 174 | 175 | Only uncomplicated cases, where the foreign key resides in the nested entity, are handled. 176 | 177 | ```clojure 178 | (sdb/save! env ::schema/review #:review{:movie 5 ;; movie has to exist before review, no nested mutation 179 | :reviewer 1 ;; reviewer has to exist before review, no nested mutation 180 | :title "Highly recommend" 181 | :stars 5 182 | :paragraphs [{:paragraph/content "Awesome."} 183 | {:paragraph/content "Just awesome."}]} 184 | => 185 | 186 | {:review/movie 6, 187 | :review/reviewer 1, 188 | :review/title "Highly recommend", 189 | :review/stars 5, 190 | :review/paragraphs 191 | [{:paragraph/content "Awesome.", 192 | :paragraph/review 1, 193 | :paragraph/id 1, 194 | :tx/id 21} 195 | {:paragraph/content "Just awesome.", 196 | :paragraph/review 1, 197 | :paragraph/id 2, 198 | :tx/id 21}], 199 | :review/id 1, 200 | :tx/id 21} 201 | ``` 202 | 203 | Nested mutations run in the same database transation as the outer entity, guaranteeing consistency. 204 | 205 | This functionality can be extended via the `save-related!` multimethod. 206 | 207 | ## Historisation 208 | 209 | In addition to the main table corresponding to an entity type, the migration system creates an associated history table that is populated via triggers with all historical versions of the records. This means that historisation is automatically applied to any mutations, whether done via specomatic-db or plain SQL. 210 | 211 | Historical versions can be queried by adding a `:tx/id` to the environment, like this: 212 | 213 | ```clojure 214 | (sdb/query (assoc env :tx/id 18) ::schema/user [:user/username] [:user/id 5]) 215 | 216 | => (#:user{:username "robert"}) 217 | 218 | (sdb/query (assoc env :tx/id 19) ::schema/user [:user/username] [:user/id 5]) 219 | 220 | => (#:user{:username "bob"}) 221 | 222 | (sdb/query (assoc env :tx/id 20) ::schema/user [:user/username] [:user/id 5]) 223 | 224 | => () 225 | 226 | ``` 227 | 228 | ## Access control 229 | 230 | Access control is governed by permissions and predicates. 231 | 232 | Permissions are assigned to individual users and define the operations (verbs) users are allowed to carry out on entities of certain types. They can be conditional on access control predicates. 233 | 234 | Permissions consist of a `:permission/verb`, `:permission/obj` and `:permission/pred`. 235 | * `:permission/verb` Can represent any operation on an entity. CRUD verbs: `:verb/read`, `:verb/create`, `:verb/update`, `:verb/delete` govern access control for the respective operations in specomatic-db. The special verb `:verb/*` is a shorthand for all CRUD verbs. For other operations e.g. more complex mutations, other verbs like `:verb/import` could be defined. 236 | * `:permission/obj` is the entity type in your schema the permission applies to 237 | * `:permission/pred` is either `:predicate/none` if the permission is unconditional or refers to an access control predicate. 238 | 239 | For example, the following permission map represents an unconditional permission to read movies from the database: 240 | 241 | ```clojure 242 | {:permission/verb :verb/read 243 | :permission/obj ::schema/movie 244 | :permission/pred :predicate/none} 245 | ``` 246 | 247 | While the following permission map represents an permission to carry out any CRUD operations on movies, provided they satisfy the `:predicate/director` predicate. 248 | 249 | ```clojure 250 | {:permission/verb :verb/* 251 | :permission/obj ::schema/movie 252 | :permission/pred :predicate/director} 253 | ``` 254 | 255 | Such a predicate is defined by way of a HoneySQL query that defines the relationship of the restricted entity `::schema/movie` to the user entity `::schema/user`: 256 | 257 | ```clojure 258 | (def director-predicate 259 | {::schema/movie {:select [[:movie.id :movieid] [:user_.id :userid]] 260 | :from [:movie] 261 | :join [:moviedirector [:= :movie.id :moviedirector.movieid] 262 | :director [:= :moviedirector.directorid :director.id] 263 | :user_ [:= :director.id :user_.directorid]]}}) 264 | ``` 265 | 266 | This has the effect of restricting the permission to the director's own movies. 267 | 268 | For setting up access control, create a base config with predicates under the `:ac-predicates` key and the entity type that acts as the user entity under `:user-etype`: 269 | 270 | ```clojure 271 | (def base-config 272 | {:ac-predicates {:predicate/director director-predicate} 273 | :user-etype ::schema/user}) 274 | ``` 275 | 276 | This is passed as the second argument to `specomatic-db.registry/config` to create the final config. 277 | 278 | ```clojure 279 | (def config (sdb-registry/config ['schema-ns] base-config)) 280 | ``` 281 | 282 | User id and permissions are part of the environment: 283 | 284 | ```clojure 285 | (def the-wachowskis-user-id 286 | (:user/id (first (sdb/query env ::user [:user/id] [[:= :user/username "the-wachowskis"]])))) 287 | 288 | (def restricted-env 289 | {:jdbc next-jdbc-connectable 290 | :config config 291 | :user {:id the wachowskis-user-id 292 | :permissions #{{:permission/verb :verb/* 293 | :permission/obj ::schema/movie 294 | :permission/pred :predicate/director}}}}) 295 | ``` 296 | 297 | Directors can now only read their own movies: 298 | 299 | ```clojure 300 | (sdb/query restricted-env ::schema/movie [:movie/title]) 301 | 302 | => (#:movie{:title "The Matrix"} 303 | #:movie{:title "The Matrix Reloaded"} 304 | #:movie{:title "The Matrix Revolutions"}) 305 | ``` 306 | 307 | ### Access control for fields 308 | 309 | Non-root users can only query the fields that are defined in the specomatic-db schema for the entities they are allowed to read. For root users, no such restriction exists: They can query for any field that exists in the database. 310 | 311 | ### Access control for conditions 312 | 313 | Non-root users can only use the `#{:and :or := :!= :< :> :like :in}` HoneySQL conditions. 314 | 315 | ## Schema structure 316 | 317 | Like the [specomatic schema](https://github.com/primeteach/specomatic#schema-structure), the specomatic-db schema is a map of entity types to entity type definitions: 318 | 319 | ```clojure 320 | {::actor ... 321 | ::director ... 322 | ::movie ... 323 | ::review ... 324 | ::user ...} 325 | ``` 326 | 327 | ### Entity type definitions 328 | 329 | Specomatic-db entity type definitions extend the [specomatic entity type definitions](https://github.com/primeteach/specomatic#entity-type-definitions) with the persistence-specific `:table-name` and `:query-name`. 330 | 331 | ```clojure 332 | {;; set of fields (keywords) that are part of the display name of the entity type. 333 | :display-name-fields #{:movie/title}} 334 | ;; field definitions, see below 335 | :field-defs ... 336 | :id-field :movie/id 337 | :required-fields #{:movie/title :movie/release-year} 338 | ;; the name of the table used for persisting the entity, as a keyword 339 | :table-name :movie 340 | ;; the name of the table or view used for querying the entity (usually the same as :table-name), as a keyword 341 | :query-name :movie} 342 | ``` 343 | 344 | ### Field definitions 345 | 346 | Specomatic-db field definitions extend the [specomatic field definitions](https://github.com/primeteach/specomatic#field-definitions) with the persistence-specific `:column-name`, `:db-via`, `:join-table`, `join-table-id-field`, `:not-persistent?`, `:owns-relation?` and `save-related?`. 347 | 348 | For example, the definition of the simple (non-relational) field `:review/stars` looks like this: 349 | 350 | ```clojure 351 | {;; the database column used for the field, usually the same as the field, but could be overridden 352 | :column-name :review/stars 353 | :kind ::sf/simple 354 | :dispatch :spec/review-stars} 355 | ``` 356 | 357 | While the definition of `:review/paragraphs` looks like this: 358 | 359 | ```clojure 360 | {;; the database column on the opposite side of the relationship, if available. 361 | ;; Usually the same as :via, but may be overriden 362 | :db-via :paragraph/review 363 | :kind ::sf/reference-coll 364 | :inverse-of :paragraph/review 365 | :reference-type :has-many 366 | :target ::schema/paragraph 367 | :via :paragraph/review 368 | ;; Indicates whether the entity type that the field definition is part of owns the relationship 369 | :owns-relation? false 370 | ;; Indicates whether contents of the field should be saved (created or updated) with the entity 371 | :save-related? true} 372 | ``` 373 | 374 | ## Mapping from field specs to SQL data types 375 | 376 | This mapping is provided by implementing the following multimethods: 377 | 378 | `specomatic-db.db.migration/sql-type` defines the SQL data type to use for a certain database backend and spec keyword or description (see `specomatic-core.field-def/dispatch`). 379 | 380 | ```clojure 381 | (defmethod migration/sql-type ["firebirdsql" :spec/review-stars] [_ _] "SMALLINT") 382 | ``` 383 | 384 | The following mapping is built in for both implemented database backends: 385 | 386 | `::sp/integer` => "integer" 387 | 388 | `'integer?` => "integer" 389 | 390 | `'string?` => "varchar(255)" 391 | 392 | `specomatic-db.db.migration/db-field-value->entity-field-value-impl` coerces a database value into an entity value for a certain spec keyword or description (see `specomatic-core.field-def/dispatch`). 393 | 394 | `specomatic-db.db.migration/entity-field-value->db-field-value-impl` coerces a entity value into an database value for a certain spec keyword or description (see `specomatic-core.field-def/dispatch`). 395 | 396 | ## Acknowledgements 397 | 398 | * Historisation is inspired by this article from Bert Wagner https://bertwagner.com/posts/faking-temporal-tables-with-triggers/ 399 | 400 | ## Plans 401 | 402 | * Support non-integer ids. 403 | * Move non-database related parts of specomatic-db access control to specomatic 404 | * Maybe: Use Postgres Temporal Tables extension 405 | * Maybe: Use Postgres row-level security 406 | * Maybe: Make access control for conditions extensible 407 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:paths ["src" "resources"] 2 | :deps {org.clojure/clojure {:mvn/version "1.11.1"} 3 | com.primeteach/specomatic {:mvn/version "0.1.0"} 4 | com.github.seancorfield/honeysql {:mvn/version "2.4.962"} 5 | com.layerware/hugsql {:mvn/version "0.5.3"} 6 | com.layerware/hugsql-adapter-next-jdbc {:mvn/version "0.5.3"} 7 | pandect/pandect {:mvn/version "1.0.2"} 8 | seancorfield/next.jdbc {:mvn/version "1.2.659"} 9 | exoscale/seql {:mvn/version "0.2.2"} 10 | com.nedap.staffing-solutions/speced.def {:mvn/version "2.1.1"}} 11 | :aliases {:codox {:extra-deps {codox/codox {:mvn/version "0.10.8"}} 12 | :exec-fn codox.main/generate-docs 13 | :exec-args {:source-paths ["src"]}} 14 | :outdated {:deps {olical/depot {:mvn/version "2.3.0"}} 15 | :main-opts ["-m" "depot.outdated.main" "-a" "outdated" "-a" "test"]} 16 | :deploy {:extra-deps {slipset/deps-deploy {:mvn/version "RELEASE"}} 17 | :exec-fn deps-deploy.deps-deploy/deploy 18 | :exec-args {:installer :remote 19 | :sign-releases? true 20 | :artifact "target/specomatic-db.jar"}} 21 | :jar {:replace-deps {com.github.seancorfield/depstar {:mvn/version "2.1.303"}} 22 | :exec-fn hf.depstar/jar 23 | :exec-args {}} 24 | :test {:extra-paths ["test-common" "test"] 25 | :extra-deps {org.firebirdsql/firebird-testcontainers-java {:mvn/version "1.2.0"} 26 | org.firebirdsql.jdbc/jaybird-jdk18 {:mvn/version "2.2.15"} 27 | org.postgresql/postgresql {:mvn/version "42.5.1"} 28 | org.testcontainers/postgresql {:mvn/version "1.17.6"}}} 29 | :runner {:main-opts ["-m" "kaocha.runner"] 30 | :extra-deps {lambdaisland/kaocha {:mvn/version "1.71.1119"} 31 | lambdaisland/kaocha-cloverage {:mvn/version "1.1.89"} 32 | lambdaisland/kaocha-junit-xml {:mvn/version "1.17.101"}}}}} 33 | -------------------------------------------------------------------------------- /resources/sql/firebird.sql: -------------------------------------------------------------------------------- 1 | -- MUTATIONS -- 2 | -- Inserting, changing and deleting of records. 3 | 4 | -- :name insert! : (count my-name) 31) 35 | (str "ac_" (subs (md5 my-name) 0 28)) 36 | my-name))) 37 | 38 | (defn ^:no-doc view-name-seql 39 | "Returns the seql entity key of the access control view for given predicate and entity type (keywords)" 40 | [pred etype] 41 | (str/replace (view-name pred etype) "_" "-")) 42 | 43 | (defn ^:no-doc view-sql 44 | "Returns the SQL DDL for creating / altering an access control predicate view." 45 | [db {:keys [schema user-etype]} pred etype pred-def] 46 | (let [user-fk (schema/default-fk-column schema user-etype) 47 | etype-fk (schema/default-fk-column schema etype)] 48 | (db-sql/create-or-replace-view 49 | db 50 | {:name (view-name pred etype) 51 | :query (-> {:select [[(sc/id-field schema user-etype) user-fk] 52 | [(sc/id-field schema etype) etype-fk]] 53 | :from [(su/strip-ns etype)]} 54 | (merge pred-def) 55 | sql/format 56 | first)}))) 57 | 58 | (defn ^:no-doc views-sql 59 | "Returns a sequence of SQL views, one for every predicate and schema entity that has an access control predicate query" 60 | [db 61 | {:keys [ac-predicates] 62 | :as config}] 63 | (reduce into 64 | (for [[pred pred-defs-by-etype] ac-predicates] 65 | (for [[etype pred-def] pred-defs-by-etype] 66 | (view-sql db config pred etype pred-def))))) 67 | 68 | (defn ensure-views-exist! 69 | "Ensures an access control view exists in the database for every entity in the entity-schema and every predicate in predicates" 70 | [db config] 71 | (doseq [ddl (views-sql db config)] 72 | (jdbc/execute! db ddl))) 73 | 74 | (defn root? 75 | "Checks if `user` is a root user." 76 | [user] 77 | (or (:root? user) (true? user))) 78 | 79 | (defn allowed-all? 80 | "Checks if the user can do what the verb describes with all entities of this type" 81 | [user verb etype] 82 | (boolean 83 | (let [verbs (if (contains? crud-verbs-set verb) 84 | #{:verb/* verb} 85 | #{verb})] 86 | (or (root? user) 87 | (some #(and 88 | (contains? verbs (:permission/verb %)) 89 | (= etype (:permission/obj %)) 90 | (= :predicate/none (:permission/pred %))) 91 | (:permissions user)))))) 92 | 93 | (defn allowed-some? 94 | "Checks if the user can do what the verb describes with some entities of this type" 95 | [user verb etype] 96 | (boolean 97 | (let [verbs (if (contains? crud-verbs-set verb) 98 | #{:verb/* verb} 99 | #{verb})] 100 | (or (root? user) 101 | (some #(and 102 | (some #{(:permission/verb %)} verbs) 103 | (= etype (:permission/obj %))) 104 | (:permissions user)))))) 105 | 106 | (defn allowed? 107 | "Checks if the user can do what the verb describes with this entity of this type" 108 | [user verb etype entity] 109 | (boolean 110 | (let [verbs (if (contains? crud-verbs-set verb) 111 | #{:verb/* verb} 112 | #{verb})] 113 | (or (allowed-all? user verb etype) 114 | (some true? 115 | (for [v verbs] 116 | (v entity))))))) 117 | 118 | (defn may-read-some? 119 | "Checks if the given permissions allow read access to some entities of this type" 120 | [etype permissions] 121 | (boolean 122 | (some #(and 123 | (some #{(:permission/verb %)} #{:verb/read :verb/*}) 124 | (= etype (:permission/obj %))) 125 | permissions))) 126 | 127 | (defn- sufficient-predicates* 128 | "Returns a set of predicates where if any one is true for an entity of this type then it may be `verb`ed given the permissions" 129 | [etype verb permissions] 130 | (set 131 | (map :permission/pred 132 | (filter #(and 133 | (some #{(:permission/verb %)} #{verb :verb/*}) 134 | (= etype (:permission/obj %))) 135 | permissions)))) 136 | 137 | (defn sufficient-predicates 138 | "Returns a set of predicates where if any one is true for an entity of this type then it may be `verb`ed given the permissions" 139 | [etype verb permissions] 140 | (sufficient-predicates* etype verb permissions)) 141 | 142 | (defn etypes-extra-conditions 143 | "Returns a vector of extra HoneySQL conditions that need to be applied when retrieving the `etypes` for the user with `user-id` and `permissions`." 144 | [schema etypes permissions verb {:keys [user-id user-etype]}] 145 | (let [id-field (->> user-etype 146 | (schema/default-fk-column schema) 147 | su/strip-ns) 148 | conds (reduce 149 | into 150 | (for [etype etypes 151 | :let 152 | [preds 153 | (sufficient-predicates* 154 | etype 155 | verb 156 | permissions)] 157 | :when 158 | (not-any? #(= % :predicate/none) preds)] 159 | (for [pred preds] 160 | [:exists 161 | {:select [id-field] 162 | :from [(keyword (view-name pred etype))] 163 | :where [:and 164 | [:= id-field user-id] 165 | [:or 166 | [:= 167 | (u/honeysql-field (sc/id-field schema etype)) 168 | nil] 169 | [:= 170 | (schema/default-fk-column schema etype) 171 | (u/honeysql-field (sc/id-field schema etype))]]]}])))] 172 | (if (not-empty conds) 173 | [(into 174 | [:and] 175 | conds)] 176 | []))) 177 | 178 | (defn conditions-snippet 179 | "Returns a snippet / sqlvec suitable for composing with a HugSQL statement" 180 | [schema etypes permissions verb user-info] 181 | (let [my-cond (first (etypes-extra-conditions schema etypes permissions verb user-info))] 182 | (when (not-empty my-cond) 183 | (sql/format-expr my-cond)))) 184 | 185 | (defn fields-extra-read-conditions 186 | "Returns a sequence of extra HoneySQL conditions that need to be applied when retrieving the `fields` for the user with `user-id` and `permissions`." 187 | [schema fields permissions user-id user-etype] 188 | (let [etypes (u/etypes-from-fields schema fields)] 189 | (etypes-extra-conditions schema 190 | etypes 191 | permissions 192 | :verb/read 193 | {:user-id user-id 194 | :user-etype user-etype}))) 195 | 196 | (defn fields-forbidden-entities 197 | "Returns the seql entities that occur in `fields` and are forbidden to read given the `permissions`." 198 | [schema fields permissions] 199 | (not-empty 200 | (let [etypes (u/etypes-from-fields schema fields)] 201 | (remove #(may-read-some? % permissions) 202 | etypes)))) 203 | 204 | (defn fields-allowed? 205 | "Checks if the `permissions` give read access to all `fields`." 206 | [schema fields permissions] 207 | (nil? (fields-forbidden-entities schema fields permissions))) 208 | 209 | (defn- hsql-field? 210 | [schema x permissions] 211 | (and (keyword? x) 212 | (sc/field-defined? schema x) 213 | (may-read-some? (sc/etype-from-field schema x) permissions))) 214 | 215 | (defn- hsql-literal? 216 | [x] 217 | (not (or (coll? x) 218 | (keyword? x) 219 | (symbol? x)))) 220 | 221 | (defn- hsql-field-or-literal? 222 | [schema x permissions] 223 | (or (hsql-field? schema x permissions) 224 | (hsql-literal? x))) 225 | 226 | (defn allowed-condition? 227 | "Checks if the condition is allowed." 228 | [schema condition permissions] 229 | (let [[op & args] condition] 230 | (cond (some #{op} #{:= :!= :< :> :like}) 231 | (and (every? #(hsql-field-or-literal? schema % permissions) args) (= 2 (count args))) 232 | (= :in op) 233 | (and (every? #(or (hsql-field? schema % permissions) 234 | (every? hsql-literal? %)) 235 | args) 236 | (= 2 (count args))) 237 | (some #{op} #{:and :or}) 238 | (every? #(allowed-condition? schema % permissions) args)))) 239 | 240 | (defn forbidden-conditions 241 | "Returns a sequence of forbidden conditions in the HoneySQL conditions vector `conditions` (recursive), nil if none are forbidden." 242 | [schema conditions permissions] 243 | (not-empty 244 | (remove #(allowed-condition? schema % permissions) 245 | conditions))) 246 | 247 | (defn concatenate-extra-conditions 248 | "Appends extra conditions to `conditions` restricting read access according to access control permissions." 249 | [env fields conditions] 250 | (let [{:keys [user config]} env 251 | {:keys [id permissions]} user] 252 | (into 253 | (or conditions []) 254 | (when-not (root? user) 255 | (fields-extra-read-conditions (:schema config) fields permissions id (:user-etype config)))))) 256 | 257 | (defn check-query-arguments 258 | "Returns true if arguments to `specomation.core/query` are allowed, throws exceptions if not." 259 | [env fields conditions] 260 | (let [{:keys [user config]} env 261 | {:keys [schema]} config] 262 | (if (root? user) 263 | true 264 | (if-let [my-forbidden-conditions (forbidden-conditions schema conditions (:permissions user))] 265 | (throw (ex-info "Access to conditions denied" {:conditions my-forbidden-conditions})) 266 | (if-let [forbidden-entities (fields-forbidden-entities schema 267 | (u/fields-without-verbs fields) 268 | (:permissions user))] 269 | (throw (ex-info "Access to entities denied" {:entities forbidden-entities})) 270 | (if-let [forbidden-fields (not-empty (remove #(sc/field-defined? schema %) 271 | (u/flatten-fields (u/fields-without-verbs fields))))] 272 | (throw (ex-info "Access to fields denied" {:entities forbidden-fields})) 273 | true)))))) 274 | -------------------------------------------------------------------------------- /src/specomatic_db/core.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.core 2 | "The main namespace for consumers of specomatic-db. Contains functions for initialisation, retrieving and persisting entities." 3 | (:require 4 | [clojure.spec.alpha :as s] 5 | [clojure.tools.logging :as log] 6 | [nedap.speced.def :as sd] 7 | [next.jdbc :as jdbc] 8 | [seql.query :as sq] 9 | [specomatic-db.access-control :as ac] 10 | [specomatic-db.core.impl :as impl] 11 | [specomatic-db.db.conversion :as cnv] 12 | [specomatic-db.db.firebird.conversion] 13 | [specomatic-db.db.firebird.migration] 14 | [specomatic-db.db.firebird.mutation] 15 | [specomatic-db.db.generic :as db-generic] 16 | [specomatic-db.db.migration :as migration] 17 | [specomatic-db.db.mutation :as mutation] 18 | [specomatic-db.db.postgres.migration] 19 | [specomatic-db.db.postgres.mutation] 20 | [specomatic-db.db.sql :as sql] 21 | [specomatic-db.field-def :as sdf] 22 | [specomatic-db.seql :as seql] 23 | [specomatic-db.spec :as sp] 24 | [specomatic.core :as sc] 25 | [specomatic.field-def :as sf] 26 | [specomatic.util :as su])) 27 | 28 | (sd/defn init! 29 | "Given the environment `env`, does all necessary initialization. 30 | To skip automatic database schema migration, pass `{:skip-migration? true}` as a second argument. 31 | Currently validates the schema, initializes transaction infrastructure, ensures access control views exist and registers coercion functions." 32 | ([^::sp/env env] 33 | (init! env {})) 34 | ([^::sp/env env {:keys [:skip-migration?]}] 35 | (let [{:keys [config jdbc]} env 36 | {:keys [schema]} config] 37 | (log/info "Validating the schema...") 38 | (when-not (s/valid? ::sp/schema 39 | schema) 40 | (throw (let [expl (s/explain-str ::sp/schema 41 | schema)] 42 | (ex-info (str "Invalid schema: " expl) 43 | {:schema schema 44 | :explain expl})))) 45 | (log/info "Ensuring transaction infrastructure exists...") 46 | (migration/ensure-transaction-infrastructure! jdbc) 47 | (log/info "Clearing system transaction ids...") 48 | (migration/clear-transaction-system-txid! jdbc) 49 | (when-not skip-migration? 50 | (migration/update-schema! jdbc (:schema config))) 51 | (log/info "Initializing access control views...") 52 | (ac/ensure-views-exist! jdbc config) 53 | (log/info "Initializing transformation rules...") 54 | (seql/set-transform! schema) 55 | (log/info "Initialization complete.")))) 56 | 57 | (sd/defn default-fields 58 | "Given `schema` and entity type `etype`, returns a seql vector of default fields." 59 | ^::sq/seql-query [^::sp/schema schema ^::sp/etype etype] 60 | (vec 61 | (for [[field field-def] (sc/field-defs schema etype)] 62 | (if (sf/relational? field-def) 63 | (let [target (sf/target field-def)] 64 | {field (into [(sc/id-field schema target)] 65 | (map (partial su/qualify target) (sc/display-name-fields schema target)))}) 66 | field)))) 67 | 68 | (sd/defn entity-history 69 | "Retrieves the full history of an entity." 70 | ^::sp/query-result [^::sp/env env ^::sp/etype etype id ^::sq/seql-query fields] 71 | (impl/entity-history env etype id fields)) 72 | 73 | (sd/defn query 74 | "Given the environment `env`, retrieves the seql `fields` from the `etype` entities matching the HoneySQL `conditions`. 75 | Optionally, the root entity may contain verbs like :verb/read, :verb/update as fields in addition to seql fields. 76 | These contain a boolean indicating whether or not the user (given by [:user :id] in `env`) is allowed to do what the verb describes with the specific entity. 77 | Shape of `env`: 78 | {:jdbc database specification suitable for use with next.jdbc 79 | :config specomatic config 80 | :user {:id user id 81 | :permissions sequence of permissions 82 | :root? if user is root}}" 83 | ^::sp/query-result 84 | ([^::sp/env env ^::sp/etype etype] 85 | (query env etype nil nil)) 86 | ([^::sp/env env ^::sp/etype etype ^::sp/nilable-query fields] 87 | (query env etype fields nil)) 88 | ([^::sp/env env ^::sp/etype etype ^::sp/nilable-query fields ^::sp/conditions conditions] 89 | (let [schema (get-in env [:config :schema]) 90 | my-fields (or fields 91 | (default-fields schema etype))] 92 | (ac/check-query-arguments env my-fields conditions) 93 | (impl/execute-query env 94 | etype 95 | my-fields 96 | (ac/concatenate-extra-conditions env my-fields conditions))))) 97 | 98 | (sd/defn by-id 99 | "Retrieves an entity by id. Returns nil if not found." 100 | (^::sd/nilable ^map? [^::sp/env env ^::sp/etype etype id ^::sq/seql-query fields] 101 | (-> (query env etype fields [[:= (sc/id-field (get-in env [:config :schema]) etype) id]]) 102 | first)) 103 | (^::sd/nilable ^map? [^::sp/env env ^::sp/etype etype id] 104 | (by-id env etype id (default-fields (get-in env [:config :schema]) etype)))) 105 | 106 | (defmulti save-related! 107 | "Saves the changeset `value` for related entities contained in a relational `field` of a entity to the database. 108 | `opts` is a map of outer-etype and outer-id. 109 | If `:specomatic.core/delete` is true in the related entity, it is deleted. 110 | Otherwise, if the id field of the related entity is not nil, it is updated, if the id field is not present or nil, it is created. 111 | In the case of a reference collection of a has-many-through type, these mutations are applied to the join table, not the actual related entity." 112 | (fn [_env _field field-def _value _opts] [(sf/kind field-def) (sf/reference-type field-def)])) 113 | 114 | (defn- extract-reference-id 115 | [my-ref id-field] 116 | (if (map? my-ref) 117 | (id-field my-ref) 118 | my-ref)) 119 | 120 | (defn- extract-reference-ids 121 | [schema etype entity] 122 | (merge entity 123 | (into {} 124 | (for [[field field-def] (sc/field-defs schema etype) 125 | :when (and (sf/relational? field-def) 126 | (sdf/owns-relation? field-def) 127 | (nil? (sdf/join-table field-def)) 128 | (field entity))] 129 | [field 130 | (let [target-id-field (sc/id-field schema (sf/target field-def))] 131 | (-> entity 132 | field 133 | (extract-reference-id target-id-field)))])))) 134 | 135 | (defn- create* 136 | [{:keys [config jdbc user] 137 | :as env} 138 | etype 139 | entity] 140 | (let [{:keys [schema]} config 141 | my-entity (extract-reference-ids schema etype entity) 142 | result (mutation/insert! jdbc schema etype my-entity) 143 | my-entity-id-value (:id result) 144 | transaction-id (:tx/id result) 145 | entity-id (sc/id-field schema etype) 146 | ret (merge entity 147 | {entity-id my-entity-id-value 148 | :tx/id transaction-id} 149 | (into {} 150 | (for [[field field-def] (sc/field-defs schema etype) 151 | :let [v (field my-entity)] 152 | :when (and v (sdf/save-related? field-def))] 153 | [field 154 | (save-related! env 155 | field 156 | field-def 157 | v 158 | {:outer-etype etype 159 | :outer-id my-entity-id-value})])))] 160 | (when-not (or 161 | (:root? user) 162 | (ac/allowed-all? user :verb/create etype) 163 | (:verb/create (by-id env etype my-entity-id-value [entity-id :verb/create]))) 164 | (throw (ex-info "Permission denied" 165 | {:etype etype 166 | :entity entity}))) 167 | ret)) 168 | 169 | (sd/defn create! 170 | "Given the environment `env`, creates the `entity` of type `etype` in the database. 171 | Returns the given `entity` containing the new id and transaction id. 172 | Shape of `env`: 173 | {:jdbc database specification suitable for use with next.jdbc 174 | :config specomatic config 175 | :user {:id user id 176 | :permissions sequence of permissions 177 | :root? if user is root}}" 178 | ^map? [^::sp/env env ^::sp/etype etype ^map? entity] 179 | (let [{:keys [jdbc user]} env] 180 | (when-not (s/valid? etype 181 | entity) 182 | (throw (let [expl (s/explain-str etype 183 | entity)] 184 | (ex-info (str "Invalid entity: " expl) 185 | {:etype etype 186 | :entity entity 187 | :explain expl})))) 188 | (when-not (or (:root? user) 189 | (ac/allowed-some? user :verb/create etype)) 190 | ;; We are not allowed to create any of the `etype` entities 191 | (throw (ex-info "Permission denied" 192 | {:etype etype 193 | :entity entity}))) 194 | (jdbc/with-transaction 195 | [trans jdbc] 196 | (create* (assoc env :jdbc trans) etype entity)))) 197 | 198 | (defn- update* 199 | [{:keys [jdbc user] 200 | :as env} etype entity id] 201 | (when-not (or (:root? user) 202 | (ac/allowed-some? user :verb/update etype)) 203 | (throw (ex-info "Permission denied" 204 | {:etype etype 205 | :entity entity}))) 206 | (let [schema (get-in env [:config :schema]) 207 | my-entity (extract-reference-ids schema etype entity) 208 | entity-id (sc/id-field schema etype) 209 | cond-snippet (ac/conditions-snippet schema 210 | [etype] 211 | (get-in env [:user :permissions]) 212 | :verb/update 213 | {:user-id (:id user) 214 | :user-etype (get-in env [:config :user-etype])}) 215 | result (mutation/update! jdbc 216 | schema 217 | etype 218 | my-entity 219 | cond-snippet)] 220 | (if-let [tx-id (:tx/id result)] 221 | ;; Happy path 222 | (merge entity 223 | {entity-id id 224 | :tx/id tx-id} 225 | (into {} 226 | (for [[field field-def] (sc/field-defs schema etype) 227 | :let [v (field my-entity)] 228 | :when (and v (sdf/save-related? field-def))] 229 | [field 230 | (save-related! env 231 | field 232 | field-def 233 | v 234 | {:outer-etype etype 235 | :outer-id id})]))) 236 | ;; The statement didn't return anything, let's check why 237 | (when (and cond-snippet (by-id env etype id [entity-id])) 238 | ;; We are only allowed to update some of the `etype` entities 239 | ;; AND we are allowed to read the entity, so it must be due to permissions 240 | (throw (ex-info "Permission denied" 241 | {:etype etype 242 | :entity entity})))))) 243 | 244 | (sd/defn update! 245 | "Given the environment `env`, updates the `entity` of type `etype` in the database. 246 | Returns the given `entity` containing the transaction id. 247 | Shape of `env`: 248 | {:jdbc database specification suitable for use with next.jdbc 249 | :config specomatic config 250 | :user {:id user id 251 | :permissions sequence of permissions 252 | :root? if user is root}}" 253 | ^map? [^::sp/env env ^::sp/etype etype ^map? entity] 254 | (let [{:keys [jdbc user]} env 255 | entity-id (sc/id-field (get-in env [:config :schema]) etype)] 256 | (when-not (s/valid? (s/keys) 257 | entity) 258 | (throw (let [expl (s/explain-str etype 259 | entity)] 260 | (ex-info (str "Invalid changeset: " expl) 261 | {:etype etype 262 | :entity entity 263 | :explain (s/explain-str (s/keys) 264 | entity)})))) 265 | (when-not (or (:root? user) 266 | (ac/allowed-some? user :verb/update etype)) 267 | ;; We are not allowed to update any of the `etype` entities 268 | (throw (ex-info "Permission denied" 269 | {:etype etype 270 | :entity entity}))) 271 | (jdbc/with-transaction 272 | [trans jdbc] 273 | (update* (assoc env :jdbc trans) etype entity (entity-id entity))))) 274 | 275 | (sd/defn save! 276 | "Given the environment `env`, saves the `entity` of type `etype` into the database. 277 | Tries to create the entity if its id field is nonexistent or nil. 278 | Tries to update the entity if it has an id. 279 | Returns the given `entity` containing the new id (if created) and transaction id. 280 | Shape of `env`: 281 | {:jdbc database specification suitable for use with next.jdbc 282 | :config specomatic config 283 | :user {:id user id 284 | :permissions sequence of permissions 285 | :root? if user is root}}" 286 | ^map? [^::sp/env env ^::sp/etype etype ^map? entity] 287 | (let [entity-id (sc/id-field (get-in env [:config :schema]) etype) 288 | entity-id-value (entity-id entity) 289 | new? (nil? entity-id-value)] 290 | (if new? 291 | (create! env etype entity) 292 | (update! env etype entity)))) 293 | 294 | (defn- delete* 295 | [{:keys [config jdbc user] 296 | :as env} etype id] 297 | (let [{:keys [schema user-etype]} config 298 | cond-snippet (ac/conditions-snippet schema 299 | [etype] 300 | (:permissions user) 301 | :verb/delete 302 | {:user-id (:id user) 303 | :user-etype user-etype}) 304 | result (mutation/delete! jdbc 305 | schema 306 | etype 307 | id 308 | cond-snippet)] 309 | (if (:tx/id result) 310 | ;; Happy path 311 | (dissoc result :tx/ts) 312 | ;; The statement didn't return anything, let's check why 313 | (when (and cond-snippet (by-id env etype id [(sc/id-field (get-in env [:config :schema]) etype)])) 314 | ;; We are only allowed to delete some of the `etype` entities 315 | ;; AND we are allowed to read the entity, so it must be due to permissions 316 | ;; We are allowed to read the entity, so it must be due to permissions 317 | (throw (ex-info "Permission denied" 318 | {:etype etype 319 | :id id})))))) 320 | 321 | (sd/defn delete! 322 | "Given the environment `env`, delete the `entity` of type `etype`. 323 | Returns a map of id, :tx/id, nil if not found (might be due to permissions). 324 | Shape of `env`: 325 | {:jdbc database specification suitable for use with next.jdbc 326 | :config specomatic config 327 | :user {:id user id 328 | :permissions sequence of permissions 329 | :root? if user is root}}" 330 | [^::sp/env env ^::sp/etype etype id] 331 | (let [{:keys [jdbc user]} env] 332 | (when-not (or (:root? user) 333 | (ac/allowed-some? user :verb/delete etype)) 334 | ;; We are not allowed to delete any of the `etype` entities 335 | (throw (ex-info "Permission denied" 336 | {:etype etype 337 | :id id}))) 338 | (jdbc/with-transaction 339 | [trans jdbc] 340 | (delete* (assoc env :jdbc trans) etype id)))) 341 | 342 | (defmethod save-related! :default 343 | [_env _field _field-def _value _opts] 344 | nil) 345 | 346 | (defmethod save-related! [::sf/reference :has-one] 347 | [env _field field-def value {:keys [outer-id]}] 348 | (let [target (sf/target field-def) 349 | target-id (sc/id-field (get-in env [:config :schema]) target) 350 | via (sdf/db-via field-def) 351 | target-id-value (target-id value)] 352 | (if (::delete value) 353 | (when target-id-value 354 | (delete* env target target-id-value)) 355 | (if target-id-value 356 | (merge value (update* env target value target-id-value)) 357 | (merge value (create* env target (assoc value via outer-id))))))) 358 | 359 | (defmethod save-related! [::sf/reference-coll :has-many] 360 | [env _field field-def value {:keys [outer-id]}] 361 | (let [target (sf/target field-def) 362 | target-id (sc/id-field (get-in env [:config :schema]) target) 363 | via (sdf/db-via field-def)] 364 | (->> 365 | (for [entity value 366 | :let [target-id-value (target-id entity)]] 367 | (if (::delete entity) 368 | (when target-id-value 369 | (delete* env target target-id-value)) 370 | (if target-id-value 371 | (merge entity (update* env target entity target-id-value)) 372 | (merge entity (create* env target (assoc entity via outer-id)))))) 373 | (filterv some?)))) 374 | 375 | (defmethod save-related! [::sf/reference-coll :has-many-through] 376 | [{:keys [jdbc]} _field field-def value {:keys [outer-id]}] 377 | (let [join-table (sdf/join-table field-def) 378 | [_ etype-fk target-fk target-id] (sdf/db-via field-def)] 379 | (->> 380 | (for [my-ref value 381 | :let [target-id-value (if (map? my-ref) 382 | (target-id my-ref) 383 | my-ref)] 384 | :when target-id-value] 385 | (let [table (cnv/etype->table-name jdbc join-table nil) 386 | entity-fk-column (cnv/field->column-name jdbc etype-fk nil) 387 | target-fk-column (cnv/field->column-name jdbc target-fk nil)] 388 | (if (::delete my-ref) 389 | (do (db-generic/delete-reference-coll-element! 390 | jdbc 391 | {:table table 392 | :entity-id outer-id 393 | :entity-idfield entity-fk-column 394 | :target-id target-id-value 395 | :target-idfield target-fk-column}) 396 | nil) 397 | (do (sql/upsert-reference-coll-element! jdbc 398 | {:table table 399 | :entity-id outer-id 400 | :entity-idfield entity-fk-column 401 | :target-id target-id-value 402 | :target-idfield target-fk-column}) 403 | my-ref)))) 404 | (filterv some?)))) 405 | -------------------------------------------------------------------------------- /src/specomatic_db/core/impl.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.core.impl 2 | (:require 3 | [clojure.set :as set] 4 | [specomatic-db.access-control :as ac] 5 | [specomatic-db.db.conversion :as cnv] 6 | [specomatic-db.schema :as db-schema] 7 | [specomatic-db.seql :as seql] 8 | [specomatic.core :as sc])) 9 | 10 | (defn- historic-conditions 11 | "Returns extra conditions for historic queries" 12 | [config etype fields txid] 13 | (let [[root joined] (seql/query-tables config etype fields)] 14 | (into 15 | [[:and 16 | [:>= txid (keyword (str (name root)) "txid_from")] 17 | [:< txid (keyword (str (name root)) "txid_until")] 18 | [:!= "D" (keyword (str (name root)) "mut")]]] 19 | (mapv #(vec 20 | [:or 21 | [:= (keyword (str (name %)) "txid_from") nil] 22 | [:and 23 | [:>= txid (keyword (str (name %)) "txid_from")] 24 | [:< txid (keyword (str (name %)) "txid_until")] 25 | [:!= "D" (keyword (str (name %)) "mut")]]]) 26 | joined)))) 27 | 28 | (defn- postprocess-entity 29 | [etype entity config allowed-or-preds-by-verb] 30 | (let [verb-map 31 | (into {} 32 | (for [[verb allowed-or-preds] allowed-or-preds-by-verb] 33 | [verb 34 | (if (true? allowed-or-preds) 35 | true 36 | (some? (some #(-> entity 37 | ((keyword (name etype) (ac/view-name-seql % etype))) 38 | first 39 | ((keyword (ac/view-name-seql % etype) 40 | (name (db-schema/default-fk-column (:schema config) etype))))) 41 | allowed-or-preds)))])) 42 | preds (->> allowed-or-preds-by-verb 43 | vals 44 | (filter set?) 45 | (apply set/union)) 46 | my-entity (apply dissoc 47 | entity 48 | (map #(keyword (name etype) 49 | (ac/view-name-seql % etype)) 50 | preds))] 51 | (merge 52 | my-entity 53 | verb-map))) 54 | 55 | (defn entity-history 56 | "Retrieves the full history of an entity." 57 | [env etype id fields] 58 | (let [config 59 | (:config env) 60 | 61 | schema 62 | (seql/schema-historic config) 63 | 64 | seql-env 65 | (-> env 66 | (dissoc :config) 67 | (assoc :schema schema)) 68 | 69 | table 70 | (cnv/etype->query-table-keyword etype (sc/etype-def (:schema config) etype)) 71 | 72 | [seql-etype my-fields my-conditions allowed-or-preds-by-verb] 73 | (seql/query env 74 | etype 75 | (into fields [(keyword (name table) "txid_from") (keyword (name table) "txid_until")]) 76 | [[:= (sc/id-field (get-in env [:config :schema]) etype) id]] 77 | cnv/etype->historic-query-table-keyword)] 78 | (map #(postprocess-entity etype % config allowed-or-preds-by-verb) 79 | (seql/execute-query seql-env 80 | seql-etype 81 | my-fields 82 | my-conditions)))) 83 | 84 | (defn execute-query 85 | "Given the environment `env`, retrieves a sequence of `etype` entities containing the seql-style `fields` and matching the HoneySQL `conditions`. 86 | Optionally, the root entity may contain verbs like :verb/read, :verb/create as fields in addition to seql fields. 87 | These contain a boolean indicating whether or not the user (given by [:user :id] in `env`) is allowed to do what the verb describes with the specific entity. 88 | Shape of `env`: 89 | {:jdbc database specification suitable for use with next.jdbc 90 | :config specomatic config}" 91 | [env etype fields conditions] 92 | (let [{config :config 93 | txid :tx/id} 94 | env 95 | 96 | schema (if txid 97 | (seql/schema-historic config) 98 | (seql/schema config)) 99 | 100 | conditions 101 | (if txid 102 | (into (historic-conditions config etype fields txid) 103 | conditions) 104 | conditions) 105 | 106 | [seql-etype my-fields my-conditions allowed-or-preds-by-verb] 107 | (seql/query env 108 | etype 109 | fields 110 | conditions 111 | (if txid 112 | cnv/etype->historic-query-table-keyword 113 | cnv/etype->query-table-keyword)) 114 | 115 | seql-env 116 | (-> env 117 | (dissoc :config) 118 | (assoc :schema schema))] 119 | (map #(postprocess-entity etype % config allowed-or-preds-by-verb) 120 | (seql/execute-query seql-env 121 | seql-etype 122 | my-fields 123 | my-conditions)))) 124 | -------------------------------------------------------------------------------- /src/specomatic_db/db/conversion.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.db.conversion 2 | "Provides conversions between entity types and database records / columns." 3 | (:require 4 | [clojure.spec.alpha :as s] 5 | [clojure.string :as str] 6 | [nedap.speced.def :as sd] 7 | [specomatic-db.db.type :refer [get-dbtype]] 8 | [specomatic-db.etype-def :as sde] 9 | [specomatic-db.field-def :as sdf] 10 | [specomatic-db.spec :as sp] 11 | [specomatic.core :as sc] 12 | [specomatic.field-def :as sf])) 13 | 14 | (sd/defn quotable-identifier-dispatch 15 | "Dispatch function for `keyword->sql-identifier`" 16 | ^string? 17 | [db ^string? _identifier] 18 | (get-dbtype db)) 19 | 20 | (defmulti quotable-sql-identifier 21 | "Returns the quotable SQL identifier (with adjusted case) for the given keyword `k`." 22 | quotable-identifier-dispatch) 23 | 24 | (defmethod quotable-sql-identifier :default [_db identifier] identifier) 25 | 26 | (def ^:private valid-sql-identifier-re 27 | "A regular expression for validating strings representing an SQL identifier." 28 | #"^[A-Za-z][A-Za-z0-9\-_]+$") 29 | 30 | (defn valid-sql-identifier-keyword? 31 | "Checks if keyword `k` can be converted into a valid SQL identifier." 32 | [k] 33 | (and 34 | (keyword? k) 35 | (re-matches valid-sql-identifier-re (name k)))) 36 | 37 | (s/def ::sql-keyword valid-sql-identifier-keyword?) 38 | 39 | (sd/defn etype->table-name 40 | "Returns the SQL table name for the `db` and entity type `etype`. " 41 | ^string? 42 | [db 43 | ^::sql-keyword etype 44 | etype-def] 45 | (let [etype-table-name (when etype-def 46 | (when-let [my-table-name (sde/table-name etype-def)] 47 | (name my-table-name)))] 48 | (quotable-sql-identifier db (str/replace (or etype-table-name (name etype)) "-" "_")))) 49 | 50 | (sd/defn field->column-name 51 | "Returns the SQL column name for the `db`, `field` and field definition `field-def`. " 52 | ^string? 53 | [db 54 | ^::sql-keyword field 55 | ^::sd/nilable ^::sp/field-def field-def] 56 | (let [column-name (when field-def 57 | (when-let [my-column-name (sdf/column-name field-def)] 58 | (name my-column-name)))] 59 | (quotable-sql-identifier db 60 | (str/replace (or column-name (name field)) "-" "_")))) 61 | 62 | (sd/defn etype->id-column 63 | "Returns table id column name for given entity type." 64 | ^string? 65 | [db 66 | ^map? schema 67 | ^::sql-keyword etype] 68 | (let [id-field (sc/id-field schema etype)] 69 | (field->column-name db id-field (sc/field-def schema id-field)))) 70 | 71 | (defn etype->query-table-keyword 72 | "Returns table / view name for querying given entity type `etype`." 73 | [etype etype-def] 74 | (let [etype-query-name (when etype-def 75 | (when-let [my-table-name (sde/query-name etype-def)] 76 | (name my-table-name)))] 77 | (keyword (str/replace (or etype-query-name (name etype)) "-" "_")))) 78 | 79 | (defn etype->historic-query-table-keyword 80 | "Returns default table / view name for querying the history of given entity type `etype`." 81 | [etype etype-def] 82 | (keyword (str (name (etype->query-table-keyword etype etype-def)) "_h"))) 83 | 84 | (defmulti db-field-value->entity-field-value-impl 85 | "Coerces field `value` with spec `fspec` from database into entity representation." 86 | (fn [fspec _value] fspec)) 87 | 88 | (defmethod db-field-value->entity-field-value-impl :default 89 | [_fspec value] 90 | value) 91 | 92 | (defn db-field-value->entity-field-value 93 | "Coerces field `value` with spec `fspec` from database into entity representation. 94 | Handles some common cases internally, delegates to db-field-value->entity-field-value-impl for everything else." 95 | [fspec value] 96 | (db-field-value->entity-field-value-impl fspec 97 | value)) 98 | 99 | (defmulti entity-field-value->db-field-value-impl 100 | "Coerces field `value` with spec `fspec` from entity into database representation." 101 | (fn [_schema fspec _value] fspec)) 102 | 103 | (defmethod entity-field-value->db-field-value-impl :default 104 | [_schema _fspec value] 105 | value) 106 | 107 | (defn entity-field-value->db-field-value 108 | "Coerces field `value` with spec `fspec` from entity into database representation. 109 | Can handle some common cases internally, delegates to entity-field-value->db-field-value-impl for everything else." 110 | [schema fspec value] 111 | (entity-field-value->db-field-value-impl schema fspec value)) 112 | 113 | (defn entity->row 114 | "Converts an entity to a database table row." 115 | [db schema etype entity] 116 | (when-let [field-defs (sc/field-defs schema etype)] 117 | (let [entity-id (sc/id-field schema etype) 118 | fields (into {} 119 | (map (fn [[field value]] 120 | (when-let [field-def (field field-defs)] 121 | (when-not (or (sf/inverse? field-def) 122 | (sf/reference-coll? field-def)) 123 | [(field->column-name db field field-def) 124 | (entity-field-value->db-field-value schema 125 | (sf/dispatch field-def) 126 | value)])))) 127 | entity)] 128 | (assoc fields 129 | (etype->id-column db schema etype) 130 | (get entity entity-id))))) 131 | -------------------------------------------------------------------------------- /src/specomatic_db/db/firebird/conversion.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.firebird.conversion 2 | "Provides conversion specialisation for firebird." 3 | (:require 4 | [clojure.string :as str] 5 | [specomatic-db.db.conversion :as cnv] 6 | [specomatic-db.db.firebird.util :refer [firebirdsql]])) 7 | 8 | (defmethod cnv/quotable-sql-identifier firebirdsql 9 | [_db identifier] 10 | (str/upper-case identifier)) 11 | -------------------------------------------------------------------------------- /src/specomatic_db/db/firebird/migration.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.firebird.migration 2 | "Implements migration multimethods for firebird sql storage." 3 | (:require 4 | [clojure.set :as set] 5 | [clojure.string :as str] 6 | [specomatic-db.db.conversion :as cnv] 7 | [specomatic-db.db.firebird.sql :as db-firebird] 8 | [specomatic-db.db.firebird.util :refer [firebirdsql]] 9 | [specomatic-db.db.generic :as db-generic] 10 | [specomatic-db.db.migration :as migration] 11 | [specomatic.core :as sc] 12 | [specomatic.field-def :as sf] 13 | [specomatic.spec :as sp])) 14 | 15 | (defmethod migration/column-def firebirdsql 16 | [db schema table-name field-keyword 17 | {:keys [cascade?] 18 | :as field-def} 19 | {:keys [historical?]}] 20 | (if (sf/reference? field-def) 21 | (let [column-name (cnv/field->column-name db field-keyword field-def) 22 | target (sf/target field-def)] 23 | (merge 24 | {:main (first (db-firebird/ref-column-def {:name column-name}))} 25 | (when-not historical? 26 | {:constraint {:table table-name 27 | :cascade? cascade? 28 | :column column-name 29 | :target (cnv/etype->table-name db target (sc/etype-def schema target))}}))) 30 | {:main (first (db-firebird/column-def {:name (cnv/field->column-name db field-keyword field-def) 31 | :type (migration/sql-type firebirdsql (sf/dispatch field-def))}))})) 32 | 33 | (defn- constraints-ddl 34 | [table-name existing-constraints constraints-params] 35 | (let [n (count constraints-params)] 36 | (loop [i 0 37 | constraint-name-i 0 38 | all-constraints existing-constraints 39 | constraint-ddl []] 40 | (if (= i n) 41 | constraint-ddl 42 | (let [constraint-name (str "FK_" table-name constraint-name-i) 43 | existing? (some #{constraint-name} all-constraints)] 44 | (recur (if existing? 45 | i 46 | (inc i)) 47 | (inc constraint-name-i) 48 | (if existing? 49 | all-constraints 50 | (conj all-constraints constraint-name)) 51 | (if existing? 52 | constraint-ddl 53 | (conj constraint-ddl 54 | (db-firebird/alter-table-add-foreign-key-sqlvec 55 | (assoc (nth constraints-params i) :constraint-name constraint-name)))))))))) 56 | 57 | (defmethod migration/create-table firebirdsql 58 | [db schema table-name id-field {:keys [existing-constraints field-defs join-table-unique-constraint]}] 59 | (let [column-ddl (for [[field field-def] field-defs] 60 | (migration/column-def db schema table-name field field-def {})) 61 | historical-column-ddl (for [[field field-def] field-defs] 62 | (migration/column-def db schema table-name field field-def {:historical? true})) 63 | column-defs (map :main column-ddl) 64 | historical-column-defs (map :main historical-column-ddl)] 65 | (when (seq column-defs) 66 | (let [params {:id-field (cnv/field->column-name db id-field nil) 67 | :table table-name 68 | :column-defs (str/join "," column-defs) 69 | :column-names (mapv (fn [[field field-def]] 70 | (cnv/field->column-name db field field-def)) 71 | field-defs) 72 | :join-table-unique-constraint join-table-unique-constraint 73 | :historical-column-defs historical-column-defs}] 74 | {:main (concat 75 | ((juxt db-firebird/create-generic-sqlvec 76 | db-firebird/create-pk-sequence-sqlvec 77 | db-firebird/create-pk-sequence-trigger-sqlvec) 78 | params) 79 | ((juxt 80 | db-firebird/create-generic-history-sqlvec 81 | db-firebird/create-or-alter-history-trigger-sqlvec) 82 | (assoc params :column-defs (str/join "," historical-column-defs)))) 83 | :constraints (constraints-ddl table-name existing-constraints (filter some? (map :constraint column-ddl)))})))) 84 | 85 | (defmethod migration/diff-table firebirdsql 86 | [db schema table-name id-field {:keys [existing-constraints field-defs]}] 87 | (let [fields-to-db-columns (into {} 88 | (for [[field field-def] field-defs] 89 | [field 90 | (cnv/field->column-name db field field-def)])) 91 | db-columns-to-fields (set/map-invert fields-to-db-columns) 92 | existing-columns (->> (db-firebird/select-fields db {:table-name table-name}) 93 | (map (comp str/trim :rdb$field_name)) 94 | set) 95 | missing-column-defs (for [missing-column-name (set/difference (-> fields-to-db-columns 96 | vals 97 | set) 98 | existing-columns) 99 | :let [missing-field (get db-columns-to-fields missing-column-name) 100 | field-def (missing-field field-defs)]] 101 | [(migration/column-def db schema table-name missing-field field-def {}) 102 | (migration/column-def db 103 | schema 104 | table-name 105 | missing-field 106 | field-def 107 | {:historical? true})])] 108 | (when (seq missing-column-defs) 109 | (let [column-defs (str/join "," 110 | (map #(->> % 111 | first 112 | :main 113 | (str "add ")) 114 | missing-column-defs)) 115 | historical-column-defs (str/join "," 116 | (map #(->> % 117 | second 118 | :main 119 | (str "add ")) 120 | missing-column-defs))] 121 | {:main [(db-generic/alter-table-sqlvec 122 | {:table table-name 123 | :column-defs column-defs}) 124 | (db-generic/alter-table-sqlvec 125 | {:table (str table-name "_H") 126 | :column-defs historical-column-defs}) 127 | (db-firebird/create-or-alter-history-trigger-sqlvec 128 | {:table table-name 129 | :id-field (cnv/field->column-name db id-field nil) 130 | :column-names (mapv (fn [[field field-def]] 131 | (cnv/field->column-name db field field-def)) 132 | field-defs)})] 133 | :constraints (constraints-ddl table-name 134 | existing-constraints 135 | (filter some? 136 | (map #(-> % 137 | first 138 | :constraint) 139 | missing-column-defs)))})))) 140 | 141 | (defmethod migration/get-constraints firebirdsql 142 | [db] 143 | (map (comp str/trim :rdb$constraint_name) (db-firebird/select-all-constraints db))) 144 | 145 | (defmethod migration/get-tables firebirdsql 146 | [db] 147 | (map (comp str/trim :rdb$relation_name) (db-firebird/select-all-tables db))) 148 | 149 | (defmethod migration/ensure-transaction-infrastructure! firebirdsql 150 | [db] 151 | (db-firebird/ensure-table-transaction db) 152 | (db-firebird/ensure-sequence-transaction db) 153 | (db-firebird/ensure-procedure-get-transaction db)) 154 | 155 | (defmethod migration/clear-transaction-system-txid! firebirdsql 156 | [db] 157 | (db-firebird/clear-transaction-system-txid db)) 158 | 159 | (defmethod migration/sql-type [firebirdsql ::sp/integer] 160 | [_ _] 161 | "integer") 162 | 163 | (defmethod migration/sql-type [firebirdsql 'integer?] 164 | [_ _] 165 | "integer") 166 | -------------------------------------------------------------------------------- /src/specomatic_db/db/firebird/mutation.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.firebird.mutation 2 | "Implements mutation multimethods for firebird sql storage." 3 | (:require 4 | [clojure.string :as str] 5 | [clojure.walk :refer [keywordize-keys]] 6 | [specomatic-db.db.conversion :as cnv] 7 | [specomatic-db.db.firebird.sql :as sql] 8 | [specomatic-db.db.firebird.util :refer [firebirdsql]] 9 | [specomatic-db.db.mutation :refer [insert! update! delete!]] 10 | [specomatic.core :as sc])) 11 | 12 | (defmethod insert! firebirdsql 13 | [db schema etype entity] 14 | (let [table-name (cnv/etype->table-name db etype (sc/etype-def schema etype)) 15 | id-column (cnv/etype->id-column db schema etype) 16 | row (cnv/entity->row db schema etype entity) 17 | result 18 | (sql/insert! db 19 | {:table table-name 20 | :id-field (cnv/etype->id-column db schema etype) 21 | :cols (keys row) 22 | :vals (vals row)})] 23 | (merge row 24 | {:id (get result (keyword (str/lower-case id-column))) 25 | :tx/id (:txid result) 26 | :tx/ts (:txts result)}))) 27 | 28 | (defmethod update! firebirdsql 29 | [db schema etype entity ac-conditions] 30 | (let [table-name (cnv/etype->table-name db etype (sc/etype-def schema etype)) 31 | id-column (cnv/etype->id-column db schema etype) 32 | row (cnv/entity->row db schema etype entity) 33 | id (get row id-column) 34 | updates (-> row 35 | (dissoc id-column) 36 | keywordize-keys 37 | not-empty)] 38 | (if updates 39 | (let [result 40 | (sql/update! db 41 | {:table table-name 42 | :id-field (cnv/etype->id-column db schema etype) 43 | :updates updates 44 | :id id 45 | :ac-conditions ac-conditions})] 46 | (merge row 47 | {:id id 48 | :tx/id (:txid result) 49 | :tx/ts (:txts result)})) 50 | (assoc row 51 | :tx/id 52 | :noop)))) 53 | 54 | (defmethod delete! firebirdsql 55 | [db schema etype param-id ac-conditions] 56 | (let [{:keys [id 57 | txid 58 | txts]} 59 | (sql/delete! db 60 | {:table (cnv/etype->table-name db etype (sc/etype-def schema etype)) 61 | :id-field (cnv/etype->id-column db schema etype) 62 | :id param-id 63 | :ac-conditions ac-conditions})] 64 | (when txid 65 | {:id id 66 | :tx/id txid 67 | :tx/ts txts}))) 68 | -------------------------------------------------------------------------------- /src/specomatic_db/db/firebird/sql.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.firebird.sql 2 | "Implements multimethods with hugsql functions for firebird sql storage." 3 | (:require 4 | [hugsql.adapter.next-jdbc :as adp] 5 | [hugsql.core :as hugsql] 6 | [specomatic-db.db.firebird.util :refer [firebirdsql]] 7 | [specomatic-db.db.sql :as sql])) 8 | 9 | (hugsql/def-db-fns "sql/firebird.sql" 10 | {:quoting :ansi 11 | :adapter (adp/hugsql-adapter-next-jdbc)}) 12 | 13 | (hugsql/def-sqlvec-fns "sql/firebird.sql" 14 | {:quoting :ansi 15 | :adapter (adp/hugsql-adapter-next-jdbc)}) 16 | 17 | (defmethod sql/create-or-replace-view firebirdsql 18 | [_dbtype params] 19 | (create-or-replace-view-sqlvec params)) 20 | 21 | (defmethod sql/upsert-reference-coll-element! firebirdsql 22 | [db params] 23 | (upsert-reference-coll-element! db params)) 24 | -------------------------------------------------------------------------------- /src/specomatic_db/db/firebird/util.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.firebird.util 2 | "Utilities for firebird.") 3 | 4 | (def firebirdsql 5 | "Defines the dbtype for firebird." 6 | "firebirdsql") 7 | -------------------------------------------------------------------------------- /src/specomatic_db/db/generic.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.generic 2 | "Generates hugsql functions from specomatic-generic.sql." 3 | (:require 4 | [hugsql.adapter.next-jdbc :as adp] 5 | [hugsql.core :as hugsql])) 6 | 7 | (hugsql/def-db-fns "sql/specomatic-generic.sql" 8 | {:quoting :ansi 9 | :adapter (adp/hugsql-adapter-next-jdbc)}) 10 | 11 | (hugsql/def-sqlvec-fns "sql/specomatic-generic.sql" 12 | {:quoting :ansi 13 | :adapter (adp/hugsql-adapter-next-jdbc)}) 14 | -------------------------------------------------------------------------------- /src/specomatic_db/db/migration.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.db.migration 2 | "Contains cross-platform functions, and multimethods to be implemented for specific SQL backends, for database migrations (DDL)." 3 | (:require 4 | [next.jdbc :as jdbc] 5 | [specomatic-db.db.conversion :as cnv] 6 | [specomatic-db.db.type :refer [get-dbtype]] 7 | [specomatic-db.field-def :as sdf] 8 | [specomatic-db.schema :as schema] 9 | [specomatic.core :as sc] 10 | [specomatic.field-def :as sf])) 11 | 12 | (defmulti column-def 13 | "Returns the column definition as SQL string." 14 | get-dbtype) 15 | 16 | (defmulti sql-type 17 | "Returns the sql type for a database type and field spec dispatch value (keyword or description)." 18 | (fn [dbtype dispatch] 19 | [dbtype dispatch])) 20 | 21 | (defmethod sql-type :default 22 | [_ _] 23 | "varchar(255)") 24 | 25 | (defmulti create-table 26 | "Returns the SQL DDL required for creating the table as a map of 27 | {:constraints sqlvecs 28 | :main sqlvecs}" 29 | get-dbtype) 30 | 31 | (defmulti diff-table 32 | "Generates a DDL diff, as a sqlvec, from inspection of the given `db` and comparison with entities of the given `ns`. 33 | Optionally restricted to `etypes` (sequence of keywords). 34 | Returns a map of 35 | {:constraints sqlvecs 36 | :main sqlvecs} 37 | if there are differences, nil if there are not." 38 | get-dbtype) 39 | 40 | (defmulti get-constraints 41 | "Returns a sequence of all constraints in the database." 42 | get-dbtype) 43 | 44 | (defmulti get-tables 45 | "Returns a sequence of all tables in the database." 46 | get-dbtype) 47 | 48 | (defmulti ensure-transaction-infrastructure! 49 | "Ensures transaction infrastructure exists." 50 | get-dbtype) 51 | 52 | (defmulti clear-transaction-system-txid! 53 | "Clears all system txids from the transaction table." 54 | get-dbtype) 55 | 56 | (defn- diff-etypes 57 | [db tables existing-constraints schema etypes-and-reference-colls] 58 | (for [etype (filter #(or (not etypes-and-reference-colls) 59 | (some #{%} etypes-and-reference-colls)) 60 | (keys schema)) 61 | :let [statements (let [db-fields (schema/persistent-field-defs schema etype) 62 | id-field (->> etype 63 | (sc/id-field schema)) 64 | table-name (cnv/etype->table-name db etype (sc/etype-def schema etype))] 65 | (if (some #{table-name} tables) 66 | (diff-table db 67 | schema 68 | table-name 69 | id-field 70 | {:existing-constraints existing-constraints 71 | :field-defs db-fields}) 72 | (create-table db 73 | schema 74 | table-name 75 | id-field 76 | {:existing-constraints existing-constraints 77 | :field-defs db-fields})))] 78 | :when statements] 79 | [etype statements])) 80 | 81 | (defn- diff-reference-colls 82 | [db tables existing-constraints schema etypes-and-reference-colls] 83 | (for [[etype ref-colls] (sc/reference-colls-by-owning-etype schema) 84 | [ref-coll field-def] (filter #(or (not etypes-and-reference-colls) (some #{%} etypes-and-reference-colls)) 85 | ref-colls) 86 | :let [join-table (sdf/join-table field-def) 87 | target (sf/target field-def) 88 | table-name (cnv/etype->table-name db join-table nil) 89 | id-field (sdf/join-table-id-field field-def) 90 | [_ main-id target-id _] (sdf/db-via field-def) 91 | db-fields {id-field {:kind ::sf/simple 92 | :dispatch 'integer?} 93 | main-id {:kind ::sf/reference 94 | :target etype 95 | :cascade? true} 96 | target-id {:kind ::sf/reference 97 | :target target 98 | :cascade? true}} 99 | statements (when-not (some #{table-name} tables) 100 | (create-table db 101 | schema 102 | table-name 103 | id-field 104 | {:field-defs db-fields 105 | :join-table-unique-constraint 106 | {:main-id (cnv/field->column-name 107 | db 108 | main-id 109 | nil) 110 | :target-id (cnv/field->column-name 111 | db 112 | target-id 113 | nil)}}))] 114 | :when statements] 115 | [ref-coll statements])) 116 | 117 | (defn diff-schema 118 | "Generates a DDL diff from inspection of the given `db` and comparison with entities of the given `schema`. 119 | Optionally restricted to `etypes-and-reference-colls` (sequence of keywords). 120 | Returns a map containing entity types as keys and maps of 121 | {:constraints sqlvecs 122 | :main sqlvecs} 123 | as values." 124 | ([db param-ns] 125 | (diff-schema db param-ns nil)) 126 | ([db schema etypes-and-reference-colls] 127 | (into {} 128 | (let [tables (get-tables db) 129 | constraints (get-constraints db)] 130 | (concat 131 | (diff-reference-colls db tables constraints schema etypes-and-reference-colls) 132 | (diff-etypes db tables constraints schema etypes-and-reference-colls)))))) 133 | 134 | (defn update-schema! 135 | "Updates database `db` for schema `schema`. 136 | Optionally restricted to `etypes` (sequence of keywords). 137 | Defaults to all detected changes." 138 | ([db schema] 139 | (update-schema! db schema nil)) 140 | ([db schema etypes] 141 | (ensure-transaction-infrastructure! db) 142 | (let [updates (vals (diff-schema db schema etypes))] 143 | (doseq [main-statement (reduce concat (map :main updates))] 144 | (jdbc/execute! db main-statement)) 145 | (doseq [constraint-statement (reduce concat (map :constraints updates))] 146 | (jdbc/execute! db constraint-statement))))) 147 | -------------------------------------------------------------------------------- /src/specomatic_db/db/mutation.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.db.mutation 2 | "Defines mutation functions. Should be implemented for specific sql backends." 3 | (:require 4 | [specomatic-db.db.type :refer [get-dbtype]])) 5 | 6 | (defmulti insert! 7 | "Inserts a new record for a given entity. Attaches a new primary key `id`." 8 | (fn [db _schema _etype _entity] 9 | (get-dbtype db))) 10 | 11 | (defmethod insert! :default 12 | [db _ _ _] 13 | (throw (UnsupportedOperationException. (str "No implementation found for inserting entities into database: " db)))) 14 | 15 | (defmulti update! 16 | "Updates a record for a given entity." 17 | (fn [db _schema _etype _entity _ac-conditions] 18 | (get-dbtype db))) 19 | 20 | (defmethod update! :default 21 | [db _ _ _] 22 | (throw (UnsupportedOperationException. (str "No implementation found for updating entities in database: " db)))) 23 | 24 | (defmulti delete! 25 | "Deletes a record for a given entity." 26 | (fn [db _schema _etype _param-id _ac-conditions] 27 | (get-dbtype db))) 28 | 29 | (defmethod delete! :default 30 | [db _ _] 31 | (throw (UnsupportedOperationException. (str "No implementation found for deleting entities in database: " db)))) 32 | -------------------------------------------------------------------------------- /src/specomatic_db/db/postgres/migration.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.postgres.migration 2 | "Implements migration multimethods for postgresql storage." 3 | (:require 4 | [clojure.set :as set] 5 | [clojure.string :as str] 6 | [specomatic-db.db.conversion :as cnv] 7 | [specomatic-db.db.generic :as db-generic] 8 | [specomatic-db.db.migration :as migration] 9 | [specomatic-db.db.postgres.sql :as db-postgres] 10 | [specomatic-db.db.postgres.util :refer [postgresql]] 11 | [specomatic.core :as sc] 12 | [specomatic.field-def :as sf] 13 | [specomatic.spec :as sp])) 14 | 15 | (defmethod migration/column-def postgresql 16 | [db schema table-name field-keyword 17 | {:keys [cascade?] 18 | :as field-def} 19 | {:keys [historical?]}] 20 | (if (sf/reference? field-def) 21 | (let [column-name (cnv/field->column-name db field-keyword field-def) 22 | target (sf/target field-def)] 23 | (merge 24 | {:main (first (db-postgres/ref-column-def {:name column-name}))} 25 | (when-not historical? 26 | {:constraint {:table table-name 27 | :cascade? cascade? 28 | :column column-name 29 | :target (cnv/etype->table-name db target (sc/etype-def schema target))}}))) 30 | {:main (first (db-postgres/column-def {:name (cnv/field->column-name db field-keyword field-def) 31 | :type (migration/sql-type postgresql (sf/dispatch field-def))}))})) 32 | 33 | (defn- constraints-ddl 34 | [table-name existing-constraints constraints-params] 35 | (let [n (count constraints-params)] 36 | (loop [i 0 37 | constraint-name-i 0 38 | all-constraints existing-constraints 39 | constraint-ddl []] 40 | (if (= i n) 41 | constraint-ddl 42 | (let [constraint-name (str "fk_" table-name constraint-name-i) 43 | existing? (some #{constraint-name} all-constraints)] 44 | (recur (if existing? 45 | i 46 | (inc i)) 47 | (inc constraint-name-i) 48 | (if existing? 49 | all-constraints 50 | (conj all-constraints constraint-name)) 51 | (if existing? 52 | constraint-ddl 53 | (conj constraint-ddl 54 | (db-postgres/alter-table-add-foreign-key-sqlvec 55 | (assoc (nth constraints-params i) :constraint-name constraint-name)))))))))) 56 | 57 | (defmethod migration/create-table postgresql 58 | [db schema table-name id-field {:keys [existing-constraints field-defs join-table-unique-constraint]}] 59 | (let [column-ddl-without-id (for [[field field-def] field-defs 60 | :when (not= (name id-field) 61 | (name field))] 62 | (migration/column-def db schema table-name field field-def {})) 63 | historical-column-ddl-without-id (for [[field field-def] field-defs 64 | :when (not= (name id-field) 65 | (name field))] 66 | (migration/column-def db 67 | schema 68 | table-name 69 | field 70 | field-def 71 | {:historical? true})) 72 | id-dispatch (sf/dispatch (id-field field-defs)) 73 | id-column (cnv/field->column-name db id-field nil) 74 | column-ddl (conj column-ddl-without-id 75 | {:main (first (db-postgres/id-column-def 76 | {:name id-column 77 | :type "serial primary key"}))}) 78 | historical-column-ddl (conj historical-column-ddl-without-id 79 | {:main (first (db-postgres/column-def 80 | {:name id-column 81 | :type (migration/sql-type postgresql id-dispatch)}))}) 82 | column-defs (map :main column-ddl) 83 | historical-column-defs (map :main historical-column-ddl)] 84 | (when (seq column-ddl) 85 | (let [params {:id-field id-column 86 | :table table-name 87 | :column-defs (str/join "," column-defs) 88 | :column-names (mapv (fn [[field field-def]] 89 | (cnv/field->column-name db field field-def)) 90 | field-defs) 91 | :join-table-unique-constraint join-table-unique-constraint} 92 | history-params (assoc params :column-defs (str/join "," historical-column-defs))] 93 | {:main (concat [(db-postgres/create-generic-sqlvec params)] 94 | ((juxt 95 | db-postgres/create-generic-history-sqlvec 96 | db-postgres/create-or-replace-history-trigger-function-sqlvec 97 | db-postgres/create-or-replace-history-trigger-sqlvec) 98 | history-params)) 99 | :constraints (constraints-ddl table-name existing-constraints (filter some? (map :constraint column-ddl)))})))) 100 | 101 | (defmethod migration/diff-table postgresql 102 | [db schema table-name id-field {:keys [existing-constraints field-defs]}] 103 | (let [fields-to-db-columns (into {} 104 | (for [[field field-def] field-defs] 105 | [field 106 | (cnv/field->column-name db field field-def)])) 107 | db-columns-to-fields (set/map-invert fields-to-db-columns) 108 | existing-columns (->> (db-postgres/select-fields db {:table-name table-name}) 109 | (map :column_name) 110 | set) 111 | missing-column-defs (for [missing-column-name (set/difference (-> fields-to-db-columns 112 | vals 113 | set) 114 | existing-columns) 115 | :let [missing-field (get db-columns-to-fields missing-column-name) 116 | field-def (missing-field field-defs)]] 117 | [(migration/column-def db schema table-name missing-field field-def {}) 118 | (migration/column-def db 119 | schema 120 | table-name 121 | missing-field 122 | field-def 123 | {:historical? true})])] 124 | (when (seq missing-column-defs) 125 | (let [column-defs (str/join "," 126 | (map #(->> % 127 | first 128 | :main 129 | (str "add ")) 130 | missing-column-defs)) 131 | historical-column-defs (str/join "," 132 | (map #(->> % 133 | second 134 | :main 135 | (str "add ")) 136 | missing-column-defs))] 137 | {:main [(db-generic/alter-table-sqlvec 138 | {:table table-name 139 | :column-defs column-defs}) 140 | (db-generic/alter-table-sqlvec 141 | {:table (str table-name "_h") 142 | :column-defs historical-column-defs}) 143 | (db-postgres/create-or-replace-history-trigger-function-sqlvec 144 | {:table table-name 145 | :id-field (cnv/field->column-name db id-field nil) 146 | :column-names (mapv (fn [[field field-def]] 147 | (cnv/field->column-name db field field-def)) 148 | field-defs) 149 | :constraints (constraints-ddl table-name 150 | existing-constraints 151 | (filter some? 152 | (map #(-> % 153 | first 154 | :constraint) 155 | missing-column-defs)))})]})))) 156 | 157 | (defmethod migration/get-constraints postgresql 158 | [db] 159 | (map :rdb$constraint_name (db-postgres/select-all-constraints db))) 160 | 161 | (defmethod migration/get-tables postgresql 162 | [db] 163 | (map :table_name (db-postgres/select-all-tables db))) 164 | 165 | (defmethod migration/ensure-transaction-infrastructure! postgresql 166 | [db] 167 | (db-postgres/ensure-table-transaction db) 168 | (db-postgres/ensure-procedure-get-transaction db)) 169 | 170 | (defmethod migration/clear-transaction-system-txid! postgresql 171 | [db] 172 | (db-postgres/clear-transaction-system-txid db)) 173 | 174 | (defmethod migration/sql-type [postgresql ::sp/integer] 175 | [_ _] 176 | "integer") 177 | 178 | (defmethod migration/sql-type [postgresql 'integer?] 179 | [_ _] 180 | "integer") 181 | -------------------------------------------------------------------------------- /src/specomatic_db/db/postgres/mutation.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.postgres.mutation 2 | "Implements mutation multimethods for postgresql storage." 3 | (:require 4 | [clojure.walk :refer [keywordize-keys]] 5 | [specomatic-db.db.conversion :as cnv] 6 | [specomatic-db.db.mutation :refer [insert! update! delete!]] 7 | [specomatic-db.db.postgres.sql :as sql] 8 | [specomatic-db.db.postgres.util :refer [postgresql]] 9 | [specomatic.core :as sc])) 10 | 11 | (defmethod insert! postgresql 12 | [db schema etype entity] 13 | (let [table-name (cnv/etype->table-name db etype (sc/etype-def schema etype)) 14 | id-column (cnv/etype->id-column db schema etype) 15 | row (dissoc (cnv/entity->row db schema etype entity) 16 | id-column) 17 | {:keys [id 18 | txid 19 | txts]} 20 | (sql/insert! db 21 | {:table table-name 22 | :id-field id-column 23 | :cols (keys row) 24 | :vals (vals row)})] 25 | (merge row 26 | {:id id 27 | :tx/id txid 28 | :tx/ts txts}))) 29 | 30 | (defmethod update! postgresql 31 | [db schema etype entity ac-conditions] 32 | (let [table-name (cnv/etype->table-name db etype (sc/etype-def schema etype)) 33 | id-column (cnv/etype->id-column db schema etype) 34 | row (cnv/entity->row db schema etype entity) 35 | id (get row id-column) 36 | updates (-> row 37 | (dissoc id-column) 38 | keywordize-keys 39 | not-empty)] 40 | (if updates 41 | (let [{:keys [txid 42 | txts]} 43 | (sql/update! db 44 | {:table table-name 45 | :updates updates 46 | :id-field id-column 47 | :id id 48 | :ac-conditions ac-conditions})] 49 | (merge row 50 | {:tx/id txid 51 | :tx/ts txts})) 52 | (assoc row 53 | :tx/id 54 | :noop)))) 55 | 56 | (defmethod delete! postgresql 57 | [db schema etype param-id ac-conditions] 58 | (let [{:keys [id 59 | txid 60 | txts]} 61 | (sql/delete! db 62 | {:table (cnv/etype->table-name db etype (sc/etype-def schema etype)) 63 | :id-field (cnv/etype->id-column db schema etype) 64 | :id param-id 65 | :ac-conditions ac-conditions})] 66 | (when txid 67 | {:id id 68 | :tx/id txid 69 | :tx/ts txts}))) 70 | -------------------------------------------------------------------------------- /src/specomatic_db/db/postgres/sql.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.postgres.sql 2 | "Implements multimethods with hugsql functions for postgresql storage." 3 | (:require 4 | [hugsql.adapter.next-jdbc :as adp] 5 | [hugsql.core :as hugsql] 6 | [specomatic-db.db.postgres.util :refer [postgresql]] 7 | [specomatic-db.db.sql :as sql])) 8 | 9 | (hugsql/def-db-fns "sql/postgres.sql" 10 | {:quoting :ansi 11 | :adapter (adp/hugsql-adapter-next-jdbc)}) 12 | 13 | (hugsql/def-sqlvec-fns "sql/postgres.sql" 14 | {:quoting :ansi 15 | :adapter (adp/hugsql-adapter-next-jdbc)}) 16 | 17 | (defmethod sql/create-or-replace-view postgresql 18 | [_dbtype params] 19 | (create-or-replace-view-sqlvec params)) 20 | 21 | (defmethod sql/upsert-reference-coll-element! postgresql 22 | [db params] 23 | (upsert-reference-coll-element! db params)) 24 | -------------------------------------------------------------------------------- /src/specomatic_db/db/postgres/util.clj: -------------------------------------------------------------------------------- 1 | (ns ^:no-doc specomatic-db.db.postgres.util 2 | "Utilities for postgresql.") 3 | 4 | (def postgresql 5 | "Defines the dbtype for postgres." 6 | "postgresql") 7 | -------------------------------------------------------------------------------- /src/specomatic_db/db/sql.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.db.sql 2 | "Defines multimethods to be implemented by hugsql functions for specific sql backends." 3 | (:require 4 | [specomatic-db.db.type :refer [get-dbtype]])) 5 | 6 | (defmulti create-or-replace-view 7 | "Returns the SQL DDL required for creating or replacing a view" 8 | get-dbtype) 9 | 10 | (defmulti upsert-reference-coll-element! 11 | "Inserts an element into a reference collection" 12 | get-dbtype) 13 | -------------------------------------------------------------------------------- /src/specomatic_db/db/type.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.db.type 2 | "Functions for determining the database type (SQL backend) of a jdbc connectable." 3 | (:require 4 | [clojure.test :refer [with-test is]])) 5 | 6 | (with-test 7 | (defn get-jdbc-url-dbtype 8 | "Gets the dbtype from a jdbc formatted url string." 9 | [s] 10 | (some->> s 11 | (re-find #"^jdbc:([^:]+):") 12 | second)) 13 | (is (nil? (get-jdbc-url-dbtype nil))) 14 | (is (= "firebirdsql" (get-jdbc-url-dbtype "jdbc:firebirdsql://localhost:12345//firebird/data/test.fdb")) 15 | "db type not found.") 16 | (is (nil? (get-jdbc-url-dbtype "jdbc://localhost//firebird/data/test.fdb")) "Unexpected value returned.")) 17 | 18 | (defn- get-jdbc-connection-dbtype 19 | "Gets the dbtype from a jdbc connection if it is one." 20 | [conn] 21 | (case (str (class conn)) 22 | "class org.firebirdsql.jdbc.FBConnection" "firebirdsql" 23 | "class org.postgresql.jdbc.PgConnection" "postgresql" 24 | nil)) 25 | 26 | (with-test 27 | (defn get-dbtype 28 | "Gets the dbtype from a jdbc `connectable`." 29 | [connectable & _] 30 | (or (get-jdbc-connection-dbtype connectable) 31 | (let [{:keys [dbtype jdbcUrl connection-uri]} connectable] 32 | (or dbtype 33 | (get-jdbc-url-dbtype jdbcUrl) 34 | (get-jdbc-url-dbtype connection-uri))))) 35 | (is (= "firebirdsql" (get-dbtype {:dbtype "firebirdsql"}))) 36 | (is (= "firebirdsql" (get-dbtype {:jdbcUrl "jdbc:firebirdsql://localhost:12345//firebird/data/test.fdb"}))) 37 | (is (= "firebirdsql" (get-dbtype {:connection-uri "jdbc:firebirdsql://localhost:12345//firebird/data/test.fdb"}))) 38 | (is (= "prioritized" 39 | (get-dbtype {:dbtype "prioritized" 40 | :jdbcUrl "jdbc:second://localhost:12345//firebird/data/test.fdb"})))) 41 | -------------------------------------------------------------------------------- /src/specomatic_db/etype_def.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.etype-def 2 | "Functions working with specomatic-db entity type definitions, extending specomatic entity type definitions." 3 | (:require 4 | [nedap.speced.def :as sd] 5 | [specomatic-db.field-def :as sdf] 6 | [specomatic-db.spec :as sp] 7 | [specomatic.etype-def :as se])) 8 | 9 | (sd/defn defaults 10 | "Given `schema`, entity type `etype` and entity type definition `etype-def`, returns a (partial) entity type definition containing defaults." 11 | [^::sp/schema schema ^::sp/etype etype ^::sp/etype-def etype-def] 12 | (merge 13 | {:query-name (or (:table-name etype-def) etype) 14 | :table-name etype} 15 | (when-let [default-field-defs (reduce-kv #(when-let [my-defaults (not-empty (sdf/defaults schema etype %2 %3))] 16 | (assoc % %2 my-defaults)) 17 | {} 18 | (se/field-defs etype-def))] 19 | {:field-defs default-field-defs}))) 20 | 21 | (sd/defn table-name 22 | "Given the entity type definition `etype-def`, returns the table name as a keyword." 23 | ^::sd/nilable ^::sp/table-name [^::sp/etype-def etype-def] 24 | (:table-name etype-def)) 25 | 26 | (sd/defn query-name 27 | "Given the entity type definition `etype-def`, returns the table / view for querying as a keyword." 28 | ^::sd/nilable ^::sp/table-name [^::sp/etype-def etype-def] 29 | (:query-name etype-def)) 30 | -------------------------------------------------------------------------------- /src/specomatic_db/field_def.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.field-def 2 | "Functions working with specomatic-db field definitions, extending specomatic field definitions." 3 | (:require 4 | [nedap.speced.def :as sd] 5 | [specomatic-db.spec :as sp] 6 | [specomatic.core :as sc] 7 | [specomatic.field-def :as sf] 8 | [specomatic.util :as su])) 9 | 10 | (sd/defn column-name 11 | "Given the field definition `field-def`, returns the column name." 12 | ^::sd/nilable ^::sp/field [^::sp/field-def field-def] 13 | (:column-name field-def)) 14 | 15 | (sd/defn db-via 16 | "Given the field definition `field-def`, returns the db field on the opposite side of the relation, if available." 17 | ^::sd/nilable ^::sp/db-via [^::sp/field-def param-field-def] 18 | (:db-via param-field-def)) 19 | 20 | (sd/defn join-table 21 | "Given the field definition `field-def`, returns the join table, if available." 22 | ^::sd/nilable ^::sp/join-table [^::sp/field-def param-field-def] 23 | (:join-table param-field-def)) 24 | 25 | (sd/defn join-table-id-field 26 | "Given the field definition `field-def`, returns the join table id field, if available." 27 | ^::sd/nilable ^::sp/join-table-id-field [^::sp/field-def param-field-def] 28 | (:join-table-id-field param-field-def)) 29 | 30 | (sd/defn not-persistent? 31 | "Given the field definition `field-def`, checks if it is not persistent." 32 | ^boolean? [^::sp/field-def param-field-def] 33 | (true? (:not-persistent? param-field-def))) 34 | 35 | (sd/defn owns-relation? 36 | "Given the field definition `field-def`, checks if it owns the relation." 37 | ^boolean? [^::sp/field-def param-field-def] 38 | (true? (:owns-relation? param-field-def))) 39 | 40 | (sd/defn save-related? 41 | "Given the field definition `field-def`, checks if the contents of it should be saved with the entity." 42 | ^boolean? [^::sp/field-def param-field-def] 43 | (true? (:save-related? param-field-def))) 44 | 45 | (defmulti defaults 46 | "Given `schema`, entity type `etype`, `field` and field definition `param-field-def`, returns a map of defaults 47 | for the field definition." 48 | (fn [_schema _etype _field param-field-def] (sf/kind param-field-def))) 49 | 50 | (defmethod defaults :default 51 | [_schema _etype field _param-field-def] 52 | {:column-name field}) 53 | 54 | (defmethod defaults ::sf/reference 55 | [schema etype field param-field-def] 56 | (let [my-column-name (column-name param-field-def) 57 | default-column-name (su/concat-keywords 58 | (or (sf/via param-field-def) 59 | field) 60 | :id) 61 | my-owns-relation? (= (name etype) (namespace (or my-column-name default-column-name))) 62 | via (sf/via param-field-def)] 63 | (merge {:column-name default-column-name 64 | :owns-relation? my-owns-relation? 65 | :save-related? (not my-owns-relation?)} 66 | (when via 67 | {:db-via (or (column-name (sc/field-def schema via)) 68 | via)})))) 69 | 70 | (defmethod defaults ::sf/reference-coll 71 | [schema etype _field param-field-def] 72 | (if (= :has-many (:reference-type param-field-def)) 73 | (when (some? (:inverse-of param-field-def)) 74 | (let [via (:via param-field-def)] 75 | {:db-via (or (:column-name (sc/field-def schema via)) 76 | via) 77 | :owns-relation? false 78 | :save-related? true})) 79 | (let [inverse? (some? (:inverse-of param-field-def)) 80 | param-join-table (join-table param-field-def) 81 | default-join-table (su/concat-keywords (if inverse? 82 | (sf/target param-field-def) 83 | etype) 84 | (if inverse? 85 | etype 86 | (sf/target param-field-def))) 87 | my-join-table (or param-join-table default-join-table) 88 | target (sf/target param-field-def)] 89 | (merge 90 | {:db-via [(sc/id-field schema etype) 91 | (keyword (name my-join-table) (str (name etype) "id")) 92 | (keyword (name my-join-table) (str (name target) "id")) 93 | (sc/id-field schema target)] 94 | :join-table-id-field (keyword (name my-join-table) (str (name my-join-table) "id")) 95 | :reference-type :has-many-through 96 | :save-related? (not inverse?) 97 | :owns-relation? (not inverse?)} 98 | (when-not param-join-table 99 | {:join-table my-join-table}))))) 100 | -------------------------------------------------------------------------------- /src/specomatic_db/registry.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.registry 2 | "Functions that work with the clojure.spec registry (via `specomatic.registry`) to generate the specomatic-db schema and config." 3 | (:require 4 | [nedap.speced.def :as sd] 5 | [specomatic-db.schema :as schema] 6 | [specomatic.registry :as sr] 7 | [specomatic.spec :as sp])) 8 | 9 | (sd/defn full-schema 10 | "Returns the full schema for the `namespaces` as a map of entity types to their definitions. 11 | Optionally restricted to a sequence of entities `only`. 12 | Specific entity and field definitions may by overridden by an `overrides` map in the same shape as the schema. 13 | Shape of result: 14 | {::my.namespace.entity {:field-defs map of fields to fields' specs 15 | :id-field id field for the entity 16 | :required-fields set of required fields} 17 | ::my.namespace.entity2 ... }" 18 | ([^::sp/namespaces namespaces ^::sd/nilable ^map? overrides] 19 | (full-schema namespaces overrides nil)) 20 | ([^::sp/namespaces namespaces ^::sd/nilable ^map? overrides only] 21 | (schema/full-schema (sr/full-schema namespaces overrides only) overrides))) 22 | 23 | (sd/defn config 24 | "Returns the full schema for the `namespaces` as a map of entity types to their definitions. 25 | Optionally restricted to a sequence of entities `only`. 26 | The `base-config` has the same shape as the result. `:ac-predicates` and `:user-entity` are for access control, 27 | the `:schema` part contains overrides for the schema. 28 | Shape of result: 29 | {:ac-predicates {:predicate/name {::my-namespace.entity honeysql-query}} 30 | :schema {::my.namespace.entity {:field-defs map of fields to fields' specs 31 | :id-field id field for the entity 32 | :required-fields set of required fields} 33 | ::my.namespace.entity2 ... } 34 | :user-entity ::my.namespace.user}" 35 | ([^::sp/namespaces namespaces] 36 | (config namespaces nil nil)) 37 | ([^::sp/namespaces namespaces ^::sd/nilable ^map? base-config] 38 | (config namespaces base-config nil)) 39 | ([^::sp/namespaces namespaces ^::sd/nilable ^map? base-config only] 40 | (merge base-config {:schema (full-schema namespaces (:schema base-config) only)}))) 41 | -------------------------------------------------------------------------------- /src/specomatic_db/schema.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.schema 2 | "Functions working with the specomatic-db schema, extending the specomatic schema." 3 | (:require 4 | [nedap.speced.def :as sd] 5 | [specomatic-db.etype-def :as sde] 6 | [specomatic-db.spec :as sp] 7 | [specomatic.core :as sc] 8 | [specomatic.etype-def :as se] 9 | [specomatic.field-def :as sf] 10 | [specomatic.util :as su])) 11 | 12 | (sd/defn default-fk-column 13 | "Returns the default keyword for foreign key columns referencing entities of type `etype` in the `schema`." 14 | ^::sp/field [^::sp/schema schema ^::sp/etype etype] 15 | (or 16 | (get-in schema [etype :default-fk]) 17 | (keyword (str (name etype) "id")))) 18 | 19 | (sd/defn defaults-schema 20 | "Given a `schema`, returns a (partial) schema containing defaults." 21 | [^::sp/schema schema] 22 | (reduce-kv #(assoc % %2 (sde/defaults schema %2 %3)) {} schema)) 23 | 24 | (sd/defn etypes-by-simple-keywords* 25 | "Given a `schema`, returns a map of simple keywords by qualified keywords representing entity types." 26 | ^:private ^map? [^::sp/schema schema] 27 | (zipmap (map su/strip-ns (keys schema)) (keys schema))) 28 | 29 | (def etypes-by-simple-keywords 30 | "Returns a map of fields to field definitions, with the entity type assoc'd to the :etype key, in `schema` (memoized)." 31 | (memoize etypes-by-simple-keywords*)) 32 | 33 | (sd/defn etype-from-simple-keyword 34 | "Given a `schema` and `simple-etype` returns a qualified entity type keyword." 35 | [^::sp/schema schema ^keyword? simple-etype] 36 | (simple-etype (etypes-by-simple-keywords schema))) 37 | 38 | (sd/defn persistent-field-defs 39 | "Returns the persistent field defs for the `etype` in the `schema`." 40 | ^::sd/nilable ^::sp/field-defs [^::sp/schema schema ^::sp/etype etype] 41 | (let [field-defs (sc/field-defs schema etype)] 42 | (select-keys field-defs 43 | (for [[k v] field-defs 44 | :when (not (or (sf/inverse? v) 45 | (sf/reference-coll? v) 46 | (:not-persistent? v)))] 47 | k)))) 48 | 49 | (sd/defn full-schema 50 | "Given a `schema` returned from `specomatic.registry/schema` spec and optionally `overrides` to override defaults, 51 | returns an schema enriched with database-specific defaults." 52 | ^::sp/schema [^::sp/schema schema ^::sd/nilable ^map? overrides] 53 | (merge-with 54 | se/merge-etype-defs 55 | schema 56 | (defaults-schema schema) 57 | overrides)) 58 | -------------------------------------------------------------------------------- /src/specomatic_db/seql.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.seql 2 | "Contains all functions that work directly with the seql library: Provides schema generation and querying and registers transformations." 3 | (:require 4 | [clojure.set :as set] 5 | [clojure.walk :as walk] 6 | [seql.coerce :as seql-coerce] 7 | [seql.helpers :as sh] 8 | [seql.params :as params] 9 | [seql.query :as query] 10 | [seql.schema :as seql-schema] 11 | [specomatic-db.access-control :as ac] 12 | [specomatic-db.db.conversion :as cnv] 13 | [specomatic-db.field-def :as sdf] 14 | [specomatic-db.schema :as db-schema] 15 | [specomatic-db.util :as u] 16 | [specomatic.core :as sc] 17 | [specomatic.etype-def :as se] 18 | [specomatic.field-def :as sf] 19 | [specomatic.util :as su])) 20 | 21 | (defmulti field-def 22 | "Returns a seql field definition for field `field` of `entity` with `spec`, given `entity-schema`." 23 | (fn [entity field specomatic-field-def entity-schema] 24 | (cond 25 | (= (sc/id-field entity-schema entity) field) 26 | :ident 27 | :else 28 | (:kind specomatic-field-def)))) 29 | 30 | (defmethod field-def :ident 31 | [_etype field _specomatic-field-def _entity-schema] 32 | (sh/field field (sh/ident))) 33 | 34 | (defmethod field-def ::sf/simple 35 | [_etype field _specomatic-field-def _entity-schema] 36 | (sh/field field)) 37 | 38 | (defmethod field-def ::sf/reference 39 | [etype field specomatic-field-def entity-schema] 40 | (let [referenced-entity (sf/target specomatic-field-def)] 41 | (sh/has-one field 42 | (if (sf/inverse? specomatic-field-def) 43 | [(sc/id-field entity-schema etype) (sdf/column-name specomatic-field-def)] 44 | [(sdf/column-name specomatic-field-def) (sc/id-field entity-schema referenced-entity)])))) 45 | 46 | (defmethod field-def ::sf/reference-coll 47 | [etype field specomatic-field-def entity-schema] 48 | (if (= :has-many (:reference-type specomatic-field-def)) 49 | (sh/has-many field [(sc/id-field entity-schema etype) (sdf/db-via specomatic-field-def)]) 50 | (sh/has-many-through field 51 | (sdf/db-via specomatic-field-def)))) 52 | 53 | (defn set-transform! 54 | "Registers transformation functions (readers) for the given `entity-schema`." 55 | [entity-schema] 56 | (doseq [etype (keys entity-schema) 57 | :let [fields (sc/field-defs entity-schema etype)]] 58 | (doseq [[field my-field-def] fields 59 | :when (and field-def 60 | (not (sf/relational? my-field-def)))] 61 | (seql-coerce/with-reader! field 62 | (fn [x _] (cnv/db-field-value->entity-field-value (sf/dispatch my-field-def) x)))))) 63 | 64 | (defn- join-table-seql-entities 65 | [schema query-table-keyword] 66 | (let [ref-colls-by-etype (sc/reference-colls-by-owning-etype schema)] 67 | (for [[_ ref-colls] ref-colls-by-etype] 68 | (for [[_ my-field-def] ref-colls 69 | :let [join-table (sdf/join-table my-field-def)]] 70 | (sh/entity [(su/strip-ns join-table) (query-table-keyword join-table nil)] 71 | (sh/field (sdf/join-table-id-field my-field-def) (sh/ident))))))) 72 | 73 | (defn- predicate-relation 74 | [schema etype predicate] 75 | (let [my-view-name (ac/view-name-seql predicate etype)] 76 | (sh/has-many (keyword my-view-name) 77 | [(sc/id-field schema etype) 78 | (keyword 79 | my-view-name 80 | (name (db-schema/default-fk-column schema etype)))]))) 81 | 82 | (defn- views-seql-entities 83 | "Returns the access control views as seql entity definitions." 84 | [etype predicates-by-etype 85 | {:keys [schema] 86 | :as config}] 87 | (let [user-etype (:user-etype config)] 88 | (for [predicate (etype predicates-by-etype)] 89 | (sh/entity 90 | [(keyword (ac/view-name-seql predicate etype)) (keyword (ac/view-name predicate etype))] 91 | (sh/field (db-schema/default-fk-column schema etype) (sh/ident)) 92 | (sh/field (db-schema/default-fk-column schema user-etype)))))) 93 | 94 | (defn- entities 95 | "Returns a sequence of seql entity definitions for the given `config`. 96 | Optionally accepts a `query-table-keyword` function parameter for mapping entity keywords to table / view keywords for querying (default: `cnv/etype->query-table-keyword`)" 97 | ([config] 98 | (entities config cnv/etype->query-table-keyword)) 99 | ([config query-table-keyword] 100 | (let [{:keys [ac-predicates schema schema-components]} config 101 | predicates-by-etype (apply merge-with 102 | into 103 | (into 104 | (for [[predicate predicate-defs] ac-predicates] 105 | (into {} 106 | (for [[etype _] schema 107 | :when (etype 108 | predicate-defs)] 109 | [etype [predicate]])))))] 110 | (reduce 111 | into 112 | ; specomatic schema entities 113 | (into 114 | (for [etype (sc/etypes schema) 115 | :let [etype-def (sc/etype-def schema etype) 116 | field-defs (se/field-defs etype-def)]] 117 | (into 118 | [(apply 119 | sh/entity 120 | (reduce 121 | into 122 | [[[(su/strip-ns etype) (query-table-keyword etype etype-def)] 123 | (sh/inline-condition :where [condition] condition)] 124 | (for [[field specomatic-field-def] field-defs] 125 | (field-def etype field specomatic-field-def schema)) 126 | (for [[field specomatic-field-def] field-defs] 127 | (sh/column-name field (or (sdf/column-name specomatic-field-def) field))) 128 | (for [predicate (etype predicates-by-etype)] 129 | (predicate-relation schema etype predicate)) 130 | (etype schema-components)]))] 131 | (views-seql-entities etype predicates-by-etype config))) 132 | (join-table-seql-entities schema query-table-keyword)))))) 133 | 134 | (defn- schema* 135 | [config] 136 | (apply 137 | sh/make-schema 138 | (entities config))) 139 | 140 | (defn- schema-historic* 141 | [config] 142 | (apply 143 | sh/make-schema 144 | (entities config cnv/etype->historic-query-table-keyword))) 145 | 146 | (def schema 147 | "Returns a seql schema for the given specomatic `config`." 148 | (memoize schema*)) 149 | 150 | (def schema-historic 151 | "Returns a seql schema for the given specomatic `config`." 152 | (memoize schema-historic*)) 153 | 154 | (defn- translate-conditions 155 | "Converts the keywords in the `conditions` from specomatic keywords to keywords usable for seql conditions, according to `entity-schema`. 156 | Optionally accepts a `query-table-keyword` function parameter for mapping entity type keywords to table / view keywords for querying (default: `cnv/etype->query-table-keyword`)." 157 | ([param-schema conditions] 158 | (translate-conditions param-schema conditions cnv/etype->query-table-keyword)) 159 | ([param-schema conditions query-table-keyword] 160 | (walk/postwalk #(if (and (keyword? %) (namespace %)) 161 | (let [simple-etype (keyword (namespace %)) 162 | etype (db-schema/etype-from-simple-keyword param-schema simple-etype) 163 | seql-view-field (su/qualify 164 | (if etype 165 | (query-table-keyword etype (sc/etype-def param-schema etype)) 166 | (query-table-keyword simple-etype nil)) 167 | (su/strip-ns 168 | (if-let [my-field-def (sc/field-def param-schema %)] 169 | (sdf/column-name my-field-def) 170 | %)))] 171 | (keyword (str (namespace seql-view-field) "." (name seql-view-field)))) 172 | %) 173 | conditions))) 174 | 175 | (defn query 176 | "Returns a vector of [`seql-etype` `fields` `conditions` `allowed-or-preds-by-verb`] representing a seql query for retrieving a sequence of `etype` entities containing the seql-style `fields` and matching the HoneySQL `conditions`, as well as how to determine the value of each access control verb (`allowed-or-preds-by-verb`). 177 | Optionally accepts a `query-table-keyword` function parameter for mapping entity type keywords to table / view keywords for querying (default: `cnv/etype->query-table-keyword`) 178 | Shape of `env`: 179 | {:config specomatic config}" 180 | ([env etype fields conditions] 181 | (query env etype fields conditions cnv/etype->query-table-keyword)) 182 | ([env etype fields conditions query-table-keyword] 183 | (let [seql-etype (su/strip-ns etype) 184 | {:keys [config user]} env 185 | {my-schema :schema 186 | user-etype :user-etype} 187 | config 188 | verbs 189 | (filter #(and (keyword? %) 190 | (= "verb" (namespace %))) 191 | fields) 192 | allowed-or-preds-by-verb 193 | (zipmap verbs 194 | (map 195 | #(if (ac/allowed-all? user % etype) 196 | true 197 | (ac/sufficient-predicates etype % (get-in env [:user :permissions]))) 198 | verbs)) 199 | my-fields-without-verbs (u/fields-without-verbs fields) 200 | preds (->> allowed-or-preds-by-verb 201 | vals 202 | (filter set?) 203 | (apply set/union)) 204 | pred-fields (for [pred preds] 205 | {(keyword (name seql-etype) 206 | (ac/view-name-seql pred etype)) 207 | [(keyword (ac/view-name-seql pred etype) 208 | (name (db-schema/default-fk-column my-schema etype)))]}) 209 | user-id (get-in env [:user :id]) 210 | ac-conditions (for [pred preds] 211 | [:or 212 | [:= 213 | (keyword (str 214 | (ac/view-name-seql pred etype) 215 | "." 216 | (name (db-schema/default-fk-column my-schema user-etype)))) 217 | user-id] 218 | [:= 219 | (keyword (str 220 | (ac/view-name-seql pred etype) 221 | "." 222 | (name (db-schema/default-fk-column my-schema user-etype)))) 223 | nil]]) 224 | seql-fields my-fields-without-verbs] 225 | [seql-etype 226 | (into seql-fields pred-fields) 227 | (mapv (fn [condition] [(keyword (name seql-etype) "where") condition]) 228 | (concat (translate-conditions my-schema conditions query-table-keyword) 229 | ac-conditions)) 230 | allowed-or-preds-by-verb]))) 231 | 232 | (defn- relation-query-tables 233 | "Returns a collection of tables used for the given `join`." 234 | [arg-schema join] 235 | (let [resolved (seql-schema/resolve-relation arg-schema join) 236 | query-tables #{(:remote-entity resolved)}] 237 | (if-let [intermediate (:intermediate resolved)] 238 | (conj query-tables intermediate) 239 | query-tables))) 240 | 241 | (defn query-tables 242 | "Returns a collection of tables used in given query." 243 | [config etype fields] 244 | (let [my-schema 245 | (schema config) 246 | 247 | {:keys [table joins]} 248 | (params/for-query my-schema 249 | (su/strip-ns etype) 250 | (u/fields-without-verbs fields) 251 | [])] 252 | [table 253 | (reduce into 254 | (map (partial relation-query-tables my-schema) 255 | joins))])) 256 | 257 | (defn execute-query 258 | "Executes query via seql." 259 | [env etype fields conditions] 260 | (query/execute env 261 | etype 262 | fields 263 | conditions)) 264 | -------------------------------------------------------------------------------- /src/specomatic_db/spec.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.spec 2 | "Specs and spec predicate functions for specomatic-db, extending the specs for specomatic." 3 | (:require 4 | [clojure.spec.alpha :as s] 5 | [seql.query :as sq] 6 | [specomatic.spec :as core-spec])) 7 | 8 | (s/def ::conditions (s/nilable (s/coll-of vector?))) 9 | 10 | (s/def ::ac-table-predicate map?) 11 | 12 | (s/def ::ac-predicate (s/map-of keyword? ::ac-table-predicate)) 13 | 14 | (s/def ::ac-predicates (s/nilable (s/map-of keyword? ::ac-predicate))) 15 | 16 | (s/def ::user 17 | (s/keys :opt-un [::id 18 | ::permissions 19 | ::root?])) 20 | 21 | (s/def ::user-etype keyword?) 22 | 23 | (defn unique-etype-names? 24 | "Checks if the entity types for `schema` have unique names." 25 | [schema] 26 | (->> 27 | schema 28 | keys 29 | (apply distinct?))) 30 | 31 | (s/def ::schema 32 | (s/and ::core-spec/schema 33 | unique-etype-names?)) 34 | 35 | (s/def ::etype ::core-spec/etype) 36 | 37 | (s/def ::etype-def ::core-spec/etype-def) 38 | 39 | (s/def ::field ::core-spec/field) 40 | 41 | (s/def ::fields ::core-spec/fields) 42 | 43 | (s/def ::column-name keyword?) 44 | 45 | (s/def ::db-via 46 | (s/or :kw keyword? 47 | :vec (s/coll-of keyword?))) 48 | 49 | (s/def ::join-table keyword?) 50 | 51 | (s/def ::join-table-id-field keyword?) 52 | 53 | (s/def ::not-persistent? boolean?) 54 | 55 | (s/def ::owns-relation? boolean?) 56 | 57 | (s/def ::save-related? boolean?) 58 | 59 | (s/def ::table-name keyword?) 60 | 61 | (s/def ::field-def 62 | (s/merge ::core-spec/field-def 63 | (s/keys :opt-un [::column-name 64 | ::db-via 65 | ::join-table 66 | ::join-table-id-field 67 | ::not-persistent? 68 | ::owns-relation?]))) 69 | 70 | (s/def ::field-defs (s/map-of ::field ::field-def)) 71 | 72 | (s/def ::config 73 | (s/keys :req-un [::schema] 74 | :opt-un [::user-etype])) 75 | 76 | (s/def ::env 77 | (s/keys :req-un [::config 78 | ::jdbc 79 | ::user] 80 | :opt-un [:tx/id])) 81 | 82 | (s/def ::query-result 83 | (s/coll-of map?)) 84 | 85 | (s/def ::nilable-query (s/nilable ::sq/seql-query)) 86 | 87 | (s/def ::change #{:create :update :delete}) 88 | 89 | (s/def ::namespaces ::core-spec/namespaces) 90 | -------------------------------------------------------------------------------- /src/specomatic_db/util.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.util 2 | "Utility functions for specomatic-db." 3 | (:require 4 | [nedap.speced.def :as sd] 5 | [seql.query :as sq] 6 | [specomatic-db.spec :as sp] 7 | [specomatic.core :as sc])) 8 | 9 | (sd/defn flatten-fields 10 | "Flattens a seql `fields` sequence." 11 | ^::sp/fields [^::sq/seql-query fields] 12 | (filter keyword? (tree-seq coll? identity fields))) 13 | 14 | (sd/defn etypes-from-fields 15 | "Given `schema`, returns all entity types from the `fields` sequence, as keywords." 16 | [^::sp/schema schema ^::sq/seql-query fields] 17 | (->> fields 18 | flatten-fields 19 | (map #(sc/etype-from-field schema %)) 20 | (filter some?) 21 | distinct)) 22 | 23 | (defn fields-without-verbs 24 | "Returns the seql `fields` vector without the top-level :verb/ keywords." 25 | [fields] 26 | (vec (remove #(and (keyword? %) 27 | (= "verb" (namespace %))) 28 | fields))) 29 | 30 | (defn honeysql-field 31 | "Returns a field keyword suitable for honeysql conditions (separated by .)" 32 | [field] 33 | (keyword (str (namespace field) "." (name field)))) 34 | -------------------------------------------------------------------------------- /test-common/specomatic_db/test/config.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.test.config 2 | (:require 3 | [specomatic-db.registry :as registry] 4 | [specomatic-db.test.schema :as schema] 5 | [specomatic.field-def :as sf])) 6 | 7 | (def base-config 8 | "The base config for specomatic-db." 9 | {;; Define :predicate/director: Describe the relation of a director to other entities for access control purposes 10 | :ac-predicates #:predicate{:director {::schema/movie {:select [[:movie.id :movieid] [:user_.id :userid]] 11 | :from [:movie] 12 | :join [:moviedirector [:= :movie.id :moviedirector.movieid] 13 | :director [:= :moviedirector.directorid :director.id] 14 | :user_ [:= :director.id :user_.directorid]]}} 15 | :reviewer {::schema/paragraph {:select [[:paragraph.id :paragraphid] [:user_.id :userid]] 16 | :from [:paragraph] 17 | :join [:review [:= :paragraph.reviewid :review.id] 18 | :reviewer [:= :review.reviewerid :reviewer.id] 19 | :user_ [:= :reviewer.id :user_.reviewerid]]} 20 | ::schema/review {:select [[:review.id :reviewid] [:user_.id :userid]] 21 | :from [:review] 22 | :join [:reviewer [:= :review.reviewerid :reviewer.id] 23 | :user_ [:= :reviewer.id :user_.reviewerid]]}}} 24 | :schema {::schema/director {:field-defs {:director/user {:kind ::sf/reference 25 | :inverse-of :user/director}}} 26 | ::schema/reviewer {:field-defs {:reviewer/user {:kind ::sf/reference 27 | :inverse-of :user/reviewer}}} 28 | ::schema/user {:table-name :user_}} 29 | :user-etype ::schema/user}) 30 | 31 | (def config 32 | "The specomatic-db config for this namespace, derived from the base config and definitions read from the clojure.spec registry." 33 | (registry/config ['specomatic-db.test.schema] base-config)) 34 | 35 | (def schema 36 | "The specomatic-db schema for this namespace, read from the clojure.spec registry and overridden by the :schema part of the base config." 37 | (:schema config)) 38 | 39 | (def director-permissions 40 | "A director is allowed to see all movies, actors, reviews, and other directors, 41 | but can only create / update / delete their own movies." 42 | [{:permission/verb :verb/read 43 | :permission/obj ::schema/movie 44 | :permission/pred :predicate/none} 45 | {:permission/verb :verb/* 46 | :permission/obj ::schema/movie 47 | :permission/pred :predicate/director} 48 | {:permission/verb :verb/read 49 | :permission/obj ::schema/actor 50 | :permission/pred :predicate/none} 51 | {:permission/verb :verb/read 52 | :permission/obj ::schema/director 53 | :permission/pred :predicate/none} 54 | {:permission/verb :verb/read 55 | :permission/obj ::schema/review 56 | :permission/pred :predicate/none}]) 57 | 58 | (def restrictive-director-permissions 59 | "A director is allowed to see all actors, reviews, and other directors, but can only see their own movies. 60 | They can create or update their own movies, but never delete them." 61 | [{:permission/verb :verb/read 62 | :permission/obj ::schema/movie 63 | :permission/pred :predicate/director} 64 | {:permission/verb :verb/create 65 | :permission/obj ::schema/movie 66 | :permission/pred :predicate/director} 67 | {:permission/verb :verb/update 68 | :permission/obj ::schema/movie 69 | :permission/pred :predicate/director} 70 | {:permission/verb :verb/read 71 | :permission/obj ::schema/actor 72 | :permission/pred :predicate/none} 73 | {:permission/verb :verb/read 74 | :permission/obj ::schema/director 75 | :permission/pred :predicate/none} 76 | {:permission/verb :verb/read 77 | :permission/obj ::schema/review 78 | :permission/pred :predicate/none}]) 79 | 80 | (def reviewer-permissions 81 | "A reviewer is allowed to see all reviews including their paragraphs, 82 | but can only create / update / delete their own reviews." 83 | [{:permission/verb :verb/read 84 | :permission/obj ::schema/review 85 | :permission/pred :predicate/none} 86 | {:permission/verb :verb/read 87 | :permission/obj ::schema/paragraph 88 | :permission/pred :predicate/none} 89 | {:permission/verb :verb/* 90 | :permission/obj ::schema/review 91 | :permission/pred :predicate/reviewer} 92 | {:permission/verb :verb/* 93 | :permission/obj ::schema/paragraph 94 | :permission/pred :predicate/reviewer}]) 95 | -------------------------------------------------------------------------------- /test-common/specomatic_db/test/schema.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.test.schema 2 | (:require 3 | [clojure.spec.alpha :as s] 4 | [specomatic-db.db.firebird.util :refer [firebirdsql]] 5 | [specomatic-db.db.migration :as migration] 6 | [specomatic-db.db.postgres.util :refer [postgresql]] 7 | [specomatic.registry :as sr] 8 | [specomatic.spec :as sp])) 9 | 10 | (s/def :spec/review-stars (s/int-in 1 6)) 11 | 12 | (defmethod migration/sql-type [firebirdsql :spec/review-stars] [_ _] "SMALLINT") 13 | 14 | (defmethod migration/sql-type [postgresql :spec/review-stars] [_ _] "SMALLINT") 15 | 16 | (s/def ::name string?) 17 | 18 | (s/def ::title string?) 19 | 20 | (s/def ::release-year integer?) 21 | 22 | (s/def ::stars :spec/review-stars) 23 | 24 | (sr/defent ::actor :req [:name]) 25 | 26 | (sr/defent ::director :req [:name]) 27 | 28 | (s/def :movie/actors (sp/references ::actor)) 29 | 30 | (s/def :movie/directors (sp/references ::director)) 31 | 32 | (sr/defent ::movie 33 | :req [:title :release-year] 34 | :opt [:actors :directors]) 35 | 36 | (s/def :review/movie (sp/reference ::movie)) 37 | 38 | (s/def :review/reviewer (sp/reference ::reviewer)) 39 | 40 | (sr/defent ::review :req [:movie :reviewer :stars :title]) 41 | 42 | (s/def :paragraph/review (sp/reference ::review)) 43 | 44 | (s/def :paragraph/content string?) 45 | 46 | (sr/defent ::paragraph :req [:content :review]) 47 | 48 | (sr/defent ::reviewer :req [:name]) 49 | 50 | (s/def ::username string?) 51 | 52 | (s/def :user/director (sp/reference ::director)) 53 | 54 | (s/def :user/reviewer (sp/reference ::reviewer)) 55 | 56 | (sr/defent ::user 57 | :req 58 | [:username] 59 | :opt 60 | [:director :reviewer]) 61 | -------------------------------------------------------------------------------- /test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cd $(dirname "$0") 4 | clojure -Mtest:runner --fail-fast 5 | -------------------------------------------------------------------------------- /test/specomatic_db/access_control_test.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.access-control-test 2 | (:require 3 | [clojure.test :refer [deftest is testing]] 4 | [specomatic-db.access-control :as ac] 5 | [specomatic-db.test.config :as config] 6 | [specomatic-db.test.schema :as-alias schema])) 7 | 8 | (deftest view-name-test 9 | (is (= "ac_owner_potato" (ac/view-name :predicate/owner :vegetable/potato)) 10 | "view-name should concatenate prefix, predicate and entity names") 11 | (is 12 | (= "ac_541ceaad3042b48c64f37d00b330" (ac/view-name :predicate/potato-variety-administrator :variety/potato-variety)) 13 | "view-name should concatenate prefix and a truncated md5 hash of predicate and entity if it otherwise became longer than 31 characters (firebird limit)")) 14 | 15 | (deftest view-name-seql-test 16 | (is (= "ac-owner-potato-variety" (ac/view-name-seql :predicate/owner :variety/potato-variety)) 17 | "view-name-seql should replace _ with - to conform with seql conventions")) 18 | 19 | (deftest view-sql-test 20 | (is 21 | (= 22 | ["create or replace view\nac_director_movie\nas\nSELECT movie.id AS movieid, user_.id AS userid FROM movie INNER JOIN moviedirector ON movie.id = moviedirector.movieid INNER JOIN director ON moviedirector.directorid = director.id INNER JOIN user_ ON director.id = user_.directorid"] 23 | (ac/view-sql 24 | {:dbtype "postgresql"} 25 | config/config 26 | :predicate/director 27 | ::schema/movie 28 | (get-in config/config [:ac-predicates :predicate/director ::schema/movie]))) 29 | "view-sql should return SQL DDL for Postgres access control predicate view") 30 | (is 31 | (= 32 | ["create or alter view\nac_director_movie\nas\nSELECT movie.id AS movieid, user_.id AS userid FROM movie INNER JOIN moviedirector ON movie.id = moviedirector.movieid INNER JOIN director ON moviedirector.directorid = director.id INNER JOIN user_ ON director.id = user_.directorid"] 33 | (ac/view-sql 34 | {:dbtype "firebirdsql"} 35 | config/config 36 | :predicate/director 37 | ::schema/movie 38 | (get-in config/config [:ac-predicates :predicate/director ::schema/movie]))) 39 | "view-sql should return SQL DDL for Firebird access control predicate view")) 40 | 41 | (deftest views-sql-test 42 | (is 43 | (= 44 | '(["create or replace view\nac_reviewer_review\nas\nSELECT review.id AS reviewid, user_.id AS userid FROM review INNER JOIN reviewer ON review.reviewerid = reviewer.id INNER JOIN user_ ON reviewer.id = user_.reviewerid"] 45 | ["create or replace view\nac_reviewer_paragraph\nas\nSELECT paragraph.id AS paragraphid, user_.id AS userid FROM paragraph INNER JOIN review ON paragraph.reviewid = review.id INNER JOIN reviewer ON review.reviewerid = reviewer.id INNER JOIN user_ ON reviewer.id = user_.reviewerid"] 46 | ["create or replace view\nac_director_movie\nas\nSELECT movie.id AS movieid, user_.id AS userid FROM movie INNER JOIN moviedirector ON movie.id = moviedirector.movieid INNER JOIN director ON moviedirector.directorid = director.id INNER JOIN user_ ON director.id = user_.directorid"]) 47 | (ac/views-sql 48 | {:dbtype "postgresql"} 49 | config/config)) 50 | "views-sql should return SQL DDL for all access control predicate views")) 51 | 52 | (deftest root?-test 53 | (is (true? (ac/root? {:root? true})) 54 | "root? should return true if :root? equals true") 55 | (is (true? (ac/root? true)) 56 | "root? should return true if user equals true") 57 | (is (false? (ac/root? {:id 1})) 58 | "root? should return false if user does not equal true and :root? does not equal true")) 59 | 60 | (def jane 61 | "Represents a *Jane* persona that is allowed to: 62 | - eat all tomatoes 63 | - throw, fry and do CRUD operations with all potatoes" 64 | {:permissions [{:permission/verb :verb/eat 65 | :permission/obj :vegetable/tomato 66 | :permission/pred :predicate/none} 67 | {:permission/verb :verb/throw 68 | :permission/obj :vegetable/potato 69 | :permission/pred :predicate/none} 70 | {:permission/verb :verb/fry 71 | :permission/obj :vegetable/potato 72 | :permission/pred :predicate/none} 73 | {:permission/verb :verb/* 74 | :permission/obj :vegetable/potato 75 | :permission/pred :predicate/none}]}) 76 | 77 | (def john 78 | "Represents a *John* persona that is allowed to: 79 | - eat all tomatoes 80 | - mash all potatoes 81 | - do CRUD on own potatoes" 82 | {:permissions [{:permission/verb :verb/eat 83 | :permission/obj :vegetable/tomato 84 | :permission/pred :predicate/none} 85 | {:permission/verb :verb/mash 86 | :permission/obj :vegetable/potato 87 | :permission/pred :predicate/none} 88 | {:permission/verb :verb/* 89 | :permission/obj :vegetable/potato 90 | :permission/pred :predicate/owner}]}) 91 | 92 | (deftest test-allowed-all? 93 | (testing "Check access on all entities of a type" 94 | (is (true? (ac/allowed-all? jane :verb/delete :vegetable/potato)) 95 | "Jane should be allowed to delete all potatoes") 96 | (is (false? (ac/allowed-all? john :verb/delete :vegetable/tomato)) 97 | "John should not be allowed to delete all tomatoes") 98 | (is (false? (ac/allowed-all? jane :verb/mash :vegetable/tomato)) 99 | "Jane should not be allowed to mash all tomatoes") 100 | (is (false? (ac/allowed-all? john :verb/eat :vegetable/potato)) 101 | "John should not be allowed to eat all potatoes") 102 | (is (false? (ac/allowed-all? jane :verb/eat :vegetable/potato)) 103 | "Jane should not be allowed to eat all potatoes") 104 | (is (true? (ac/allowed-all? john :verb/mash :vegetable/potato)) 105 | "John should be allowed to mash all potatoes"))) 106 | 107 | (deftest test-allowed-some? 108 | (testing "Check access on some entities of a type" 109 | (is (false? (ac/allowed-some? jane :verb/delete :vegetable/tomato)) 110 | "Jane should not be allowed to delete any tomatoes") 111 | (is (true? (ac/allowed-some? john :verb/delete :vegetable/potato)) 112 | "John should be allowed delete some potatoes") 113 | (is (true? (ac/allowed-some? jane :verb/fry :vegetable/potato)) 114 | "Jane should be allowed to fry some potatoes") 115 | (is (false? (ac/allowed-some? john :verb/eat :vegetable/potato)) 116 | "John should be not allowed to eat any potatoes") 117 | (is (true? (ac/allowed-some? jane :verb/eat :vegetable/tomato)) 118 | "Jane should be allowed to eat some tomatoes") 119 | (is (true? (ac/allowed-some? john :verb/eat :vegetable/tomato)) 120 | "John should be allowed to eat some tomatoes"))) 121 | 122 | (deftest test-allowed? 123 | (testing "Check access on specific entities" 124 | (is (false? (ac/allowed? jane :verb/delete :vegetable/tomato {:tomato/serial-number "203098120983"})) 125 | "Jane should not be allowed to delete this tomato") 126 | (is (false? (ac/allowed? john :verb/delete :vegetable/potato {:potato/color :color/green})) 127 | "John should not be allowed to delete this potato") 128 | (is (false? (ac/allowed? jane :verb/mash :vegetable/potato {:potato/color :color/brown})) 129 | "John should not be allowed to mash this potato") 130 | (is (false? (ac/allowed? john :verb/throw :vegetable/potato {:potato/color :color/blue})) 131 | "John should not be allowed to throw this potato") 132 | (is (true? (ac/allowed? jane :verb/eat :vegetable/tomato {:tomato/serial-number "0000048192382"})) 133 | "Jane should be allowed to eat this tomato") 134 | (is (true? (ac/allowed? john 135 | :verb/eat 136 | :vegetable/potato 137 | {:verb/eat true 138 | :verb/throw false 139 | :potato/color :color/yellow})) 140 | "John should be allowed to eat this potato"))) 141 | 142 | (deftest test-may-read-some? 143 | (testing 144 | "Check read access on some entities of a type" 145 | (is (true? (ac/may-read-some? :vegetable/potato (:permissions jane))) 146 | "Jane should be allowed to read some potatoes") 147 | (is (true? (ac/may-read-some? :vegetable/potato (:permissions john))) 148 | "John should be allowed to read some potatoes"))) 149 | 150 | (deftest sufficient-predicates-test 151 | (is 152 | (= #{:predicate/director} 153 | (ac/sufficient-predicates ::schema/movie :verb/read config/restrictive-director-permissions)) 154 | "If a director has restrictive permissions, only the :predicate/director predicate is in the set of sufficient predicates for the :verb/read verb, it has to be true for them being allowed to read a movie") 155 | (is 156 | (= #{:predicate/none :predicate/director} 157 | (ac/sufficient-predicates ::schema/movie :verb/read config/director-permissions)) 158 | "If a director has normal permissions, the special :predicate/none predicate is in the set of sufficient predicates for the :verb/read verb, meaning they are allowed to read all movies") 159 | (is 160 | (= #{} 161 | (ac/sufficient-predicates ::schema/movie :verb/delete config/restrictive-director-permissions)) 162 | "If a director has restrictive permissions, the set of sufficient predicates for the :verb/delete verb is empty, meaning the are not allowed to delete any movies") 163 | (is 164 | (= #{:predicate/director} 165 | (ac/sufficient-predicates ::schema/movie :verb/delete config/director-permissions)) 166 | "If a director has normal permissions, only the :predicate/director predicate is in the set of sufficient predicates for the :verb/read verb, it has to be true for them being allowed to delete a movie")) 167 | 168 | (deftest etypes-extra-conditions-test 169 | (is (= [] 170 | (ac/etypes-extra-conditions config/schema 171 | #{::schema/movie ::schema/actor} 172 | config/director-permissions 173 | :verb/read 174 | {:user-id 1 175 | :user-etype ::schema/user})) 176 | "If a director has normal permissions, no extra conditions apply for reading movies or actors") 177 | (is 178 | (= 179 | [[:and 180 | [:exists 181 | {:select [:userid] 182 | :from [:ac_director_movie] 183 | :where [:and 184 | [:= :userid 1] 185 | [:or [:= :movie.id nil] [:= :movieid :movie.id]]]}]]] 186 | (ac/etypes-extra-conditions config/schema 187 | #{::schema/movie ::schema/actor} 188 | config/restrictive-director-permissions 189 | :verb/read 190 | {:user-id 1 191 | :user-etype ::schema/user})) 192 | "If a director has restrictive permissions, entities-extra-conditions should return a vector of extra conditions containing the ac_director_movie predicate check")) 193 | 194 | (deftest conditions-snippet-test 195 | (is (nil? 196 | (ac/conditions-snippet config/schema 197 | #{::schema/movie ::schema/actor} 198 | config/director-permissions 199 | :verb/read 200 | {:user-id 1 201 | :user-etype ::schema/user})) 202 | "If a director has normal permissions, conditions-snippet should return nil") 203 | (is 204 | (= 205 | ["EXISTS (SELECT userid FROM ac_director_movie WHERE (userid = ?) AND ((movie.id IS NULL) OR (movieid = movie.id)))" 206 | 1] 207 | (ac/conditions-snippet config/schema 208 | #{::schema/movie ::schema/actor} 209 | config/restrictive-director-permissions 210 | :verb/read 211 | {:user-id 1 212 | :user-etype ::schema/user})) 213 | "If a director has restrictive permissions, conditions-snippet should return a sqlvec containing the ac_director_movie predicate check")) 214 | 215 | (deftest fields-extra-read-conditions-test 216 | (is 217 | (= 218 | [[:and 219 | [:exists 220 | {:select [:userid] 221 | :from [:ac_director_movie] 222 | :where [:and 223 | [:= :userid 1] 224 | [:or [:= :movie.id nil] [:= :movieid :movie.id]]]}]]] 225 | (ac/fields-extra-read-conditions config/schema 226 | [:movie/title {:movie/actors [:actor/name]}] 227 | config/restrictive-director-permissions 228 | 1 229 | :schema/user)) 230 | "If a director has restrictive permissions, fields-extra-read-conditions should return a vector of extra conditions containing the ac_director_movie predicate check")) 231 | 232 | (deftest fields-forbidden-entities 233 | (is 234 | (= '(::schema/paragraph) 235 | (ac/fields-forbidden-entities config/schema 236 | [{:movie/reviews [:review/title {:review/paragraphs [:paragraph/content]}]}] 237 | config/director-permissions)) 238 | "For a query including paragraph fields and director permissions, fields-forbidden-entities should return a sequence containing the paragraph entity (unqualified keyword)") 239 | (is 240 | (nil? 241 | (ac/fields-forbidden-entities config/schema 242 | [:review/title {:review/paragraphs [:paragraph/content]}] 243 | config/reviewer-permissions)) 244 | "For a query including only review and paragraph fields and reviewer permissions, fields-forbidden-entities should return nil")) 245 | 246 | (deftest fields-allowed? 247 | (is 248 | (false? 249 | (ac/fields-allowed? config/schema 250 | [{:movie/reviews [:review/title {:review/paragraphs [:paragraph/content]}]}] 251 | config/director-permissions)) 252 | "For a query including paragraph fields and director permissions, fields-allowed? should return false") 253 | (is 254 | (true? 255 | (ac/fields-allowed? config/schema 256 | [:review/title {:review/paragraphs [:paragraph/content]}] 257 | config/reviewer-permissions)) 258 | "For a query including only review and paragraph fields and reviewer permissions, fields-allowed? should return true")) 259 | -------------------------------------------------------------------------------- /test/specomatic_db/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.core-test 2 | "Unit tests for db functions" 3 | (:require 4 | [clojure.test :refer [deftest testing is use-fixtures]] 5 | [specomatic-db.core :as core] 6 | [specomatic-db.db.migration :as migration] 7 | [specomatic-db.test.config :as config] 8 | [specomatic-db.test.schema :as-alias schema]) 9 | (:import [java.sql SQLException] 10 | [org.firebirdsql.testcontainers FirebirdContainer] 11 | [org.testcontainers.containers PostgreSQLContainer])) 12 | 13 | ; an extremely simplified example of a movie catalog. 14 | 15 | (defonce ^{:doc "Database test container."} 16 | ^FirebirdContainer firebird-container 17 | (doto (FirebirdContainer.) 18 | (.setDockerImageName "jacobalberty/firebird:2.5-sc") 19 | (.withDatabaseName "test.fdb") 20 | (.withUsername "sysdba") 21 | (.withPassword "masterke"))) 22 | 23 | (defonce ^{:doc "Database test container."} 24 | ^PostgreSQLContainer postgres-container 25 | (doto (PostgreSQLContainer.) 26 | (.setDockerImageName "postgres:14-alpine") 27 | (.withDatabaseName "test") 28 | (.withUsername "sysdba") 29 | (.withPassword "masterke"))) 30 | 31 | (def 32 | ^{:doc "The current database container"} 33 | current-container 34 | nil) 35 | 36 | (defn db-spec 37 | "Database configuration for test container." 38 | [] 39 | {:connection-uri (.getJdbcUrl current-container) 40 | :jdbcUrl (.getJdbcUrl current-container) 41 | :user (.getUsername current-container) 42 | :password (.getPassword current-container)}) 43 | 44 | ;; Actual testing 45 | 46 | (def keanu-reeves 47 | "The actor Keanu Reeves." 48 | {:actor/name "Keanu Reeves"}) 49 | 50 | (def laurence-fishburne 51 | "The actor Laurence Fishburne." 52 | {:actor/name "Laurence Fishburne"}) 53 | 54 | (def the-wachowskis 55 | "The Wachowski director duo." 56 | {:director/name "The Wachowskis"}) 57 | 58 | (def chad-stahelski 59 | "The director Chad Stahelski." 60 | {:director/name "Chad Stahelski"}) 61 | 62 | (def david-leitch 63 | "The director David Leitch." 64 | {:director/name "David Leitch"}) 65 | 66 | (def the-matrix-cast 67 | "The cast (ensemble of actors) for The Matrix movies." 68 | [keanu-reeves laurence-fishburne]) 69 | 70 | (def john-wick-cast 71 | "The cast for the John Wick original movie." 72 | [keanu-reeves]) 73 | 74 | (def john-wick-chapter-two-cast 75 | "The cast for the John Wick movie sequel." 76 | [keanu-reeves laurence-fishburne]) 77 | 78 | (def the-matrix 79 | "The original Matrix movie." 80 | #:movie{:title "The Matrix" 81 | :release-year 1999 82 | :actors the-matrix-cast 83 | :directors [the-wachowskis]}) 84 | 85 | (def the-matrix-reloaded 86 | "The sequel to The Matrix movie." 87 | #:movie{:title "The Matrix Reloaded" 88 | :release-year 2003 89 | :actors the-matrix-cast 90 | :directors [the-wachowskis]}) 91 | 92 | (def the-matrix-revolutions 93 | "Third installment of The Matrix." 94 | #:movie{:title "The Matrix Revolutions" 95 | :release-year 2003 96 | :actors the-matrix-cast 97 | :directors [the-wachowskis]}) 98 | 99 | (def john-wick 100 | "The original John Wick movie." 101 | #:movie{:title "John Wick" 102 | :release-year 2014 103 | :actors [keanu-reeves] 104 | :directors [chad-stahelski david-leitch]}) 105 | 106 | (def john-wick-chapter-two 107 | "The sequel to the John Wick movie." 108 | #:movie{:title "John Wick: Chapter 2" 109 | :release-year 2017 110 | :actors [keanu-reeves laurence-fishburne] 111 | :directors [chad-stahelski]}) 112 | 113 | (def john-wick-chapter-three 114 | "Third installment of the John Wick movie." 115 | #:movie{:title "John Wick 3" 116 | :release-year 2019 117 | :actors [keanu-reeves laurence-fishburne] 118 | :directors [chad-stahelski]}) 119 | 120 | (def jane 121 | "Jane, who writes movie reviews" 122 | #:reviewer{:name "Jane"}) 123 | 124 | (def john 125 | "John, who writes movie reviews" 126 | #:reviewer{:name "John"}) 127 | 128 | (def friendly-review 129 | "A friendly movie review." 130 | #:review{:title "Highly recommend" 131 | :stars 5 132 | :paragraphs [{:paragraph/content "Awesome."} 133 | {:paragraph/content "Just awesome."}]}) 134 | 135 | (def grumpy-review 136 | "A grumpy movie review." 137 | #:review{:title "Don't watch this movie" 138 | :stars 1 139 | :paragraphs [{:paragraph/content "Didn't like it."} 140 | {:paragraph/content "Fell asleep while watching and had a bad dream."}]}) 141 | 142 | (def chad-stahelski-user 143 | "Chad Stahelski's user." 144 | {:user/username "chad-stahelski"}) 145 | 146 | (def the-wachowskis-user 147 | "The Wachowskis' user." 148 | {:user/username "the-wachowskis"}) 149 | 150 | (def jane-user 151 | "Jane's user." 152 | {:user/username "jane"}) 153 | 154 | (def john-user 155 | "John's user." 156 | {:user/username "john"}) 157 | 158 | (defn get-env 159 | "Gets the environment including the connection to the current database container." 160 | [] 161 | {:jdbc (db-spec) 162 | :config config/config 163 | :user {:root? true}}) 164 | 165 | (defn- init! 166 | [] 167 | (core/init! (get-env))) 168 | 169 | (defn- start! 170 | [container] 171 | (.start container) 172 | (alter-var-root #'current-container (constantly container))) 173 | 174 | (defn- stop! 175 | [container] 176 | (.stop container)) 177 | 178 | (defn- index-single 179 | [maps k] 180 | (->> maps 181 | (group-by k) 182 | (reduce-kv #(assoc % %2 (first %3)) {}))) 183 | 184 | (defn- save-many! 185 | [env etype xs] 186 | (mapv #(core/save! env etype %) xs)) 187 | 188 | (defn- insert-all! 189 | [env] 190 | (let [reviewers-by-name (index-single 191 | (save-many! env 192 | ::schema/reviewer 193 | [jane john]) 194 | :reviewer/name) 195 | saved-actors (save-many! env 196 | ::schema/actor 197 | [keanu-reeves 198 | laurence-fishburne]) 199 | actors-by-name (index-single saved-actors :actor/name) 200 | saved-directors (save-many! env 201 | ::schema/director 202 | [chad-stahelski 203 | david-leitch 204 | the-wachowskis]) 205 | directors-by-name (index-single saved-directors :director/name) 206 | movies 207 | (map 208 | (fn [movie] 209 | (-> movie 210 | (update 211 | :movie/actors 212 | (fn [actors] 213 | (for [actor actors] 214 | (->> actor 215 | :actor/name 216 | (get actors-by-name))))) 217 | (update 218 | :movie/directors 219 | (fn [directors] 220 | (for [director directors] 221 | (->> director 222 | :director/name 223 | (get directors-by-name))))))) 224 | [the-matrix the-matrix-reloaded the-matrix-revolutions john-wick john-wick-chapter-two 225 | john-wick-chapter-three]) 226 | saved-movies (doall (save-many! env ::schema/movie movies)) 227 | saved-users-by-name 228 | (index-single 229 | (save-many! 230 | env 231 | ::schema/user 232 | [(assoc chad-stahelski-user :user/director (get-in directors-by-name ["Chad Stahelski" :director/id])) 233 | (assoc the-wachowskis-user :user/director (get-in directors-by-name ["The Wachowskis" :director/id])) 234 | (assoc jane-user :user/reviewer (get-in reviewers-by-name ["Jane" :reviewer/id])) 235 | (assoc john-user :user/reviewer (get-in reviewers-by-name ["John" :reviewer/id]))]) 236 | :user/username)] 237 | {::schema/actors saved-actors 238 | :actors-by-name actors-by-name 239 | ::schema/directors saved-directors 240 | :directors-by-name directors-by-name 241 | ::schema/movies saved-movies 242 | :reviewers-by-name reviewers-by-name 243 | :users-by-name saved-users-by-name})) 244 | 245 | (defn- submap? 246 | "Check for (shallow) partial equality between maps." 247 | [sub-m m] 248 | (reduce-kv 249 | (fn [r k v] 250 | (and r 251 | (cond 252 | (map? v) (submap? v (get m k)) 253 | (coll? v) (every? true? 254 | (keep-indexed (fn [i x] 255 | (let [y (nth (get m k) i)] 256 | (cond 257 | (map? x) (submap? x y) 258 | :else (= x y)))) 259 | v)) 260 | :else (is (= v (get m k)))))) 261 | true 262 | sub-m)) 263 | 264 | (defn- submaps? 265 | "Apply submap to collections. `a` contains maps which are a submap of `b`." 266 | [b a] 267 | (and (= (count a) (count b)) 268 | (every? true? 269 | (keep-indexed 270 | (fn [i x] (submap? x (nth b i))) 271 | a)))) 272 | 273 | (deftest schema-tests 274 | (let [db (db-spec) 275 | env {:jdbc db 276 | :config config/config 277 | :user {:id 1 278 | :root? true}}] 279 | (testing "Compare against empty database" 280 | (is (= (set (keys (migration/diff-schema db config/schema))) 281 | #{::schema/actor ::schema/director ::schema/movie :movie/actors :movie/directors ::schema/paragraph 282 | ::schema/review ::schema/reviewer ::schema/user}) 283 | "all entities and reference collections should require updating")) 284 | (testing "Compare only selected entity" 285 | (is (= (set (keys (migration/diff-schema db config/schema [::schema/actor]))) 286 | #{::schema/actor}) 287 | "only specified entities should require updating")) 288 | (testing "Migrate the actor table without the name column into the database" 289 | (migration/update-schema! db 290 | (update-in config/schema [::schema/actor :field-defs] #(dissoc % :actor/name)) 291 | [::schema/actor])) 292 | (testing "Migrate the name column of the actor into the database" 293 | (migration/update-schema! db config/schema [::schema/actor])) 294 | (testing 295 | "Insert actor records" 296 | (let [saved-actors (map #(core/save! env ::schema/actor %) 297 | [keanu-reeves laurence-fishburne])] 298 | (is (every? (comp pos? :actor/id) saved-actors) 299 | "Every entity should get an id") 300 | (testing "Inserted records should equal retrieved records" 301 | (let [retrieved-actors (mapv #(core/by-id env ::schema/actor % [:actor/id :actor/name]) 302 | (map :actor/id saved-actors))] 303 | (is (submaps? saved-actors retrieved-actors) 304 | "Retrieved actors should equal inserted actors"))))))) 305 | 306 | (deftest save-and-query-tests 307 | (init!) 308 | (let [env (get-env) 309 | saved-entities (insert-all! env) 310 | the-wachowskis-user-id (get-in saved-entities [:users-by-name "the-wachowskis" :user/id]) 311 | actor-id (get-in saved-entities [:actors-by-name "Laurence Fishburne" :actor/id]) 312 | restricted-env (assoc env 313 | :user 314 | {:id the-wachowskis-user-id 315 | :permissions config/director-permissions}) 316 | more-restricted-env (assoc env 317 | :user 318 | {:id the-wachowskis-user-id 319 | :permissions config/restrictive-director-permissions}) 320 | saved-the-matrix 321 | (first (::schema/movies saved-entities)) 322 | saved-the-matrix-reloaded 323 | (second (::schema/movies saved-entities)) 324 | saved-the-matrix-revolutions 325 | (nth (::schema/movies saved-entities) 2) 326 | saved-john-wick 327 | (nth (::schema/movies saved-entities) 3) 328 | saved-john-wick-chapter-two 329 | (nth (::schema/movies saved-entities) 4) 330 | saved-john-wick-chapter-three 331 | (nth (::schema/movies saved-entities) 5)] 332 | (testing "Insert all" 333 | (is (map? saved-entities))) 334 | (testing "Query all as root, default fields" 335 | (is (submaps? (::schema/movies saved-entities) 336 | (sort-by :movie/id (core/query env ::schema/movie))))) 337 | (testing "Query all as regular user, default fields" 338 | (is (submaps? (::schema/movies saved-entities) 339 | (sort-by :movie/id (core/query restricted-env ::schema/movie))))) 340 | (testing "Query all as more restricted regular user, default fields" 341 | (is (submaps? (filter #(re-find #"Matrix" (:movie/title %)) 342 | (::schema/movies saved-entities)) 343 | (sort-by :movie/id 344 | (core/query more-restricted-env ::schema/movie))))) 345 | 346 | (testing "Update as root" 347 | (is (map? 348 | (core/save! env ::schema/movie (assoc saved-the-matrix :movie/title "The Matrix Renamed"))))) 349 | (testing "Update as regular user" 350 | (is (map? 351 | (core/save! restricted-env ::schema/movie (assoc saved-the-matrix :movie/title "The Matrix Renamed Twice")))) 352 | (is (thrown? 353 | Exception 354 | (core/save! restricted-env ::schema/movie (assoc saved-john-wick :movie/title "John Wick Renamed"))))) 355 | 356 | (testing "Saving nested entities" 357 | (let [jane-reviewer-id (get-in saved-entities [:reviewers-by-name "Jane" :reviewer/id]) 358 | john-reviewer-id (get-in saved-entities [:reviewers-by-name "John" :reviewer/id]) 359 | jane-user-id (get-in saved-entities [:users-by-name "jane" :user/id]) 360 | john-user-id (get-in saved-entities [:users-by-name "john" :user/id]) 361 | jane-env (assoc env 362 | :user 363 | {:id jane-user-id 364 | :permissions config/reviewer-permissions}) 365 | john-env (assoc env 366 | :user 367 | {:id john-user-id 368 | :permissions config/reviewer-permissions})] 369 | (testing "Create reviews with paragraphs" 370 | (is (core/save! jane-env 371 | ::schema/review 372 | (assoc friendly-review 373 | :review/reviewer jane-reviewer-id 374 | :review/movie (:movie/id saved-john-wick)))) 375 | (is (core/save! john-env 376 | ::schema/review 377 | (assoc grumpy-review 378 | :review/reviewer john-reviewer-id 379 | :review/movie saved-john-wick)))) 380 | (testing "Revise reviews with paragraphs" 381 | (let [janes-review (first 382 | (core/query env 383 | ::schema/review 384 | [:review/id {:review/paragraphs [:paragraph/id :paragraph/content]}] 385 | [[:= :review/reviewer jane-reviewer-id]])) 386 | janes-revised-review (-> janes-review 387 | (assoc-in [:review/paragraphs 0 ::core/delete] true)) 388 | johns-review (first 389 | (core/query env 390 | ::schema/review 391 | [:review/id {:review/paragraphs [:paragraph/id :paragraph/content]}] 392 | [[:= :review/reviewer john-reviewer-id]])) 393 | johns-revised-review (-> johns-review 394 | (assoc :review/title "OK" 395 | :review/stars 3) 396 | (dissoc :review/movie) 397 | (assoc-in [:review/paragraphs 0 :paragraph/content] "So-so.") 398 | (assoc-in [:review/paragraphs 1 :paragraph/content] "Not too bad."))] 399 | (is (core/save! jane-env ::schema/review janes-revised-review)) 400 | (is (core/save! john-env ::schema/review johns-revised-review)))) 401 | 402 | (testing "Update reviewer including user" 403 | (let [reviewer-including-user (first (core/query 404 | env 405 | ::schema/reviewer 406 | [:reviewer/id :reviewer/name 407 | {:reviewer/user [:user/id 408 | :user/username]}] 409 | [[:= :reviewer/name 410 | "John"]])) 411 | reviewer-id (:reviewer/id 412 | reviewer-including-user) 413 | renamed-reviewer-including-user (-> john 414 | (assoc :reviewer/name "Jim") 415 | (assoc-in [:reviewer/user 416 | :user/username] 417 | "jim"))] 418 | (is (pos? (get-in (core/save! env 419 | ::schema/reviewer 420 | (-> reviewer-including-user 421 | (assoc :reviewer/name "Jim") 422 | (assoc-in [:reviewer/user :user/username] "jim"))) 423 | [:reviewer/user :tx/id])) 424 | "save! should return transaction id for nested entity") 425 | (is (submap? 426 | renamed-reviewer-including-user 427 | (core/by-id env 428 | ::schema/reviewer 429 | reviewer-id 430 | [:reviewer/id :reviewer/name 431 | {:reviewer/user [:user/id :user/username]}])) 432 | "Both reviewer name and username should be updated"))))) 433 | 434 | (testing "Query inverse relations" 435 | (let [result (core/query restricted-env 436 | ::schema/actor 437 | [:actor/name {:actor/movies [:movie/id]}] 438 | [[:= :actor/id actor-id]]) 439 | actor-movies (-> result 440 | first 441 | :actor/movies)] 442 | (is (= (map :movie/id 443 | [saved-the-matrix saved-the-matrix-reloaded saved-the-matrix-revolutions saved-john-wick-chapter-two 444 | saved-john-wick-chapter-three]) 445 | (map :movie/id actor-movies)) 446 | "Inverse reference collection should include all the actor's movies but no others") 447 | (is (= '(#:director{:name "Chad Stahelski" 448 | :user #:user{:username "chad-stahelski"}}) 449 | (core/query env 450 | ::schema/director 451 | [:director/name {:director/user [:user/username]}] 452 | [[:= :user/username "chad-stahelski"]])) 453 | "Inverse reference should return a single entity") 454 | (is (= '(#:movie{:title "John Wick" 455 | :reviews [#:review{:title "Highly recommend"} 456 | #:review{:title "OK"}]}) 457 | (core/query env 458 | ::schema/movie 459 | [:movie/title {:movie/reviews [:review/title]}] 460 | [[:= :movie/title "John Wick"]])) 461 | "Inverse reference collection should return a collection"))) 462 | 463 | (testing "Query historic data" 464 | (let [version-1 (core/by-id env 465 | ::schema/movie 466 | (:movie/id saved-john-wick-chapter-three)) 467 | {movieid :movie/id 468 | title-1 :movie/title 469 | tx-id :tx/id} 470 | saved-john-wick-chapter-three 471 | title-2 "John Wick: Chapter three" 472 | title-3 "John Wick: Chapter 3"] 473 | (is (> tx-id 0) "Should include a transaction id") 474 | (testing "Update transactions" 475 | (let [version-2 (core/save! env ::schema/movie (assoc version-1 :movie/title title-2)) 476 | version-3 (core/save! env 477 | ::schema/movie 478 | (-> version-1 479 | (assoc :movie/title title-3) 480 | (assoc-in [:movie/actors 0 ::core/delete] true)))] 481 | (is (< tx-id (:tx/id version-2) (:tx/id version-3)) "Updates should have different transaction ids") 482 | (testing "Retrieve historic data" 483 | (testing "Query for latest version" 484 | (is (submap? (core/by-id env 485 | ::schema/movie 486 | movieid) 487 | version-3) 488 | "Query without transaction id should return latest version.")) 489 | (testing "Query for older versions" 490 | (is (submap? (core/by-id (assoc env :tx/id tx-id) 491 | ::schema/movie 492 | movieid) 493 | version-1) 494 | "Query for transaction id of version-1 should return version-1.") 495 | (is (empty? (core/by-id (assoc env :tx/id (dec tx-id)) 496 | ::schema/movie 497 | movieid)) 498 | "Record should not exist in earlier transactions.") 499 | (is (submap? (core/by-id (assoc env :tx/id (:tx/id version-2)) 500 | ::schema/movie 501 | movieid) 502 | version-2) 503 | "Query for transaction id of version-2 should return version-2.") 504 | (is (submap? (core/by-id (assoc env :tx/id (inc (:tx/id version-3))) 505 | ::schema/movie 506 | movieid) 507 | version-3) 508 | "Query for later transaction id should return most recent record."))) 509 | (testing "Retrieve full entity history" 510 | (is (submaps? (core/entity-history env ::schema/movie movieid [:movie/title]) 511 | [#:movie{:title title-1} #:movie{:title title-2} #:movie{:title title-3}]))))))) 512 | 513 | (testing "Query fields not present in the schema" 514 | (is (thrown-with-msg? 515 | Exception 516 | #"Access to fields denied" 517 | (core/query restricted-env ::schema/movie [:movie/id :movie/spoiler {:movie/directors [:director/fee]}])) 518 | "Querying fields not in the schema should throw 'Access to fields denied' for a regular user") 519 | (is (thrown? 520 | SQLException 521 | (core/query env ::schema/movie [:movie/id :movie/spoiler {:movie/directors [:director/fee]}])) 522 | "Querying fields not in the schema and not in the database should throw SQL exception for root")) 523 | 524 | (testing "Delete" 525 | (testing "Delete as root" 526 | (is (core/delete! env ::schema/movie (:movie/id saved-the-matrix-reloaded))) 527 | (is (nil? 528 | (core/delete! restricted-env ::schema/movie 8789)) 529 | "Trying to delete a nonexistent movie should return nil")) 530 | (testing "Delete as regular user" 531 | (is (core/delete! restricted-env ::schema/movie (:movie/id saved-the-matrix)) 532 | "With less restrictive permissions, the Wachowskis should be allowed to delete The Matrix") 533 | (is (thrown? 534 | Exception 535 | (core/delete! restricted-env ::schema/movie (:movie/id saved-john-wick))) 536 | "But they should still not be allowed to delete John Wick") 537 | (is (nil? (core/delete! restricted-env ::schema/movie (:movie/id saved-the-matrix))) 538 | "Trying to delete an already deleted movie should return nil")) 539 | (testing "Delete as more restricted regular user" 540 | (is 541 | (thrown? 542 | Exception 543 | (core/delete! more-restricted-env ::schema/movie (:movie/id saved-the-matrix))) 544 | "With permissions not allowing deletion of any movies, trying to delete a movie should throw Permission 545 | denied even if it does not exist"))))) 546 | 547 | (use-fixtures :each 548 | #(do 549 | (start! postgres-container) 550 | (try (%) 551 | (finally 552 | (stop! postgres-container))) 553 | (start! firebird-container) 554 | (try (%) 555 | (finally 556 | (stop! firebird-container))))) 557 | -------------------------------------------------------------------------------- /test/specomatic_db/db/firebird_test.clj: -------------------------------------------------------------------------------- 1 | (ns specomatic-db.db.firebird-test 2 | (:require 3 | [clojure.test :refer [deftest is testing]] 4 | [next.jdbc :as jdbc] 5 | [next.jdbc.result-set :as rs] 6 | [specomatic-db.db.migration :as migration] 7 | [specomatic-db.db.mutation :as mut]) 8 | (:import [org.firebirdsql.testcontainers FirebirdContainer])) 9 | 10 | (defn- builder-fn 11 | "Builds a result set." 12 | [rs _opts] 13 | (let [rsmeta (.getMetaData rs) 14 | cols (mapv (fn [^Integer i] (.getColumnLabel rsmeta i)) 15 | (range 1 16 | (inc (if rsmeta 17 | (.getColumnCount rsmeta) 18 | 0))))] 19 | (rs/->MapResultSetBuilder rs rsmeta cols))) 20 | 21 | (deftest unit-tests 22 | (let [db-container (doto (FirebirdContainer.) 23 | (.setDockerImageName "jacobalberty/firebird:2.5-sc") 24 | (.withDatabaseName "test.fdb") 25 | (.withUsername "sysdba") 26 | (.withPassword "masterke") 27 | (.start)) 28 | db {:connection-uri (.getJdbcUrl db-container) 29 | :jdbcUrl (.getJdbcUrl db-container) 30 | :user (.getUsername db-container) 31 | :password (.getPassword db-container)} 32 | ds (jdbc/get-datasource db)] 33 | (try 34 | (testing "Setup schema for assertions" 35 | (migration/ensure-transaction-infrastructure! db) 36 | (jdbc/execute! ds ["create table foo (id integer primary key, bar integer, baz varchar(32))"])) 37 | (testing "Insert into database" 38 | (let [inserted (mut/insert! db 39 | {:foo {:field-defs {:id {:kind :simple} 40 | :bar {:kind :simple} 41 | :baz {:kind :simple}} 42 | :id-field :id}} 43 | :foo 44 | {:id 1 45 | :bar 1 46 | :baz "qux"}) 47 | rows (jdbc/execute! 48 | ds 49 | ["select id, bar, baz from foo"] 50 | {:builder-fn builder-fn})] 51 | (is (= 1 (count rows)) "Table foo should contain only one record.") 52 | (is (= (select-keys inserted ["ID" "BAR" "BAZ"]) 53 | (first rows))))) 54 | (finally 55 | (.stop db-container))))) 56 | -------------------------------------------------------------------------------- /tests.edn: -------------------------------------------------------------------------------- 1 | #kaocha/v1 2 | {:tests [{:id :unit 3 | :type :kaocha.type/clojure.test 4 | :ns-patterns [".*"] 5 | :test-paths ["test" "src"]}] 6 | 7 | :kaocha/reporter [kaocha.report/documentation] 8 | 9 | :plugins [:kaocha.plugin/junit-xml 10 | :kaocha.plugin/cloverage 11 | ] 12 | 13 | :kaocha.plugin.junit-xml/target-file "junit.xml" 14 | 15 | :cloverage/opts {:ns-exclude-regex [] 16 | :text? false 17 | :lcov? true 18 | :exclude-call [nedap.utils.spec.api/check!] 19 | :high-watermark 80 20 | :fail-threshold 0 21 | :output "target/coverage" 22 | :low-watermark 50 23 | :ns-regex [] 24 | :summary? true 25 | :coveralls? false 26 | :emma-xml? false 27 | :html? true 28 | :nop? false 29 | :codecov? true}} 30 | --------------------------------------------------------------------------------