Diff
patch 53ab61013f3768bf02ab2fb2763023d16998afad
Author: fritjof@alokat.org
Date: Wed Mar 11 20:15:19 UTC 2026
* Add tree view to navigation and polish the date view.
hunk ./darcsweb.cabal 32
+ , time >= 1.9 && < 2
hunk ./src/DarcsWeb/Darcs.hs 12
+ , getRepoTree
+ , getRepoBlob
hunk ./src/DarcsWeb/Darcs.hs 19
-import Data.List (sortBy)
+import Data.List (isPrefixOf, partition, sortBy)
hunk ./src/DarcsWeb/Darcs.hs 21
-import System.Directory (listDirectory, doesDirectoryExist, doesFileExist)
+import System.Directory (listDirectory, doesDirectoryExist, doesFileExist,
+ getFileSize)
hunk ./src/DarcsWeb/Darcs.hs 151
+-- | List entries in a directory within a repository's working tree.
+-- The subPath is relative to the repo root. Returns Nothing if the path
+-- is not a directory or doesn't exist.
+getRepoTree :: FilePath -> FilePath -> IO (Maybe [TreeEntry])
+getRepoTree repoPath subPath = do
+ let fullDir = if null subPath then repoPath else repoPath </> subPath
+ isDir <- doesDirectoryExist fullDir
+ if not isDir
+ then return Nothing
+ else do
+ entries <- listDirectory fullDir
+ let visible = filter (\e -> e /= "_darcs" && not ("." `isPrefixOf` e)) entries
+ items <- mapM (mkEntry fullDir) (sortBy compare visible)
+ -- Sort: directories first, then files, alphabetically within each group
+ let (dirs, files) = partition teIsDir items
+ return (Just (dirs ++ files))
+ where
+ mkEntry dir name = do
+ let path = dir </> name
+ isDir <- doesDirectoryExist path
+ size <- if isDir then return 0
+ else fromIntegral <$> getFileSize path
+ return TreeEntry
+ { teName = T.pack name
+ , teIsDir = isDir
+ , teSize = size
+ }
+
+-- | Read a file's contents from the repository working tree.
+-- Returns Nothing if the file doesn't exist or is a directory.
+getRepoBlob :: FilePath -> FilePath -> IO (Maybe Text)
+getRepoBlob repoPath subPath = do
+ let fullPath = repoPath </> subPath
+ exists <- doesFileExist fullPath
+ if not exists
+ then return Nothing
+ else do
+ txt <- T.pack <$> Prelude.readFile fullPath
+ return (Just txt)
+
hunk ./src/DarcsWeb/Html.hs 10
+ , renderTree
+ , renderBlob
hunk ./src/DarcsWeb/Html.hs 18
+import Data.Time.Clock (UTCTime, diffUTCTime)
+import Data.Time.Format (parseTimeM, defaultTimeLocale)
hunk ./src/DarcsWeb/Html.hs 47
-renderRepoList :: Text -> [RepoInfo] -> Text
-renderRepoList siteTitle repos =
+renderRepoList :: UTCTime -> Text -> [RepoInfo] -> Text
+renderRepoList now siteTitle repos =
hunk ./src/DarcsWeb/Html.hs 53
- else renderRepoTable repos
+ else renderRepoTable now repos
hunk ./src/DarcsWeb/Html.hs 57
-renderRepoTable :: [RepoInfo] -> Text
-renderRepoTable repos = T.concat
+renderRepoTable :: UTCTime -> [RepoInfo] -> Text
+renderRepoTable now repos = T.concat
hunk ./src/DarcsWeb/Html.hs 65
- , T.concat (map renderRepoRow repos)
+ , T.concat (map (renderRepoRow now) repos)
hunk ./src/DarcsWeb/Html.hs 69
-renderRepoRow :: RepoInfo -> Text
-renderRepoRow ri = T.concat
+renderRepoRow :: UTCTime -> RepoInfo -> Text
+renderRepoRow now ri = T.concat
hunk ./src/DarcsWeb/Html.hs 74
- , "<td>", esc (riLastChange ri), "</td>\n"
+ , "<td>", esc (relativeDate now (riLastChange ri)), "</td>\n"
hunk ./src/DarcsWeb/Html.hs 84
-renderRepoSummary :: Text -> RepoInfo -> [PatchSummary] -> [PatchSummary] -> Text
-renderRepoSummary repoName ri recentPatches tags =
+renderRepoSummary :: UTCTime -> Text -> RepoInfo -> [PatchSummary] -> [PatchSummary] -> Text
+renderRepoSummary now repoName ri recentPatches tags =
hunk ./src/DarcsWeb/Html.hs 92
- , "<div class=\"repo-nav\">\n"
- , navLink repoName "summary" "summary"
- , navLink repoName "shortlog" "shortlog"
- , navLink repoName "log" "log"
- , navLink repoName "tags" "tags"
- , "</div>\n"
+ , repoNavBar repoName "summary"
hunk ./src/DarcsWeb/Html.hs 97
- else renderShortLogTable repoName (take 10 recentPatches)
+ else renderShortLogTable now repoName (take 10 recentPatches)
hunk ./src/DarcsWeb/Html.hs 106
- , renderTagList repoName (take 5 tags)
+ , renderTagList now repoName (take 5 tags)
hunk ./src/DarcsWeb/Html.hs 115
-renderShortLog :: Text -> [PatchSummary] -> Text
-renderShortLog repoName patches =
+renderShortLog :: UTCTime -> Text -> [PatchSummary] -> Text
+renderShortLog now repoName patches =
hunk ./src/DarcsWeb/Html.hs 123
- else renderShortLogTable repoName patches
+ else renderShortLogTable now repoName patches
hunk ./src/DarcsWeb/Html.hs 127
-renderShortLogTable :: Text -> [PatchSummary] -> Text
-renderShortLogTable repoName patches = T.concat
+renderShortLogTable :: UTCTime -> Text -> [PatchSummary] -> Text
+renderShortLogTable now repoName patches = T.concat
hunk ./src/DarcsWeb/Html.hs 133
- , T.concat (map (renderShortLogRow repoName) patches)
+ , T.concat (map (renderShortLogRow now repoName) patches)
hunk ./src/DarcsWeb/Html.hs 137
-renderShortLogRow :: Text -> PatchSummary -> Text
-renderShortLogRow repoName ps = T.concat
+renderShortLogRow :: UTCTime -> Text -> PatchSummary -> Text
+renderShortLogRow now repoName ps = T.concat
hunk ./src/DarcsWeb/Html.hs 140
- , "<td class=\"date\">", esc (shortDate (psDate ps)), "</td>\n"
+ , "<td class=\"date\">", esc (relativeDate now (psDate ps)), "</td>\n"
hunk ./src/DarcsWeb/Html.hs 156
-renderFullLog :: Text -> [PatchSummary] -> Text
-renderFullLog repoName patches =
+renderFullLog :: UTCTime -> Text -> [PatchSummary] -> Text
+renderFullLog now repoName patches =
hunk ./src/DarcsWeb/Html.hs 164
- else T.concat (map (renderFullLogEntry repoName) patches)
+ else T.concat (map (renderFullLogEntry now repoName) patches)
hunk ./src/DarcsWeb/Html.hs 168
-renderFullLogEntry :: Text -> PatchSummary -> Text
-renderFullLogEntry repoName ps = T.concat
+renderFullLogEntry :: UTCTime -> Text -> PatchSummary -> Text
+renderFullLogEntry now repoName ps = T.concat
hunk ./src/DarcsWeb/Html.hs 177
- , "<span class=\"log-date\">", esc (psDate ps), "</span>\n"
+ , "<span class=\"log-date\">", esc (relativeDate now (psDate ps)), "</span>\n"
hunk ./src/DarcsWeb/Html.hs 192
-renderPatchDetail :: Text -> PatchSummary -> Text
-renderPatchDetail repoName ps =
+renderPatchDetail :: UTCTime -> Text -> PatchSummary -> Text
+renderPatchDetail now repoName ps =
hunk ./src/DarcsWeb/Html.hs 205
- , "<tr><th>Date</th><td>", esc (psDate ps), "</td></tr>\n"
+ , "<tr><th>Date</th><td>", esc (relativeDate now (psDate ps)), "</td></tr>\n"
hunk ./src/DarcsWeb/Html.hs 223
-renderTags :: Text -> [PatchSummary] -> Text
-renderTags repoName tags =
+renderTags :: UTCTime -> Text -> [PatchSummary] -> Text
+renderTags now repoName tags =
hunk ./src/DarcsWeb/Html.hs 231
- else renderTagList repoName tags
+ else renderTagList now repoName tags
hunk ./src/DarcsWeb/Html.hs 235
-renderTagList :: Text -> [PatchSummary] -> Text
-renderTagList repoName tags = T.concat
+renderTagList :: UTCTime -> Text -> [PatchSummary] -> Text
+renderTagList now repoName tags = T.concat
hunk ./src/DarcsWeb/Html.hs 240
- , T.concat (map (renderTagRow repoName) tags)
+ , T.concat (map (renderTagRow now repoName) tags)
hunk ./src/DarcsWeb/Html.hs 244
-renderTagRow :: Text -> PatchSummary -> Text
-renderTagRow repoName ps = T.concat
+renderTagRow :: UTCTime -> Text -> PatchSummary -> Text
+renderTagRow now repoName ps = T.concat
hunk ./src/DarcsWeb/Html.hs 251
- , "<td class=\"date\">", esc (shortDate (psDate ps)), "</td>\n"
+ , "<td class=\"date\">", esc (relativeDate now (psDate ps)), "</td>\n"
hunk ./src/DarcsWeb/Html.hs 259
+-- | 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"
+
hunk ./src/DarcsWeb/Html.hs 375
+ , navLink' repoName "tree" "tree" active
hunk ./src/DarcsWeb/Html.hs 380
-navLink :: Text -> Text -> Text -> Text
-navLink repoName path label =
- "<a href=\"/repo/" <> esc repoName <> "/" <> path <> "\">" <> label <> "</a>\n"
-
hunk ./src/DarcsWeb/Html.hs 397
--- | Shorten a date string to just the date part
-shortDate :: Text -> Text
-shortDate d = T.take 19 d
+-- | 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
hunk ./src/DarcsWeb/Types.hs 4
+ , TreeEntry(..)
hunk ./src/DarcsWeb/Types.hs 31
+ } deriving (Show)
+
+-- | An entry in the repository file tree
+data TreeEntry = TreeEntry
+ { teName :: !Text -- ^ File or directory name
+ , teIsDir :: !Bool -- ^ True if directory
+ , teSize :: !Int -- ^ File size in bytes (0 for directories)
hunk ./src/Main.hs 17
+import Data.Time.Clock (getCurrentTime)
hunk ./src/Main.hs 192
+ now <- liftIO getCurrentTime
hunk ./src/Main.hs 194
- html $ TL.fromStrict $ renderRepoList (cfgTitle cfg) repos
+ html $ TL.fromStrict $ renderRepoList now (cfgTitle cfg) repos
hunk ./src/Main.hs 200
+ now <- liftIO getCurrentTime
hunk ./src/Main.hs 210
- html $ TL.fromStrict $ renderRepoSummary name ri (take 10 patches) tags
+ html $ TL.fromStrict $ renderRepoSummary now name ri (take 10 patches) tags
hunk ./src/Main.hs 216
+ now <- liftIO getCurrentTime
hunk ./src/Main.hs 218
- html $ TL.fromStrict $ renderShortLog name patches
+ html $ TL.fromStrict $ renderShortLog now name patches
hunk ./src/Main.hs 224
+ now <- liftIO getCurrentTime
hunk ./src/Main.hs 226
- html $ TL.fromStrict $ renderFullLog name patches
+ html $ TL.fromStrict $ renderFullLog now name patches
hunk ./src/Main.hs 232
+ now <- liftIO getCurrentTime
hunk ./src/Main.hs 234
- html $ TL.fromStrict $ renderTags name tags
+ html $ TL.fromStrict $ renderTags now name tags
+
+ -- Tree view (root)
+ get "/repo/:name/tree" $ do
+ name <- pathParam "name"
+ withRepo cfg name $ \repoPath -> do
+ mEntries <- liftIO $ getRepoTree repoPath ""
+ case mEntries of
+ Nothing -> do
+ status status404
+ html $ TL.fromStrict $ render404 "Tree not found."
+ Just entries ->
+ html $ TL.fromStrict $ renderTree name "" entries
+
+ -- Tree view (subdirectory)
+ get (regex "^/repo/([^/]+)/tree/(.+)$") $ do
+ name <- pathParam "1"
+ subPath <- pathParam "2"
+ withRepo cfg name $ \repoPath -> do
+ let sub = T.unpack subPath
+ mEntries <- liftIO $ getRepoTree repoPath sub
+ case mEntries of
+ Nothing -> do
+ status status404
+ html $ TL.fromStrict $ render404 "Directory not found."
+ Just entries ->
+ html $ TL.fromStrict $ renderTree name subPath entries
+
+ -- Blob view (file contents)
+ get (regex "^/repo/([^/]+)/blob/(.+)$") $ do
+ name <- pathParam "1"
+ subPath <- pathParam "2"
+ withRepo cfg name $ \repoPath -> do
+ let sub = T.unpack subPath
+ -- Reject paths with ".." to prevent directory traversal
+ if ".." `T.isInfixOf` subPath
+ then do
+ status status403
+ html $ TL.fromStrict $ render404 "Access denied."
+ else do
+ mContent <- liftIO $ getRepoBlob repoPath sub
+ case mContent of
+ Nothing -> do
+ status status404
+ html $ TL.fromStrict $ render404 "File not found."
+ Just content ->
+ html $ TL.fromStrict $ renderBlob name subPath content
hunk ./src/Main.hs 292
- Just ps ->
- html $ TL.fromStrict $ renderPatchDetail name ps
+ Just ps -> do
+ now <- liftIO getCurrentTime
+ html $ TL.fromStrict $ renderPatchDetail now name ps
hunk ./static/style.css 395
+
+/* === Tree View === */
+.tree-path {
+ margin: 8px 0 12px 0;
+ font-size: 13px;
+}
+
+.tree-path a {
+ color: #0000cc;
+}
+
+.tree-list td.tree-icon {
+ width: 20px;
+ text-align: center;
+ padding: 3px 4px;
+}
+
+.tree-list td.tree-name {
+ padding: 3px 8px;
+}
+
+.tree-list td.tree-name a {
+ color: #000;
+}
+
+.tree-list td.tree-name a:hover {
+ color: #0000cc;
+}
+
+.tree-list td.tree-size {
+ text-align: right;
+ color: #666;
+ font-family: monospace;
+ font-size: 12px;
+ width: 80px;
+ white-space: nowrap;
+}
+
+/* === Blob View === */
+.blob-content {
+ margin-top: 12px;
+}
+
+.blob-content pre {
+ background: #fafaf6;
+ padding: 8px;
+ border: 1px solid #d9d8d1;
+ overflow-x: auto;
+ white-space: pre;
+ line-height: 1.4;
+ tab-size: 4;
+}
+
+.blob-content code {
+ font-family: monospace;
+ font-size: 12px;
+}
/ darcsweb / shortlog / 53ab61013f37...