Fix pull attribute ordering

src/dbval/db.clj

@@ -368,19 +368,54 @@
     :else
     v))
 
+(defn attr-sort-key
+  "Returns the serialized key used for attribute components in indexes."
+  [attr]
+  (when attr
+    (pr-str attr)))
+
+(defn compare-attr-keys
+  "Compares two serialized attribute keys (see `attr-sort-key`) in
+   code-point order — the order of their UTF-8 bytes, which is how the
+   store sorts serialized attribute components. Java's String compare
+   orders by UTF-16 code units instead, which disagrees for
+   supplementary-plane characters (e.g. emoji): surrogates sort below
+   U+E000..U+FFFF even though their code points are larger."
+  ^long [^String ka ^String kb]
+  (cond
+    (nil? ka) (if (nil? kb) 0 -1)
+    (nil? kb) 1
+    :else
+    (let [la (.length ka)
+          lb (.length kb)]
+      (loop [i (int 0)]
+        (if (and (< i la) (< i lb))
+          (let [ca (.codePointAt ka i)
+                cb (.codePointAt kb i)]
+            (if (= ca cb)
+              (recur (int (+ i (Character/charCount ca))))
+              (long (Integer/compare ca cb))))
+          (long (Integer/compare la lb)))))))
+
+(defn attr-compare
+  "Compares attributes in the same order as dbval indexes store them."
+  [a b]
+  (compare-attr-keys (attr-sort-key a)
+                     (attr-sort-key b)))
+
 (defn tuple-list
   [db order datom]
   (try
     (let [[e a v t added] datom]
       (case (keyword order)
         :eavt
-        (list (name order) e (when a (pr-str a)) (serialize-value db a v) t added)
+        (list (name order) e (attr-sort-key a) (serialize-value db a v) t added)
         :aevt
-        (list (name order) (when a (pr-str a)) e (serialize-value db a v) t added)
+        (list (name order) (attr-sort-key a) e (serialize-value db a v) t added)
         :avet
-        (list (name order) (when a (pr-str a)) (serialize-value db a v) e t added)
+        (list (name order) (attr-sort-key a) (serialize-value db a v) e t added)
         :teav
-        (list (name order) t e (when a (pr-str a)) (serialize-value db a v) added)
+        (list (name order) t e (attr-sort-key a) (serialize-value db a v) added)
         ))
     (catch Exception e
       (throw (ex-info "tuple-list failed"

src/dbval/pull_api.clj

@@ -139,7 +139,8 @@
 
         :let [^Datom datom (first-seq datoms)
               cmp          (when (and datom attr)
-                             (compare (.-name attr) (.-a datom)))
+                             (db/compare-attr-keys (.-sort-key ^PullAttr attr)
+                                                   (db/attr-sort-key (.-a datom))))
               attr-ahead?  (or (nil? attr) (and cmp (pos? cmp)))
               datom-ahead? (or (nil? datom) (and cmp (neg? cmp)))]
 
@@ -280,25 +281,29 @@
                  (nil? (.-first-attr pattern))
                  nil
 
-                 :let [from (.-name ^PullAttr (.-first-attr pattern))
-                       to   (.-name ^PullAttr (.-last-attr pattern))]
+                 :let [from   (.-name ^PullAttr (.-first-attr pattern))
+                       to-key (.-sort-key ^PullAttr (.-last-attr pattern))]
 
                  (instance? DB db)
                  (take-while (fn [datom]
                                (and (= (:e datom)
                                        id)
-                                    (<= (compare (:a datom)
-                                                 to)
+                                    (<= (db/compare-attr-keys
+                                          (db/attr-sort-key (:a datom))
+                                          to-key)
                                         0)))
                              (db/-seek-datoms db :eavt id from nil nil))
 
                  :else
-                 (->> (db/-seek-datoms db :eavt id nil nil nil))
-                 (take-while
-                   (fn [^Datom d]
-                     (and
-                       (= (.-e d) id)
-                       (<= (compare (.-a d) to) 0)))))]
+                 (->> (db/-seek-datoms db :eavt id nil nil nil)
+                      (take-while
+                        (fn [^Datom d]
+                          (and
+                            (= (.-e d) id)
+                            (<= (db/compare-attr-keys
+                                  (db/attr-sort-key (.-a d))
+                                  to-key)
+                                0))))))]
     (when (.-wildcard? pattern)
       (visit context :db.pull/wildcard id nil nil))
     (AttrsFrame.

src/dbval/pull_parser.clj

@@ -1,15 +1,17 @@
 (ns ^:no-doc dbval.pull-parser
   (:require
+    [clojure.string :as str]
     [dbval.built-ins :as built-ins]
     [dbval.db :as db]
     [dbval.util :as util]))
 
-(defrecord PullAttr [as default limit name pattern recursion-limit recursive? reverse? xform multival? ref? component?])
+(defrecord PullAttr [as default limit name pattern recursion-limit recursive? reverse? xform multival? ref? component? sort-key])
 
 (defrecord PullPattern [attrs first-attr last-attr reverse-attrs wildcard?])
 
 (def default-db-id-attr
-  (map->PullAttr {:name :db/id :as :db/id :xform identity}))
+  (map->PullAttr {:name :db/id :as :db/id :xform identity
+                  :sort-key (db/attr-sort-key :db/id)}))
 
 (def default-pattern-ref
   (map->PullPattern {:attrs (list default-db-id-attr)}))
@@ -35,15 +37,28 @@
     (throw (ex-info (str "Expected " expected ", got: " (pr-str fragment))
              {:error :parser/pull, :fragment fragment}))))
 
+(defn- normalize-attr-spec
+  "A string attr spec starting with \":\" is the string spelling of a
+   keyword attribute (e.g. \":name\" or \":ns/_ref\") — normalize it to
+   the keyword, so it compares equal to the keyword attrs datoms carry.
+   Other strings name genuine string attributes and stay as-is."
+  [attr-spec]
+  (if (and (string? attr-spec)
+           (str/starts-with? attr-spec ":"))
+    (keyword (subs attr-spec 1))
+    attr-spec))
+
 (defn parse-attr-name [db attr-spec]
-  (let [reverse?   (db/reverse-ref? attr-spec)
+  (let [attr-spec  (normalize-attr-spec attr-spec)
+        reverse?   (db/reverse-ref? attr-spec)
         name       (if reverse? (db/reverse-ref attr-spec) attr-spec)
         ref?       (db/ref? db name)
         component? (db/component? db name)
         multival?  (db/multival? db name)]
     (map->PullAttr
       {:as         attr-spec
        :name       name
+       :sort-key   (db/attr-sort-key name)
        :xform      identity
        :multival?  (when multival? true)
        :limit      (if multival? 1000 nil)
@@ -153,19 +168,26 @@
     (util/cond+
       (empty? pattern)
       (let [attrs       (.-attrs result)
-            db-id?      (fn [^PullAttr attr] (#{:db/id ":db/id"} (.-name attr)))
+            db-id?      (fn [^PullAttr attr] (= :db/id (.-name attr)))
             key-fn      (fn [^PullAttr attr]
-                          (let [name (:name attr)]
-                            (cond
-                              (keyword? name) name
-                              (= ":" (subs name 0 1)) (keyword (subs name 1))
-                              :eles (keyword name))))
+                          (if (db-id? attr)
+                            [1 nil]
+                            [0 (.-sort-key attr)]))
             attrs       (if (and
                               (.-wildcard? result)
                               (not (some db-id? (.-attrs result))))
                           (conj attrs default-db-id-attr)
                           attrs)
-            attrs       (list* (sort-by key-fn attrs))
+            ;; sort with the same code-point comparator the frame walk and
+            ;; the store use — default compare orders strings by UTF-16
+            ;; code units, which disagrees for supplementary-plane chars
+            attrs       (list* (sort-by key-fn
+                                        (fn [[group-a key-a] [group-b key-b]]
+                                          (let [c (compare group-a group-b)]
+                                            (if (zero? c)
+                                              (db/compare-attr-keys key-a key-b)
+                                              c)))
+                                        attrs))
             datom-attrs (remove db-id? attrs)
             first-attr  (first datom-attrs)
             last-attr   (last datom-attrs)]

test/dbval/test/pull_api.clj

@@ -79,6 +79,72 @@
         (d/pull-many (test-db) '[:name] [[:name "Petr"] [:name "Elizabeth"]
                                          [:name "Eunan"] [:name "Rebecca"]]))))
 
+(deftest test-pull-namespaced-attrs-after-ref-attr
+  (let [db (:db-after
+             (d/with
+               (d/empty-db
+                 {:type {:db/valueType :db.type/ref}
+                  :instagram.story.image.preview/blob {:db/valueType :db.type/ref}})
+               [{:db/id "image-type"
+                 :db/ident :type.instagram.story/image}
+                {:db/id "preview-blob"
+                 :blob/id :preview}
+                {:db/id "story-media"
+                 :type "image-type"
+                 :story-media/name "image.jpg"
+                 :instagram.story.image.preview/blob "preview-blob"}]))
+        story-media-eid (ffirst (d/q '[:find ?e
+                                       :where
+                                       [?e :story-media/name]]
+                                     db))]
+    (is (= {:instagram.story.image.preview/blob {:blob/id :preview}
+            :story-media/name "image.jpg"
+            :type {:db/ident :type.instagram.story/image}}
+           (d/pull db
+                   '[:story-media/name
+                     {:type [:db/ident]}
+                     {:instagram.story.image.preview/blob [:blob/id]}]
+                   story-media-eid)))))
+
+(deftest test-pull-filtered-db-is-bounded
+  ;; regression: the non-DB branch of attrs-frame had its take-while outside
+  ;; the ->>, returning an unbounded, entity-unguarded scan that leaked other
+  ;; entities' attribute values into the result
+  (let [e1 #uuid "11111111-1111-1111-1111-111111111111"
+        e2 #uuid "22222222-2222-2222-2222-222222222222"
+        db (:db-after
+             (d/with (d/empty-db)
+               [{:db/id e1 :name "First"}
+                {:db/id e2 :name "Second" :extra "must not leak"}]))
+        fdb (d/filter db (constantly true))]
+    (is (= {:name "First"}
+           (d/pull fdb [:name :extra] e1)))
+    (is (= {:name "Second" :extra "must not leak"}
+           (d/pull fdb [:name :extra] e2)))))
+
+(deftest test-pull-string-spelled-attrs
+  ;; regression: the string spelling of a keyword attribute (":name") was
+  ;; silently dropped after the parser stopped normalizing it
+  (is (= {:name "Petr"}
+         (d/pull (test-db) [":name"] [:name "Petr"])))
+  (let [result (d/pull (test-db) [":db/id" :name] [:name "Petr"])]
+    (is (= "Petr" (:name result)))
+    (is (uuid? (:db/id result)))))
+
+(deftest test-pull-supplementary-plane-attrs
+  ;; regression: attr-compare ordered attributes by UTF-16 code units while
+  ;; the store orders their serialized form by UTF-8 bytes (code points);
+  ;; the orders disagree for supplementary-plane characters, cutting the
+  ;; frame scan short
+  (let [attr-private (keyword "aa\ue000")   ;; U+E000: sorts high in UTF-16
+        attr-emoji   (keyword "aa\ud83d\ude00") ;; U+1F600: higher code point
+        db (:db-after
+             (d/with (d/empty-db)
+               [{:db/id "e" attr-private 1 attr-emoji 2}]))
+        eid (:e (first (d/datoms db :aevt attr-private)))]
+    (is (= {attr-private 1 attr-emoji 2}
+           (d/pull db [attr-private attr-emoji] eid)))))
+
 (deftest test-pull-reverse-attr-spec
   (is (= {:name "David" :_child [{:db/id (eid "petr")}]}
         (d/pull (test-db) '[:name :_child] [:name "David"])))

test/dbval/test/pull_parser.clj

@@ -29,7 +29,8 @@
 (defn attr [name & {:as args}]
   (dpp/map->PullAttr
     (merge
-      {:name name :xform identity :as name}
+      {:name name :xform identity :as name
+       :sort-key (db/attr-sort-key name)}
       (when (db/ref? @*db name) {:pattern dpp/default-pattern-ref})
       args)))