wip

docs/todo/hbs2-git-dashboard.txt

@@ -4,3 +4,31 @@ FIXME: poll-fixme-refchans
 
   Сейчас не обновляются
 
+FIXME: commit-cache-inconsistency
+
+  Встретилась ситуация, когда commit помечен, как processed, но не все блобы
+  из него попали в кэш.
+
+  Похожие ситуации возникают и в hbs2-git.
+
+  Похоже, надо как-то инвертировать подход: когда искомые данные
+  встречаются в кэше --- отдаём из него, а когда нет --- ищем
+  в источнике (рефчане, дереве, репозитории).
+
+  Значит, в этих источниках должен быть некий индекс.
+
+  В git он есть.
+
+  В hbs2-git он вроде бы тоже есть.
+
+  Возможно, это будет незначительно медленнее при выдаче,
+  но сильно быстрее при индексации и система будет, типа,
+  самовосстанавливающаяся.
+
+  Возможно, это приведёт к тому, что все схемы выродятся
+  в таблицу "object", для ускорения доступа к которой
+  будут создаваться индексные таблицы (aka materialized view)
+  на её же основе только средствами sqlite.
+
+
+

hbs2-git-dashboard/app/GitDashBoard.hs

@@ -641,6 +641,7 @@ theDict = do
 
           _ -> throwIO $ BadFormException @C nil
 
+
     developAssetsEntry = do
       entry $ bindMatch "develop-assets" $ nil_ \case
         [StringLike s] -> do
@@ -668,6 +669,15 @@ theDict = do
     -- TODO: ASAP-hide-debug-functions-from-help
 
     debugEntries = do
+
+      entry $ bindMatch "debug:cache:ignore:on" $ nil_ $ const $ lift do
+        t <- asks _dashBoardIndexIgnoreCaches
+        atomically $ writeTVar t True
+
+      entry $ bindMatch "debug:cache:ignore:off" $ nil_ $ const $ lift do
+        t <- asks _dashBoardIndexIgnoreCaches
+        atomically $ writeTVar t False
+
       entry $ bindMatch "debug:select-repo-fixme" $ nil_ $ const $ lift do
         rs <- selectRepoFixme
         for_ rs $ \(r,f) -> do

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

@@ -81,9 +81,9 @@ updateIndexFromPeer = do
                   Right hxs -> do
                     for_ hxs $ \htx -> void $ runMaybeT do
 
-                      done <- lift $ withState $ isProcessed (HashRef $ hashObject @HbSync (serialise (lw,htx)))
+                      -- done <- lift $ withState $ isProcessed (HashRef $ hashObject @HbSync (serialise (lw,htx)))
 
-                      guard (not done)
+                      -- guard (not done)
 
                       getBlock sto (fromHashRef htx) >>= toMPlus
                          <&> deserialiseOrFail @(RefLogUpdate L4Proto)
@@ -105,11 +105,13 @@ updateIndexFromPeer = do
           let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv)
           insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead
 
-          insertProcessed (HashRef $ hashObject @HbSync (serialise (l,coerce @_ @HashRef tx)))
+          -- insertProcessed (HashRef $ hashObject @HbSync (serialise (l,coerce @_ @HashRef tx)))
 
           for_ fme $ \f -> do
             insertRepoFixme l rlwwseq f
 
+      buildCommitTreeIndex (coerce lw)
+
   fxe <- selectRepoFixme
 
   for_ fxe $ \(r,f)  -> do
@@ -119,3 +121,4 @@ updateIndexFromPeer = do
       addJob (withDashBoardEnv env $ updateFixmeFor r f)
 
 
+

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

@@ -57,6 +57,7 @@ data DashBoardEnv =
   , _pipeline           :: TQueue (IO ())
   , _dashBoardHttpPort  :: TVar (Maybe Word16)
   , _dashBoardDevAssets :: TVar (Maybe FilePath)
+  , _dashBoardIndexIgnoreCaches :: TVar Bool
   }
 
 makeLenses 'DashBoardEnv
@@ -94,6 +95,7 @@ newDashBoardEnv ddir peer rlog rchan lww sto  = do
         <*> newTQueueIO
         <*> newTVarIO (Just 8911)
         <*> newTVarIO Nothing
+        <*> newTVarIO False
 
 getHttpPortNumber :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m a
 getHttpPortNumber = do
@@ -106,6 +108,12 @@ getDevAssets = do
   asks _dashBoardDevAssets
     >>= readTVarIO
 
+
+getIgnoreCaches :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m Bool
+getIgnoreCaches = do
+  asks _dashBoardIndexIgnoreCaches
+    >>= readTVarIO
+
 withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a
 withDashBoardEnv env m = runReaderT (fromDashBoardM m) env