diff --git a/hbs2-share/app/Main.hs b/hbs2-share/app/Main.hs index e789703c..1f31f166 100644 --- a/hbs2-share/app/Main.hs +++ b/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")) diff --git a/hbs2-share/hbs2-share.cabal b/hbs2-share/hbs2-share.cabal index 3e1e56f4..46e70bbe 100644 --- a/hbs2-share/hbs2-share.cabal +++ b/hbs2-share/hbs2-share.cabal @@ -75,6 +75,7 @@ common shared-properties , stm , text , time + , timeit , transformers , typed-process , unordered-containers diff --git a/hbs2-share/src/HBS2/Share/App.hs b/hbs2-share/src/HBS2/Share/App.hs index b4401973..fd5e6e76 100644 --- a/hbs2-share/src/HBS2/Share/App.hs +++ b/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 - commitAll + seen <- selectSeen rv + 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 ) diff --git a/hbs2-share/src/HBS2/Share/State.hs b/hbs2-share/src/HBS2/Share/State.hs index a863cf49..f6bbcb97 100644 --- a/hbs2-share/src/HBS2/Share/State.hs +++ b/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) +