wip

hbs2-core/lib/HBS2/Prelude.hs

@@ -24,7 +24,7 @@ module HBS2.Prelude
   , (&), (<&>), for_, for
   , HasErrorStatus(..), ErrorStatus(..), SomeError(..), WithSomeError(..), mayE, someE
   , ByFirst(..)
-  , whenTrue
+  , whenTrue, whenFalse
   ) where
 
 import HBS2.Clock
@@ -99,6 +99,9 @@ instance Monad m => ToMPlus (MaybeT m) (Either x a) where
 whenTrue :: forall m b a . (Monad m) => b -> Bool -> m a -> (b -> m a) -> m a
 whenTrue b f fallback continue = if f then continue b else fallback
 
+whenFalse :: forall m b a . (Monad m) => b -> Bool -> m a -> (b -> m a) -> m a
+whenFalse b f fallback continue = if not f then continue b else fallback
+
 data ErrorStatus = Complete
                  | HasIssuesButOkay
                  | Failed

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

@@ -106,6 +106,7 @@ evolveDB = do
   createRepoTreeIndexTable
   createRepoBlobIndexTable
   createRepoCommitTable
+  createForksTable
 
 
 instance ToField GitHash where
@@ -382,6 +383,16 @@ where rn = 1;
   |]
 
 
+createForksTable :: DashBoardPerks m => DBPipeM m ()
+createForksTable = do
+  ddl [qc|
+    create table if not exists forks
+      ( a text not null
+      , b text not null
+      , primary key (a,b)
+      )
+  |]
+
 createRepoHeadTable :: DashBoardPerks m => DBPipeM m ()
 createRepoHeadTable = do
   ddl [qc|
@@ -519,8 +530,7 @@ insertTree (commit,parent,tree,level,path) = do
   insert into tree (parent,tree,kommit,level,path)
   values (?,?,?,?,?)
   on conflict (parent,tree,kommit)
-  do update set level = excluded.level
+  do nothing
-              , path  = excluded.path
   |] (parent,tree,commit,level,path)
 
 selectParentTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
@@ -642,43 +652,57 @@ readBlob repo hash = do
     <&> fromRight mempty
 
 
-buildCommitTreeIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
+buildCommitTreeIndex :: ( MonadUnliftIO m
+                        , DashBoardPerks m
+                        , MonadReader DashBoardEnv m
+                        )
+                     => LWWRefKey 'HBS2Basic
+                     -> m ()
 buildCommitTreeIndex lww = do
 
+  commits <- listCommits
+  env <- ask
+
+  for_ commits $ \co -> void $ runMaybeT do
+    checkCommitProcessed co >>= guard . not
+    root <- getRootTree co >>= toMPlus
+    (trees, blobs) <- getTreeRecursive co
+
+    lift $ addJob $ liftIO $ withDashBoardEnv env do
+
+      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)
+                         )
+
+  where
+
+    syntaxMap = Sky.defaultSyntaxMap
+
+    getTreeRecursive co = lift do
       dir <- repoDataPath lww
-
-  let syntaxMap = Sky.defaultSyntaxMap
-
-  commits <- gitRunCommand [qc|git --git-dir {dir} rev-list --all|]
-              <&> fromRight mempty
-              <&> mapMaybe (headMay . LBS8.words) . LBS8.lines
-              <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
-
-  -- FIXME: check-names-with-spaces
-
-  withState do
-
-    for_ commits $ \co -> do
-      let hkey = ("commit-for-tree-index", co, lww) & serialise & hashObject @HbSync & HashRef
-
-      here <- (select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co))
-                  <&> listToMaybe @(Only Int) <&> isJust
-
-      unless here do
-
-        transactional do
-
-          insert @RepoCommitTable $ onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
-
-          let cmd =  [qc|git --git-dir {dir} cat-file commit {pretty co}|]
-
-          root' <- gitRunCommand cmd
-                    <&> fromRight mempty
-                    <&> LBS8.lines
-                    <&> \case
-                           (TreeHash ha : _) -> Just ha
-                           _                 -> Nothing
-
       items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
         <&> fromRight mempty
         <&> fmap LBS8.words . LBS8.lines
@@ -702,37 +726,32 @@ buildCommitTreeIndex lww = do
               _ -> Nothing
 
       let trees = Map.fromList [ (k,v) | (k,Right v) <- items ]
-
       let blobs = [ (k,v) | ([k],Left v) <- items ]
+      pure (trees, blobs)
 
-          for_ blobs $ \(fn, (hash, size, syn)) -> do
+    getRootTree co = lift do
-            insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
+      dir <- repoDataPath lww
+      let cmd =  [qc|git --git-dir {dir} cat-file commit {pretty co}|]
 
+      gitRunCommand cmd
+        <&> fromRight mempty
+        <&> LBS8.lines
+        <&> \case
+               (TreeHash ha : _) -> Just ha
+               _                 -> Nothing
 
-          for_ root' \root -> do
+    checkCommitProcessed co = lift $ withState do
+      select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co)
+        <&> listToMaybe @(Only Int) <&> isJust
 
-            for_ (Map.toList trees) $ \(t,h0) -> do
+    listCommits = do
+      dir <- repoDataPath lww
+      gitRunCommand [qc|git --git-dir {dir} rev-list --all|]
+                <&> fromRight mempty
+                <&> mapMaybe (headMay . LBS8.words) . LBS8.lines
+                <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack)
 
-              case t of
+  -- FIXME: check-names-with-spaces
-                [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)
-                           )
-            -- insertTree co p h0
-
-
-      -- insertProcessed hkey
 
 
 gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)