wip

hbs2-git-dashboard/app/GitDashBoard.hs

@@ -696,6 +696,17 @@ theDict = do
 
         _ -> throwIO $ BadFormException @C nil
 
+
+      entry $ bindMatch "debug:build-single-commit-index" $ nil_ $ \case
+        [SignPubKeyLike lw, StringLike h'] -> lift do
+
+          h <- fromStringMay @GitHash h'
+                  & orThrowUser ("invalid git object hash" <+> pretty h')
+
+          buildSingleCommitTreeIndex (LWWRefKey lw) h
+
+        _ -> throwIO $ BadFormException @C nil
+
         -- rs <- selectRepoFixme
         -- for_ rs $ \(r,f) -> do
         --   liftIO $ print $ pretty r <+> pretty (AsBase58 f)

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

@@ -758,32 +758,8 @@ readBlob repo hash = do
     <&> fromRight mempty
 
 
-buildCommitTreeIndex :: ( MonadUnliftIO m
+updateForks :: (MonadIO m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
-                        , DashBoardPerks m
+updateForks lww = withState do
-                        , MonadReader DashBoardEnv m
-                        )
-                     => LWWRefKey 'HBS2Basic
-                     -> m ()
-buildCommitTreeIndex lww = do
-
-  commits <- listCommits
-  env <- ask
-
-  ignoreCaches <- getIgnoreCaches
-
-  for_ commits $ \co -> void $ runMaybeT do
-    done <- checkCommitProcessed co
-    let skip = done && not ignoreCaches
-    guard (not skip)
-    updateRepoData env co
-
-  updateForks
-
-  where
-
-    syntaxMap = Sky.defaultSyntaxMap
-
-    updateForks = withState do
 
   S.insert [qc|
     insert into fork (a,b)
@@ -796,42 +772,30 @@ buildCommitTreeIndex lww = do
 
   pure ()
 
-    updateRepoData env co  = do
+checkCommitProcessed :: (MonadIO m, MonadReader DashBoardEnv m)
+                     => LWWRefKey 'HBS2Basic -> GitHash -> m Bool
+checkCommitProcessed lww co = withState do
+  select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co)
+    <&> listToMaybe @(Only Int) <&> isJust
 
-      root <- getRootTree co >>= toMPlus
+listCommits :: (MonadUnliftIO m, MonadReader DashBoardEnv m)
-      (trees, blobs) <- getTreeRecursive co
+            => LWWRefKey HBS2Basic -> m [GitHash]
-
+listCommits lww = do
-      lift $ addJob $ liftIO $ withDashBoardEnv env do
+  dir <- repoDataPath lww
-
+  gitRunCommand [qc|git --git-dir {dir} rev-list --all|]
-        withState $ transactional do
+            <&> fromRight mempty
-
+            <&> mapMaybe (headMay . LBS8.words) . LBS8.lines
-          insert @RepoCommitTable $
+            <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
-            onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
-
-          for_ blobs $ \(fn, (hash, size, syn)) -> do
-            insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
-
-            for_ (Map.toList trees) $ \(t,h0) -> do
-
-              case t of
-                [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
-                _   -> pure ()
-
-              let child = tailSafe t
-              debug $ red "TREE-REL:" <+> pretty t
-              let parent = Map.lookup child trees
-
-              for_ parent $ \p -> do
-                debug $ red "FOUND SHIT:" <+> pretty (h0,p)
-                insertTree ( TreeCommit co
-                           , TreeParent p
-                           , TreeTree h0
-                           , TreeLevel (length t)
-                           , TreePath (headDef "" t)
-                           )
 
 
-    getTreeRecursive co = lift do
+getTreeRecursive :: (MonadUnliftIO m,MonadReader DashBoardEnv m)
+                 => LWWRefKey HBS2Basic
+                 -> GitHash
+                 -> m  (Map [FilePath] GitHash,[(FilePath, (GitHash, Integer, Maybe Text))])
+getTreeRecursive lww co = do
+
+  let syntaxMap = Sky.defaultSyntaxMap
+
   dir <- repoDataPath lww
   items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
     <&> fromRight mempty
@@ -859,7 +823,9 @@ buildCommitTreeIndex lww = do
   let blobs = [ (k,v) | ([k],Left v) <- items ]
   pure (trees, blobs)
 
-    getRootTree co = lift do
+getRootTree :: (MonadUnliftIO m, MonadReader DashBoardEnv m)
+            => LWWRefKey HBS2Basic -> GitHash -> m (Maybe GitHash)
+getRootTree lww co = do
   dir <- repoDataPath lww
   let cmd =  [qc|git --git-dir {dir} cat-file commit {pretty co}|]
 
@@ -870,16 +836,84 @@ buildCommitTreeIndex lww = do
            (TreeHash ha : _) -> Just ha
            _                 -> Nothing
 
-    checkCommitProcessed co = lift $ withState do
+updateRepoData :: (MonadReader DashBoardEnv m, MonadUnliftIO m)
-      select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co)
+               => LWWRefKey HBS2Basic -> GitHash -> m ()
-        <&> listToMaybe @(Only Int) <&> isJust
+updateRepoData lww co  = do
 
-    listCommits = do
+  env <- ask
-      dir <- repoDataPath lww
+
-      gitRunCommand [qc|git --git-dir {dir} rev-list --all|]
+  void $ runMaybeT do
-                <&> fromRight mempty
+
-                <&> mapMaybe (headMay . LBS8.words) . LBS8.lines
+    root <- lift (getRootTree lww co) >>= toMPlus
-                <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
+    (trees, blobs) <- lift $ getTreeRecursive lww co
+
+    -- lift $ addJob $ liftIO $ withDashBoardEnv env do
+
+    lift $ withState $ transactional do
+
+      insert @RepoCommitTable $
+        onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
+
+      for_ blobs $ \(fn, (hash, size, syn)) -> do
+        insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
+
+        for_ (Map.toList trees) $ \(t,h0) -> do
+
+          case t of
+            [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
+            _   -> pure ()
+
+          let child = tailSafe t
+          debug $ red "TREE-REL:" <+> pretty t
+          let parent = Map.lookup child trees
+
+          for_ parent $ \p -> do
+            debug $ red "FOUND SHIT:" <+> pretty (h0,p)
+            insertTree ( TreeCommit co
+                       , TreeParent p
+                       , TreeTree h0
+                       , TreeLevel (length t)
+                       , TreePath (headDef "" t)
+                       )
+
+  updateForks lww
+
+buildSingleCommitTreeIndex :: ( MonadUnliftIO m
+                              , DashBoardPerks m
+                              , MonadReader DashBoardEnv m
+                              )
+                     => LWWRefKey 'HBS2Basic
+                     -> GitHash
+                     -> m ()
+buildSingleCommitTreeIndex lww co = do
+
+  env <- ask
+  ignoreCaches <- getIgnoreCaches
+
+  void $ runMaybeT do
+    done <- checkCommitProcessed lww co
+    let skip = done && not ignoreCaches
+    guard (not skip)
+    lift $ updateRepoData lww co
+
+buildCommitTreeIndex :: ( MonadUnliftIO m
+                        , DashBoardPerks m
+                        , MonadReader DashBoardEnv m
+                        )
+                     => LWWRefKey 'HBS2Basic
+                     -> m ()
+buildCommitTreeIndex lww = do
+
+  commits <- listCommits lww
+  env <- ask
+
+  ignoreCaches <- getIgnoreCaches
+
+  for_ commits $ \co -> void $ runMaybeT do
+    done <- checkCommitProcessed lww co
+    let skip = done && not ignoreCaches
+    guard (not skip)
+    lift $ addJob $ withDashBoardEnv env (updateRepoData lww co)
 
   -- FIXME: check-names-with-spaces