Issue 275: Alternative approach using a listener

src/main/clojure/clara/rules/engine.cljc

@@ -1739,7 +1739,9 @@
           ;; group before continuing.
           (do
             (flush-updates *current-session*)
-            (recur (mem/next-activation-group transient-memory) next-group))
+            (let [upcoming-group (mem/next-activation-group transient-memory)]
+              (l/activation-group-transition! listener next-group upcoming-group)
+              (recur upcoming-group next-group)))
 
           (do
 
@@ -1808,7 +1810,7 @@
                                                                []
                                                                (l/get-children p-listener)))
                                                            (catch #?(:clj Exception :cljs :default)
-                                                             listener-exception
+                                                               listener-exception
                                                              listener-exception))}
                                              e)))))
 
@@ -1823,7 +1825,9 @@
         ;; updates and recur with a potential new activation group
         ;; since a flushed item may have triggered one.
         (when (flush-updates *current-session*)
-          (recur (mem/next-activation-group transient-memory) next-group))))))
+          (let [upcoming-group (mem/next-activation-group transient-memory)]
+            (l/activation-group-transition! listener next-group upcoming-group)
+            (recur upcoming-group next-group)))))))
 
 (deftype LocalSession [rulebase memory transport listener get-alphas-fn pending-operations]
   ISession

src/main/clojure/clara/rules/listener.cljc

@@ -23,6 +23,7 @@
   (remove-activations! [listener node activations])
   (fire-activation! [listener activation resulting-operations])
   (fire-rules! [listener node])
+  (activation-group-transition! [listener original-group new-group])
   (to-persistent! [listener]))
 
 ;; A listener that does nothing.
@@ -60,6 +61,8 @@
     listener)
   (fire-rules! [listener node]
     listener)
+  (activation-group-transition! [listener original-group new-group]
+    listener)
   (to-persistent! [listener]
     listener)
 
@@ -136,6 +139,10 @@
     (doseq [child children]
       (fire-rules! child node)))
 
+  (activation-group-transition! [listener original-group new-group]
+    (doseq [child children]
+      (activation-group-transition! child original-group new-group)))
+
   (to-persistent! [listener]
     (delegating-listener (map to-persistent! children))))
 

src/main/clojure/clara/tools/internal/inspect.cljc

@@ -44,6 +44,8 @@
     listener)
   (remove-activations! [listener node activations]
     listener)
+  (activation-group-transition! [listener previous-group new-group]
+    listener)
   (fire-rules! [listener node]
     listener))
 

src/main/clojure/clara/tools/loop_detector.cljc

@@ -0,0 +1,51 @@
+(ns clara.tools.loop-detector
+  (:require [clara.rules.listener :as l]
+            [clara.rules.engine :as eng]))
+
+(deftype LoopDetectorListener [cycles-count max-cycles fn-on-limit]
+    l/ITransientEventListener
+  (left-activate! [listener node tokens]
+    listener)
+  (left-retract! [listener node tokens]
+    listener)
+  (right-activate! [listener node elements]
+    listener)
+  (right-retract! [listener node elements]
+    listener)
+  (insert-facts! [listener node token facts]
+    listener)
+  (alpha-activate! [listener node facts]
+    listener)
+  (insert-facts-logical! [listener node token facts]
+    listener)
+  (retract-facts! [listener node token facts]
+    listener)
+  (alpha-retract! [listener node facts]
+    listener)
+  (retract-facts-logical! [listener node token facts]
+    listener)
+  (add-accum-reduced! [listener node join-bindings result fact-bindings]
+    listener)
+  (remove-accum-reduced! [listener node join-bindings fact-bindings]
+    listener)
+  (add-activations! [listener node activations]
+    listener)
+  (remove-activations! [listener node activations]
+    listener)
+  (fire-activation! [listener activation resulting-operations]
+    listener)
+  (fire-rules! [listener node]
+    listener)
+  (activation-group-transition! [listener original-group new-group]
+    (when (>= @cycles-count max-cycles)
+      (fn-on-limit))
+    (swap! cycles-count inc))
+  (to-persistent! [listener]
+    (LoopDetectorListener. (atom 0) max-cycles fn-on-limit))
+
+  l/IPersistentEventListener
+  (to-transient [listener]
+    listener))
+
+(defn with-loop-detection [session fn-on-limit max-cycles]
+  (eng/with-listener session (LoopDetectorListener. (atom 0) max-cycles fn-on-limit)))

src/main/clojure/clara/tools/testing_utils.cljc

@@ -203,3 +203,19 @@
                      e# \newline
                      "Non matches found: " \newline
                      res#)))))))
+
+#?(:clj
+   (defn ex-data-maps
+     "Given a Throwable, return in order the ExceptionInfo data maps for all items in the
+      chain that implement IExceptionInfo and have nonempty data maps."
+     [t]
+     (let [throwables  ((fn append-self
+                          [prior t1]
+                          (if t1
+                            (append-self (conj prior t1) (.getCause ^Throwable t1))
+                            prior))
+                        []
+                        t)]
+       (into []
+             (comp (map ex-data))
+             throwables))))

src/main/clojure/clara/tools/tracing.cljc

@@ -69,6 +69,9 @@
   (fire-rules! [listener node]
     (append-trace listener {:type :fire-rules :node-id (:id node)}))
 
+  (activation-group-transition! [listener previous-group new-group]
+    (append-trace listener {:type :activation-group-transition :new-group new-group :previous-group previous-group}))
+
   (to-persistent! [listener]
     (PersistentTracingListener. @trace)))
 

src/test/clojure/clara/test_infinite_loops.clj

@@ -0,0 +1,189 @@
+(ns clara.test-infinite-loops
+  (:require [clojure.test :refer :all]
+            [clara.rules :refer :all]
+            [clara.rules.testfacts :refer [->Cold  ->Hot ->First ->Second]]
+            [clara.tools.testing-utils :refer [def-rules-test
+                                               ex-data-maps
+                                               side-effect-holder-fixture
+                                               side-effect-holder
+                                               assert-ex-data]]
+            [clara.tools.tracing :as tr]
+            [clara.rules.accumulators :as acc]
+            [clara.tools.loop-detector :as ld])
+  (:import [clara.rules.testfacts Cold Hot First Second]
+           [clara.tools.tracing
+            PersistentTracingListener]))
+
+(use-fixtures :each side-effect-holder-fixture)
+
+(defn throw-fn
+  []
+  (throw (ex-info "Infinite loop suspected" {:clara-rules/infinite-loop-suspected true})))
+
+(def-rules-test test-truth-maintenance-loop
+
+  ;; Test of an infinite loop to an endless cycle caused by truth maintenance,
+  ;; that is an insertion that causes its support to be retracted.
+
+  {:rules [hot-rule [[[:not [Hot]]]
+                     (insert! (->Cold nil))]
+
+           cold-rule [[[Cold]]
+                      (insert! (->Hot nil))]]
+
+   :sessions [empty-session [hot-rule cold-rule] {}]}
+
+  (let [watched-session (ld/with-loop-detection empty-session throw-fn 3000)]
+
+  (assert-ex-data  {:clara-rules/infinite-loop-suspected true}  (fire-rules watched-session))))
+
+(def-rules-test test-truth-maintenance-loop-with-salience
+
+  ;; Test of an infinite loop to an endless cycle caused by truth maintenance,
+  ;; that is an insertion that causes its support to be retracted, when the
+  ;; two rules that form the loop have salience and are thus parts of different
+  ;; activation groups.
+
+
+  {:rules [hot-rule [[[:not [Hot]]]
+                     (insert! (->Cold nil))
+                     {:salience 1}]
+
+           cold-rule [[[Cold]]
+                      (insert! (->Hot nil))
+                      {:salience 2}]]
+
+   :sessions [empty-session [hot-rule cold-rule] {}
+              empty-session-negated-salience [hot-rule cold-rule] {:activation-group-fn (comp - :salience :props)}]}
+
+  (doseq [session (map #(ld/with-loop-detection % throw-fn 3000)
+                       [empty-session empty-session-negated-salience])]
+    ;; Validate that the results are the same in either rule ordering.
+    (assert-ex-data  {:clara-rules/infinite-loop-suspected true}  (fire-rules session))))
+
+
+(def-rules-test test-recursive-insertion
+
+  ;; Test of an infinite loop due to runaway insertions without retractions.
+
+  {:rules [cold-rule [[[Cold]]
+                      (insert! (->Cold "ORD"))]]
+
+   :sessions [empty-session [cold-rule] {}]}
+
+  (let [watched-session (ld/with-loop-detection empty-session throw-fn 10)]
+
+    (assert-ex-data {:clara-rules/infinite-loop-suspected true}
+                    (-> watched-session
+                        (insert (->Cold "ARN"))
+                        ;; Use a small value here to ensure that we don't run out of memory before throwing.
+                        ;; There is unfortunately a tradeoff where making the default number of cycles allowed
+                        ;; high enough for some use cases will allow others to create OutOfMemory errors in cases
+                        ;; like these but we can at least throw when there is enough memory available to hold the facts
+                        ;; created in the loop.
+                        (fire-rules {:max-cycles 10})))))
+
+(def-rules-test test-recursive-insertion-loop-no-salience
+
+  {:rules [first-rule [[[First]]
+                       (insert! (->Second))]
+
+           second-rule [[[Second]]
+                        (insert! (->First))]]
+
+   :sessions [empty-session [first-rule second-rule] {}]}
+
+  (let [watched-session (ld/with-loop-detection empty-session throw-fn 10)]
+
+    (assert-ex-data {:clara-rules/infinite-loop-suspected true}
+                    (-> watched-session
+                        (insert (->First))
+                        (fire-rules {:max-cycles 10})))))
+
+(def-rules-test test-recursive-insertion-loop-with-salience
+
+  {:rules [first-rule [[[First]]
+                       (insert! (->Second))
+                       {:salience 1}]
+
+           second-rule [[[Second]]
+                        (insert! (->First))
+                        {:salience 2}]]
+
+   :sessions [empty-session [first-rule second-rule] {}
+              empty-session-negated-salience [first-rule second-rule] {:activation-group-fn (comp - :salience :props)}]}
+
+  (doseq [session
+          (map #(ld/with-loop-detection % throw-fn 10)
+               [empty-session empty-session-negated-salience])]
+    (assert-ex-data {:clara-rules/infinite-loop-suspected true}
+                    (-> session
+                        (insert (->First))
+                        (fire-rules {:max-cycles 10})))))
+
+;; FIXME: Fix this before merging; it is a genuine issue to address not a test problem.
+;; (def-rules-test test-tracing-infinite-loop
+
+;;   {:rules [cold-rule [[[Cold]]
+;;                       (insert! (->Cold "ORD"))]]
+
+;;    :sessions [empty-session [cold-rule] {}]}
+
+;;   (let [watched-session (ld/with-loop-detection empty-session throw-fn 10)]
+
+;;     (try
+;;       (do (-> watched-session
+;;               tr/with-tracing
+;;               (insert (->Cold "ARN"))
+;;               ;; Use a small value here to ensure that we don't run out of memory before throwing.
+;;               ;; There is unfortunately a tradeoff where making the default number of cycles allowed
+;;               ;; high enough for some use cases will allow others to create OutOfMemory errors in cases
+;;               ;; like these but we can at least throw when there is enough memory available to hold the facts
+;;               ;; created in the loop.
+;;               (fire-rules {:max-cycles 10}))
+;;           (is false "The infinite loop did not throw an exception."))
+;;       (catch Exception e
+;;         (let [data-maps (ex-data-maps e)
+;;               loop-data (filter :clara-rules/infinite-loop-suspected data-maps)]
+;;           (is (= (count loop-data)
+;;                  1)
+;;               "There should only be one exception in the chain from infinite rules loops.")
+;;           (is (= (-> loop-data first  :listeners count) 1)
+;;               "There should only be one listener.")
+;;           (is (-> loop-data first  :listeners ^PersistentTracingListener first .-trace not-empty)
+;;               "There should be tracing data available when a traced session throws an exception on an infinite loop."))))))
+
+(def-rules-test test-max-cycles-respected
+
+  ;; As the name suggests, this is a test to validate that setting the max-cycles to different
+  ;; values actually works.  The others tests are focused on validating that infinite loops
+  ;; throw exceptions, and the max-cycles values there are simply set to restrict resource usage,
+  ;; whether CPU or memory, by the test.  Here, on the other hand, we construct a rule where we control
+  ;; how many rule cycles will be executed, and then validate that an exception is thrown when that number is
+  ;; greater than the max-cycles and is not when it isn't.  For good measure, we validate that the non-exception-throwing
+  ;; case has queryable output to make sure that the logic was actually run, not ommitted because of a typo or similar.
+
+  {:rules [recursive-rule-with-end [[[First]]
+                                    (when (< @side-effect-holder 20)
+                                      (do
+                                        (insert-unconditional! (->First))
+                                        (swap! side-effect-holder inc)))]]
+
+   :queries [first-query [[] [[?f <- First]]]]
+
+   :sessions [empty-session [recursive-rule-with-end first-query] {}]}
+
+  (reset! side-effect-holder 0)
+
+  (assert-ex-data {:clara-rules/infinite-loop-suspected true}
+                  (-> (ld/with-loop-detection empty-session throw-fn 10)
+                      (insert (->First))
+                      (fire-rules {:max-cycles 10})))
+
+  (reset! side-effect-holder 0)
+
+  (is (= (count (-> (ld/with-loop-detection empty-session throw-fn 30)
+                    (insert (->First))
+                    (fire-rules {:max-cycles 30})
+                    (query first-query)))
+         21)))

src/test/common/clara/tools/test_tracing.cljc

@@ -132,7 +132,7 @@
 
     ;; Ensure expected events occur in order.
    (is (= [:add-facts :alpha-activate :right-activate :left-activate
-           :add-activations :fire-activation :add-facts-logical]
+           :add-activations :fire-activation :add-facts-logical :activation-group-transition]
            (map :type (t/get-trace session))))))
 
 (def-rules-test test-insert-and-retract-trace
@@ -151,8 +151,9 @@
        session-trace (t/get-trace session)]
 
     ;; Ensure expected events occur in order.
-   (is (= [:add-facts :alpha-activate :right-activate :left-activate :add-activations :fire-activation :add-facts-logical
-           :retract-facts :alpha-retract :right-retract :left-retract :remove-activations :retract-facts-logical]
+   (is (= [:add-facts :alpha-activate :right-activate :left-activate :add-activations :fire-activation
+           :add-facts-logical :activation-group-transition :retract-facts :alpha-retract :right-retract
+           :left-retract :remove-activations :retract-facts-logical]
           (map :type session-trace)))
 
    ;; Ensure only the expected fact was indicated as retracted.