mirror of https://github.com/voidlizard/hbs2
wip, prelude for hbs2-git-dashboard
This commit is contained in:
Dmitry Zuikov
parent
a7b9bf7532
commit
aa269770fb
|
|
@ -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" )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
||||
|
|
@ -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))
|
||||
|
||||
|
||||
|
||||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
Loading…
Reference in New Issue