mirror of https://github.com/voidlizard/hbs2
Add base-url configuration option to the hbs2-git-dashboard
This commit is contained in:
Andrei Borzenkov
voidlizard
parent
ed7a402fc3
commit
791e5e2313
|
|
@ -248,7 +248,8 @@ runDashboardWeb WebOptions{..} = do
|
|||
lww <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic)
|
||||
>>= orThrow (itemNotFound "repository key")
|
||||
|
||||
redirect (LT.fromStrict $ toURL (RepoPage (CommitsTab Nothing) lww))
|
||||
asksBaseUrl $ withBaseUrl $
|
||||
redirect (LT.fromStrict $ toBaseURL (RepoPage (CommitsTab Nothing) lww))
|
||||
|
||||
get (routePattern (RepoPage "tab" "lww")) do
|
||||
lww <- captureParam @String "lww" <&> fromStringMay
|
||||
|
|
@ -371,8 +372,8 @@ runDashboardWeb WebOptions{..} = do
|
|||
lww <- lwws' & orFall (status status404)
|
||||
|
||||
-- FIXME: this
|
||||
referrer <- lift (Scotty.header "Referer")
|
||||
>>= orFall (redirect $ LT.fromStrict $ toURL (RepoPage (CommitsTab Nothing) lww))
|
||||
referrer <- asksBaseUrl $ withBaseUrl $ lift (Scotty.header "Referer")
|
||||
>>= orFall (redirect $ LT.fromStrict $ toBaseURL (RepoPage (CommitsTab Nothing) lww))
|
||||
|
||||
lift $ renderHtml (repoCommits lww (Left pred))
|
||||
|
||||
|
|
@ -602,6 +603,7 @@ theDict = do
|
|||
webEntry
|
||||
portEntry
|
||||
developAssetsEntry
|
||||
baseUrlEntry
|
||||
getRpcSocketEntry
|
||||
rpcPingEntry
|
||||
rpcIndexEntry
|
||||
|
|
@ -665,6 +667,13 @@ theDict = do
|
|||
|
||||
_ -> none
|
||||
|
||||
baseUrlEntry = do
|
||||
entry $ bindMatch "base-url" $ nil_ \case
|
||||
[StringLike s] -> do
|
||||
urlTV <- lift $ asks _dashBoardBaseUrl
|
||||
atomically $ writeTVar urlTV (Just (Text.pack s))
|
||||
_ -> none
|
||||
|
||||
getRpcSocketEntry = do
|
||||
entry $ bindMatch "rpc:socket" $ nil_ $ const do
|
||||
lift getRPCSocket >>= liftIO . maybe exitFailure putStr
|
||||
|
|
@ -756,5 +765,3 @@ main = do
|
|||
|
||||
void $ runDashBoardM $ do
|
||||
run dict cli
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ import HBS2.System.Dir
|
|||
import System.FilePath
|
||||
|
||||
import Data.Word
|
||||
import Data.Text qualified as Text
|
||||
|
||||
type MyRefChan = RefChanId L4Proto
|
||||
type MyRefLogKey = RefLogKey 'HBS2Basic
|
||||
|
|
@ -57,6 +58,7 @@ data DashBoardEnv =
|
|||
, _pipeline :: TQueue (IO ())
|
||||
, _dashBoardHttpPort :: TVar (Maybe Word16)
|
||||
, _dashBoardDevAssets :: TVar (Maybe FilePath)
|
||||
, _dashBoardBaseUrl :: TVar (Maybe Text)
|
||||
, _dashBoardIndexIgnoreCaches :: TVar Bool
|
||||
}
|
||||
|
||||
|
|
@ -95,6 +97,7 @@ newDashBoardEnv ddir peer rlog rchan lww sto = do
|
|||
<*> newTQueueIO
|
||||
<*> newTVarIO (Just 8911)
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO Nothing
|
||||
<*> newTVarIO False
|
||||
|
||||
getHttpPortNumber :: (MonadIO m, MonadReader DashBoardEnv m, Integral a) => m a
|
||||
|
|
@ -114,6 +117,11 @@ getIgnoreCaches = do
|
|||
asks _dashBoardIndexIgnoreCaches
|
||||
>>= readTVarIO
|
||||
|
||||
asksBaseUrl :: (MonadIO m, MonadReader DashBoardEnv m) => (Text -> m a) -> m a
|
||||
asksBaseUrl thingInside = do
|
||||
mUrl <- readTVarIO =<< asks _dashBoardBaseUrl
|
||||
thingInside (fromMaybe (Text.pack "") mUrl)
|
||||
|
||||
withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a
|
||||
withDashBoardEnv env m = runReaderT (fromDashBoardM m) env
|
||||
|
||||
|
|
@ -158,4 +166,3 @@ addJob f = do
|
|||
|
||||
hbs2_git_dashboard :: FilePath
|
||||
hbs2_git_dashboard = "hbs2-git-dashboard"
|
||||
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ repoFixme :: ( MonadReader DashBoardEnv m
|
|||
-> LWWRefKey HBS2Basic
|
||||
-> HtmlT m ()
|
||||
|
||||
repoFixme q@(FromParams p') lww = do
|
||||
repoFixme q@(FromParams p') lww = asksBaseUrl $ withBaseUrl do
|
||||
|
||||
let p = Map.fromList p'
|
||||
|
||||
|
|
@ -62,7 +62,7 @@ repoFixme q@(FromParams p') lww = do
|
|||
for_ fme $ \fixme -> do
|
||||
tr_ [class_ "commit-brief-title"] $ do
|
||||
td_ [class_ "mono", width_ "10"] do
|
||||
a_ [ href_ (toURL (IssuePage (RepoLww lww) (fixmeKey fixme)))
|
||||
a_ [ href_ (toBaseURL (IssuePage (RepoLww lww) (fixmeKey fixme)))
|
||||
] $ toHtml (H $ fixmeKey fixme)
|
||||
td_ [width_ "10"] do
|
||||
strong_ [] $ toHtml (H $ fixmeTag fixme)
|
||||
|
|
@ -93,7 +93,7 @@ repoFixme q@(FromParams p') lww = do
|
|||
|
||||
unless (List.null fme) do
|
||||
tr_ [ class_ "commit-brief-last"
|
||||
, hxGet_ (toURL (Paged (offset + fromIntegral fixmePageSize) (RepoFixmeHtmx p (RepoLww lww))))
|
||||
, hxGet_ (toBaseURL (Paged (offset + fromIntegral fixmePageSize) (RepoFixmeHtmx p (RepoLww lww))))
|
||||
, hxTrigger_ "revealed"
|
||||
, hxSwap_ "afterend"
|
||||
] do
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ issuePage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
-> FixmeKey
|
||||
-> HtmlT m ()
|
||||
|
||||
issuePage repo@(RepoLww lww) f = rootPage do
|
||||
issuePage repo@(RepoLww lww) f = asksBaseUrl $ withBaseUrl $ rootPage do
|
||||
|
||||
ti@TopInfoBlock{} <- lift $ getTopInfoBlock (coerce repo)
|
||||
|
||||
|
|
@ -82,7 +82,7 @@ issuePage repo@(RepoLww lww) f = rootPage do
|
|||
|
||||
div_ do
|
||||
small_ do
|
||||
a_ [ href_ (toURL (RepoPage IssuesTab lww))
|
||||
a_ [ href_ (toBaseURL (RepoPage IssuesTab lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconArrowUturnLeft
|
||||
span_ [] "back to issues"
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ issuesSidebar :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
-> TopInfoBlock
|
||||
-> [(Text,Text)]
|
||||
-> HtmlT m ()
|
||||
issuesSidebar lww topInfoBlock p' = do
|
||||
issuesSidebar lww topInfoBlock p' = asksBaseUrl $ withBaseUrl do
|
||||
|
||||
let p = Map.fromList p'
|
||||
|
||||
|
|
@ -42,7 +42,7 @@ issuesSidebar lww topInfoBlock p' = do
|
|||
for_ fmt $ \(s,n) -> do
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.insert "fixme-tag" (coerce s) p) (RepoLww lww))))
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.insert "fixme-tag" (coerce s) p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
|
|
@ -56,7 +56,7 @@ issuesSidebar lww topInfoBlock p' = do
|
|||
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.delete "workflow" p) (RepoLww lww))))
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.delete "workflow" p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
|
|
@ -67,7 +67,7 @@ issuesSidebar lww topInfoBlock p' = do
|
|||
for_ fmw $ \(s,n) -> do
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.insert "workflow" (coerce s) p) (RepoLww lww))))
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.insert "workflow" (coerce s) p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
|
|
@ -81,7 +81,7 @@ issuesSidebar lww topInfoBlock p' = do
|
|||
for_ ass $ \(s,n) -> do
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.insert "assigned" (coerce s) p) (RepoLww lww))))
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.insert "assigned" (coerce s) p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
|
|
@ -94,7 +94,7 @@ issuesSidebar lww topInfoBlock p' = do
|
|||
for_ cla $ \(s,n) -> do
|
||||
li_ [] $ small_ [] do
|
||||
a_ [ class_ "secondary"
|
||||
, hxGet_ (toURL (Paged 0 (RepoFixmeHtmx (Map.insert "class" (coerce s) p) (RepoLww lww))))
|
||||
, hxGet_ (toBaseURL (Paged 0 (RepoFixmeHtmx (Map.insert "class" (coerce s) p) (RepoLww lww))))
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
] do
|
||||
span_ [style_ "display: inline-block; width: 4ch; text-align: right; padding-right: 0.5em;"] $
|
||||
|
|
@ -103,4 +103,3 @@ issuesSidebar lww topInfoBlock p' = do
|
|||
span_ [] $ toHtml $ show $ pretty s
|
||||
|
||||
pure ()
|
||||
|
||||
|
|
|
|||
|
|
@ -37,10 +37,10 @@ repoTopInfoBlock :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
-> TopInfoBlock
|
||||
-> HtmlT m ()
|
||||
|
||||
repoTopInfoBlock lww TopInfoBlock{..} = do
|
||||
repoTopInfoBlock lww TopInfoBlock{..} = asksBaseUrl $ withBaseUrl do
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
let url = toURL (RepoPage (CommitsTab Nothing) lww)
|
||||
let url = toBaseURL (RepoPage (CommitsTab Nothing) lww)
|
||||
let txt = toHtml (ShortRef lww)
|
||||
a_ [href_ url, class_ "secondary"] txt
|
||||
|
||||
|
|
@ -60,14 +60,14 @@ repoTopInfoBlock lww TopInfoBlock{..} = do
|
|||
|
||||
when (Text.length manifest > 100) do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary", href_ (toURL (RepoPage ManifestTab lww))] do
|
||||
a_ [class_ "secondary", href_ (toBaseURL (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
|
||||
, href_ (toBaseURL (RepoPage IssuesTab lww)) ] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconFixme
|
||||
toHtml $ show fixmeCnt
|
||||
" Issues"
|
||||
|
|
@ -75,7 +75,7 @@ repoTopInfoBlock lww TopInfoBlock{..} = do
|
|||
when (forksNum > 0) do
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ (toURL (RepoPage ForksTab lww))
|
||||
, href_ (toBaseURL (RepoPage ForksTab lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork
|
||||
toHtml $ show forksNum
|
||||
|
|
@ -83,7 +83,7 @@ repoTopInfoBlock lww TopInfoBlock{..} = do
|
|||
|
||||
li_ $ small_ do
|
||||
a_ [class_ "secondary"
|
||||
, href_ (toURL (RepoPage (CommitsTab Nothing) lww))
|
||||
, href_ (toBaseURL (RepoPage (CommitsTab Nothing) lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit
|
||||
toHtml $ show commitsNum
|
||||
|
|
@ -93,7 +93,7 @@ repoTopInfoBlock lww TopInfoBlock{..} = do
|
|||
case ref of
|
||||
PinnedRefBlob s n hash -> small_ do
|
||||
li_ $ a_ [class_ "secondary"
|
||||
, href_ (toURL (RepoPage (PinnedTab (Just (s,n,hash))) lww))
|
||||
, href_ (toBaseURL (RepoPage (PinnedTab (Just (s,n,hash))) lww))
|
||||
] do
|
||||
span_ [class_ "inline-icon-wrapper"] $ svgIcon IconPinned
|
||||
toHtml (Text.take 12 n)
|
||||
|
|
@ -150,4 +150,3 @@ getTopInfoBlock lww = do
|
|||
let repoName = rlRepoName
|
||||
|
||||
pure $ TopInfoBlock{..}
|
||||
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@ repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
-> [(Text,Text)]
|
||||
-> HtmlT m ()
|
||||
|
||||
repoPage IssuesTab lww p' = rootPage do
|
||||
repoPage IssuesTab lww p' = asksBaseUrl $ withBaseUrl $ rootPage do
|
||||
|
||||
ti@TopInfoBlock{..} <- lift $ getTopInfoBlock lww
|
||||
|
||||
|
|
@ -76,13 +76,13 @@ repoPage IssuesTab lww p' = rootPage do
|
|||
div_ [ id_ "repo-tab-data"
|
||||
, hxTrigger_ "load"
|
||||
, hxTarget_ "#fixme-tab-data"
|
||||
, hxGet_ (toURL (RepoFixmeHtmx mempty (RepoLww lww)))
|
||||
, hxGet_ (toBaseURL (RepoFixmeHtmx mempty (RepoLww lww)))
|
||||
] mempty
|
||||
|
||||
div_ [id_ "repo-tab-data-embedded"] mempty
|
||||
|
||||
|
||||
repoPage tab lww params = rootPage do
|
||||
repoPage tab lww params = asksBaseUrl $ withBaseUrl $ rootPage do
|
||||
|
||||
sto <- asks _sto
|
||||
|
||||
|
|
@ -107,7 +107,7 @@ repoPage tab lww params = rootPage do
|
|||
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
|
||||
a_ [class_ "secondary", href_ (toBaseURL (RepoPage (CommitsTab (Just v)) lww ))] do
|
||||
checkHead (Just v) $ toHtml branch
|
||||
|
||||
div_ [class_ "info-block" ] do
|
||||
|
|
@ -115,7 +115,7 @@ repoPage tab lww params = rootPage do
|
|||
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
|
||||
a_ [class_ "secondary", href_ (toBaseURL (RepoPage (CommitsTab (Just v)) lww ))] do
|
||||
checkHead (Just v) $ toHtml tag
|
||||
|
||||
div_ [class_ "content"] $ do
|
||||
|
|
@ -129,13 +129,13 @@ repoPage tab lww params = rootPage do
|
|||
|
||||
menuTab (CommitsTab Nothing)
|
||||
[ href_ "#"
|
||||
, hxGet_ (toURL (RepoCommits lww))
|
||||
, hxGet_ (toBaseURL (RepoCommits lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "commits"
|
||||
|
||||
menuTab (TreeTab Nothing)
|
||||
[ href_ "#"
|
||||
, hxGet_ (toURL (RepoRefs lww))
|
||||
, hxGet_ (toBaseURL (RepoRefs lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "tree"
|
||||
|
||||
|
|
@ -196,14 +196,14 @@ thisRepoManifest rh = do
|
|||
repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> HtmlT m ()
|
||||
repoRefs lww = do
|
||||
repoRefs lww = asksBaseUrl $ withBaseUrl 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 uri = toBaseURL (RepoTree lww h h)
|
||||
|
||||
let showRef = Text.isPrefixOf "refs" r_
|
||||
|
||||
|
|
@ -225,7 +225,7 @@ repoRefs lww = do
|
|||
] (toHtml $ show $ pretty h)
|
||||
|
||||
|
||||
treeLocator :: DashBoardPerks m
|
||||
treeLocator :: (WithBaseUrl, DashBoardPerks m)
|
||||
=> LWWRefKey 'HBS2Basic
|
||||
-> GitHash
|
||||
-> TreeLocator
|
||||
|
|
@ -240,12 +240,12 @@ treeLocator lww co locator next = do
|
|||
|
||||
let prefixSlash x = if fromIntegral x > 1 then span_ "/" else ""
|
||||
let showRoot =
|
||||
[ hxGet_ (toURL (RepoTree lww co co))
|
||||
[ hxGet_ (toBaseURL (RepoTree lww co co))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, href_ "#"
|
||||
]
|
||||
|
||||
span_ [] $ a_ [ hxGet_ (toURL (RepoRefs lww))
|
||||
span_ [] $ a_ [ hxGet_ (toBaseURL (RepoRefs lww))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, href_ "#"
|
||||
] $ toHtml (take 10 repo <> "..")
|
||||
|
|
@ -255,7 +255,7 @@ treeLocator lww co locator next = do
|
|||
span_ [] "/"
|
||||
for_ locator $ \(_,this,level,name) -> do
|
||||
prefixSlash level
|
||||
let uri = toURL (RepoTree lww co (coerce @_ @GitHash this))
|
||||
let uri = toBaseURL (RepoTree lww co (coerce @_ @GitHash this))
|
||||
span_ [] do
|
||||
a_ [ href_ "#"
|
||||
, hxGet_ uri
|
||||
|
|
@ -288,7 +288,7 @@ repoTree_ :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
-> GitHash -- ^ this
|
||||
-> HtmlT m ()
|
||||
|
||||
repoTree_ embed lww co root = do
|
||||
repoTree_ embed lww co root = asksBaseUrl $ withBaseUrl $ do
|
||||
|
||||
tree <- lift $ gitShowTree lww root
|
||||
back' <- lift $ selectParentTree (TreeCommit co) (TreeTree root)
|
||||
|
|
@ -316,7 +316,7 @@ repoTree_ embed lww co root = do
|
|||
tr_ mempty do
|
||||
|
||||
for_ back' $ \r -> do
|
||||
let rootLink = toURL (RepoTree lww co (coerce @_ @GitHash r))
|
||||
let rootLink = toBaseURL (RepoTree lww co (coerce @_ @GitHash r))
|
||||
td_ $ svgIcon IconArrowUturnLeft
|
||||
td_ ".."
|
||||
td_ do a_ [ href_ "#"
|
||||
|
|
@ -327,7 +327,7 @@ repoTree_ embed lww co root = do
|
|||
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
|
||||
let uri = toBaseURL $ RepoTree lww co h
|
||||
tr_ mempty do
|
||||
td_ $ case tp of
|
||||
Commit -> mempty
|
||||
|
|
@ -357,7 +357,7 @@ repoTree_ embed lww co root = do
|
|||
td_ [class_ "mono"] do
|
||||
case tp of
|
||||
Blob -> do
|
||||
let blobUri = toURL $ RepoBlob lww co root h
|
||||
let blobUri = toBaseURL $ RepoBlob lww co root h
|
||||
a_ [ href_ "#"
|
||||
, hxGet_ blobUri
|
||||
, hxTarget_ target
|
||||
|
|
@ -383,7 +383,7 @@ repoCommit :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
-> GitHash
|
||||
-> HtmlT m ()
|
||||
|
||||
repoCommit style lww hash = do
|
||||
repoCommit style lww hash = asksBaseUrl $ withBaseUrl do
|
||||
let syntaxMap = Sky.defaultSyntaxMap
|
||||
|
||||
txt <- lift $ getCommitRawBrief lww hash
|
||||
|
|
@ -399,7 +399,7 @@ repoCommit style lww hash = do
|
|||
|
||||
tr_ do
|
||||
th_ [width_ "16rem"] $ strong_ "back"
|
||||
td_ $ a_ [ href_ (toURL (RepoPage (CommitsTab (Just hash)) lww))
|
||||
td_ $ a_ [ href_ (toBaseURL (RepoPage (CommitsTab (Just hash)) lww))
|
||||
] $ toHtml $ show $ pretty hash
|
||||
|
||||
for_ au $ \author -> do
|
||||
|
|
@ -412,16 +412,16 @@ repoCommit style lww hash = do
|
|||
td_ do
|
||||
ul_ [class_ "misc-menu"]do
|
||||
li_ $ a_ [ href_ "#"
|
||||
, hxGet_ (toURL (RepoCommitSummaryQ lww hash))
|
||||
, hxGet_ (toBaseURL (RepoCommitSummaryQ lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "summary"
|
||||
|
||||
li_ $ a_ [ href_ "#"
|
||||
, hxGet_ (toURL (RepoCommitPatchQ lww hash))
|
||||
, hxGet_ (toBaseURL (RepoCommitPatchQ lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
] "patch"
|
||||
|
||||
li_ $ a_ [ href_ (toURL (RepoPage (TreeTab (Just hash)) lww))
|
||||
li_ $ a_ [ href_ (toBaseURL (RepoPage (TreeTab (Just hash)) lww))
|
||||
] "tree"
|
||||
|
||||
case style of
|
||||
|
|
@ -462,7 +462,7 @@ repoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
=> LWWRefKey 'HBS2Basic
|
||||
-> HtmlT m ()
|
||||
|
||||
repoForks lww = do
|
||||
repoForks lww = asksBaseUrl $ withBaseUrl do
|
||||
forks <- lift $ selectRepoForks lww
|
||||
now <- getEpoch
|
||||
|
||||
|
|
@ -474,7 +474,7 @@ repoForks lww = do
|
|||
tr_ [class_ "commit-brief-title"] do
|
||||
td_ $ svgIcon IconGitFork
|
||||
td_ [class_ "mono"] $
|
||||
a_ [ href_ (toURL (RepoPage (CommitsTab Nothing) lwwTo))
|
||||
a_ [ href_ (toBaseURL (RepoPage (CommitsTab Nothing) lwwTo))
|
||||
] do
|
||||
toHtmlRaw $ view rlRepoLwwAsText it
|
||||
td_ $ small_ $ toHtml (agePure rlRepoSeq now)
|
||||
|
|
@ -485,7 +485,7 @@ repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
-> Either SelectCommitsPred SelectCommitsPred
|
||||
-> HtmlT m ()
|
||||
|
||||
repoCommits lww predicate' = do
|
||||
repoCommits lww predicate' = asksBaseUrl $ withBaseUrl do
|
||||
now <- getEpoch
|
||||
|
||||
debug $ red "repoCommits"
|
||||
|
|
@ -514,9 +514,9 @@ repoCommits lww predicate' = do
|
|||
td_ [class_ "commit-hash mono"] do
|
||||
let hash = coerce @_ @GitHash commitListHash
|
||||
a_ [ href_ "#"
|
||||
, hxGet_ (toURL (RepoCommitDefault lww hash))
|
||||
, hxGet_ (toBaseURL (RepoCommitDefault lww hash))
|
||||
, hxTarget_ "#repo-tab-data"
|
||||
, hxPushUrl_ (toURL query)
|
||||
, hxPushUrl_ (toBaseURL query)
|
||||
] $ toHtml (ShortRef hash)
|
||||
|
||||
td_ [class_ "commit-brief-title"] do
|
||||
|
|
@ -531,7 +531,7 @@ repoCommits lww predicate' = do
|
|||
|
||||
unless (List.null co) do
|
||||
tr_ [ class_ "commit-brief-last"
|
||||
, hxGet_ (toURL query)
|
||||
, hxGet_ (toBaseURL query)
|
||||
, hxTrigger_ "revealed"
|
||||
, hxSwap_ "afterend"
|
||||
] do
|
||||
|
|
@ -564,7 +564,7 @@ repoBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m)
|
|||
-> BlobInfo
|
||||
-> HtmlT m ()
|
||||
|
||||
repoBlob lww co tree bi@BlobInfo{..} = do
|
||||
repoBlob lww co tree bi@BlobInfo{..} = asksBaseUrl $ withBaseUrl do
|
||||
locator <- lift $ selectTreeLocator co tree
|
||||
|
||||
table_ [] do
|
||||
|
|
@ -591,6 +591,3 @@ repoBlob lww co tree bi@BlobInfo{..} = do
|
|||
td_ [colspan_ "3"] mempty
|
||||
|
||||
doRenderBlob (pure mempty) lww bi
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -23,9 +23,9 @@ import Lucid.Html5 hiding (for_)
|
|||
import Data.Word
|
||||
|
||||
|
||||
myCss :: Monad m => HtmlT m ()
|
||||
myCss :: (WithBaseUrl, Monad m) => HtmlT m ()
|
||||
myCss = do
|
||||
link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])]
|
||||
link_ [rel_ "stylesheet", href_ (toBaseURL "css/custom.css")]
|
||||
|
||||
hyper_ :: Text -> Attribute
|
||||
hyper_ = makeAttribute "_"
|
||||
|
|
@ -64,7 +64,7 @@ instance ToHtml GitRef where
|
|||
toHtml (GitRef s)= toHtml s
|
||||
toHtmlRaw (GitRef s)= toHtmlRaw s
|
||||
|
||||
rootPage :: Monad m => HtmlT m () -> HtmlT m ()
|
||||
rootPage :: (WithBaseUrl, Monad m) => HtmlT m () -> HtmlT m ()
|
||||
rootPage content = do
|
||||
doctypehtml_ do
|
||||
head_ do
|
||||
|
|
@ -80,13 +80,13 @@ rootPage content = do
|
|||
|
||||
header_ [class_ "container-fluid"] do
|
||||
nav_ do
|
||||
ul_ $ li_ $ a_ [href_ (toURL RepoListPage)] $ strong_ "hbs2-git dashboard"
|
||||
ul_ $ li_ $ a_ [href_ (toBaseURL RepoListPage)] $ strong_ "hbs2-git dashboard"
|
||||
|
||||
content
|
||||
|
||||
|
||||
dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m ()
|
||||
dashboardRootPage = rootPage do
|
||||
dashboardRootPage = asksBaseUrl $ withBaseUrl $ rootPage do
|
||||
|
||||
items <- lift $ selectRepoList mempty
|
||||
|
||||
|
|
@ -112,7 +112,7 @@ dashboardRootPage = rootPage do
|
|||
|
||||
let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0
|
||||
|
||||
let url = toURL (RepoPage (CommitsTab Nothing) (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww))
|
||||
let url = toBaseURL (RepoPage (CommitsTab Nothing) (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww))
|
||||
-- path ["repo", Text.unpack $ view rlRepoLwwAsText it]
|
||||
let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq
|
||||
|
||||
|
|
@ -158,4 +158,3 @@ dashboardRootPage = rootPage do
|
|||
tabClick :: Attribute
|
||||
tabClick =
|
||||
hyper_ "on click take .contrast from .tab for event's target"
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# Language MultiWayIf #-}
|
||||
{-# Language ImplicitParams #-}
|
||||
module HBS2.Git.Web.Html.Types where
|
||||
|
||||
import HBS2.Git.DashBoard.Prelude
|
||||
|
|
@ -37,9 +38,22 @@ class Path a where
|
|||
instance Path String where
|
||||
path = Text.pack . joinPath . rootPath
|
||||
|
||||
|
||||
class ToRoutePattern a where
|
||||
routePattern :: a -> RoutePattern
|
||||
|
||||
type WithBaseUrl = ?dashBoardBaseUrl :: Text
|
||||
|
||||
getBaseUrl :: WithBaseUrl => Text
|
||||
getBaseUrl = ?dashBoardBaseUrl
|
||||
|
||||
withBaseUrl :: (WithBaseUrl => r) -> Text -> r
|
||||
withBaseUrl thingInside baseUrl =
|
||||
let ?dashBoardBaseUrl = baseUrl in thingInside
|
||||
|
||||
toBaseURL :: (WithBaseUrl, ToURL a) => a -> Text
|
||||
toBaseURL x = getBaseUrl <> toURL x
|
||||
|
||||
class ToURL a where
|
||||
toURL :: a -> Text
|
||||
|
||||
|
|
@ -136,6 +150,9 @@ instance ToRoutePattern RepoListPage where
|
|||
routePattern = \case
|
||||
RepoListPage -> "/"
|
||||
|
||||
instance ToURL String where
|
||||
toURL str = path [str]
|
||||
|
||||
instance ToURL (RepoPage RepoPageTabs (LWWRefKey 'HBS2Basic)) where
|
||||
toURL (RepoPage s w) = path @String [ "/", show (pretty s), show (pretty w)]
|
||||
<> pred_
|
||||
|
|
@ -303,5 +320,3 @@ agePure t0 t = do
|
|||
if | sec > 86400 -> pretty (sec `div` 86400) <+> "days ago"
|
||||
| sec > 3600 -> pretty (sec `div` 3600) <+> "hours ago"
|
||||
| otherwise -> pretty (sec `div` 60) <+> "minutes ago"
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue