diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css
index 4faf5f7e..acc73fed 100644
--- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css
+++ b/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;
}
diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/logo-small.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/logo-small.svg
new file mode 100644
index 00000000..d2f555c9
--- /dev/null
+++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/logo-small.svg
@@ -0,0 +1,108 @@
+
+
+
+
diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/logo_black.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/logo_black.svg
new file mode 100644
index 00000000..8ea5228f
--- /dev/null
+++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/logo_black.svg
@@ -0,0 +1,66 @@
+
+
+
+
diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
index 6c2ca6c8..4389487f 100644
--- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
+++ b/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 ()
diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs
index 9de7579a..2cf3a339 100644
--- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs
+++ b/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 dir = do
+buildCommitTreeIndex :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m ()
+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
- let hkey = ("commit-for-tree-index", co) & serialise & hashObject @HbSync & HashRef
+ for_ commits $ \co -> do
+ 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
- <&> fromRight mempty
- <&> LBS8.lines
- <&> \case
- (TreeHash ha : _) -> Just ha
- _ -> Nothing
- >>= toMPlus
+ insert @RepoCommitTable $ onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co)
- 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}|]
- <&> fromRight mempty
- <&> fmap LBS8.words . LBS8.lines
- <&> mapMaybe \case
- [_,"tree",h,_,n] ->
- (reverse $ splitDirectories $ LBS8.unpack n,) <$> fmap Right (fromStringMay @GitHash (LBS8.unpack h))
+ root' <- gitRunCommand cmd
+ <&> fromRight mempty
+ <&> LBS8.lines
+ <&> \case
+ (TreeHash ha : _) -> Just ha
+ _ -> Nothing
- [_,"blob",h,size,n] -> do
- let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n)
- <&> List.singleton
+ items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|]
+ <&> fromRight mempty
+ <&> 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)
- let sz = readMay @Integer (LBS8.unpack size)
+ [_,"blob",h,size,n] -> do
+ let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n)
+ <&> List.singleton
- let syn = Sky.syntaxesByFilename syntaxMap (LBS8.unpack n)
- & headMay
- <&> Text.toLower . Sky.sName
+ let ha = fromStringMay @GitHash (LBS8.unpack h)
+ let sz = readMay @Integer (LBS8.unpack size)
- (,) <$> 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
- insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn)
+ let blobs = [ (k,v) | ([k],Left v) <- items ]
- 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
- debug $ red "TREE-REL:" <+> pretty t
- let parent = Map.lookup child trees
+ for_ root' \root -> do
- for_ parent $ \p -> do
- debug $ red "FOUND SHIT:" <+> pretty (h0,p)
- insertTree ( TreeCommit co
- , TreeParent p
- , TreeTree h0
- , TreeLevel (length t)
- , TreePath (headDef "" t)
- )
+ 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)
+ )
-- insertTree co p h0
- insertProcessed hkey
+
+ -- insertProcessed hkey
gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m)
diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs
index 5e2d1587..f0f6a386 100644
--- a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs
+++ b/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))