wip

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Facts.hs

@@ -1,6 +1,7 @@
 module HBS2.Git.Oracle.Facts where
 
 import HBS2.Git.Oracle.Prelude
+import HBS2.Hash
 import Data.Word
 import Codec.Serialise
 
@@ -63,3 +64,4 @@ instance Pretty GitRepoHeadFact where
 instance Pretty GitRepoHeadVersionFact where
   pretty (GitRepoHeadVersionFact1 v) = pretty v
 
+

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/Run.hs

@@ -84,8 +84,9 @@ runOracleIndex auPk = do
 
                     Right hxs -> do
                       for_ hxs $ \htx -> void $ runMaybeT do
-                        done <- liftIO $ withDB db (isTxProcessed (HashVal htx))
+                        done  <- liftIO $ withDB db (isTxProcessed (HashVal htx))
-                        guard (not done)
+                        done1 <- liftIO $ withDB db (isTxProcessed (processedRepoTx (gitLwwRef,htx)))
+                        guard (not done && not done1)
                         getBlock sto (fromHashRef htx) >>= toMPlus
                            <&> deserialiseOrFail @(RefLogUpdate L4Proto)
                            >>= toMPlus
@@ -139,7 +140,7 @@ runOracleIndex auPk = do
     debug $ "posted tx" <+> pretty (hashObject @HbSync (serialise f))
 
   -- FIXME: ASAP-wait-refchan-actually-updated
-  pause @'Seconds 0.25
+  -- pause @'Seconds 0.25
 
   updateState
 
@@ -294,6 +295,7 @@ updateState = do
   chan  <- asks _refchanId
   rchanAPI <- asks _refchanAPI
   sto  <- asks  _storage
+  db   <- asks _db
 
   void $ runMaybeT do
 
@@ -306,6 +308,8 @@ updateState = do
         Right txs -> do
           -- FIXME: skip-already-processed-blocks
           for_ txs $ \htx -> void $ runMaybeT do
+            done <- liftIO $ withDB db (isTxProcessed (HashVal htx))
+            guard (not done)
             getBlock sto (fromHashRef htx)
              >>= toMPlus
              <&> deserialiseOrFail @(RefChanUpdate L4Proto)
@@ -320,7 +324,7 @@ updateState = do
              <&> snd
              <&> deserialiseOrFail @GitRepoFacts . LBS.fromStrict
              >>= toMPlus
-             >>= lift . S.yield
+             >>= lift . S.yield . (htx,)
 
     let rf  = [ (HashRef (hashObject $ serialise f), f)
               | f@GitRepoFact1{} <-  universeBi facts
@@ -338,8 +342,11 @@ updateState = do
 
       transactional do
 
-        for_ done $ \(r,t) -> do
+        for_ done $ \w -> do
-          debug $ red "DONE" <+> pretty (r,t)
+          insertTxProcessed (processedRepoTx w)
+
+        for_  facts $ \(t,_) -> do
+          insertTxProcessed (HashVal t)
 
         for_ (HM.toList rf) $ \(k, GitRepoFact1{..}) -> do
 

hbs2-git/hbs2-git-oracle/lib/HBS2/Git/Oracle/State.hs

@@ -1,12 +1,16 @@
 module HBS2.Git.Oracle.State where
 
 import HBS2.Git.Oracle.Prelude
+import HBS2.Hash
 import DBPipe.SQLite
 
 import Data.Coerce
 import Text.InterpolatedString.Perl6 (qc)
 import Data.Word
 
+processedRepoTx :: (LWWRefKey HBS2Basic, HashRef) -> HashVal
+processedRepoTx w = HashVal $ HashRef $ hashObject @HbSync (serialise w)
+
 evolveDB :: MonadUnliftIO m => DBPipeM m ()
 evolveDB = do
   debug $ yellow "evolveDB"
@@ -124,8 +128,10 @@ insertTxProcessed hash = do
 isTxProcessed :: MonadUnliftIO m => HashVal -> DBPipeM m Bool
 isTxProcessed hash = do
   results <- select [qc|
-    select 1 from txprocessed where hash = ?
+    select 1 from txprocessed where hash = ? limit 1
   |] (Only hash)
   pure $ not $ null (results :: [Only Int])
 
 
+
+