speedup a little

hbs2-share/app/Main.hs

@@ -14,7 +14,7 @@ globalOptions = do
              <&> maybe mempty (const [AppDebugOpt])
 
   trace <- optional (flag' True (long "trace" <> help "allow more debug output"))
-             <&> maybe mempty (const [AppDebugOpt])
+             <&> maybe mempty (const [AppTraceOpt])
 
 
   replica <- optional (flag' True (long "replica" <> help "replica (slave) mode"))

hbs2-share/hbs2-share.cabal

@@ -75,6 +75,7 @@ common shared-properties
       , stm
       , text
       , time
+      , timeit
       , transformers
       , typed-process
       , unordered-containers

hbs2-share/src/HBS2/Share/App.hs

@@ -69,6 +69,8 @@ import Codec.Serialise
 import Codec.Compression.GZip as GZip
 import System.AtomicWrite.Writer.LazyByteString qualified as AwL
 
+import System.TimeIt
+
 import Streaming.Prelude qualified as S
 
 
@@ -422,7 +424,7 @@ updateFileMethod UpdateFileSync rpc fe = do
         fnew <- renameFileUniq fpath
         info $ "renamed" <+> pretty fpath <+> pretty fnew
 
-      info $ "create dir" <+> pretty fpath
+      debug $ "create dir" <+> pretty fpath
       liftIO $ createDirectoryIfMissing True fpath
 
     let h = view remoteTree fe & fromHashRef
@@ -494,11 +496,14 @@ scanState rpc = do
   debug $ "refchan value" <+> pretty rv
 
   withState do
-    scanTx sto rv
+    seen <- selectSeen rv
-    commitAll
+    unless seen do
+      scanTx sto rv
+      commitAll
 
   props <- withState selectProposes
 
+  -- FIXME: cache-somehow
   ((px,e), meta) <- findGoodNewBlock kr sto props
                       >>= orThrowUser "no meta block found"
 
@@ -512,16 +517,20 @@ scanState rpc = do
   for_ rfs $ \rf -> do
     updateFile rpc rf
 
+  withState $ insertSeen rv
+
   pure px
 
   where
 
     findGoodNewBlock kr sto props = do
       runMaybeT (go props)
+
       where
 
         go [] = mzero
         go (p:ps) = do
+
           let btx = fst p
           missed <- lift $ isMissed sto btx
           if missed then
@@ -530,7 +539,9 @@ scanState rpc = do
 
             what <- S.head_ do
               walkMerkle (fromHashRef btx) (getBlock sto) $ \case
-                Right ( (hx:_) :: [HashRef] ) -> S.yield hx
+                Right ( (hx:_) :: [HashRef] ) -> do
+                  S.yield hx
+
                 _ -> pure ()
 
             hmeta <- toMPlus what
@@ -555,6 +566,12 @@ scanState rpc = do
           trace $ "got some" <+> pretty (length hs)
 
           for_ hs $ \htx -> void $ runMaybeT do
+
+            seen <- lift $ lift $ selectSeen htx
+
+            -- debug $ "SEEN" <+> pretty seen <+> pretty htx
+            guard (not seen)
+
             bs <- toMPlus =<< getBlock sto (fromHashRef htx)
             tx <- toMPlus $ deserialiseOrFail @(RefChanUpdate L4Proto) bs
 
@@ -576,6 +593,8 @@ scanState rpc = do
                 trace $ "tx propose" <+> pretty htx <+> pretty mytx
                 lift $ lift $ insertPropose htx mytx
 
+            lift $ lift $ insertSeen htx
+
 dontPost :: AppPerks m => ShareCLI m Bool
 dontPost = do
   opts <- asks ( view appOpts )

hbs2-share/src/HBS2/Share/State.hs

@@ -54,6 +54,9 @@ instance HasHash HashRef  where
 newtype HashVal = HashVal { fromHashVal :: HashRef }
                   deriving newtype (IsString)
 
+wrapHash :: HasHash hx => hx -> HashVal
+wrapHash hx = HashVal (HashRef (toHash hx))
+
 instance ToField GK0Key where
   toField (GK0Key hs) = toField (show (pretty hs))
 
@@ -127,6 +130,7 @@ populateState = do
          |]
 
   createRemoteFileTable
+  createSeenTable
 
   commitAll
 
@@ -343,3 +347,33 @@ selectRemoteFile px k = do
     limit 1
   |] (HashVal px, k) <&> listToMaybe
 
+
+createSeenTable :: MonadUnliftIO m => DBPipeM m ()
+createSeenTable = do
+  ddl [qc|create table if not exists seen
+          ( hash text not null
+          , primary key (hash)
+          )
+         |]
+
+
+insertSeen :: (MonadUnliftIO m, HasHash hx)
+           => hx
+           -> DBPipeM m ()
+insertSeen hx = do
+  insert [qc|
+    insert into seen (hash)
+    values (?)
+    on conflict (hash)
+    do nothing
+  |] (Only $ wrapHash hx)
+
+selectSeen :: (MonadUnliftIO m, HasHash hx)
+           => hx
+           -> DBPipeM m Bool
+selectSeen hx = do
+  select [qc|
+    select 1 from seen where hash = ? limit 1
+  |] (Only $ wrapHash hx)
+  <&> (maybe False fromOnly . listToMaybe)
+