wip, prelude for hbs2-git-dashboard

hbs2-git/hbs2-git-dashboard/GitDashBoard.hs

@@ -3,60 +3,36 @@
 {-# Language AllowAmbiguousTypes #-}
 module Main where
 
-import HBS2.Prelude.Plated
+import HBS2.Git.DashBoard.Prelude
-import HBS2.OrDie
 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" )

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
+

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
+module HBS2.Git.DashBoard.State
-
+  ( module HBS2.Git.DashBoard.State
-import HBS2.Prelude.Plated
+  , Only(..)
-import HBS2.Merkle
+  ) where
-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
 
+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))
 

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
+
+
+

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))
+
+
+

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"

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
 

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: