wip

hbs2-git-dashboard/app/GitDashBoard.hs

@@ -441,24 +441,69 @@ runRPC = do
 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 (, 60)
+  changes <- newTQueueIO
 
   flip runContT pure do
 
-    void $ ContT $ withAsync $ forever do
+    p1 <- ContT $ withAsync $ forever do
       rs <- atomically $ peekTQueue changes >> flushTQueue changes
       addJob (withDashBoardEnv env updateIndex)
       pause @'Seconds 1
 
-    lift do
+    p2 <- pollRepos changes
+
+    p3 <- pollFixmies
+
+    void $ waitAnyCatchCancel [p1,p2,p3]
+
+  where
+
+    pollFixmies = do
+
+      env <- ask
+
+      api <- asks _refChanAPI
+
+      cached <- newTVarIO ( mempty :: HashMap MyRefChan HashRef )
+
+      let chans = selectRepoFixme
+                   <&> fmap (,60)
+
+      ContT $ withAsync $ do
+        polling (Polling 1 30) chans $ \(l,r) -> do
+          debug $ yellow "POLL FIXME CHAN" <+> pretty (AsBase58 r)
+
+          void $ runMaybeT do
+
+            new <- lift (callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) api (coerce r))
+                    <&> join
+                    >>= toMPlus
+
+            old <- readTVarIO cached <&> HM.lookup r
+
+            when (Just new /= old) $ lift do
+              debug $ yellow "fixme refchan changed" <+> "run update" <+> pretty new
+              addJob do
+                -- TODO: this-is-not-100-percent-reliable
+                --   $workflow: backlog
+                --   откуда нам вообще знать, что там всё получилось?
+                atomically $ modifyTVar cached (HM.insert r new)
+                void $ try @_ @SomeException (withDashBoardEnv env $ updateFixmeFor l r)
+
+
+    pollRepos changes = do
+
+      cached <- newTVarIO ( mempty :: HashMap MyRefLogKey HashRef )
+
+      api <- asks _refLogAPI
+      let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 60)
+
+      ContT $ withAsync $ do
         polling (Polling 1 30) rlogs $ \r -> do
 
           debug $ yellow "POLL REFLOG" <+> pretty r
@@ -495,6 +540,7 @@ updateIndexPeriodially = do
 
                 lift $ buildCommitTreeIndex (coerce lww)
 
+
 quit :: DashBoardPerks m => m ()
 quit = liftIO exitSuccess
 

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

@@ -175,7 +175,7 @@ newtype RepoCommitsNum = RepoCommitsNum Int
 
 newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic)
                   deriving stock (Generic,Ord,Eq)
-                  deriving newtype (ToField,FromField,Pretty)
+                  deriving newtype (ToField,FromField,Pretty,Hashable)
 
 instance Show RepoLww where
   show (RepoLww x) = show $ parens $  "RepoLww" <+> pretty x