mirror of https://github.com/voidlizard/hbs2
76 lines
2.5 KiB
Haskell
76 lines
2.5 KiB
Haskell
module HBS2.Git.DashBoard.State.Index.Channels where
|
|
|
|
import HBS2.Git.DashBoard.Prelude
|
|
import HBS2.Git.DashBoard.Types
|
|
import HBS2.Git.DashBoard.State
|
|
|
|
import DBPipe.SQLite hiding (insert)
|
|
import DBPipe.SQLite.Generic as G
|
|
|
|
import Streaming.Prelude qualified as S
|
|
|
|
updateIndexFromChannels :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m ()
|
|
updateIndexFromChannels = do
|
|
debug "updateIndexChannels"
|
|
|
|
rchanAPI <- asks _refChanAPI
|
|
sto <- asks _sto
|
|
|
|
flip runContT pure do
|
|
|
|
es <- lift getIndexEntries
|
|
|
|
for_ es $ \rc -> do
|
|
callCC \next -> do
|
|
debug $ red (pretty (AsBase58 rc))
|
|
|
|
h <- lift (callRpcWaitMay @RpcRefChanGet (1 :: Timeout 'Seconds) rchanAPI rc)
|
|
<&> join
|
|
>>= maybe (next ()) pure
|
|
|
|
debug $ "rechan val" <+> red (pretty h)
|
|
|
|
txs <- S.toList_ do
|
|
walkMerkle @[HashRef] (coerce h) (getBlock sto) $ \case
|
|
Left{} -> pure ()
|
|
Right hs -> mapM_ S.yield hs
|
|
|
|
for_ txs $ \txh -> void $ runMaybeT do
|
|
|
|
done <- lift $ lift $ withState do
|
|
select @(Only Int)
|
|
[qc|select 1 from processed where hash = ? limit 1|]
|
|
(Only (TxHash txh)) <&> isJust . listToMaybe
|
|
|
|
guard (not done)
|
|
|
|
tx@GitIndexTx{..} <- getBlock sto (coerce txh)
|
|
>>= toMPlus
|
|
>>= readProposeTranMay @(GitIndexTx 'HBS2Basic) @L4Proto
|
|
>>= toMPlus
|
|
|
|
lift $ lift $ withState $ transactional do
|
|
let nm = [ RepoName n | GitIndexRepoName n <- universeBi gitIndexTxPayload ] & headMay
|
|
let bri = [ RepoBrief n | GitIndexRepoBrief n <- universeBi gitIndexTxPayload ] & headMay
|
|
|
|
insert @RepoTable $ onConflictIgnore @RepoTable (Only (RepoLww gitIndexTxRef))
|
|
|
|
insert @RepoChannelTable $
|
|
onConflictIgnore @RepoChannelTable (RepoLww gitIndexTxRef, RepoChannel rc)
|
|
|
|
-- FIXME: on-conflict-update!
|
|
for_ nm $ \n -> do
|
|
insert @RepoNameTable $
|
|
onConflictIgnore @RepoNameTable (RepoLww gitIndexTxRef, n)
|
|
|
|
for_ bri $ \n -> do
|
|
insert @RepoBriefTable $
|
|
onConflictIgnore @RepoBriefTable (RepoLww gitIndexTxRef, n)
|
|
|
|
lift $ withState $ transactional do
|
|
for_ txs $ \t -> do
|
|
insert @TxProcessedTable $ onConflictIgnore @TxProcessedTable (Only (TxHash t))
|
|
|
|
|
|
|