diff --git a/hbs2-git-dashboard/app/GitDashBoard.hs b/hbs2-git-dashboard/app/GitDashBoard.hs index 36a7e99a..e7d8a719 100644 --- a/hbs2-git-dashboard/app/GitDashBoard.hs +++ b/hbs2-git-dashboard/app/GitDashBoard.hs @@ -441,59 +441,105 @@ 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 - polling (Polling 1 30) rlogs $ \r -> do + p2 <- pollRepos changes - debug $ yellow "POLL REFLOG" <+> pretty r + p3 <- pollFixmies - rv <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) api (coerce r) - <&> join + void $ waitAnyCatchCancel [p1,p2,p3] - old <- readTVarIO cached <&> HM.lookup r + where - for_ rv $ \x -> do + pollFixmies = do - when (rv /= old) do - debug $ yellow "REFLOG UPDATED" <+> pretty r <+> pretty x - atomically $ modifyTVar cached (HM.insert r x) - atomically $ writeTQueue changes r + env <- ask - flip runContT pure $ callCC $ \exit -> do + api <- asks _refChanAPI - lww <- lift (selectLwwByRefLog (RepoRefLog r)) - >>= maybe (exit ()) pure + cached <- newTVarIO ( mempty :: HashMap MyRefChan HashRef ) - dir <- lift $ repoDataPath (coerce lww) + let chans = selectRepoFixme + <&> fmap (,60) - here <- doesDirectoryExist dir + ContT $ withAsync $ do + polling (Polling 1 30) chans $ \(l,r) -> do + debug $ yellow "POLL FIXME CHAN" <+> pretty (AsBase58 r) - unless here do - debug $ red "INIT DATA DIR" <+> pretty dir - mkdir dir - void $ runProcess $ shell [qc|git --git-dir {dir} init --bare|] + void $ runMaybeT do - let cmd = [qc|git --git-dir {dir} hbs2 import {show $ pretty lww}|] - debug $ red "SYNC" <+> pretty cmd - void $ runProcess $ shell cmd + 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 + + 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 + + flip runContT pure $ callCC $ \exit -> do + + lww <- lift (selectLwwByRefLog (RepoRefLog r)) + >>= maybe (exit ()) pure + + dir <- lift $ repoDataPath (coerce lww) + + here <- doesDirectoryExist dir + + unless here do + debug $ red "INIT DATA DIR" <+> pretty dir + mkdir dir + void $ runProcess $ shell [qc|git --git-dir {dir} init --bare|] + + let cmd = [qc|git --git-dir {dir} hbs2 import {show $ pretty lww}|] + debug $ red "SYNC" <+> pretty cmd + void $ runProcess $ shell cmd + + lift $ buildCommitTreeIndex (coerce lww) - lift $ buildCommitTreeIndex (coerce lww) quit :: DashBoardPerks m => m () quit = liftIO exitSuccess diff --git a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs b/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs index 58952c97..f694a10a 100644 --- a/hbs2-git-dashboard/hbs2-git-dashboard-core/HBS2/Git/DashBoard/State.hs +++ b/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