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 cbe5bda3..4faf5f7e 100644 --- a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css @@ -367,7 +367,7 @@ tr.commit-brief-details th { } td.commit-brief-title { - background-color: + text-align: left; } tr.commit-brief-last td { @@ -378,6 +378,16 @@ tr.commit-brief-last th { border: none; } +td.commit-icon { + width: 4rem; + /* width: px; */ +} + +td.commit-hash { + width: 10rem; + text-align: left; +} + pre > code.sourceCode { white-space: pre; position: relative; } pre > code.sourceCode > span { line-height: 1.25; } diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 817606f8..6c2ca6c8 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -194,7 +194,7 @@ runDashboardWeb wo = do lww <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) >>= orThrow (itemNotFound "repository key") - redirect (LT.fromStrict $ toURL (RepoPage CommitsTab lww)) + redirect (LT.fromStrict $ toURL (RepoPage (CommitsTab Nothing) lww)) get (routePattern (RepoPage "tab" "lww")) do lww <- captureParam @String "lww" <&> fromStringMay @@ -202,7 +202,7 @@ runDashboardWeb wo = do tab <- captureParam @String "tab" <&> fromStringMay - <&> fromMaybe CommitsTab + <&> fromMaybe (CommitsTab Nothing) qp <- queryParams @@ -241,11 +241,7 @@ runDashboardWeb wo = do lww <- lwws' & orFall (status status404) hash <- hash' & orFall (status status404) co <- co' & orFall (status status404) - tree <- lift $ gitShowTree lww hash - back <- lift $ selectParentTree (TreeCommit co) (TreeTree hash) - - debug $ "selectParentTree" <+> pretty co <+> pretty hash <+> pretty back - lift $ html =<< renderTextT (repoTree lww co hash tree (coerce <$> back)) + lift $ html =<< renderTextT (repoTree lww co hash) get (routePattern (RepoBlob "lww" "co" "hash" "blob")) do lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) @@ -292,7 +288,7 @@ runDashboardWeb wo = do -- FIXME: this referrer <- lift (Scotty.header "Referer") - >>= orFall (redirect $ LT.fromStrict $ toURL (RepoPage CommitsTab lww)) + >>= orFall (redirect $ LT.fromStrict $ toURL (RepoPage (CommitsTab Nothing) lww)) lift $ renderHtml (repoCommits lww (Left pred)) 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 cd741008..2258cc06 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 @@ -60,10 +60,9 @@ data family Tabs a :: Type data RepoListPage = RepoListPage -data RepoPageTabs = CommitsTab - | CommitsTabPred GitHash +data RepoPageTabs = CommitsTab (Maybe GitHash) | ManifestTab - | TreeTab + | TreeTab (Maybe GitHash) deriving stock (Eq,Ord,Show) data RepoPage s a = RepoPage s a @@ -72,6 +71,8 @@ data RepoRefs repo = RepoRefs repo data RepoTree repo commit tree = RepoTree repo commit tree +data RepoTreeEmbedded repo commit tree = RepoTreeEmbedded repo commit tree + data RepoBlob repo commit tree blob = RepoBlob repo commit tree blob newtype RepoManifest repo = RepoManifest repo @@ -86,6 +87,13 @@ data RepoCommitSummaryQ repo commit = RepoCommitSummaryQ repo commit data RepoCommitPatchQ repo commit = RepoCommitPatchQ repo commit +isActiveTab :: RepoPageTabs -> RepoPageTabs -> Bool +isActiveTab a b = case (a,b) of + (CommitsTab{},CommitsTab{}) -> True + (ManifestTab{},ManifestTab{}) -> True + (TreeTab{},TreeTab{}) -> True + _ -> False + toArg :: (Semigroup a, IsString a) => a -> a toArg s = ":" <> s @@ -94,17 +102,16 @@ toPattern = fromString . Text.unpack instance Pretty RepoPageTabs where pretty = \case - CommitsTab -> "commits" - CommitsTabPred{} -> "commits" - ManifestTab -> "manifest" - TreeTab -> "tree" + CommitsTab{} -> "commits" + ManifestTab{} -> "manifest" + TreeTab{} -> "tree" instance FromStringMaybe RepoPageTabs where fromStringMay = \case - "commits" -> pure CommitsTab + "commits" -> pure (CommitsTab Nothing) "manifest" -> pure ManifestTab - "tree" -> pure TreeTab - _ -> pure CommitsTab + "tree" -> pure (TreeTab Nothing) + _ -> pure (CommitsTab Nothing) instance ToRoutePattern RepoListPage where routePattern = \case @@ -115,7 +122,8 @@ instance ToURL (RepoPage RepoPageTabs (LWWRefKey 'HBS2Basic)) where <> pred_ where pred_ = case s of - CommitsTabPred p -> Text.pack $ "?ref=" <> show (pretty p) + CommitsTab (Just p) -> Text.pack $ "?ref=" <> show (pretty p) + TreeTab (Just p) -> Text.pack $ "?tree=" <> show (pretty p) _ -> mempty instance ToRoutePattern (RepoPage String String) where @@ -208,6 +216,18 @@ instance ToRoutePattern (RepoCommitPatchQ String String) where path ["/", "htmx", "commit", "patch", toArg r, toArg h] & toPattern +instance ToURL (RepoTreeEmbedded (LWWRefKey 'HBS2Basic) GitHash GitHash) where + toURL (RepoTreeEmbedded k co tree') = path ["/", "htmx", "tree", "embedded", repo, commit, tree] + where + repo = show $ pretty k + commit = show $ pretty co + tree = show $ pretty tree' + +instance ToRoutePattern (RepoTreeEmbedded String String String) where + routePattern (RepoTreeEmbedded r co tree) = + path ["/", "htmx", "tree", "embedded", toArg r, toArg co, toArg tree] & toPattern + + myCss :: Monad m => HtmlT m () myCss = do link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])] @@ -264,7 +284,7 @@ instance ToHtml (WithTime RepoListItem) where let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0 - let url = toURL (RepoPage CommitsTab (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww)) + let url = toURL (RepoPage (CommitsTab Nothing) (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww)) -- path ["repo", Text.unpack $ view rlRepoLwwAsText it] let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq @@ -385,7 +405,8 @@ thisRepoManifest it@RepoListItem{..} = do repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> HtmlT m () -repoRefs lww = do +repoRefs lww = do + refs <- lift $ gitShowRefs lww table_ [] do for_ refs $ \(r,h) -> do @@ -451,15 +472,35 @@ treeLocator lww co locator next = do ] (toHtml (show $ pretty name)) next + +repoTreeEmbedded :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> GitHash -- ^ this + -> GitHash -- ^ this + -> HtmlT m () + +repoTreeEmbedded = repoTree_ True + + repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> GitHash -- ^ this -> GitHash -- ^ this - -> [(GitObjectType, GitHash, Text)] - -> Maybe GitHash -- ^ back -> HtmlT m () -repoTree lww co root tree back' = do +repoTree = repoTree_ False + +repoTree_ :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => Bool + -> LWWRefKey 'HBS2Basic + -> GitHash -- ^ this + -> GitHash -- ^ this + -> HtmlT m () + +repoTree_ embed lww co root = do + + tree <- lift $ gitShowTree lww root + back' <- lift $ selectParentTree (TreeCommit co) (TreeTree root) let syntaxMap = Sky.defaultSyntaxMap @@ -471,22 +512,26 @@ repoTree lww co root tree back' = do locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root) + let target = if embed then "#repo-tab-data-embedded" else "#repo-tab-data" + table_ [] do - tr_ do - td_ [class_ "tree-locator", colspan_ "3"] do - treeLocator lww co locator none + unless embed do - tr_ mempty do + tr_ do + td_ [class_ "tree-locator", colspan_ "3"] do + treeLocator lww co locator none - for_ back' $ \root -> do - let rootLink = toURL (RepoTree lww co root) - td_ $ img_ [src_ "/icon/tree-up.svg"] - td_ ".." - td_ do a_ [ href_ "#" - , hxGet_ rootLink - , hxTarget_ "#repo-tab-data" - ] (toHtml $ show $ pretty root) + tr_ mempty do + + for_ back' $ \r -> do + let rootLink = toURL (RepoTree lww co (coerce @_ @GitHash r)) + td_ $ img_ [src_ "/icon/tree-up.svg"] + td_ ".." + td_ do a_ [ href_ "#" + , hxGet_ rootLink + , hxTarget_ target + ] (toHtml $ show $ pretty r) for_ sorted $ \(tp,h,name) -> do let itemClass = pretty tp & show & Text.pack @@ -524,13 +569,13 @@ repoTree lww co root tree back' = do let blobUri = toURL $ RepoBlob lww co root h a_ [ href_ "#" , hxGet_ blobUri - , hxTarget_ "#repo-tab-data" + , hxTarget_ target ] (toHtml hash_) Tree -> do a_ [ href_ "#" , hxGet_ uri - , hxTarget_ "#repo-tab-data" + , hxTarget_ target ] (toHtml hash_) _ -> mempty @@ -562,10 +607,8 @@ repoCommit style lww hash = do table_ [class_ "item-attr"] do tr_ do - th_ [width_ "16rem"] $ strong_ "commit" - td_ $ a_ [ href_ "#" - , hxGet_ (toURL (RepoTree lww hash hash)) - , hxTarget_ "#repo-tab-data" + th_ [width_ "16rem"] $ strong_ "back" + td_ $ a_ [ href_ (toURL (RepoPage (CommitsTab Nothing) lww)) ] $ toHtml $ show $ pretty hash for_ au $ \author -> do @@ -577,17 +620,19 @@ repoCommit style lww hash = do th_ $ strong_ "view" td_ do ul_ [class_ "misc-menu"]do - unless (style == RepoCommitSummary ) do li_ $ a_ [ href_ "#" , hxGet_ (toURL (RepoCommitSummaryQ lww hash)) , hxTarget_ "#repo-tab-data" ] "summary" - unless (style == RepoCommitPatch ) do + li_ $ a_ [ href_ "#" , hxGet_ (toURL (RepoCommitPatchQ lww hash)) , hxTarget_ "#repo-tab-data" ] "patch" + li_ $ a_ [ href_ (toURL (RepoPage (TreeTab (Just hash)) lww)) + ] "tree" + case style of RepoCommitSummary -> do @@ -639,25 +684,33 @@ repoCommits lww predicate' = do let query = RepoCommitsQ lww noff lim --) path ["repo", repo, "commits", show noff, show lim] + let normalizeText s = l $ (Text.take 60 . Text.unwords . Text.words) s + where l x | Text.length x < 60 = x + | otherwise = x <> "..." + let rows = do for_ co $ \case CommitListItemBrief{..} -> do tr_ [class_ "commit-brief-title"] do - td_ $ img_ [src_ "/icon/git-commit.svg"] - td_ $ small_ $ toHtml (agePure (coerce @_ @Integer commitListTime) now) - td_ [class_ "mono", width_ "20rem"] do + td_ [class_ "commit-icon"] $ img_ [src_ "/icon/git-commit.svg"] + + td_ [class_ "commit-hash mono"] do let hash = coerce @_ @GitHash commitListHash a_ [ href_ "#" , hxGet_ (toURL (RepoCommitDefault lww hash)) , hxTarget_ "#repo-tab-data" , hxPushUrl_ (toURL query) - ] (toHtml $ show $ pretty hash) - td_ do - small_ $ toHtml $ coerce @_ @Text commitListAuthor + ] (toHtml $ take 10 (show $ pretty hash) <> "..") + + td_ [class_ "commit-brief-title"] do + toHtml $ normalizeText $ coerce @_ @Text commitListTitle + tr_ [class_ "commit-brief-details"] do - td_ [colspan_ "1"] mempty - td_ [colspan_ "3", class_ "commit-brief-title"] do - small_ $ toHtml $ coerce @_ @Text commitListTitle + td_ [colspan_ "3"] do + small_ do + toHtml (agePure (coerce @_ @Integer commitListTime) now) + toHtml " by " + toHtml $ coerce @_ @Text commitListAuthor unless (List.null co) do tr_ [ class_ "commit-brief-last" @@ -779,9 +832,6 @@ repoPage tab lww params = rootPage do let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ] let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ] - let setActive True = class_ "tab active" - setActive False = class_ mempty - div_ [class_ "container main"] $ do nav_ [class_ "left"] $ do @@ -801,7 +851,7 @@ repoPage tab lww params = rootPage do h6_ [] "heads" for_ (view repoHeadHeads rh) $ \(branch,v) -> do div_ [ class_ "attrval onleft"] do - a_ [ href_ (toURL (RepoPage (CommitsTabPred v) lww )) + a_ [ href_ (toURL (RepoPage (CommitsTab (Just v)) lww )) ] $ toHtml branch div_ [class_ "info-block" ] do @@ -809,7 +859,7 @@ repoPage tab lww params = rootPage do h6_ [] "tags" for_ (view repoHeadTags rh) $ \(tag,v) -> do div_ [ class_ "attrval onleft"] do - a_ [href_ (toURL (RepoPage (CommitsTabPred v) lww ))] $ toHtml tag + a_ [href_ (toURL (RepoPage (CommitsTab (Just v)) lww ))] $ toHtml tag main_ do @@ -817,19 +867,21 @@ repoPage tab lww params = rootPage do repoMenu do repoMenuItem mempty $ a_ [href_ "/"] "root" - let menu t = if tab == t then repoMenuItem0 else repoMenuItem + let menu t = if isActiveTab tab t then repoMenuItem0 else repoMenuItem - menu CommitsTab [ hxGet_ (toURL (RepoCommits lww)) - , hxTarget_ "#repo-tab-data" - ] "commits" + menu (CommitsTab Nothing) + [ hxGet_ (toURL (RepoCommits lww)) + , hxTarget_ "#repo-tab-data" + ] "commits" menu ManifestTab [ hxGet_ (toURL (RepoManifest lww)) - , hxTarget_ "#repo-tab-data" - ] "manifest" + , hxTarget_ "#repo-tab-data" + ] "manifest" - menu TreeTab [ hxGet_ (toURL (RepoRefs lww)) - , hxTarget_ "#repo-tab-data" - ] "tree" + menu (TreeTab Nothing) + [ hxGet_ (toURL (RepoRefs lww)) + , hxTarget_ "#repo-tab-data" + ] "tree" section_ [id_ "repo-data"] do h1_ (toHtml $ rlRepoName) @@ -838,18 +890,21 @@ repoPage tab lww params = rootPage do case tab of - TreeTab -> do - repoRefs lww + TreeTab{} -> do + + let tree = [ fromStringMay @GitHash (Text.unpack v) + | ("tree", v) <- params + ] & catMaybes & headMay + + maybe (repoRefs lww) (\t -> repoTree lww t t) tree ManifestTab -> do thisRepoManifest it - CommitsTab -> do + CommitsTab{} -> do let predicate = Right (fromQueryParams params) repoCommits lww predicate - CommitsTabPred _ -> do - let predicate = Right (fromQueryParams params) - repoCommits lww predicate + div_ [id_ "repo-tab-data-embedded"] mempty