diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs index 6f1d2200..58952c97 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs @@ -154,6 +154,8 @@ newtype RepoHeadTx = RepoHeadTx HashRef deriving stock (Generic) deriving newtype (ToField,FromField,Pretty) +instance Serialise RepoHeadTx + newtype RepoName = RepoName Text deriving stock (Eq,Show,Generic) deriving newtype (ToField,FromField,ToHtml,IsString,Pretty) @@ -191,6 +193,8 @@ newtype RepoHeadRef = RepoHeadRef HashRef deriving stock (Generic) deriving newtype (ToField,FromField) +instance Serialise RepoHeadRef + newtype RepoHeadSeq = RepoHeadSeq Word64 deriving stock (Generic) @@ -591,7 +595,7 @@ createRepoCommitTable = do |] -isProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m Bool +isProcessed :: (MonadIO m) => HashRef -> DBPipeM m Bool isProcessed href = do select @(Only Int) [qc|select 1 from processed where hash = ? limit 1|] (Only href) <&> not . List.null diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs index fc2caf5b..19e3dfed 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs +++ b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs @@ -7,6 +7,8 @@ import HBS2.Git.DashBoard.Manifest import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.Tx.Git +import HBS2.Hash + import HBS2.System.Dir import Streaming.Prelude qualified as S @@ -38,6 +40,7 @@ updateFixmeFor (RepoLww lw) f = do void $ runProcess cmd + updateIndexFromPeer :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m () updateIndexFromPeer = do debug "updateIndexFromPeer" @@ -77,9 +80,13 @@ updateIndexFromPeer = do Right hxs -> do for_ hxs $ \htx -> void $ runMaybeT do - -- done <- liftIO $ withDB db (isTxProcessed (HashVal htx)) - -- done1 <- liftIO $ withDB db (isTxProcessed (processedRepoTx (gitLwwRef,htx))) - -- guard (not done && not done1) + + done <- lift $ withState $ isProcessed (HashRef $ hashObject @HbSync (serialise (lw,htx))) + + guard (not done) + + debug $ red "AAAAAAA" <+> pretty htx + getBlock sto (fromHashRef htx) >>= toMPlus <&> deserialiseOrFail @(RefLogUpdate L4Proto) >>= toMPlus @@ -100,6 +107,8 @@ updateIndexFromPeer = do let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv) insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead + insertProcessed (HashRef $ hashObject @HbSync (serialise (l,coerce @_ @HashRef tx))) + for_ fme $ \f -> do insertRepoFixme l rlwwseq f