{-# LANGUAGE OverloadedStrings #-}
module DarcsWeb.Html
( renderPage
, renderRepoList
, renderShortLog
, renderFullLog
, renderPatchDetail
, renderTags
, renderTree
, renderBlob
, renderRepoSummary
, render404
-- Exported for testing
, esc
, highlightDiff
, shortAuthor
, formatSize
, formatAbsolute
) where
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime, diffUTCTime)
import Data.Time.Format (parseTimeM, defaultTimeLocale)
import qualified HtmlPure
import DarcsWeb.Types
-- | Wrap content in a full HTML page
renderPage :: Text -> Text -> [Text] -> Text
renderPage title breadcrumbs bodyParts = T.concat
[ "<!DOCTYPE html>\n<html lang=\"en\">\n<head>\n"
, "<meta charset=\"utf-8\">\n"
, "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">\n"
, "<title>", esc title, "</title>\n"
, "<link rel=\"stylesheet\" href=\"/static/style.css\">\n"
, "</head>\n<body>\n"
, "<div class=\"page-header\">\n"
, "<a href=\"/\"><img src=\"/static/darcs-logo.png\" alt=\"darcs\" class=\"header-logo\"></a>\n"
, breadcrumbs
, "</div>\n"
, "<div class=\"page-body\">\n"
, T.concat bodyParts
, "</div>\n"
, "<div class=\"page-footer\">\n"
, "<p>Powered by <a href=\"https://darcs.net\">darcs</a> & "
, "<a href=\"https://github.com/scotty-web/scotty\">scotty</a></p>\n"
, "</div>\n"
, "</body>\n</html>\n"
]
-- | Render the list of repositories (main index page)
renderRepoList :: UTCTime -> Text -> [RepoInfo] -> Text
renderRepoList now siteTitle repos =
let breadcrumbs = ""
body = T.concat
[ if null repos
then "<p class=\"empty\">No repositories found.</p>\n"
else renderRepoTable now repos
]
in renderPage siteTitle breadcrumbs [body]
renderRepoTable :: UTCTime -> [RepoInfo] -> Text
renderRepoTable now repos = T.concat
[ "<table class=\"repo-list\">\n"
, "<thead><tr>\n"
, "<th>Repository</th><th>Description</th>"
, "<th>Last Change</th><th>Patches</th>"
, "<th></th>\n"
, "</tr></thead>\n<tbody>\n"
, T.concat (map (renderRepoRow now) repos)
, "</tbody></table>\n"
]
renderRepoRow :: UTCTime -> RepoInfo -> Text
renderRepoRow now ri = T.concat
[ "<tr>\n"
, "<td class=\"repo-name\"><a href=\"/repo/", esc (riName ri), "/summary\">", esc (riName ri), "</a></td>\n"
, "<td>", esc (riDescription ri), "</td>\n"
, "<td>", esc (relativeDate now (riLastChange ri)), "</td>\n"
, "<td class=\"num\">", T.pack (show (riPatchCount ri)), "</td>\n"
, "<td class=\"actions\">"
, "<a href=\"/repo/", esc (riName ri), "/shortlog\">log</a> | "
, "<a href=\"/repo/", esc (riName ri), "/tags\">tags</a>"
, "</td>\n"
, "</tr>\n"
]
-- | Render repository summary page
renderRepoSummary :: UTCTime -> Text -> RepoInfo -> [PatchSummary] -> [PatchSummary] -> Text
renderRepoSummary now repoName ri recentPatches tags =
let breadcrumbs = " / <a href=\"/repo/" <> esc repoName <> "/summary\">" <> esc repoName <> "</a>"
body = T.concat
[ "<h1>", esc repoName, "</h1>\n"
, if T.null (riDescription ri)
then ""
else "<p class=\"description\">" <> esc (riDescription ri) <> "</p>\n"
, repoNavBar repoName "summary"
-- Recent activity
, "<h2>Recent Activity</h2>\n"
, if null recentPatches
then "<p class=\"empty\">No patches.</p>\n"
else renderShortLogTable now repoName (take 10 recentPatches)
, if length recentPatches > 0
then "<p class=\"more\"><a href=\"/repo/" <> esc repoName <> "/shortlog\">...</a></p>\n"
else ""
-- Tags
, if null tags
then ""
else T.concat
[ "<h2>Tags</h2>\n"
, renderTagList now repoName (take 5 tags)
, if length tags > 5
then "<p class=\"more\"><a href=\"/repo/" <> esc repoName <> "/tags\">all tags...</a></p>\n"
else ""
]
]
in renderPage (repoName <> " - Summary") breadcrumbs [body]
-- | Render shortlog (compact patch list)
renderShortLog :: UTCTime -> Text -> [PatchSummary] -> Text
renderShortLog now repoName patches =
let breadcrumbs = repoBreadcrumb repoName <> " / shortlog"
body = T.concat
[ "<h1>", esc repoName, " - Shortlog</h1>\n"
, repoNavBar repoName "shortlog"
, if null patches
then "<p class=\"empty\">No patches.</p>\n"
else renderShortLogTable now repoName patches
]
in renderPage (repoName <> " - Shortlog") breadcrumbs [body]
renderShortLogTable :: UTCTime -> Text -> [PatchSummary] -> Text
renderShortLogTable now repoName patches = T.concat
[ "<table class=\"shortlog\">\n"
, "<thead><tr>"
, "<th>Date</th><th>Author</th><th>Description</th><th></th>"
, "</tr></thead>\n<tbody>\n"
, T.concat (map (renderShortLogRow now repoName) patches)
, "</tbody></table>\n"
]
renderShortLogRow :: UTCTime -> Text -> PatchSummary -> Text
renderShortLogRow now repoName ps = T.concat
[ "<tr", if psIsTag ps then " class=\"tag-row\"" else "", ">\n"
, "<td class=\"date\">", esc (relativeDate now (psDate ps)), "</td>\n"
, "<td class=\"author\">", esc (shortAuthor (psAuthor ps)), "</td>\n"
, "<td class=\"subject\">"
, "<a href=\"/repo/", esc repoName, "/patch/", esc (psHash ps), "\">"
, if psIsTag ps
then "<span class=\"tag-badge\">TAG</span> "
else ""
, esc (psName ps), "</a>"
, "</td>\n"
, "<td class=\"actions\">"
, "<a href=\"/repo/", esc repoName, "/patch/", esc (psHash ps), "\">diff</a>"
, "</td>\n"
, "</tr>\n"
]
-- | Render full log (detailed patch list)
renderFullLog :: UTCTime -> Text -> [PatchSummary] -> Text
renderFullLog now repoName patches =
let breadcrumbs = repoBreadcrumb repoName <> " / log"
body = T.concat
[ "<h1>", esc repoName, " - Log</h1>\n"
, repoNavBar repoName "log"
, if null patches
then "<p class=\"empty\">No patches.</p>\n"
else T.concat (map (renderFullLogEntry now repoName) patches)
]
in renderPage (repoName <> " - Log") breadcrumbs [body]
renderFullLogEntry :: UTCTime -> Text -> PatchSummary -> Text
renderFullLogEntry now repoName ps = T.concat
[ "<div class=\"log-entry", if psIsTag ps then " tag-entry" else "", "\">\n"
, "<div class=\"log-header\">\n"
, "<span class=\"log-name\">"
, "<a href=\"/repo/", esc repoName, "/patch/", esc (psHash ps), "\">"
, if psIsTag ps then "<span class=\"tag-badge\">TAG</span> " else ""
, esc (psName ps)
, "</a></span>\n"
, "<span class=\"log-date\">", esc (relativeDate now (psDate ps)), "</span>\n"
, "</div>\n"
, "<div class=\"log-meta\">\n"
, "<span class=\"log-author\">", esc (psAuthor ps), "</span>\n"
, "</div>\n"
, if T.null (T.strip (psLog ps))
then ""
else "<div class=\"log-body\"><pre>" <> esc (T.strip (psLog ps)) <> "</pre></div>\n"
, if T.null (T.strip (psSummary ps))
then ""
else "<div class=\"log-summary\"><pre>" <> esc (T.strip (psSummary ps)) <> "</pre></div>\n"
, "</div>\n"
]
-- | Render a single patch detail with diff
renderPatchDetail :: UTCTime -> Text -> PatchSummary -> Text
renderPatchDetail now repoName ps =
let breadcrumbs = repoBreadcrumb repoName
<> " / <a href=\"/repo/" <> esc repoName <> "/shortlog\">shortlog</a>"
<> " / " <> esc (T.take 12 (psHash ps)) <> "..."
body = T.concat
[ "<div class=\"patch-detail\">\n"
, "<h1>"
, if psIsTag ps then "<span class=\"tag-badge\">TAG</span> " else ""
, esc (psName ps)
, "</h1>\n"
, "<table class=\"patch-meta\">\n"
, "<tr><th>Author</th><td>", esc (psAuthor ps), "</td></tr>\n"
, "<tr><th>Date</th><td>", esc (relativeDate now (psDate ps)), "</td></tr>\n"
, "<tr><th>Hash</th><td class=\"hash\">", esc (psHash ps), "</td></tr>\n"
, "</table>\n"
, if T.null (T.strip (psLog ps))
then ""
else "<div class=\"patch-log\"><h2>Description</h2><pre>" <> esc (T.strip (psLog ps)) <> "</pre></div>\n"
, if T.null (T.strip (psSummary ps))
then ""
else "<div class=\"patch-summary\"><h2>Summary</h2><pre>" <> esc (T.strip (psSummary ps)) <> "</pre></div>\n"
, "<div class=\"patch-diff\">\n"
, "<h2>Diff</h2>\n"
, "<pre class=\"diff\">", highlightDiff (psDiff ps), "</pre>\n"
, "</div>\n"
, "</div>\n"
]
in renderPage (psName ps <> " - " <> repoName) breadcrumbs [body]
-- | Render tags list
renderTags :: UTCTime -> Text -> [PatchSummary] -> Text
renderTags now repoName tags =
let breadcrumbs = repoBreadcrumb repoName <> " / tags"
body = T.concat
[ "<h1>", esc repoName, " - Tags</h1>\n"
, repoNavBar repoName "tags"
, if null tags
then "<p class=\"empty\">No tags found.</p>\n"
else renderTagList now repoName tags
]
in renderPage (repoName <> " - Tags") breadcrumbs [body]
renderTagList :: UTCTime -> Text -> [PatchSummary] -> Text
renderTagList now repoName tags = T.concat
[ "<table class=\"tag-list\">\n"
, "<thead><tr><th>Tag</th><th>Date</th><th>Author</th><th></th></tr></thead>\n"
, "<tbody>\n"
, T.concat (map (renderTagRow now repoName) tags)
, "</tbody></table>\n"
]
renderTagRow :: UTCTime -> Text -> PatchSummary -> Text
renderTagRow now repoName ps = T.concat
[ "<tr>\n"
, "<td class=\"tag-name\">"
, "<a href=\"/repo/", esc repoName, "/patch/", esc (psHash ps), "\">"
, esc (maybe (psName ps) id (psTagName ps))
, "</a></td>\n"
, "<td class=\"date\">", esc (relativeDate now (psDate ps)), "</td>\n"
, "<td class=\"author\">", esc (shortAuthor (psAuthor ps)), "</td>\n"
, "<td class=\"actions\">"
, "<a href=\"/repo/", esc repoName, "/patch/", esc (psHash ps), "\">details</a>"
, "</td>\n"
, "</tr>\n"
]
-- | Render repository tree (directory listing)
renderTree :: Text -> Text -> [TreeEntry] -> Text
renderTree repoName subPath entries =
let pathSuffix = if T.null subPath then "" else " / " <> subPath
breadcrumbs = repoBreadcrumb repoName <> " / tree" <> pathSuffix
body = T.concat
[ "<h1>", esc repoName, " - ", esc (if T.null subPath then "/" else subPath), "</h1>\n"
, repoNavBar repoName "tree"
, renderTreeBreadcrumb repoName subPath
, renderTreeTable repoName subPath entries
]
in renderPage (repoName <> " - Tree") breadcrumbs [body]
renderTreeBreadcrumb :: Text -> Text -> Text
renderTreeBreadcrumb repoName subPath =
let parts = if T.null subPath then [] else T.splitOn "/" subPath
buildCrumbs _ [] = ""
buildCrumbs acc (p:ps) =
let newAcc = if T.null acc then p else acc <> "/" <> p
in " / <a href=\"/repo/" <> esc repoName <> "/tree/" <> esc newAcc <> "\">"
<> esc p <> "</a>" <> buildCrumbs newAcc ps
in "<div class=\"tree-path\">"
<> "<a href=\"/repo/" <> esc repoName <> "/tree\">[root]</a>"
<> buildCrumbs "" parts
<> "</div>\n"
renderTreeTable :: Text -> Text -> [TreeEntry] -> Text
renderTreeTable repoName subPath entries = T.concat
[ "<table class=\"tree-list\">\n"
, "<thead><tr><th></th><th>Name</th><th>Size</th></tr></thead>\n"
, "<tbody>\n"
, if not (T.null subPath)
then let parent = case T.breakOnEnd "/" subPath of
("", _) -> ""
(pre, _) -> T.dropEnd 1 pre
parentHref = "/repo/" <> esc repoName <> "/tree"
<> (if T.null parent then "" else "/" <> esc parent)
in "<tr><td class=\"tree-icon\">\xf0\x9f\x93\x81</td>"
<> "<td class=\"tree-name\"><a href=\"" <> parentHref <> "\">..</a></td>"
<> "<td></td></tr>\n"
else ""
, T.concat (map (renderTreeRow repoName subPath) entries)
, "</tbody></table>\n"
]
renderTreeRow :: Text -> Text -> TreeEntry -> Text
renderTreeRow repoName subPath entry =
let name = teName entry
entryPath = if T.null subPath then name else subPath <> "/" <> name
(icon, href) = if teIsDir entry
then ("\xf0\x9f\x93\x81", "/repo/" <> esc repoName <> "/tree/" <> esc entryPath)
else ("\xf0\x9f\x93\x84", "/repo/" <> esc repoName <> "/blob/" <> esc entryPath)
sizeText = if teIsDir entry then "" else formatSize (teSize entry)
in T.concat
[ "<tr>"
, "<td class=\"tree-icon\">", icon, "</td>"
, "<td class=\"tree-name\"><a href=\"", href, "\">", esc name
, if teIsDir entry then "/" else ""
, "</a></td>"
, "<td class=\"tree-size\">", sizeText, "</td>"
, "</tr>\n"
]
formatSize :: Int -> Text
formatSize n
| n < 1024 = T.pack (show n) <> " B"
| n < 1048576 = T.pack (show (n `div` 1024)) <> " KiB"
| otherwise = T.pack (show (n `div` 1048576)) <> " MiB"
-- | Render blob (file contents)
renderBlob :: Text -> Text -> Text -> Text
renderBlob repoName subPath content =
let breadcrumbs = repoBreadcrumb repoName <> " / blob / " <> esc subPath
body = T.concat
[ "<h1>", esc repoName, " - ", esc subPath, "</h1>\n"
, repoNavBar repoName "tree"
, renderBlobBreadcrumb repoName subPath
, "<div class=\"blob-content\"><pre><code>"
, esc content
, "</code></pre></div>\n"
]
in renderPage (repoName <> " - " <> subPath) breadcrumbs [body]
renderBlobBreadcrumb :: Text -> Text -> Text
renderBlobBreadcrumb repoName subPath =
let parts = T.splitOn "/" subPath
dirParts = init parts
fileName = last parts
buildCrumbs _ [] = ""
buildCrumbs acc (p:ps) =
let newAcc = if T.null acc then p else acc <> "/" <> p
in " / <a href=\"/repo/" <> esc repoName <> "/tree/" <> esc newAcc <> "\">"
<> esc p <> "</a>" <> buildCrumbs newAcc ps
in "<div class=\"tree-path\">"
<> "<a href=\"/repo/" <> esc repoName <> "/tree\">[root]</a>"
<> buildCrumbs "" dirParts
<> " / " <> esc fileName
<> "</div>\n"
-- | Render 404 page
render404 :: Text -> Text
render404 msg =
renderPage "Not Found" "" ["<h1>404 - Not Found</h1>\n<p>" <> esc msg <> "</p>\n"]
-- Helpers
repoBreadcrumb :: Text -> Text
repoBreadcrumb repoName =
" / <a href=\"/repo/" <> esc repoName <> "/summary\">" <> esc repoName <> "</a>"
repoNavBar :: Text -> Text -> Text
repoNavBar repoName active = T.concat
[ "<div class=\"repo-nav\">\n"
, navLink' repoName "summary" "summary" active
, navLink' repoName "shortlog" "shortlog" active
, navLink' repoName "log" "log" active
, navLink' repoName "tree" "tree" active
, navLink' repoName "tags" "tags" active
, "</div>\n"
]
navLink' :: Text -> Text -> Text -> Text -> Text
navLink' repoName path label active =
if path == active
then "<a href=\"/repo/" <> esc repoName <> "/" <> path <> "\" class=\"active\">" <> label <> "</a>\n"
else "<a href=\"/repo/" <> esc repoName <> "/" <> path <> "\">" <> label <> "</a>\n"
-- | HTML-escape text.
-- Uses formally verified implementation from Coq/Rocq.
esc :: Text -> Text
esc = T.pack . HtmlPure.esc . T.unpack
-- | Highlight diff output: added lines in green, removed lines in red,
-- hunk headers in blue.
highlightDiff :: Text -> Text
highlightDiff = T.concat . map highlightLine . T.lines
where
highlightLine l
| T.isPrefixOf "+" l = "<span class=\"diff-add\">" <> esc l <> "</span>\n"
| T.isPrefixOf "-" l = "<span class=\"diff-del\">" <> esc l <> "</span>\n"
| T.isPrefixOf "@@" l = "<span class=\"diff-hunk\">" <> esc l <> "</span>\n"
| otherwise = esc l <> "\n"
-- | Format a darcs date (YYYYMMDDHHMMSS) as relative time or absolute date.
-- Shows relative time (e.g. "5 minutes ago") if within 4 weeks,
-- otherwise shows the date as YYYY-MM-DD HH:MM:SS.
relativeDate :: UTCTime -> Text -> Text
relativeDate now dateStr =
case parseDarcsDate (T.unpack dateStr) of
Nothing -> dateStr -- unparseable, return as-is
Just t ->
let secs = floor (diffUTCTime now t) :: Int
in if secs < 0 then formatAbsolute dateStr
else if secs < 60 then pluralize secs "second"
else if secs < 3600 then pluralize (secs `div` 60) "minute"
else if secs < 86400 then pluralize (secs `div` 3600) "hour"
else if secs < 604800 then pluralize (secs `div` 86400) "day"
else if secs < 2419200 then pluralize (secs `div` 604800) "week"
else formatAbsolute dateStr
where
pluralize n unit =
T.pack (show n) <> " " <> T.pack unit <> if n == 1 then " ago" else "s ago"
-- | Parse darcs YYYYMMDDHHMMSS format to UTCTime
parseDarcsDate :: String -> Maybe UTCTime
parseDarcsDate = parseTimeM False defaultTimeLocale "%Y%m%d%H%M%S"
-- | Format a darcs date string as YYYY-MM-DD HH:MM:SS
formatAbsolute :: Text -> Text
formatAbsolute d =
let s = T.unpack d
in if length s >= 14
then T.pack $ take 4 s ++ "-" ++ take 2 (drop 4 s) ++ "-" ++ take 2 (drop 6 s)
++ " " ++ take 2 (drop 8 s) ++ ":" ++ take 2 (drop 10 s) ++ ":" ++ take 2 (drop 12 s)
else d
-- | Shorten author to just the name part (before email)
shortAuthor :: Text -> Text
shortAuthor a =
let trimmed = T.strip a
in case T.breakOn "<" trimmed of
(name, rest)
| T.null rest -> trimmed
| otherwise -> T.strip name
/ darcsweb / blob / src/DarcsWeb/Html.hs