greg/mentat
1
0
Fork 0
Code Issues 294 Pull requests Projects Releases 9 Packages Wiki Activity

Implement type-aware querying, fulltext searching, fast importing, and much besides. Fixes #14, #30, #35, #39, #40, #42. r=nalexander

Browse source
This commit is contained in:
Richard Newman 2016-08-30 18:24:12 -07:00
commit b2a1af30ed
34 changed files with 3382 additions and 847 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
project.clj
View file

@ -8,6 +8,8 @@
[org.clojure/core.async "0.2.385"]
[datascript "0.15.1"]
[honeysql "0.8.0"]
[com.datomic/datomic-free "0.9.5359"]
[com.taoensso/tufte "1.0.2"]
[jamesmacaulay/cljs-promises "0.1.0"]]
:cljsbuild {:builds {:release {
@ -48,9 +50,12 @@
[org.clojure/tools.nrepl "0.2.10"]
[org.clojure/java.jdbc "0.6.2-alpha1"]
[org.xerial/sqlite-jdbc "3.8.11.2"]]
:jvm-opts ["-Xss4m"]
:repl-options {:nrepl-middleware [cemerick.piggieback/wrap-cljs-repl]}
:plugins [[lein-cljsbuild "1.1.3"]
[lein-doo "0.1.6"]]
[lein-doo "0.1.6"]
[venantius/ultra "0.4.1"]
[com.jakemccrary/lein-test-refresh "0.16.0"]]
}}
:doo {:build "test"}

196
src/datomish/d.clj Normal file
View file

@ -0,0 +1,196 @@
(ns datomish.d
(:require [datomic.db :as db]))
(use '[datomic.api :only [q db] :as d])
(use 'clojure.pprint)
(def uri "datomic:free://localhost:4334//news")
(d/create-database uri)
(def conn (d/connect uri))
(def schema-tx (read-string (slurp "src/datomish/schema.edn")))
(println "schema-tx:")
(pprint schema-tx)
;; alter/attribute does not retract/assert install/attribute.
;; @(d/transact conn [{:db/id :news/baz
;; :db/cardinality :db.cardinality/one
;; :db.alter/_attribute :db.part/db}])
@(d/transact conn schema-tx)
;; add some data:
(def data-tx [{:news/title "Rain Tomorrow", :db/id #db/id[:db.part/user -1000001]}])
@(d/transact conn data-tx)
(def x
@(d/transact conn [[:db/add #db/id[:db.part/user -1] :news/title "Rain Tomorrow 1" #db/id[:db.part/tx -1]]
[:db/add #db/id[:db.part/user -2] :news/title "Rain Tomorrow 2" #db/id[:db.part/tx -2]]
[:db/add #db/id[:db.part/tx -2] :news/title "Test"]]))
;; This drops the tx entirely!
(def x
@(d/transact conn [[:db/add #db/id[:db.part/user -1] :news/title "Rain Tomorrow 3" 13194139534684]]))
(def x
@(d/transact conn [[:db/add #db/id[:db.part/user -1] :news/title "Rain Tomorrow 3" 13194139534684]
{:db/id #db/id[:db.part/db -1] :db/ident :test/test2 :db.install/_partition :db.part/db}
[:db/add #db/id[:db.part/tx -2] :news/title "Test"]]))
(def x
@(d/transact conn [[:db/add #db/id[:test/test2 -1] :news/title "Rain Tomorrow 5"]]))
;; [:db/add #db/id[:db.part/user -2] :news/title "Rain Tomorrow 2" #db/id[:db.part/tx -2]]
;; [:db/add #db/id[:db.part/tx -2] :news/title "Test"]]))
(def results (q '[:find ?n :where [?n :news/title]] (db conn)))
(println (count results))
(pprint results)
(pprint (first results))
(def id (ffirst results))
(def entity (-> conn db (d/entity id)))
;; display the entity map's keys
(pprint (keys entity))
;; display the value of the entity's community name
(println (:news/title entity))
;; @(d/transact conn [[:db/retract )
@(d/transact conn [[:db/add 17592186045427 :news/title "Test"]])
;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; :db.error/datoms-conflict Two datoms in the same transaction
;; conflict {:d1 [17592186045427 :news/title "Test" 13194139534372
;; true], :d2 [17592186045427 :news/title "Test2" 13194139534372
;; true]}
;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; :db.error/not-an-entity Unable to resolve entity: [:news/foobar
;; "a"] in datom [[:news/foobar "a"] :news/foobar "b"]
;; {:db/error :db.error/not-an-entity}
;; @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/foobar "a"]
;; [:db/add #db/id[db.part/user -2] :news/zot "a"]])
;; @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/baz #db/id[db.part/user -2]]
;; [:db/add #db/id[db.part/user -2] :news/baz #db/id[db.part/user -1]]])
;; {:db-before datomic.db.Db@a0166706, :db-after datomic.db.Db@5d0d6a62, :tx-data [#datom[13194139534399 50 #inst "2016-07-20T04:45:19.553-00:00" 13194139534399 true] #datom[17592186045504 68 17592186045505 13194139534399 true] #datom[17592186045505 68 17592186045504 13194139534399 true]], :tempids {-9223350046622220289 17592186045504, -9223350046622220290 17592186045505}}
;; @(d/transact conn [[:db/add [:news/foobar "a"] :news/foobar "b"]])
;; @(d/transact conn [[:db/retract 17592186045505 68 17592186045504 13194139534399]])
;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; :db.error/not-a-data-function Unable to resolve data function:
;; {:news/foobar "a", :news/zot "a", :news/title "test"}
;; {:db/error :db.error/not-a-data-function}
;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; :db.error/entity-missing-db-id Missing :db/id
;; {:input {:news/foobar "a", :news/zot "a", :news/title "test"}, :db/error :db.error/entity-missing-db-id}
;; @(d/transact conn [{:news/foobar "a" :news/zot "a" :news/title "test"}])
;; ;; 1. Caused by datomic.impl.Exceptions$IllegalStateExceptionInfo
;; ;; :db.error/unique-conflict Unique conflict: :news/zot, value: a
;; ;; already held by: 17592186045489 asserted for: 17592186045483
;; ;; {:db/error :db.error/unique-conflict}
;; @(d/transact conn [{:db/id [:news/foobar "a"] :news/zot "a" :news/title "test"}])
;; ;; 1. Caused by datomic.impl.Exceptions$IllegalStateExceptionInfo
;; ;; :db.error/unique-conflict Unique conflict: :news/zot, value: b
;; ;; already held by: 17592186045492 asserted for: 17592186045483
;; @(d/transact conn [
;; {:db/id #db/id[db.part/user -1] :news/foobar "c" :news/zot "c"}])
;; ;; {:db/id #db/id[db.part/user -1] :news/zot "a"} ])
;; ;; 1. Caused by datomic.impl.Exceptions$IllegalStateExceptionInfo
;; ;; :db.error/unique-conflict Unique conflict: :news/foobar, value: b
;; ;; already held by: 17592186045478 asserted for: 1
;; ;; {:db/error :db.error/unique-conflict}
;; @(d/transact conn [[:db/add 17592186045478 :news/foobar "b"]])
;; @(d/transact conn [[:db/add 17592186045478 :news/foobar "a"]])
;; ;; Datomic accepts two different id-literals resolving to the same entid.
(def txx #db/id[db.part/tx])
(def x @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/foobar "c"]
[:db/add #db/id[db.part/user -2] :news/zot "c"]
[:db/add txx :news/title "x"]
[:db/add #db/id[db.part/tx -5] :news/title "x"]
]))
(def x @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/baz #db/id[db.part/tx]]]))
;; ;; 1. Caused by datomic.impl.Exceptions$IllegalArgumentExceptionInfo
;; ;; :db.error/tempid-not-an-entity tempid used only as value in
;; ;; transaction
;; ;; {:db/error :db.error/tempid-not-an-entity}
;; @(d/transact conn [[:db/add #db/id[db.part/user -1] :news/baz #db/id[db.part/user -3]]
;; [:db/add #db/id[db.part/user -2] :news/baz #db/id[db.part/user -3]]])
;; ;; 2. Unhandled java.util.concurrent.ExecutionException
;; ;; java.lang.IndexOutOfBoundsException
;; @(d/transact conn [[:db/add #db/id[db.part/user -1] :db/ident :news/zot]
;; [:db/add #db/id[db.part/user -2] #db/id[db.part/user -1] "c"]])
(vec
(q '[:find ?added ?a ?v ?tx
:where
[17592186045427 ?a ?v ?tx ?added]
;; [(>= ?e 17592186045427)]
;; [(tx-ids ?log ?t1 ?t2) [?tx ...]]
;; [(tx-data ?log ?tx) [[?e ?a ?v _ ?added]]]
]
(d/db conn)))
;; [[true 63 "Test" 13194139534324]]
(vec
(q '[:find ?e ?added ?a ?v ?tx
:in ?log ?t1 ?t2
:where
[(tx-ids ?log ?t1 ?t2) [?tx ...]]
[(tx-data ?log ?tx) [[?e ?a ?v _ ?added]]]
[(= ?e 17592186045427)]
]
(d/log conn) #inst "2013-08-01" #inst "2017-01-01"))
[[17592186045427 false 63 "Rain Tomorrow" 13194139534324] [17592186045427 true 63 "Test" 13194139534324] [17592186045427 false 63 "Test" 13194139534325] [17592186045427 true 63 "Rain Tomorrow" 13194139534322]]
;; [[17592186045427 false 63 "Rain Tomorrow" 13194139534324] [17592186045427 true 63 "Test" 13194139534324] [17592186045427 true 63 "Rain Tomorrow" 13194139534322]]
@(d/transact conn [[:db/retract 17592186045427 :news/title "Test"]])
(sort-by first (d/q '[:find ?a ?ident :where
[?e ?a ?ident]
[_ :db.install/attribute ?e]] (db/bootstrap-db)))
(def x (db/bootstrap-db))
(pprint (vec (map (juxt :e :a :v :tx :added) (filter #(= 13194139533312 (:tx %)) (d/datoms x :eavt)))))
(pprint (sort (set (map (juxt :tx) (d/datoms x :eavt)))))
(def tx0 13194139533312)
(def tx1 13194139533366)
(def tx2 13194139533368)
(def tx3 13194139533375)
(pprint
(sort-by first (d/q '[:find ?e ?an ?v ?tx
:in $ ?tx
:where
[?e ?a ?v ?tx true]
[?a :db/ident ?an]
] x tx3)))
;; (d/datoms x :eavt))))
;; 13194139533312

580
src/datomish/db.cljc
View file

@ -8,16 +8,19 @@
[datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]]))
(:require
[clojure.set]
[datomish.query.context :as context]
[datomish.query.projection :as projection]
[datomish.query.source :as source]
[datomish.query :as query]
[datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.util :as util
#?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.schema :as ds]
[datomish.schema-changes]
[datomish.sqlite :as s]
[datomish.sqlite-schema :as sqlite-schema]
[taoensso.tufte :as tufte
#?(:cljs :refer-macros :clj :refer) [defnp p profiled profile]]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :as a :refer [chan go <! >!]]])
#?@(:cljs [[datomish.pair-chan]
@ -34,6 +37,9 @@
(uncaughtException [_ thread ex]
(println ex "Uncaught exception on" (.getName thread))))))
(def max-sql-vars 999) ;; TODO: generalize.
;; ----------------------------------------------------------------------------
;; define data-readers to be made available to EDN readers. in CLJS
;; they're magically available. in CLJ, data_readers.clj may or may
@ -55,7 +61,7 @@
(->TempId part idx)))
(defn id-literal? [x]
(and (instance? TempId x)))
(instance? TempId x))
(defprotocol IClock
(now
@ -74,13 +80,13 @@
[db]
"Return the schema of this database.")
(idents
[db]
"Return the known idents of this database, as a map from keyword idents to entids.")
(entid
[db ident]
"Returns the entity id associated with a symbolic keyword, or the id itself if passed.")
(current-tx
[db]
"TODO: document this interface.")
(ident
[db eid]
"Returns the keyword associated with an id, or the key itself if passed.")
(in-transaction!
[db chan-fn]
@ -88,29 +94,29 @@
commit the transaction; otherwise, rollback the transaction. Returns a pair-chan resolving to
the pair-chan returned by `chan-fn`.")
(<eavt
[db pattern]
"Search for datoms using the EAVT index.")
(<bootstrapped? [db]
"Return true if this database has no transactions yet committed.")
(<avet
[db pattern]
"Search for datoms using the AVET index.")
(<av
[db a v]
"Search for a single matching datom using the AVET index.")
(<apply-datoms
[db datoms]
"Apply datoms to the store.")
(<apply-entities
[db tx entities]
"Apply entities to the store, returning sequence of datoms transacted.")
(<apply-db-ident-assertions
[db added-idents]
"Apply added idents to the store.")
[db added-idents merge]
"Apply added idents to the store, using `merge` as a `merge-with` function.")
(<apply-db-install-assertions
[db fragment]
"Apply added schema fragment to the store.")
[db fragment merge]
"Apply added schema fragment to the store, using `merge` as a `merge-with` function.")
(<advance-tx
[db]
"TODO: document this interface."))
(<next-eid
[db id-literal]
"Return a unique integer for the given id-literal, accounting for the literal's partition. The
returned integer should never be returned again."))
(defn db? [x]
(and (satisfies? IDB x)
@ -140,117 +146,459 @@
]
rowid)))
(defrecord DB [sqlite-connection schema idents current-tx]
;; idents is map {ident -> entid} of known idents. See http://docs.datomic.com/identity.html#idents.
(defn datoms-attribute-transform
[db x]
{:pre [(db? db)]}
(entid db x))
(defn datoms-constant-transform
[db x]
{:pre [(db? db)]}
(sqlite-schema/->SQLite x))
(defn datoms-source [db]
(source/map->DatomsSource
{:table :datoms
:schema (:schema db)
:fulltext-table :fulltext_datoms
:fulltext-values :fulltext_values
:fulltext-view :all_datoms
:columns [:e :a :v :tx :added]
:attribute-transform (partial datoms-attribute-transform db)
:constant-transform (partial datoms-constant-transform db)
:table-alias source/gensym-table-alias
:make-constraints nil}))
(defn- retractions->queries [retractions tx fulltext? ->SQLite]
(let
[f-q
"WITH vv AS (SELECT rowid FROM fulltext_values WHERE text = ?)
INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, sv, svalue_type_tag)
VALUES (?, ?, (SELECT rowid FROM vv), ?, 0, ?, (SELECT rowid FROM vv), ?)"
non-f-q
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, sv, svalue_type_tag)
VALUES (?, ?, ?, ?, 0, ?, ?, ?)"]
(map
(fn [[_ e a v]]
(let [[v tag] (->SQLite a v)]
(if (fulltext? a)
[f-q
v e a tx tag tag]
[non-f-q
e a v tx tag v tag])))
retractions)))
(defn- non-fts-many->queries [ops tx ->SQLite indexing? ref? unique?]
(let [q "INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, index_avet0, index_vaet0, index_fulltext0, unique_value0, sv, svalue_type_tag) VALUES "
values-part
;; e0, a0, v0, tx0, added0, value_type_tag0
;; index_avet0, index_vaet0, index_fulltext0,
;; unique_value0, sv, svalue_type_tag
"(?, ?, ?, ?, 1, ?, ?, ?, 0, ?, ?, ?)"
repeater (memoize (fn [n] (interpose ", " (repeat n values-part))))]
;; This query takes ten variables per item. So we partition into max-sql-vars / 10.
(map
(fn [chunk]
(cons
;; Query string.
(apply str q (repeater (count chunk)))
;; Bindings.
(mapcat (fn [[_ e a v]]
(let [[v tag] (->SQLite a v)]
[e a v tx tag
(indexing? a) ; index_avet
(ref? a) ; index_vaet
(unique? a) ; unique_value
v tag]))
chunk)))
(partition-all (quot max-sql-vars 10) ops))))
(defn- non-fts-one->queries [ops tx ->SQLite indexing? ref? unique?]
(let [first-values-part
;; TODO: order value and tag closer together.
;; flags0
;; sv, svalue_type_tag
"(?, ?, ?, ?, ?, ?, ?, ?, 0, ?, ?, ?)"
first-repeater (memoize (fn [n] (interpose ", " (repeat n first-values-part))))
second-values-part
"(?, ?, ?, ?, ?, ?)"
second-repeater (memoize (fn [n] (interpose ", " (repeat n second-values-part))))
]
;; :db.cardinality/one takes two queries.
(mapcat
(fn [chunk]
[(cons
(apply
str
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, index_avet0, index_vaet0, index_fulltext0, unique_value0, sv, svalue_type_tag) VALUES "
(first-repeater (count chunk)))
(mapcat (fn [[_ e a v]]
(let [[v tag] (->SQLite a v)]
[e a v tx 1 tag
(indexing? a) ; index_avet
(ref? a) ; index_vaet
(unique? a) ; unique_value
v tag]))
chunk))
(cons
(apply
str
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0) VALUES "
(second-repeater (count chunk)))
(mapcat (fn [[_ e a v]]
(let [[v tag] (->SQLite a v)]
[e a v tx 0 tag]))
chunk))])
(partition-all (quot max-sql-vars 11) ops))))
(def initial-many-searchid 2000) ; Just to make it more obvious in the DB.
(def initial-one-searchid 5000)
;;; An FTS insertion happens in two parts.
;;;
;;; Firstly, we ensure that the fulltext value is present in the store.
;;; This is effectively an INSERT OR IGNORE… but FTS tables don't support
;;; uniqueness constraints. So we do it through a trigger on a view.
;;;
;;; When we insert the value, we pass with it a searchid. We'll use this
;;; later when inserting the datom, then we'll throw it away. The FTS table
;;; only contains searchids for the duration of the transaction that uses
;;; them.
;;;
;;; Secondly, we insert a row just like for non-FTS. The only difference
;;; is that the value is the rowid into the fulltext_values table.
(defn- fts-many->queries [ops tx ->SQLite indexing? ref? unique?]
;; TODO: operations with the same text value should be
;; coordinated here!
;; It'll work fine without so long as queries are executed
;; in order and not combined, but even so it's inefficient.
(conj
(mapcat
(fn [[_ e a v] searchid]
(let [[v tag] (->SQLite a v)]
;; First query: ensure the value exists.
[["INSERT INTO fulltext_values_view (text, searchid) VALUES (?, ?)"
v searchid]
;; Second query: tx_lookup.
[(str
"WITH vv(rowid) AS (SELECT rowid FROM fulltext_values WHERE searchid = ?) "
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, index_avet0, index_vaet0, index_fulltext0, unique_value0, sv, svalue_type_tag) VALUES "
"(?, ?, (SELECT rowid FROM vv), ?, 1, ?, ?, ?, 1, ?, (SELECT rowid FROM vv), ?)")
searchid
e a tx tag
(indexing? a) ; index_avet
(ref? a) ; index_vaet
(unique? a) ; unique_value
tag]]))
ops
(range initial-many-searchid 999999999))
["UPDATE fulltext_values SET searchid = NULL WHERE searchid IS NOT NULL"]))
(defn fts-one->queries [ops tx ->SQLite indexing? ref? unique?]
(conj
(mapcat
(fn [[_ e a v] searchid]
(let [[v tag] (->SQLite a v)]
;; First query: ensure the value exists.
[["INSERT INTO fulltext_values_view (text, searchid) VALUES (?, ?)"
v searchid]
;; Second and third queries: tx_lookup.
[(str
"WITH vv(rowid) AS (SELECT rowid FROM fulltext_values WHERE searchid = ?) "
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0, index_avet0, index_vaet0, index_fulltext0, unique_value0, sv, svalue_type_tag) VALUES "
"(?, ?, (SELECT rowid FROM vv), ?, 1, ?, ?, ?, 1, ?, (SELECT rowid FROM vv), ?)")
searchid
e a tx tag
(indexing? a) ; index_avet
(ref? a) ; index_vaet
(unique? a) ; unique_value
tag]
[(str
"INSERT INTO tx_lookup (e0, a0, v0, tx0, added0, value_type_tag0) VALUES "
"(?, ?, (SELECT rowid FROM fulltext_values WHERE searchid = ?), ?, 0, ?)")
e a searchid tx tag]]))
ops
(range initial-one-searchid 999999999))
["UPDATE fulltext_values SET searchid = NULL WHERE searchid IS NOT NULL"]))
(defn- -run-queries [conn queries exception-message]
(go-pair
(try
(doseq [q queries]
(<? (s/execute! conn q)))
(catch #?(:clj java.sql.SQLException :cljs js/Error) e
(throw (ex-info exception-message {} e))))))
(defn- -preamble-drop [conn]
(let [preamble-drop-index ["DROP INDEX IF EXISTS id_tx_lookup_added"]
preamble-delete-tx-lookup ["DELETE FROM tx_lookup"]]
(go-pair
(p :preamble
(doseq [q [preamble-drop-index preamble-delete-tx-lookup]]
(<? (s/execute! conn q)))))))
(defn- -after-drop [conn]
(go-pair
(doseq [q [;; The lookup table takes space on disk, so we purge it aggressively.
["DROP INDEX IF EXISTS id_tx_lookup_added"]
["DELETE FROM tx_lookup"]]]
(<? (s/execute! conn q)))))
(defn- -build-transaction [conn tx]
(let [build-indices ["CREATE INDEX IF NOT EXISTS idx_tx_lookup_added ON tx_lookup (added0)"]
;; First is fast, only one table walk: lookup by exact eav.
;; Second is slower, but still only one table walk: lookup old value by ea.
insert-into-tx-lookup
["INSERT INTO tx_lookup
SELECT t.e0, t.a0, t.v0, t.tx0, t.added0 + 2, t.value_type_tag0, t.index_avet0, t.index_vaet0, t.index_fulltext0, t.unique_value0, t.sv, t.svalue_type_tag, d.rowid, d.e, d.a, d.v, d.tx, d.value_type_tag
FROM tx_lookup AS t
LEFT JOIN datoms AS d
ON t.e0 = d.e AND
t.a0 = d.a AND
t.sv = d.v AND
t.svalue_type_tag = d.value_type_tag AND
t.sv IS NOT NULL
UNION ALL
SELECT t.e0, t.a0, t.v0, t.tx0, t.added0 + 2, t.value_type_tag0, t.index_avet0, t.index_vaet0, t.index_fulltext0, t.unique_value0, t.sv, t.svalue_type_tag, d.rowid, d.e, d.a, d.v, d.tx, d.value_type_tag
FROM tx_lookup AS t,
datoms AS d
WHERE t.sv IS NULL AND
t.e0 = d.e AND
t.a0 = d.a"]
t-datoms-not-already-present
["INSERT INTO transactions (e, a, v, tx, added, value_type_tag)
SELECT e0, a0, v0, ?, 1, value_type_tag0
FROM tx_lookup
WHERE added0 IS 3 AND e IS NULL" tx] ;; TODO: get rid of magic value 3.
t-retract-datoms-carefully
["INSERT INTO transactions (e, a, v, tx, added, value_type_tag)
SELECT e, a, v, ?, 0, value_type_tag
FROM tx_lookup
WHERE added0 IS 2 AND ((sv IS NOT NULL) OR (sv IS NULL AND v0 IS NOT v)) AND v IS NOT NULL" tx] ;; TODO: get rid of magic value 2.
]
(go-pair
(doseq [q [build-indices insert-into-tx-lookup
t-datoms-not-already-present
t-retract-datoms-carefully]]
(<? (s/execute! conn q))))))
(defn- -build-datoms [conn tx]
(let [d-datoms-not-already-present
["INSERT INTO datoms (e, a, v, tx, value_type_tag, index_avet, index_vaet, index_fulltext, unique_value)
SELECT e0, a0, v0, ?, value_type_tag0,
index_avet0, index_vaet0, index_fulltext0, unique_value0
FROM tx_lookup
WHERE added0 IS 3 AND e IS NULL" tx] ;; TODO: get rid of magic value 3.
;; TODO: retract fulltext datoms correctly.
d-retract-datoms-carefully
["WITH ids AS (SELECT l.rid FROM tx_lookup AS l WHERE l.added0 IS 2 AND ((l.sv IS NOT NULL) OR (l.sv IS NULL AND l.v0 IS NOT l.v)))
DELETE FROM datoms WHERE rowid IN ids" ;; TODO: get rid of magic value 2.
]]
(-run-queries conn [d-datoms-not-already-present d-retract-datoms-carefully]
"Transaction violates unique constraint")))
(defn- -<apply-entities [db tx entities]
(let [schema (.-schema db)
->SQLite (partial ds/->SQLite schema)
fulltext? (memoize (partial ds/fulltext? schema))
many? (memoize (fn [a] (ds/multival? schema a)))
indexing? (memoize (fn [a] (ds/indexing? schema a)))
ref? (memoize (fn [a] (ds/ref? schema a)))
unique? (memoize (fn [a] (ds/unique? schema a)))
conn (:sqlite-connection db)
;; Collect all the queries we need to run.
queries (atom [])
operations (group-by first entities)]
(when-not (clojure.set/subset? (keys operations) #{:db/retract :db/add})
(raise (str "Unknown operations " (keys operations))
{:error :transact/syntax, :operations (dissoc operations :db/retract :db/add)}))
;; We can turn all non-FTS operations into simple SQL queries that we run serially.
;; FTS queries require us to get a rowid from the FTS table and use that for
;; insertion, so we need another pass.
;; We can't just freely use `go-pair` here, because this function is so complicated
;; that ClojureScript blows the stack trying to compile it.
(when-let [retractions (:db/retract operations)]
(swap!
queries concat (retractions->queries retractions tx fulltext? ->SQLite)))
;; We want to partition our additions into four groups according to two
;; characteristics: whether they require writing to the FTS value table,
;; and whether the attribute has a 'many' cardinality constraint. Each of
;; these four requires different queries.
(let [additions
(group-by (fn [[op e a v]]
(if (fulltext? a)
(if (many? a)
:fts-many
:fts-one)
(if (many? a)
:non-fts-many
:non-fts-one)))
(:db/add operations))
transforms
{:fts-one fts-one->queries
:fts-many fts-many->queries
:non-fts-one non-fts-one->queries
:non-fts-many non-fts-many->queries}]
(doseq [[key ops] additions]
(when-let [transform (key transforms)]
(swap!
queries concat
(transform ops tx ->SQLite indexing? ref? unique?)))))
;; Now run each query.
;; This code is a little tortured to avoid blowing the compiler stack in cljs.
(go-pair
(<? (-preamble-drop conn))
(p :run-insert-queries
(<? (-run-queries conn @queries "Transaction violates cardinality constraint")))
;; Follow up by building indices, then do the work.
(p :build-and-transaction
(<? (-build-transaction conn tx)))
(p :update-materialized-datoms
(<? (-build-datoms conn tx)))
(<? (-after-drop conn))
;; Return the written transaction.
(p :select-tx-data
(mapv (partial row->Datom schema)
(<?
(s/all-rows
(:sqlite-connection db)
;; We index on tx, so the following is fast.
["SELECT * FROM transactions WHERE tx = ?" tx])))))))
(defrecord DB [sqlite-connection schema ident-map]
;; ident-map maps between keyword idents and integer entids. The set of idents and entids is
;; disjoint, so we represent both directions of the mapping in the same map for simplicity. Also
;; for simplicity, we assume that an entid has at most one associated ident, and vice-versa. See
;; http://docs.datomic.com/identity.html#idents.
;; TODO: cache parts. parts looks like {:db.part/db {:start 0 :current 10}}. It maps between
;; keyword ident part names and integer ranges.
IDB
(query-context [db] (context/->Context (source/datoms-source db) nil nil))
(query-context [db] (context/make-context (datoms-source db)))
(schema [db] (.-schema db))
(idents [db] (.-idents db))
(entid [db ident]
(if (keyword? ident)
(get (.-ident-map db) ident ident)
ident))
(current-tx
[db]
(inc (:current-tx db)))
(ident [db eid]
(if-not (keyword? eid)
(get (.-ident-map db) eid eid)
eid))
(in-transaction! [db chan-fn]
(s/in-transaction!
(:sqlite-connection db) chan-fn))
;; TODO: use q for searching? Have q use this for searching for a single pattern?
(<eavt [db pattern]
(let [[e a v] pattern
v (and v (ds/->SQLite schema a v))] ;; We assume e and a are always given.
(<bootstrapped? [db]
(go-pair
(->
(:sqlite-connection db)
(s/all-rows ["SELECT EXISTS(SELECT 1 FROM transactions LIMIT 1) AS bootstrapped"])
(<?)
(first)
(:bootstrapped)
(not= 0))))
(<av [db a v]
(let [schema (.-schema db) ;; TODO: understand why (schema db) fails.
a (entid db a)
[v tag] (ds/->SQLite schema a v)
yield-datom
(fn [rows]
(when-let [row (first rows)]
(row->Datom schema row)))]
(go-pair
(->>
{:select [:e :a :v :tx [1 :added]] ;; TODO: generalize columns.
:from [:all_datoms]
:where (cons :and (map #(vector := %1 %2) [:e :a :v] (take-while (comp not nil?) [e a v])))} ;; Must drop nils.
(s/format)
;; TODO: generalize columns.
["SELECT e, a, v, tx, 1 AS added FROM all_datoms
WHERE index_avet = 1 AND a = ? AND value_type_tag = ? AND v = ?
LIMIT 1" a tag v]
(s/all-rows (:sqlite-connection db))
(<?)
<?
yield-datom))))
(mapv (partial row->Datom (.-schema db))))))) ;; TODO: understand why (schema db) fails.
(<avet [db pattern]
(let [[a v] pattern
v (ds/->SQLite schema a v)]
(go-pair
(->>
{:select [:e :a :v :tx [1 :added]] ;; TODO: generalize columns.
:from [:all_datoms]
:where [:and [:= :a a] [:= :v v] [:= :index_avet 1]]}
(s/format)
(s/all-rows (:sqlite-connection db))
(<?)
(mapv (partial row->Datom (.-schema db))))))) ;; TODO: understand why (schema db) fails.
(<apply-datoms [db datoms]
(<next-eid [db tempid]
{:pre [(id-literal? tempid)]}
{:post [ds/entid?]}
(go-pair
;; TODO: keep all of these eid allocations in the transaction report and apply them at the end
;; of the transaction.
(let [exec (partial s/execute! (:sqlite-connection db))
schema (.-schema db)] ;; TODO: understand why (schema db) fails.
;; TODO: batch insert, batch delete.
(doseq [datom datoms]
(let [[e a v tx added] datom
v (ds/->SQLite schema a v)
fulltext? (ds/fulltext? schema a)]
;; Append to transaction log.
(<? (exec
["INSERT INTO transactions VALUES (?, ?, ?, ?, ?)" e a v tx (if added 1 0)]))
;; Update materialized datom view.
(if (.-added datom)
(let [v (if fulltext?
(<? (<insert-fulltext-value db v))
v)]
(<? (exec
["INSERT INTO datoms VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)" e a v tx
(ds/indexing? schema a) ;; index_avet
(ds/ref? schema a) ;; index_vaet
fulltext? ;; index_fulltext
(ds/unique-value? schema a) ;; unique_value
(ds/unique-identity? schema a) ;; unique_identity
])))
(if fulltext?
(<? (exec
;; TODO: in the future, purge fulltext values from the fulltext_datoms table.
["DELETE FROM datoms WHERE (e = ? AND a = ? AND v IN (SELECT rowid FROM fulltext_values WHERE text = ?))" e a v]))
(<? (exec
["DELETE FROM datoms WHERE (e = ? AND a = ? AND v = ?)" e a v])))))))
db))
part (entid db (:part tempid))]
(when-not (ds/entid? part) ;; TODO: cache parts materialized view.
(raise "Cannot allocate entid for id-literal " tempid " because part " (:part tempid) " is not known"
{:error :db/bad-part
:part (:part tempid)}))
(<advance-tx [db]
(p :next-eid-body
(<? (exec ["UPDATE parts SET idx = idx + 1 WHERE part = ?" part]))
(:eid (first (<? (s/all-rows (:sqlite-connection db) ["SELECT (start + idx) AS eid FROM parts WHERE part = ?" part]))))))))
(<apply-entities [db tx entities]
{:pre [(db? db) (sequential? entities)]}
(-<apply-entities db tx entities))
(<apply-db-ident-assertions [db added-idents merge]
(go-pair
(let [exec (partial s/execute! (:sqlite-connection db))]
;; (let [ret (<? (exec
;; ;; TODO: be more clever about UPDATE OR ...?
;; ["UPDATE metadata SET current_tx = ? WHERE current_tx = ?" (inc (:current-tx db)) (:current-tx db)]))]
;; TODO: handle exclusion across transactions here.
(update db :current-tx inc))))
(<apply-db-ident-assertions [db added-idents]
(go-pair
(let [->SQLite (get-in ds/value-type-map [:db.type/keyword :->SQLite]) ;; TODO: make this a protocol.
exec (partial s/execute! (:sqlite-connection db))]
;; TODO: batch insert.
(doseq [[ident entid] added-idents]
(<? (exec
["INSERT INTO idents VALUES (?, ?)" (->SQLite ident) entid]))))
db))
["INSERT INTO idents VALUES (?, ?)" (sqlite-schema/->SQLite ident) entid]))))
(<apply-db-install-assertions [db fragment]
(let [db (update db :ident-map #(merge-with merge % added-idents))
db (update db :ident-map #(merge-with merge % (clojure.set/map-invert added-idents)))]
db)))
(<apply-db-install-assertions [db fragment merge]
(go-pair
(let [->SQLite (get-in ds/value-type-map [:db.type/keyword :->SQLite]) ;; TODO: make this a protocol.
exec (partial s/execute! (:sqlite-connection db))]
(let [exec (partial s/execute! (:sqlite-connection db))]
;; TODO: batch insert.
(doseq [[ident attr-map] fragment]
(doseq [[attr value] attr-map]
(<? (exec
["INSERT INTO schema VALUES (?, ?, ?)" (->SQLite ident) (->SQLite attr) (->SQLite value)])))))
db))
["INSERT INTO schema VALUES (?, ?, ?)" (sqlite-schema/->SQLite ident) (sqlite-schema/->SQLite attr) (sqlite-schema/->SQLite value)])))))
(let [symbolic-schema (merge-with merge (:symbolic-schema db) fragment)
schema (ds/schema (into {} (map (fn [[k v]] [(entid db k) v]) symbolic-schema)))]
(assoc db
:symbolic-schema symbolic-schema
:schema schema))))
(close-db [db] (s/close (.-sqlite-connection db)))
@ -261,6 +609,24 @@
:cljs
(.getTime (js/Date.)))))
(defn with-ident [db ident entid]
(update db :ident-map #(assoc % ident entid, entid ident)))
(defn db [sqlite-connection idents schema]
{:pre [(map? idents)
(every? keyword? (keys idents))
(map? schema)
(every? keyword? (keys schema))]}
(let [entid-schema (ds/schema (into {} (map (fn [[k v]] [(k idents) v]) schema))) ;; TODO: fail if ident missing.
ident-map (into idents (clojure.set/map-invert idents))]
(map->DB
{:sqlite-connection sqlite-connection
:ident-map ident-map
:symbolic-schema schema
:schema entid-schema
;; TODO :parts
})))
;; TODO: factor this into the overall design.
(defn <?run
"Execute the provided query on the provided DB.

59
src/datomish/db/debug.cljc Normal file
View file

@ -0,0 +1,59 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.db.debug
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]]))
(:require
[datomish.db :as db]
[datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.sqlite :as s]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :as a :refer [chan go <! >!]]])
#?@(:cljs [[datomish.pair-chan]
[cljs.core.async :as a :refer [chan <! >!]]]))
#?(:clj
(:import
[datomish.datom Datom])))
(defn <datoms-after [db tx]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT e, a, v, tx FROM datoms WHERE tx > ?" tx])
(<?)
(mapv #(vector (:e %) (db/ident db (:a %)) (:v %)))
(filter #(not (= :db/txInstant (second %))))
(set))))
(defn <datoms [db]
(<datoms-after db 0))
(defn <shallow-entity [db eid]
;; TODO: make this actually be <entity. Handle :db.cardinality/many and :db/isComponent.
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT a, v FROM datoms WHERE e = ?" eid])
(<?)
(mapv #(vector (db/ident db (:a %)) (:v %)))
(reduce conj {}))))
(defn <transactions-after [db tx]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT e, a, v, tx, added FROM transactions WHERE tx > ? ORDER BY tx ASC, e, a, v, added" tx])
(<?)
(mapv #(vector (:e %) (db/ident db (:a %)) (:v %) (:tx %) (:added %))))))
(defn <transactions [db]
(<transactions-after db 0))
(defn <fulltext-values [db]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT rowid, text FROM fulltext_values"])
(<?)
(mapv #(vector (:rowid %) (:text %))))))

69
src/datomish/db_factory.cljc
View file

@ -23,35 +23,22 @@
(:import
[datomish.datom Datom])))
;; TODO: implement support for DB parts?
(def tx0 0x2000000)
(defn <idents [sqlite-connection]
"Read the ident map materialized view from the given SQLite store.
Returns a map (keyword ident) -> (integer entid), like {:db/ident 0}."
(let [<-SQLite (get-in ds/value-type-map [:db.type/keyword :<-SQLite])] ;; TODO: make this a protocol.
(go-pair
(let [rows (<? (->>
{:select [:ident :entid] :from [:idents]}
(s/format)
(s/all-rows sqlite-connection)))]
(into {} (map (fn [row] [(<-SQLite (:ident row)) (:entid row)])) rows)))))
(defn <current-tx [sqlite-connection]
"Find the largest tx written to the SQLite store.
Returns an integer, -1 if no transactions have been written yet."
(go-pair
(let [rows (<? (s/all-rows sqlite-connection ["SELECT COALESCE(MAX(tx), -1) AS current_tx FROM transactions"]))]
(:current_tx (first rows)))))
(into {} (map (fn [row] [(sqlite-schema/<-SQLite :db.type/keyword (:ident row)) (:entid row)])) rows))))
(defn <symbolic-schema [sqlite-connection]
"Read the schema map materialized view from the given SQLite store.
Returns a map (keyword ident) -> (map (keyword attribute -> keyword value)), like
{:db/ident {:db/cardinality :db.cardinality/one}}."
(let [<-SQLite (get-in ds/value-type-map [:db.type/keyword :<-SQLite])] ;; TODO: make this a protocol.
(go-pair
(->>
(->>
@ -60,23 +47,34 @@
(s/all-rows sqlite-connection))
(<?)
(group-by (comp <-SQLite :ident))
(group-by (comp (partial sqlite-schema/<-SQLite :db.type/keyword) :ident))
(map (fn [[ident rows]]
[ident
(into {} (map (fn [row]
[(<-SQLite (:attr row)) (<-SQLite (:value row))]) rows))]))
(into {})))))
[(sqlite-schema/<-SQLite :db.type/keyword (:attr row))
(sqlite-schema/<-SQLite :db.type/keyword (:value row))]) rows))])) ;; TODO: this is wrong, it doesn't handle true.
(into {}))))
(defn <initialize-connection [sqlite-connection]
(go-pair
;; Some of these return values when set, and some don't, hence the craziness here.
(<? (s/execute! sqlite-connection ["PRAGMA page_size=32768"]))
(<? (s/all-rows sqlite-connection ["PRAGMA journal_mode=wal"]))
(<? (s/all-rows sqlite-connection ["PRAGMA wal_autocheckpoint=32"]))
(<? (s/all-rows sqlite-connection ["PRAGMA journal_size_limit=3145728"]))
(<? (s/execute! sqlite-connection ["PRAGMA foreign_keys=ON"]))))
(defn <db-with-sqlite-connection
[sqlite-connection]
(go-pair
(<? (<initialize-connection sqlite-connection))
(when-not (= sqlite-schema/current-version (<? (sqlite-schema/<ensure-current-version sqlite-connection)))
(raise "Could not ensure current SQLite schema version."))
(let [current-tx (<? (<current-tx sqlite-connection))
bootstrapped (>= current-tx 0)
current-tx (max current-tx tx0)]
(when-not bootstrapped
(let [db (db/db sqlite-connection bootstrap/idents bootstrap/symbolic-schema)
bootstrapped? (<? (db/<bootstrapped? db))]
(when-not bootstrapped?
;; We need to bootstrap the DB.
(let [fail-alter-ident (fn [old new] (if-not (= old new)
(raise "Altering idents is not yet supported, got " new " altering existing ident " old
@ -86,12 +84,17 @@
(raise "Altering schema attributes is not yet supported, got " new " altering existing schema attribute " old
{:error :schema/alter-schema :old old :new new})
new))]
(-> (db/map->DB
{:sqlite-connection sqlite-connection
:idents bootstrap/idents
:symbolic-schema bootstrap/symbolic-schema
:schema (ds/schema (into {} (map (fn [[k v]] [(k bootstrap/idents) v]) bootstrap/symbolic-schema))) ;; TODO: fail if ident missing.
:current-tx current-tx})
(do
(let [exec (partial s/execute! (:sqlite-connection db))]
;; TODO: allow inserting new parts.
;; TODO: think more carefully about allocating new parts and bitmasking part ranges.
(<? (exec
["INSERT INTO parts VALUES (?, ?, ?)" (db/entid db :db.part/db) 0x0 (inc (apply max (vals bootstrap/idents)))]))
(<? (exec
["INSERT INTO parts VALUES (?, ?, ?)" (db/entid db :db.part/user) 0x10000 0]))
(<? (exec
["INSERT INTO parts VALUES (?, ?, ?)" (db/entid db :db.part/tx) 0x10000000 0])))
(-> db
;; We use <with-internal rather than <transact! to apply the bootstrap transaction
;; data but to not follow the regular schema application process. We can't apply the
;; schema changes, since the applied datoms would conflict with the bootstrapping
@ -100,12 +103,13 @@
;; datoms to the store. It's feasible but awkward.) After bootstrapping, we read
;; back the idents and schema, just like when we re-open.
(transact/<with-internal (bootstrap/tx-data) fail-alter-ident fail-alter-attr)
(<?))))
(<?)))))
;; We just bootstrapped, or we are returning to an already bootstrapped DB.
(let [idents (<? (<idents sqlite-connection))
symbolic-schema (<? (<symbolic-schema sqlite-connection))]
(when-not bootstrapped
(when-not bootstrapped?
;; TODO: parts.
(when (not (= idents bootstrap/idents))
(raise "After bootstrapping database, expected new materialized idents and old bootstrapped idents to be identical"
{:error :bootstrap/bad-idents,
@ -116,9 +120,4 @@
{:error :bootstrap/bad-symbolic-schema,
:new symbolic-schema :old bootstrap/symbolic-schema
})))
(db/map->DB
{:sqlite-connection sqlite-connection
:idents idents
:symbolic-schema symbolic-schema
:schema (ds/schema (into {} (map (fn [[k v]] [(k idents) v]) symbolic-schema))) ;; TODO: fail if ident missing.
:current-tx (inc current-tx)})))))
(db/db sqlite-connection idents symbolic-schema)))))

22
src/datomish/exec_repl.cljc
View file

@ -9,6 +9,7 @@
[datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]]))
(:require
[datomish.db-factory]
[datomish.db :as db]
[datomish.sqlite :as s]
[datomish.sqlite-schema :as ss]
@ -44,7 +45,7 @@
#_
(defn xxopen []
(datomish.pair-chan/go-pair
(let [d (datomish.pair-chan/<? (s/<sqlite-connection "/tmp/foo.sqlite"))]
(let [d (datomish.pair-chan/<? (s/<sqlite-connection "/tmp/import.sqlite"))]
(clojure.core.async/<!! (ss/<ensure-current-version d))
(def db d))))
@ -59,19 +60,26 @@
"/tmp/foo.sqlite"
'[:find ?page :in $ :where [?page :page/starred true ?t]]))
#_(require 'datomish.exec-repl)
#_(in-ns 'datomish.exec-repl)
#_
(go-pair
(let [connection (<? (s/<sqlite-connection "/tmp/foo.sqlite"))
d (<? (db/<with-sqlite-connection connection))]
(println
"Result: "
(<! (db/<?q d '[:find ?page :in $ :where [?page :page/starred true ?t]] {})))))
(let [connection (<? (s/<sqlite-connection "/tmp/bigport.db"))
d (<? (datomish.db-factory/<db-with-sqlite-connection connection))]
(def db d)))
#_
(go-pair
(println (count (first (time
(<! (db/<?q db
'[:find ?url ?title :in $ :where
[?page :page/visitAt ?v] [(> ?v 1438748166567751)] [?page :page/title ?title] [?page :page/url ?url] ] {})))))))
#_
(go-pair
(let [connection (<? (s/<sqlite-connection "/tmp/foo.sqlite"))
dd (<? (db/<with-sqlite-connection connection))]
dd (<? (datomish.db-factory/<db-with-sqlite-connection connection))]
(def *db* dd)))
#_
(clojure.core.async/<!!

1
src/datomish/jdbc_sqlite.clj
View file

@ -31,6 +31,7 @@
(defn open
[path & {:keys [mode]}]
(let [spec {:classname "org.sqlite.JDBC"
:identifiers identity
:subprotocol "sqlite"
:subname path}] ;; TODO: use mode.
(go-pair

101
src/datomish/places/import.cljc Normal file
View file

@ -0,0 +1,101 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.places.import
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]]))
(:require
[datomish.db :as db]
[datomish.transact :as transact]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.sqlite :as s]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :as a :refer [chan go <! >!]]])
#?@(:cljs [[datomish.pair-chan]
[cljs.core.async :as a :refer [chan <! >!]]])))
(def places-schema-fragment
[{:db/id (db/id-literal :db.part/user)
:db/ident :page/url
:db/unique :db.unique/identity
:db/valueType :db.type/string ;; TODO: uri
:db.install/_attribute :db.part/db}
{:db/id (db/id-literal :db.part/user)
:db/ident :page/guid
:db/unique :db.unique/identity
:db/valueType :db.type/string ;; TODO: uuid or guid?
:db.install/_attribute :db.part/db}
{:db/id (db/id-literal :db.part/user)
:db/ident :page/title
:db/cardinality :db.cardinality/one
:db/valueType :db.type/string
:db.install/_attribute :db.part/db}
{:db/id (db/id-literal :db.part/user)
:db/ident :page/visitAt
:db/cardinality :db.cardinality/many
:db/valueType :db.type/long ;; TODO: instant
:db.install/_attribute :db.part/db}
])
(defn- place->entity [[id rows]]
(let [title (:title (first rows))
required {:db/id (db/id-literal :db.part/user)
:page/url (:url (first rows))
:page/guid (:guid (first rows))}
visits (keep :visit_date rows)]
(util/assoc-if required
:page/title title
:page/visitAt visits)))
(defn import-titles [conn places-connection]
(go-pair
(let [rows
(<?
(s/all-rows
places-connection
["SELECT DISTINCT p.title AS title, p.guid
FROM moz_places AS p
WHERE p.title IS NOT NULL AND p.hidden = 0 LIMIT 10"]))]
(<?
(transact/<transact!
conn
(map (fn [row]
{:db/id [:page/guid (:guid row)]
:page/title (:title row)})
rows))))))
(defn import-places [conn places-connection]
(go-pair
;; Ensure schema fragment is in place, even though it may cost a (mostly empty) transaction.
(<? (transact/<transact! conn places-schema-fragment))
(let [rows
(<?
(s/all-rows
places-connection
["SELECT DISTINCT p.id AS id, p.url AS url, p.title AS title, p.visit_count, p.last_visit_date, p.guid,
hv.visit_date
FROM (SELECT * FROM moz_places LIMIT 1000) AS p LEFT JOIN moz_historyvisits AS hv ON p.id = hv.place_id
WHERE p.hidden = 0
ORDER BY p.id, hv.visit_date"]))]
(<?
(transact/<transact!
conn
(map place->entity (group-by :id rows)))))))
(defn import-titles-from-path [db places]
(go-pair
(let [conn (transact/connection-with-db db)
pdb (<? (s/<sqlite-connection places))]
(import-titles conn pdb))))
(defn import-places-from-path [db places]
(go-pair
(let [conn (transact/connection-with-db db)
pdb (<? (s/<sqlite-connection places))]
(import-places conn pdb))))

41
src/datomish/query.cljc
View file

@ -40,14 +40,26 @@
(def sql-quoting-style :ansi)
(defn context->sql-clause [context]
(let [inner
(merge
{:select (projection/sql-projection context)
{:select (projection/sql-projection-for-relation context)
;; Always SELECT DISTINCT, because Datalog is set-based.
;; TODO: determine from schema analysis whether we can avoid
;; the need to do this.
:modifiers [:distinct]}
(clauses/cc->partial-subquery (:cc context))))
(clauses/cc->partial-subquery (:cc context)))]
(if (:has-aggregates? context)
(merge
(when-not (empty? (:group-by-vars context))
;; We shouldn't need to account for types here, until we account for
;; `:or` clauses that bind from different attributes.
{:group-by (map util/var->sql-var (:group-by-vars context))})
{:select (projection/sql-projection-for-aggregation context :preag)
:modifiers [:distinct]
:from [:preag]
:with {:preag inner}})
inner)))
(defn context->sql-string [context args]
(->
@ -56,8 +68,9 @@
(sql/format args :quoting sql-quoting-style)))
(defn- validate-with [with]
(when-not (nil? with)
(raise-str "`with` not supported.")))
(when-not (or (nil? with)
(every? #(instance? Variable %1) with))
(raise "Complex :with not supported." {:with with})))
(defn- validate-in [in]
(when (nil? in)
@ -91,10 +104,15 @@
(let [{:keys [find in with where]} find] ; Destructure the Datalog query.
(validate-with with)
(validate-in in)
(let [external-bindings (in->bindings in)]
(let [external-bindings (in->bindings in)
elements (:elements find)
known-types {}
group-by-vars (projection/extract-group-by-vars elements with)]
(assoc context
:elements (:elements find)
:cc (clauses/patterns->cc (:default-source context) where external-bindings)))))
:elements elements
:group-by-vars group-by-vars
:has-aggregates? (not (nil? group-by-vars))
:cc (clauses/patterns->cc (:default-source context) where known-types external-bindings)))))
(defn find->sql-clause
"Take a parsed `find` expression and turn it into a structured SQL
@ -116,21 +134,22 @@
[q]
(dp/parse-query q))
(comment
#_
(def sql-quoting-style nil)
#_
(datomish.query/find->sql-string
(datomish.query.context/->Context (datomish.query.source/datoms-source nil) nil nil)
(datomish.query.context/make-context (datomish.query.source/datoms-source nil))
(datomish.query/parse
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [(> ?t ?latest)]) ])
{:latest 5})
)
#_
(datomish.query/find->sql-string
(datomish.query.context/->Context (datomish.query.source/datoms-source nil) nil nil)
(datomish.query.context/make-context (datomish.query.source/datoms-source nil))
(datomish.query/parse
'[:find ?page :in $ ?latest :where
[?page :page/url "http://example.com/"]

104
src/datomish/query/cc.cljc
View file

@ -8,6 +8,7 @@
:refer [attribute-in-source
constant-in-source]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[honeysql.core :as sql]
[datascript.parser :as dp
#?@(:cljs
[:refer
@ -52,27 +53,97 @@
;;
;; `from` is a list of [source alias] pairs, suitable for passing to honeysql.
;; `bindings` is a map from var to qualified columns.
;; `known-types` is a map from var to type keyword (e.g., :db.type/ref)
;; `extracted-types` is a mapping, similar to `bindings`, but used to pull
;; type tags out of the store at runtime.
;; `wheres` is a list of fragments that can be joined by `:and`.
(defrecord ConjoiningClauses [source from external-bindings bindings wheres])
(defrecord ConjoiningClauses
[source
from ; [[:datoms 'datoms123]]
external-bindings ; {?var0 (sql/param :foobar)}
bindings ; {?var1 :datoms123.v}
known-types ; {?var1 :db.type/integer}
extracted-types ; {?var2 :datoms123.value_type_tag}
wheres ; [[:= :datoms123.v 15]]
ctes ; {:name {:select …}}
])
(defn bind-column-to-var [cc variable col]
(let [var (:symbol variable)]
(util/conj-in cc [:bindings var] col)))
(defn bind-column-to-var [cc variable table position]
(let [var (:symbol variable)
col (sql/qualify table (name position))
bound (util/append-in cc [:bindings var] col)]
(if (or (not (= position :v))
(contains? (:known-types cc) var)
(contains? (:extracted-types cc) var))
;; Type known; no need to accumulate a type-binding.
bound
(let [tag-col (sql/qualify table :value_type_tag)]
(assoc-in bound [:extracted-types var] tag-col)))))
(defn constrain-column-to-constant [cc col position value]
(util/conj-in cc [:wheres]
(defn constrain-column-to-constant [cc table position value]
(let [col (sql/qualify table (name position))]
(util/append-in cc
[:wheres]
[:= col (if (= :a position)
(attribute-in-source (:source cc) value)
(constant-in-source (:source cc) value))]))
(constant-in-source (:source cc) value))])))
(defn augment-cc [cc from bindings wheres]
(defprotocol ITypeTagged (->tag-codes [x]))
(extend-protocol ITypeTagged
#?@(:cljs
[string (->tag-codes [x] #{4 10 11 12})
Keyword (->tag-codes [x] #{13}) ; TODO: what about idents?
boolean (->tag-codes [x] #{1})
number (->tag-codes [x]
(if (integer? x)
#{0 4 5} ; Could be a ref or a number or a date.
#{4 5}))]) ; Can't be a ref.
#?@(:clj
[String (->tag-codes [x] #{10})
clojure.lang.Keyword (->tag-codes [x] #{13}) ; TODO: what about idents?
Boolean (->tag-codes [x] #{1})
Integer (->tag-codes [x] #{0 5}) ; Could be a ref or a number.
Long (->tag-codes [x] #{0 5}) ; Could be a ref or a number.
Float (->tag-codes [x] #{5})
Double (->tag-codes [x] #{5})
java.util.UUID (->tag-codes [x] #{11})
java.util.Date (->tag-codes [x] #{4})
java.net.URI (->tag-codes [x] #{12})]))
(defn constrain-value-column-to-constant
"Constrain a `v` column. Note that this can contribute *two*
constraints: one for the column itself, and one for the type tag.
We don't need to do this if the attribute is known and thus
constrains the type."
[cc table-alias value]
(let [possible-type-codes (->tag-codes value)
aliased (sql/qualify table-alias (name :value_type_tag))
clauses (map
(fn [code] [:= aliased code])
possible-type-codes)]
(util/concat-in cc [:wheres]
;; Type checks then value checks.
[(case (count clauses)
0 (raise-str "Unexpected number of clauses.")
1 (first clauses)
(cons :or clauses))
[:= (sql/qualify table-alias (name :v))
(constant-in-source (:source cc) value)]])))
(defn augment-cc [cc from bindings extracted-types wheres]
(assoc cc
:from (concat (:from cc) from)
:bindings (merge-with concat (:bindings cc) bindings)
:extracted-types (merge (:extracted-types cc) extracted-types)
:wheres (concat (:wheres cc) wheres)))
(defn merge-ccs [left right]
(augment-cc left (:from right) (:bindings right) (:wheres right)))
(augment-cc left
(:from right)
(:bindings right)
(:extracted-types right)
(:wheres right)))
(defn- bindings->where
"Take a bindings map like
@ -115,16 +186,19 @@
(impose-external-bindings
(assoc cc :wheres
;; Note that the order of clauses here means that cross-pattern var bindings
;; come first. That's OK: the SQL engine considers these altogether.
(concat (bindings->where (:bindings cc))
(:wheres cc)))))
;; come last That's OK: the SQL engine considers these altogether.
(concat (:wheres cc)
(bindings->where (:bindings cc))))))
(defn binding-for-symbol-or-throw [cc symbol]
(defn binding-for-symbol [cc symbol]
(let [internal-bindings (symbol (:bindings cc))
external-bindings (symbol (:external-bindings cc))]
(or (first internal-bindings)
(first external-bindings)
(raise-str "No bindings yet for " symbol))))
(first external-bindings))))
(defn binding-for-symbol-or-throw [cc symbol]
(or (binding-for-symbol cc symbol)
(raise-str "No bindings yet for " symbol)))
(defn argument->value
"Take a value from an argument list and resolve it against the CC.

95
src/datomish/query/clauses.cljc
View file

@ -7,10 +7,12 @@
[datomish.query.cc :as cc]
[datomish.query.functions :as functions]
[datomish.query.source
:refer [attribute-in-source
:refer [pattern->schema-value-type
attribute-in-source
constant-in-source
source->from
source->constraints]]
[datomish.schema :as schema]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datascript.parser :as dp
#?@(:cljs
@ -50,18 +52,48 @@
Not->NotJoinClause not-join->where-fragment
simple-or? simple-or->cc)
(defn- check-or-apply-value-type [cc value-type pattern-part]
(if (nil? value-type)
cc
(condp instance? pattern-part
Placeholder
cc
Variable
(let [var-sym (:symbol pattern-part)]
(if-let [existing-type (var-sym (:known-types cc))]
(if (= existing-type value-type)
cc
(raise "Var " var-sym " already has type " existing-type "; this pattern wants " value-type
{:pattern pattern-part :value-type value-type}))
(assoc-in cc [:known-types var-sym] value-type)))
Constant
(do
(or (and (= :db.type/ref value-type)
(or (keyword? (:value pattern-part)) ; ident
(integer? (:value pattern-part)))) ; entid
(schema/ensure-value-matches-type value-type (:value pattern-part)))
cc))))
(defn- apply-pattern-clause-for-alias
"This helper assumes that `cc` has already established a table association
for the provided alias."
[cc alias pattern]
(let [places (map vector
(:pattern pattern)
(:columns (:source cc)))]
(let [pattern (:pattern pattern)
columns (:columns (:source cc))
places (map vector pattern columns)
value-type (pattern->schema-value-type (:source cc) pattern)] ; Optional; e.g., :db.type/string
(reduce
(fn [cc
[pattern-part ; ?x, :foo/bar, 42
position]] ; :a
(let [col (sql/qualify alias (name position))] ; :datoms123.a
(let [cc (case position
;; TODO: we should be able to constrain :e and :a to be
;; entities... but the type checker expects that to be an int.
:v (check-or-apply-value-type cc value-type pattern-part)
:e (check-or-apply-value-type cc :db.type/ref pattern-part)
cc)]
(condp instance? pattern-part
;; Placeholders don't contribute any bindings, nor do
;; they constrain the query -- there's no need to produce
@ -70,10 +102,16 @@
cc
Variable
(cc/bind-column-to-var cc pattern-part col)
(cc/bind-column-to-var cc pattern-part alias position)
Constant
(cc/constrain-column-to-constant cc col position (:value pattern-part))
(if (and (nil? value-type)
(= position :v))
;; If we don't know the type, but we have a constant, generate
;; a :wheres clause constraining the accompanying value_type_tag
;; column.
(cc/constrain-value-column-to-constant cc alias (:value pattern-part))
(cc/constrain-column-to-constant cc alias position (:value pattern-part)))
(raise "Unknown pattern part." {:part pattern-part :clause pattern}))))
@ -105,7 +143,7 @@
(apply-pattern-clause-for-alias
;; Record the new table mapping.
(util/conj-in cc [:from] [table alias])
(util/append-in cc [:from] [table alias])
;; Use the new alias for columns.
alias
@ -114,7 +152,7 @@
(defn- plain-symbol->sql-predicate-symbol [fn]
(when-not (instance? PlainSymbol fn)
(raise-str "Predicate functions must be named by plain symbols." fn))
(#{:> :< :=} (keyword (name (:symbol fn)))))
(#{:> :>= :< :<= := :!=} (keyword (name (:symbol fn)))))
(defn apply-predicate-clause [cc predicate]
(when-not (instance? Predicate predicate)
@ -124,7 +162,7 @@
(raise-str "Unknown function " (:fn predicate)))
(let [args (map (partial cc/argument->value cc) (:args predicate))]
(util/conj-in cc [:wheres] (cons f args)))))
(util/append-in cc [:wheres] (cons f args)))))
(defn apply-not-clause [cc not]
(when-not (instance? Not not)
@ -136,9 +174,15 @@
;; fragment, and include the external bindings so that they match up.
;; Otherwise, we need to delay. Right now we're lazy, so we just fail:
;; reorder your query yourself.
(util/conj-in cc [:wheres]
;;
;; Note that we don't extract and reuse any types established inside
;; the `not` clause: perhaps those won't make sense outside. But it's
;; a filter, so we push the external types _in_.
(util/append-in cc
[:wheres]
(not-join->where-fragment
(Not->NotJoinClause (:source cc)
(:known-types cc)
(merge-with concat
(:external-bindings cc)
(:bindings cc))
@ -163,6 +207,7 @@
(if (simple-or? orc)
(cc/merge-ccs cc (simple-or->cc (:source cc)
(:known-types cc)
(merge-with concat
(:external-bindings cc)
(:bindings cc))
@ -200,14 +245,17 @@
[cc patterns]
(reduce apply-clause cc patterns))
(defn patterns->cc [source patterns external-bindings]
(defn patterns->cc [source patterns known-types external-bindings]
(cc/expand-where-from-bindings
(expand-pattern-clauses
(cc/map->ConjoiningClauses
{:source source
:from []
:known-types (or known-types {})
:extracted-types {}
:external-bindings (or external-bindings {})
:bindings {}
:ctes {}
:wheres []})
patterns)))
@ -218,6 +266,8 @@
[cc]
(merge
{:from (:from cc)}
(when-not (empty? (:ctes cc))
{:with (:ctes cc)})
(when-not (empty? (:wheres cc))
{:where (cons :and (:wheres cc))})))
@ -230,13 +280,12 @@
;; that a declared variable list is valid for the clauses given.
(defrecord NotJoinClause [unify-vars cc])
(defn make-not-join-clause [source external-bindings unify-vars patterns]
(->NotJoinClause unify-vars (patterns->cc source patterns external-bindings)))
(defn Not->NotJoinClause [source external-bindings not]
(defn Not->NotJoinClause [source known-types external-bindings not]
(when-not (instance? DefaultSrc (:source not))
(raise "Non-default sources are not supported in `not` clauses." {:clause not}))
(make-not-join-clause source external-bindings (:vars not) (:clauses not)))
(map->NotJoinClause
{:unify-vars (:vars not)
:cc (patterns->cc source (:clauses not) known-types external-bindings)}))
(defn not-join->where-fragment [not-join]
[:not
@ -288,15 +337,17 @@
(defn simple-or->cc
"The returned CC has not yet had bindings expanded."
[source external-bindings orc]
[source known-types external-bindings orc]
(validate-or-clause orc)
;; We 'fork' a CC for each pattern, then union them together.
;; We need to build the first in order that the others use the same
;; column names.
;; column names and known types.
(let [cc (cc/map->ConjoiningClauses
{:source source
:from []
:known-types (or known-types {})
:extracted-types {}
:external-bindings (or external-bindings {})
:bindings {}
:wheres []})
@ -307,6 +358,9 @@
;; That was easy.
primary
;; Note that for a simple `or` clause, the same template is used for each,
;; so we can simply use the `extracted-types` bindings from `primary`.
;; A complex `or` is much harder to handle.
(let [template (assoc primary :wheres [])
alias (second (first (:from template)))
ccs (map (partial apply-pattern-clause-for-alias template alias)
@ -315,7 +369,8 @@
;; Because this is a simple clause, we know that the first pattern established
;; any necessary bindings.
;; Take any new :wheres from each CC and combine them with :or.
(assoc primary :wheres
(assoc primary
:wheres
[(cons :or
(reduce (fn [acc cc]
(let [w (:wheres cc)]

16
src/datomish/query/context.cljc
View file

@ -2,8 +2,18 @@
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;; A context, very simply, holds on to a default source. Eventually
;; it'll also do projection and similar transforms.
;; A context, very simply, holds on to a default source and some knowledge
;; needed for aggregation.
(ns datomish.query.context)
(defrecord Context [default-source elements cc])
(defrecord Context
[
default-source
elements ; The :find list itself.
has-aggregates?
group-by-vars ; A list of variables from :find and :with, used to generate GROUP BY.
cc ; The main conjoining clause.
])
(defn make-context [source]
(->Context source nil false nil nil))

132
src/datomish/query/functions.cljc
View file

@ -6,7 +6,12 @@
(:require
[honeysql.format :as fmt]
[datomish.query.cc :as cc]
[datomish.query.source :as source]
[datomish.schema :as schema]
[datomish.sqlite-schema :refer [->tag ->SQLite]]
[datomish.query.source
:as source
:refer [attribute-in-source
constant-in-source]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datascript.parser :as dp
#?@(:cljs
@ -66,10 +71,8 @@
(when-not (and (instance? SrcVar src)
(= "$" (name (:symbol src))))
(raise "Non-default sources not supported." {:arg src}))
(when-not (instance? Constant attr)
(raise "Non-constant fulltext attributes not supported." {:arg attr}))
(when-not (fulltext-attribute? (:source cc) (:value attr))
(when (and (instance? Constant attr)
(not (fulltext-attribute? (:source cc) (:value attr))))
(raise-str "Attribute " (:value attr) " is not a fulltext-indexed attribute."))
(when-not (and (instance? BindColl bind-coll)
@ -89,6 +92,18 @@
;; We do not currently support scoring; the score value will always be 0.
(let [[src attr search] (:args function)
;; Note that DataScript's parser won't allow us to write a term like
;;
;; [(fulltext $ _ "foo") [[?x]]]
;;
;; so we instead have a placeholder attribute. Sigh.
attr-constant (or
(and (instance? Constant attr)
(not (= :any (:value attr)))
(source/attribute-in-source (:source cc) (:value attr)))
(and (instance? Variable attr)
(cc/binding-for-symbol-or-throw cc (:symbol attr))))
;; Pull out the symbols for the binding array.
[entity value tx score]
(map (comp :symbol :variable) ; This will nil-out placeholders.
@ -97,7 +112,7 @@
;; Find the FTS table name and alias. We might have multiple fulltext
;; expressions so we will generate a query like
;; SELECT ttt.a FROM t1 AS ttt WHERE ttt.t1 MATCH 'string'
[fulltext-table fulltext-alias] (source/source->fulltext-from (:source cc)) ; [:t1 :ttt]
[fulltext-table fulltext-alias] (source/source->fulltext-values (:source cc)) ; [:t1 :ttt]
match-column (sql/qualify fulltext-alias fulltext-table) ; :ttt.t1
match-value (cc/argument->value cc search)
@ -107,22 +122,27 @@
from [[fulltext-table fulltext-alias]
[datom-table datom-alias]]
wheres [[:match match-column match-value] ; The FTS match.
extracted-types {} ; TODO
wheres (concat
[[:match match-column match-value] ; The FTS match.
;; The fulltext rowid-to-datom correspondence.
[:=
(sql/qualify datom-alias :v)
(sql/qualify fulltext-alias :rowid)]
(sql/qualify fulltext-alias :rowid)]]
;; The attribute itself must match.
[:=
(when attr-constant
;; If known, the attribute itself must match.
[[:=
(sql/qualify datom-alias :a)
(source/attribute-in-source (:source cc) (:value attr))]]
attr-constant]]))
;; Now compose any bindings for entity, value, tx, and score.
;; TODO: do we need to examine existing bindings to capture
;; wheres for any of these? We shouldn't, because the CC will
;; be internally cross-where'd when everything is done...
;; TODO: bind attribute?
bindings (into {}
(filter
(comp not nil? first)
@ -134,11 +154,97 @@
;; if this is a variable rather than a placeholder.
[score [0]]]))]
(cc/augment-cc cc from bindings wheres)))
(cc/augment-cc cc from bindings extracted-types wheres)))
;; get-else is how Datalog handles optional attributes.
;;
;; It consists of:
;; * A bound entity
;; * A cardinality-one attribute
;; * A var to bind the value
;; * A default value.
;;
;; We model this as:
;; * A check against known bindings for the entity.
;; * A check against the schema for cardinality-one.
;; * Generating a COALESCE expression with a query inside the projection itself.
;;
;; Note that this will be messy for queries like:
;;
;; [:find ?page ?title :in $
;; :where [?page :page/url _]
;; [(get-else ?page :page/title "<empty>") ?title]
;; [_ :foo/quoted ?title]]
;;
;; or
;; [(some-function ?title)]
;;
;; -- we aren't really establishing a binding, so the subquery will be
;; repeated. But this will do for now.
(defn apply-get-else-clause [cc function]
(let [{:keys [source bindings external-bindings]} cc
schema (:schema source)
{:keys [args binding]} function
[src e a default-val] args]
(when-not (instance? BindScalar binding)
(raise-str "Expected scalar binding."))
(when-not (instance? Variable (:variable binding))
(raise-str "Expected variable binding."))
(when-not (instance? Constant a)
(raise-str "Expected constant attribute."))
(when-not (instance? Constant default-val)
(raise-str "Expected constant default value."))
(when-not (and (instance? SrcVar src)
(= "$" (name (:symbol src))))
(raise "Non-default sources not supported." {:arg src}))
(let [a (attribute-in-source source (:value a))
a-type (get-in (:schema schema) [a :db/valueType])
a-tag (->tag a-type)
default-val (:value default-val)
var (:variable binding)]
;; Schema check.
(when-not (and (integer? a)
(not (datomish.schema/multival? schema a)))
(raise-str "Attribute " a " is not cardinality-one."))
;; TODO: type-check the default value.
(condp instance? e
Variable
(let [e (:symbol e)
e-binding (cc/binding-for-symbol-or-throw cc e)]
(let [[table _] (source/source->from source a) ; We don't need to alias: single pattern.
;; These :limit values shouldn't be needed, but sqlite will
;; appreciate them.
;; Note that we don't extract type tags here: the attribute
;; must be known!
subquery {:select
[(sql/call
:coalesce
{:select [:v]
:from [table]
:where [:and
[:= 'a a]
[:= 'e e-binding]]
:limit 1}
(->SQLite default-val))]
:limit 1}]
(->
(assoc-in cc [:known-types (:symbol var)] a-type)
(util/append-in [:bindings (:symbol var)] subquery))))
(raise-str "Can't handle entity" e)))))
(def sql-functions
;; Future: versions of this that uses snippet() or matchinfo().
{"fulltext" apply-fulltext-clause})
{"fulltext" apply-fulltext-clause
"get-else" apply-get-else-clause})
(defn apply-sql-function
"Either returns an application of `function` to `cc`, or nil to

248
src/datomish/query/projection.cljc
View file

@ -4,18 +4,114 @@
(ns datomish.query.projection
(:require
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise-str cond-let]]
[honeysql.core :as sql]
[datomish.query.source :as source]
[datomish.sqlite-schema :as ss]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datascript.parser :as dp
#?@(:cljs [:refer [Pattern DefaultSrc Variable Constant Placeholder]])]
#?@(:cljs [:refer [Aggregate Pattern DefaultSrc Variable Constant Placeholder PlainSymbol]])]
)
#?(:clj (:import [datascript.parser Pattern DefaultSrc Variable Constant Placeholder]))
#?(:clj (:import [datascript.parser Aggregate Pattern DefaultSrc Variable Constant Placeholder PlainSymbol]))
)
(defn lookup-variable [cc variable]
(or (-> cc :bindings variable first)
(raise-str "Couldn't find variable " variable)))
(defn sql-projection
(def aggregate-functions
{:avg :avg
:count :count
:max :max
:min :min
:sum :total
})
(defn- aggregate-symbols->projected-var [fn-symbol var-symbol]
(keyword (str "_" (name fn-symbol) "_" (subs (name var-symbol) 1))))
(defn- aggregate->projected-var [elem]
(aggregate-symbols->projected-var (:symbol (:fn elem))
(:symbol (first (:args elem)))))
(defn simple-aggregate?
"If `elem` is a simple aggregate -- symbolic function, one var arg --
return the variable symbol."
[elem]
(when (instance? Aggregate elem)
(let [{:keys [fn args]} elem]
(when (and (instance? PlainSymbol fn)
(= 1 (count args)))
(let [arg (first args)]
(when (instance? Variable arg)
(:symbol arg)))))))
(defn- aggregate->var [elem]
(when (instance? Aggregate elem)
(when-not (simple-aggregate? elem)
(raise-str "Only know how to handle simple aggregates."))
(:symbol (first (:args elem)))))
(defn- variable->var [elem]
(when (instance? Variable elem)
(:symbol elem)))
(defn- aggregate->projection [elem context lookup-fn]
(when (instance? Aggregate elem)
(when-not (simple-aggregate? elem)
(raise-str "Only know how to handle simple aggregates."))
(let [var-symbol (:symbol (first (:args elem)))
fn-symbol (:symbol (:fn elem))
lookup-var (lookup-fn var-symbol)
aggregate-fn (get aggregate-functions (keyword fn-symbol))]
(when-not aggregate-fn
(raise-str "Unknown aggregate function " fn-symbol))
(let [funcall-var (util/aggregate->sql-var aggregate-fn lookup-var)
project-as (aggregate-symbols->projected-var fn-symbol var-symbol)]
[[funcall-var project-as]]))))
(defn- type-projection
"Produce a projection pair by looking up `var` in the provided
`extracted-types`."
[extracted-types var]
(when-let [t (get extracted-types var)]
[t (util/var->sql-type-var var)]))
(defn- aggregate-type-projection
"Produce a passthrough projection pair for a type field
in an inner query."
[inner var]
(let [type-var (util/var->sql-type-var var)]
[(sql/qualify inner type-var) type-var]))
(defn- symbol->projection
"Given a variable symbol, produce a projection pair.
`lookup-fn` will be used to find a column. For a non-aggregate query,
this will typically be a lookup into the CC's bindings. For an
aggregate query it'll be a qualification of the same var into the
subquery.
`known-types` is a type map to decide whether to project a type tag.
`type-projection-fn` is like `lookup-fn` but for type tag columns."
[var lookup-fn known-types type-projection-fn]
(let [lookup-var (lookup-fn var)
projected-var (util/var->sql-var var)
var-projection [lookup-var projected-var]]
;; If the type of a variable isn't explicitly known, we also select
;; its type column so we can transform it.
(if-let [type-proj (when (not (contains? known-types var))
(type-projection-fn var))]
[var-projection type-proj]
[var-projection])))
(defn- variable->projection [elem lookup-fn known-types type-projection-fn]
(when (instance? Variable elem)
(symbol->projection (:symbol elem) lookup-fn known-types type-projection-fn)))
(defn sql-projection-for-relation
"Take a `find` clause's `:elements` list and turn it into a SQL
projection clause, suitable for passing as a `:select` clause to
honeysql.
@ -32,23 +128,145 @@
[[:datoms12.e :foo] [:datoms13.e :bar]]
Note that we also look at `:group-by-vars`, because we need to
alias columns and apply `DISTINCT` to those columns in order to
aggregate correctly.
This function unpacks aggregate operations, instead selecting the var.
@param context A Context, containing elements.
@return a sequence of pairs."
[context]
(def foo context)
(let [elements (:elements context)]
(when-not (every? #(instance? Variable %1) elements)
(raise-str "Unable to :find non-variables."))
(let [{:keys [group-by-vars elements cc]} context
{:keys [known-types extracted-types]} cc]
;; The primary projections from the :find list.
;; Note that deduplication will be necessary, because we unpack aggregates.
(let [projected-vars
(map (fn [elem]
(let [var (:symbol elem)]
[(lookup-variable (:cc context) var) (util/var->sql-var var)]))
(or (aggregate->var elem)
(variable->var elem)
(raise "Only able to :find variables or aggregates."
{:elem elem})))
elements)
;; If we have any GROUP BY requirements from :with, that aren't already
;; included in the above, project them now.
additional-vars
(clojure.set/difference
(set group-by-vars)
(set projected-vars))
full-var-list
(distinct (concat projected-vars additional-vars))
type-proj-fn
(partial type-projection extracted-types)
lookup-fn
(partial lookup-variable cc)]
(mapcat (fn [var]
(symbol->projection var lookup-fn known-types type-proj-fn))
full-var-list))))
(defn sql-projection-for-aggregation
"Project an element list that contains aggregates. This expects a subquery
aliased to `inner-table` which itself will project each var with the
correct name."
[context inner-table]
(let [{:keys [group-by-vars elements cc]} context
{:keys [known-types extracted-types]} cc
lookup-fn (fn [var]
(sql/qualify inner-table (util/var->sql-var var)))
type-proj-fn (partial aggregate-type-projection inner-table)]
(mapcat (fn [elem]
(or (variable->projection elem lookup-fn known-types type-proj-fn)
(aggregate->projection elem context lookup-fn)
(raise "Only able to :find variables or aggregates."
{:elem elem})))
elements)))
(defn make-projectors-for-columns [elements known-types extracted-types]
{:pre [(map? extracted-types)
(map? known-types)]}
(letfn [(variable->projector [elem known-types extracted-types tag-decoder]
(when (instance? Variable elem)
(let [var (:symbol elem)
projected-var (util/var->sql-var var)]
(if-let [type (get known-types var)]
;; We know the type! We already know how to decode it.
;; TODO: most of these tags don't actually require calling through to <-tagged-SQLite.
;; TODO: optimize this without making it horrible.
(let [decoder (tag-decoder (ss/->tag type))]
(fn [row]
(decoder (get row projected-var))))
;; We don't know the type. Find the type projection column
;; and use it to decode the value.
(if (contains? extracted-types var)
(let [type-column (util/var->sql-type-var var)]
(fn [row]
(ss/<-tagged-SQLite
(get row type-column)
(get row projected-var))))
;; We didn't extract a type and we don't know it in advance.
;; Just pass through; the :col will look itself up in the row.
projected-var)))))
;; For now we assume numerics and that everything will shake out in the wash.
(aggregate->projector [elem]
(when (instance? Aggregate elem)
(let [var (aggregate->projected-var elem)]
(fn [row]
(get row var)))))]
(let [tag-decoder (memoize
(fn [tag]
(partial ss/<-tagged-SQLite tag)))]
(map (fn [elem]
(or (variable->projector elem known-types extracted-types tag-decoder)
(aggregate->projector elem)))
elements))))
(defn row-pair-transducer [context]
;; For now, we only support straight var lists, so
;; our transducer is trivial.
(let [columns-in-order (map second (sql-projection context))]
(map (fn [[row err]]
(let [{:keys [elements cc]} context
{:keys [source known-types extracted-types]} cc
;; We know the projection will fail above if these aren't simple variables or aggregates.
projectors
(make-projectors-for-columns elements known-types extracted-types)]
(map
(fn [[row err]]
(if err
[row err]
[(map row columns-in-order) nil])))))
[(map (fn [projector] (projector row)) projectors) nil])))))
(defn extract-group-by-vars
"Take inputs to :find and, if any aggregates exist in `elements`,
return the variable names upon which we should GROUP BY."
[elements with]
(when (some #(instance? Aggregate %1) elements)
(loop [ignore #{}
group-by (map :symbol with)
e elements]
(if-let [element (first e)]
(if-let [aggregated-var (simple-aggregate? element)]
(recur (conj ignore aggregated-var)
group-by
(rest e))
(if (instance? Variable element)
(let [var (:symbol element)]
(recur ignore
(if (contains? ignore var)
group-by
(conj group-by var))
(rest e)))
(raise-str "Unknown element." {:element element})))
;; Done. Remove any later vars we saw.
(remove ignore group-by)))))

70
src/datomish/query/source.cljc
View file

@ -5,13 +5,15 @@
(ns datomish.query.source
(:require
[datomish.query.transforms :as transforms]
[datomish.schema :as schema]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str]]
[datascript.parser
#?@(:cljs
[:refer [Variable Constant Placeholder]])])
#?(:clj
(:import [datascript.parser Variable Constant Placeholder])))
(defn- gensym-table-alias [table]
(defn gensym-table-alias [table]
(gensym (name table)))
;;;
@ -38,16 +40,21 @@
(source->non-fulltext-from [source])
(source->fulltext-from [source]
"Returns a pair, `[table alias]` for querying the source's fulltext index.")
(source->fulltext-values [source]
"Returns a pair, `[table alias]` for querying the source's fulltext values")
(source->constraints [source alias])
(pattern->schema-value-type [source pattern])
(attribute-in-source [source attribute])
(constant-in-source [source constant]))
(defrecord
DatomsSource
[table ; Typically :datoms.
fulltext-table ; Typically :fulltext_values
fulltext-table ; Typically :fulltext_datoms
fulltext-view ; Typically :all_datoms
fulltext-values ; Typically :fulltext_values
columns ; e.g., [:e :a :v :tx]
schema ; An ISchema instance.
;; `attribute-transform` is a function from attribute to constant value. Used to
;; turn, e.g., :p/attribute into an interned integer.
@ -65,15 +72,31 @@
Source
(source->from [source attribute]
(let [table
(if (and (instance? Constant attribute)
;; TODO: look in the DB schema to see if `attribute` is known to not be
;; a fulltext attribute.
true)
(:table source)
(let [schema (:schema source)
int->table (fn [a]
(if (schema/fulltext? schema a)
(:fulltext-table source)
(:table source)))
table
(cond
(integer? attribute)
(int->table attribute)
(instance? Constant attribute)
(let [a (:value attribute)
id (if (keyword? a)
(attribute-in-source source a)
a)]
(int->table id))
;; TODO: perhaps we know an external binding already?
(or (instance? Variable attribute)
(instance? Placeholder attribute))
;; It's variable. We must act as if it could be a fulltext datom.
(:fulltext-view source))]
(:fulltext-view source)
true
(raise "Unknown source->from attribute " attribute {:attribute attribute}))]
[table ((:table-alias source) table)]))
(source->non-fulltext-from [source]
@ -84,24 +107,29 @@
(let [table (:fulltext-table source)]
[table ((:table-alias source) table)]))
(source->fulltext-values [source]
(let [table (:fulltext-values source)]
[table ((:table-alias source) table)]))
(source->constraints [source alias]
(when-let [f (:make-constraints source)]
(f alias)))
(pattern->schema-value-type [source pattern]
(let [[_ a v _] pattern
schema (:schema (:schema source))]
(when (instance? Constant a)
(let [val (:value a)]
(if (keyword? val)
;; We need to find the entid for the keyword attribute,
;; because the schema stores attributes by ID.
(let [id (attribute-in-source source val)]
(get-in schema [id :db/valueType]))
(when (integer? val)
(get-in schema [val :db/valueType])))))))
(attribute-in-source [source attribute]
((:attribute-transform source) attribute))
(constant-in-source [source constant]
((:constant-transform source) constant)))
(defn datoms-source [db]
(map->DatomsSource
{:table :datoms
:fulltext-table :fulltext_values
:fulltext-view :all_datoms
:columns [:e :a :v :tx :added]
:attribute-transform transforms/attribute-transform-string
:constant-transform transforms/constant-transform-default
:table-alias gensym-table-alias
:make-constraints nil}))

54
src/datomish/schema.cljc
View file

@ -5,7 +5,12 @@
;; Purloined from DataScript.
(ns datomish.schema
(:require [datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise]]))
(:require
[datomish.sqlite-schema :as sqlite-schema]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise]]))
(defn entid? [x]
(and (integer? x) (pos? x)))
(defprotocol ISchema
(attrs-by
@ -94,19 +99,41 @@
:key k
:value v}))))
;; TODO: consider doing this with a protocol and extending the underlying Clojure(Script) types.
#?(:clj
(defn uuidish? [x]
(instance? java.util.UUID x)))
#?(:cljs
(let [uuid-re (js/RegExp. "[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}" "i")]
(defn uuidish? [x]
(and (string? x)
(re-find uuid-re x)))))
(def value-type-map
{:db.type/ref { :valid? #(and (integer? %) (pos? %)) :->SQLite identity :<-SQLite identity }
:db.type/keyword { :valid? keyword? :->SQLite str :<-SQLite #(keyword (subs % 1)) }
:db.type/string { :valid? string? :->SQLite identity :<-SQLite identity }
:db.type/boolean { :valid? #?(:clj #(instance? Boolean %) :cljs #(= js/Boolean (type %))) :->SQLite #(if % 1 0) :<-SQLite #(not= % 0) }
:db.type/integer { :valid? integer? :->SQLite identity :<-SQLite identity }
:db.type/real { :valid? #?(:clj float? :cljs number?) :->SQLite identity :<-SQLite identity }
{:db.type/ref { :valid? entid? }
:db.type/keyword { :valid? keyword? }
:db.type/string { :valid? string? }
:db.type/boolean { :valid? #?(:clj #(instance? Boolean %) :cljs #(= js/Boolean (type %))) }
:db.type/long { :valid? integer? }
:db.type/uuid { :valid? uuidish? }
:db.type/instant { :valid? #?(:clj #(instance? java.util.Date %) :cljs #(= js/Date (type %))) }
:db.type/uri { :valid? #?(:clj #(instance? java.net.URI %) :cljs string?) }
:db.type/double { :valid? #?(:clj float? :cljs number?) }
})
(defn #?@(:clj [^Boolean ensure-value-matches-type]
:cljs [^boolean ensure-value-matches-type]) [type value]
(if-let [valid? (get-in value-type-map [type :valid?])]
(when-not (valid? value)
(raise "Invalid value for type " type "; got " value
{:error :schema/valueType, :type type, :value value}))
(raise "Unknown valueType " type ", expected one of " (sorted-set (keys value-type-map))
{:error :schema/valueType, :type type})))
;; There's some duplication here so we get better error messages.
(defn #?@(:clj [^Boolean ensure-valid-value]
:cljs [^boolean ensure-valid-value]) [schema attr value]
{:pre [(schema? schema)]}
{:pre [(schema? schema)
(integer? attr)]}
(let [schema (.-schema schema)]
(if-let [valueType (get-in schema [attr :db/valueType])]
(if-let [valid? (get-in value-type-map [valueType :valid?])]
@ -119,12 +146,13 @@
{:error :schema/valueType, :attribute attr}))))
(defn ->SQLite [schema attr value]
{:pre [(schema? schema)]}
{:pre [(schema? schema)
(integer? attr)]}
(let [schema (.-schema schema)]
(if-let [valueType (get-in schema [attr :db/valueType])]
(if-let [valid? (get-in value-type-map [valueType :valid?])]
(if (valid? value)
((get-in value-type-map [valueType :->SQLite]) value)
[(sqlite-schema/->SQLite value) (sqlite-schema/->tag valueType)]
(raise "Invalid value for attribute " attr ", expected " valueType " but got " value
{:error :schema/valueType, :attribute attr, :value value}))
(raise "Unknown valueType for attribute " attr ", expected one of " (sorted-set (keys value-type-map))
@ -136,8 +164,8 @@
{:pre [(schema? schema)]}
(let [schema (.-schema schema)]
(if-let [valueType (get-in schema [attr :db/valueType])]
(if-let [<-SQLite (get-in value-type-map [valueType :<-SQLite])]
(<-SQLite value)
(if (contains? value-type-map valueType)
(sqlite-schema/<-SQLite valueType value)
(raise "Unknown valueType for attribute " attr ", expected one of " (sorted-set (keys value-type-map))
{:error :schema/valueType, :attribute attr}))
(raise "Unknown attribute " attr ", expected one of " (sorted-set (keys schema))

59
src/datomish/schema.edn Normal file
View file

@ -0,0 +1,59 @@
[
;; news
{:db/id #db/id[:db.part/db]
:db/ident :news/title
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/fulltext true
:db/doc "A news story's title"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/foobar
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/unique :db.unique/identity
:db/fulltext true
:db/doc "A news story's foobar"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/zot
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/unique :db.unique/identity
:db/fulltext true
:db/doc "A news story's zot"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/baz
:db/valueType :db.type/ref
:db/cardinality :db.cardinality/one
:db/doc "A news story's baz"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/url
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/doc "A news story's url"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/summary
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/doc "Automatically generated summary of a news story"
:db.install/_attribute :db.part/db}
{:db/id #db/id[:db.part/db]
:db/ident :news/category
:db/valueType :db.type/string
:db/cardinality :db.cardinality/many
:db/fulltext true
:db/doc "Categories automatically set for a news story"
:db.install/_attribute :db.part/db}
]

3
src/datomish/schema_changes.cljc
View file

@ -6,9 +6,6 @@
(:require
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]))
(defn- is-install? [db [_ a & _]]
(= a (get-in db [:idents :db.install/attribute])))
(defn datoms->schema-fragment
"Turn [[:db.part/db :db.install/attribute e] [e :db/ident :attr]] into {:attr {:db/* v}}.

4
src/datomish/sqlite.cljc
View file

@ -24,7 +24,7 @@
(def sql-quoting-style :ansi)
(defn format [args]
(honeysql.core/format args :quoting :ansi))
(honeysql.core/format args :quoting sql-quoting-style))
(defprotocol ISQLiteConnection
(-execute!
@ -76,7 +76,7 @@
;; channel being rejected and no further row callbacks
;; being called.
(when (second result)
(put! result c))
(put! c result))
(close! c))))
(defn all-rows

204
src/datomish/sqlite_schema.cljc
View file

@ -8,7 +8,7 @@
[datomish.pair-chan :refer [go-pair <?]]
[cljs.core.async.macros :refer [go]]))
(:require
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise-str cond-let]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.sqlite :as s]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :refer [go <! >!]]])
@ -19,34 +19,51 @@
(def v1-statements
["CREATE TABLE datoms (e INTEGER NOT NULL, a SMALLINT NOT NULL, v BLOB NOT NULL, tx INTEGER NOT NULL,
value_type_tag SMALLINT NOT NULL,
index_avet TINYINT NOT NULL DEFAULT 0, index_vaet TINYINT NOT NULL DEFAULT 0,
index_fulltext TINYINT NOT NULL DEFAULT 0,
unique_value TINYINT NOT NULL DEFAULT 0, unique_identity TINYINT NOT NULL DEFAULT 0)"
"CREATE INDEX idx_datoms_eavt ON datoms (e, a, v)"
"CREATE INDEX idx_datoms_aevt ON datoms (a, e, v)"
unique_value TINYINT NOT NULL DEFAULT 0)"
"CREATE UNIQUE INDEX idx_datoms_eavt ON datoms (e, a, value_type_tag, v)"
"CREATE UNIQUE INDEX idx_datoms_aevt ON datoms (a, e, value_type_tag, v)"
;; n.b., v0/value_type_tag0 can be NULL, in which case we look up v from datoms;
;; and the datom columns are NULL into the LEFT JOIN fills them in.
;; TODO: update comment about sv.
"CREATE TABLE tx_lookup (e0 INTEGER NOT NULL, a0 SMALLINT NOT NULL, v0 BLOB NOT NULL, tx0 INTEGER NOT NULL, added0 TINYINT NOT NULL,
value_type_tag0 SMALLINT NOT NULL,
index_avet0 TINYINT, index_vaet0 TINYINT,
index_fulltext0 TINYINT,
unique_value0 TINYINT,
sv BLOB,
svalue_type_tag SMALLINT,
rid INTEGER,
e INTEGER, a SMALLINT, v BLOB, tx INTEGER, value_type_tag SMALLINT)"
;; Note that `id_tx_lookup_added` is created and dropped
;; after insertion, which makes insertion slightly faster.
;; Prevent overlapping transactions. TODO: drop added0?
"CREATE UNIQUE INDEX idx_tx_lookup_eavt ON tx_lookup (e0, a0, v0, added0, value_type_tag0) WHERE sv IS NOT NULL"
;; Opt-in index: only if a has :db/index true.
"CREATE UNIQUE INDEX idx_datoms_avet ON datoms (a, v, e) WHERE index_avet IS NOT 0"
"CREATE UNIQUE INDEX idx_datoms_avet ON datoms (a, value_type_tag, v, e) WHERE index_avet IS NOT 0"
;; Opt-in index: only if a has :db/valueType :db.type/ref.
;; Opt-in index: only if a has :db/valueType :db.type/ref. No need for tag here since all
;; indexed elements are refs.
"CREATE UNIQUE INDEX idx_datoms_vaet ON datoms (v, a, e) WHERE index_vaet IS NOT 0"
;; Opt-in index: only if a has :db/fulltext true; thus, it has :db/valueType :db.type/string,
;; which is not :db/valueType :db.type/ref. That is, index_vaet and index_fulltext are mutually
;; exclusive.
"CREATE INDEX idx_datoms_fulltext ON datoms (v, a, e) WHERE index_fulltext IS NOT 0"
"CREATE INDEX idx_datoms_fulltext ON datoms (value_type_tag, v, a, e) WHERE index_fulltext IS NOT 0"
;; TODO: possibly remove this index. :db.unique/value should be asserted by the transactor in
;; all cases, but the index may speed up some of SQLite's query planning. For now, it services
;; to validate the transactor implementation.
"CREATE UNIQUE INDEX idx_datoms_unique_value ON datoms (v) WHERE unique_value IS NOT 0"
;; TODO: possibly remove this index. :db.unique/identity should be asserted by the transactor in
;; all cases, but the index may speed up some of SQLite's query planning. For now, it serves to
;; validate the transactor implementation.
"CREATE UNIQUE INDEX idx_datoms_unique_identity ON datoms (a, v) WHERE unique_identity IS NOT 0"
;; TODO: possibly remove this index. :db.unique/{value,identity} should be asserted by the
;; transactor in all cases, but the index may speed up some of SQLite's query planning. For now,
;; it serves to validate the transactor implementation. Note that tag is needed here to
;; differentiate, e.g., keywords and strings.
"CREATE UNIQUE INDEX idx_datoms_unique_value ON datoms (a, value_type_tag, v) WHERE unique_value IS NOT 0"
"CREATE TABLE transactions (e INTEGER NOT NULL, a SMALLINT NOT NULL, v BLOB NOT NULL, tx INTEGER NOT NULL, added TINYINT NOT NULL DEFAULT 1)"
"CREATE INDEX idx_transactions_tx ON transactions (tx)"
"CREATE TABLE transactions (e INTEGER NOT NULL, a SMALLINT NOT NULL, v BLOB NOT NULL, tx INTEGER NOT NULL, added TINYINT NOT NULL DEFAULT 1, value_type_tag SMALLINT NOT NULL)"
"CREATE INDEX idx_transactions_tx ON transactions (tx, added)"
;; Fulltext indexing.
;; A fulltext indexed value v is an integer rowid referencing fulltext_values.
@ -57,27 +74,45 @@
;; By default we use Unicode-aware tokenizing (particularly for case folding), but preserve
;; diacritics.
"CREATE VIRTUAL TABLE fulltext_values
USING FTS4 (text NOT NULL, tokenize=unicode61 \"remove_diacritics=0\")"
USING FTS4 (text NOT NULL, searchid INT, tokenize=unicode61 \"remove_diacritics=0\")"
;; This combination of view and triggers allows you to transparently
;; update-or-insert into FTS. Just INSERT INTO fulltext_values_view (text, searchid).
"CREATE VIEW fulltext_values_view AS SELECT * FROM fulltext_values"
"CREATE TRIGGER replace_fulltext_searchid
INSTEAD OF INSERT ON fulltext_values_view
WHEN EXISTS (SELECT 1 FROM fulltext_values WHERE text = new.text)
BEGIN
UPDATE fulltext_values SET searchid = new.searchid WHERE text = new.text;
END"
"CREATE TRIGGER insert_fulltext_searchid
INSTEAD OF INSERT ON fulltext_values_view
WHEN NOT EXISTS (SELECT 1 FROM fulltext_values WHERE text = new.text)
BEGIN
INSERT INTO fulltext_values (text, searchid) VALUES (new.text, new.searchid);
END"
;; A view transparently interpolating fulltext indexed values into the datom structure.
"CREATE VIEW fulltext_datoms AS
SELECT e, a, fulltext_values.text AS v, tx, index_avet, index_vaet, index_fulltext, unique_value, unique_identity
SELECT e, a, fulltext_values.text AS v, tx, value_type_tag, index_avet, index_vaet, index_fulltext, unique_value
FROM datoms, fulltext_values
WHERE datoms.index_fulltext IS NOT 0 AND datoms.v = fulltext_values.rowid"
;; A view transparently interpolating all entities (fulltext and non-fulltext) into the datom structure.
"CREATE VIEW all_datoms AS
SELECT e, a, v, tx, index_avet, index_vaet, index_fulltext, unique_value, unique_identity
SELECT e, a, v, tx, value_type_tag, index_avet, index_vaet, index_fulltext, unique_value
FROM datoms
WHERE index_fulltext IS 0
UNION ALL
SELECT e, a, v, tx, index_avet, index_vaet, index_fulltext, unique_value, unique_identity
SELECT e, a, v, tx, value_type_tag, index_avet, index_vaet, index_fulltext, unique_value
FROM fulltext_datoms"
;; Materialized views of the schema.
"CREATE TABLE idents (ident TEXT NOT NULL PRIMARY KEY, entid INTEGER UNIQUE NOT NULL)"
;; TODO: allow arbitrary schema values (true/false) and tag the resulting values.
"CREATE TABLE schema (ident TEXT NOT NULL, attr TEXT NOT NULL, value TEXT NOT NULL, FOREIGN KEY (ident) REFERENCES idents (ident))"
"CREATE INDEX idx_schema_unique ON schema (ident, attr, value)"
"CREATE TABLE parts (part INTEGER NOT NULL PRIMARY KEY, start INTEGER NOT NULL, idx INTEGER NOT NULL)"
])
(defn <create-current-version
@ -115,3 +150,130 @@
(< v current-version)
(<? (<update-from-version db v))))))
;; This is close to the SQLite schema since it may impact the value tag bit.
(defprotocol IEncodeSQLite
(->SQLite [x] "Transforms Clojure{Script} values to SQLite."))
(extend-protocol IEncodeSQLite
#?@(:clj
[String
(->SQLite [x] x)
clojure.lang.Keyword
(->SQLite [x] (str x))
Boolean
(->SQLite [x] (if x 1 0))
Integer
(->SQLite [x] x)
Long
(->SQLite [x] x)
java.util.Date
(->SQLite [x] (.getTime x))
java.util.UUID
(->SQLite [x] (.toString x)) ; TODO: BLOB storage. Issue #44.
Float
(->SQLite [x] x)
Double
(->SQLite [x] x)]
:cljs
[string
(->SQLite [x] x)
Keyword
(->SQLite [x] (str x))
boolean
(->SQLite [x] (if x 1 0))
js/Date
(->SQLite [x] (.getTime x))
number
(->SQLite [x] x)]))
;; Datomish rows are tagged with a numeric representation of :db/valueType:
;; The tag is used to limit queries, and therefore is placed carefully in the relevant indices to
;; allow searching numeric longs and doubles quickly. The tag is also used to convert SQLite values
;; to the correct Datomish value type on query egress.
(def value-type-tag-map
{:db.type/ref 0
:db.type/boolean 1
:db.type/instant 4
:db.type/long 5 ;; SQLite distinguishes integral from decimal types, allowing long and double to share a tag.
:db.type/double 5 ;; SQLite distinguishes integral from decimal types, allowing long and double to share a tag.
:db.type/string 10
:db.type/uuid 11
:db.type/uri 12
:db.type/keyword 13})
(defn ->tag [valueType]
(or
(valueType value-type-tag-map)
(raise "Unknown valueType " valueType ", expected one of " (sorted-set (keys value-type-tag-map))
{:error :SQLite/tag, :valueType valueType})))
#?(:clj
(defn <-tagged-SQLite
"Transforms SQLite values to Clojure with tag awareness."
[tag value]
(case tag
;; In approximate commonality order.
0 value ; ref.
1 (= value 1) ; boolean
4 (java.util.Date. value) ; instant
13 (keyword (subs value 1)) ; keyword
12 (java.net.URI. value) ; URI
11 (java.util.UUID/fromString value) ; UUID
; 5 value ; numeric
; 10 value ; string
value
)))
#?(:cljs
(defn <-tagged-SQLite
"Transforms SQLite values to ClojureScript with tag awareness."
[tag value]
;; In approximate commonality order.
(case tag
0 value ; ref.
1 (= value 1) ; boolean
4 (js/Date. value) ; instant
13 (keyword (subs value 1)) ; keyword
; 12 value ; URI
; 11 value ; UUID
; 5 value ; numeric
; 10 value ; string
value
)))
(defn tagged-SQLite-to-JS
"Transforms SQLite values to JavaScript-compatible values."
[tag value]
(case tag
1 (= value 1) ; boolean.
; 0 value ; No point trying to ident.
; 4 value ; JS doesn't have a Date representation.
; 13 value ; Return the keyword string from the DB: ":foobar".
value))
(defn <-SQLite
"Transforms SQLite values to Clojure{Script}."
[valueType value]
(case valueType
:db.type/ref value
:db.type/keyword (keyword (subs value 1))
:db.type/string value
:db.type/boolean (not= value 0)
:db.type/long value
:db.type/instant (<-tagged-SQLite 4 value)
:db.type/uuid (<-tagged-SQLite 11 value)
:db.type/double value))

21
src/datomish/test_macros.cljc
View file

@ -4,7 +4,9 @@
(ns datomish.test-macros
#?(:cljs
(:require-macros [datomish.test-macros]))
(:require-macros
[datomish.test-macros]
[datomish.node-tempfile-macros]))
(:require
[datomish.pair-chan]))
@ -38,3 +40,20 @@
(let [[v# e#] (clojure.core.async/<!! (datomish.pair-chan/go-pair ~@body))]
(when e# (throw e#)) ;; Assert nil just to be safe, even though we should always throw first.
(clojure.test/is (= e# nil))))))
(defmacro deftest-db
[n conn-var & body]
`(deftest-async ~n
(if-cljs
(datomish.node-tempfile-macros/with-tempfile [t# (datomish.node-tempfile/tempfile)]
(let [~conn-var (datomish.pair-chan/<? (datomish.api/<connect t#))]
(try
~@body
(finally
(datomish.pair-chan/<? (datomish.api/<close ~conn-var))))))
(tempfile.core/with-tempfile [t# (tempfile.core/tempfile)]
(let [~conn-var (datomish.pair-chan/<? (datomish.api/<connect t#))]
(try
~@body
(finally
(datomish.pair-chan/<? (datomish.api/<close ~conn-var)))))))))

242
src/datomish/transact.cljc
View file

@ -13,6 +13,7 @@
[datomish.query.source :as source]
[datomish.query :as query]
[datomish.db :as db :refer [id-literal id-literal?]]
[datomish.db.debug :as debug]
[datomish.datom :as dd :refer [datom datom? #?@(:cljs [Datom])]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise raise-str cond-let]]
[datomish.schema :as ds]
@ -21,6 +22,8 @@
[datomish.sqlite-schema :as sqlite-schema]
[datomish.transact.bootstrap :as bootstrap]
[datomish.transact.explode :as explode]
[taoensso.tufte :as tufte
#?(:cljs :refer-macros :clj :refer) [defnp p profiled profile]]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
[clojure.core.async :as a :refer [chan go <! >!]]])
#?@(:cljs [[datomish.pair-chan]
@ -56,7 +59,8 @@
(defrecord TxReport [db-before ;; The DB before the transaction.
db-after ;; The DB after the transaction.
current-tx ;; The tx ID represented by the transaction in this report.
tx ;; The tx ID represented by the transaction in this report; refer :db/tx.
txInstant ;; The timestamp instant when the the transaction was processed/committed in this report; refer :db/txInstant.
entities ;; The set of entities (like [:db/add e a v tx]) processed.
tx-data ;; The set of datoms applied to the database, like (Datom. e a v tx added).
tempids ;; The map from id-literal -> numeric entid.
@ -106,11 +110,14 @@
entity))
(defn maybe-ident->entid [db [op e a v tx :as orig]]
(let [e (get (db/idents db) e e) ;; TODO: use ident, entid here.
a (get (db/idents db) a a)
(let [e (db/entid db e)
a (db/entid db a)
v (if (ds/kw? (db/schema db) a) ;; TODO: decide if this is best. We could also check for ref and numeric types.
v
(get (db/idents db) v v))]
(db/entid db v))]
(when-not (integer? a)
(raise "Unknown attribute " a
{:form orig :attribute a}))
[op e a v tx]))
(defrecord Transaction [db tempids entities])
@ -120,7 +127,7 @@
(let [tx (:tx report)
txInstant (:txInstant report)]
;; n.b., this must not be symbolic -- it's inserted after we map idents -> entids.
[:db/add tx (get-in db [:idents :db/txInstant]) txInstant]))
[:db/add tx (db/entid db :db/txInstant) txInstant]))
(defn ensure-entity-form [[op e a v & rest :as entity]]
(cond
@ -153,8 +160,8 @@
(defn- tx-instant? [db [op e a & _]]
(and (= op :db/add)
(= e (get-in db [:idents :db/tx]))
(= a (get-in db [:idents :db/txInstant]))))
(= (db/entid db e) (db/entid db :db/tx))
(= (db/entid db a) (db/entid db :db/txInstant))))
(defn- update-txInstant [db report]
"Extract [:db/add :db/tx :db/txInstant ...], and update :txInstant with that value."
@ -175,7 +182,7 @@
;; to unify all id-literals in :db.part/tx to the current transaction value, but also seems
;; inconsistent.
tx (:tx report)
db* (assoc-in db [:idents :db/tx] tx)]
db* (db/with-ident db :db/tx tx)]
(when-not (sequential? initial-es)
(raise "Bad transaction data " initial-es ", expected sequential collection"
{:error :transact/syntax, :tx-data initial-es}))
@ -205,23 +212,48 @@
(->> (update-txInstant db*)))))
(defn- lookup-ref? [x]
"Return true if `x` is like [:attr value]."
"Return `x` if `x` is like [:attr value], false otherwise."
(and (sequential? x)
(= (count x) 2)
(or (keyword? (first x))
(integer? (first x)))))
(integer? (first x)))
x))
(defn <resolve-lookup-refs [db report]
{:pre [(db/db? db) (report? report)]}
(let [entities (:entities report)]
;; TODO: meta.
(go-pair
(->>
(vec (for [[op & entity] (:entities report)]
(into [op] (for [field entity]
(if (lookup-ref? field)
(first (<? (db/<eavt db field))) ;; TODO improve this -- this should be avet, shouldn't it?
field)))))
(assoc-in report [:entities])))) ;; TODO: meta.
(if (empty? entities)
report
(assoc-in
report [:entities]
;; We can't use `for` because go-pair doesn't traverse function boundaries.
;; Apologies for the tortured nested loop.
(loop [[op & entity] (first entities)
next (rest entities)
acc []]
(if (nil? op)
acc
(recur (first next)
(rest next)
(conj acc
(loop [field (first entity)
rem (rest entity)
acc [op]]
(if (nil? field)
acc
(recur (first rem)
(rest rem)
(conj acc
(if-let [[a v] (lookup-ref? field)]
(or
;; The lookup might fail! If so, throw.
(:e (<? (db/<av db a v)))
(raise "No entity found with attr " a " and val " v "."
{:a a :v v}))
field))))))))))))))
(declare <resolve-id-literals)
@ -280,7 +312,9 @@
report
(and (not= op :db/add)
(not (empty? (filter id-literal? [e a v]))))
(or (id-literal? e)
(id-literal? a)
(id-literal? v)))
(raise "id-literals are resolved for :db/add only"
{:error :transact/syntax
:op entity })
@ -289,26 +323,26 @@
(and (id-literal? e)
(ds/unique-identity? (db/schema db) a)
(not-any? id-literal? [a v]))
(let [upserted-eid (:e (first (<? (db/<avet db [a v]))))
(let [upserted-eid (:e (<? (db/<av db a v)))
allocated-eid (get-in report [:tempids e])]
(if (and upserted-eid allocated-eid (not= upserted-eid allocated-eid))
(<? (<retry-with-tempid db initial-report initial-entities e upserted-eid)) ;; TODO: not initial report, just the sorted entities here.
(let [eid (or upserted-eid allocated-eid (next-eid db))]
(let [eid (or upserted-eid allocated-eid (<? (db/<next-eid db e)))]
(recur (allocate-eid report e eid) (cons [op eid a v] entities)))))
;; Start allocating and retrying. We try with e last, so as to eventually upsert it.
(id-literal? v)
;; We can't fail with unbound literals here, since we could have multiple.
(let [eid (or (get-in report [:tempids v]) (next-eid db))]
(let [eid (or (get-in report [:tempids v]) (<? (db/<next-eid db e)))]
(recur (allocate-eid report v eid) (cons [op e a eid] entities)))
(id-literal? a)
;; TODO: should we even allow id-literal attributes? Datomic fails in some cases here.
(let [eid (or (get-in report [:tempids a]) (next-eid db))]
(let [eid (or (get-in report [:tempids a]) (<? (db/<next-eid db e)))]
(recur (allocate-eid report a eid) (cons [op e eid v] entities)))
(id-literal? e)
(let [eid (or (get-in report [:tempids e]) (next-eid db))]
(let [eid (or (get-in report [:tempids e]) (<? (db/<next-eid db e)))]
(recur (allocate-eid report e eid) (cons [op eid a v] entities)))
true
@ -333,99 +367,14 @@
(ds/ensure-valid-value schema a v)))
report))
(defn- <ensure-unique-constraints
"Throw unless all datoms in :tx-data obey the uniqueness constraints."
[db report]
{:pre [(db/db? db) (report? report)]}
;; TODO: consider accumulating errors to show more meaningful error reports.
;; TODO: constrain entities; constrain attributes.
(go-pair
;; TODO: comment on applying datoms that violate uniqueness.
(let [schema (db/schema db)
unique-datoms (transient {})] ;; map (nil, a, v)|(e, a, nil)|(e, a, v) -> datom.
(doseq [[e a v tx added :as datom] (:tx-data report)]
(when added
;; Check for violated :db/unique constraint between datom and existing store.
(when (ds/unique? schema a)
(when-let [found (first (<? (db/<avet db [a v])))]
(raise "Cannot add " datom " because of unique constraint: " found
{:error :transact/unique
:attribute a ;; TODO: map attribute back to ident.
:entity datom})))
;; Check for violated :db/unique constraint between datoms.
(when (ds/unique? schema a)
(let [key [nil a v]]
(when-let [other (get unique-datoms key)]
(raise "Cannot add " datom " and " other " because together they violate unique constraint"
{:error :transact/unique
:attribute a ;; TODO: map attribute back to ident.
:entity datom}))
(assoc! unique-datoms key datom)))
;; Check for violated :db/cardinality :db.cardinality/one constraint between datoms.
(when-not (ds/multival? schema a)
(let [key [e a nil]]
(when-let [other (get unique-datoms key)]
(raise "Cannot add " datom " and " other " because together they violate cardinality constraint"
{:error :transact/unique
:entity datom}))
(assoc! unique-datoms key datom)))
;; Check for duplicated datoms. Datomic doesn't allow overlapping writes, and we don't
;; want to guarantee order, so we don't either.
(let [key [e a v]]
(when-let [other (get unique-datoms key)]
(raise "Cannot add duplicate " datom
{:error :transact/unique
:entity datom}))
(assoc! unique-datoms key datom)))))
report))
(defn <entities->tx-data [db report]
{:pre [(db/db? db) (report? report)]}
(go-pair
(let [initial-report report
{tx :tx} report
schema (db/schema db)]
(loop [report initial-report
es (:entities initial-report)]
(let [[[op e a v :as entity] & entities] es]
(cond
(nil? entity)
report
(= op :db/add)
(if (ds/multival? schema a)
(if (empty? (<? (db/<eavt db [e a v])))
(recur (transact-report report (datom e a v tx true)) entities)
(recur report entities))
(if-let [^Datom old-datom (first (<? (db/<eavt db [e a])))]
(if (= (.-v old-datom) v)
(recur report entities)
(recur (-> report
(transact-report (datom e a (.-v old-datom) tx false))
(transact-report (datom e a v tx true)))
entities))
(recur (transact-report report (datom e a v tx true)) entities)))
(= op :db/retract)
(if (first (<? (db/<eavt db [e a v])))
(recur (transact-report report (datom e a v tx false)) entities)
(recur report entities))
true
(raise "Unknown operation at " entity ", expected :db/add, :db/retract"
{:error :transact/syntax, :operation op, :tx-data entity})))))))
(defn <transact-tx-data
[db report]
{:pre [(db/db? db) (report? report)]}
(let [<apply-entities (fn [db report]
(go-pair
(let [tx-data (<? (db/<apply-entities db (:tx report) (:entities report)))]
(assoc report :tx-data tx-data))))]
(go-pair
(->>
report
@ -433,27 +382,23 @@
(<resolve-lookup-refs db)
(<?)
(p :resolve-lookup-refs)
(<resolve-id-literals db)
(<?)
(p :resolve-id-literals)
(<ensure-schema-constraints db)
(<?)
(p :ensure-schema-constraints)
(<entities->tx-data db)
(<apply-entities db)
(<?)
(<ensure-unique-constraints db)
(<?))))
;; Normalize as [op int|id-literal int|id-literal value|id-literal]. ;; TODO: mention lookup-refs.
;; Replace lookup-refs with entids where possible.
;; Upsert or allocate id-literals.
(p :apply-entities)
))))
(defn- is-ident? [db [_ a & _]]
(= a (get-in db [:idents :db/ident])))
(= a (db/entid db :db/ident)))
(defn collect-db-ident-assertions
"Transactions may add idents, install new partitions, and install new schema attributes.
@ -486,24 +431,22 @@
{:error :schema/idents
:op ia }))))))))
(defn- symbolicate-datom [db [e a v added]]
(let [entids (zipmap (vals (db/idents db)) (keys (db/idents db)))
symbolicate (fn [x]
(get entids x x))]
(datom
(symbolicate e)
(symbolicate a)
(symbolicate v)
added)))
(defn collect-db-install-assertions
"Transactions may add idents, install new partitions, and install new schema attributes.
Collect [:db.part/db :db.install/attribute] assertions here."
[db report]
{:pre [(db/db? db) (report? report)]}
;; TODO: be more efficient; symbolicating each datom is expensive!
(let [datoms (map (partial symbolicate-datom db) (:tx-data report))
;; Symbolicating is not expensive.
(let [symbolicate-install-datom
(fn [[e a v tx added]]
(datom
(db/ident db e)
(db/ident db a)
(db/ident db v)
tx
added))
datoms (map symbolicate-install-datom (:tx-data report))
schema-fragment (datomish.schema-changes/datoms->schema-fragment datoms)]
(assoc-in report [:added-attributes] schema-fragment)))
@ -518,7 +461,7 @@
;; transaction ID and transaction timestamp directly from the report; Datomic
;; makes this surprisingly difficult: one needs a :db.part/tx temporary and an
;; explicit upsert of that temporary.
:tx (db/current-tx db)
:tx (<? (db/<next-eid db (id-literal :db.part/tx)))
:txInstant (db/now db)
:entities tx-data
:tx-data []
@ -530,32 +473,25 @@
(<transact-tx-data db)
(<?)
(p :transact-tx-data)
(collect-db-ident-assertions db)
(p :collect-db-ident-assertions)
(collect-db-install-assertions db)
(p :collect-db-install-assertions))
(collect-db-install-assertions db))
idents (merge-with merge-ident (:idents db) (:added-idents report))
symbolic-schema (merge-with merge-attr (:symbolic-schema db) (:added-attributes report))
schema (ds/schema (into {} (map (fn [[k v]] [(k idents) v]) symbolic-schema)))
db-after (->
db
(db/<apply-datoms (:tx-data report))
(db/<apply-db-ident-assertions (:added-idents report) merge-ident)
(<?)
(->> (p :apply-db-ident-assertions))
(db/<apply-db-ident-assertions (:added-idents report))
(db/<apply-db-install-assertions (:added-attributes report) merge-attr)
(<?)
(db/<apply-db-install-assertions (:added-attributes report))
(<?)
;; TODO: abstract this.
(assoc :idents idents
:symbolic-schema symbolic-schema
:schema schema)
(db/<advance-tx)
(<?))]
(->> (p :apply-db-install-assertions)))
]
(-> report
(assoc-in [:db-after] db-after)))))

29
src/datomish/transact/bootstrap.cljc
View file

@ -17,13 +17,15 @@
;; TODO: support user-specified functions in the future.
;; :db.install/function {:db/valueType :db.type/ref
;; :db/cardinality :db.cardinality/many}
:db/txInstant {:db/valueType :db.type/integer
:db/txInstant {:db/valueType :db.type/long
:db/cardinality :db.cardinality/one
} ;; :db/index true} TODO: Handle this using SQLite protocol.
:db/valueType {:db/valueType :db.type/ref
:db/cardinality :db.cardinality/one}
:db/cardinality {:db/valueType :db.type/ref
:db/cardinality :db.cardinality/one}
:db/doc {:db/valueType :db.type/string
:db/cardinality :db.cardinality/one}
:db/unique {:db/valueType :db.type/ref
:db/cardinality :db.cardinality/one}
:db/isComponent {:db/valueType :db.type/boolean
@ -52,8 +54,8 @@
:db/noHistory 13
:db/add 14
:db/retract 15
:db.part/tx 16
:db.part/user 17
:db.part/user 16
:db.part/tx 17
:db/excise 18
:db.excise/attrs 19
:db.excise/beforeT 20
@ -61,15 +63,18 @@
:db.alter/attribute 22
:db.type/ref 23
:db.type/keyword 24
:db.type/integer 25 ;; TODO: :db.type/long, to match Datomic?
:db.type/string 26
:db.type/boolean 27
:db.type/instant 28
:db.type/bytes 29
:db.cardinality/one 30
:db.cardinality/many 31
:db.unique/value 32
:db.unique/identity 33})
:db.type/long 25
:db.type/double 26
:db.type/string 27
:db.type/boolean 28
:db.type/instant 29
:db.type/bytes 30
:db.cardinality/one 31
:db.cardinality/many 32
:db.unique/value 33
:db.unique/identity 34
:db/doc 35
})
(defn tx-data []
(concat

20
src/datomish/transact/explode.cljc
View file

@ -34,14 +34,14 @@
(declare explode-entity)
(defn- explode-entity-a-v [db entity eid a v]
;; a should be symbolic at this point. Map it. TODO: use ident/entid to ensure we have a symbolic attr.
(let [reverse? (reverse-ref? a)
(let [a (db/ident db a) ;; We expect a to be an ident, but it's legal to provide an entid.
a* (db/entid db a)
reverse? (reverse-ref? a)
straight-a (if reverse? (reverse-ref a) a)
straight-a* (get-in db [:idents straight-a] straight-a)
straight-a* (db/entid db straight-a)
_ (when (and reverse? (not (ds/ref? (db/schema db) straight-a*)))
(raise "Bad attribute " a ": reverse attribute name requires {:db/valueType :db.type/ref} in schema"
{:error :transact/syntax, :attribute a, :op entity}))
a* (get-in db [:idents a] a)]
{:error :transact/syntax, :attribute a, :op entity}))]
(cond
reverse?
(explode-entity-a-v db entity v straight-a eid)
@ -60,11 +60,19 @@
:op entity }))
(sequential? v)
(if (some nil? v)
;; This is a hard one to track down, with a steep stack back in `transact/ensure-entity-form`, so
;; we error specifically here rather than expanding further.
(raise "Sequential attribute value for " a " contains nil."
{:error :transact/sequence-contains-nil
:op entity
:attribute a
:value v})
(if (ds/multival? (db/schema db) a*) ;; dm/schema
(mapcat (partial explode-entity-a-v db entity eid a) v) ;; Allow sequences of nested maps, etc. This does mean [[1]] will work.
(raise "Sequential values " v " but attribute " a " is :db.cardinality/one"
{:error :transact/entity-sequential-cardinality-one
:op entity }))
:op entity })))
true
[[:db/add eid a* v]])))

61
src/datomish/util.cljc
View file

@ -30,25 +30,30 @@
~expr
(cond-let ~@rest)))))
(defn ensure-datalog-var [x]
(or (and (symbol? x)
(nil? (namespace x))
(str/starts-with? (name x) "?"))
(throw (ex-info (str x " is not a Datalog var.") {}))))
(defn var->sql-type-var
"Turns '?xyz into :_xyz_type_tag."
[x]
(and
(ensure-datalog-var x)
(keyword (str "_" (subs (name x) 1) "_type_tag"))))
(defn var->sql-var
"Turns '?xyz into :xyz."
[x]
(if (and (symbol? x)
(str/starts-with? (name x) "?"))
(keyword (subs (name x) 1))
(throw (ex-info (str x " is not a Datalog var.") {}))))
(and
(ensure-datalog-var x)
(keyword (subs (name x) 1))))
(defn conj-in
"Associates a value into a sequence in a nested associative structure, where
ks is a sequence of keys and v is the new value, and returns a new nested
structure.
If any levels do not exist, hash-maps will be created. If the destination
sequence does not exist, a new one is created."
{:static true}
[m [k & ks] v]
(if ks
(assoc m k (conj-in (get m k) ks v))
(assoc m k (conj (get m k) v))))
(defn aggregate->sql-var
"Turns (:max 'column) into :%max.column."
[fn-kw x]
(keyword (str "%" (name fn-kw) "." (name x))))
(defn concat-in
{:static true}
@ -57,6 +62,30 @@
(assoc m k (concat-in (get m k) ks vs))
(assoc m k (concat (get m k) vs))))
(defn append-in
"Associates a value into a sequence in a nested associative structure, where
ks is a sequence of keys and v is the new value, and returns a new nested
structure.
Always puts the value last.
If any levels do not exist, hash-maps will be created. If the destination
sequence does not exist, a new one is created."
{:static true}
[m path v]
(concat-in m path [v]))
(defn assoc-if
([m k v]
(if v
(assoc m k v)
m))
([m k v & kvs]
(if kvs
(let [[kk vv & remainder] kvs]
(apply assoc-if
(assoc-if m k v)
kk vv remainder))
(assoc-if m k v))))
(defmacro while-let [binding & forms]
`(loop []
(when-let ~binding
@ -70,3 +99,5 @@
(f (first xs) (first ys))
(recur f (rest xs) (rest ys)))))
(defn mapvals [f m]
(into (empty m) (map #(vector (first %) (f (second %))) m)))

19
test/datomish/api.cljc
View file

@ -20,14 +20,9 @@
(defn <connect [uri]
;; Eventually, URI. For now, just a plain path (no file://).
(go-pair
(->
(sqlite/<sqlite-connection uri)
(<?)
(db-factory/<db-with-sqlite-connection)
(<?)
(transact/connection-with-db))))
(let [conn (<? (sqlite/<sqlite-connection uri))
db (<? (db-factory/<db-with-sqlite-connection conn))]
(transact/connection-with-db db))))
(def <transact! transact/<transact!)
@ -38,3 +33,11 @@
(def id-literal db/id-literal)
(def db transact/db)
(def entid db/entid)
(def ident db/ident)
(def <q db/<?q)
(def schema db/schema)

201
test/datomish/db_test.cljc
View file

@ -10,17 +10,20 @@
[cljs.core.async.macros :as a :refer [go]]))
(:require
[datomish.api :as d]
[datomish.db.debug :refer [<datoms-after <transactions-after <shallow-entity <fulltext-values]]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise cond-let]]
[datomish.schema :as ds]
[datomish.sqlite :as s]
[datomish.sqlite-schema]
[datomish.datom]
[datomish.db :as db]
#?@(:clj [[datomish.pair-chan :refer [go-pair <?]]
#?@(:clj [[datomish.jdbc-sqlite]
[datomish.pair-chan :refer [go-pair <?]]
[tempfile.core :refer [tempfile with-tempfile]]
[datomish.test-macros :refer [deftest-async]]
[clojure.test :as t :refer [is are deftest testing]]
[clojure.core.async :refer [go <! >!]]])
#?@(:cljs [[datomish.pair-chan]
#?@(:cljs [[datomish.promise-sqlite]
[datomish.pair-chan]
[datomish.test-macros :refer-macros [deftest-async]]
[datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing async]]
@ -36,88 +39,46 @@
(defn- tempids [tx]
(into {} (map (juxt (comp :idx first) second) (:tempids tx))))
(defn- <datoms-after [db tx]
(let [entids (zipmap (vals (db/idents db)) (keys (db/idents db)))]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT e, a, v, tx FROM datoms WHERE tx > ?" tx])
(<?)
(mapv #(vector (:e %) (get entids (:a %) (str "fail" (:a %))) (:v %)))
(filter #(not (= :db/txInstant (second %))))
(set)))))
(defn- <datoms [db]
(<datoms-after db 0))
(defn- <shallow-entity [db eid]
;; TODO: make this actually be <entity. Handle :db.cardinality/many and :db/isComponent.
(let [entids (zipmap (vals (db/idents db)) (keys (db/idents db)))]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT a, v FROM datoms WHERE e = ?" eid])
(<?)
(mapv #(vector (entids (:a %)) (:v %)))
(reduce conj {})))))
(defn- <transactions-after [db tx]
(let [entids (zipmap (vals (db/idents db)) (keys (db/idents db)))]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT e, a, v, tx, added FROM transactions WHERE tx > ? ORDER BY tx ASC, e, a, v, added" tx])
(<?)
(mapv #(vector (:e %) (entids (:a %)) (:v %) (:tx %) (:added %)))))))
(defn- <transactions [db]
(<transactions-after db 0))
(defn- <fulltext-values [db]
(go-pair
(->>
(s/all-rows (:sqlite-connection db) ["SELECT rowid, text FROM fulltext_values"])
(<?)
(mapv #(vector (:rowid %) (:text %))))))
;; TODO: use reverse refs!
(def test-schema
[{:db/id (d/id-literal :test -1)
[{:db/id (d/id-literal :db.part/user)
:db/ident :x
:db/unique :db.unique/identity
:db/valueType :db.type/integer}
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -1)}
{:db/id (d/id-literal :test -2)
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :name
:db/unique :db.unique/identity
:db/valueType :db.type/string}
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -2)}
{:db/id (d/id-literal :test -3)
:db/valueType :db.type/string
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :y
:db/cardinality :db.cardinality/many
:db/valueType :db.type/integer}
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -3)}
{:db/id (d/id-literal :test -5)
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :aka
:db/cardinality :db.cardinality/many
:db/valueType :db.type/string}
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -5)}
{:db/id (d/id-literal :test -6)
:db/valueType :db.type/string
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :age
:db/valueType :db.type/integer}
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -6)}
{:db/id (d/id-literal :test -7)
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :email
:db/unique :db.unique/identity
:db/valueType :db.type/string}
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -7)}
{:db/id (d/id-literal :test -8)
:db/valueType :db.type/string
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :spouse
:db/unique :db.unique/value
:db/valueType :db.type/string}
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -8)}
{:db/id (d/id-literal :test -9)
:db/valueType :db.type/string
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :friends
:db/cardinality :db.cardinality/many
:db/valueType :db.type/ref}
{:db/id :db.part/db :db.install/attribute (d/id-literal :test -9)}
:db/valueType :db.type/ref
:db.install/_attribute :db.part/db}
])
(deftest-async test-add-one
@ -381,10 +342,12 @@
(with-tempfile [t (tempfile)]
(let [conn (<? (d/<connect t))]
(try
(is (= :test/ident (d/entid (d/db conn) :test/ident)))
(let [report (<? (d/<transact! conn [[:db/add (d/id-literal :db.part/db -1) :db/ident :test/ident]]))
db-after (:db-after report)
tx (:tx db-after)]
(is (= (:test/ident (db/idents db-after)) (get-in report [:tempids (d/id-literal :db.part/db -1)]))))
eid (get-in report [:tempids (d/id-literal :db.part/db -1)])]
(is (= eid (d/entid (d/db conn) :test/ident)))
(is (= :test/ident (d/ident (d/db conn) eid))))
;; TODO: This should fail, but doesn't, due to stringification of :test/ident.
;; (is (thrown-with-msg?
@ -417,7 +380,7 @@
tx (:tx db-after)]
(testing "New ident is allocated"
(is (some? (get-in db-after [:idents :test/attr]))))
(is (some? (d/entid db-after :test/attr))))
(testing "Schema is modified"
(is (= (get-in db-after [:symbolic-schema :test/attr])
@ -450,26 +413,37 @@
{:db/id :db.part/db :db.install/attribute (d/id-literal :db.part/db -2)}
]
tx0 (:tx (<? (d/<transact! conn schema)))]
(testing "Schema checks"
(is (ds/fulltext? (d/schema (d/db conn))
(d/entid (d/db conn) :test/fulltext))))
(try
(testing "Can add fulltext indexed datoms"
(let [r (<? (d/<transact! conn [[:db/add 101 :test/fulltext "test this"]]))]
(let [{tx1 :tx txInstant1 :txInstant}
(<? (d/<transact! conn [[:db/add 101 :test/fulltext "test this"]]))]
(is (= (<? (<fulltext-values (d/db conn)))
[[1 "test this"]]))
(is (= (<? (<datoms-after (d/db conn) tx0))
#{[101 :test/fulltext 1]})) ;; Values are raw; 1 is the rowid into fulltext_values.
))
(is (= (<? (<transactions-after (d/db conn) tx0))
[[101 :test/fulltext 1 tx1 1] ;; Values are raw; 1 is the rowid into fulltext_values.
[tx1 :db/txInstant txInstant1 tx1 1]]))
(testing "Can replace fulltext indexed datoms"
(let [r (<? (d/<transact! conn [[:db/add 101 :test/fulltext "alternate thing"]]))]
(let [{tx2 :tx txInstant2 :txInstant} (<? (d/<transact! conn [[:db/add 101 :test/fulltext "alternate thing"]]))]
(is (= (<? (<fulltext-values (d/db conn)))
[[1 "test this"]
[2 "alternate thing"]]))
(is (= (<? (<datoms-after (d/db conn) tx0))
#{[101 :test/fulltext 2]})) ;; Values are raw; 2 is the rowid into fulltext_values.
))
(is (= (<? (<transactions-after (d/db conn) tx0))
[[101 :test/fulltext 1 tx1 1] ;; Values are raw; 1 is the rowid into fulltext_values.
[tx1 :db/txInstant txInstant1 tx1 1]
[101 :test/fulltext 1 tx2 0] ;; Values are raw; 1 is the rowid into fulltext_values.
[101 :test/fulltext 2 tx2 1] ;; Values are raw; 2 is the rowid into fulltext_values.
[tx2 :db/txInstant txInstant2 tx2 1]]))
(testing "Can upsert keyed by fulltext indexed datoms"
(let [r (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user) :test/fulltext "alternate thing" :test/other "other"}]))]
(let [{tx3 :tx txInstant3 :txInstant} (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user) :test/fulltext "alternate thing" :test/other "other"}]))]
(is (= (<? (<fulltext-values (d/db conn)))
[[1 "test this"]
[2 "alternate thing"]
@ -477,7 +451,16 @@
(is (= (<? (<datoms-after (d/db conn) tx0))
#{[101 :test/fulltext 2] ;; Values are raw; 2, 3 are the rowids into fulltext_values.
[101 :test/other 3]}))
))
(is (= (<? (<transactions-after (d/db conn) tx0))
[[101 :test/fulltext 1 tx1 1] ;; Values are raw; 1 is the rowid into fulltext_values.
[tx1 :db/txInstant txInstant1 tx1 1]
[101 :test/fulltext 1 tx2 0] ;; Values are raw; 1 is the rowid into fulltext_values.
[101 :test/fulltext 2 tx2 1] ;; Values are raw; 2 is the rowid into fulltext_values.
[tx2 :db/txInstant txInstant2 tx2 1]
[101 :test/other 3 tx3 1] ;; Values are raw; 3 is the rowid into fulltext_values.
[tx3 :db/txInstant txInstant3 tx3 1]]))
))))))
(testing "Can re-use fulltext indexed datoms"
(let [r (<? (d/<transact! conn [[:db/add 102 :test/other "test this"]]))]
@ -632,3 +615,63 @@
(finally
(<? (d/<close conn)))))))
(deftest-async test-next-eid
(with-tempfile [t (tempfile)]
(let [conn (<? (d/<connect t))
{tx0 :tx} (<? (d/<transact! conn test-schema))]
(testing "entids are increasing, tx ids are larger than user ids"
(let [r1 (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -1) :name "Igor"}]))
r2 (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -2) :name "Oleg"}]))
e1 (get (tempids r1) -1)
e2 (get (tempids r2) -2)]
(is (< e1 (:tx r1)))
(is (< e2 (:tx r2)))
(is (< e1 e2))
(is (< (:tx r1) (:tx r2)))
;; Close and re-open same DB.
(<? (d/<close conn))
(let [conn (<? (d/<connect t))]
(try
(testing "entid counters are persisted across re-opens"
(let [r3 (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -3) :name "Petr"}]))
e3 (get (tempids r3) -3)]
(is (< e3 (:tx r3)))
(is (< e2 e3))
(is (< (:tx r2) (:tx r3)))))
(finally
(<? (d/<close conn))))))))))
(deftest-async test-unique-value
(with-tempfile [t (tempfile)]
(let [conn (<? (d/<connect t))]
(try
(let [tx0 (:tx (<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -1)
:db/ident :test/x
:db/unique :db.unique/value
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user -2)
:db/ident :test/y
:db/unique :db.unique/value
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}])))]
(testing "can insert different :db.unique/value attributes with the same value"
(let [report1 (<? (d/<transact! conn [[:db/add (d/id-literal :db.part/user -1) :test/x 12345]]))
eid1 (get-in report1 [:tempids (d/id-literal :db.part/user -1)])
report2 (<? (d/<transact! conn [[:db/add (d/id-literal :db.part/user -2) :test/y 12345]]))
eid2 (get-in report2 [:tempids (d/id-literal :db.part/user -2)])]
(is (= (<? (<datoms-after (d/db conn) tx0))
#{[eid1 :test/x 12345]
[eid2 :test/y 12345]}))))
(testing "can't upsert a :db.unique/value field"
(is (thrown-with-msg?
ExceptionInfo #"unique constraint"
(<? (d/<transact! conn [{:db/id (d/id-literal :db.part/user -1) :test/x 12345 :test/y 99999}]))))))
(finally
(<? (d/<close conn)))))))

79
test/datomish/places/import_test.cljc Normal file
View file

@ -0,0 +1,79 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.places.import-test
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[datomish.node-tempfile-macros :refer [with-tempfile]]
[cljs.core.async.macros :as a :refer [go]]))
(:require
[taoensso.tufte :as tufte
#?(:cljs :refer-macros :clj :refer) [defnp p profiled profile]]
[datomish.api :as d]
[datomish.places.import :as pi]
[datomish.util :as util #?(:cljs :refer-macros :clj :refer) [raise cond-let]]
[datomish.sqlite :as s]
#?@(:clj [[datomish.jdbc-sqlite]
[datomish.pair-chan :refer [go-pair <?]]
[tempfile.core :refer [tempfile with-tempfile]]
[datomish.test-macros :refer [deftest-async]]
[clojure.test :as t :refer [is are deftest testing]]
[clojure.core.async :refer [go <! >!]]])
#?@(:cljs [[datomish.promise-sqlite]
[datomish.pair-chan]
[datomish.test-macros :refer-macros [deftest-async]]
[datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing async]]
[cljs.core.async :as a :refer [<! >!]]])))
#?(:cljs
(def Throwable js/Error))
(tufte/add-basic-println-handler! {})
(deftest-async test-import
(with-tempfile [t (tempfile)]
(let [places (<? (s/<sqlite-connection "/tmp/places.sqlite"))
conn (<? (d/<connect t))]
(try
(let [report (profile {:dynamic? true} (<? (pi/import-places conn places)))]
(is (= nil (count (:tx-data report)))))
(finally
(<? (d/<close conn)))))))
(deftest-async test-import-repeat
;; Repeated import is worst possible for the big joins to find datoms that already exist, because
;; *every* datom added in the first import will match in the second.
(with-tempfile [t (tempfile)]
(let [places (<? (s/<sqlite-connection "/tmp/places.sqlite"))
conn (<? (d/<connect t))]
(try
(let [report0 (<? (pi/import-places conn places))
report (profile {:dynamic? true} (<? (pi/import-places conn places)))]
(is (= nil (count (:tx-data report)))))
(finally
(<? (d/<close conn)))))))
#_
(defn <?? [pair-chan]
(datomish.pair-chan/consume-pair (clojure.core.async/<!! pair-chan)))
#_ [
(def places (<?? (s/<sqlite-connection "/tmp/places.sqlite")))
(def conn (<?? (d/<connect "/tmp/testkb.sqlite")))
(def tx0 (:tx (<?? (d/<transact! conn places-schema-fragment))))
(tufte/add-basic-println-handler! {})
(def report (profile {:dynamic? true} (<?? (pi/import conn places))))
;; Empty:
;; "Elapsed time: 5451.610551 msecs"
;; Reimport:
;; "Elapsed time: 25600.358881 msecs"
]

56
test/datomish/query_test.cljc Normal file
View file

@ -0,0 +1,56 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.query-test
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[datomish.node-tempfile-macros :refer [with-tempfile]]
[cljs.core.async.macros :as a :refer [go]]))
(:require
[datomish.api :as d]
#?@(:clj [[datomish.jdbc-sqlite]
[datomish.pair-chan :refer [go-pair <?]]
[tempfile.core :refer [tempfile with-tempfile]]
[datomish.test-macros :refer [deftest-async]]
[clojure.test :as t :refer [is are deftest testing]]
[clojure.core.async :refer [go <! >!]]])
#?@(:cljs [[datomish.promise-sqlite]
[datomish.pair-chan]
[datomish.test-macros :refer-macros [deftest-async]]
[datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing async]]
[cljs.core.async :as a :refer [<! >!]]]))
#?(:clj
(:import [clojure.lang ExceptionInfo]))
#?(:clj
(:import [datascript.db DB])))
#?(:cljs
(def Throwable js/Error))
(def test-schema
[{:db/id (d/id-literal :db.part/user)
:db/ident :x
:db/unique :db.unique/identity
:db/valueType :db.type/long
:db.install/_attribute :db.part/db}
])
(deftest-async test-q
(with-tempfile [t (tempfile)]
(let [conn (<? (d/<connect t))
{tx0 :tx} (<? (d/<transact! conn test-schema))]
(try
(let [{tx1 :tx} (<? (d/<transact! conn [{:db/id 101 :x 505}]))]
(is (= (<? (d/<q (d/db conn)
[:find '?e '?a '?v '?tx :in '$ :where
'[?e ?a ?v ?tx]
[(list '> '?tx tx0)]
[(list '!= '?a (d/entid (d/db conn) :db/txInstant))] ;; TODO: map ident->entid for values.
] {}))
[[101 (d/entid (d/db conn) :x) 505 tx1]]))) ;; TODO: map entid->ident on egress.
(finally
(<? (d/<close conn)))))))

22
test/datomish/schema_test.cljc Normal file
View file

@ -0,0 +1,22 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.schema-test
(:require
[datomish.schema :as schema]
#?@(:clj [[datomish.test-macros :refer [deftest-async]]
[clojure.test :as t :refer [is are deftest testing]]])
#?@(:cljs [[datomish.test-macros :refer-macros [deftest-async]]
[cljs.test :as t :refer-macros [is are deftest testing async]]])))
#?(:clj
(deftest test-uuid-validation
(is (not (schema/uuidish? "123e4567-e89b-12d3-a456-426655440000")))
(is (schema/uuidish? (java.util.UUID/fromString "123e4567-e89b-12d3-a456-426655440000")))))
#?(:cljs
(deftest test-uuid-validation
;; Case-insensitive.
(is (schema/uuidish? "123e4567-e89b-12d3-a456-426655440000"))
(is (schema/uuidish? "123E4567-e89b-12d3-a456-426655440000"))))

11
test/datomish/test.cljs
View file

@ -2,18 +2,27 @@
(:require
[doo.runner :refer-macros [doo-tests doo-all-tests]]
[cljs.test :as t :refer-macros [is are deftest testing]]
datomish.places.import-test
datomish.promise-sqlite-test
datomish.db-test
datomish.query-test
datomish.schema-test
datomish.sqlite-user-version-test
datomish.tofinoish-test
datomish.test.util
datomish.test.transforms
datomish.test.query
datomish.test-macros-test))
datomish.test-macros-test
))
(doo-tests
'datomish.places.import-test
'datomish.promise-sqlite-test
'datomish.db-test
'datomish.query-test
'datomish.schema-test
'datomish.sqlite-user-version-test
'datomish.tofinoish-test
'datomish.test.util
'datomish.test.transforms
'datomish.test.query

549
test/datomish/test/query.cljc
View file

@ -1,18 +1,34 @@
(ns datomish.test.query
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[datomish.node-tempfile-macros :refer [with-tempfile]]
[cljs.core.async.macros :as a :refer [go]]))
(:require
[datomish.query.cc :as cc]
[datomish.query.context :as context]
[datomish.query.source :as source]
[datomish.query.transforms :as transforms]
[datomish.query :as query]
[datomish.db :as db]
[datomish.schema :as schema]
[datomish.transact :as transact]
[datomish.api :as d]
#?@(:clj
[
[[datomish.pair-chan :refer [go-pair <?]]
[datomish.jdbc-sqlite]
[datomish.test-macros :refer [deftest-db]]
[honeysql.core :as sql :refer [param]]
[tempfile.core :refer [tempfile with-tempfile]]
[clojure.test :as t :refer [is are deftest testing]]])
#?@(:cljs
[
[[datomish.promise-sqlite]
[datomish.test-macros :refer-macros [deftest-db]]
[honeysql.core :as sql :refer-macros [param]]
[cljs.test :as t :refer-macros [is are deftest testing]]])
))
[datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing]]]))
#?(:clj
(:import [clojure.lang ExceptionInfo])))
(defn- fgensym [s c]
(symbol (str s c)))
@ -25,144 +41,479 @@
([s]
(fgensym s (dec (swap! counter inc)))))))
(defn mock-source [db]
(source/map->DatomsSource
{:table :datoms
:fulltext-table :fulltext_values
:fulltext-view :all_datoms
:columns [:e :a :v :tx :added]
:attribute-transform transforms/attribute-transform-string
:constant-transform transforms/constant-transform-default
:table-alias (comp (make-predictable-gensym) name)
:make-constraints nil}))
(def simple-schema
[{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :db/txInstant
:db/valueType :db.type/long
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/bar
:db/valueType :db.type/string
:db/cardinality :db.cardinality/many}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/int
:db/valueType :db.type/long
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/str
:db/valueType :db.type/string
:db/cardinality :db.cardinality/many}])
(defn- expand [find]
(let [context (context/->Context (mock-source nil) nil nil)
(def page-schema
[{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/loves
:db/valueType :db.type/ref
:db/cardinality :db.cardinality/many}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/likes
:db/valueType :db.type/ref
:db/cardinality :db.cardinality/many}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/url
:db/valueType :db.type/string
:db/unique :db.unique/identity
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/title
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/starred
:db/valueType :db.type/boolean
:db/cardinality :db.cardinality/one}])
(def aggregate-schema
[{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :page/url
:db/valueType :db.type/string
:db/unique :db.unique/identity
:db/cardinality :db.cardinality/one}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/points
:db/valueType :db.type/long
:db/cardinality :db.cardinality/many}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/ident :foo/visitedAt
:db/valueType :db.type/instant
:db/cardinality :db.cardinality/many}])
(def schema-with-page
(concat
simple-schema
page-schema))
(defn mock-source [db]
(assoc (datomish.db/datoms-source db)
:table-alias (comp (make-predictable-gensym) name)))
(defn conn->context [conn]
(context/make-context (mock-source (d/db conn))))
(defn- expand [find conn]
(let [context (conn->context conn)
parsed (query/parse find)]
(query/find->sql-clause context parsed)))
(deftest test-basic-join
(is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from '[[:datoms datoms0]
[:datoms datoms1]],
:where (list
:and
[:= :datoms1.e :datoms0.tx]
[:= :datoms0.a "page/starred"]
[:= :datoms0.v 1]
[:= :datoms1.a "db/txInstant"]
[:not
(list :and (list :> :datoms1.e (sql/param :latest)))])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [(> ?t ?latest)])]))))
(defn- populate [find conn]
(let [context (conn->context conn)
parsed (query/parse find)]
(query/find-into-context context parsed)))
(deftest test-pattern-not-join
(is (= '{:select ([:datoms1.v :timestampMicros] [:datoms0.e :page]),
(defn <initialize-with-schema [conn schema]
(go-pair
(let [tx (<? (d/<transact! conn schema))]
(let [idents (map :db/ident schema)
db (d/db conn)]
(into {}
(map (fn [ident]
[ident (d/entid db ident)])
idents))))))
(deftest-db test-type-extraction conn
;; We expect to be able to look up the default types.
(is (integer? (d/entid (d/db conn) :db.type/ref)))
(is (integer? (d/entid (d/db conn) :db.type/long)))
;; Add our own schema.
(<? (<initialize-with-schema conn simple-schema))
(testing "Variable entity."
(is (= (->
(populate '[:find ?e ?v :in $ :where [?e :foo/int ?v]] conn)
:cc :known-types)
{'?v :db.type/long
'?e :db.type/ref})))
(testing "Numeric entid."
(is (= (->
(populate '[:find ?v :in $ :where [6 :foo/int ?v]] conn)
:cc :known-types)
{'?v :db.type/long})))
(testing "Keyword entity."
(is (= (->
(populate '[:find ?v :in $ :where [:my/thing :foo/int ?v]] conn)
:cc :known-types)
{'?v :db.type/long}))))
(deftest-db test-value-constant-constraint-descends-into-not-and-or conn
(let [attrs (<? (<initialize-with-schema conn simple-schema))]
(testing "Elision of types inside a join."
(is (= {:select '([:datoms0.e :e]
[:datoms0.v :v]),
:modifiers [:distinct],
:from [[:datoms datoms0]
[:datoms datoms1]],
:where (:and
[:= :datoms1.e :datoms0.tx]
[:= :datoms0.a "page/starred"]
[:= :datoms0.v 1]
[:= :datoms1.a "db/txInstant"]
:from [[:datoms 'datoms0]],
:where (list :and
[:= :datoms0.a (:foo/int attrs)]
[:not
[:exists
{:select [1],
:from [[:datoms datoms2]],
:where (:and
[:= :datoms2.a "foo/bar"]
[:= :datoms0.e :datoms2.e])}]])}
:from [[:all_datoms 'all_datoms1]],
:where (list :and
[:= :all_datoms1.e 999]
[:= :datoms0.v :all_datoms1.v])}]])}
(expand
'[:find ?e ?v :in $ :where
[?e :foo/int ?v]
(not [999 ?a ?v])]
conn))))
(testing "Type collisions inside :not."
(is (thrown-with-msg?
ExceptionInfo #"v already has type :db.type.long"
(expand
'[:find ?e ?v :in $ :where
[?e :foo/int ?v]
(not [999 :foo/str ?v])]
conn))))
(testing "Type collisions inside :or"
(is (thrown-with-msg?
ExceptionInfo #"v already has type :db.type.long"
(expand
'[:find ?e ?v :in $ :where
[?e :foo/int ?v]
(or
[999 :foo/str ?v]
[666 :foo/int ?v])]
conn))))))
(deftest-db test-type-collision conn
(<? (<initialize-with-schema conn simple-schema))
(let [find '[:find ?e ?v :in $
:where
[?e :foo/int ?v]
[?x :foo/str ?v]]]
(is (thrown-with-msg?
ExceptionInfo #"v already has type :db.type.long"
(populate find conn)))))
(deftest-db test-value-constant-constraint conn
(<? (<initialize-with-schema conn simple-schema))
(is (= {:select '([:all_datoms0.e :foo]),
:modifiers [:distinct],
:from '[[:all_datoms all_datoms0]],
:where (list :and
(list :or
[:= :all_datoms0.value_type_tag 0]
;; In CLJS, this can also be an `instant`.
#?@(:cljs [[:= :all_datoms0.value_type_tag 4]])
[:= :all_datoms0.value_type_tag 5])
[:= :all_datoms0.v 99])}
(expand
'[:find ?foo :in $ :where
[?foo _ 99]]
conn))))
(deftest-db test-value-constant-constraint-elided-using-schema conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(testing "Our attributes were interned."
(is (integer? (d/entid (d/db conn) :foo/str)))
(is (integer? (d/entid (d/db conn) :page/starred))))
(testing "There's no need to produce value_type_tag constraints when the attribute is specified."
(is
(= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from [[:datoms 'datoms0]
[:datoms 'datoms1]],
:where (list :and
;; We don't need a type check on the range of page/starred...
[:= :datoms0.a (:page/starred attrs)]
[:= :datoms0.v 1]
[:= :datoms1.a (:db/txInstant attrs)]
[:not
[:exists
{:select [1],
:from [[:datoms 'datoms2]],
:where (list :and
[:= :datoms2.a (:foo/bar attrs)]
[:= :datoms0.e :datoms2.e])}]]
[:= :datoms0.tx :datoms1.e])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [?page :foo/bar _])]))))
(not [?page :foo/bar _])]
conn))))))
(deftest-db test-basic-join conn
;; Note that we use a schema without :page/starred, so we
;; don't know what type it is.
(let [attrs (<? (<initialize-with-schema conn simple-schema))]
(is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from '([:datoms datoms0]
[:datoms datoms1]),
:where (list
:and
;; Note that :page/starred is literal, because
;; it's not present in the interned schema.
[:= :datoms0.a :page/starred]
[:= :datoms0.value_type_tag 1] ; boolean
[:= :datoms0.v 1]
[:= :datoms1.a (:db/txInstant attrs)]
[:not
(list :and (list :> :datoms0.tx (sql/param :latest)))]
[:= :datoms0.tx :datoms1.e])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [(> ?t ?latest)])]
conn)))))
(deftest-db test-pattern-not-join conn
(let [attrs (<? (<initialize-with-schema conn simple-schema))]
(is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from [[:datoms 'datoms0]
[:datoms 'datoms1]],
:where (list
:and
;; Note that :page/starred is literal, because
;; it's not present in the interned schema.
[:= :datoms0.a :page/starred]
[:= :datoms0.value_type_tag 1] ; boolean
[:= :datoms0.v 1]
[:= :datoms1.a (:db/txInstant attrs)]
[:not
[:exists
{:select [1],
:from [[:datoms 'datoms2]],
:where (list :and
[:= :datoms2.a (:foo/bar attrs)]
[:= :datoms0.e :datoms2.e])}]]
[:= :datoms0.tx :datoms1.e])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
[?t :db/txInstant ?timestampMicros]
(not [?page :foo/bar _])]
conn)))))
;; Note that clause ordering is not directly correlated to the output: cross-bindings end up
;; at the front. The SQL engine will do its own analysis. See `clauses/expand-where-from-bindings`.
(deftest test-not-clause-ordering-preserved
(deftest-db test-not-clause-ordering-preserved conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:datoms1.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from '[[:datoms datoms0]
[:datoms datoms1]],
:where (list
:and
[:= :datoms1.e :datoms0.tx]
[:= :datoms0.a "page/starred"]
;; We don't need a value tag constraint -- we know the range of the attribute.
[:= :datoms0.a (:page/starred attrs)]
[:= :datoms0.v 1]
[:not
(list :and (list :> :datoms0.tx (sql/param :latest)))]
[:= :datoms1.a "db/txInstant"])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
(not [(> ?t ?latest)])
[?t :db/txInstant ?timestampMicros]]))))
(deftest test-pattern-not-join-ordering-preserved
(is (= '{:select ([:datoms2.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from [[:datoms datoms0]
[:datoms datoms2]],
:where (:and
[:= :datoms2.e :datoms0.tx]
[:= :datoms0.a "page/starred"]
[:= :datoms0.v 1]
[:not
[:exists
{:select [1],
:from [[:datoms datoms1]],
:where (:and
[:= :datoms1.a "foo/bar"]
[:= :datoms0.e :datoms1.e])}]]
[:= :datoms2.a "db/txInstant"]
[:= :datoms1.a (:db/txInstant attrs)]
[:= :datoms0.tx :datoms1.e]
)}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
(not [?page :foo/bar _])
[?t :db/txInstant ?timestampMicros]]))))
(not [(> ?t ?latest)])
[?t :db/txInstant ?timestampMicros]]
conn)))))
(deftest test-single-or
(is (= '{:select ([:datoms1.e :page]),
(deftest-db test-pattern-not-join-ordering-preserved conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:datoms2.v :timestampMicros] [:datoms0.e :page]),
:modifiers [:distinct],
:from ([:datoms datoms0] [:datoms datoms1] [:datoms datoms2]),
:where (:and
[:= :datoms1.e :datoms0.e]
[:= :datoms1.e :datoms2.v]
[:= :datoms0.a "page/url"]
:from [[:datoms 'datoms0]
[:datoms 'datoms2]],
:where (list :and
;; We don't need a value tag constraint -- we know the range of the attribute.
[:= :datoms0.a (:page/starred attrs)]
[:= :datoms0.v 1]
[:not
[:exists
{:select [1],
:from [[:datoms 'datoms1]],
:where (list :and
[:= :datoms1.a (:foo/bar attrs)]
[:= :datoms0.e :datoms1.e])}]]
[:= :datoms2.a (:db/txInstant attrs)]
[:= :datoms0.tx :datoms2.e])}
(expand
'[:find ?timestampMicros ?page :in $ ?latest :where
[?page :page/starred true ?t]
(not [?page :foo/bar _])
[?t :db/txInstant ?timestampMicros]]
conn)))))
(deftest-db test-single-or conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:datoms0.e :page]),
:modifiers [:distinct],
:from '([:datoms datoms0] [:datoms datoms1] [:datoms datoms2]),
:where (list :and
[:= :datoms0.a (:page/url attrs)]
[:= :datoms0.v "http://example.com/"]
[:= :datoms1.a "page/title"]
[:= :datoms2.a "page/loves"])}
[:= :datoms1.a (:page/title attrs)]
[:= :datoms2.a (:page/loves attrs)]
[:= :datoms0.e :datoms1.e]
[:= :datoms0.e :datoms2.v])}
(expand
'[:find ?page :in $ ?latest :where
[?page :page/url "http://example.com/"]
[?page :page/title ?title]
(or
[?entity :page/loves ?page])]))))
[?entity :page/loves ?page])]
conn)))))
(deftest test-simple-or
(is (= '{:select ([:datoms1.e :page]),
(deftest-db test-simple-or conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:datoms0.e :page]),
:modifiers [:distinct],
:from ([:datoms datoms0] [:datoms datoms1] [:datoms datoms2]),
:where (:and
[:= :datoms1.e :datoms0.e]
[:= :datoms1.e :datoms2.v]
[:= :datoms0.a "page/url"]
:from '([:datoms datoms0] [:datoms datoms1] [:datoms datoms2]),
:where (list :and
[:= :datoms0.a (:page/url attrs)]
[:= :datoms0.v "http://example.com/"]
[:= :datoms1.a "page/title"]
(:or
[:= :datoms2.a "page/likes"]
[:= :datoms2.a "page/loves"]))}
[:= :datoms1.a (:page/title attrs)]
(list :or
[:= :datoms2.a (:page/likes attrs)]
[:= :datoms2.a (:page/loves attrs)])
[:= :datoms0.e :datoms1.e]
[:= :datoms0.e :datoms2.v])}
(expand
'[:find ?page :in $ ?latest :where
[?page :page/url "http://example.com/"]
[?page :page/title ?title]
(or
[?entity :page/likes ?page]
[?entity :page/loves ?page])]))))
[?entity :page/loves ?page])]
conn)))))
(defn tag-clauses [column input]
(let [codes (cc/->tag-codes input)]
(if (= 1 (count codes))
[:= column (first codes)]
(cons :or (map (fn [tag]
[:= column tag])
codes)))))
(deftest-db test-url-tag conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:all_datoms0.e :page]
[:datoms1.v :thing]),
:modifiers [:distinct],
:from '([:all_datoms all_datoms0]
[:datoms datoms1]),
:where (list
:and
(tag-clauses :all_datoms0.value_type_tag "http://example.com/")
[:= :all_datoms0.v "http://example.com/"]
(list
:or
[:= :datoms1.a (:page/likes attrs)]
[:= :datoms1.a (:page/loves attrs)])
[:= :all_datoms0.e :datoms1.e])}
(expand
'[:find ?page ?thing :in $ ?latest :where
[?page _ "http://example.com/"]
(or
[?page :page/likes ?thing]
[?page :page/loves ?thing])]
conn)))))
(deftest-db test-tag-projection conn
(let [attrs (<? (<initialize-with-schema conn schema-with-page))]
(is (= {:select '([:all_datoms0.e :page]
[:all_datoms0.v :thing]
[:all_datoms0.value_type_tag :_thing_type_tag]),
:modifiers [:distinct],
:from '([:all_datoms all_datoms0])}
(expand
'[:find ?page ?thing :in $ :where
[?page _ ?thing]]
conn)))))
(deftest-db test-aggregates conn
(let [attrs (<? (<initialize-with-schema conn aggregate-schema))
context
(populate '[:find ?date (max ?v)
:with ?e
:in $ ?then
:where
[?e :foo/visitedAt ?date]
[(> ?date ?then)]
[?e :foo/points ?v]] conn)]
(is (= (:group-by-vars context)
['?date '?e]))
(is (= {:select '([:preag.date :date]
[:%max.preag.v :_max_v])
:modifiers [:distinct]
:group-by '(:date :e),
:with {:preag
{:select '([:datoms0.v :date]
[:datoms1.v :v]
[:datoms0.e :e]), ; Because we need to group on it.
:modifiers [:distinct],
:from '([:datoms datoms0] [:datoms datoms1]),
:where (list
:and
[:= :datoms0.a (:foo/visitedAt attrs)]
(list :> :datoms0.v (sql/param :then))
[:= :datoms1.a (:foo/points attrs)]
[:= :datoms0.e :datoms1.e])}}
:from [:preag]}
(query/context->sql-clause context)))))
(deftest-db test-get-else conn
(let [attrs (<? (<initialize-with-schema conn page-schema))]
(is (= {:select (list
[:datoms0.e :page]
[{:select [(sql/call
:coalesce
{:select [:v],
:from [:datoms],
:where [:and
[:= 'a 65540]
[:= 'e :datoms0.e]],
:limit 1}
"No title")],
:limit 1} :title]),
:modifiers [:distinct],
:from '([:datoms datoms0]),
:where (list :and [:= :datoms0.a 65539])}
(expand '[:find ?page ?title :in $
:where
[?page :page/url _]
[(get-else $ ?page :page/title "No title") ?title]]
conn)))))

16
test/datomish/test/util.cljc
View file

@ -9,6 +9,22 @@
(is (= :x (util/var->sql-var '?x)))
(is (= :XX (util/var->sql-var '?XX))))
#?(:cljs
(deftest test-integer?-js
(is (integer? 0))
(is (integer? 5))
(is (integer? 50000000000))
(is (integer? 5.00)) ; Because JS.
(is (not (integer? 5.1)))))
#?(:clj
(deftest test-integer?-clj
(is (integer? 0))
(is (integer? 5))
(is (integer? 50000000000))
(is (not (integer? 5.00)))
(is (not (integer? 5.1)))))
#?(:cljs
(deftest test-raise
(let [caught

466
test/datomish/tofinoish_test.cljc Normal file
View file

@ -0,0 +1,466 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
(ns datomish.tofinoish-test
#?(:cljs
(:require-macros
[datomish.pair-chan :refer [go-pair <?]]
[datomish.node-tempfile-macros :refer [with-tempfile]]
[cljs.core.async.macros :as a :refer [go]]))
(:require
[datomish.api :as d]
[datomish.util :as util]
#?@(:clj [[datomish.jdbc-sqlite]
[datomish.pair-chan :refer [go-pair <?]]
[tempfile.core :refer [tempfile with-tempfile]]
[datomish.test-macros :refer [deftest-async deftest-db]]
[clojure.test :as t :refer [is are deftest testing]]
[clojure.core.async :refer [go <! >!]]])
#?@(:cljs [[datomish.promise-sqlite]
[datomish.pair-chan]
[datomish.test-macros :refer-macros [deftest-async deftest-db]]
[datomish.node-tempfile :refer [tempfile]]
[cljs.test :as t :refer-macros [is are deftest testing async]]
[cljs.core.async :as a :refer [<! >!]]]))
#?(:clj
(:import [clojure.lang ExceptionInfo]))
#?(:clj
(:import [datascript.db DB])))
#?(:cljs
(def Throwable js/Error))
(def page-schema
[{:db/id (d/id-literal :db.part/user)
:db/ident :page/url
:db/valueType :db.type/string ; Because not all URLs are java.net.URIs. For JS we may want to use /uri.
:db/cardinality :db.cardinality/one
:db/unique :db.unique/identity
:db/doc "A page's URL."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :page/title
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one ; We supersede as we see new titles.
:db/doc "A page's title."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :page/starred
:db/valueType :db.type/boolean
:db/cardinality :db.cardinality/one
:db/doc "Whether the page is starred."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :page/visit
:db/valueType :db.type/ref
:db/cardinality :db.cardinality/many
:db/doc "A visit to the page."
:db.install/_attribute :db.part/db}])
(def visit-schema
[{:db/id (d/id-literal :db.part/user)
:db/ident :visit/visitAt
:db/valueType :db.type/instant
:db/cardinality :db.cardinality/many
:db/doc "The instant of the visit."
:db.install/_attribute :db.part/db}])
(def session-schema
[{:db/id (d/id-literal :db.part/user)
:db/ident :session/startedFromAncestor
:db/valueType :db.type/ref ; To a session.
:db/cardinality :db.cardinality/one
:db/doc "The ancestor of a session."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :session/startedInScope
:db/valueType :db.type/string
:db/cardinality :db.cardinality/one
:db/doc "The parent scope of a session."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :session/startReason
:db/valueType :db.type/string ; TODO: enum?
:db/cardinality :db.cardinality/many
:db/doc "The start reasons of a session."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :session/endReason
:db/valueType :db.type/string ; TODO: enum?
:db/cardinality :db.cardinality/many
:db/doc "The end reasons of a session."
:db.install/_attribute :db.part/db}
{:db/id (d/id-literal :db.part/user)
:db/ident :event/session
:db/valueType :db.type/ref ; To a session.
:db/cardinality :db.cardinality/one
:db/doc "The session in which a tx took place."
:db.install/_attribute :db.part/db}])
(def save-schema
[{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/ref
:db/ident :save/page}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/instant
:db/ident :save/savedAt}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/string
:db/fulltext true
:db/ident :save/title}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/string
:db/fulltext true
:db/ident :save/excerpt}
{:db/id (d/id-literal :db.part/user)
:db.install/_attribute :db.part/db
:db/cardinality :db.cardinality/one
:db/valueType :db.type/string
:db/fulltext true
:db/ident :save/content}])
(def tofino-schema (concat page-schema visit-schema session-schema save-schema))
(defn instant [x]
#?(:cljs x)
#?(:clj (.getTime x)))
(defn now []
#?(:cljs (js/Date.))
#?(:clj (java.util.Date.)))
;; Returns the session ID.
(defn <start-session [conn {:keys [ancestor scope reason]
:or {reason "none"}}]
(let [id (d/id-literal :db.part/user -1)
base {:db/id id
:session/startedInScope (str scope)
:session/startReason reason}
datoms
(if ancestor
[(assoc base :session/startedFromAncestor ancestor)
{:db/id :db/tx
:event/session ancestor}]
[base])]
(go-pair
(->
(<? (d/<transact! conn datoms))
:tempids
(get id)))))
(defn <end-session [conn {:keys [session reason]
:or {reason "none"}}]
(d/<transact!
conn
[{:db/id :db/tx
:event/session session} ; So meta!
{:db/id session
:session/endReason reason}]))
(defn <active-sessions [db]
(d/<q
db
'[:find ?id ?reason ?ts :in $
:where
[?id :session/startReason ?reason ?tx]
[?tx :db/txInstant ?ts]
(not-join [?id]
[?id :session/endReason _])]
{}))
(defn <ended-sessions [db]
(d/<q
db
'[:find ?id ?endReason ?ts :in $
:where
[?id :session/endReason ?endReason ?tx]
[?tx :db/txInstant ?ts]]
{}))
(defn <star-page [conn {:keys [url uri title session]}]
(let [page (d/id-literal :db.part/user -1)]
(d/<transact!
conn
[{:db/id :db/tx
:event/session session}
(merge
(when title
{:page/title title})
{:db/id page
:page/url (or uri url)
:page/starred true})])))
(defn <starred-pages [db]
(go-pair
(->>
(<?
(d/<q
db
'[:find ?page ?uri ?title ?starredOn
:in $
:where
[?page :page/starred true ?tx]
[?tx :db/txInstant ?starredOn]
[?page :page/url ?uri]
[?page :page/title ?title] ; N.B., this means we will exclude pages with no title.
]
{}))
(map (fn [[page uri title starredOn]]
{:page page :uri uri :title title :starredOn starredOn})))))
(defn <save-page [conn {:keys [url uri title session excerpt content]}]
(let [save (d/id-literal :db.part/user -1)
page (d/id-literal :db.part/user -2)]
(d/<transact!
conn
[{:db/id :db/tx
:event/session session}
{:db/id page
:page/url (or uri url)}
(merge
{:db/id save
:save/savedAt (now)
:save/page page}
(when title
{:save/title title})
(when excerpt
{:save/excerpt excerpt})
(when content
{:save/content content}))])))
(defn <saved-pages [db]
(d/<q db
'[:find ?page ?url ?title ?excerpt
:in $
:where
[?save :save/page ?page]
[?page :page/url ?url]
[(get-else $ ?save :save/title "") ?title]
[(get-else $ ?save :save/excerpt "") ?excerpt]]
{}))
(defn <saved-pages-matching-string [db string]
(d/<q db
{:find '[?page ?url ?title ?excerpt]
:in '[$]
:where [[(list 'fulltext '$ :any string) '[[?save]]]
'[?save :save/page ?page]
'[?page :page/url ?url]
'[(get-else $ ?save :save/title "") ?title]
'[(get-else $ ?save :save/excerpt "") ?excerpt]]}
{}))
;; TODO: return ID?
(defn <add-visit [conn {:keys [url uri title session]}]
(let [visit (d/id-literal :db.part/user -1)
page (d/id-literal :db.part/user -2)]
(d/<transact!
conn
[{:db/id :db/tx
:event/session session}
{:db/id visit
:visit/visitAt (now)}
(merge
(when title
{:page/title title})
{:db/id page
:page/url (or uri url)
:page/visit visit})])))
(defn- third [x]
(nth x 2))
(defn <visited [db
{:keys [limit since]
:or {limit 10}}]
(let [where
(if since
'[[?visit :visit/visitAt ?time]
[(> ?time ?since)]
[?page :page/visit ?visit]
[?page :page/url ?uri]
[(get-else $ ?page :page/title "") ?title]]
'[[?page :page/visit ?visit]
[?visit :visit/visitAt ?time]
[?page :page/url ?uri]
[(get-else $ ?page :page/title "") ?title]])]
(go-pair
(let [rows (<? (d/<q
db
{:find '[?uri ?title (max ?time)]
:in (if since '[$ ?since] '[$])
:where where}
{:since since}))]
(->>
rows
(sort-by (comp unchecked-negate third)) ;; TODO: these should be dates!
(take limit)
(map (fn [[uri title lastVisited]]
{:uri uri :title title :lastVisited lastVisited})))))))
(defn <find-title [db url]
;; Until we support [:find ?title . :in…] we crunch this by hand.
(go-pair
(first
(first
(<?
(d/<q db
'[:find ?title :in $ ?url
:where
[?page :page/url ?url]
[(get-else $ ?page :page/title "") ?title]]
{:url url}))))))
;; Ensure that we can grow the schema over time.
(deftest-db test-schema-evolution conn
(<? (d/<transact! conn page-schema))
(<? (d/<transact! conn tofino-schema)))
(deftest-db test-starring conn
(<? (d/<transact! conn tofino-schema))
(let [session (<? (<start-session conn {:ancestor nil :scope "foo"}))
earliest (instant (now))]
(<? (<star-page conn {:uri "http://mozilla.org/"
:title "Mozilla"
:session session}))
(let [[moz & starred] (<? (<starred-pages (d/db conn)))]
(is (empty? starred))
(is (= "Mozilla" (:title moz)))
(is (<= earliest (:starredOn moz) (instant (now)))))))
(deftest-db test-simple-sessions conn
(<? (d/<transact! conn tofino-schema))
;; Start a session.
(let [session (<? (<start-session conn {:ancestor nil :scope "foo"}))]
(is (integer? session))
;; Now it's active.
(let [active (<? (<active-sessions (d/db conn)))]
(is (= 1 (count active)))
(is (= (first (first active))
session)))
;; There are no ended sessions yet.
(is (empty? (<? (<ended-sessions (d/db conn)))))
(let [earliest (instant (now))]
(<? (<add-visit conn {:uri "http://example.org/"
:title "Example Philanthropy Old"
:session session}))
(<? (<add-visit conn {:uri "http://example.com/"
:title "Example Commercial"
:session session}))
(<? (<add-visit conn {:uri "http://example.org/"
:title "Example Philanthropy New"
:session session}))
(let [latest (instant (now))
visited (<? (<visited (d/db conn) {:limit 3}))]
(is (= 2 (count visited)))
(is (= "http://example.org/" (:uri (first visited))))
(is (= "http://example.com/" (:uri (second visited))))
(is (<= earliest (:lastVisited (first visited)) latest))
(is (<= earliest (:lastVisited (second visited)) latest))
(is (>= (:lastVisited (first visited)) (:lastVisited (second visited))))))
(is (= "Example Philanthropy New"
(<? (<find-title (d/db conn) "http://example.org/"))))
;; Add a page with no title.
(<? (<add-visit conn {:uri "http://notitle.example.org/"
:session session}))
(is (= "" (<? (<find-title (d/db conn) "http://notitle.example.org/"))))
(is (= (select-keys (first (<? (<visited (d/db conn) {:limit 1})))
[:uri :title])
{:uri "http://notitle.example.org/"
:title ""}))
;; If we end this one, then it's no longer active but is ended.
(<? (<end-session conn {:session session}))
(is (empty? (<? (<active-sessions (d/db conn)))))
(is (= 1 (count (<? (<ended-sessions (d/db conn))))))))
(deftest-db test-saved-pages conn
(<? (d/<transact! conn tofino-schema))
;; Start a session.
(let [session (<? (<start-session conn {:ancestor nil :scope "foo"}))]
(<? (<save-page conn {:uri "http://example.com/apples/1"
:title "A page about apples."
:session session
:excerpt "This page tells you things about apples."
:content "<html><head><title>A page about apples.</title></head><body><p>Fruit content goes here.</p></body></html>"}))
(<? (<save-page conn {:uri "http://example.com/apricots/1"
:title "A page about apricots."
:session session
:excerpt nil
:content "<html><head><title>A page about apricots.</title></head><body><p>Fruit content goes here.</p></body></html>"}))
(<? (<save-page conn {:uri "http://example.com/bananas/2"
:title "A page about bananas"
:session session
:excerpt nil
:content nil}))
(let [db (d/db conn)]
;; Fetch all.
(let [all (sort-by first (<? (<saved-pages db)))]
(is (= 3 (count all)))
(let [[[apple-id apple-url apple-title apple-excerpt]
[apricot-id apricot-url apricot-title apricot-excerpt]
[banana-id banana-url banana-title banana-excerpt]]
all]
(is (= apple-url "http://example.com/apples/1"))
(is (= apple-title "A page about apples."))
(is (= apple-excerpt "This page tells you things about apples."))
(is (= apricot-url "http://example.com/apricots/1"))
(is (= apricot-title "A page about apricots."))
(is (= apricot-excerpt ""))
(is (= banana-url "http://example.com/bananas/2"))
(is (= banana-title "A page about bananas"))
(is (= banana-excerpt ""))))
;; Match against title.
(let [this-page (sort-by first (<? (<saved-pages-matching-string db "about apricots")))]
(is (= 1 (count this-page)))
(let [[[apricot-id apricot-url apricot-title apricot-excerpt]]
this-page]
(is (= apricot-url "http://example.com/apricots/1"))
(is (= apricot-title "A page about apricots."))
(is (= apricot-excerpt ""))))
;; Match against excerpt.
(let [this-page (sort-by first (<? (<saved-pages-matching-string db "This page")))]
(is (= 1 (count this-page)))
(let [[[apple-id apple-url apple-title apple-excerpt]]
this-page]
(is (= apple-url "http://example.com/apples/1"))
(is (= apple-title "A page about apples."))
(is (= apple-excerpt "This page tells you things about apples."))))
;; Match against content.
(let [fruit-content (sort-by first (<? (<saved-pages-matching-string db "Fruit content")))]
(is (= 2 (count fruit-content)))
(let [[[apple-id apple-url apple-title apple-excerpt]
[apricot-id apricot-url apricot-title apricot-excerpt]]
fruit-content]
(is (= apple-url "http://example.com/apples/1"))
(is (= apple-title "A page about apples."))
(is (= apple-excerpt "This page tells you things about apples."))
(is (= apricot-url "http://example.com/apricots/1"))
(is (= apricot-title "A page about apricots."))
(is (= apricot-excerpt "")))))))