wip

hbs2-git-dashboard/app/GitDashBoard.hs

@@ -28,9 +28,10 @@ import HBS2.Git.Web.Html.Root
 import HBS2.Git.Web.Html.Issue
 import HBS2.Git.Web.Html.Repo
 import HBS2.Git.Web.Html.Fixme
-
 import HBS2.Peer.CLI.Detect
 
+import DBPipe.SQLite
+
 import Data.Config.Suckless.Script
 
 import Lucid (renderTextT,HtmlT(..),toHtml)
@@ -142,7 +143,6 @@ runDashBoardM m = do
   xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard
 
   let dataDir = xdgData
-  let dbFile = xdgData </> "state.db"
 
   -- FIXME: unix-socket-from-config
   soname <- detectRPC `orDie` "hbs2-peer rpc not found"
@@ -191,6 +191,18 @@ runDashBoardM m = do
                 lwwAPI
                 sto
 
+    void $ ContT $ withAsync do
+      fix \next -> do
+        dbe' <- readTVarIO (_db env)
+        case dbe' of
+          Just dbe -> do
+            notice $ green "Aquired database!"
+            runPipe dbe
+
+          Nothing -> do
+            pause @'Seconds 5
+            next
+
     void $ ContT $ withAsync do
       q <- withDashBoardEnv env $ asks _pipeline
       forever do
@@ -678,6 +690,17 @@ theDict = do
         t <- asks _dashBoardIndexIgnoreCaches
         atomically $ writeTVar t False
 
+      entry $ bindMatch "debug:build-commit-index" $ nil_ $ \case
+        [SignPubKeyLike lw] -> lift do
+          buildCommitTreeIndex (LWWRefKey lw)
+
+        _ -> throwIO $ BadFormException @C nil
+
+        -- rs <- selectRepoFixme
+        -- for_ rs $ \(r,f) -> do
+        --   liftIO $ print $ pretty r <+> pretty (AsBase58 f)
+
+
       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.hs

@@ -769,8 +769,12 @@ buildCommitTreeIndex lww = do
   commits <- listCommits
   env <- ask
 
+  ignoreCaches <- getIgnoreCaches
+
   for_ commits $ \co -> void $ runMaybeT do
-    checkCommitProcessed co >>= guard . not
+    done <- checkCommitProcessed co
+    let skip = done && not ignoreCaches
+    guard (not skip)
     updateRepoData env co
 
   updateForks

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,12 +105,12 @@ 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)
+      -- buildCommitTreeIndex (coerce lw)
 
   fxe <- selectRepoFixme
 

hbs2-git-dashboard/hbs2-git-dashboard.cabal

@@ -178,6 +178,7 @@ executable hbs2-git-dashboard
         , hbs2-git-dashboard-core
         , hbs2-peer
         , suckless-conf
+        , db-pipe
 
         , binary
         , bytestring