tx: enforce :db/ident immutability (prevent retarget + change)
ober
ddeb63f81804c1fd0aceec344e3f084f125e19ed
--- a/lib/jerboa-db/tx.ss +++ b/lib/jerboa-db/tx.ss @@ -197,6 +197,28 @@ d (loop (+ i 1))))))))) ) + ;; ---- Ident immutability (Datomic prevent-ident-retarget) ---- + ;; :db/ident must stay a stable 1:1 keyword<->entity mapping. Reject + ;; assigning a keyword already held by a different entity (retarget), and + ;; changing an entity's existing ident (jerboa's schema registry, keyed by + ;; ident, cannot follow a rename). Computed against the committed db, so + ;; re-transacting a brand-new attribute (fresh eid, no prior ident) is fine. + (define ident-attr* (schema-lookup-by-ident schema +db/ident+)) + (define ident-aid* (and ident-attr* (db-attribute-id ident-attr*))) + + (define (check-ident! eid new-ident) + (when ident-aid* + (let ([owner (find-entity-by-unique ident-attr* new-ident)]) + (when (and owner (not (= owner eid))) + (error 'transact! + (format ":db/ident ~a is already assigned to entity ~a; idents may not be reassigned" + new-ident owner)))) + (let ([cur (current-value eid ident-aid*)]) + (when (and cur (not (equal? (datom-v cur) new-ident))) + (error 'transact! + (format "entity ~a already has :db/ident ~a; idents are immutable (cannot change to ~a)" + eid (datom-v cur) new-ident)))))) + ;; Per-transaction value cache: O(1) lookup for cardinality/one checks. ;; Keyed by a composite fixnum (eid * 256 + aid) — no allocation per lookup. ;; Assumes aid < 256 (generous: schemas typically have < 100 attributes). @@ -290,6 +312,9 @@ (error 'transact! (format "Type mismatch for ~a: expected ~a, got ~a" attr-ident (db-attribute-value-type attr) final-val))) + ;; Enforce :db/ident immutability + (when (and ident-aid* (= aid ident-aid*)) + (check-ident! eid final-val)) ;; Check uniqueness (check-unique-value! attr eid final-val) ;; Cardinality/one: auto-retract old value. @@ -319,6 +344,8 @@ [(and (ref-type? attr) (tempid? cval)) (resolve-eid cval)] [else cval])]) + (when (and ident-aid* (= aid ident-aid*)) + (check-ident! eid final-val)) (check-unique-value! attr eid final-val) (when (cardinality-one? attr) (let ([old (or (tx-current-value eid aid) --- a/tests/test-core.ss +++ b/tests/test-core.ss @@ -831,6 +831,21 @@ [c-eid (caar (q '((find ?e) (where (?e n/name "C"))) d))]) (assert-equal (caar (q '((find ?c) (in $ ?p) (where (?p n/child ?c))) d p-eid)) c-eid)))) +(test "ident immutability: reject change and retarget, allow idempotent re-assert" + (let ([conn (connect ":memory:")]) + (transact! conn + (list '((db/ident . color/red) (db/valueType . db.type/string) (db/cardinality . db.cardinality/one)))) + (let ([red-eid (caar (q '((find ?e) (where (?e db/ident color/red))) (db conn)))]) + ;; changing an entity's existing ident is rejected + (assert-true (guard (exn [#t #t]) + (transact! conn (list `(db/add ,red-eid db/ident color/crimson))) #f)) + ;; retargeting color/red onto a different entity is rejected + (assert-true (guard (exn [#t #t]) + (transact! conn (list `(db/add 99999 db/ident color/red))) #f)) + ;; re-asserting the same ident on the same entity is allowed (idempotent) + (transact! conn (list `(db/add ,red-eid db/ident color/red))) + (assert-equal (caar (q '((find ?e) (where (?e db/ident color/red))) (db conn))) red-eid)))) + ;; ============================================================ ;; Report ;; ============================================================