diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 91172382..dd3dea9c 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -550,12 +550,48 @@ ;; separate: its own "type:id" nodes in lib/relations, untouched by this.) (define host/blog--edge-key (fn (src kind dst) (str "edge:" src "|" kind "|" dst))) +;; H7: per-(node,kind) ADJACENCY STREAMS — the hot reads (out/in/out-raw) fold ONLY the pair's +;; event stream (append-only: no read-modify-write race; a duplicate :add folds to a set, so +;; concurrent writers are benign). The edge:* kv rows are still written — they feed the two +;; whole-graph consumers (subtype-closure, the relations admin block) and legacy-store migration +;; (host/blog-reindex-edges! at boot). +(define host/blog--rel-stream (fn (src kind) (str "rel:" src "|" kind))) +(define host/blog--rin-stream (fn (dst kind) (str "rin:" dst "|" kind))) +(define host/blog--adj-fold + (fn (stream field) + (reduce (fn (acc e) + (let ((v (get (persist/event-data e) field))) + (cond ((= (persist/event-type e) :add) + (if (contains? acc v) acc (concat acc (list v)))) + ((= (persist/event-type e) :del) + (filter (fn (x) (not (= x v))) acc)) + (else acc)))) + (list) (persist/read host/blog-store stream)))) +(define host/blog--adj-out (fn (src kind) (host/blog--adj-fold (host/blog--rel-stream src kind) "dst"))) +(define host/blog--adj-in (fn (dst kind) (host/blog--adj-fold (host/blog--rin-stream dst kind) "src"))) + (define host/blog--add-edge! (fn (src dst kind) - (persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1))) + (begin + (persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1) + (when (not (contains? (host/blog--adj-out src kind) dst)) + (persist/append host/blog-store (host/blog--rel-stream src kind) :add 0 {"dst" dst})) + (when (not (contains? (host/blog--adj-in dst kind) src)) + (persist/append host/blog-store (host/blog--rin-stream dst kind) :add 0 {"src" src}))))) (define host/blog--del-edge! (fn (src dst kind) - (persist/backend-kv-delete host/blog-store (host/blog--edge-key src kind dst)))) + (begin + (persist/backend-kv-delete host/blog-store (host/blog--edge-key src kind dst)) + (when (contains? (host/blog--adj-out src kind) dst) + (persist/append host/blog-store (host/blog--rel-stream src kind) :del 0 {"dst" dst})) + (when (contains? (host/blog--adj-in dst kind) src) + (persist/append host/blog-store (host/blog--rin-stream dst kind) :del 0 {"src" src}))))) +;; MIGRATION: rebuild the adjacency streams from legacy edge:* rows (idempotent — add-edge! skips +;; already-indexed pairs). serve.sh calls this once at boot so pre-H7 stores read correctly. +(define host/blog-reindex-edges! + (fn () + (for-each (fn (e) (host/blog--add-edge! (get e :src) (get e :dst) (get e :kind))) + (host/blog--all-edges)))) ;; A symmetric kind writes both directions, so children alone read it from either ;; side; a directed kind writes one edge (the inverse is host/blog-in). @@ -612,29 +648,20 @@ (map host/blog--parse-edge-key (persist/backend-kv-keys host/blog-store))))) ;; outgoing targets / incoming sources of `slug` under `kind`, as existing slugs. +;; H7: out/in read the pair's ADJACENCY STREAM — O(edges of this node under this kind), not a +;; full kv scan. out/in filter to existing local slugs; the -raw variants keep cross-domain refs. (define host/blog-out (fn (slug kind) (let ((existing (host/blog-slugs))) - (filter (fn (s) (contains? existing s)) - (reduce (fn (acc e) - (if (and (= (get e :src) slug) (= (get e :kind) kind)) - (concat acc (list (get e :dst))) acc)) - (list) (host/blog--all-edges)))))) + (filter (fn (s) (contains? existing s)) (host/blog--adj-out slug kind))))) ;; unfiltered outgoing edges — includes CROSS-DOMAIN targets (a post/order on another peer, which ;; isn't a local slug so host/blog-out would drop it). Used for federated links (allocated, sold). -(define host/blog--out-raw - (fn (slug kind) - (reduce (fn (acc e) - (if (and (= (get e :src) slug) (= (get e :kind) kind)) (concat acc (list (get e :dst))) acc)) - (list) (host/blog--all-edges)))) +(define host/blog--out-raw (fn (slug kind) (host/blog--adj-out slug kind))) +(define host/blog--in-raw (fn (slug kind) (host/blog--adj-in slug kind))) (define host/blog-in (fn (slug kind) (let ((existing (host/blog-slugs))) - (filter (fn (s) (contains? existing s)) - (reduce (fn (acc e) - (if (and (= (get e :dst) slug) (= (get e :kind) kind)) - (concat acc (list (get e :src))) acc)) - (list) (host/blog--all-edges)))))) + (filter (fn (s) (contains? existing s)) (host/blog--adj-in slug kind))))) ;; back-compat: "related posts" is just the symmetric "related" kind. (define host/blog-related (fn (slug) (host/blog-out slug "related"))) @@ -714,25 +741,22 @@ ;; operand edges live in the KV ONLY (read back via host/blog-out), NOT in lib/relations: ;; conj/disj are structural, and feeding extra kinds into the Datalog graph blows up its ;; per-query re-saturation. host/blog-load-edges! skips them on replay for the same reason. -(define host/blog--add-edge-kv! - (fn (src dst kind) - (persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1))) (define host/blog-make-and! (fn (t a b) (begin (host/blog-seed! t t (str "(article (h1 \"" t "\") (p \"An intersection type (" a " ∧ " b ") — its instances are exactly those that are instances of BOTH.\"))") "published") - (host/blog--add-edge-kv! t a "conj") - (host/blog--add-edge-kv! t b "conj")))) + (host/blog--add-edge! t a "conj") + (host/blog--add-edge! t b "conj")))) (define host/blog-make-or! (fn (t a b) (begin (host/blog-seed! t t (str "(article (h1 \"" t "\") (p \"A union type (" a " ∨ " b ") — its instances are those that are instances of EITHER.\"))") "published") - (host/blog--add-edge-kv! t a "disj") - (host/blog--add-edge-kv! t b "disj")))) + (host/blog--add-edge! t a "disj") + (host/blog--add-edge! t b "disj")))) ;; the EXTENT of a type expression: operands' extents combined by set ops (recursive). ;; A plain type (no operands) falls through to its instances. (define host/blog-instances-of-expr diff --git a/lib/host/serve.sh b/lib/host/serve.sh index af582d6b..70c5b99b 100755 --- a/lib/host/serve.sh +++ b/lib/host/serve.sh @@ -304,6 +304,10 @@ EPOCH=1 echo "(eval \"(host/blog--set-actor! \\\"${SX_ACTOR:-site}\\\" \\\"${SX_SELF_URL:-}\\\")\")" EPOCH=$((EPOCH+1)) echo "(epoch $EPOCH)" + # H7: migrate legacy edge:* rows into the per-pair adjacency streams (idempotent). + echo "(eval \"(host/blog-reindex-edges!)\")" + EPOCH=$((EPOCH+1)) + echo "(epoch $EPOCH)" echo "(eval \"(host/blog-load-followers!)\")" EPOCH=$((EPOCH+1)) echo "(epoch $EPOCH)" diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 9af0e903..3c9e8bd1 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -1534,6 +1534,32 @@ (len (filter (fn (e) (= (get e "verb") "h6-ping")) host/blog--flow-log))) 2) +;; ── HARDENING H7: adjacency STREAMS — per-(node,kind) reads, not full kv scans ──────────── +;; relate!/unrelate! maintain per-pair event streams (rel:src|kind ← {:dst}, rin:dst|kind ← +;; {:src}); out/in/out-raw fold ONLY the pair's stream (O(edges of that node), not O(all keys)). +;; Legacy stores migrate via host/blog-reindex-edges! at boot. +(host/blog-use-store! (persist/open)) +(host/blog-put! "h7a" "a" "(article (h1 \"a\"))" "published") +(host/blog-put! "h7b" "b" "(article (h1 \"b\"))" "published") +(host/blog-relate! "h7a" "h7b" "h7k") + +(host-bl-test "H7: relate! writes the forward adjacency stream rel:src|kind" + (>= (len (persist/read host/blog-store "rel:h7a|h7k")) 1) true) +(host-bl-test "H7: relate! writes the reverse adjacency stream rin:dst|kind" + (>= (len (persist/read host/blog-store "rin:h7b|h7k")) 1) true) +(host-bl-test "H7: out-raw reads through (regression)" + (host/blog--out-raw "h7a" "h7k") (list "h7b")) +(host-bl-test "H7: in reads through (regression)" + (host/blog-in "h7b" "h7k") (list "h7a")) +(host-bl-test "H7: unrelate! removes from both directions (regression)" + (begin (host/blog-unrelate! "h7a" "h7b" "h7k") + (list (host/blog--out-raw "h7a" "h7k") (host/blog-in "h7b" "h7k"))) + (list (list) (list))) +(host-bl-test "H7: re-relate after remove works (add/del/add folds correctly)" + (begin (host/blog-relate! "h7a" "h7b" "h7k") + (host/blog--out-raw "h7a" "h7k")) + (list "h7b")) + (define host-bl-tests-run! (fn ()