mirror of https://github.com/voidlizard/hbs2
wip, issues pages
This commit is contained in:
Dmitry Zuikov
parent
dfc2524d7f
commit
77fa0bfefb
|
|
@ -1,73 +1,8 @@
|
|||
module Main where
|
||||
|
||||
import Fixme
|
||||
-- import Fixme.Run
|
||||
import Fixme.Run
|
||||
import System.Environment
|
||||
|
||||
-- TODO: fixme-new
|
||||
-- $author: Dmitry Zuikov <dzuikov@gmail.com>
|
||||
-- $milestone: undefined
|
||||
-- $priority: ASAP
|
||||
-- после майских:
|
||||
-- 1. fixme переезжает в дерево hbs2, конкретно в hbs2-git
|
||||
|
||||
-- 2. fixme преобразуется в утилиту для генерации отчётов по репозиторию git
|
||||
--
|
||||
-- 3. fixme генерирует поток фактов про репозиторий git, включая записи todo/fixme
|
||||
--
|
||||
-- 4. fixme начинает генерировать PR-ы в формате git (у гита есть простенькие пулл-реквесты!)
|
||||
-- и умеет постить их куда там их следует постить
|
||||
--
|
||||
-- 5. fixme получает ограничитель глубины сканирования и фильтр бранчей,
|
||||
-- что бы не окочуриваться на больших проектах
|
||||
--
|
||||
-- 6. fixme генерирует настройки по умолчанию, включая .gitignore
|
||||
--
|
||||
-- 7. fixme позволяет явно задавать лог изменений статуса, беря его как из
|
||||
-- .fixme/log так и откуда скажут
|
||||
--
|
||||
-- 8. fixme интегрируется в hbs2-git-dashboard
|
||||
--
|
||||
-- 9. fixme временно получает название fixme2 или nfixme или hfixme (не решил пока),
|
||||
-- потом возвращается к старому названию
|
||||
--
|
||||
-- 10. fixme умеет постить записи в своём формате в hbs2 или же умеет любые источники дампить в своём формате так,
|
||||
-- что бы hbs2-git мог запостить их в соответствующий рефчан
|
||||
--
|
||||
-- 11. fixme оформляет либу для экстракции фактов из git, которую будет использовать и hbs2-git-dashboard
|
||||
--
|
||||
-- 12. hbs2-git-dashboard понимает и уважает каталог настроек .fixme , а стейт берёт прямо оттуда
|
||||
|
||||
-- открытые вопросы:
|
||||
|
||||
-- hbs2-git использует fixme или fixme использует hbs2
|
||||
|
||||
-- переводить fixme на fuzzy-parse или нет (скорее, да)
|
||||
|
||||
-- переводить ли suckless-conf на fuzzy-parse сейчас (или хрен пока с ним)
|
||||
|
||||
-- встроить ли jq внутрь или лучше дать доступ к sql запросам по json
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
-- TODO: discover-config
|
||||
--
|
||||
-- TODO: local-config-has-same-name-with-binary
|
||||
--
|
||||
-- TODO: per-user-config-has-same-name-with-binary
|
||||
--
|
||||
-- TODO: per-user-config-added-after-per-project-config
|
||||
|
||||
-- TODO: scan-all-sources
|
||||
-- for-source-from-con
|
||||
|
||||
runFixmeCLI runCLI
|
||||
|
||||
-- FIXME: test-fixme
|
||||
-- $workflow: wip
|
||||
-- $assigned: voidlizard
|
||||
--
|
||||
-- Тестовый тикет с параметрами
|
||||
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ module Fixme.State
|
|||
, withState
|
||||
, cleanupDatabase
|
||||
, listFixme
|
||||
, countFixme
|
||||
, insertFixme
|
||||
, insertFixmeExported
|
||||
, modifyFixme
|
||||
|
|
@ -319,6 +320,28 @@ selectFixmeKey s = do
|
|||
sqliteToAeson :: FromJSON a => Text -> Maybe a
|
||||
sqliteToAeson = Aeson.decode . LBS.fromStrict . Text.encodeUtf8
|
||||
|
||||
|
||||
countFixme :: (FixmePerks m, MonadReader FixmeEnv m) => m Int
|
||||
countFixme = do
|
||||
|
||||
let present = [qc|coalesce(json_extract(s1.blob, '$.deleted'),'false') <> 'true' |] :: String
|
||||
|
||||
let sql = [qc|
|
||||
with s1 as (
|
||||
select cast (json_insert(json_group_object(o.k, o.v), '$.w', max(o.w)) as text) as blob
|
||||
from object o
|
||||
group by o.o
|
||||
)
|
||||
select count(s1.blob) from s1
|
||||
where
|
||||
{present}
|
||||
|]
|
||||
|
||||
debug $ pretty sql
|
||||
|
||||
withState $ select_ @_ @(Only Int) sql
|
||||
<&> maybe 0 fromOnly . headMay
|
||||
|
||||
listFixme :: (FixmePerks m, MonadReader FixmeEnv m, HasPredicate q)
|
||||
=> q
|
||||
-> m [Fixme]
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ import HBS2.Git.DashBoard.State.Index
|
|||
import HBS2.Git.DashBoard.State.Commits
|
||||
import HBS2.Git.DashBoard.Types
|
||||
import HBS2.Git.DashBoard.Fixme
|
||||
import HBS2.Git.DashBoard.Manifest
|
||||
import HBS2.Git.Web.Html.Root
|
||||
|
||||
import HBS2.Peer.CLI.Detect
|
||||
|
|
@ -230,16 +231,8 @@ runDashboardWeb WebOptions{..} = do
|
|||
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
||||
flip runContT pure do
|
||||
lww <- lwws' & orFall (status status404)
|
||||
|
||||
item <- lift (selectRepoList ( mempty
|
||||
& set repoListByLww (Just lww)
|
||||
& set repoListLimit (Just 1))
|
||||
)
|
||||
<&> listToMaybe
|
||||
>>= orFall (status status404)
|
||||
|
||||
lift $ html =<< renderTextT (thisRepoManifest item)
|
||||
|
||||
TopInfoBlock{..} <- getTopInfoBlock lww
|
||||
lift $ html (LT.fromStrict manifest)
|
||||
|
||||
get (routePattern (RepoRefs "lww")) do
|
||||
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
||||
|
|
@ -299,6 +292,12 @@ runDashboardWeb WebOptions{..} = do
|
|||
lift $ renderHtml (repoForks lww)
|
||||
-- lift $ renderHtml (toHtml $ show $ pretty lww)
|
||||
|
||||
get (routePattern (RepoFixmeHtmx "lww")) do
|
||||
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
||||
flip runContT pure do
|
||||
lww <- lwws' & orFall (status status404)
|
||||
lift $ renderHtml (repoFixme lww)
|
||||
|
||||
get (routePattern (RepoCommits "lww")) do
|
||||
lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
||||
|
||||
|
|
@ -602,15 +601,21 @@ theDict = do
|
|||
|
||||
entry $ bindMatch "debug:test-with-fixme" $ nil_ $ \case
|
||||
[SignPubKeyLike s] -> lift do
|
||||
r <- runInFixme (RepoLww (LWWRefKey s)) (listFixme ())
|
||||
& try @_ @SomeException
|
||||
>>= orThrowPassIO
|
||||
|
||||
r <- listFixme (RepoLww (LWWRefKey s)) ()
|
||||
for_ r $ \f -> do
|
||||
liftIO $ print $ pretty f
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "debug:count-fixme" $ nil_ $ \case
|
||||
[SignPubKeyLike s] -> lift do
|
||||
r <- countFixme (RepoLww (LWWRefKey s))
|
||||
liftIO $ print $ pretty r
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
argz <- getArgs
|
||||
|
|
|
|||
|
|
@ -1,9 +1,18 @@
|
|||
module HBS2.Git.DashBoard.Fixme
|
||||
( F.listFixme
|
||||
, F.HasPredicate(..)
|
||||
( F.HasPredicate(..)
|
||||
, F.SelectPredicate(..)
|
||||
, runInFixme
|
||||
, countFixme
|
||||
, listFixme
|
||||
, RunInFixmeError(..)
|
||||
, Fixme(..)
|
||||
, FixmeKey(..)
|
||||
, FixmeTitle(..)
|
||||
, FixmeTag(..)
|
||||
, FixmePlainLine(..)
|
||||
, FixmeAttrName(..)
|
||||
, FixmeAttrVal(..)
|
||||
, FixmeOpts(..)
|
||||
) where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
|
|
@ -13,11 +22,13 @@ import HBS2.Git.DashBoard.State
|
|||
import HBS2.OrDie
|
||||
|
||||
import Fixme.State qualified as F
|
||||
import Fixme.State (HasPredicate(..))
|
||||
import Fixme.Types
|
||||
import Fixme.Config
|
||||
|
||||
import DBPipe.SQLite (withDB, shutdown)
|
||||
import DBPipe.SQLite (shutdown)
|
||||
|
||||
import Data.Either
|
||||
import Data.Generics.Product.Fields (field)
|
||||
|
||||
data RunInFixmeError =
|
||||
|
|
@ -49,9 +60,6 @@ runInFixme repo m = do
|
|||
let fenvNew = fenv & set (field @"fixmeEnvWorkDir") twd
|
||||
& set (field @"fixmeEnvOpts") fo
|
||||
|
||||
-- TODO: close-fixme-database-garanteed
|
||||
-- похоже, что надо будет фиксить db-pipe
|
||||
|
||||
flip runContT pure do
|
||||
dbe <- lift $ withFixmeEnv fenvNew $ F.withState ask
|
||||
|
||||
|
|
@ -67,4 +75,16 @@ runInFixme repo m = do
|
|||
|
||||
m
|
||||
|
||||
listFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m, HasPredicate q) => RepoLww -> q -> m [Fixme]
|
||||
listFixme repo q = do
|
||||
runInFixme repo $ F.listFixme q
|
||||
& try @_ @RunInFixmeError
|
||||
<&> fromRight mempty
|
||||
|
||||
countFixme :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoLww -> m (Maybe Int)
|
||||
countFixme repo = do
|
||||
runInFixme repo $ F.countFixme
|
||||
& try @_ @RunInFixmeError
|
||||
<&> either (const Nothing) Just
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -156,7 +156,7 @@ newtype RepoHeadTx = RepoHeadTx HashRef
|
|||
|
||||
newtype RepoName = RepoName Text
|
||||
deriving stock (Eq,Show,Generic)
|
||||
deriving newtype (ToField,FromField,ToHtml,IsString)
|
||||
deriving newtype (ToField,FromField,ToHtml,IsString,Pretty)
|
||||
|
||||
newtype RepoBrief = RepoBrief Text
|
||||
deriving stock (Generic)
|
||||
|
|
@ -172,7 +172,7 @@ newtype RepoCommitsNum = RepoCommitsNum Int
|
|||
deriving newtype (ToField,FromField,Show,Pretty)
|
||||
|
||||
newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic)
|
||||
deriving stock (Generic)
|
||||
deriving stock (Generic,Ord,Eq)
|
||||
deriving newtype (ToField,FromField,Pretty)
|
||||
|
||||
instance Show RepoLww where
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ import HBS2.Git.DashBoard.Types
|
|||
import HBS2.Git.DashBoard.State
|
||||
import HBS2.Git.DashBoard.State.Commits
|
||||
import HBS2.Git.DashBoard.Manifest
|
||||
import HBS2.Git.DashBoard.Fixme as Fixme
|
||||
|
||||
import HBS2.OrDie
|
||||
|
||||
|
|
@ -67,6 +68,7 @@ data RepoListPage = RepoListPage
|
|||
data RepoPageTabs = CommitsTab (Maybe GitHash)
|
||||
| ManifestTab
|
||||
| TreeTab (Maybe GitHash)
|
||||
| IssuesTab
|
||||
| ForksTab
|
||||
deriving stock (Eq,Ord,Show)
|
||||
|
||||
|
|
@ -88,6 +90,8 @@ newtype RepoManifest repo = RepoManifest repo
|
|||
|
||||
newtype RepoCommits repo = RepoCommits repo
|
||||
|
||||
newtype RepoFixmeHtmx repo = RepoFixmeHtmx repo
|
||||
|
||||
data RepoCommitsQ repo off lim = RepoCommitsQ repo off lim
|
||||
|
||||
data RepoCommitDefault repo commit = RepoCommitDefault repo commit
|
||||
|
|
@ -115,6 +119,7 @@ instance Pretty RepoPageTabs where
|
|||
ManifestTab{} -> "manifest"
|
||||
TreeTab{} -> "tree"
|
||||
ForksTab{} -> "forks"
|
||||
IssuesTab{} -> "issues"
|
||||
|
||||
instance FromStringMaybe RepoPageTabs where
|
||||
fromStringMay = \case
|
||||
|
|
@ -122,6 +127,7 @@ instance FromStringMaybe RepoPageTabs where
|
|||
"manifest" -> pure ManifestTab
|
||||
"tree" -> pure (TreeTab Nothing)
|
||||
"forks" -> pure ForksTab
|
||||
"issues" -> pure IssuesTab
|
||||
_ -> pure (CommitsTab Nothing)
|
||||
|
||||
instance ToRoutePattern RepoListPage where
|
||||
|
|
@ -256,10 +262,20 @@ instance ToURL (RepoForksHtmx (LWWRefKey 'HBS2Basic)) where
|
|||
where
|
||||
repo = show $ pretty k
|
||||
|
||||
instance ToRoutePattern (RepoFixmeHtmx String) where
|
||||
routePattern (RepoFixmeHtmx r) =
|
||||
path ["/", "htmx", "fixme", toArg r] & toPattern
|
||||
|
||||
instance ToURL (RepoFixmeHtmx RepoLww) where
|
||||
toURL (RepoFixmeHtmx k) = path ["/", "htmx", "fixme", 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"])]
|
||||
|
|
@ -422,10 +438,10 @@ parsedManifest RepoListItem{..} = do
|
|||
Just x -> parseManifest (snd x)
|
||||
Nothing -> pure (mempty, coerce rlRepoBrief)
|
||||
|
||||
thisRepoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
|
||||
thisRepoManifest it@RepoListItem{..} = do
|
||||
(_, manifest) <- lift $ parsedManifest it
|
||||
toHtmlRaw (renderMarkdown' manifest)
|
||||
thisRepoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoHead -> HtmlT m ()
|
||||
thisRepoManifest rh = do
|
||||
(_, man) <- lift $ parseManifest rh
|
||||
toHtmlRaw (renderMarkdown' man)
|
||||
|
||||
repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
|
|
@ -885,12 +901,122 @@ instance ToHtml (ShortRef (LWWRefKey 'HBS2Basic)) where
|
|||
toHtmlRaw (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a))
|
||||
|
||||
|
||||
repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoPageTabs
|
||||
-> LWWRefKey 'HBS2Basic
|
||||
-> [(Text,Text)]
|
||||
-> HtmlT m ()
|
||||
repoPage tab lww params = rootPage do
|
||||
newtype H a = H a
|
||||
|
||||
instance ToHtml (H FixmeKey) where
|
||||
toHtmlRaw (H k) = toHtmlRaw $ take 10 $ show $ pretty k
|
||||
toHtml (H k) = toHtml $ take 10 $ show $ pretty k
|
||||
|
||||
instance ToHtml (H FixmeTag) where
|
||||
toHtmlRaw (H k) = toHtmlRaw $ coerce @_ @Text k
|
||||
toHtml (H k) = toHtml $ coerce @_ @Text k
|
||||
|
||||
instance ToHtml (H FixmeTitle) where
|
||||
toHtmlRaw (H k) = toHtmlRaw $ coerce @_ @Text k
|
||||
toHtml (H k) = toHtml $ coerce @_ @Text k
|
||||
|
||||
repoFixme :: (MonadReader DashBoardEnv m, DashBoardPerks m) => LWWRefKey HBS2Basic -> HtmlT m ()
|
||||
repoFixme lww = do
|
||||
|
||||
fme <- lift $ listFixme (RepoLww lww) ()
|
||||
|
||||
table_ [] do
|
||||
for_ fme $ \fixme -> do
|
||||
tr_ [class_ "commit-brief-title"] $ do
|
||||
td_ [class_ "mono", width_ "10"] do
|
||||
a_ [] $ toHtml (H $ fixmeKey fixme)
|
||||
td_ [width_ "10"] do
|
||||
strong_ [] $ toHtml (H $ fixmeTag fixme)
|
||||
td_ [] do
|
||||
toHtml (H $ fixmeTitle fixme)
|
||||
tr_ [class_ "commit-brief-details"] $ do
|
||||
td_ [colspan_ "3"] do
|
||||
small_ "seconday shit"
|
||||
|
||||
|
||||
data TopInfoBlock =
|
||||
TopInfoBlock
|
||||
{ author :: Maybe Text
|
||||
, public :: Maybe Text
|
||||
, forksNum :: RepoForks
|
||||
, commitsNum :: RepoCommitsNum
|
||||
, manifest :: Text
|
||||
, fixme :: Maybe MyRefChan
|
||||
, fixmeCnt :: Int
|
||||
, pinned :: [(Text, Syntax C)]
|
||||
, repoHeadRef :: RepoHeadRef
|
||||
, repoHead :: Maybe RepoHead
|
||||
, repoName :: RepoName
|
||||
}
|
||||
|
||||
repoTopInfoBlock :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> TopInfoBlock
|
||||
-> HtmlT m ()
|
||||
|
||||
repoTopInfoBlock lww TopInfoBlock{..} = do
|
||||
div_ [class_ "info-block" ] do
|
||||
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "About"
|
||||
ul_ [class_ "mb-0"] do
|
||||
for_ author $ \a -> do
|
||||
li_ $ small_ do
|
||||
"Author: "
|
||||
toHtml a
|
||||
|
||||
for_ public $ \p -> do
|
||||
li_ $ small_ do
|
||||
"Public: "
|
||||
toHtml p
|
||||
|
||||
when (Text.length manifest > 100) do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary", href_ (toURL (RepoPage ManifestTab lww))] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconLicense
|
||||
"Manifest"
|
||||
|
||||
for_ fixme $ \_ -> do
|
||||
li_ $ small_ do
|
||||
a_ [ class_ "secondary"
|
||||
, href_ (toURL (RepoPage IssuesTab lww)) ] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconFixme
|
||||
toHtml $ show fixmeCnt
|
||||
" Issues"
|
||||
|
||||
when (forksNum > 0) do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ "#"
|
||||
, hxGet_ (toURL (RepoForksHtmx lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork
|
||||
toHtml $ show forksNum
|
||||
" forks"
|
||||
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ (toURL (RepoPage (CommitsTab Nothing) lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit
|
||||
toHtml $ show commitsNum
|
||||
" commits"
|
||||
|
||||
for_ pinned $ \(_,ref) -> do
|
||||
case ref of
|
||||
PinnedRefBlob s n hash -> small_ do
|
||||
li_ $ a_ [class_ "secondary"
|
||||
, href_ "#"
|
||||
, hxGet_ (toURL (RepoSomeBlob lww s hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconPinned
|
||||
toHtml (Text.take 12 n)
|
||||
" "
|
||||
toHtml $ ShortRef hash
|
||||
|
||||
|
||||
getTopInfoBlock lww = do
|
||||
|
||||
it@RepoListItem{..} <- lift (selectRepoList ( mempty
|
||||
& set repoListByLww (Just lww)
|
||||
|
|
@ -901,7 +1027,7 @@ repoPage tab lww params = rootPage do
|
|||
sto <- asks _sto
|
||||
mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx)
|
||||
|
||||
let mbHead = snd <$> mhead
|
||||
let repoHead = snd <$> mhead
|
||||
|
||||
(meta, manifest) <- lift $ parsedManifest it
|
||||
|
||||
|
|
@ -912,7 +1038,25 @@ repoPage tab lww params = rootPage do
|
|||
allowed <- lift $ checkFixmeAllowed (RepoLww lww)
|
||||
let fixme = headMay [ x | allowed, FixmeRefChanP x <- meta ]
|
||||
|
||||
debug $ red "META" <+> pretty meta
|
||||
fixmeCnt <- lift (Fixme.countFixme (RepoLww lww))
|
||||
<&> fromMaybe 0
|
||||
|
||||
let forksNum = rlRepoForks
|
||||
let commitsNum = rlRepoCommits
|
||||
let repoHeadRef = rlRepoHead
|
||||
let repoName = rlRepoName
|
||||
|
||||
pure $ TopInfoBlock{..}
|
||||
|
||||
repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> RepoPageTabs
|
||||
-> LWWRefKey 'HBS2Basic
|
||||
-> [(Text,Text)]
|
||||
-> HtmlT m ()
|
||||
|
||||
repoPage IssuesTab lww _ = rootPage do
|
||||
|
||||
topInfoBlock@TopInfoBlock{..} <- getTopInfoBlock lww
|
||||
|
||||
main_ [class_ "container-fluid"] do
|
||||
div_ [class_ "wrapper"] do
|
||||
|
|
@ -923,70 +1067,60 @@ repoPage tab lww params = rootPage do
|
|||
let txt = toHtml (ShortRef lww)
|
||||
a_ [href_ url, class_ "secondary"] txt
|
||||
|
||||
-- div_ [class_ "info-block" ] do
|
||||
-- a_ [ href_ "/"] do
|
||||
-- span_ [class_ "inline-icon-wrapper"] $ svgIcon IconArrowUturnLeft
|
||||
-- "back to projects"
|
||||
repoTopInfoBlock lww topInfoBlock
|
||||
|
||||
div_ [class_ "content"] $ do
|
||||
|
||||
-- article_ [class_ "py-0"] $ nav_ [ariaLabel_ "breadcrumb", class_ "repo-menu"] $ ul_ do
|
||||
|
||||
-- let menuTabClasses isActive = if isActive then "tab contrast" else "tab"
|
||||
-- menuTab t misc name = li_ do
|
||||
-- a_ ([class_ $ menuTabClasses $ isActiveTab tab t] <> misc <> [tabClick]) do
|
||||
-- name
|
||||
|
||||
-- menuTab (CommitsTab Nothing)
|
||||
-- [ href_ "#"
|
||||
-- , hxGet_ (toURL (RepoCommits lww))
|
||||
-- , hxTarget_ "#repo-tab-data"
|
||||
-- ] "commits"
|
||||
|
||||
-- menuTab (TreeTab Nothing)
|
||||
-- [ href_ "#"
|
||||
-- , hxGet_ (toURL (RepoRefs lww))
|
||||
-- , hxTarget_ "#repo-tab-data"
|
||||
-- ] "tree"
|
||||
|
||||
section_ do
|
||||
strong_ $ toHtml (show $ "Issues ::" <+> pretty repoName)
|
||||
|
||||
div_ [ id_ "repo-tab-data"
|
||||
, hxTrigger_ "load"
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, hxGet_ (toURL (RepoFixmeHtmx (RepoLww lww)))
|
||||
] do
|
||||
pure ()
|
||||
|
||||
div_ [id_ "repo-tab-data-embedded"] mempty
|
||||
|
||||
|
||||
repoPage tab lww params = rootPage do
|
||||
|
||||
sto <- asks _sto
|
||||
|
||||
topInfoBlock@TopInfoBlock{..} <- getTopInfoBlock lww
|
||||
|
||||
main_ [class_ "container-fluid"] do
|
||||
div_ [class_ "wrapper"] do
|
||||
aside_ [class_ "sidebar"] do
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
let url = toURL (RepoPage (CommitsTab Nothing) lww)
|
||||
let txt = toHtml (ShortRef lww)
|
||||
a_ [href_ url, class_ "secondary"] txt
|
||||
|
||||
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "About"
|
||||
ul_ [class_ "mb-0"] do
|
||||
for_ author $ \a -> do
|
||||
li_ $ small_ do
|
||||
"Author: "
|
||||
toHtml a
|
||||
repoTopInfoBlock lww topInfoBlock
|
||||
|
||||
for_ public $ \p -> do
|
||||
li_ $ small_ do
|
||||
"Public: "
|
||||
toHtml p
|
||||
|
||||
when (Text.length manifest > 100) do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary", href_ (toURL (RepoPage ManifestTab lww))] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconLicense
|
||||
"Manifest"
|
||||
|
||||
for_ fixme $ \_ -> do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconFixme
|
||||
"Issues"
|
||||
|
||||
when (rlRepoForks > 0) do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ "#"
|
||||
, hxGet_ (toURL (RepoForksHtmx lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork
|
||||
toHtml $ show rlRepoForks
|
||||
" forks"
|
||||
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ (toURL (RepoPage (CommitsTab Nothing) lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit
|
||||
toHtml $ show rlRepoCommits
|
||||
" commits"
|
||||
|
||||
for_ pinned $ \(_,ref) -> do
|
||||
case ref of
|
||||
PinnedRefBlob s n hash -> small_ do
|
||||
li_ $ a_ [class_ "secondary"
|
||||
, href_ "#"
|
||||
, hxGet_ (toURL (RepoSomeBlob lww s hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconPinned
|
||||
toHtml (Text.take 12 n)
|
||||
" "
|
||||
toHtml $ ShortRef hash
|
||||
|
||||
for_ mbHead $ \rh -> do
|
||||
for_ repoHead $ \rh -> do
|
||||
|
||||
let theHead = headMay [ v | (GitRef "HEAD", v) <- view repoHeadRefs rh ]
|
||||
|
||||
|
|
@ -1031,7 +1165,7 @@ repoPage tab lww params = rootPage do
|
|||
] "tree"
|
||||
|
||||
section_ do
|
||||
strong_ $ toHtml rlRepoName
|
||||
strong_ $ toHtml repoName
|
||||
|
||||
div_ [id_ "repo-tab-data"] do
|
||||
|
||||
|
|
@ -1046,7 +1180,7 @@ repoPage tab lww params = rootPage do
|
|||
maybe (repoRefs lww) (\t -> repoTree lww t t) tree
|
||||
|
||||
ManifestTab -> do
|
||||
thisRepoManifest it
|
||||
for_ repoHead $ thisRepoManifest
|
||||
|
||||
CommitsTab{} -> do
|
||||
let predicate = Right (fromQueryParams params)
|
||||
|
|
|
|||
|
|
@ -52,11 +52,13 @@ newtype LWWRefKey s =
|
|||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
|
||||
instance RefMetaData (LWWRefKey s)
|
||||
|
||||
deriving stock instance IsRefPubKey s => Eq (LWWRefKey s)
|
||||
|
||||
instance IsRefPubKey s => Ord (LWWRefKey s) where
|
||||
compare a b = compare (serialise a) (serialise b)
|
||||
|
||||
instance IsRefPubKey e => Serialise (LWWRefKey e)
|
||||
|
||||
instance IsRefPubKey s => Hashable (LWWRefKey s) where
|
||||
|
|
|
|||
Loading…
Reference in New Issue