mirror of https://github.com/voidlizard/hbs2
1092 lines
34 KiB
Haskell
1092 lines
34 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# Language PatternSynonyms #-}
|
|
{-# Language ViewPatterns #-}
|
|
{-# Language MultiWayIf #-}
|
|
module HBS2.Git.Web.Html.Root where
|
|
|
|
import HBS2.Git.DashBoard.Prelude
|
|
import HBS2.Git.DashBoard.Types
|
|
import HBS2.Git.DashBoard.State
|
|
import HBS2.Git.DashBoard.State.Commits
|
|
|
|
import HBS2.OrDie
|
|
|
|
import HBS2.Git.Data.Tx.Git
|
|
import HBS2.Git.Data.RepoHead
|
|
import HBS2.Git.Web.Assets
|
|
|
|
-- import Data.Text.Fuzzy.Tokenize as Fuzz
|
|
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Data.Text qualified as Text
|
|
import Data.Text.Encoding qualified as Text
|
|
import Lucid.Base
|
|
import Lucid.Html5 hiding (for_)
|
|
import Lucid.Htmx
|
|
|
|
import Skylighting qualified as Sky
|
|
import Skylighting.Tokenizer
|
|
import Skylighting.Format.HTML.Lucid as Lucid
|
|
|
|
import Control.Applicative
|
|
import Text.Pandoc hiding (getPOSIXTime)
|
|
import System.FilePath
|
|
import Data.Word
|
|
import Data.Either
|
|
import Data.List qualified as List
|
|
import Data.List (sortOn)
|
|
|
|
import Web.Scotty.Trans as Scotty
|
|
|
|
import Data.Kind
|
|
|
|
import Streaming.Prelude qualified as S
|
|
|
|
import Network.HTTP.Types.Status
|
|
|
|
rootPath :: [String] -> [String]
|
|
rootPath = ("/":)
|
|
|
|
class Path a where
|
|
path :: [a] -> Text
|
|
|
|
instance Path String where
|
|
path = Text.pack . joinPath . rootPath
|
|
|
|
class ToRoutePattern a where
|
|
routePattern :: a -> RoutePattern
|
|
|
|
class ToURL a where
|
|
toURL :: a -> Text
|
|
|
|
data family Tabs a :: Type
|
|
|
|
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
|
|
|
|
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
|
|
|
|
data RepoSomeBlob repo blob tp = RepoSomeBlob repo blob tp
|
|
|
|
data RepoForksHtmx repo = RepoForksHtmx repo
|
|
|
|
newtype RepoManifest repo = RepoManifest repo
|
|
|
|
newtype RepoCommits repo = RepoCommits repo
|
|
|
|
data RepoCommitsQ repo off lim = RepoCommitsQ repo off lim
|
|
|
|
data RepoCommitDefault repo commit = RepoCommitDefault repo commit
|
|
|
|
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
|
|
|
|
toPattern :: Text -> RoutePattern
|
|
toPattern = fromString . Text.unpack
|
|
|
|
instance Pretty RepoPageTabs where
|
|
pretty = \case
|
|
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
|
|
routePattern = \case
|
|
RepoListPage -> "/"
|
|
|
|
instance ToURL (RepoPage RepoPageTabs (LWWRefKey 'HBS2Basic)) where
|
|
toURL (RepoPage s w) = path @String [ "/", show (pretty s), show (pretty w)]
|
|
<> pred_
|
|
where
|
|
pred_ = case s of
|
|
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
|
|
routePattern (RepoPage s w) = path ["/", toArg s, toArg w] & toPattern
|
|
|
|
instance ToURL RepoListPage where
|
|
toURL _ = "/"
|
|
|
|
instance ToURL (RepoRefs (LWWRefKey 'HBS2Basic)) where
|
|
toURL (RepoRefs repo') = path ["/", "htmx", "refs", repo]
|
|
where
|
|
repo = show $ pretty repo'
|
|
|
|
instance ToRoutePattern (RepoRefs String) where
|
|
routePattern (RepoRefs s) = path ["/", "htmx", "refs", toArg s] & toPattern
|
|
|
|
|
|
instance ToURL (RepoTree (LWWRefKey 'HBS2Basic) GitHash GitHash) where
|
|
toURL (RepoTree k co tree') = path ["/", "htmx", "tree", repo, commit, tree]
|
|
where
|
|
repo = show $ pretty k
|
|
commit = show $ pretty co
|
|
tree = show $ pretty tree'
|
|
|
|
instance ToRoutePattern (RepoTree String String String) where
|
|
routePattern (RepoTree r co tree) =
|
|
path ["/", "htmx", "tree", toArg r, toArg co, toArg tree] & toPattern
|
|
|
|
instance ToURL (RepoBlob (LWWRefKey 'HBS2Basic) GitHash GitHash GitHash) where
|
|
toURL (RepoBlob k co t bo) = path ["/", "htmx", "blob", repo, commit, tree, blob]
|
|
where
|
|
repo = show $ pretty k
|
|
commit = show $ pretty co
|
|
tree = show $ pretty t
|
|
blob = show $ pretty bo
|
|
|
|
instance ToRoutePattern (RepoBlob String String String String) where
|
|
routePattern (RepoBlob r c t b) =
|
|
path ["/", "htmx", "blob", toArg r, toArg c, toArg t, toArg b] & toPattern
|
|
|
|
|
|
instance ToURL (RepoSomeBlob (LWWRefKey 'HBS2Basic) Text GitHash) where
|
|
toURL (RepoSomeBlob k tp' blo) = path ["/", "htmx", "some-blob", repo, tp, blob]
|
|
where
|
|
repo = show $ pretty k
|
|
tp = Text.unpack tp'
|
|
blob = show $ pretty blo
|
|
|
|
instance ToRoutePattern (RepoSomeBlob String String String) where
|
|
routePattern (RepoSomeBlob r t b) =
|
|
path ["/", "htmx", "some-blob", toArg r, toArg t, toArg b] & toPattern
|
|
|
|
instance ToURL (RepoManifest (LWWRefKey 'HBS2Basic)) where
|
|
toURL (RepoManifest repo') = path ["/", "htmx", "manifest", repo]
|
|
where
|
|
repo = show $ pretty repo'
|
|
|
|
instance ToRoutePattern (RepoManifest String) where
|
|
routePattern (RepoManifest s) = path ["/", "htmx", "manifest", toArg s] & toPattern
|
|
|
|
instance ToURL (RepoCommits (LWWRefKey 'HBS2Basic)) where
|
|
toURL (RepoCommits repo') = path ["/", "htmx", "commits", repo]
|
|
where
|
|
repo = show $ pretty repo'
|
|
|
|
instance ToRoutePattern (RepoCommits String) where
|
|
routePattern (RepoCommits s) = path ["/", "htmx", "commits", toArg s] & toPattern
|
|
|
|
instance ToURL (RepoCommitsQ (LWWRefKey 'HBS2Basic) Int Int) where
|
|
toURL (RepoCommitsQ repo' off lim) = path ["/", "htmx", "commits", repo, show off, show lim]
|
|
where
|
|
repo = show $ pretty repo'
|
|
|
|
instance ToRoutePattern (RepoCommitsQ String String String) where
|
|
routePattern (RepoCommitsQ r o l) =
|
|
path ["/", "htmx", "commits", toArg r, toArg o, toArg l] & toPattern
|
|
|
|
instance ToURL (RepoCommitDefault (LWWRefKey 'HBS2Basic) GitHash) where
|
|
toURL (RepoCommitDefault repo' h) = toURL (RepoCommitSummaryQ repo' h)
|
|
|
|
instance ToRoutePattern (RepoCommitDefault String String) where
|
|
routePattern (RepoCommitDefault r h) = routePattern (RepoCommitSummaryQ r h)
|
|
|
|
instance ToURL (RepoCommitSummaryQ (LWWRefKey 'HBS2Basic) GitHash) where
|
|
toURL (RepoCommitSummaryQ repo' h) = path ["/", "htmx", "commit", "summary", repo, ha]
|
|
where
|
|
repo = show $ pretty repo'
|
|
ha = show $ pretty h
|
|
|
|
instance ToRoutePattern (RepoCommitSummaryQ String String) where
|
|
routePattern (RepoCommitSummaryQ r h) =
|
|
path ["/", "htmx", "commit", "summary", toArg r, toArg h] & toPattern
|
|
|
|
instance ToURL (RepoCommitPatchQ (LWWRefKey 'HBS2Basic) GitHash) where
|
|
toURL (RepoCommitPatchQ repo' h) = path ["/", "htmx", "commit", "patch", repo, ha]
|
|
where
|
|
repo = show $ pretty repo'
|
|
ha = show $ pretty h
|
|
|
|
instance ToRoutePattern (RepoCommitPatchQ String String) where
|
|
routePattern (RepoCommitPatchQ r h) =
|
|
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
|
|
|
|
|
|
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"])]
|
|
|
|
hyper_ :: Text -> Attribute
|
|
hyper_ = makeAttribute "_"
|
|
|
|
ariaLabel_ :: Text -> Attribute
|
|
ariaLabel_ = makeAttribute "aria-label"
|
|
|
|
onClickCopy :: Text -> Attribute
|
|
onClickCopy s =
|
|
hyper_ [qc|on click writeText('{s}') into the navigator's clipboard
|
|
set my innerHTML to '{svgIconText IconCopyDone}'
|
|
set @data-tooltip to 'Copied!'
|
|
wait 2s
|
|
set my innerHTML to '{svgIconText IconCopy}'
|
|
set @data-tooltip to 'Copy'
|
|
|]
|
|
|
|
markdownToHtml :: Text -> Either PandocError String
|
|
markdownToHtml markdown = runPure $ do
|
|
doc <- readMarkdown def {readerExtensions = pandocExtensions} markdown
|
|
html <- writeHtml5String def {writerExtensions = pandocExtensions} doc
|
|
return $ Text.unpack html
|
|
|
|
renderMarkdown' :: Text -> Text
|
|
renderMarkdown' markdown = case markdownToHtml markdown of
|
|
Left{} -> markdown
|
|
Right html -> Text.pack html
|
|
|
|
renderMarkdown :: Text -> Html ()
|
|
renderMarkdown markdown = case markdownToHtml markdown of
|
|
Left{} -> blockquote_ (toHtml markdown)
|
|
Right html -> toHtmlRaw $ Text.pack html
|
|
|
|
instance ToHtml RepoBrief where
|
|
toHtml (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt)
|
|
toHtmlRaw (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt)
|
|
|
|
data WithTime a = WithTime Integer a
|
|
|
|
agePure :: forall a b . (Integral a,Integral b) => a -> b -> Text
|
|
agePure t0 t = do
|
|
let sec = fromIntegral @_ @Word64 t - fromIntegral t0
|
|
fromString $ show $
|
|
if | sec > 86400 -> pretty (sec `div` 86400) <+> "days ago"
|
|
| sec > 3600 -> pretty (sec `div` 3600) <+> "hours ago"
|
|
| otherwise -> pretty (sec `div` 60) <+> "minutes ago"
|
|
|
|
|
|
instance ToHtml GitRef where
|
|
toHtml (GitRef s)= toHtml s
|
|
toHtmlRaw (GitRef s)= toHtmlRaw s
|
|
|
|
rootPage :: Monad m => HtmlT m () -> HtmlT m ()
|
|
rootPage content = do
|
|
doctypehtml_ do
|
|
head_ do
|
|
meta_ [charset_ "UTF-8"]
|
|
meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
|
|
-- FIXME: static-local-loading
|
|
link_ [rel_ "stylesheet", href_ "https://cdn.jsdelivr.net/npm/@picocss/pico@2.0.6/css/pico.min.css"]
|
|
script_ [src_ "https://unpkg.com/hyperscript.org@0.9.12"] ""
|
|
script_ [src_ "https://unpkg.com/htmx.org@1.9.11"] ""
|
|
myCss
|
|
|
|
body_ do
|
|
|
|
header_ [class_ "container-fluid"] do
|
|
nav_ do
|
|
ul_ $ li_ $ a_ [href_ (toURL RepoListPage)] $ strong_ "hbs2-peer dashboard"
|
|
|
|
content
|
|
|
|
|
|
dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
|
|
dashboardRootPage = rootPage do
|
|
|
|
items <- lift $ selectRepoList mempty
|
|
|
|
now <- liftIO getPOSIXTime <&> fromIntegral . round
|
|
|
|
main_ [class_ "container-fluid"] $ do
|
|
div_ [class_ "wrapper"] $ do
|
|
aside_ [class_ "sidebar"] $ do
|
|
div_ [class_ "info-block"] $ small_ "Всякая разная рандомная информация хрен знает, что тут пока выводить"
|
|
div_ [class_ "info-block"] $ small_ "Всякая разная рандомная информация хрен знает, что тут пока выводить"
|
|
|
|
div_ [class_ "content"] do
|
|
|
|
section_ do
|
|
h2_ "Git repositories"
|
|
form_ [role_ "search"] do
|
|
input_ [name_ "search", type_ "search"]
|
|
input_ [type_ "submit", value_ "Search"]
|
|
|
|
section_ do
|
|
|
|
for_ items $ \it@RepoListItem{..} -> do
|
|
|
|
let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0
|
|
|
|
let url = toURL (RepoPage (CommitsTab Nothing) (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww))
|
|
-- path ["repo", Text.unpack $ view rlRepoLwwAsText it]
|
|
let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq
|
|
|
|
let updated = agePure t now
|
|
|
|
article_ [class_ "repo-list-item"] do
|
|
div_ do
|
|
|
|
h5_ do
|
|
toHtml rlRepoName
|
|
|
|
div_ [class_ "repo-list-item-link-wrapper"] $ do
|
|
a_ [href_ url] (toHtml $ view rlRepoLwwAsText it)
|
|
button_ [class_ "copy-button", onClickCopy (view rlRepoLwwAsText it), data_ "tooltip" "Copy"] do
|
|
svgIcon IconCopy
|
|
|
|
toHtml rlRepoBrief
|
|
|
|
div_ do
|
|
|
|
div_ [class_ "text-nowrap"] do
|
|
small_ $ "Updated " <> toHtml updated
|
|
|
|
when locked do
|
|
div_ do
|
|
small_ do
|
|
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconLockClosed
|
|
"Encrypted"
|
|
|
|
div_ do
|
|
small_ do
|
|
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit
|
|
strong_ $ toHtml $ show rlRepoCommits
|
|
" commits"
|
|
|
|
div_ do
|
|
small_ do
|
|
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork
|
|
strong_ $ toHtml $ show rlRepoForks
|
|
" forks"
|
|
|
|
|
|
|
|
tabClick :: Attribute
|
|
tabClick =
|
|
hyper_ "on click take .contrast from .tab for event's target"
|
|
|
|
parsedManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> m ([Syntax C], Text)
|
|
parsedManifest RepoListItem{..} = do
|
|
|
|
sto <- asks _sto
|
|
mhead <- readRepoHeadFromTx sto (coerce rlRepoTx)
|
|
|
|
let rawManifest = (_repoManifest . snd =<< mhead)
|
|
& fromMaybe (coerce rlRepoBrief)
|
|
& Text.lines
|
|
|
|
w <- S.toList_ do
|
|
flip fix rawManifest $ \next ss -> do
|
|
case ss of
|
|
( "" : rest ) -> S.yield (Right (Text.stripStart (Text.unlines rest)))
|
|
( a : rest ) -> S.yield (Left a ) >> next rest
|
|
[] -> pure ()
|
|
|
|
let meta = Text.unlines (lefts w)
|
|
& Text.unpack
|
|
& parseTop
|
|
& fromRight mempty
|
|
|
|
let manifest = mconcat $ rights w
|
|
|
|
pure (meta, manifest)
|
|
|
|
|
|
thisRepoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m ()
|
|
thisRepoManifest it@RepoListItem{..} = do
|
|
(_, manifest) <- lift $ parsedManifest it
|
|
toHtmlRaw (renderMarkdown' manifest)
|
|
|
|
repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|
=> LWWRefKey 'HBS2Basic
|
|
-> HtmlT m ()
|
|
repoRefs lww = do
|
|
|
|
refs <- lift $ gitShowRefs lww
|
|
table_ [] do
|
|
for_ refs $ \(r,h) -> do
|
|
let r_ = Text.pack $ show $ pretty r
|
|
let co = show $ pretty h
|
|
let uri = toURL (RepoTree lww h h)
|
|
|
|
let showRef = Text.isPrefixOf "refs" r_
|
|
|
|
when showRef do
|
|
tr_ do
|
|
td_ do
|
|
|
|
if | Text.isPrefixOf "refs/heads" r_ -> do
|
|
svgIcon IconGitBranch
|
|
| Text.isPrefixOf "refs/tags" r_ -> do
|
|
svgIcon IconTag
|
|
| otherwise -> mempty
|
|
|
|
td_ (toHtml r_)
|
|
td_ [class_ "mono"] $ do
|
|
a_ [ href_ "#"
|
|
, hxGet_ uri
|
|
, hxTarget_ "#repo-tab-data"
|
|
] (toHtml $ show $ pretty h)
|
|
|
|
|
|
treeLocator :: DashBoardPerks m
|
|
=> LWWRefKey 'HBS2Basic
|
|
-> GitHash
|
|
-> TreeLocator
|
|
-> HtmlT m ()
|
|
-> HtmlT m ()
|
|
|
|
treeLocator lww co locator next = do
|
|
|
|
let repo = show $ pretty $ lww
|
|
|
|
let co_ = show $ pretty co
|
|
|
|
let prefixSlash x = if fromIntegral x > 1 then span_ "/" else ""
|
|
let showRoot =
|
|
[ hxGet_ (toURL (RepoTree lww co co))
|
|
, hxTarget_ "#repo-tab-data"
|
|
, href_ "#"
|
|
]
|
|
|
|
span_ [] $ a_ [ hxGet_ (toURL (RepoRefs lww))
|
|
, hxTarget_ "#repo-tab-data"
|
|
, href_ "#"
|
|
] $ toHtml (take 10 repo <> "..")
|
|
span_ [] "/"
|
|
span_ [] $ a_ showRoot $ toHtml (take 10 co_ <> "..")
|
|
unless (List.null locator) do
|
|
span_ [] "/"
|
|
for_ locator $ \(_,this,level,name) -> do
|
|
prefixSlash level
|
|
let uri = toURL (RepoTree lww co (coerce @_ @GitHash this))
|
|
span_ [] do
|
|
a_ [ href_ "#"
|
|
, hxGet_ uri
|
|
, hxTarget_ "#repo-tab-data"
|
|
] (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
|
|
-> HtmlT m ()
|
|
|
|
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
|
|
|
|
let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree
|
|
where
|
|
tpOrder Tree = (0 :: Int)
|
|
tpOrder Blob = 1
|
|
tpOrder _ = 2
|
|
|
|
locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root)
|
|
|
|
let target = if embed then "#repo-tab-data-embedded" else "#repo-tab-data"
|
|
|
|
table_ [] do
|
|
|
|
unless embed do
|
|
|
|
tr_ do
|
|
td_ [class_ "tree-locator", colspan_ "3"] do
|
|
treeLocator lww co locator none
|
|
|
|
tr_ mempty do
|
|
|
|
for_ back' $ \r -> do
|
|
let rootLink = toURL (RepoTree lww co (coerce @_ @GitHash r))
|
|
td_ $ svgIcon IconArrowUturnLeft
|
|
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
|
|
let hash_ = show $ pretty h
|
|
let uri = toURL $ RepoTree lww co h
|
|
tr_ mempty do
|
|
td_ $ case tp of
|
|
Commit -> mempty
|
|
Tree -> svgIcon IconFolderFilled
|
|
Blob -> do
|
|
let syn = Sky.syntaxesByFilename syntaxMap (Text.unpack name)
|
|
& headMay
|
|
<&> Text.toLower . Sky.sName
|
|
|
|
let icon = case syn of
|
|
Just "haskell" -> IconHaskell
|
|
Just "markdown" -> IconMarkdown
|
|
Just "nix" -> IconNix
|
|
Just "bash" -> IconBash
|
|
Just "python" -> IconPython
|
|
Just "javascript" -> IconJavaScript
|
|
Just "sql" -> IconSql
|
|
Just s | s `elem` ["cabal","makefile","toml","ini","yaml"]
|
|
-> IconSettingsFilled
|
|
_ -> IconFileFilled
|
|
|
|
svgIcon icon
|
|
|
|
-- debug $ red "PUSH URL" <+> pretty (path ["back", wtf])
|
|
|
|
td_ [class_ itemClass] (toHtml $ show $ pretty name)
|
|
td_ [class_ "mono"] do
|
|
case tp of
|
|
Blob -> do
|
|
let blobUri = toURL $ RepoBlob lww co root h
|
|
a_ [ href_ "#"
|
|
, hxGet_ blobUri
|
|
, hxTarget_ target
|
|
] (toHtml hash_)
|
|
|
|
Tree -> do
|
|
a_ [ href_ "#"
|
|
, hxGet_ uri
|
|
, hxTarget_ target
|
|
] (toHtml hash_)
|
|
|
|
_ -> mempty
|
|
|
|
|
|
{- HLINT ignore "Functor law" -}
|
|
|
|
data RepoCommitStyle = RepoCommitSummary | RepoCommitPatch
|
|
deriving (Eq,Ord,Show)
|
|
|
|
repoCommit :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|
=> RepoCommitStyle
|
|
-> LWWRefKey 'HBS2Basic
|
|
-> GitHash
|
|
-> HtmlT m ()
|
|
|
|
repoCommit style lww hash = do
|
|
let syntaxMap = Sky.defaultSyntaxMap
|
|
|
|
txt <- lift $ getCommitRawBrief lww hash
|
|
|
|
let header = Text.lines txt & takeWhile (not . Text.null)
|
|
& fmap Text.words
|
|
|
|
let au = [ Text.takeWhile (/= '<') (Text.unwords a)
|
|
| ("Author:" : a) <- header
|
|
] & headMay
|
|
|
|
table_ [class_ "item-attr"] do
|
|
|
|
tr_ do
|
|
th_ [width_ "16rem"] $ strong_ "back"
|
|
td_ $ a_ [ href_ (toURL (RepoPage (CommitsTab (Just hash)) lww))
|
|
] $ toHtml $ show $ pretty hash
|
|
|
|
for_ au $ \author -> do
|
|
tr_ do
|
|
th_ $ strong_ "author"
|
|
td_ $ toHtml author
|
|
|
|
tr_ $ do
|
|
th_ $ strong_ "view"
|
|
td_ do
|
|
ul_ [class_ "misc-menu"]do
|
|
li_ $ a_ [ href_ "#"
|
|
, hxGet_ (toURL (RepoCommitSummaryQ lww hash))
|
|
, hxTarget_ "#repo-tab-data"
|
|
] "summary"
|
|
|
|
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
|
|
|
|
let msyn = Sky.syntaxByName syntaxMap "default"
|
|
|
|
for_ msyn $ \syn -> do
|
|
|
|
let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
|
|
|
|
case tokenize config syn txt of
|
|
Left _ -> mempty
|
|
Right tokens -> do
|
|
let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color }
|
|
let code = renderText (Lucid.formatHtmlBlock fo tokens)
|
|
toHtmlRaw code
|
|
|
|
RepoCommitPatch -> do
|
|
|
|
let msyn = Sky.syntaxByName syntaxMap "diff"
|
|
|
|
for_ msyn $ \syn -> do
|
|
|
|
txt <- lift $ getCommitRawPatch lww hash
|
|
|
|
let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
|
|
|
|
case tokenize config syn txt of
|
|
Left _ -> mempty
|
|
Right tokens -> do
|
|
let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color }
|
|
let code = renderText (Lucid.formatHtmlBlock fo tokens)
|
|
toHtmlRaw code
|
|
|
|
|
|
repoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|
=> LWWRefKey 'HBS2Basic
|
|
-> HtmlT m ()
|
|
|
|
repoForks lww = do
|
|
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_ $ svgIcon IconGitFork
|
|
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
|
|
-> Either SelectCommitsPred SelectCommitsPred
|
|
-> HtmlT m ()
|
|
|
|
repoCommits lww predicate' = do
|
|
now <- getEpoch
|
|
|
|
let predicate = either id id predicate'
|
|
|
|
co <- lift $ selectCommits lww predicate
|
|
|
|
let off = view commitPredOffset predicate
|
|
let lim = view commitPredLimit predicate
|
|
let noff = off + lim
|
|
|
|
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
|
|
tr_ $ th_ [colspan_ "5"] mempty
|
|
for_ co $ \case
|
|
CommitListItemBrief{..} -> do
|
|
tr_ [class_ "commit-brief-title"] do
|
|
td_ [class_ "commit-icon"] $ svgIcon IconGitCommit
|
|
|
|
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 (ShortRef hash)
|
|
|
|
td_ [class_ "commit-brief-title"] do
|
|
toHtml $ normalizeText $ coerce @_ @Text commitListTitle
|
|
|
|
tr_ [class_ "commit-brief-details"] do
|
|
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"
|
|
, hxGet_ (toURL query)
|
|
, hxTrigger_ "revealed"
|
|
, hxSwap_ "afterend"
|
|
] do
|
|
td_ [colspan_ "4"] do
|
|
mempty
|
|
|
|
if isRight predicate' then do
|
|
table_ rows
|
|
else do
|
|
rows
|
|
|
|
|
|
repoSomeBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|
=> LWWRefKey 'HBS2Basic
|
|
-> Text
|
|
-> GitHash
|
|
-> HtmlT m ()
|
|
|
|
repoSomeBlob lww syn hash = do
|
|
|
|
bi <- lift (selectBlobInfo (BlobHash hash))
|
|
>>= orThrow (itemNotFound hash)
|
|
|
|
doRenderBlob (pure mempty) lww bi
|
|
|
|
repoBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|
=> LWWRefKey 'HBS2Basic
|
|
-> TreeCommit
|
|
-> TreeTree
|
|
-> BlobInfo
|
|
-> HtmlT m ()
|
|
|
|
repoBlob lww co tree bi@BlobInfo{..} = do
|
|
locator <- lift $ selectTreeLocator co tree
|
|
|
|
table_ [] do
|
|
tr_ do
|
|
td_ [class_ "tree-locator", colspan_ "3"] do
|
|
treeLocator lww (coerce co) locator do
|
|
span_ "/"
|
|
span_ $ toHtml (show $ pretty blobName)
|
|
|
|
|
|
table_ [class_ "item-attr"] do
|
|
tr_ do
|
|
th_ $ strong_ "hash"
|
|
td_ [colspan_ "7"] do
|
|
span_ [class_ "mono"] $ toHtml $ show $ pretty blobHash
|
|
|
|
tr_ do
|
|
th_ $ strong_ "syntax"
|
|
td_ $ toHtml $ show $ pretty blobSyn
|
|
|
|
th_ $ strong_ "size"
|
|
td_ $ toHtml $ show $ pretty blobSize
|
|
|
|
td_ [colspan_ "3"] mempty
|
|
|
|
doRenderBlob (pure mempty) lww bi
|
|
|
|
doRenderBlob fallback lww BlobInfo{..} = do
|
|
fromMaybe mempty <$> runMaybeT do
|
|
|
|
guard (blobSize < 10485760)
|
|
|
|
let fn = blobName & coerce
|
|
let syntaxMap = Sky.defaultSyntaxMap
|
|
|
|
syn <- ( Sky.syntaxesByFilename syntaxMap fn
|
|
& headMay
|
|
) <|> Sky.syntaxByName syntaxMap "default"
|
|
& toMPlus
|
|
|
|
lift do
|
|
|
|
txt <- lift (readBlob lww blobHash)
|
|
<&> LBS.toStrict
|
|
<&> Text.decodeUtf8
|
|
|
|
case blobSyn of
|
|
BlobSyn (Just "markdown") -> do
|
|
|
|
toHtmlRaw (renderMarkdown' txt)
|
|
|
|
_ -> do
|
|
|
|
txt <- lift (readBlob lww blobHash)
|
|
<&> LBS.toStrict
|
|
<&> Text.decodeUtf8
|
|
|
|
let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap }
|
|
|
|
case tokenize config syn txt of
|
|
Left _ -> fallback txt
|
|
Right tokens -> do
|
|
let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color }
|
|
let code = renderText (Lucid.formatHtmlBlock fo tokens)
|
|
toHtmlRaw code
|
|
|
|
raiseStatus :: forall m . MonadIO m => Status -> Text -> m ()
|
|
raiseStatus s t = throwIO (StatusError s t)
|
|
|
|
itemNotFound s = StatusError status404 (Text.pack $ show $ pretty s)
|
|
|
|
newtype ShortRef a = ShortRef a
|
|
|
|
shortRef :: Int -> Int -> String -> String
|
|
shortRef n k a = if k > 0 then [qc|{b}..{r}|] else [qc|{b}|]
|
|
where
|
|
b = take n a
|
|
r = reverse $ take k (reverse a)
|
|
|
|
instance ToHtml (ShortRef GitHash) where
|
|
toHtml (ShortRef a) = toHtml (shortRef 10 0 (show $ pretty a))
|
|
toHtmlRaw (ShortRef a) = toHtml (shortRef 10 0 (show $ pretty a))
|
|
|
|
instance ToHtml (ShortRef (LWWRefKey 'HBS2Basic)) where
|
|
toHtml (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a))
|
|
toHtmlRaw (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a))
|
|
|
|
|
|
pattern PinnedRefBlob :: forall {c}. Text -> Text -> GitHash -> Syntax c
|
|
pattern PinnedRefBlob syn name hash <- ListVal [ SymbolVal "blob"
|
|
, SymbolVal (Id syn)
|
|
, LitStrVal name
|
|
, asGitHash -> Just hash
|
|
]
|
|
{-# COMPLETE PinnedRefBlob #-}
|
|
|
|
asGitHash :: forall c . Syntax c -> Maybe GitHash
|
|
asGitHash = \case
|
|
LitStrVal s -> fromStringMay (Text.unpack s)
|
|
_ -> Nothing
|
|
|
|
|
|
pattern FixmeRefChanP :: forall {c} . PubKey Sign HBS2Basic -> Syntax c
|
|
pattern FixmeRefChanP x <- ListVal [ SymbolVal "fixme:"
|
|
, ListVal [ SymbolVal "refchan", SignPubKeyLike x
|
|
]]
|
|
|
|
repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
|
=> RepoPageTabs
|
|
-> LWWRefKey 'HBS2Basic
|
|
-> [(Text,Text)]
|
|
-> HtmlT m ()
|
|
repoPage tab lww params = rootPage do
|
|
|
|
it@RepoListItem{..} <- lift (selectRepoList ( mempty
|
|
& set repoListByLww (Just lww)
|
|
& set repoListLimit (Just 1))
|
|
<&> listToMaybe
|
|
) >>= orThrow (itemNotFound lww)
|
|
|
|
sto <- asks _sto
|
|
mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx)
|
|
|
|
let mbHead = snd <$> mhead
|
|
|
|
(meta, manifest) <- lift $ parsedManifest it
|
|
|
|
let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ]
|
|
let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ]
|
|
let pinned = [ (name,r) | ListVal [ SymbolVal "pinned:", r@(PinnedRefBlob _ name _) ] <- meta ] & take 5
|
|
|
|
let fixme = headMay [ x | FixmeRefChanP x <- meta ]
|
|
|
|
debug $ red "META" <+> pretty meta
|
|
|
|
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
|
|
|
|
-- div_ [class_ "info-block" ] do
|
|
-- a_ [ href_ "/"] do
|
|
-- span_ [class_ "inline-icon-wrapper"] $ svgIcon IconArrowUturnLeft
|
|
-- "back to projects"
|
|
|
|
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"] 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
|
|
|
|
let theHead = headMay [ v | (GitRef "HEAD", v) <- view repoHeadRefs rh ]
|
|
|
|
let checkHead v what | v == theHead = strong_ what
|
|
| otherwise = what
|
|
|
|
div_ [class_ "info-block" ] do
|
|
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Heads"
|
|
ul_ [class_ "mb-0"] $ do
|
|
for_ (view repoHeadHeads rh) $ \(branch,v) -> do
|
|
li_ $ small_ do
|
|
a_ [class_ "secondary", href_ (toURL (RepoPage (CommitsTab (Just v)) lww ))] do
|
|
checkHead (Just v) $ toHtml branch
|
|
|
|
div_ [class_ "info-block" ] do
|
|
summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Tags"
|
|
ul_ [class_ "mb-0"] $ do
|
|
for_ (view repoHeadTags rh) $ \(tag,v) -> do
|
|
li_ $ small_ do
|
|
a_ [class_ "secondary", href_ (toURL (RepoPage (CommitsTab (Just v)) lww ))] do
|
|
checkHead (Just v) $ toHtml tag
|
|
|
|
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 rlRepoName
|
|
|
|
div_ [id_ "repo-tab-data"] do
|
|
|
|
case tab of
|
|
|
|
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
|
|
let predicate = Right (fromQueryParams params)
|
|
repoCommits lww predicate
|
|
|
|
ForksTab -> do
|
|
repoForks lww
|
|
|
|
div_ [id_ "repo-tab-data-embedded"] mempty
|