From ddaf936aaa360102c4238a3e6a74db3e863458e3 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Sat, 20 Apr 2024 16:29:27 +0300 Subject: [PATCH] wip --- .../assets/css/custom.css | 11 ++--- hbs2-git/hbs2-git-dashboard/GitDashBoard.hs | 9 ++-- .../src/HBS2/Git/DashBoard/State.hs | 43 +++++++++---------- .../src/HBS2/Git/Web/Html/Root.hs | 40 +++++++++-------- 4 files changed, 52 insertions(+), 51 deletions(-) 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 279a63e5..19ef4481 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css @@ -314,13 +314,8 @@ nav[role="tab-control"] li.active { font-family: 'Courier New', Courier, monospace; } - -.blob { - width: 16px; - height: 16px; - display: inline-block; - - background-image: url('/icon/file.svg'); - background-size: cover; +.tree { + font-weight: 600; } + diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 75c23910..d87badc6 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -222,16 +222,19 @@ runDashboardWeb wo = do refs <- lift $ gitShowRefs lww lift $ html =<< renderTextT (repoRefs lww refs) - get "/repo/:lww/tree/:hash" do + get "/repo/:lww/tree/:co/:hash" do lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) hash' <- captureParam @String "hash" <&> fromStringMay @GitHash - back <- queryParamMaybe @String "back" <&> ((fromStringMay @GitHash) =<<) + co' <- captureParam @String "co" <&> fromStringMay @GitHash flip runContT pure do lww <- lwws' & orFall (status status404) hash <- hash' & orFall (status status404) + co <- co' & orFall (status status404) tree <- lift $ gitShowTree lww hash - lift $ html =<< renderTextT (repoTree lww hash tree back) + back <- lift $ selectParentTree co hash + debug $ "selectParentTree" <+> pretty co <+> pretty hash <+> pretty back + lift $ html =<< renderTextT (repoTree lww co hash tree back) repoDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath 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 d622b123..2853cf84 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 @@ -24,6 +24,7 @@ import DBPipe.SQLite qualified as S import DBPipe.SQLite.Generic as G +import Control.Applicative import Data.ByteString.Lazy.Char8 qualified as LBS8 import Lucid.Base import Data.Text qualified as Text @@ -443,17 +444,11 @@ createRepoTreeIndexTable = do create table if not exists tree ( parent text not null , child text not null - , primary key (parent,child) + , kommit text not null + , primary key (parent,child,kommit) ) |] - ddl [qc| - create table if not exists committree - ( kommit text not null - , tree text not null - , primary key (kommit,tree) - ) - |] isProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m Bool isProcessed href = do @@ -468,24 +463,27 @@ insertProcessed href = do on conflict(hash) do nothing |] (Only href) -insertCommitTree :: (DashBoardPerks m) => GitHash -> GitHash -> DBPipeM m () -insertCommitTree commit tree = do +insertTree :: (DashBoardPerks m) => GitHash -> GitHash -> GitHash -> DBPipeM m () +insertTree commit parent child = do S.insert [qc| - insert into committree (kommit,tree) - values (?,?) - on conflict (kommit,tree) do nothing - |] (commit,tree) + insert into tree (parent,child,kommit) + values (?,?,?) + on conflict (parent,child,kommit) do nothing + |] (parent,child,commit) -insertTree :: (DashBoardPerks m) => GitHash -> GitHash -> DBPipeM m () -insertTree parent child = do - S.insert [qc| - insert into tree (parent,child) - values (?,?) - on conflict (parent,child) do nothing - |] (parent,child) +selectParentTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => GitHash -> GitHash -> m (Maybe GitHash) +selectParentTree co me = withState do + w <- select [qc|select coalesce(parent,kommit) from tree where child = ? and kommit = ?|] (me,co) + <&> listToMaybe . fmap fromOnly + + if co == me then + pure Nothing + else do + pure $ w <|> Just co {- HLINT ignore "Functor law" -} + pattern TreeHash :: GitHash -> LBS8.ByteString pattern TreeHash hash <- (LBS8.words -> (_ : (fromStringMay . LBS8.unpack -> Just hash) : _)) @@ -519,7 +517,6 @@ buildCommitTreeIndex dir = do >>= toMPlus lift $ transactional do - insertCommitTree co root trees <- gitRunCommand [qc|git --git-dir {dir} ls-tree -r -t {pretty co}|] <&> fromRight mempty @@ -538,7 +535,7 @@ buildCommitTreeIndex dir = do for_ parent $ \p -> do debug $ red "FOUND SHIT:" <+> pretty (h0,p) - insertTree p h0 + insertTree co p h0 insertProcessed hkey 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 4614fa34..fe59f6b7 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 @@ -20,10 +20,9 @@ import System.FilePath import Data.Word import Data.Either import Safe +import Data.List (sortOn) +import Data.Ord (comparing, Down(..)) -import Data.ByteString.Char8 qualified as BS8 -import Network.URI (uriToString, parseURI, URI(..), URIAuth(..)) -import Network.HTTP.Types.URI (renderQuery) import Streaming.Prelude qualified as S @@ -204,30 +203,39 @@ repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) repoRefs lww refs = do table_ [] do for_ refs $ \(r,h) -> do - let link = path [ "repo", show $ pretty lww, "tree", show (pretty h) ] + let co = show $ pretty h + let uri = path [ "repo", show $ pretty lww, "tree", co, co ] tr_ mempty do td_ mempty (toHtml $ show $ pretty r) td_ [class_ "mono"] $ a_ [ href_ "#" - , hxGet_ link + , hxGet_ uri , hxTarget_ "#repo-tab-data" ] (toHtml $ show $ pretty h) - repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> GitHash -- ^ this + -> GitHash -- ^ this -> [(GitObjectType, GitHash, Text)] -> Maybe GitHash -- ^ back -> HtmlT m () -repoTree lww root tree back' = do +repoTree lww co root tree back' = do + + let co_ = show $ pretty co + + let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree + where + tpOrder Tree = (0 :: Int) + tpOrder Blob = 1 + tpOrder _ = 2 table_ [] do tr_ mempty do for_ back' $ \root -> do - let rootLink = path [ "repo", show $ pretty lww, "tree", show (pretty root) ] + let rootLink = path [ "repo", show $ pretty lww, "tree", co_, show (pretty root) ] td_ $ img_ [src_ "/icon/tree-up.svg"] td_ ".." td_ do a_ [ href_ "#" @@ -235,19 +243,17 @@ repoTree lww root tree back' = do , hxTarget_ "#repo-tab-data" ] (toHtml $ show $ pretty root) - for_ tree $ \(tp,h,name) -> do - - let back = show $ pretty root - let backPart = [qc|?back={back}|] - - let link = path [ "repo", show $ pretty lww, "tree", show (pretty h) ] + for_ sorted $ \(tp,h,name) -> do + let itemClass = pretty tp & show & Text.pack + let hash_ = show $ pretty h + let uri = path [ "repo", show $ pretty lww, "tree", co_, hash_ ] tr_ mempty do td_ $ case tp of Blob -> img_ [src_ "/icon/blob.svg"] Tree -> img_ [src_ "/icon/tree.svg"] _ -> mempty - td_ mempty (toHtml $ show $ pretty name) + td_ [class_ itemClass] (toHtml $ show $ pretty name) td_ [class_ "mono"] do case tp of Blob -> do @@ -256,9 +262,9 @@ repoTree lww root tree back' = do Tree -> do a_ [ href_ "#" - , hxGet_ (link <> backPart) + , hxGet_ uri , hxTarget_ "#repo-tab-data" - , hxPushUrl_ "true" + -- , hxPushUrl_ "true" ] (toHtml $ show $ pretty h) _ -> mempty