voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-09-29 08:44:26 +03:00
parent 9145089ded
commit f0088deb03
2 changed files with 17 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs
View File

@ -154,6 +154,8 @@ newtype RepoHeadTx = RepoHeadTx HashRef
deriving stock (Generic) deriving stock (Generic)
deriving newtype (ToField,FromField,Pretty) deriving newtype (ToField,FromField,Pretty)
instance Serialise RepoHeadTx
newtype RepoName = RepoName Text newtype RepoName = RepoName Text
deriving stock (Eq,Show,Generic) deriving stock (Eq,Show,Generic)
deriving newtype (ToField,FromField,ToHtml,IsString,Pretty) deriving newtype (ToField,FromField,ToHtml,IsString,Pretty)
@ -191,6 +193,8 @@ newtype RepoHeadRef = RepoHeadRef HashRef
deriving stock (Generic) deriving stock (Generic)
deriving newtype (ToField,FromField) deriving newtype (ToField,FromField)
instance Serialise RepoHeadRef
newtype RepoHeadSeq = RepoHeadSeq Word64 newtype RepoHeadSeq = RepoHeadSeq Word64
deriving stock (Generic) 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 isProcessed href = do
select @(Only Int) [qc|select 1 from processed where hash = ? limit 1|] (Only href) select @(Only Int) [qc|select 1 from processed where hash = ? limit 1|] (Only href)
<&> not . List.null <&> not . List.null

15
hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State/Index/Peer.hs
View File

@ -7,6 +7,8 @@ import HBS2.Git.DashBoard.Manifest
import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.LWWBlock
import HBS2.Git.Data.Tx.Git import HBS2.Git.Data.Tx.Git
import HBS2.Hash
import HBS2.System.Dir import HBS2.System.Dir
import Streaming.Prelude qualified as S import Streaming.Prelude qualified as S
@ -38,6 +40,7 @@ updateFixmeFor (RepoLww lw) f = do
void $ runProcess cmd void $ runProcess cmd
updateIndexFromPeer :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m () updateIndexFromPeer :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m ()
updateIndexFromPeer = do updateIndexFromPeer = do
debug "updateIndexFromPeer" debug "updateIndexFromPeer"
@ -77,9 +80,13 @@ updateIndexFromPeer = do
Right hxs -> do Right hxs -> do
for_ hxs $ \htx -> void $ runMaybeT do for_ hxs $ \htx -> void $ runMaybeT do
-- done <- liftIO $ withDB db (isTxProcessed (HashVal htx))
-- done1 <- liftIO $ withDB db (isTxProcessed (processedRepoTx (gitLwwRef,htx))) done <- lift $ withState $ isProcessed (HashRef $ hashObject @HbSync (serialise (lw,htx)))
-- guard (not done && not done1)
guard (not done)
debug $ red "AAAAAAA" <+> pretty htx
getBlock sto (fromHashRef htx) >>= toMPlus getBlock sto (fromHashRef htx) >>= toMPlus
<&> deserialiseOrFail @(RefLogUpdate L4Proto) <&> deserialiseOrFail @(RefLogUpdate L4Proto)
>>= toMPlus >>= toMPlus
@ -100,6 +107,8 @@ updateIndexFromPeer = do
let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv) let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv)
insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead
insertProcessed (HashRef $ hashObject @HbSync (serialise (l,coerce @_ @HashRef tx)))
for_ fme $ \f -> do for_ fme $ \f -> do
insertRepoFixme l rlwwseq f insertRepoFixme l rlwwseq f