wip

hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css

@@ -89,7 +89,7 @@ nav.left {
 }
 
 nav.left .info-block {
-  margin-bottom: 4rem;
+  margin-bottom: 2rem;
   padding-left: 1em;
   padding-right: 1.2em;
 }

hbs2-git/hbs2-git-dashboard/GitDashBoard.hs

@@ -376,7 +376,7 @@ updateIndexPeriodially = do
               debug $ red "SYNC" <+> pretty cmd
               void $ runProcess $ shell cmd
 
-              lift $ buildCommitTreeIndex dir
+              lift $ buildCommitTreeIndex (coerce lww)
 
 
 main :: IO ()

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

@@ -105,6 +105,7 @@ evolveDB = do
 
   createRepoTreeIndexTable
   createRepoBlobIndexTable
+  createRepoCommitTable
 
 
 instance ToField GitHash where
@@ -185,6 +186,7 @@ data RepoTable
 data RepoChannelTable
 data RepoNameTable
 data RepoBriefTable
+data RepoCommitTable
 
 instance HasTableName RepoChannelTable where
   tableName = "repochannel"
@@ -201,6 +203,9 @@ instance HasTableName RepoBriefTable where
 instance HasTableName TxProcessedTable where
   tableName = "processed"
 
+instance HasTableName RepoCommitTable where
+  tableName = "repocommit"
+
 instance HasColumnName TxHash where
   columnName = "hash"
 
@@ -222,6 +227,9 @@ instance HasColumnName RepoRefLog where
 instance HasColumnName RepoChannel where
   columnName = "channel"
 
+instance HasColumnName RepoCommit where
+  columnName = "kommit"
+
 instance HasPrimaryKey TxProcessedTable where
   primaryKey = [G.columnName @TxHash]
 
@@ -237,6 +245,8 @@ instance HasPrimaryKey RepoNameTable where
 instance HasPrimaryKey RepoBriefTable where
   primaryKey = [G.columnName @RepoLww]
 
+instance HasPrimaryKey RepoCommitTable where
+  primaryKey = [G.columnName @RepoLww, G.columnName @RepoCommit]
 
 pattern PRefChan :: MyRefChan -> Syntax C
 pattern PRefChan s <- ListVal [ SymbolVal "refchan" , asRefChan -> Just s ]
@@ -457,6 +467,15 @@ createRepoTreeIndexTable = do
   |]
 
 
+createRepoCommitTable :: (DashBoardPerks m) => DBPipeM m ()
+createRepoCommitTable  = do
+  ddl [qc|
+    create table if not exists repocommit
+    ( lww     text not null
+    , kommit  text not null
+    , primary key (lww,kommit)
+    )
+  |]
 
 
 isProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m Bool
@@ -473,6 +492,9 @@ insertProcessed href = do
   |] (Only href)
 
 
+newtype RepoCommit = RepoCommit GitHash
+                     deriving newtype (FromField,ToField,Pretty)
+
 newtype TreeCommit = TreeCommit GitHash
                      deriving newtype (FromField,ToField,Pretty)
 
@@ -620,8 +642,10 @@ readBlob repo hash = do
     <&> fromRight mempty
 
 
-buildCommitTreeIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => FilePath -> m ()
+buildCommitTreeIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
-buildCommitTreeIndex dir = do
+buildCommitTreeIndex lww = do
+
+  dir <- repoDataPath lww
 
   let syntaxMap = Sky.defaultSyntaxMap
 
@@ -634,24 +658,26 @@ buildCommitTreeIndex dir = do
 
   withState do
 
-    for_ commits $ \co -> void $ runMaybeT do
+    for_ commits $ \co -> do
-      let hkey = ("commit-for-tree-index", co) & serialise & hashObject @HbSync & HashRef
+      let hkey = ("commit-for-tree-index", co, lww) & serialise & hashObject @HbSync & HashRef
 
-      done <- lift $ isProcessed hkey
+      here <- (select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co))
+                  <&> listToMaybe @(Only Int) <&> isJust
 
-      guard (not done)
+      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
+          root' <- gitRunCommand cmd
                     <&> fromRight mempty
                     <&> LBS8.lines
                     <&> \case
                            (TreeHash ha : _) -> Just ha
                            _                 -> Nothing
-                >>= toMPlus
-
-      lift $ transactional do
 
           items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
             <&> fromRight mempty
@@ -682,6 +708,9 @@ buildCommitTreeIndex dir = do
           for_ blobs $ \(fn, (hash, size, syn)) -> do
             insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
 
+
+          for_ root' \root -> do
+
             for_ (Map.toList trees) $ \(t,h0) -> do
 
               case t of
@@ -702,7 +731,8 @@ buildCommitTreeIndex dir = do
                            )
             -- insertTree co p h0
 
-        insertProcessed hkey
+
+      -- insertProcessed hkey
 
 
 gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs

@@ -321,7 +321,10 @@ rootPage content  = do
 
     body_ do
       header_ do
-        div_ [class_ "header-title"] $ h1_ [] $ a_ [href_ (toURL RepoListPage)] "hbs2-peer dashboard"
+        div_ [class_ "header-title"] $ h1_ [] $ do
+          a_ [href_ (toURL RepoListPage)] "hbs2-peer dashboard"
+
+
       content
 
 
@@ -838,6 +841,13 @@ repoPage tab lww params = rootPage do
   div_ [class_ "container main"] $ do
     nav_ [class_ "left"] $ do
 
+      div_ [class_ "info-block" ] do
+        div_ [ class_ "attr" ] do
+         img_ [src_ "/icon/tree-up.svg"]
+         small_ do
+           a_ [ href_ "/"] "back to projects"
+
+
       div_ [class_ "info-block" ] do
         for_ author $ \a -> do
             div_ [ class_ "attr" ] do
@@ -849,6 +859,11 @@ repoPage tab lww params = rootPage do
               div_ [ class_ "attrname"] "public:"
               div_ [ class_ "attrval"] $ toHtml p
 
+      div_ [class_ "info-block" ] do
+        when (Text.length manifest > 100) do
+            div_ [ class_ "attr" ] do
+              div_ [ class_ "attrname"] do
+                a_ [ href_ (toURL (RepoPage ManifestTab lww))] "Manifest"
 
       for_ mbHead $ \rh -> do
 
@@ -877,7 +892,6 @@ repoPage tab lww params = rootPage do
 
       nav_ [ role_ "tab-control" ] do
        repoMenu do
-        repoMenuItem  mempty $ a_ [href_ "/"] "root"
 
         let menu t = if isActiveTab tab t then repoMenuItem0 else repoMenuItem
 
@@ -886,9 +900,6 @@ repoPage tab lww params = rootPage do
                        , hxTarget_ "#repo-tab-data"
                        ] "commits"
 
-        menu ManifestTab [ hxGet_ (toURL (RepoManifest lww))
-                        , hxTarget_ "#repo-tab-data"
-                        ] "manifest"
 
         menu (TreeTab Nothing)
                     [ hxGet_ (toURL (RepoRefs lww))