wip

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

@@ -8,6 +8,7 @@ import HBS2.System.Dir
 
 import HBS2.Net.Messaging.Unix
 import HBS2.OrDie
+import HBS2.Polling
 
 import HBS2.Peer.RPC.API.Storage
 import HBS2.Peer.RPC.Client.StorageClient
@@ -21,8 +22,7 @@ import HBS2.Git.Web.Html.Root
 
 import HBS2.Peer.CLI.Detect
 
-
+import Lucid (renderTextT)
-import Lucid
 import Options.Applicative as O
 import Data.Either
 import Data.ByteString.Lazy qualified as LBS
@@ -33,6 +33,10 @@ import Network.Wai.Middleware.RequestLogger
 import Web.Scotty.Trans
 import System.Directory
 import Control.Monad.Except
+import System.Random
+import Data.HashMap.Strict (HashMap)
+import Data.HashMap.Strict qualified as HM
+import Control.Concurrent.STM (flushTQueue)
 
 
 configParser :: DashBoardPerks m => Parser (m ())
@@ -202,9 +206,51 @@ runScotty  = do
 
     env <- ask
 
-    addJob (withDashBoardEnv env updateIndex)
+    flip runContT pure do
 
-    scottyT pno (withDashBoardEnv env) (runDashboardWeb wo)
+      void $ ContT $ withAsync updateIndexPeriodially
+
+      scottyT pno (withDashBoardEnv env) (runDashboardWeb wo)
+
+updateIndexPeriodially :: DashBoardPerks m => DashBoardM m ()
+updateIndexPeriodially = do
+
+  cached <- newTVarIO ( mempty :: HashMap MyRefLogKey HashRef )
+
+  changes <- newTQueueIO
+
+  api <- asks _refLogAPI
+
+  env <- ask
+
+  let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 30)
+
+  flip runContT pure do
+
+    void $ ContT $ withAsync $ forever do
+      _ <- atomically $ peekTQueue changes >> flushTQueue changes
+      addJob (withDashBoardEnv env updateIndex)
+      pause @'Seconds 30
+
+    lift do
+      polling (Polling 10 10) rlogs $ \r -> do
+
+        debug $ yellow "POLL REFLOG" <+> pretty r
+
+        rv <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) api (coerce r)
+                <&> join
+
+        old <- readTVarIO cached <&> HM.lookup r
+
+        for_ rv $ \x -> do
+
+          when (rv /= old) do
+            debug $ yellow "REFLOG UPDATED" <+> pretty r <+> pretty x
+            atomically $ modifyTVar cached (HM.insert r x)
+            atomically $ writeTQueue changes r
+
+        delay <- liftIO $ randomRIO (0.5,10)
+        pause (TimeoutSec (realToFrac delay))
 
 
 main :: IO ()

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs

@@ -38,8 +38,8 @@ instance Semigroup RepoListPred where
 instance Monoid RepoListPred where
   mempty = RepoListPred Nothing Nothing
 
-type MyRefChan = RefChanId L4Proto
+type MyRefChan    = RefChanId L4Proto
-
+type MyRefLogKey  = RefLogKey 'HBS2Basic
 
 evolveDB :: DashBoardPerks m => DBPipeM m ()
 evolveDB = do
@@ -148,7 +148,7 @@ newtype RepoHeadSeq = RepoHeadSeq Word64
 
 newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic)
                      deriving stock (Generic)
-                     deriving newtype (ToField,FromField)
+                     deriving newtype (ToField,FromField,Pretty)
 
 newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef)
                       deriving stock (Generic)
@@ -410,4 +410,8 @@ insertRepoHead lww lwwseq rlog tx rf rh = do
 
   pure ()
 
+selectRefLogs :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoRefLog]
+selectRefLogs = withState do
+  select_ [qc|select distinct(reflog) from repolistview|] <&> fmap fromOnly
+