voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-04-24 09:26:38 +03:00
parent a9195048be
commit fc18d4be9b
4 changed files with 97 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
hbs2-git/hbs2-git-dashboard-assets/assets/icon/git-fork.svg Normal file
View File

@ -0,0 +1,8 @@
<svg xmlns="http://www.w3.org/2000/svg" class="icon icon-tabler icon-tabler-git-fork" width="20" height="20" viewBox="0 0 24 24" stroke-width="1.5" stroke="#000000" fill="none" stroke-linecap="round" stroke-linejoin="round">
<path stroke="none" d="M0 0h24v24H0z" fill="none"/>
<path d="M12 18m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
<path d="M7 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
<path d="M17 6m-2 0a2 2 0 1 0 4 0a2 2 0 1 0 -4 0" />
<path d="M7 8v2a2 2 0 0 0 2 2h6a2 2 0 0 0 2 -2v-2" />
<path d="M12 12l0 4" />
</svg>
Side by Side

After

Width:  |  Height:  |  Size: 533 B

23
hbs2-git/hbs2-git-dashboard/GitDashBoard.hs
View File

@ -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"

16
hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs
View File

@ -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

68
hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs
View File

@ -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