diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/icon/git-fork.svg b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/git-fork.svg new file mode 100644 index 00000000..e08e98ab --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/icon/git-fork.svg @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs index 4389487f..f0176ec6 100644 --- a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -209,7 +209,7 @@ runDashboardWeb wo = do renderHtml (repoPage tab lww qp) get (routePattern (RepoManifest "lww")) do - lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) flip runContT pure do lww <- lwws' & orFall (status status404) @@ -224,7 +224,7 @@ runDashboardWeb wo = do get (routePattern (RepoRefs "lww")) do - lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) -- setHeader "HX-Push-Url" [qc|/{show $ pretty lwws'}|] @@ -233,7 +233,7 @@ runDashboardWeb wo = do lift $ renderHtml (repoRefs lww) get (routePattern (RepoTree "lww" "co" "hash")) do - lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) hash' <- captureParam @String "hash" <&> fromStringMay @GitHash co' <- captureParam @String "co" <&> fromStringMay @GitHash @@ -241,10 +241,10 @@ runDashboardWeb wo = do lww <- lwws' & orFall (status status404) hash <- hash' & orFall (status status404) co <- co' & orFall (status status404) - lift $ html =<< renderTextT (repoTree lww co hash) + lift $ renderHtml (repoTree lww co hash) get (routePattern (RepoBlob "lww" "co" "hash" "blob")) do - lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) hash' <- captureParam @String "hash" <&> fromStringMay @GitHash co' <- captureParam @String "co" <&> fromStringMay @GitHash blob' <- captureParam @String "blob" <&> fromStringMay @GitHash @@ -264,18 +264,25 @@ runDashboardWeb wo = do get (routePattern (RepoCommitSummaryQ "lww" "hash")) (commitRoute RepoCommitSummary) get (routePattern (RepoCommitPatchQ "lww" "hash")) (commitRoute RepoCommitPatch) + get (routePattern (RepoForksHtmx "lww")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + flip runContT pure do + lww <- lwws' & orFall (status status404) + lift $ renderHtml (repoForks lww) + -- lift $ renderHtml (toHtml $ show $ pretty lww) + get (routePattern (RepoCommits "lww")) do - lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) let pred = mempty & set commitPredOffset 0 & set commitPredLimit 100 flip runContT pure do lww <- lwws' & orFall (status status404) - lift $ html =<< renderTextT (repoCommits lww (Right pred)) + lift $ renderHtml (repoCommits lww (Right pred)) get (routePattern (RepoCommitsQ "lww" "off" "lim")) do - lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) off <- captureParam @Int "off" lim <- captureParam @Int "lim" 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 72b89a64..b72b30a7 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 @@ -154,7 +154,7 @@ newtype RepoBrief = RepoBrief Text newtype RepoForks = RepoForks Int deriving stock (Generic,Data) - deriving newtype (ToField,FromField,Show,Pretty) + deriving newtype (ToField,FromField,Show,Pretty,Num,Eq,Ord) newtype RepoCommitsNum = RepoCommitsNum Int deriving stock (Generic,Data) @@ -178,7 +178,7 @@ newtype RepoHeadRef = RepoHeadRef HashRef newtype RepoHeadSeq = RepoHeadSeq Word64 deriving stock (Generic) - deriving newtype (ToField,FromField) + deriving newtype (ToField,FromField,Integral,Real,Ord,Eq,Num,Enum) newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic) deriving stock (Generic) @@ -815,6 +815,18 @@ buildCommitTreeIndex lww = do -- FIXME: check-names-with-spaces +selectRepoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> m [RepoListItem] +selectRepoForks lww = withState do + let cols = columnListPart (AllColumns @RepoListItem) & fromSQL + let sql = [qc| select {cols} + from repolistview v join fork f on v.lww = f.b + where f.a = ? + |] + + debug $ yellow "selectRepoForks" <+> pretty sql <+> pretty lww + select sql (Only (RepoLww lww)) gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic 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 1a1117ad..119df945 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 @@ -63,6 +63,7 @@ data RepoListPage = RepoListPage data RepoPageTabs = CommitsTab (Maybe GitHash) | ManifestTab | TreeTab (Maybe GitHash) + | ForksTab deriving stock (Eq,Ord,Show) data RepoPage s a = RepoPage s a @@ -75,6 +76,8 @@ data RepoTreeEmbedded repo commit tree = RepoTreeEmbedded repo commit tree data RepoBlob repo commit tree blob = RepoBlob repo commit tree blob +data RepoForksHtmx repo = RepoForksHtmx repo + newtype RepoManifest repo = RepoManifest repo newtype RepoCommits repo = RepoCommits repo @@ -105,12 +108,14 @@ instance Pretty RepoPageTabs where CommitsTab{} -> "commits" ManifestTab{} -> "manifest" TreeTab{} -> "tree" + ForksTab{} -> "forks" instance FromStringMaybe RepoPageTabs where fromStringMay = \case "commits" -> pure (CommitsTab Nothing) "manifest" -> pure ManifestTab "tree" -> pure (TreeTab Nothing) + "forks" -> pure ForksTab _ -> pure (CommitsTab Nothing) instance ToRoutePattern RepoListPage where @@ -228,6 +233,15 @@ instance ToRoutePattern (RepoTreeEmbedded String String String) where path ["/", "htmx", "tree", "embedded", toArg r, toArg co, toArg tree] & toPattern +instance ToURL (RepoForksHtmx (LWWRefKey 'HBS2Basic)) where + toURL (RepoForksHtmx k) = path ["/", "htmx", "forks", repo] + where + repo = show $ pretty k + +instance ToRoutePattern (RepoForksHtmx String) where + routePattern (RepoForksHtmx r) = + path ["/", "htmx", "forks", toArg r] & toPattern + myCss :: Monad m => HtmlT m () myCss = do link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])] @@ -676,11 +690,26 @@ repoCommit style lww hash = do repoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m) - => LWWRefKey 'HBS2Basic - -> HtmlT m () + => LWWRefKey 'HBS2Basic + -> HtmlT m () repoForks lww = do - pure mempty + forks <- lift $ selectRepoForks lww + now <- getEpoch + + unless (List.null forks) do + table_ $ do + tr_ $ th_ [colspan_ "3"] mempty + for_ forks $ \it@RepoListItem{..} -> do + let lwwTo = coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww + tr_ [class_ "commit-brief-title"] do + td_ $ img_ [src_ "/icon/git-fork.svg"] + td_ [class_ "mono"] $ + a_ [ href_ (toURL (RepoPage (CommitsTab Nothing) lwwTo)) + ] do + toHtmlRaw $ view rlRepoLwwAsText it + td_ $ small_ $ toHtml (agePure rlRepoSeq now) + repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic @@ -705,6 +734,7 @@ repoCommits lww predicate' = do | otherwise = x <> "..." let rows = do + tr_ $ th_ [colspan_ "5"] mempty for_ co $ \case CommitListItemBrief{..} -> do tr_ [class_ "commit-brief-title"] do @@ -827,6 +857,18 @@ raiseStatus s t = throwIO (StatusError s t) itemNotFound s = StatusError status404 (Text.pack $ show $ pretty s) +newtype ShortRef a = ShortRef a + +shortRef :: String -> String +shortRef a = [qc|{b}..{r}|] + where + b = take 18 a + r = reverse $ take 2 (reverse a) + +instance Pretty a => ToHtml (ShortRef a) where + toHtml (ShortRef a) = toHtml (shortRef (show $ pretty a)) + toHtmlRaw (ShortRef a) = toHtml (shortRef (show $ pretty a)) + repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m) => RepoPageTabs -> LWWRefKey 'HBS2Basic @@ -854,6 +896,10 @@ repoPage tab lww params = rootPage do div_ [class_ "container main"] $ do nav_ [class_ "left"] $ do + div_ [class_ "info-block" ] do + div_ [ class_ "attr" ] do + a_ [href_ (toURL (RepoPage (CommitsTab Nothing) lww))] $ toHtml (ShortRef lww) + div_ [class_ "info-block" ] do div_ [ class_ "attr" ] do img_ [src_ "/icon/tree-up.svg"] @@ -877,10 +923,13 @@ repoPage tab lww params = rootPage do div_ [ class_ "attrname"] do a_ [ href_ (toURL (RepoPage ManifestTab lww))] "Manifest" - div_ [ class_ "attr" ] do - div_ [ class_ "attrname"] do - a_ [ href_ (toURL (RepoPage ManifestTab lww))] "Forks" - div_ [ class_ "attrval"] $ toHtml (show $ rlRepoForks) + when (rlRepoForks > 0) do + div_ [ class_ "attr" ] do + div_ [ class_ "attrname"] do + a_ [ hxGet_ (toURL (RepoForksHtmx lww)) + , hxTarget_ "#repo-tab-data" + ] "Forks" + div_ [ class_ "attrval"] $ toHtml (show $ rlRepoForks) div_ [ class_ "attr" ] do div_ [ class_ "attrname"] do @@ -929,7 +978,7 @@ repoPage tab lww params = rootPage do ] "tree" section_ [id_ "repo-data"] do - h1_ (toHtml $ rlRepoName) + strong_ (toHtml $ rlRepoName) div_ [id_ "repo-tab-data"] do @@ -950,6 +999,9 @@ repoPage tab lww params = rootPage do let predicate = Right (fromQueryParams params) repoCommits lww predicate + ForksTab -> do + repoForks lww + div_ [id_ "repo-tab-data-embedded"] mempty