diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs index 61c02018..c019b2a9 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs @@ -99,6 +99,12 @@ instance FromField HashRef where instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (LWWRefKey s) where toField x = toField $ show $ pretty (AsBase58 x) +instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (RefLogKey s) where + toField x = toField $ show $ pretty (AsBase58 x) + +instance IsRefPubKey s => FromField (RefLogKey s) where + fromField = fmap (fromString @(RefLogKey s)) . fromField @String + instance FromField (LWWRefKey HBS2Basic) where fromField = fmap fromString . fromField @String @@ -124,6 +130,10 @@ newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic) deriving stock (Generic) deriving newtype (ToField,FromField,Pretty) +newtype RepoLwwSeq = RepoLwwSeq Integer + deriving stock (Generic) + deriving newtype (ToField,FromField,Pretty) + newtype RepoChannel = RepoChannel MyRefChan @@ -136,6 +146,9 @@ newtype RepoHeadSeq = RepoHeadSeq Word64 deriving stock (Generic) deriving newtype (ToField,FromField) +newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic) + deriving stock (Generic) + deriving newtype (ToField,FromField) newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef) deriving stock (Generic) @@ -171,12 +184,18 @@ instance HasColumnName TxHash where instance HasColumnName RepoLww where columnName = "lww" +instance HasColumnName RepoLwwSeq where + columnName = "lwwseq" + instance HasColumnName RepoName where columnName = "name" instance HasColumnName RepoBrief where columnName = "brief" +instance HasColumnName RepoRefLog where + columnName = "reflog" + instance HasColumnName RepoChannel where columnName = "channel" @@ -283,7 +302,9 @@ create view repolistview as with repolist as ( select r.lww, + 0 as lwwseq, 0 as seq, + null as reflog, null as repohead, null as tx, coalesce(n.name, r.lww) as name, @@ -295,6 +316,8 @@ with repolist as ( union select lww, + lwwseq, + reflog, seq, repohead, tx, @@ -306,18 +329,20 @@ with repolist as ( ranked_repos as ( select lww, + lwwseq, + reflog, seq, repohead, tx, name, brief, gk0, - row_number() over (partition by lww order by seq desc) as rn + row_number() over (partition by lww order by lwwseq desc, seq desc) as rn from repolist order by seq desc ) -select lww, seq, repohead, tx, name, brief, gk0 +select lww, lwwseq, reflog, seq, repohead, tx, name, brief, gk0 from ranked_repos where rn = 1; @@ -329,13 +354,15 @@ createRepoHeadTable = do ddl [qc| create table if not exists repohead ( lww text not null + , lwwseq integer not null + , reflog text not null , repohead text not null , tx text not null , seq integer not null , gk0 text null , name text , brief text - , primary key (lww,repohead) + , primary key (lww,lwwseq,repohead) ) |] @@ -345,7 +372,7 @@ instance HasTableName RepoHeadTable where tableName = "repohead" instance HasPrimaryKey RepoHeadTable where - primaryKey = ["lww", "repohead"] + primaryKey = ["lww", "lwwseq", "repohead"] instance HasColumnName RepoHeadRef where columnName = "repohead" @@ -359,15 +386,20 @@ instance HasColumnName RepoHeadGK0 where instance HasColumnName RepoHeadTx where columnName = "tx" + insertRepoHead :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic + -> RepoLwwSeq + -> RepoRefLog -> RepoHeadTx -> RepoHeadRef -> RepoHead -> DBPipeM m () -insertRepoHead lww tx rf rh = do +insertRepoHead lww lwwseq rlog tx rf rh = do insert @RepoHeadTable $ onConflictIgnore @RepoHeadTable ( RepoLww lww + , lwwseq + , rlog , rf , tx , RepoHeadSeq (_repoHeadTime rh) diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs index e4d7848e..c30d8eb6 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs @@ -10,12 +10,15 @@ import Streaming.Prelude qualified as S {- HLINT ignore "Functor law" -} +seconds = TimeoutSec + updateIndexFromPeer :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m () updateIndexFromPeer = do debug "updateIndexFromPeer" peer <- asks _peerAPI reflog <- asks _refLogAPI + lwwAPI <- asks _lwwRefAPI sto <- asks _sto @@ -24,12 +27,16 @@ updateIndexFromPeer = do <&> fmap (LWWRefKey @HBS2Basic . view _1) repos <- S.toList_ $ forM_ polls $ \r -> void $ runMaybeT do + + lwval <- liftIO (callRpcWaitMay @RpcLWWRefGet (seconds 1) lwwAPI r) + >>= toMPlus >>= toMPlus + (lw,blk) <- readLWWBlock sto r >>= toMPlus let rk = lwwRefLogPubKey blk - lift $ S.yield (r,RefLogKey @'HBS2Basic rk,blk) + lift $ S.yield (r,lwval,RefLogKey @'HBS2Basic rk,blk) - for_ repos $ \(lw,rk,LWWBlockData{..}) -> do + for_ repos $ \(lw,wv,rk,LWWBlockData{..}) -> do mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk) <&> join @@ -61,93 +68,6 @@ updateIndexFromPeer = do withState $ transactional do for_ headz $ \(l, tx, rh, rhead) -> do - insertRepoHead l tx rh rhead - - -- db <- asks _db - - -- facts <- S.toList_ do - - -- for_ repos $ \(lw,rk,LWWBlockData{..}) -> do - - -- mhead <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk) - -- <&> join - - -- for_ mhead $ \mh -> do - - -- txs <- S.toList_ $ do - -- walkMerkle @[HashRef] (fromHashRef mh) (getBlock sto) $ \case - -- Left{} -> do - -- pure () - - -- 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) - -- getBlock sto (fromHashRef htx) >>= toMPlus - -- <&> deserialiseOrFail @(RefLogUpdate L4Proto) - -- >>= toMPlus - -- >>= unpackTx - -- >>= \(n,h,blk) -> lift (S.yield (n,htx,blk)) - - -- relAlready <- lift $ withDB db do - -- -- FIXME: uncomment-for-speedup - -- done <- isGitRepoBundleProcessed mh >> pure False - -- unless done do - -- transactional do - -- for_ txs $ \(n,_,bu) -> do - -- refs <- fromRight mempty <$> readBundleRefs sto bu - -- for_ refs $ \r -> do - -- debug $ red "bundle-fact" <+> pretty lw <+> pretty r - -- insertRepoBundleFact (GitRepoBundle (GitLwwRef lw) (GitBundle r)) - - -- insertGitRepoBundleProcessed mh - -- pure done - - -- -- let tx' = maximumByMay (comparing (view _1)) txs - - -- for_ txs $ \(n,tx,blk) -> void $ runMaybeT do - -- liftIO $ withDB db do - -- transactional do - -- for_ [ t | (i,t,_) <- txs, i < n ] $ \tran -> do - -- insertTxProcessed (HashVal tran) - - -- (rhh,RepoHeadSimple{..}) <- readRepoHeadFromTx sto tx - -- >>= toMPlus - - -- let name = Text.take 256 $ _repoHeadName - -- let brief = Text.take 1024 $ _repoHeadBrief - -- let manifest = _repoManifest - - -- lift $ S.yield $ GitRepoFacts - -- (GitLwwRef lw) - -- (GitLwwSeq lwwRefSeed) - -- (GitRefLog rk) - -- (GitTx tx) - -- (GitRepoHeadRef rhh) - -- (GitRepoHeadSeq (fromIntegral n)) - -- (GitName (Just name)) - -- (GitBrief (Just brief)) - -- (GitEncrypted _repoHeadGK0) - -- [GitRepoExtendedManifest (GitManifest manifest)] - - -- -- yield repo relation facts by common bundles - -- unless relAlready do - - -- what <- withDB db do - -- select_ @_ @(GitLwwRef, GitLwwRef) [qc| - -- select distinct - -- b1.lwwref - -- , b2.lwwref - -- from gitrepobundle b1 join gitrepobundle b2 on b1.bundle = b2.bundle - -- where b1.lwwref <> b2.lwwref - -- |] - - -- let r = HM.fromListWith (<>) [ (a, HS.singleton b) | (a,b) <- what ] - -- & HM.toList - - -- for_ r $ \(lww, rel) -> do - -- lift $ S.yield $ GitRepoRelatedFact lww rel - - -- liftIO $ withDB db (insertTxProcessed (HashVal tx)) + let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv) + insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead