From aa269770fb93879a298afcf25c3f2d6a128179f5 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Fri, 19 Apr 2024 07:31:20 +0300 Subject: [PATCH] wip, prelude for hbs2-git-dashboard --- hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 32 +------ .../src/HBS2/Git/DashBoard/Prelude.hs | 53 +++++++++++ .../src/HBS2/Git/DashBoard/State.hs | 87 ++----------------- .../src/HBS2/Git/DashBoard/State/Index.hs | 20 +++++ .../Git/DashBoard/State/Index/Channels.hs | 75 ++++++++++++++++ .../HBS2/Git/DashBoard/State/Index/Peer.hs | 8 ++ .../src/HBS2/Git/DashBoard/Types.hs | 15 +--- hbs2-git/hbs2-git.cabal | 4 + 8 files changed, 170 insertions(+), 124 deletions(-) create mode 100644 hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs create mode 100644 hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs create mode 100644 hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs create mode 100644 hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 5e54893d..50538fc0 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -3,60 +3,36 @@ {-# Language AllowAmbiguousTypes #-} module Main where -import HBS2.Prelude.Plated -import HBS2.OrDie +import HBS2.Git.DashBoard.Prelude import HBS2.System.Dir -import HBS2.System.Logger.Simple.ANSI hiding (info) -import HBS2.Data.Types.Refs -import HBS2.Net.Auth.Credentials -import HBS2.Merkle -import HBS2.Storage import HBS2.Net.Messaging.Unix import HBS2.OrDie -import HBS2.Misc.PrettyStuff -import HBS2.Net.Proto.Service -import HBS2.Peer.Proto.LWWRef -import HBS2.Peer.RPC.API.Peer -import HBS2.Peer.RPC.API.RefLog -import HBS2.Peer.RPC.API.RefChan -import HBS2.Peer.RPC.API.LWWRef import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient import HBS2.Git.Web.Assets import HBS2.Git.DashBoard.State +import HBS2.Git.DashBoard.State.Index import HBS2.Git.DashBoard.Types import HBS2.Git.Web.Html.Root import HBS2.Peer.CLI.Detect -import Data.Config.Suckless - -import DBPipe.SQLite import Lucid import Options.Applicative as O -import Data.Maybe import Data.Either -import Control.Applicative import Data.ByteString.Lazy qualified as LBS import Network.HTTP.Types.Status import Network.Wai.Middleware.Static hiding ((<|>)) import Network.Wai.Middleware.StaticEmbedded as E import Network.Wai.Middleware.RequestLogger -import Text.InterpolatedString.Perl6 (qc) import Web.Scotty.Trans -import Control.Monad.Reader -import Control.Monad.Trans.Maybe import System.Directory import Control.Monad.Except -import Control.Monad.Trans.Cont - -import UnliftIO - configParser :: DashBoardPerks m => Parser (m ()) @@ -70,7 +46,7 @@ configParser = do )) cmd <- subparser - ( command "web" (info pRunWeb (progDesc "Run the web interface")) ) + ( command "web" (O.info pRunWeb (progDesc "Run the web interface")) ) pure $ cmd opts @@ -211,7 +187,7 @@ main :: IO () main = do execParser opts & join where - opts = info (configParser <**> helper) + opts = O.info (configParser <**> helper) ( fullDesc <> progDesc "hbs2-git-dashboard" <> O.header "hbs2-git-dashboard" ) diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs new file mode 100644 index 00000000..aaeb8b13 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs @@ -0,0 +1,53 @@ +module HBS2.Git.DashBoard.Prelude + ( module HBS2.Git.DashBoard.Prelude + , module HBS2.Prelude.Plated + , module HBS2.Data.Types.Refs + , module HBS2.Base58 + , module HBS2.Merkle + , module HBS2.Net.Proto.Service + , module HBS2.Storage + , module API + , module Config + , module Logger + , module Maybe + , module Reader + , module Coerce + , module TransCont + , module TransMaybe + , module UnliftIO + , qc, q + ) where + +import HBS2.Data.Types.Refs +import HBS2.Base58 +import HBS2.Net.Proto.Service +import HBS2.Prelude.Plated +import HBS2.Storage +import HBS2.Merkle + +import HBS2.System.Logger.Simple.ANSI as Logger +import HBS2.Misc.PrettyStuff as Logger + + +import HBS2.Peer.RPC.API.RefChan as API +import HBS2.Peer.RPC.API.RefLog as API +import HBS2.Peer.RPC.API.Peer as API +import HBS2.Peer.RPC.API.LWWRef as API + +import HBS2.Peer.Proto.LWWRef as API +import HBS2.Peer.Proto.RefChan.Types as API +import HBS2.Peer.Proto.RefChan.RefChanUpdate as API + + +import Data.Config.Suckless as Config + +import Text.InterpolatedString.Perl6 (qc,q) + +import Data.Maybe as Maybe +import Control.Monad.Reader as Reader +import Data.Coerce as Coerce +import Control.Monad.Trans.Cont as TransCont +import Control.Monad.Trans.Maybe as TransMaybe + +import UnliftIO + 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 20749e0a..0960d8bd 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 @@ -3,40 +3,19 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -module HBS2.Git.DashBoard.State where - -import HBS2.Prelude.Plated -import HBS2.Merkle -import HBS2.Data.Types.Refs -import HBS2.Base58 -import HBS2.Clock -import HBS2.Net.Auth.Schema -import HBS2.Misc.PrettyStuff -import HBS2.Net.Proto.Service -import HBS2.Storage - -import HBS2.Peer.Proto.LWWRef -import HBS2.Peer.Proto.RefChan.Types -import HBS2.Peer.Proto.RefChan.RefChanUpdate -import HBS2.Peer.RPC.API.RefChan +module HBS2.Git.DashBoard.State + ( module HBS2.Git.DashBoard.State + , Only(..) + ) where +import HBS2.Git.DashBoard.Prelude import HBS2.Git.DashBoard.Types -import HBS2.System.Logger.Simple.ANSI -import Data.Config.Suckless - import DBPipe.SQLite hiding (insert) import DBPipe.SQLite.Generic as G import Lucid.Base -import Data.Maybe import Data.Text qualified as Text -import Text.InterpolatedString.Perl6 (qc) -import Control.Monad.Reader -import Control.Monad.Trans.Cont -import Control.Monad.Trans.Maybe -import Data.Coerce -import Streaming.Prelude qualified as S type MyRefChan = RefChanId L4Proto @@ -203,65 +182,9 @@ selectRepoList = withState do join brief b on b.lww = r.lww |] -updateIndex :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m () -updateIndex = do - debug "updateIndex" - 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)) diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs new file mode 100644 index 00000000..183c30cd --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs @@ -0,0 +1,20 @@ +module HBS2.Git.DashBoard.State.Index + ( module HBS2.Git.DashBoard.State.Index + , module HBS2.Git.DashBoard.State.Index.Channels + , module HBS2.Git.DashBoard.State.Index.Peer + + ) where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types +import HBS2.Git.DashBoard.State.Index.Channels +import HBS2.Git.DashBoard.State.Index.Peer + +updateIndex :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m () +updateIndex = do + debug "updateIndex" + updateIndexFromPeer + updateIndexFromChannels + + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs new file mode 100644 index 00000000..ba7fd839 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs @@ -0,0 +1,75 @@ +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)) + + + 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 new file mode 100644 index 00000000..5cbfe93e --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs @@ -0,0 +1,8 @@ +module HBS2.Git.DashBoard.State.Index.Peer where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types + +updateIndexFromPeer :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m () +updateIndexFromPeer = do + debug "updateIndexFromPeer" diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs index 9f48b7d4..503ebc23 100644 --- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs @@ -6,26 +6,13 @@ module HBS2.Git.DashBoard.Types , module HBS2.Git.Data.Tx.Index ) where -import HBS2.Prelude.Plated +import HBS2.Git.DashBoard.Prelude import HBS2.Git.Data.Tx.Index -import HBS2.Net.Proto.Service -import HBS2.Storage -import HBS2.Peer.RPC.API.Peer -import HBS2.Peer.RPC.API.RefLog -import HBS2.Peer.RPC.API.RefChan -import HBS2.Peer.RPC.API.LWWRef -import HBS2.Peer.RPC.API.Storage -import HBS2.Peer.RPC.Client.StorageClient import HBS2.Net.Messaging.Unix -import Data.Config.Suckless - import DBPipe.SQLite -import Control.Monad.Reader - -import UnliftIO data HttpPortOpt diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 4920c5fb..d8c8dff6 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -144,8 +144,12 @@ executable hbs2-git-dashboard main-is: GitDashBoard.hs other-modules: + HBS2.Git.DashBoard.Prelude HBS2.Git.DashBoard.Types HBS2.Git.DashBoard.State + HBS2.Git.DashBoard.State.Index + HBS2.Git.DashBoard.State.Index.Channels + HBS2.Git.DashBoard.State.Index.Peer HBS2.Git.Web.Html.Root -- other-extensions: