fix: Scope reply commands to the nearest report only

Author: bzg

src/bone/commands.clj

@@ -348,14 +348,32 @@
       (re-find vote-down-pattern body-text) :down
       (re-find vote-null-pattern body-text) :null)))
 
+(defn vote-tx
+  "Pure: the transaction map recording `vote` for the voter, or nil
+  when it matches `current` (a no-op revote).  One entity per voter
+  per report: a revote carries the `existing` entity id explicitly --
+  no upsert through the unique attr at transact time."
+  [{:keys [vote-key report-eid email-eid voter-addr existing current vote]}]
+  (when (not= current vote)
+    (if existing
+      {:db/id       existing
+       :vote/email  email-eid
+       :vote/value  vote}
+      {:vote/key    vote-key
+       :vote/report report-eid
+       :vote/email  email-eid
+       :vote/value  vote
+       :vote/voter  voter-addr})))
+
 ;; ---------------------------------------------------------------------------
 ;; Command application (effectful)
 ;; ---------------------------------------------------------------------------
 
 (defn- ref-eid [v] (if (map? v) (:db/id v) v))
 
 (defn- apply-vote!
-  "Record a pre-detected `vote` (caller runs `detect-vote`)."
+  "Record a pre-detected `vote` (caller runs `detect-vote`); the tx
+  itself is built by the pure `vote-tx` (last vote wins)."
   [conn report-eid from-addr vote email delivery source-cfg]
   (if-not (common/sent-via-source-channel? delivery source-cfg)
     (log/info "Vote ignored (private email on public source)" from-addr)
@@ -365,22 +383,17 @@
           ;; keyed on the mid hash (unique attr, raw mids unbounded).
           addr       (some-> from-addr str/lower-case)
           vote-key   (str (common/mid-hash report-mid) ":" addr)
-          ;; One entity per voter per report; a new vote replaces the
-          ;; previous one (last vote wins).  Explicit :db/id on revote
-          ;; -- no upsert through the unique attr at transact time.
           existing   (d/entid db [:vote/key vote-key])
           current    (when existing
                        (:vote/value (d/pull db [:vote/value] existing)))]
-      (when (not= current vote)
-        (d/transact! conn [(if existing
-                             {:db/id       existing
-                              :vote/email  (:db/id email)
-                              :vote/value  vote}
-                             {:vote/key    vote-key
-                              :vote/report report-eid
-                              :vote/email  (:db/id email)
-                              :vote/value  vote
-                              :vote/voter  addr})])
+      (when-let [tx (vote-tx {:vote-key   vote-key
+                              :report-eid report-eid
+                              :email-eid  (:db/id email)
+                              :voter-addr addr
+                              :existing   existing
+                              :current    current
+                              :vote       vote})]
+        (d/transact! conn [tx])
         (tracking/bump-report-updated! conn report-eid)
         (log/info (cond-> (str "Vote " (case vote :up "+1" :down "-1" "0")
                                " by " from-addr)
@@ -650,26 +663,36 @@
       :unset-related    (str syntax ": " target-message-id)
       syntax)))
 
+(defn partition-lines-by-scope
+  "Pure decision behind `filter-permitted-lines`: split the `line-pred`
+  subset of `lines` into {:allowed [...] :denied [...]} by whether the
+  effective scope permits `from-addr` to act (`current-d` as in
+  `scope-permits?` -- a realized snapshot makes this side-effect
+  free)."
+  [lines current-d from-addr is-maintainer? line-pred]
+  (let [{allowed true denied false}
+        (group-by (fn [{:keys [scope attr]}]
+                    (boolean (scope-permits? scope attr from-addr
+                                             is-maintainer? current-d)))
+                  (filterv line-pred lines))]
+    {:allowed (vec allowed) :denied (vec denied)}))
+
 (defn- filter-permitted-lines
-  "Subset of `lines` passing `line-pred` whose scope permits
-  `from-addr` to act (`current-d` as in `scope-permits?`).  With a
-  non-nil `failure-ctx`, scope-rejected lines are recorded as
-  :insufficient-scope failures, audience :maintainers."
+  "Effectful shell over `partition-lines-by-scope`: with a non-nil
+  `failure-ctx`, each denied line is recorded as an
+  :insufficient-scope failure (audience :maintainers); the allowed
+  lines are returned."
   [lines current-d from-addr is-maintainer? line-pred failure-ctx]
-  ;; Eager realization via `filterv` so the recording side effect in
-  ;; the denial branch fires deterministically, regardless of whether
-  ;; callers seq or reduce over the result.
-  (filterv (fn [{:keys [scope attr] :as line}]
-             (and (line-pred line)
-                  (or (scope-permits? scope attr from-addr is-maintainer? current-d)
-                      (do (when failure-ctx
-                            (record-failure!
-                             (assoc failure-ctx
-                                    :reason    :insufficient-scope
-                                    :audience  :maintainers
-                                    :command   (describe-denied-line line))))
-                          false))))
-           lines))
+  (let [{:keys [allowed denied]}
+        (partition-lines-by-scope lines current-d from-addr
+                                  is-maintainer? line-pred)]
+    (when failure-ctx
+      (doseq [line denied]
+        (record-failure! (assoc failure-ctx
+                                :reason    :insufficient-scope
+                                :audience  :maintainers
+                                :command   (describe-denied-line line)))))
+    allowed))
 
 (defn- report-eid-by-mid
   "Report eid for `target-mid`, matching the root or any thread
@@ -1121,32 +1144,43 @@
   [attr]
   (some-> (attr->word-cmd attr) :id name str/capitalize (str ".")))
 
+(defn partition-words-by-scope
+  "Pure decision behind `filter-words-by-scope`: split `word-result`
+  into {:allowed <word-map-or-nil> :denied [attr ...]} by each
+  bareword's effective scope.  :report/close-reason is no bareword:
+  it rides back onto a non-empty allowed map (build-word-tx only
+  consumes it when :report/closed is set)."
+  [word-result overrides is-maintainer?]
+  (let [{allowed true denied false}
+        (group-by (fn [[attr _]]
+                    (let [cmd   (attr->word-cmd attr)
+                          scope (or (:scope (get overrides (:id cmd))) (:scope cmd))]
+                      (word-scope-permits? scope is-maintainer?)))
+                  (dissoc word-result :report/close-reason))
+        allowed-map (into {} allowed)]
+    {:allowed (when (seq allowed-map)
+                (cond-> allowed-map
+                  (:report/close-reason word-result)
+                  (assoc :report/close-reason (:report/close-reason word-result))))
+     :denied  (mapv key denied)}))
+
 (defn- filter-words-by-scope
-  "Filter `word-result` to the subset allowed by the effective scope
-  for each bareword.  When `failure-ctx` is non-nil, barewords that fail
-  the scope check are recorded as :insufficient-scope failures with
-  \":audience :maintainers\", so denied attempts surface to maintainer
-  subscribers via the notification loop."
+  "Effectful shell over `partition-words-by-scope`: with a non-nil
+  `failure-ctx`, each denied bareword is recorded as an
+  :insufficient-scope failure (audience :maintainers, so denied
+  attempts surface to maintainer subscribers via the notification
+  loop); the allowed map is returned."
   [word-result overrides is-maintainer? failure-ctx]
   (when word-result
-    (let [filtered (into {}
-                         (keep (fn [[attr :as entry]]
-                                 (let [cmd   (attr->word-cmd attr)
-                                       scope (or (:scope (get overrides (:id cmd))) (:scope cmd))]
-                                   (if (word-scope-permits? scope is-maintainer?)
-                                     entry
-                                     (do (when failure-ctx
-                                           (record-failure!
-                                            (assoc failure-ctx
-                                                   :reason   :insufficient-scope
-                                                   :audience :maintainers
-                                                   :command  (describe-denied-word attr))))
-                                         nil)))))
-                         (dissoc word-result :report/close-reason))]
-      (when (seq filtered)
-        (cond-> filtered
-          (:report/close-reason word-result) (assoc :report/close-reason
-                                                    (:report/close-reason word-result)))))))
+    (let [{:keys [allowed denied]}
+          (partition-words-by-scope word-result overrides is-maintainer?)]
+      (when failure-ctx
+        (doseq [attr denied]
+          (record-failure! (assoc failure-ctx
+                                  :reason   :insufficient-scope
+                                  :audience :maintainers
+                                  :command  (describe-denied-word attr)))))
+      allowed)))
 
 ;; Carrier-eligible commands: when a mail simultaneously creates a new
 ;; report AND carries one of these annotations, the annotation applies

src/bone/digest.clj

@@ -50,7 +50,9 @@
                               (:email/in-reply-to email)))
 
 (defn- reports-by-hash
-  "Report eids whose root or any descendant has the mid-hash `h`.
+  "Reports matched by the mid-hash `h`: {:root report-eid-or-nil
+  :encl #{eids}} -- :root when `h` is a report's own message-id,
+  :encl the reports counting that email among their descendants.
   Resolution via bone.lookup, descendant join eid-bound (see the
   bone.lookup ns docstring)."
   [db h]
@@ -59,7 +61,7 @@
         as-desc (when email-e
                   (d/q '[:find [?r ...] :in $ ?e :where [?r :report/descendants ?e]]
                        db email-e))]
-    (cond-> (set as-desc) as-root (conj as-root))))
+    {:root as-root :encl (set as-desc)}))
 
 (defn- email-ancestors
   "Ancestor mids of the stored email `eid` (root first).  Used by
@@ -74,10 +76,42 @@
   "Upper bound on transitive ancestor splicing per `thread-lookup` call."
   32)
 
+(defn thread-step
+  "Pure arbitration of one ancestor mid during `thread-lookup`, walked
+  nearest-first.  `state` is {:all #{eids} :nearest nil-or-#{eids}
+  :cand nil-or-#{eids}} -- :cand holds the enclosing reports of the
+  closest hit while no root has decided.  `hit` is `reports-by-hash`'s
+  {:root :encl}.  A root decides :nearest: the root itself when the
+  undecided set contains it (or there is none) -- a reply to a patch
+  targets the patch, never the cover letter (or bug) whose thread
+  merely encloses it -- else the undecided set, which belongs to a
+  closer thread.  Returns the next state."
+  [{:keys [nearest cand] :as state} {:keys [root encl]}]
+  (let [eids     (cond-> (or encl #{}) root (conj root))
+        nearest' (or nearest
+                     (cond
+                       (and root (or (nil? cand) (contains? cand root))) #{root}
+                       root cand
+                       :else nil))
+        cand'    (if (and (nil? nearest') (nil? cand) (seq encl)) encl cand)]
+    (-> state
+        (update :all into eids)
+        (assoc :nearest nearest' :cand cand'))))
+
+(defn finalize-thread-lookup
+  "Pure: end of the walk -- an undecided candidate set becomes the
+  :nearest (no ancestor ever resolved as a root), and the working
+  :cand key is dropped."
+  [{:keys [nearest cand] :as state}]
+  (-> state
+      (assoc :nearest (or nearest cand))
+      (dissoc :cand)))
+
 (defn thread-lookup
   "Walk `email`'s ancestor mids nearest-first.  Returns
   `{:all #{eids} :nearest #{eids}}` -- :all is every report matched
-  by any ancestor, :nearest is the closest match (nil if none).
+  by any ancestor, :nearest is the closest match (nil if none), both
+  arbitrated by the pure `thread-step`/`finalize-thread-lookup`.
   When an ancestor mid matches a stored email with no report, that
   email's own ancestors are spliced into the walk (bounded by
   `thread-lookup-max-splices`) so pending intermediates don't orphan
@@ -86,26 +120,24 @@
   (loop [stack   (vec (ancestor-mids email))  ; root-first; peek = nearest
          seen    #{}
          splices 0
-         acc     {:all #{} :nearest nil}]
+         state   {:all #{} :nearest nil :cand nil}]
     (if (empty? stack)
-      acc
+      (finalize-thread-lookup state)
       (let [mid    (peek stack)
             stack' (pop stack)]
         (if (contains? seen mid)
-          (recur stack' seen splices acc)
-          (let [seen' (conj seen mid)
-                h     (common/mid-hash mid)
-                eids  (reports-by-hash db h)
-                acc'  (cond-> acc
-                        (seq eids)                              (update :all into eids)
-                        (and (seq eids) (nil? (:nearest acc))) (assoc :nearest eids))]
-            (if (and (empty? eids)
+          (recur stack' seen splices state)
+          (let [seen'  (conj seen mid)
+                h      (common/mid-hash mid)
+                {:keys [root encl] :as hit} (reports-by-hash db h)
+                state' (thread-step state hit)]
+            (if (and (nil? root) (empty? encl)
                      (< splices thread-lookup-max-splices))
               (if-let [ancestors (some->> (lookup/email-eid-by-hash db h)
                                           (email-ancestors db))]
-                (recur (into stack' ancestors) seen' (inc splices) acc')
-                (recur stack' seen' splices acc'))
-              (recur stack' seen' splices acc'))))))))
+                (recur (into stack' ancestors) seen' (inc splices) state')
+                (recur stack' seen' splices state'))
+              (recur stack' seen' splices state'))))))))
 
 ;; ---------------------------------------------------------------------------
 ;; DB operations