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,75 +658,81 @@ 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
 
-      let cmd =  [qc|git --git-dir {dir} cat-file commit {pretty co}|]
+        transactional do
 
-      root <- gitRunCommand cmd
+          insert @RepoCommitTable $ onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
-                <&> fromRight mempty
-                <&> LBS8.lines
-                <&> \case
-                       (TreeHash ha : _) -> Just ha
-                       _                 -> Nothing
-                >>= toMPlus
 
-      lift $ transactional do
+          let cmd =  [qc|git --git-dir {dir} cat-file commit {pretty co}|]
 
-        items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
+          root' <- gitRunCommand cmd
-          <&> fromRight mempty
+                    <&> fromRight mempty
-          <&> fmap LBS8.words . LBS8.lines
+                    <&> LBS8.lines
-          <&> mapMaybe \case
+                    <&> \case
-                [_,"tree",h,_,n] ->
+                           (TreeHash ha : _) -> Just ha
-                  (reverse $ splitDirectories $ LBS8.unpack n,) <$> fmap Right (fromStringMay @GitHash (LBS8.unpack h))
+                           _                 -> Nothing
 
-                [_,"blob",h,size,n] -> do
+          items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
-                  let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n)
+            <&> fromRight mempty
-                             <&> List.singleton
+            <&> fmap LBS8.words . LBS8.lines
+            <&> mapMaybe \case
+                  [_,"tree",h,_,n] ->
+                    (reverse $ splitDirectories $ LBS8.unpack n,) <$> fmap Right (fromStringMay @GitHash (LBS8.unpack h))
 
-                  let ha  = fromStringMay @GitHash (LBS8.unpack h)
+                  [_,"blob",h,size,n] -> do
-                  let sz  = readMay @Integer (LBS8.unpack size)
+                    let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n)
+                               <&> List.singleton
 
-                  let syn = Sky.syntaxesByFilename syntaxMap (LBS8.unpack n)
+                    let ha  = fromStringMay @GitHash (LBS8.unpack h)
-                              & headMay
+                    let sz  = readMay @Integer (LBS8.unpack size)
-                              <&> Text.toLower . Sky.sName
 
-                  (,) <$> fn <*> fmap Left ( (,,) <$> ha <*> sz <*> pure syn )
+                    let syn = Sky.syntaxesByFilename syntaxMap (LBS8.unpack n)
+                                & headMay
+                                <&> Text.toLower . Sky.sName
 
-                _ -> Nothing
+                    (,) <$> fn <*> fmap Left ( (,,) <$> ha <*> sz <*> pure syn )
 
-        let trees = Map.fromList [ (k,v) | (k,Right v) <- items ]
+                  _ -> Nothing
 
-        let blobs = [ (k,v) | ([k],Left v) <- items ]
+          let trees = Map.fromList [ (k,v) | (k,Right v) <- items ]
 
-        for_ blobs $ \(fn, (hash, size, syn)) -> do
+          let blobs = [ (k,v) | ([k],Left v) <- items ]
-          insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
 
-        for_ (Map.toList trees) $ \(t,h0) -> do
+          for_ blobs $ \(fn, (hash, size, syn)) -> do
+            insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
 
-          case t of
-            [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
-            _   -> pure ()
 
-          let child = tailSafe t
+          for_ root' \root -> do
-          debug $ red "TREE-REL:" <+> pretty t
-          let parent = Map.lookup child trees
 
-          for_ parent $ \p -> do
+            for_ (Map.toList trees) $ \(t,h0) -> do
-            debug $ red "FOUND SHIT:" <+> pretty (h0,p)
+
-            insertTree ( TreeCommit co
+              case t of
-                       , TreeParent p
+                [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x)
-                       , TreeTree h0
+                _   -> pure ()
-                       , TreeLevel (length t)
+
-                       , TreePath (headDef "" t)
+              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
+
+      -- 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))