mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
f4bd830668
commit
d93dbc397e
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue