Diff
patch bf69b2c8ff801cf540b0467af45f846294cc109e
Author: fritjof@alokat.org
Date: Mon Nov 9 06:34:57 UTC 2026
* Close OWASP Top 10 gaps and restyle UI as a gitweb homage
Hardens headers, error handling, symlinks, diff size and deployment, and replaces the stylesheet with a mobile-first light/dark "Putty & Ink" design.
Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
hunk ./Caddyfile 4
-# Encrypt) and enables HSTS by default. This configuration adds additional
-# security hardening on top.
+# Encrypt) and redirects HTTP to HTTPS. It does NOT send
+# Strict-Transport-Security by itself; the header block below adds it.
hunk ./Caddyfile 13
-# Note: the `rate_limit` directive below requires the caddy-ratelimit
-# module. The stock `caddy:2-alpine` image does not include it -- either
-# build a custom image (`FROM caddy:builder` then `xcaddy build --with
-# github.com/mholt/caddy-ratelimit`), use a prebuilt image that bundles
-# the module, or remove the `rate_limit { ... }` block to run with the
-# stock image.
+# Rate limiting is disabled by default: `rate_limit` is a third-party
+# directive that the stock `caddy:2-alpine` image does not include, and
+# Caddy refuses to start with it. To enable it, build a custom image
+# (`FROM caddy:builder` then `xcaddy build --with
+# github.com/mholt/caddy-ratelimit`), point docker-compose.yml at it,
+# uncomment the global option and the `rate_limit` block below.
+#
+# {
+# order rate_limit before basic_auth
+# }
hunk ./Caddyfile 25
- # Rate limiting: 10 requests/s per client IP, burst of 20
- rate_limit {
- zone darcsweb {
- key {remote_host}
- events 10
- window 1s
- }
- }
+ # Rate limiting: 10 requests/s per client IP (needs the module above)
+ # rate_limit {
+ # zone darcsweb {
+ # key {remote_host}
+ # events 10
+ # window 1s
+ # }
+ # }
hunk ./Caddyfile 42
- # Restrict browser APIs
+ # HSTS: one year, this host only (no includeSubDomains, no preload)
+ Strict-Transport-Security "max-age=31536000"
+ # Restrict browser APIs (same value as the application sends)
hunk ./Dockerfile 14
-FROM haskell:9.6-slim AS build
+# Refresh the digest pin: docker buildx imagetools inspect haskell:9.6-slim
+FROM haskell:9.6-slim@sha256:3abe1175a5466fe760ed90937b32b42be340281b6707dace6d5addea2148d05e AS build
hunk ./Dockerfile 91
-FROM debian:bookworm-slim
+# Refresh the digest pin: docker buildx imagetools inspect debian:bookworm-slim
+FROM debian:bookworm-slim@sha256:734a72b3d6142a71993b4bc580ca01d8ca687f77a2c422d96a961d3376b179bc
hunk ./README.md 187
-docker run -d -p 3000:3000 -v /srv/darcs:/srv/darcs:ro darcsweb
+docker run -d -p 127.0.0.1:3000:3000 -v /srv/darcs:/srv/darcs:ro darcsweb
hunk ./README.md 207
-docker run -d -p 3000:3000 \
+docker run -d -p 127.0.0.1:3000:3000 \
hunk ./README.md 273
-| `build_csp` / `sanitize_value` | `verified/csp_pure.v` | CSP header construction in `Main` |
+| `build_csp` / `sanitize_value` | `verified/csp_pure.v` | CSP header construction in `DarcsWeb.Http` |
hunk ./app/Main.hs 3
+{-# LANGUAGE ScopedTypeVariables #-}
hunk ./app/Main.hs 10
- request, regex, middleware)
-import Network.Wai.Handler.Warp (setPort, setHost, defaultSettings)
-import Network.HTTP.Types.Status (status404, status403)
-import Network.Wai (Request, pathInfo, modifyResponse,
- mapResponseHeaders, requestHeaders, Middleware)
+ request, regex, middleware, defaultHandler)
+import Network.Wai.Handler.Warp (setPort, setHost, setServerName,
+ setOnException, defaultSettings,
+ defaultShouldDisplayException)
+import Network.HTTP.Types.Status (status404, status403, status500)
+import Network.Wai (Request, pathInfo, requestHeaders)
+import Control.Exception (evaluate, SomeException, SomeAsyncException,
+ fromException, throwIO)
+import Control.Monad.Catch (Handler(..))
+import Control.Monad (when)
hunk ./app/Main.hs 22
-import qualified Data.ByteString.Char8 as BC
hunk ./app/Main.hs 47
+import DarcsWeb.Http
hunk ./app/Main.hs 49
-import qualified CspPure
hunk ./app/Main.hs 159
+ $ setServerName ""
+ $ setOnException logWarpException
hunk ./app/Main.hs 164
+ where
+ -- Anything that escapes Scotty is logged sanitised, never raw. Benign
+ -- connection and timeout exceptions stay quiet, as in Warp's default.
+ logWarpException _ e =
+ when (defaultShouldDisplayException e) $
+ cfgLog cfg ("warp exception: " ++ sanitizeLogLine (show e))
hunk ./app/Main.hs 208
--- | Map file extension to MIME type for static assets
-mimeType :: String -> TL.Text
-mimeType ".css" = "text/css; charset=utf-8"
-mimeType ".js" = "application/javascript"
-mimeType ".png" = "image/png"
-mimeType ".jpg" = "image/jpeg"
-mimeType ".jpeg" = "image/jpeg"
-mimeType ".gif" = "image/gif"
-mimeType ".svg" = "image/svg+xml"
-mimeType ".ico" = "image/x-icon"
-mimeType ".woff" = "font/woff"
-mimeType ".woff2" = "font/woff2"
-mimeType _ = "application/octet-stream"
-
--- | Build CSP header using formally verified builder from Rocq.
--- The builder guarantees no semicolon injection within directive values.
-cspHeader :: BC.ByteString
-cspHeader = BC.pack $ CspPure.build_csp
- [ ("default-src", "'none'")
- , ("style-src", "'self'")
- , ("img-src", "'self'")
- , ("frame-ancestors", "'none'")
- , ("base-uri", "'none'")
- , ("form-action", "'none'")
- ]
-
--- | WAI middleware that adds security response headers to every response.
-securityHeaders :: Middleware
-securityHeaders = modifyResponse $ mapResponseHeaders (++ secHeaders)
- where
- secHeaders =
- [ ("X-Content-Type-Options", "nosniff")
- , ("X-Frame-Options", "DENY")
- , ("Referrer-Policy", "strict-origin-when-cross-origin")
- , ("Permissions-Policy", "camera=(), microphone=(), geolocation=()")
- , ("Content-Security-Policy", cspHeader)
- , ("X-Robots-Tag", "noindex, nofollow")
- ]
+-- | Send an HTML page. The 'Text' is forced here, inside the action:
+-- Scotty only stores a lazy builder, so an exception thrown while the
+-- page renders would otherwise surface in Warp, past 'defaultHandler'.
+page :: T.Text -> ActionM ()
+page t = liftIO (evaluate t) >> html (TL.fromStrict t)
hunk ./app/Main.hs 218
+ -- Log unhandled exceptions (control characters stripped against log
+ -- injection) and answer with a generic 500 page that carries no
+ -- exception text. Asynchronous exceptions (Warp timeout, shutdown)
+ -- are not request failures and are rethrown.
+ defaultHandler $ Handler $ \(e :: SomeException) ->
+ case fromException e :: Maybe SomeAsyncException of
+ Just _ -> liftIO (throwIO e)
+ Nothing -> do
+ liftIO $ cfgLog cfg
+ $ "unhandled exception: " ++ sanitizeLogLine (show e)
+ status status500
+ page render500
+
hunk ./app/Main.hs 241
- html $ TL.fromStrict $ renderRepoList now (cfgTitle cfg) repos
+ page $ renderRepoList now (cfgTitle cfg) repos
hunk ./app/Main.hs 254
- html $ TL.fromStrict $ renderRepoSummary now name ri clone (take 10 patches) tags
+ page $ renderRepoSummary now name ri clone (take 10 patches) tags
hunk ./app/Main.hs 272
- html $ TL.fromStrict $ renderShortLog now name patches
+ page $ renderShortLog now name patches
hunk ./app/Main.hs 280
- html $ TL.fromStrict $ renderFullLog now name patches
+ page $ renderFullLog now name patches
hunk ./app/Main.hs 288
- html $ TL.fromStrict $ renderTags now name tags
+ page $ renderTags now name tags
hunk ./app/Main.hs 298
- html $ TL.fromStrict $ render404 "Tree not found."
+ page $ render404 "Tree not found."
hunk ./app/Main.hs 300
- html $ TL.fromStrict $ renderTree name "" entries
+ page $ renderTree name "" entries
hunk ./app/Main.hs 312
- html $ TL.fromStrict $ render404 "Not found."
+ page $ render404 "Not found."
hunk ./app/Main.hs 314
- html $ TL.fromStrict $ renderTree name subPath entries
+ page $ renderTree name subPath entries
hunk ./app/Main.hs 326
- html $ TL.fromStrict $ render404 "Not found."
+ page $ render404 "Not found."
hunk ./app/Main.hs 328
- html $ TL.fromStrict $ renderBlob name subPath content
+ page $ renderBlob name subPath content
hunk ./app/Main.hs 339
- html $ TL.fromStrict $ render404 "Patch not found."
+ page $ render404 "Patch not found."
hunk ./app/Main.hs 342
- html $ TL.fromStrict $ renderPatchDetail now name ps
+ page $ renderPatchDetail now name ps
hunk ./app/Main.hs 347
- html $ TL.fromStrict $ render404 "Page not found."
+ page $ render404 "Page not found."
hunk ./app/Main.hs 384
- setHeader "Cache-Control" "public, max-age=86400, immutable"
+ setHeader "Cache-Control" staticCacheControl
hunk ./app/Main.hs 393
- | T.any (== '/') name || T.any (== '\\') name || ".." `T.isInfixOf` name
- || T.isPrefixOf "." name = do
+ | not (isValidRepoName name) = do
hunk ./app/Main.hs 395
- html $ TL.fromStrict $ render404 "Invalid repository name."
+ page $ render404 "Invalid repository name."
hunk ./app/Main.hs 402
- html $ TL.fromStrict $ render404 "Repository not found."
+ page $ render404 "Repository not found."
hunk ./app/Main.hs 409
- html $ TL.fromStrict $ render404 "Repository not found."
+ page $ render404 "Repository not found."
hunk ./app/Main.hs 416
- html $ TL.fromStrict $ render404 "Access denied."
+ page $ render404 "Access denied."
hunk ./app/Main.hs 455
- html $ TL.fromStrict $ render404 "Not found."
+ page $ render404 "Not found."
hunk ./darcsweb.cabal 23
+ , DarcsWeb.Http
hunk ./darcsweb.cabal 37
+ , wai >= 3.0 && < 4
+ , http-types >= 0.12 && < 1
hunk ./darcsweb.cabal 53
+ , exceptions >= 0.10 && < 1
hunk ./darcsweb.cabal 69
+ , Properties.Http
+ , Properties.Darcs
hunk ./darcsweb.cabal 77
+ , bytestring >= 0.10 && < 1
+ , directory >= 1.3 && < 2
+ , filepath >= 1.4 && < 2
+ , time >= 1.9 && < 2
+ , wai >= 3.0 && < 4
+ , http-types >= 0.12 && < 1
hunk ./docker-compose.yml 9
+ read_only: true
+ tmpfs:
+ - /tmp
+ cap_drop:
+ - ALL
+ security_opt:
+ - no-new-privileges:true
+ mem_limit: 512m
+ pids_limit: 128
hunk ./docker-compose.yml 20
- image: caddy:2-alpine
+ # Refresh the digest pin: docker buildx imagetools inspect caddy:2-alpine
+ image: caddy:2-alpine@sha256:78bd35025c7ba85961dd149ae670315129954e77abe2383ac47c89106b35ade9
hunk ./docker-compose.yml 30
+ - caddy_logs:/var/log/caddy
hunk ./docker-compose.yml 34
+ cap_drop:
+ - ALL
+ cap_add:
+ - NET_BIND_SERVICE
+ security_opt:
+ - no-new-privileges:true
hunk ./docker-compose.yml 44
+ caddy_logs:
hunk ./src/DarcsWeb/Darcs.hs 19
+ , tryNonAsync
+ , maxDiffChars
+ , capDiff
hunk ./src/DarcsWeb/Darcs.hs 32
+import Data.Maybe (fromMaybe)
hunk ./src/DarcsWeb/Darcs.hs 35
- getFileSize, canonicalizePath)
+ getFileSize, canonicalizePath,
+ pathIsSymbolicLink)
hunk ./src/DarcsWeb/Darcs.hs 38
-import Control.Exception (try, SomeException, evaluate)
+import Control.Exception (try, throwIO, fromException, SomeException,
+ SomeAsyncException, evaluate)
hunk ./src/DarcsWeb/Darcs.hs 67
+import DarcsWeb.Http (isValidRepoName)
hunk ./src/DarcsWeb/Darcs.hs 70
+-- | 'try' for ordinary failures only. Asynchronous exceptions (Warp's
+-- timeout, 'Control.Concurrent.killThread', shutdown) are rethrown so a
+-- cancelled handler cannot carry on with empty data.
+tryNonAsync :: IO a -> IO (Either SomeException a)
+tryNonAsync act = do
+ r <- try act
+ case r of
+ Left e | Just (_ :: SomeAsyncException) <- fromException e -> throwIO e
+ _ -> return r
+
hunk ./src/DarcsWeb/Darcs.hs 92
-checkRepo baseDir name = do
+checkRepo baseDir name
+ | not (isValidRepoName (T.pack name)) = return []
+ | otherwise = do
hunk ./src/DarcsWeb/Darcs.hs 101
- if not isRepo
+ -- Same jail as 'withRepo': a symlink pointing outside the
+ -- repository directory is not listed.
+ inJail <- jailCheck baseDir fullPath
+ if not isRepo || not inJail
hunk ./src/DarcsWeb/Darcs.hs 130
- res <- try (BS.readFile descFile) :: IO (Either SomeException BS.ByteString)
+ res <- tryNonAsync (BS.readFile descFile)
hunk ./src/DarcsWeb/Darcs.hs 139
- result <- try $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
+ result <- tryNonAsync $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
hunk ./src/DarcsWeb/Darcs.hs 154
- result <- try $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
+ result <- tryNonAsync $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
hunk ./src/DarcsWeb/Darcs.hs 170
- result <- try $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
+ result <- tryNonAsync $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
hunk ./src/DarcsWeb/Darcs.hs 201
- result <- try $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
+ result <- tryNonAsync $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
hunk ./src/DarcsWeb/Darcs.hs 204
- allInfos = mapRL extractPatchListing patchRL
- tags = filter psIsTag allInfos
- _ <- evaluate (length tags)
+ -- Filter on the cheap 'PatchInfo' before rendering any summary.
+ tags = concat (mapRL (\p -> [extractPatchListing p | isTag (info p)]) patchRL)
+ mapM_ evaluate tags
hunk ./src/DarcsWeb/Darcs.hs 231
- result <- try $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
+ result <- tryNonAsync $ withRepositoryLocation YesUseCache repoPath $ RepoJob $ \repository -> do
hunk ./src/DarcsWeb/Darcs.hs 282
- r <- try (canonicalizePath p) :: IO (Either SomeException FilePath)
+ r <- tryNonAsync (canonicalizePath p)
hunk ./src/DarcsWeb/Darcs.hs 304
+-- | Working-tree jail: inside the repo, but neither @_darcs@ nor anything
+-- under it. 'jailCheck' resolves symlinks, so a link in the working
+-- tree that points into @_darcs@ is refused too. Fails closed. The
+-- @_darcs@ jail is canonicalised as well, so a repo whose @_darcs@ is
+-- itself a symlink still matches its target.
+treeJailCheck :: FilePath -> FilePath -> IO Bool
+treeJailCheck repoPath path = do
+ inRepo <- jailCheck repoPath path
+ metaDir <- fromMaybe metaRaw <$> safeCanonicalize metaRaw
+ inMeta <- jailCheck metaDir path
+ return (inRepo && not inMeta)
+ where
+ metaRaw = repoPath </> "_darcs"
+
hunk ./src/DarcsWeb/Darcs.hs 377
- safe <- jailCheck repoPath fullDir
+ safe <- treeJailCheck repoPath fullDir
hunk ./src/DarcsWeb/Darcs.hs 388
+ -- A symlink is followed only if its target stays inside the working
+ -- tree ('treeJailCheck': in the repo, not under @_darcs@). Dangling
+ -- links and links to anywhere else are listed as plain size-0 files
+ -- and never stat'ed, so nothing about their targets is leaked. The
+ -- stat itself is guarded so a target that vanishes mid-listing
+ -- cannot fail the whole page.
hunk ./src/DarcsWeb/Darcs.hs 396
- isDir <- doesDirectoryExist path
- size <- if isDir then return 0
- else fromIntegral <$> getFileSize path
+ isLink <- pathIsSymbolicLink path
+ inside <- if isLink then treeJailCheck repoPath path else return True
+ let opaque = isLink && not inside
+ isDir <- if opaque then return False else doesDirectoryExist path
+ size <- if isDir || opaque then return 0 else do
+ r <- tryNonAsync (getFileSize path)
+ return (either (const 0) fromIntegral r)
hunk ./src/DarcsWeb/Darcs.hs 427
- safe <- jailCheck repoPath fullPath
+ safe <- treeJailCheck repoPath fullPath
hunk ./src/DarcsWeb/Darcs.hs 435
- res <- try (BS.readFile fullPath)
- :: IO (Either SomeException BS.ByteString)
+ res <- tryNonAsync (BS.readFile fullPath)
hunk ./src/DarcsWeb/Darcs.hs 468
- (diffText, summaryText) = case hopefullyM piap of
- Just p -> ( T.pack $ renderString $ showPatch ForDisplay p
- , T.pack $ renderString $ summary p
- )
- Nothing -> ("(patch content unavailable)", "")
- in patchInfoToSummary pinfo diffText summaryText
+ (diffText, truncated, summaryText) = case hopefullyM piap of
+ Just p -> let (d, t) = capDiff maxDiffChars
+ (renderString $ showPatch ForDisplay p)
+ in (d, t, T.pack $ renderString $ summary p)
+ Nothing -> ("(patch content unavailable)", False, "")
+ in (patchInfoToSummary pinfo diffText summaryText)
+ { psDiffTruncated = truncated }
+
+-- | Maximum number of characters of a rendered diff to keep (bounds
+-- per-request memory for huge patches).
+maxDiffChars :: Int
+maxDiffChars = 2000000
+
+-- | Cut a rendered diff at @n@ characters. Single pass: at most @n+1@
+-- characters are packed (so it terminates on an unbounded string and
+-- never holds the capped 'String' and the 'Text' at once). The flag is
+-- set iff something was dropped.
+capDiff :: Int -> String -> (Text, Bool)
+capDiff n s =
+ let t = T.pack (take (n + 1) s)
+ in if T.length t > n then (T.take n t, True) else (t, False)
hunk ./src/DarcsWeb/Darcs.hs 501
+ , psDiffTruncated = False
hunk ./src/DarcsWeb/Html.hs 14
+ , render500
hunk ./src/DarcsWeb/Html.hs 18
+ , ageClass
hunk ./src/DarcsWeb/Html.hs 96
- , "<td>", esc (relativeDate now (riLastChange ri)), "</td>\n"
+ , "<td class=\"date ", ageClass now (riLastChange ri), "\">"
+ , esc (relativeDate now (riLastChange ri)), "</td>\n"
hunk ./src/DarcsWeb/Html.hs 183
- , "<td class=\"date\">", esc (relativeDate now (psDate ps)), "</td>\n"
+ , "<td class=\"date ", ageClass now (psDate ps), "\">"
+ , esc (relativeDate now (psDate ps)), "</td>\n"
hunk ./src/DarcsWeb/Html.hs 265
+ , if psDiffTruncated ps
+ then "<p class=\"diff-truncated\">Diff truncated: it exceeds the display limit.</p>\n"
+ else ""
hunk ./src/DarcsWeb/Html.hs 305
- , "<td class=\"date\">", esc (relativeDate now (psDate ps)), "</td>\n"
+ , "<td class=\"date ", ageClass now (psDate ps), "\">"
+ , esc (relativeDate now (psDate ps)), "</td>\n"
hunk ./src/DarcsWeb/Html.hs 403
- in "<tr><td class=\"tree-icon\" aria-hidden=\"true\">\xf0\x9f\x93\x81</td>"
+ in "<tr class=\"tree-dir\"><td class=\"tree-icon\" aria-hidden=\"true\">\x1F4C1</td>"
hunk ./src/DarcsWeb/Html.hs 418
- then ("\xf0\x9f\x93\x81", "/repo/" <> nameSeg <> "/tree/" <> entryHref)
- else ("\xf0\x9f\x93\x84", "/repo/" <> nameSeg <> "/blob/" <> entryHref)
+ then ("\x1F4C1", "/repo/" <> nameSeg <> "/tree/" <> entryHref)
+ else ("\x1F4C4", "/repo/" <> nameSeg <> "/blob/" <> entryHref)
hunk ./src/DarcsWeb/Html.hs 422
- [ "<tr>"
+ [ if teIsDir entry then "<tr class=\"tree-dir\">" else "<tr class=\"tree-file\">"
hunk ./src/DarcsWeb/Html.hs 459
+-- | Render generic 500 page. Takes no argument on purpose: exception
+-- text must never reach the client.
+render500 :: Text
+render500 =
+ renderPage "Server Error" ""
+ ["<h1>500 - Server Error</h1>\n<p>Something went wrong. Please try again later.</p>\n"]
+
hunk ./src/DarcsWeb/Html.hs 518
--- hunk headers in blue.
+-- hunk headers and darcs file operations in their own classes.
hunk ./src/DarcsWeb/Html.hs 526
+ | T.isPrefixOf "hunk " l = "<span class=\"diff-hunk\">" <> esc l <> "</span>\n"
+ | any (`T.isPrefixOf` l) fileOps = "<span class=\"diff-file\">" <> esc l <> "</span>\n"
hunk ./src/DarcsWeb/Html.hs 530
+ fileOps = [ "addfile ", "rmfile ", "adddir ", "rmdir ", "move "
+ , "replace ", "binary ", "changepref " ]
+
+-- | gitweb-style age bucket for date cells: @age0@ (under 2 hours),
+-- @age1@ (under 2 days), @age2@ otherwise. Future and unparseable
+-- dates are @age2@.
+ageClass :: UTCTime -> Text -> Text
+ageClass now dateStr =
+ case parseDarcsDate (T.unpack dateStr) of
+ Nothing -> "age2"
+ Just t -> bucket (floor (diffUTCTime now t) :: Int)
+ where
+ bucket secs
+ | secs < 0 = "age2"
+ | secs < 2 * hourSeconds = "age0"
+ | secs < 2 * daySeconds = "age1"
+ | otherwise = "age2"
+
addfile ./src/DarcsWeb/Http.hs
hunk ./src/DarcsWeb/Http.hs 1
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | HTTP-level pieces shared by the executable and the test suite:
+-- response security headers, the verified CSP, static MIME types,
+-- repository-name validation and log-line sanitising. Kept in the
+-- library (not in @app/Main.hs@) so the test suite can reach them.
+module DarcsWeb.Http
+ ( securityHeaderList
+ , securityHeaders
+ , cspHeader
+ , mimeType
+ , staticCacheControl
+ , isValidRepoName
+ , sanitizeLogLine
+ ) where
+
+import qualified Data.ByteString.Char8 as BC
+import Data.Char (isControl)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types (Header)
+import Network.Wai (Middleware, modifyResponse, mapResponseHeaders)
+
+import qualified CspPure
+
+-- | Map file extension to MIME type for static assets
+mimeType :: String -> TL.Text
+mimeType ".css" = "text/css; charset=utf-8"
+mimeType ".js" = "application/javascript"
+mimeType ".png" = "image/png"
+mimeType ".jpg" = "image/jpeg"
+mimeType ".jpeg" = "image/jpeg"
+mimeType ".gif" = "image/gif"
+mimeType ".svg" = "image/svg+xml"
+mimeType ".ico" = "image/x-icon"
+mimeType ".woff" = "font/woff"
+mimeType ".woff2" = "font/woff2"
+mimeType _ = "application/octet-stream"
+
+-- | Cache policy for static assets. Not @immutable@: the stylesheet URL
+-- is unversioned, so browsers must be able to revalidate after a
+-- redesign ships.
+staticCacheControl :: TL.Text
+staticCacheControl = "public, max-age=3600"
+
+-- | Build CSP header using formally verified builder from Rocq.
+-- The builder guarantees no semicolon injection within directive values.
+cspHeader :: BC.ByteString
+cspHeader = BC.pack $ CspPure.build_csp
+ [ ("default-src", "'none'")
+ , ("style-src", "'self'")
+ , ("img-src", "'self'")
+ , ("frame-ancestors", "'none'")
+ , ("base-uri", "'none'")
+ , ("form-action", "'none'")
+ ]
+
+-- | Security headers added to every response. HSTS is deliberately left
+-- to the TLS-terminating proxy, which knows whether TLS is in use.
+securityHeaderList :: [Header]
+securityHeaderList =
+ [ ("X-Content-Type-Options", "nosniff")
+ , ("X-Frame-Options", "DENY")
+ , ("Referrer-Policy", "strict-origin-when-cross-origin")
+ , ("Permissions-Policy", "camera=(), microphone=(), geolocation=(), payment=()")
+ , ("Content-Security-Policy", cspHeader)
+ , ("X-Robots-Tag", "noindex, nofollow")
+ , ("Cross-Origin-Opener-Policy", "same-origin")
+ , ("Cross-Origin-Resource-Policy", "same-origin")
+ ]
+
+-- | WAI middleware that adds security response headers to every response.
+securityHeaders :: Middleware
+securityHeaders = modifyResponse $ mapResponseHeaders (++ securityHeaderList)
+
+-- | Repository names must be a single, non-hidden path component without
+-- control characters (NUL would be truncated by C path APIs).
+isValidRepoName :: T.Text -> Bool
+isValidRepoName name =
+ not (T.null name
+ || T.any isControl name
+ || T.any (== '/') name || T.any (== '\\') name
+ || ".." `T.isInfixOf` name
+ || T.isPrefixOf "." name)
+
+-- | Replace control characters so request-derived text cannot forge or
+-- split log lines.
+sanitizeLogLine :: String -> String
+sanitizeLogLine = map (\c -> if isControl c then ' ' else c)
hunk ./src/DarcsWeb/Types.hs 22
+ , psDiffTruncated :: !Bool -- ^ True if 'psDiff' was cut at the size cap
hunk ./static/style.css 1
-/* DarcsWeb ��� Technical Manuscript Theme
- A warm, precise aesthetic for browsing darcs repositories.
- Supports light/dark mode via prefers-color-scheme. */
-
-/* === Design Tokens === */
+/*
+ * DarcsWeb -- "Putty & Ink"
+ *
+ * A lamp-lit ledger take on gitweb: putty header and footer bars, the logo
+ * on the right, bold slash breadcrumbs, pipe-separated page nav, bone
+ * serif title bars, ivory zebra rows, yellow tag labels, green/red diffs
+ * with purple chunk headers and age-coloured dates.
+ *
+ * Constraints (see the Content-Security-Policy): system font stacks only,
+ * no @font-face, no data: URLs, no external assets, no inline styles.
+ * Mobile-first: the base rules are for narrow screens; min-width media
+ * queries (48rem, 64rem) add the table layout and the framed page.
+ */
+
+/* ---------- Tokens ---------- */
+
hunk ./static/style.css 18
- /* Typography */
- --font-body: -apple-system, BlinkMacSystemFont, "Segoe UI", Helvetica, Arial, sans-serif, "Apple Color Emoji", "Segoe UI Emoji";
- --font-mono: "SF Mono", "Cascadia Code", "Fira Code", "JetBrains Mono", Menlo, Consolas, "Liberation Mono", monospace;
- --size-xs: 0.6875rem;
- --size-sm: 0.75rem;
- --size-base: 0.875rem;
- --size-md: 1rem;
- --size-lg: 1.25rem;
- --size-xl: 1.5rem;
- --line-height: 1.6;
- --line-mono: 1.5;
-
- /* Spacing */
- --space-1: 0.25rem;
- --space-2: 0.5rem;
- --space-3: 0.75rem;
- --space-4: 1rem;
- --space-5: 1.5rem;
- --space-6: 2rem;
- --space-8: 3rem;
-
- /* Radii */
- --radius-sm: 4px;
- --radius-md: 6px;
- --radius-lg: 8px;
-
- /* Light mode colors */
- --bg-page: #faf9f7;
- --bg-surface: #ffffff;
- --bg-muted: #f3f1ed;
- --bg-header: #2d2a26;
- --bg-footer: #2d2a26;
-
- --text-primary: #1a1a1a;
- --text-secondary: #5c574f;
- --text-muted: #8a847a;
- --text-inverse: #f3f1ed;
- --text-link: #0d6e6e;
- --text-link-hover: #095252;
-
- --border-default: #e4e0d8;
- --border-strong: #ccc7bc;
- --border-subtle: #edeae4;
-
- --accent: #0d6e6e;
- --accent-bg: #e8f5f4;
- --accent-subtle: #f0faf9;
-
- --tag-bg: #fef3c7;
- --tag-text: #92400e;
- --tag-border: #fcd34d;
-
- --diff-add-bg: #dafbe1;
- --diff-add-text: #1a7f37;
- --diff-del-bg: #ffd7d5;
- --diff-del-text: #cf222e;
- --diff-hunk-bg: #eee8fb;
- --diff-hunk-text: #7c3aed;
-
- --nav-bg: transparent;
- --nav-active-bg: var(--bg-surface);
- --nav-active-border: var(--accent);
- --nav-hover-bg: var(--bg-muted);
-
- --table-hover: #f8f6f2;
- --table-stripe: #fcfbf9;
-
- --shadow-sm: 0 1px 2px rgba(0,0,0,0.05);
- --shadow-md: 0 2px 8px rgba(0,0,0,0.08);
+ color-scheme: light dark;
+
+ --putty: #d9d8d1;
+ --bone: #edece6;
+ --ivory: #f6f6f0;
+ --paper: #fffffb;
+ --page: #fbfaf6;
+
+ --ink: #1d1c19;
+ --ink-2: #55524a;
+ --ink-3: #6b675c;
+ --rule: #c9c7bd;
+
+ --link: #1d3fa3;
+ --link-hover: #0f2670;
+ --focus: #1d3fa3;
+
+ --tag-bg: #ffffaa;
+ --tag-border: #e0b400;
+ --tag-text: #5c4400;
+
+ --add: #0b6e0b;
+ --add-bg: #eaf6e4;
+ --del: #b01e1e;
+ --del-bg: #fbeaea;
+ --hunk: #8a1f8a;
+ --hunk-bg: #f4e9f4;
+ --file: #1d3fa3;
+ --file-bg: var(--bone);
+
+ --age0: #0b6e0b;
+ --age1: #4d6b1f;
+ --age2: var(--ink-3);
+
+ --logo-chip: transparent;
+
+ --font-ui: "Lucida Grande", "Lucida Sans Unicode", "Lucida Sans",
+ "DejaVu Sans", Geneva, Verdana, sans-serif;
+ --font-title: "Iowan Old Style", "Palatino Linotype", Palatino,
+ "URW Palladio L", P052, "Book Antiqua", Georgia, serif;
+ --font-mono: ui-monospace, "SF Mono", "Cascadia Mono", "DejaVu Sans Mono",
+ Menlo, Consolas, "Liberation Mono", monospace;
+
+ --tap: 2.75rem; /* 44px minimum touch target */
+ --gutter: 0.875rem;
hunk ./static/style.css 67
- --bg-page: #16171a;
- --bg-surface: #1e1f23;
- --bg-muted: #26272c;
- --bg-header: #111214;
- --bg-footer: #111214;
-
- --text-primary: #e4e2de;
- --text-secondary: #a09b93;
- --text-muted: #6e6960;
- --text-inverse: #1a1a1a;
- --text-link: #4ecdc4;
- --text-link-hover: #7ee0d9;
-
- --border-default: #33343a;
- --border-strong: #44464d;
- --border-subtle: #28292e;
-
- --accent: #4ecdc4;
- --accent-bg: #1a2f2e;
- --accent-subtle: #162524;
-
- --tag-bg: #3d2e0a;
- --tag-text: #fbbf24;
- --tag-border: #78600f;
-
- --diff-add-bg: #132a1c;
- --diff-add-text: #56d364;
- --diff-del-bg: #3d1117;
- --diff-del-text: #ff7b72;
- --diff-hunk-bg: #211b39;
- --diff-hunk-text: #b28bf5;
-
- --nav-hover-bg: var(--bg-muted);
- --nav-active-bg: var(--bg-page);
-
- --table-hover: #22232a;
- --table-stripe: #1a1b20;
-
- --shadow-sm: 0 1px 2px rgba(0,0,0,0.2);
- --shadow-md: 0 2px 8px rgba(0,0,0,0.3);
+ --putty: #35332d;
+ --bone: #2a2924;
+ --ivory: #22211d;
+ --paper: #1b1a17;
+ --page: #141311;
+
+ --ink: #ebe8de;
+ --ink-2: #bdb9ac;
+ --ink-3: #9a968a;
+ --rule: #46443c;
+
+ --link: #9db4ff;
+ --link-hover: #c3d1ff;
+ --focus: #c3d1ff;
+
+ --tag-bg: #4a4210;
+ --tag-border: #a68a00;
+ --tag-text: #ffe680;
+
+ --add: #8fdc8f;
+ --add-bg: #13280f;
+ --del: #ff9a90;
+ --del-bg: #2f1412;
+ --hunk: #e3a6e3;
+ --hunk-bg: #2a1a2a;
+ --file: #9db4ff;
+
+ --age0: #8fdc8f;
+ --age1: #b9cf86;
+
+ /* The logo is dark ink on a light ground: give it a light chip. */
+ --logo-chip: #ebe8de;
hunk ./static/style.css 102
-/* === Reset & Base === */
-*, *::before, *::after {
- margin: 0;
- padding: 0;
+/* ---------- Base ---------- */
+
+*,
+*::before,
+*::after {
hunk ./static/style.css 112
- -webkit-font-smoothing: antialiased;
- -moz-osx-font-smoothing: grayscale;
+ text-size-adjust: 100%;
hunk ./static/style.css 116
- font-family: var(--font-body);
- font-size: var(--size-base);
- line-height: var(--line-height);
- color: var(--text-primary);
- background: var(--bg-page);
+ margin: 0;
+ background: var(--page);
+ color: var(--ink);
+ font-family: var(--font-ui);
+ font-size: 0.9375rem;
+ line-height: 1.5;
+ display: flex;
+ flex-direction: column;
hunk ./static/style.css 125
- display: flex;
- flex-direction: column;
+ min-height: 100dvh;
hunk ./static/style.css 129
- color: var(--text-link);
+ color: var(--link);
hunk ./static/style.css 131
- transition: color 0.15s ease;
hunk ./static/style.css 134
- color: var(--text-link-hover);
+ color: var(--link-hover);
hunk ./static/style.css 136
- text-underline-offset: 2px;
hunk ./static/style.css 138
-pre, code {
+:focus-visible {
+ outline: 2px solid var(--focus);
+ outline-offset: 2px;
+ border-radius: 2px;
+}
+
+code,
+pre {
hunk ./static/style.css 147
- font-size: var(--size-sm);
- line-height: var(--line-mono);
+ font-size: 0.8125rem;
hunk ./static/style.css 150
-h1 {
- font-size: var(--size-xl);
- font-weight: 700;
- letter-spacing: -0.02em;
- margin-bottom: var(--space-4);
- color: var(--text-primary);
+pre {
+ margin: 0;
+ overflow-x: auto;
+ tab-size: 4;
hunk ./static/style.css 156
-h2 {
- font-size: var(--size-md);
- font-weight: 600;
- letter-spacing: -0.01em;
- margin: var(--space-6) 0 var(--space-3) 0;
- padding-bottom: var(--space-2);
- border-bottom: 2px solid var(--border-default);
- color: var(--text-primary);
-}
-
-/* === Page Layout === */
+/* ---------- Header: the putty bar ---------- */
+
hunk ./static/style.css 159
- background: var(--bg-header);
- padding: var(--space-3) var(--space-5);
- font-size: var(--size-base);
hunk ./static/style.css 161
- flex-wrap: wrap;
- gap: var(--space-4);
- border-bottom: 3px solid var(--accent);
- position: sticky;
- top: 0;
- z-index: 100;
+ gap: 0.75rem;
+ background: var(--putty);
+ border-bottom: 1px solid var(--rule);
+ padding: 0.375rem var(--gutter);
+ min-height: var(--tap);
hunk ./static/style.css 168
-.page-header a {
- color: var(--text-inverse);
- text-decoration: none;
+/* Logo on the right, as in gitweb; the DOM keeps it first for a11y. */
+.brand {
+ order: 2;
+ margin-left: auto;
+ flex: none;
hunk ./static/style.css 175
- font-weight: 500;
- transition: opacity 0.15s ease;
+ justify-content: center;
+ min-width: var(--tap);
+ min-height: var(--tap);
hunk ./static/style.css 180
-.page-header a:hover {
- text-decoration: none;
-}
-
-/* Brand chip: light background so the original dark-on-light logo
- reads clearly against the dark header. */
-.page-header .brand {
- background: #ffffff;
- padding: 4px 12px;
- border-radius: var(--radius-md);
- box-shadow: var(--shadow-sm);
- opacity: 1;
- flex-shrink: 0;
-}
-
-.page-header .brand:hover {
- background: #f8f6f2;
-}
-
hunk ./static/style.css 181
- height: 32px;
- width: auto;
hunk ./static/style.css 182
+ height: 1.5rem;
+ width: auto;
+ background: var(--logo-chip);
+ border-radius: 3px;
+ padding: 2px;
hunk ./static/style.css 190
- color: var(--text-inverse);
- opacity: 0.85;
- display: inline-flex;
- align-items: center;
- flex-wrap: wrap;
- gap: 0;
- font-size: var(--size-sm);
+ order: 1;
hunk ./static/style.css 192
+ font-weight: bold;
hunk ./static/style.css 197
- opacity: 0.85;
+ display: inline-block;
+ padding: 0.5rem 0.125rem;
hunk ./static/style.css 201
-.breadcrumbs a:hover {
- opacity: 1;
- text-decoration: underline;
- text-underline-offset: 2px;
-}
+/* ---------- Page body ---------- */
hunk ./static/style.css 204
- flex: 1;
- padding: var(--space-6) var(--space-5);
- max-width: 1100px;
+ flex: 1 0 auto;
hunk ./static/style.css 206
- margin: 0 auto;
+ background: var(--paper);
+ padding: 0 0 1.5rem;
hunk ./static/style.css 210
-.page-footer {
- background: var(--bg-footer);
- padding: var(--space-3) var(--space-5);
- font-size: var(--size-xs);
- color: var(--text-muted);
- text-align: center;
- margin-top: auto;
- border-top: 1px solid var(--border-subtle);
+/* Title bars: bone, serif, hairline-ruled. */
+h1,
+h2 {
+ margin: 0;
+ background: var(--bone);
+ border-top: 1px solid var(--rule);
+ border-bottom: 1px solid var(--rule);
+ font-family: var(--font-title);
+ font-weight: normal;
+ letter-spacing: 0.01em;
+ color: var(--ink);
+ overflow-wrap: anywhere;
hunk ./static/style.css 224
-.page-footer a {
- color: var(--text-muted);
- opacity: 0.8;
+h1 {
+ font-size: 1.375rem;
+ line-height: 1.3;
+ padding: 0.625rem var(--gutter);
hunk ./static/style.css 230
-.page-footer a:hover {
- color: var(--text-link);
- opacity: 1;
+h2 {
+ font-size: 1.0625rem;
+ padding: 0.4rem var(--gutter);
+ margin-top: 1.25rem;
hunk ./static/style.css 236
-/* === Repository Navigation === */
+.page-body > p,
+.description,
+.empty,
+.more {
+ margin: 0;
+ padding: 0.625rem var(--gutter);
+}
+
+.description {
+ color: var(--ink-2);
+ font-style: italic;
+ border-bottom: 1px solid var(--rule);
+}
+
+.empty {
+ color: var(--ink-3);
+ font-style: italic;
+}
+
+.more {
+ text-align: right;
+}
+
+/* ---------- Repo nav: pipe-separated text row ---------- */
+
hunk ./static/style.css 262
- margin: var(--space-3) 0 var(--space-5) 0;
hunk ./static/style.css 263
- gap: var(--space-1);
- border-bottom: 2px solid var(--border-default);
- padding-bottom: 0;
hunk ./static/style.css 265
+ background: var(--ivory);
+ border-bottom: 1px solid var(--rule);
+ padding: 0 var(--gutter);
hunk ./static/style.css 271
- display: inline-block;
- padding: var(--space-2) var(--space-4);
- color: var(--text-secondary);
- font-size: var(--size-sm);
- font-weight: 500;
- border-bottom: 2px solid transparent;
- margin-bottom: -2px;
- transition: color 0.15s ease, border-color 0.15s ease;
+ flex: none;
+ display: inline-flex;
+ align-items: center;
+ min-height: var(--tap);
+ padding: 0 0.875rem;
+ color: var(--link);
hunk ./static/style.css 278
- text-decoration: none;
hunk ./static/style.css 280
-.repo-nav a:hover {
- color: var(--text-primary);
- background: var(--nav-hover-bg);
- border-radius: var(--radius-sm) var(--radius-sm) 0 0;
- text-decoration: none;
+.repo-nav a:first-child {
+ padding-left: 0;
hunk ./static/style.css 284
+/* The separators are borders, not generated text, so they never become
+ part of a link's label. */
+.repo-nav a + a {
+ border-left: 1px solid var(--rule);
+}
+
hunk ./static/style.css 291
- color: var(--accent);
- border-bottom-color: var(--accent);
- font-weight: 600;
+ color: var(--ink);
+ font-weight: bold;
+ text-decoration: none;
hunk ./static/style.css 296
-/* === Tables === */
+/* ---------- Tables (stacked ledger rows on narrow screens) ---------- */
+
+table,
+tbody,
+tr,
+td {
+ display: block;
+}
+
hunk ./static/style.css 308
- border-spacing: 0;
hunk ./static/style.css 310
-thead th {
+/* Header row hidden visually but kept for assistive technology. */
+thead {
+ position: absolute;
+ width: 1px;
+ height: 1px;
+ margin: -1px;
+ padding: 0;
+ overflow: hidden;
+ clip: rect(0 0 0 0);
+ clip-path: inset(50%);
+ white-space: nowrap;
+}
+
+tbody tr {
+ padding: 0.5rem var(--gutter);
+ border-bottom: 1px solid var(--rule);
+}
+
+tbody tr:nth-child(even) {
+ background: var(--ivory);
+}
+
+td {
+ padding: 0.125rem 0;
+ overflow-wrap: anywhere;
+}
+
+th {
hunk ./static/style.css 339
- padding: var(--space-2) var(--space-3);
- background: var(--bg-muted);
- border-bottom: 2px solid var(--border-default);
- font-size: var(--size-xs);
- font-weight: 600;
- text-transform: uppercase;
- letter-spacing: 0.05em;
- color: var(--text-secondary);
+ font-weight: bold;
hunk ./static/style.css 342
-tbody tr {
- border-bottom: 1px solid var(--border-subtle);
- transition: background 0.1s ease;
+/* Actions are real tap targets on touch screens. */
+td.actions a,
+td.tree-name a,
+td.repo-name a,
+td.subject a,
+td.tag-name a {
+ display: inline-block;
+ padding: 0.5rem 0;
+ min-height: var(--tap);
hunk ./static/style.css 353
-tbody tr:hover {
- background: var(--table-hover);
+td.actions {
+ color: var(--ink-3);
hunk ./static/style.css 357
-td {
- padding: var(--space-2) var(--space-3);
- vertical-align: top;
+td.actions a {
+ padding: 0.5rem 0.25rem;
hunk ./static/style.css 361
+td.repo-name {
+ font-family: var(--font-title);
+ font-size: 1.0625rem;
+ font-weight: bold;
+}
+
hunk ./static/style.css 368
- text-align: right;
+ color: var(--ink-2);
+}
+
+td.num::after {
+ content: " patches";
+ color: var(--ink-3);
+}
+
+td.date,
+td.hash,
+td.tree-size {
hunk ./static/style.css 380
- font-size: var(--size-sm);
- color: var(--text-secondary);
+ font-size: 0.8125rem;
hunk ./static/style.css 383
-/* === Repository List === */
-.repo-list td.repo-name a {
+td.author {
+ color: var(--ink-2);
+}
+
+td.subject {
hunk ./static/style.css 389
- color: var(--text-link);
hunk ./static/style.css 391
-.repo-list td.actions {
- white-space: nowrap;
- font-size: var(--size-sm);
+td.subject a {
+ color: var(--ink);
hunk ./static/style.css 395
-.repo-list td.actions a {
- color: var(--text-muted);
- padding: var(--space-1) var(--space-2);
- border-radius: var(--radius-sm);
- transition: color 0.15s ease, background 0.15s ease;
+td.subject a:hover {
+ color: var(--link);
hunk ./static/style.css 399
-.repo-list td.actions a:hover {
- color: var(--text-link);
- background: var(--accent-bg);
- text-decoration: none;
+/* gitweb-style age colouring */
+.date.age0 {
+ color: var(--age0);
+ font-weight: bold;
hunk ./static/style.css 405
-/* === Shortlog Table === */
-.shortlog td.date {
- white-space: nowrap;
- color: var(--text-muted);
- font-family: var(--font-mono);
- font-size: var(--size-sm);
- width: 140px;
+.date.age1 {
+ color: var(--age1);
hunk ./static/style.css 409
-.shortlog td.author {
- white-space: nowrap;
- color: var(--text-secondary);
- font-weight: 500;
- width: 180px;
- max-width: 180px;
- overflow: hidden;
- text-overflow: ellipsis;
+.date.age2 {
+ color: var(--age2);
hunk ./static/style.css 413
-.shortlog td.subject a {
- color: var(--text-primary);
- font-weight: 500;
+/* Tag rows carry a yellow marker on the left edge. */
+tr.tag-row {
+ box-shadow: inset 3px 0 0 var(--tag-border);
hunk ./static/style.css 418
-.shortlog td.subject a:hover {
- color: var(--text-link);
+/* Tree rows: icon + name + size on one line. */
+.tree-list tbody tr {
+ display: flex;
+ align-items: center;
+ gap: 0.5rem;
+ padding-top: 0;
+ padding-bottom: 0;
hunk ./static/style.css 427
-.shortlog td.actions {
- white-space: nowrap;
- font-size: var(--size-sm);
- width: 60px;
+.tree-list td {
+ padding: 0;
hunk ./static/style.css 431
-.shortlog td.actions a {
- color: var(--text-muted);
- padding: var(--space-1) var(--space-2);
- border-radius: var(--radius-sm);
+td.tree-icon {
+ flex: none;
+ width: 1.5rem;
+ text-align: center;
hunk ./static/style.css 437
-.shortlog td.actions a:hover {
- color: var(--text-link);
- background: var(--accent-bg);
- text-decoration: none;
+td.tree-name {
+ flex: 1 1 auto;
+ min-width: 0;
hunk ./static/style.css 442
-.shortlog tr.tag-row {
- background: var(--tag-bg);
+td.tree-size {
+ flex: none;
+ color: var(--ink-3);
hunk ./static/style.css 447
-.shortlog tr.tag-row:hover {
- background: var(--tag-bg);
- filter: brightness(0.97);
+tr.tree-dir td.tree-name a {
+ font-weight: bold;
hunk ./static/style.css 451
-/* === Tag Badge === */
+tr.tree-file td.tree-name a {
+ font-weight: normal;
+ color: var(--ink);
+}
+
+tr.tree-file td.tree-name a:hover {
+ color: var(--link);
+}
+
+/* Patch metadata */
+.patch-meta tr {
+ display: flex;
+ flex-wrap: wrap;
+ gap: 0.25rem 0.75rem;
+}
+
+.patch-meta th {
+ display: block;
+ flex: 0 0 4.5rem;
+ color: var(--ink-3);
+ padding: 0.125rem 0;
+}
+
+.patch-meta td {
+ flex: 1 1 12rem;
+ min-width: 0;
+}
+
+.patch-meta td.hash {
+ color: var(--ink-2);
+ word-break: break-all;
+}
+
+/* ---------- Tags ---------- */
+
hunk ./static/style.css 488
+ vertical-align: baseline;
+ padding: 0 0.4rem;
hunk ./static/style.css 491
- color: var(--tag-text);
- font-size: var(--size-xs);
- font-weight: 700;
- padding: 1px 6px;
- border-radius: var(--radius-sm);
hunk ./static/style.css 492
- margin-right: var(--space-1);
- vertical-align: middle;
- letter-spacing: 0.04em;
- text-transform: uppercase;
+ border-radius: 2px;
+ color: var(--tag-text);
+ font-family: var(--font-ui);
+ font-size: 0.6875rem;
+ font-weight: bold;
+ letter-spacing: 0.06em;
+ line-height: 1.5;
hunk ./static/style.css 501
-/* === Tags Table === */
-.tag-list td.tag-name a {
- font-weight: 600;
- color: var(--text-link);
+/* ---------- Clone box ---------- */
+
+.clone-box {
+ display: flex;
+ flex-direction: column;
+ gap: 0.25rem;
+ margin: 0;
+ padding: 0.625rem var(--gutter);
+ background: var(--ivory);
+ border-bottom: 1px solid var(--rule);
hunk ./static/style.css 513
-.tag-list td.date {
+.clone-label {
+ color: var(--ink-3);
+ font-size: 0.75rem;
+ text-transform: uppercase;
+ letter-spacing: 0.08em;
+}
+
+.clone-url {
+ display: block;
+ overflow-x: auto;
+ padding: 0.375rem 0.5rem;
+ background: var(--paper);
+ border: 1px solid var(--rule);
+ border-radius: 2px;
+ user-select: all;
hunk ./static/style.css 529
- color: var(--text-muted);
- font-family: var(--font-mono);
- font-size: var(--size-sm);
- width: 140px;
hunk ./static/style.css 531
-.tag-list td.author {
- color: var(--text-secondary);
- font-weight: 500;
-}
-
-/* === Full Log === */
+/* ---------- Log entries (full log) ---------- */
+
hunk ./static/style.css 534
- margin-bottom: var(--space-4);
- padding: var(--space-4);
- border: 1px solid var(--border-default);
- border-radius: var(--radius-md);
- background: var(--bg-surface);
- box-shadow: var(--shadow-sm);
- transition: box-shadow 0.15s ease;
+ border-bottom: 1px solid var(--rule);
hunk ./static/style.css 537
-.log-entry:hover {
- box-shadow: var(--shadow-md);
-}
-
-.log-entry.tag-entry {
- background: var(--tag-bg);
- border-color: var(--tag-border);
-}
-
hunk ./static/style.css 539
+ flex-wrap: wrap;
+ align-items: baseline;
hunk ./static/style.css 542
- align-items: baseline;
- gap: var(--space-3);
- margin-bottom: var(--space-2);
+ gap: 0.25rem 0.75rem;
+ padding: 0.375rem var(--gutter);
+ background: var(--bone);
+ border-top: 1px solid var(--rule);
hunk ./static/style.css 548
+.log-entry:first-of-type .log-header {
+ border-top: 0;
+}
+
hunk ./static/style.css 553
- font-weight: 600;
- font-size: var(--size-base);
+ font-family: var(--font-title);
+ font-size: 1rem;
+ font-weight: bold;
hunk ./static/style.css 557
+ overflow-wrap: anywhere;
hunk ./static/style.css 561
- color: var(--text-primary);
+ display: inline-block;
+ padding: 0.25rem 0;
+ color: var(--ink);
hunk ./static/style.css 567
- color: var(--text-link);
+ color: var(--link);
hunk ./static/style.css 571
- color: var(--text-muted);
hunk ./static/style.css 572
- font-size: var(--size-sm);
- white-space: nowrap;
- flex-shrink: 0;
+ font-size: 0.8125rem;
+ color: var(--ink-3);
hunk ./static/style.css 577
- font-size: var(--size-sm);
- color: var(--text-secondary);
- margin-bottom: var(--space-2);
+ padding: 0.25rem var(--gutter) 0;
+ color: var(--ink-2);
+ overflow-wrap: anywhere;
hunk ./static/style.css 582
-.log-body {
- margin-top: var(--space-3);
+.log-body,
+.log-summary {
+ padding: 0.375rem var(--gutter);
hunk ./static/style.css 588
- background: var(--bg-muted);
- padding: var(--space-3) var(--space-4);
- border-radius: var(--radius-sm);
- color: var(--text-primary);
hunk ./static/style.css 589
- word-wrap: break-word;
- font-size: var(--size-sm);
+ overflow-wrap: anywhere;
+ font-family: var(--font-ui);
+ font-size: 0.875rem;
hunk ./static/style.css 594
-.log-summary {
- margin-top: var(--space-2);
-}
-
hunk ./static/style.css 595
- color: var(--text-secondary);
- font-size: var(--size-xs);
- white-space: pre-wrap;
- padding: var(--space-2) var(--space-3);
- background: var(--bg-muted);
- border-radius: var(--radius-sm);
+ color: var(--ink-2);
hunk ./static/style.css 598
-/* === Patch Detail === */
-.patch-detail h1 {
- font-size: var(--size-lg);
- margin-bottom: var(--space-4);
- padding-bottom: var(--space-3);
- border-bottom: 2px solid var(--border-default);
+.tag-entry .log-header {
+ background: var(--tag-bg);
+ border-top-color: var(--tag-border);
+ border-bottom: 1px solid var(--tag-border);
hunk ./static/style.css 604
-.patch-meta {
- width: auto;
- margin-bottom: var(--space-5);
- background: var(--bg-surface);
- border: 1px solid var(--border-default);
- border-radius: var(--radius-md);
- overflow: hidden;
+.tag-entry .log-name a,
+.tag-entry .log-date {
+ color: var(--tag-text);
hunk ./static/style.css 609
-.patch-meta th {
- background: var(--bg-muted);
- border: none;
- border-bottom: 1px solid var(--border-subtle);
- text-align: right;
- padding: var(--space-2) var(--space-3);
- font-weight: 600;
- font-size: var(--size-sm);
- color: var(--text-secondary);
- width: 80px;
- text-transform: none;
- letter-spacing: normal;
+/* ---------- Patch detail ---------- */
+
+.patch-log pre,
+.patch-summary pre {
+ padding: 0.5rem var(--gutter);
+ white-space: pre-wrap;
+ overflow-wrap: anywhere;
hunk ./static/style.css 618
-.patch-meta td {
- border: none;
- border-bottom: 1px solid var(--border-subtle);
- padding: var(--space-2) var(--space-3);
- font-size: var(--size-sm);
-}
-
-.patch-meta tr:last-child th,
-.patch-meta tr:last-child td {
- border-bottom: none;
-}
-
-.patch-meta td.hash {
- font-family: var(--font-mono);
- font-size: var(--size-sm);
- color: var(--text-muted);
- word-break: break-all;
-}
-
hunk ./static/style.css 619
- background: var(--bg-muted);
- padding: var(--space-3) var(--space-4);
- border-radius: var(--radius-md);
- white-space: pre-wrap;
- word-wrap: break-word;
- font-size: var(--size-sm);
+ font-family: var(--font-ui);
+ font-size: 0.875rem;
hunk ./static/style.css 624
- background: var(--bg-muted);
- padding: var(--space-3) var(--space-4);
- border-radius: var(--radius-md);
- color: var(--text-secondary);
- white-space: pre-wrap;
- font-size: var(--size-sm);
+ color: var(--ink-2);
hunk ./static/style.css 627
-/* === Diff Viewer === */
-.patch-diff pre.diff {
- background: var(--bg-surface);
- padding: 0;
- border: 1px solid var(--border-default);
- border-radius: var(--radius-md);
- overflow-x: auto;
- white-space: pre;
- font-size: var(--size-sm);
- line-height: 1.55;
+.patch-detail h1 .tag-badge {
+ vertical-align: middle;
hunk ./static/style.css 631
+/* ---------- Diffs ---------- */
+
+pre.diff {
+ padding: 0.25rem var(--gutter);
+ background: var(--paper);
+ border-bottom: 1px solid var(--rule);
+ line-height: 1.45;
+}
+
+/* Each line is a span ending in a newline; make add/del/hunk/file lines
+ full-width bands inside the scrolling <pre>. */
+.diff-add,
+.diff-del,
+.diff-hunk,
+.diff-file {
+ display: inline-block;
+ margin: 0 calc(-1 * var(--gutter));
+ padding: 0 var(--gutter);
+ min-width: calc(100% + 2 * var(--gutter));
+}
+
hunk ./static/style.css 653
- display: block;
- color: var(--diff-add-text);
- background: var(--diff-add-bg);
- padding: 0 var(--space-3);
+ color: var(--add);
+ background: var(--add-bg);
hunk ./static/style.css 658
- display: block;
- color: var(--diff-del-text);
- background: var(--diff-del-bg);
- padding: 0 var(--space-3);
+ color: var(--del);
+ background: var(--del-bg);
hunk ./static/style.css 663
- display: block;
- color: var(--diff-hunk-text);
- background: var(--diff-hunk-bg);
- padding: var(--space-1) var(--space-3);
- font-weight: 600;
- border-top: 1px solid var(--border-default);
- border-bottom: 1px solid var(--border-default);
- margin-top: var(--space-1);
+ color: var(--hunk);
+ background: var(--hunk-bg);
+ font-weight: bold;
hunk ./static/style.css 668
-.diff-hunk:first-child {
- margin-top: 0;
- border-top: none;
- border-radius: var(--radius-md) var(--radius-md) 0 0;
+.diff-file {
+ color: var(--file);
+ background: var(--file-bg);
+ font-weight: bold;
+ border-top: 1px solid var(--rule);
hunk ./static/style.css 675
-/* === Description & Empty States === */
-.description {
- color: var(--text-secondary);
- font-style: italic;
- margin-bottom: var(--space-3);
- padding: var(--space-3) var(--space-4);
- background: var(--accent-subtle);
- border-left: 3px solid var(--accent);
- border-radius: 0 var(--radius-sm) var(--radius-sm) 0;
+.diff-truncated {
+ margin: 0;
+ padding: 0.5rem var(--gutter);
+ background: var(--tag-bg);
+ border-bottom: 1px solid var(--tag-border);
+ color: var(--tag-text);
+ font-weight: bold;
hunk ./static/style.css 684
-.empty {
- color: var(--text-muted);
- font-style: italic;
- padding: var(--space-8) 0;
- text-align: center;
-}
-
-.more {
- margin-top: var(--space-2);
-}
-
-.more a {
- color: var(--text-muted);
- font-size: var(--size-sm);
- font-style: italic;
-}
-
-.more a:hover {
- color: var(--text-link);
-}
-
-/* === Tree View === */
+/* ---------- Tree path and blobs ---------- */
+
hunk ./static/style.css 687
- margin: var(--space-3) 0 var(--space-4) 0;
- font-size: var(--size-sm);
- color: var(--text-secondary);
- padding: var(--space-2) var(--space-3);
- background: var(--bg-muted);
- border-radius: var(--radius-sm);
- overflow-x: auto;
- white-space: nowrap;
+ padding: 0.25rem var(--gutter);
+ background: var(--ivory);
+ border-bottom: 1px solid var(--rule);
+ font-family: var(--font-mono);
+ font-size: 0.8125rem;
+ overflow-wrap: anywhere;
hunk ./static/style.css 696
- color: var(--text-link);
- font-weight: 500;
+ display: inline-block;
+ padding: 0.5rem 0.125rem;
hunk ./static/style.css 700
-.tree-list td.tree-icon {
- width: 28px;
- text-align: center;
- padding: var(--space-2) var(--space-1);
- font-size: var(--size-base);
-}
-
-.tree-list td.tree-name {
- padding: var(--space-2) var(--space-3);
-}
-
-.tree-list td.tree-name a {
- color: var(--text-primary);
- font-weight: 500;
-}
-
-.tree-list td.tree-name a:hover {
- color: var(--text-link);
-}
-
-.tree-list td.tree-size {
- text-align: right;
- color: var(--text-muted);
- font-family: var(--font-mono);
- font-size: var(--size-sm);
- width: 90px;
- white-space: nowrap;
-}
-
-/* === Blob View === */
-.blob-content {
- margin-top: var(--space-4);
-}
-
hunk ./static/style.css 701
- background: var(--bg-surface);
- padding: var(--space-4);
- border: 1px solid var(--border-default);
- border-radius: var(--radius-md);
- overflow-x: auto;
- white-space: pre;
- line-height: var(--line-mono);
- tab-size: 4;
+ padding: 0.5rem var(--gutter);
+ background: var(--paper);
+ border-bottom: 1px solid var(--rule);
+ line-height: 1.5;
hunk ./static/style.css 707
-.blob-content code {
- font-family: var(--font-mono);
- font-size: var(--size-sm);
+/* ---------- Footer: thin putty bar ---------- */
+
+.page-footer {
+ background: var(--putty);
+ border-top: 1px solid var(--rule);
+ color: var(--ink-2);
+ font-size: 0.75rem;
+ padding: 0.5rem var(--gutter);
hunk ./static/style.css 717
-/* === Clone URL Box === */
-.clone-box {
- display: flex;
- align-items: center;
- gap: var(--space-3);
- flex-wrap: wrap;
- margin: var(--space-4) 0 var(--space-6);
- padding: var(--space-3) var(--space-4);
- background: var(--accent-subtle);
- border: 1px solid var(--border-default);
- border-left: 3px solid var(--accent);
- border-radius: var(--radius-md);
+.page-footer p {
+ margin: 0;
hunk ./static/style.css 721
-.clone-label {
- color: var(--text-secondary);
- font-size: var(--size-sm);
- font-weight: 600;
- flex-shrink: 0;
-}
-
-.clone-url {
- font-family: var(--font-mono);
- font-size: var(--size-sm);
- color: var(--text-primary);
- background: var(--bg-surface);
- padding: var(--space-1) var(--space-2);
- border: 1px solid var(--border-subtle);
- border-radius: var(--radius-sm);
- user-select: all;
- word-break: break-all;
- flex: 1;
- min-width: 0;
-}
-
-/* === Mobile Responsiveness === */
-@media (max-width: 768px) {
- .page-header {
- padding: var(--space-2) var(--space-3);
- gap: var(--space-2);
+/* ---------- Medium screens: real tables ---------- */
+
+@media (min-width: 48rem) {
+ :root {
+ --gutter: 1.25rem;
hunk ./static/style.css 728
- .page-header .brand {
- padding: 3px 8px;
- }
-
- .header-logo {
- height: 26px;
- }
-
- .page-body {
- padding: var(--space-4) var(--space-3);
- }
-
- h1 {
- font-size: var(--size-lg);
- }
-
- /* Scrollable tables on mobile */
hunk ./static/style.css 729
- display: block;
- overflow-x: auto;
- -webkit-overflow-scrolling: touch;
- }
-
- thead, tbody, tr {
hunk ./static/style.css 730
- width: 100%;
- table-layout: fixed;
hunk ./static/style.css 733
- display: none;
+ position: static;
+ width: auto;
+ height: auto;
+ margin: 0;
+ overflow: visible;
+ clip: auto;
+ clip-path: none;
+ display: table-header-group;
hunk ./static/style.css 743
- /* Repo list: stack on mobile */
- .repo-list tbody tr {
- display: flex;
- flex-wrap: wrap;
- padding: var(--space-3);
- gap: var(--space-1);
- border-bottom: 1px solid var(--border-default);
+ tbody {
+ display: table-row-group;
hunk ./static/style.css 747
- .repo-list td {
+ tr {
+ display: table-row;
+ }
+
+ td,
+ th {
+ display: table-cell;
+ }
+
+ th {
+ padding: 0.4rem 0.75rem;
+ background: var(--bone);
+ border-bottom: 1px solid var(--rule);
+ color: var(--ink-2);
+ font-size: 0.8125rem;
+ text-transform: uppercase;
+ letter-spacing: 0.06em;
+ }
+
+ tbody tr {
hunk ./static/style.css 768
- border: none;
hunk ./static/style.css 770
- .repo-list td.repo-name {
- width: 100%;
- font-size: var(--size-md);
+ td {
+ padding: 0.125rem 0.75rem;
+ vertical-align: middle;
hunk ./static/style.css 775
- .repo-list td.actions {
- margin-left: auto;
+ th:first-child,
+ td:first-child {
+ padding-left: var(--gutter);
hunk ./static/style.css 780
- /* Shortlog: compact on mobile */
- .shortlog tbody tr {
- display: flex;
- flex-wrap: wrap;
- padding: var(--space-2) var(--space-3);
- gap: var(--space-1);
+ th:last-child,
+ td:last-child {
+ padding-right: var(--gutter);
hunk ./static/style.css 785
- .shortlog td {
- padding: 0;
- border: none;
+ tbody tr:hover {
+ background: var(--bone);
hunk ./static/style.css 789
- .shortlog td.date {
- width: auto;
- order: 2;
+ td.actions a,
+ td.tree-name a,
+ td.repo-name a,
+ td.subject a,
+ td.tag-name a {
+ padding: 0.25rem 0;
+ min-height: 0;
hunk ./static/style.css 798
- .shortlog td.author {
- width: auto;
- max-width: none;
- order: 3;
+ td.actions {
+ white-space: nowrap;
hunk ./static/style.css 802
- .shortlog td.subject {
- width: 100%;
- order: 1;
+ td.num {
+ text-align: right;
hunk ./static/style.css 806
- .shortlog td.actions {
- order: 4;
- margin-left: auto;
+ td.num::after {
+ content: none;
hunk ./static/style.css 810
- /* Log entries: full width */
- .log-header {
- flex-direction: column;
- gap: var(--space-1);
+ td.date {
+ white-space: nowrap;
+ width: 1%;
hunk ./static/style.css 815
- /* Patch meta: stack */
- .patch-meta th,
+ td.author {
+ white-space: nowrap;
+ width: 1%;
+ }
+
+ td.tree-size {
+ text-align: right;
+ white-space: nowrap;
+ width: 1%;
+ }
+
+ td.tree-icon {
+ width: 2rem;
+ }
+
+ .tree-list tbody tr {
+ display: table-row;
+ }
+
+ .tree-list td {
+ padding: 0.125rem 0.75rem;
+ }
+
+ .tree-list td:first-child {
+ padding-left: var(--gutter);
+ text-align: center;
+ }
+
+ tr.tag-row {
+ box-shadow: none;
+ }
+
+ tr.tag-row td:first-child {
+ box-shadow: inset 3px 0 0 var(--tag-border);
+ }
+
+ .patch-meta tr {
+ display: table-row;
+ }
+
+ .patch-meta th {
+ display: table-cell;
+ width: 6rem;
+ padding: 0.2rem var(--gutter);
+ background: transparent;
+ border-bottom: 0;
+ text-transform: none;
+ letter-spacing: normal;
+ font-size: inherit;
+ color: var(--ink-3);
+ }
+
hunk ./static/style.css 868
- display: block;
- width: 100%;
- text-align: left;
+ padding: 0.2rem 0.75rem;
hunk ./static/style.css 871
- .patch-meta th {
- padding-bottom: 0;
- border-bottom: none;
+ .clone-box {
+ flex-direction: row;
+ align-items: center;
+ gap: 0.75rem;
hunk ./static/style.css 877
- /* Repo nav: scroll */
- .repo-nav {
- gap: 0;
+ .clone-url {
+ flex: 1 1 auto;
hunk ./static/style.css 882
- padding: var(--space-2) var(--space-3);
- font-size: var(--size-xs);
+ min-height: 2.25rem;
hunk ./static/style.css 884
+
+ h1 {
+ font-size: 1.5rem;
+ }
hunk ./static/style.css 890
-@media (max-width: 480px) {
- .page-body {
- padding: var(--space-3) var(--space-2);
+/* ---------- Wide screens: the framed page ---------- */
+
+@media (min-width: 64rem) {
+ body {
+ padding: 0.625rem;
hunk ./static/style.css 897
- .blob-content pre,
- .patch-diff pre.diff {
- border-radius: 0;
- margin-left: calc(var(--space-2) * -1);
- margin-right: calc(var(--space-2) * -1);
- padding: var(--space-3);
+ .page-header,
+ .page-body,
+ .page-footer {
+ width: 100%;
+ max-width: 75rem;
+ margin-left: auto;
+ margin-right: auto;
+ border-left: 1px solid var(--putty);
+ border-right: 1px solid var(--putty);
hunk ./static/style.css 907
+
+ .page-header {
+ border-top: 1px solid var(--putty);
+ }
+
+ .page-footer {
+ border-bottom: 1px solid var(--putty);
+ }
hunk ./static/style.css 917
-/* === Print === */
+/* ---------- Motion ---------- */
+
+@media (prefers-reduced-motion: reduce) {
+ *,
+ *::before,
+ *::after {
+ animation: none !important;
+ transition: none !important;
+ scroll-behavior: auto !important;
+ }
+}
+
+/* ---------- Print ---------- */
+
hunk ./static/style.css 932
- .page-header,
- .page-footer,
- .repo-nav {
- display: none;
+ :root {
+ --putty: #fff;
+ --bone: #fff;
+ --ivory: #fff;
+ --paper: #fff;
+ --page: #fff;
+ --ink: #000;
+ --ink-2: #000;
+ --ink-3: #333;
+ --rule: #999;
+ --link: #000;
+ --logo-chip: transparent;
hunk ./static/style.css 946
- .page-body {
+ body {
+ display: block;
hunk ./static/style.css 949
+ font-size: 10pt;
+ }
+
+ .page-header,
+ .page-body,
+ .page-footer {
hunk ./static/style.css 956
+ border: 0;
hunk ./static/style.css 959
- body {
- background: white;
- color: black;
+ .brand,
+ .repo-nav {
+ display: none;
hunk ./static/style.css 965
- color: black;
hunk ./static/style.css 968
- .diff-add { background: #e6ffe6; }
- .diff-del { background: #ffe6e6; }
+ pre,
+ pre.diff {
+ white-space: pre-wrap;
+ overflow: visible;
+ }
+
+ tr,
+ .log-entry {
+ break-inside: avoid;
+ }
addfile ./test/Properties/Darcs.hs
hunk ./test/Properties/Darcs.hs 1
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Properties.Darcs (tests) where
+
+import Test.QuickCheck
+import Control.Exception (AsyncException(..), ErrorCall(..),
+ SomeException, bracket, throwIO, try)
+import Data.List (find, sort)
+import qualified Data.Text as T
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import System.Directory (canonicalizePath, createDirectory,
+ createDirectoryIfMissing,
+ createFileLink, createDirectoryLink,
+ getTemporaryDirectory,
+ removeDirectoryRecursive)
+import System.Exit (ExitCode(..))
+import System.FilePath ((</>))
+
+import DarcsWeb.Types (TreeEntry(..), RepoInfo(..))
+import DarcsWeb.Darcs (getRepoTree, getRepoBlob, listRepos, tryNonAsync,
+ capDiff, maxDiffChars)
+
+-- --------------------------------------------------------------------------
+-- Temporary directory helper (no extra dependency). The root is
+-- canonicalised so the repo jail check compares like with like, exactly
+-- as 'withRepo' hands a canonical path to the Darcs layer.
+-- --------------------------------------------------------------------------
+
+withTempDir :: (FilePath -> IO a) -> IO a
+withTempDir = bracket mk removeDirectoryRecursive
+ where
+ mk = do
+ tmp <- getTemporaryDirectory >>= canonicalizePath
+ t <- getPOSIXTime
+ let go :: Int -> IO FilePath
+ go n = do
+ let d = tmp </> ("darcsweb-test-" ++ show t ++ "-" ++ show n)
+ r <- try (createDirectory d) :: IO (Either SomeException ())
+ case r of
+ Right () -> return d
+ Left e | n < 100 -> go (n + 1)
+ | otherwise -> throwIO e
+ go 0
+
+writeBytes :: FilePath -> Int -> IO ()
+writeBytes p n = writeFile p (replicate n 'x')
+
+-- --------------------------------------------------------------------------
+-- Behaviour 6: a dangling symlink in the working tree must not turn the
+-- tree page into a 500. The listing still succeeds and regular files
+-- keep their size. Pinned variant: symlinks are listed as non-directory
+-- entries with size 0.
+-- --------------------------------------------------------------------------
+
+prop_tree_dangling_symlink :: Property
+prop_tree_dangling_symlink = once $ ioProperty $ withTempDir $ \root -> do
+ let repo = root </> "repo"
+ createDirectoryIfMissing True (repo </> "_darcs")
+ writeBytes (repo </> "normal.txt") 42
+ createFileLink (root </> "does-not-exist") (repo </> "dangling")
+ r <- try (getRepoTree repo "") :: IO (Either SomeException (Maybe [TreeEntry]))
+ return $ case r of
+ Right (Just es) ->
+ let normal = find ((== "normal.txt") . teName) es
+ dangled = find ((== "dangling") . teName) es
+ in counterexample (show es) $
+ fmap teSize normal == Just 42
+ && fmap teIsDir normal == Just False
+ && fmap teSize dangled == Just 0
+ && fmap teIsDir dangled == Just False
+ Right Nothing -> counterexample "getRepoTree returned Nothing" False
+ Left e -> counterexample ("getRepoTree threw: " ++ show e) False
+
+-- --------------------------------------------------------------------------
+-- Behaviour 7: a symlink to a file outside the repository must not leak
+-- the target's size into the listing, and the blob route still refuses
+-- to read it.
+-- --------------------------------------------------------------------------
+
+prop_tree_symlink_outside_no_size :: Property
+prop_tree_symlink_outside_no_size = once $ ioProperty $ withTempDir $ \root -> do
+ let repo = root </> "repo"
+ outside = root </> "outside"
+ createDirectoryIfMissing True (repo </> "_darcs")
+ createDirectoryIfMissing True outside
+ writeBytes (outside </> "secret.txt") 1234
+ writeBytes (repo </> "inside.txt") 7
+ createFileLink (outside </> "secret.txt") (repo </> "leak")
+ mEs <- getRepoTree repo ""
+ blob <- getRepoBlob repo "leak"
+ return $ case mEs of
+ Nothing -> counterexample "getRepoTree returned Nothing" False
+ Just es ->
+ let leak = find ((== "leak") . teName) es
+ inside = find ((== "inside.txt") . teName) es
+ in counterexample (show es) $
+ fmap teSize leak == Just 0
+ && fmap teIsDir leak == Just False
+ && fmap teSize inside == Just 7
+ && blob == Nothing
+
+-- --------------------------------------------------------------------------
+-- Symlink policy (second opinion, finding 3): a symlink whose canonical
+-- target lies inside the repo jail is treated like its target, so
+-- in-tree directory links stay navigable and file links show their real
+-- size. Dangling or outside links keep the no-stat variant above
+-- (non-directory, size 0); this includes a link to an outside directory.
+-- --------------------------------------------------------------------------
+
+prop_tree_symlink_inside_dir_navigable :: Property
+prop_tree_symlink_inside_dir_navigable = once $ ioProperty $ withTempDir $ \root -> do
+ let repo = root </> "repo"
+ createDirectoryIfMissing True (repo </> "_darcs")
+ createDirectoryIfMissing True (repo </> "real" </> "sub")
+ writeBytes (repo </> "real" </> "inner.txt") 5
+ createDirectoryLink (repo </> "real") (repo </> "dlink")
+ mEs <- getRepoTree repo ""
+ mSub <- getRepoTree repo "dlink"
+ return $ case mEs of
+ Nothing -> counterexample "getRepoTree returned Nothing" False
+ Just es ->
+ let dl = find ((== "dlink") . teName) es
+ in counterexample (show es ++ " / " ++ show mSub) $
+ fmap teIsDir dl == Just True
+ && fmap (map teName) mSub == Just ["sub", "inner.txt"]
+
+prop_tree_symlink_inside_file_size :: Property
+prop_tree_symlink_inside_file_size = once $ ioProperty $ withTempDir $ \root -> do
+ let repo = root </> "repo"
+ createDirectoryIfMissing True (repo </> "_darcs")
+ writeBytes (repo </> "target.txt") 321
+ createFileLink (repo </> "target.txt") (repo </> "flink")
+ mEs <- getRepoTree repo ""
+ blob <- getRepoBlob repo "flink"
+ return $ case mEs of
+ Nothing -> counterexample "getRepoTree returned Nothing" False
+ Just es ->
+ let fl = find ((== "flink") . teName) es
+ in counterexample (show es) $
+ fmap teSize fl == Just 321
+ && fmap teIsDir fl == Just False
+ && fmap T.length blob == Just 321
+
+prop_tree_symlink_outside_dir_not_dir :: Property
+prop_tree_symlink_outside_dir_not_dir = once $ ioProperty $ withTempDir $ \root -> do
+ let repo = root </> "repo"
+ outside = root </> "outside"
+ createDirectoryIfMissing True (repo </> "_darcs")
+ createDirectoryIfMissing True (outside </> "private")
+ createDirectoryLink outside (repo </> "odir")
+ mEs <- getRepoTree repo ""
+ mSub <- getRepoTree repo "odir"
+ return $ case mEs of
+ Nothing -> counterexample "getRepoTree returned Nothing" False
+ Just es ->
+ let od = find ((== "odir") . teName) es
+ in counterexample (show es ++ " / " ++ show mSub) $
+ fmap teIsDir od == Just False
+ && fmap teSize od == Just 0
+ && maybe True (const False) mSub
+
+-- Fail-closed for darcs metadata: a working-tree symlink whose canonical
+-- target is @_darcs@ or anything under it is opaque (non-directory, size
+-- 0, not stat'ed), and neither the tree nor the blob route resolves
+-- through it, also not via deeper paths below the link.
+prop_tree_symlink_to_darcs_dir_opaque :: Property
+prop_tree_symlink_to_darcs_dir_opaque = once $ ioProperty $ withTempDir $ \root -> do
+ let repo = root </> "repo"
+ createDirectoryIfMissing True (repo </> "_darcs" </> "prefs")
+ writeBytes (repo </> "_darcs" </> "prefs" </> "somefile") 99
+ createDirectoryLink (repo </> "_darcs") (repo </> "meta")
+ mEs <- getRepoTree repo ""
+ mMeta <- getRepoTree repo "meta"
+ mPrefs <- getRepoTree repo "meta/prefs"
+ blob <- getRepoBlob repo "meta/prefs/somefile"
+ return $ case mEs of
+ Nothing -> counterexample "getRepoTree returned Nothing" False
+ Just es ->
+ let m = find ((== "meta") . teName) es
+ in counterexample (show es ++ " / " ++ show mMeta ++ " / "
+ ++ show mPrefs ++ " / " ++ show blob) $
+ fmap teIsDir m == Just False
+ && fmap teSize m == Just 0
+ && isNothing' mMeta && isNothing' mPrefs && blob == Nothing
+
+prop_tree_symlink_to_darcs_file_opaque :: Property
+prop_tree_symlink_to_darcs_file_opaque = once $ ioProperty $ withTempDir $ \root -> do
+ let repo = root </> "repo"
+ createDirectoryIfMissing True (repo </> "_darcs" </> "prefs")
+ writeBytes (repo </> "_darcs" </> "prefs" </> "somefile") 99
+ createFileLink (repo </> "_darcs" </> "prefs" </> "somefile") (repo </> "pref")
+ mEs <- getRepoTree repo ""
+ blob <- getRepoBlob repo "pref"
+ return $ case mEs of
+ Nothing -> counterexample "getRepoTree returned Nothing" False
+ Just es ->
+ let p = find ((== "pref") . teName) es
+ in counterexample (show es ++ " / " ++ show blob) $
+ fmap teIsDir p == Just False
+ && fmap teSize p == Just 0
+ && blob == Nothing
+
+isNothing' :: Maybe a -> Bool
+isNothing' = maybe True (const False)
+
+-- --------------------------------------------------------------------------
+-- Behaviours 8 and 9: 'tryNonAsync' captures ordinary failures but lets
+-- asynchronous exceptions (Warp timeout, killThread) propagate.
+-- --------------------------------------------------------------------------
+
+prop_tryNonAsync_captures_sync :: Property
+prop_tryNonAsync_captures_sync = once $ ioProperty $ do
+ r1 <- tryNonAsync (throwIO (userError "x") :: IO ())
+ r2 <- tryNonAsync (throwIO (ErrorCall "y") :: IO ())
+ r3 <- tryNonAsync (throwIO (ExitFailure 1) :: IO ())
+ r4 <- tryNonAsync (return (5 :: Int))
+ return $ isLeft r1 && isLeft r2 && isLeft r3 && either (const False) (== 5) r4
+ where
+ isLeft = either (const True) (const False)
+
+prop_tryNonAsync_rethrows_async :: Property
+prop_tryNonAsync_rethrows_async = once $ ioProperty $ do
+ r <- try (tryNonAsync (throwIO ThreadKilled :: IO ()))
+ return $ case r of
+ Left ThreadKilled -> property True
+ Left other -> counterexample ("wrong async: " ++ show other) False
+ Right inner -> counterexample
+ ("swallowed: " ++ either show (const "Right ()") inner) False
+
+prop_tryNonAsync_rethrows_user_interrupt :: Property
+prop_tryNonAsync_rethrows_user_interrupt = once $ ioProperty $ do
+ r <- try (tryNonAsync (throwIO UserInterrupt :: IO ()))
+ return $ case r of
+ Left UserInterrupt -> True
+ _ -> False
+
+-- --------------------------------------------------------------------------
+-- Behaviour 12 (pure part): diff size cap.
+-- --------------------------------------------------------------------------
+
+prop_maxDiffChars_value :: Bool
+prop_maxDiffChars_value = maxDiffChars == 2000000
+
+prop_capDiff_short_unchanged :: Property
+prop_capDiff_short_unchanged =
+ forAll (choose (0, 200)) $ \n ->
+ forAll (arbitrary :: Gen String) $ \s ->
+ length s <= n ==> capDiff n s == (T.pack s, False)
+
+prop_capDiff_exact_boundary :: Property
+prop_capDiff_exact_boundary =
+ forAll (arbitrary :: Gen String) $ \s ->
+ capDiff (length s) s == (T.pack s, False)
+
+prop_capDiff_long_truncated :: Property
+prop_capDiff_long_truncated =
+ forAll (listOf1 arbitrary) $ \s ->
+ forAll (choose (0, length s - 1)) $ \n ->
+ capDiff n s == (T.pack (take n s), True)
+
+-- The cap must bound the work: an unbounded (lazy) rendering is only
+-- consumed up to the limit, so an infinite input still terminates.
+prop_capDiff_lazy :: Property
+prop_capDiff_lazy = once $ within 5000000 $
+ let (t, cut) = capDiff 1000 (cycle "+line\n")
+ in T.length t == 1000 && cut
+
+-- --------------------------------------------------------------------------
+-- Behaviour 17: the index ('listRepos') respects the same jail as
+-- 'withRepo': hidden repos and repos symlinked from outside are not
+-- listed. A plain repo next to them still is (so the test is not
+-- vacuous). The fake repos have no real darcs history; a failed read
+-- must still yield a listing entry with count 0.
+-- --------------------------------------------------------------------------
+
+prop_listRepos_jail :: Property
+prop_listRepos_jail = once $ ioProperty $ withTempDir $ \root -> do
+ let repos = root </> "repos"
+ outside = root </> "outside" </> "extrepo"
+ createDirectoryIfMissing True (repos </> "good" </> "_darcs")
+ createDirectoryIfMissing True (repos </> ".hidden" </> "_darcs")
+ createDirectoryIfMissing True (outside </> "_darcs")
+ createDirectoryLink outside (repos </> "linked")
+ -- Names that 'withRepo' rejects ('isValidRepoName') must not be
+ -- listed either, or the index shows dead links. A valid name with an
+ -- inner dot stays listed, so the filter does not over-reject.
+ mapM_ (\n -> createDirectoryIfMissing True (repos </> n </> "_darcs"))
+ [ "foo..bar", "a\\b", "a\tb", "a\DELb", "my-repo_1.0" ]
+ rs <- listRepos repos
+ let names = sort (map (T.unpack . riName) rs)
+ return $ counterexample (show names) (names == ["good", "my-repo_1.0"])
+
+-- --------------------------------------------------------------------------
+-- Test runner
+-- --------------------------------------------------------------------------
+
+tests :: IO Bool
+tests = fmap and $ sequence
+ [ run "6 tree survives dangling symlink" prop_tree_dangling_symlink
+ , run "7 tree hides outside symlink size" prop_tree_symlink_outside_no_size
+ , run "tree in-repo dir symlink navigable" prop_tree_symlink_inside_dir_navigable
+ , run "tree in-repo file symlink real size" prop_tree_symlink_inside_file_size
+ , run "tree outside dir symlink not a dir" prop_tree_symlink_outside_dir_not_dir
+ , run "tree symlink to _darcs dir opaque" prop_tree_symlink_to_darcs_dir_opaque
+ , run "tree symlink to _darcs file opaque" prop_tree_symlink_to_darcs_file_opaque
+ , run "8 tryNonAsync captures sync errors" prop_tryNonAsync_captures_sync
+ , run "9 tryNonAsync rethrows ThreadKilled" prop_tryNonAsync_rethrows_async
+ , run "9 tryNonAsync rethrows UserInterrupt" prop_tryNonAsync_rethrows_user_interrupt
+ , run "12 maxDiffChars value" (property prop_maxDiffChars_value)
+ , run "12 capDiff short unchanged" prop_capDiff_short_unchanged
+ , run "12 capDiff exact boundary" prop_capDiff_exact_boundary
+ , run "12 capDiff long truncated" prop_capDiff_long_truncated
+ , run "12 capDiff is lazy" prop_capDiff_lazy
+ , run "17 listRepos skips hidden/outside/invalid" prop_listRepos_jail
+ ]
+ where
+ run name prop = do
+ putStr $ " " ++ name ++ ": "
+ r <- quickCheckWithResult stdArgs { maxSuccess = 200 } prop
+ return (isSuccess r)
hunk ./test/Properties/Html.hs 8
+import Data.Char (isAlpha, isSpace)
+import Data.Time (UTCTime(..), addUTCTime, fromGregorian,
+ formatTime, defaultTimeLocale, secondsToDiffTime)
+
hunk ./test/Properties/Html.hs 14
- renderTreeBreadcrumb, renderBlobBreadcrumb)
+ renderTreeBreadcrumb, renderBlobBreadcrumb,
+ renderPage, renderRepoList, renderRepoSummary,
+ renderShortLog, renderFullLog, renderPatchDetail,
+ renderTags, renderTree, renderBlob, render404,
+ render500, ageClass)
+import DarcsWeb.Types (PatchSummary(..), RepoInfo(..), TreeEntry(..))
hunk ./test/Properties/Html.hs 198
+-- Behaviour 13: darcs patch headers are classed. darcs never emits "@@";
+-- its hunk header is "hunk <file> <line>", and file operations are
+-- listed as "addfile", "rmfile", ... at column 0.
+-- --------------------------------------------------------------------------
+
+spanned :: T.Text -> T.Text -> T.Text
+spanned cls l = "<span class=\"" <> cls <> "\">" <> l <> "</span>\n"
+
+prop_highlightDiff_darcs_hunk :: Bool
+prop_highlightDiff_darcs_hunk =
+ highlightDiff "hunk ./f 3" == spanned "diff-hunk" "hunk ./f 3"
+
+prop_highlightDiff_file_ops :: Bool
+prop_highlightDiff_file_ops = all check
+ [ "addfile ./x", "rmfile ./x", "adddir ./d", "rmdir ./d"
+ , "move ./a ./b", "replace ./f [A-Za-z_0-9] old new"
+ , "binary ./img.png", "changepref boringfile" ]
+ where
+ check l = highlightDiff l == spanned "diff-file" l
+
+-- File-op lines are escaped like every other branch.
+prop_highlightDiff_file_op_escaped :: Bool
+prop_highlightDiff_file_op_escaped =
+ highlightDiff "addfile ./<b>&" == spanned "diff-file" "addfile ./<b>&"
+
+-- --------------------------------------------------------------------------
+-- Behaviour 14: precedence and escaping. Content lines that start with
+-- '+' or '-' stay add/del even if the rest looks like a header; the
+-- indented patch description never matches; "@@" still works.
+-- --------------------------------------------------------------------------
+
+prop_highlightDiff_precedence :: Bool
+prop_highlightDiff_precedence = and
+ [ highlightDiff "+hunk x" == spanned "diff-add" "+hunk x"
+ , highlightDiff "-addfile ./x" == spanned "diff-del" "-addfile ./x"
+ , highlightDiff "+move ./a ./b" == spanned "diff-add" "+move ./a ./b"
+ , highlightDiff " hunk x" == " hunk x\n"
+ , highlightDiff " addfile ./x" == " addfile ./x\n"
+ , highlightDiff "@@ -1 +1 @@" == spanned "diff-hunk" "@@ -1 +1 @@"
+ ]
+
+-- Remove the wrapper spans highlightDiff is allowed to add.
+stripDiffSpans :: T.Text -> T.Text
+stripDiffSpans t = case T.breakOn "<span class=\"diff-" t of
+ (pre, rest)
+ | T.null rest -> T.replace "</span>" "" pre
+ | otherwise ->
+ let afterOpen = T.drop 1 (T.dropWhile (/= '>') rest)
+ in T.replace "</span>" "" pre <> stripDiffSpans afterOpen
+
+diffLineGen :: Gen String
+diffLineGen = do
+ prefix <- elements [ "", "+", "-", "@@", "hunk ", "addfile ", "rmfile "
+ , "move ", "binary ", " hunk ", "replace " ]
+ body <- listOf (frequency [(4, elements "<>&\"' "), (3, arbitrary)])
+ return (prefix ++ filter (`notElem` ("\n\r" :: String)) body)
+
+-- Every branch is "optional span + esc(line)": stripping the spans
+-- gives exactly the escaped input, so no raw input markup survives.
+prop_highlightDiff_escapes_all_branches :: Property
+prop_highlightDiff_escapes_all_branches =
+ forAll (listOf diffLineGen) $ \ls ->
+ let input = T.pack (unlines ls)
+ out = highlightDiff input
+ plain = stripDiffSpans out
+ in counterexample (T.unpack out) $
+ plain == T.concat (map (\l -> esc l <> "\n") (T.lines input))
+ && not (T.isInfixOf "<" plain)
+
+-- --------------------------------------------------------------------------
+-- Fixtures for render tests
+-- --------------------------------------------------------------------------
+
+fixedNow :: UTCTime
+fixedNow = UTCTime (fromGregorian 2026 1 15) (secondsToDiffTime (12 * 3600))
+
+-- | darcs date string (YYYYMMDDHHMMSS) for @secs@ seconds before 'fixedNow'.
+agoDate :: Integer -> T.Text
+agoDate secs = T.pack (formatTime defaultTimeLocale "%Y%m%d%H%M%S"
+ (addUTCTime (fromInteger (negate secs)) fixedNow))
+
+hostileText :: Gen T.Text
+hostileText = T.pack <$> listOf (frequency
+ [ (4, elements "<>&\"'= /")
+ , (2, arbitrary) ])
+
+hostileWords :: Gen T.Text
+hostileWords = oneof
+ [ hostileText
+ , elements [ "<script>alert(1)</script>", "\" onload=\"x", "' onclick='y"
+ , "<style>*{}</style>", " style=\"color:red\"", "<img src=x onerror=1>" ] ]
+
+genPatch :: Gen PatchSummary
+genPatch = do
+ n <- hostileWords
+ a <- hostileWords
+ d <- oneof [hostileText, agoDate <$> choose (-7200, 90 * 86400)]
+ l <- hostileWords
+ h <- hostileWords
+ t <- arbitrary
+ tn <- oneof [pure Nothing, Just <$> hostileWords]
+ df <- T.pack . unlines <$> listOf diffLineGen
+ sm <- hostileWords
+ tr <- arbitrary
+ return PatchSummary
+ { psName = n, psAuthor = a, psDate = d, psLog = l, psHash = h
+ , psIsTag = t, psTagName = tn, psDiff = df, psSummary = sm
+ , psDiffTruncated = tr }
+
+genRepoInfo :: Gen RepoInfo
+genRepoInfo = do
+ n <- hostileWords
+ d <- hostileWords
+ c <- oneof [hostileText, agoDate <$> choose (0, 90 * 86400)]
+ k <- choose (0, 1000)
+ return RepoInfo { riName = n, riPath = "/nonexistent", riDescription = d
+ , riLastChange = c, riPatchCount = k }
+
+genTreeEntry :: Gen TreeEntry
+genTreeEntry = TreeEntry <$> hostileWords <*> arbitrary <*> choose (0, 10 ^ (9 :: Int))
+
+basePatch :: PatchSummary
+basePatch = PatchSummary
+ { psName = "p", psAuthor = "A <a@b>", psDate = agoDate 3600, psLog = ""
+ , psHash = "abc", psIsTag = False, psTagName = Nothing
+ , psDiff = "hunk ./f 1\n+x\n", psSummary = "", psDiffTruncated = False }
+
+-- --------------------------------------------------------------------------
+-- Behaviour 11: a fixed, generic 500 page.
+-- --------------------------------------------------------------------------
+
+prop_render500_page :: Bool
+prop_render500_page =
+ T.isPrefixOf "<!DOCTYPE html>" render500
+ && T.isInfixOf "</html>" render500
+ && T.isInfixOf "500" render500
+ && T.isInfixOf "<link rel=\"stylesheet\" href=\"/static/style.css\">" render500
+ && not (T.isInfixOf "Exception" render500)
+
+-- --------------------------------------------------------------------------
+-- Behaviour 12 (render part): a truncated diff shows a visible notice,
+-- an untruncated one does not, and escaping still applies.
+-- --------------------------------------------------------------------------
+
+prop_patch_truncated_notice :: Bool
+prop_patch_truncated_notice =
+ let on = renderPatchDetail fixedNow "r" basePatch { psDiffTruncated = True }
+ off = renderPatchDetail fixedNow "r" basePatch { psDiffTruncated = False }
+ noticeOf t = snd (T.breakOn "class=\"diff-truncated\"" t)
+ in T.isInfixOf "class=\"diff-truncated\"" on
+ && T.isInfixOf "truncated" (T.toLower (T.take 300 (noticeOf on)))
+ && not (T.isInfixOf "diff-truncated" off)
+
+prop_patch_truncated_still_escaped :: Bool
+prop_patch_truncated_still_escaped =
+ let ps = basePatch { psDiff = "+<script>alert(1)</script>\nhunk ./<x> 1\n"
+ , psDiffTruncated = True }
+ out = renderPatchDetail fixedNow "r" ps
+ in not (T.isInfixOf "<script" out)
+ && T.isInfixOf "<script>" out
+ && T.isInfixOf "<span class=\"diff-hunk\">hunk ./<x> 1</span>" out
+
+-- --------------------------------------------------------------------------
+-- Behaviour 15: every page is CSP-safe. No script/style elements, no
+-- inline style or on* event attributes, exactly one stylesheet link to
+-- /static/style.css, same-origin assets only, and a viewport meta tag.
+-- --------------------------------------------------------------------------
+
+-- | All markup tags in the output. Every '<' from user data is escaped
+-- by 'esc', so each remaining '<' starts real markup.
+tagsOf :: T.Text -> [T.Text]
+tagsOf t = case T.breakOn "<" t of
+ (_, rest) | T.null rest -> []
+ | otherwise ->
+ let (tag, after) = T.breakOn ">" (T.drop 1 rest)
+ in tag : tagsOf after
+
+tagName :: T.Text -> T.Text
+tagName = T.toLower . T.takeWhile (\c -> not (isSpace c) && c /= '/') . T.dropWhile (== '/')
+
+-- | Attribute (name, value) pairs of a tag body. Values are quoted with
+-- '"' (the renderer never uses single quotes or bare values).
+attrsOf :: T.Text -> [(T.Text, T.Text)]
+attrsOf tag = go (T.dropWhile (\c -> not (isSpace c)) tag)
+ where
+ go s0 =
+ let s = T.stripStart s0
+ in if T.null s || s == "/" then [] else
+ let (name, r1) = T.span (\c -> not (isSpace c) && c /= '=') s
+ in case T.uncons r1 of
+ Just ('=', r2) -> case T.uncons r2 of
+ Just ('"', r3) ->
+ let (v, r4) = T.breakOn "\"" r3
+ in (T.toLower name, v) : go (T.drop 1 r4)
+ _ -> let (v, r4) = T.break isSpace r2
+ in (T.toLower name, v) : go r4
+ _ -> (T.toLower name, "") : go r1
+
+cspSafe :: T.Text -> Property
+cspSafe out =
+ let tags = filter (\t -> not (T.isPrefixOf "!" t)) (tagsOf out)
+ names = map tagName tags
+ attrs = concatMap attrsOf tags
+ links = [ attrsOf t | t <- tags, tagName t == "link" ]
+ styles = [ a | a <- links, lookup "rel" a == Just "stylesheet" ]
+ assetUrl = [ v | t <- tags, tagName t `elem` ["img", "link", "script"]
+ , (k, v) <- attrsOf t, k `elem` ["src", "href"] ]
+ lower = T.toLower out
+ in counterexample (T.unpack out) $ conjoin
+ [ counterexample "script/style element"
+ (not (T.isInfixOf "<script" lower) && not (T.isInfixOf "<style" lower)
+ && all (`notElem` ["script", "style", "iframe", "object", "embed"]) names)
+ , counterexample "inline style / on* attribute"
+ (all (\(k, _) -> k /= "style" && not (T.isPrefixOf "on" k)
+ && T.all (\c -> isAlpha c || c == '-') k) attrs)
+ , counterexample "stylesheet link"
+ (map (lookup "href") styles == [Just "/static/style.css"])
+ , counterexample "same-origin assets"
+ (all (T.isPrefixOf "/static/") assetUrl)
+ , counterexample "viewport"
+ (T.isInfixOf "<meta name=\"viewport\"" out)
+ , counterexample "doctype" (T.isPrefixOf "<!DOCTYPE html>" out)
+ ]
+
+prop_csp_safe_pages :: Property
+prop_csp_safe_pages = conjoin
+ [ forAll ((,,) <$> hostileWords <*> hostileWords <*> hostileWords) $ \(t, b, x) ->
+ -- renderPage takes trusted breadcrumb HTML; feed it escaped text
+ cspSafe (renderPage t (esc b) [esc x])
+ , forAll ((,) <$> hostileWords <*> listOf genRepoInfo) $ \(t, rs) ->
+ cspSafe (renderRepoList fixedNow t rs)
+ , forAll ((,,,,) <$> hostileWords <*> genRepoInfo <*> hostileWords
+ <*> listOf genPatch <*> listOf genPatch) $ \(n, ri, c, ps, ts) ->
+ cspSafe (renderRepoSummary fixedNow n ri c ps ts)
+ , forAll ((,) <$> hostileWords <*> listOf genPatch) $ \(n, ps) ->
+ cspSafe (renderShortLog fixedNow n ps)
+ , forAll ((,) <$> hostileWords <*> listOf genPatch) $ \(n, ps) ->
+ cspSafe (renderFullLog fixedNow n ps)
+ , forAll ((,) <$> hostileWords <*> genPatch) $ \(n, p) ->
+ cspSafe (renderPatchDetail fixedNow n p)
+ , forAll ((,) <$> hostileWords <*> listOf genPatch) $ \(n, ps) ->
+ cspSafe (renderTags fixedNow n ps)
+ , forAll ((,,) <$> hostileWords <*> hostileWords <*> listOf genTreeEntry) $ \(n, s, es) ->
+ cspSafe (renderTree n s es)
+ , forAll ((,,) <$> hostileWords <*> hostileWords <*> hostileWords) $ \(n, s, c) ->
+ cspSafe (renderBlob n s c)
+ , forAll hostileWords $ \m -> cspSafe (render404 m)
+ , property (cspSafe render500)
+ ]
+
+-- --------------------------------------------------------------------------
+-- Behaviour 16: gitweb-style age classes on date cells.
+-- age0 < 2 hours <= age1 < 2 days <= age2; future and unparseable -> age2.
+-- --------------------------------------------------------------------------
+
+prop_ageClass_buckets :: Bool
+prop_ageClass_buckets = and
+ [ ageClass fixedNow (agoDate 0) == "age0"
+ , ageClass fixedNow (agoDate 3600) == "age0"
+ , ageClass fixedNow (agoDate (2 * 3600 - 1)) == "age0"
+ , ageClass fixedNow (agoDate (2 * 3600)) == "age1"
+ , ageClass fixedNow (agoDate 86400) == "age1"
+ , ageClass fixedNow (agoDate (2 * 86400 - 1)) == "age1"
+ , ageClass fixedNow (agoDate (2 * 86400)) == "age2"
+ , ageClass fixedNow (agoDate (30 * 86400)) == "age2"
+ , ageClass fixedNow (agoDate (-3600)) == "age2"
+ , ageClass fixedNow "garbage" == "age2"
+ , ageClass fixedNow "" == "age2"
+ ]
+
+prop_ageClass_on_date_cells :: Bool
+prop_ageClass_on_date_cells =
+ let shortlog = renderShortLog fixedNow "r" [basePatch { psDate = agoDate 3600 }]
+ tags = renderTags fixedNow "r"
+ [basePatch { psDate = agoDate 86400, psIsTag = True
+ , psTagName = Just "v1" }]
+ repos = renderRepoList fixedNow "t"
+ [RepoInfo "r" "/x" "" (agoDate (30 * 86400)) 1]
+ in T.isInfixOf "<td class=\"date age0\">" shortlog
+ && T.isInfixOf "<td class=\"date age1\">" tags
+ && T.isInfixOf "<td class=\"date age2\">" repos
+
+-- Unparseable dates are still shown verbatim but escaped.
+prop_ageClass_date_text_escaped :: Bool
+prop_ageClass_date_text_escaped =
+ let out = renderShortLog fixedNow "r" [basePatch { psDate = "<b>" }]
+ in T.isInfixOf "<td class=\"date age2\"><b></td>" out
+ && not (T.isInfixOf "<b>" out)
+
+-- --------------------------------------------------------------------------
+-- Adopted design item: tree rows are classed so CSS does not depend on
+-- the emoji icon.
+-- --------------------------------------------------------------------------
+
+prop_tree_row_classes :: Bool
+prop_tree_row_classes =
+ let out = renderTree "r" "" [TreeEntry "d" True 0, TreeEntry "f" False 3]
+ rowOf name = snd (T.breakOnEnd "<tr" (fst (T.breakOn (">" <> name) out)))
+ in T.isInfixOf " class=\"tree-dir\"" (rowOf "d/</a>")
+ && T.isInfixOf " class=\"tree-file\"" (rowOf "f</a>")
+
+-- Tree icons must be the real emoji code points. A Haskell "\xf0\x9f..."
+-- Text literal is four code points (U+00F0 plus three C1 controls), not
+-- the UTF-8 bytes of one emoji, and renders as mojibake. The non-empty
+-- sub-path makes the ".." parent row part of the check.
+prop_tree_icons_are_emoji :: Bool
+prop_tree_icons_are_emoji =
+ let out = renderTree "r" "sub" [TreeEntry "d" True 0, TreeEntry "f" False 3]
+ rows = drop 1 (T.splitOn "<tr" out)
+ dirRows = filter (T.isInfixOf "class=\"tree-dir\"") rows
+ fileRows = filter (T.isInfixOf "class=\"tree-file\"") rows
+ folder = T.singleton '\x1F4C1'
+ page = T.singleton '\x1F4C4'
+ in length dirRows == 2
+ && any (T.isInfixOf ">..</a>") dirRows
+ && all (\r -> T.isInfixOf folder r && not (T.isInfixOf page r)) dirRows
+ && length fileRows == 1
+ && all (\r -> T.isInfixOf page r && not (T.isInfixOf folder r)) fileRows
+ && not (T.any (\c -> c >= '\x80' && c <= '\x9f') out)
+
+-- --------------------------------------------------------------------------
hunk ./test/Properties/Html.hs 547
+ , run "11 render500 generic page" (property prop_render500_page)
+ , run "12 patch truncated notice" (property prop_patch_truncated_notice)
+ , run "12 patch truncated still escaped" (property prop_patch_truncated_still_escaped)
+ , run "13 highlightDiff darcs hunk" (property prop_highlightDiff_darcs_hunk)
+ , run "13 highlightDiff file ops" (property prop_highlightDiff_file_ops)
+ , run "13 highlightDiff file op escaped" (property prop_highlightDiff_file_op_escaped)
+ , run "14 highlightDiff precedence" (property prop_highlightDiff_precedence)
+ , run "14 highlightDiff escapes all branches" prop_highlightDiff_escapes_all_branches
+ , run "15 pages are CSP-safe" prop_csp_safe_pages
+ , run "16 ageClass buckets" (property prop_ageClass_buckets)
+ , run "16 ageClass on date cells" (property prop_ageClass_on_date_cells)
+ , run "16 date text escaped" (property prop_ageClass_date_text_escaped)
+ , run "tree rows carry dir/file classes" (property prop_tree_row_classes)
+ , run "tree icons are real emoji" (property prop_tree_icons_are_emoji)
addfile ./test/Properties/Http.hs
hunk ./test/Properties/Http.hs 1
+{-# LANGUAGE OverloadedStrings #-}
+
+module Properties.Http (tests) where
+
+import Test.QuickCheck
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import Data.Char (isControl)
+import Data.IORef (newIORef, readIORef, writeIORef)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import Network.HTTP.Types (Header, HeaderName, status200, status404)
+import Network.Wai (Application, defaultRequest, responseLBS,
+ responseHeaders)
+import Network.Wai.Internal (ResponseReceived(..))
+
+import DarcsWeb.Http (securityHeaderList, securityHeaders, cspHeader,
+ mimeType, staticCacheControl, isValidRepoName,
+ sanitizeLogLine)
+
+-- --------------------------------------------------------------------------
+-- Behaviour 1: the security header list is exact. Every expected header
+-- appears exactly once, nothing else is sent, and the application does
+-- not emit HSTS (TLS terminates in Caddy, which owns that header).
+-- --------------------------------------------------------------------------
+
+expectedHeaders :: [Header]
+expectedHeaders =
+ [ ("X-Content-Type-Options", "nosniff")
+ , ("X-Frame-Options", "DENY")
+ , ("Referrer-Policy", "strict-origin-when-cross-origin")
+ , ("Permissions-Policy", "camera=(), microphone=(), geolocation=(), payment=()")
+ , ("X-Robots-Tag", "noindex, nofollow")
+ , ("Cross-Origin-Opener-Policy", "same-origin")
+ , ("Cross-Origin-Resource-Policy", "same-origin")
+ , ("Content-Security-Policy", cspHeader)
+ ]
+
+countName :: HeaderName -> [Header] -> Int
+countName n = length . filter ((== n) . fst)
+
+-- Each expected header (name and value) is present exactly once.
+prop_header_list_exact :: Bool
+prop_header_list_exact =
+ all (\h@(n, _) -> countName n securityHeaderList == 1
+ && h `elem` securityHeaderList) expectedHeaders
+ && length securityHeaderList == length expectedHeaders
+
+-- The app must not claim HSTS; it cannot know where TLS terminates.
+prop_header_list_no_hsts :: Bool
+prop_header_list_no_hsts =
+ countName "Strict-Transport-Security" securityHeaderList == 0
+
+-- --------------------------------------------------------------------------
+-- Behaviour 2: the CSP stays exactly as strict as before.
+-- --------------------------------------------------------------------------
+
+prop_csp_exact :: Bool
+prop_csp_exact =
+ cspHeader == "default-src 'none'; style-src 'self'; img-src 'self'; \
+ \frame-ancestors 'none'; base-uri 'none'; form-action 'none'"
+
+prop_csp_strict :: Bool
+prop_csp_strict =
+ not (BS.isInfixOf "unsafe-inline" cspHeader)
+ && not (BS.isInfixOf "unsafe-eval" cspHeader)
+ && not (BS.isInfixOf "script-src" cspHeader)
+ && not (BS.isInfixOf "font-src" cspHeader)
+
+-- --------------------------------------------------------------------------
+-- Behaviour 3: the middleware adds every header to every response,
+-- regardless of status, and keeps the handler's own headers.
+-- --------------------------------------------------------------------------
+
+runMiddleware :: Application -> IO [Header]
+runMiddleware inner = do
+ ref <- newIORef []
+ _ <- securityHeaders inner defaultRequest $ \resp -> do
+ writeIORef ref (responseHeaders resp)
+ return ResponseReceived
+ readIORef ref
+
+stubApp :: Header -> Application
+stubApp own _ respond =
+ respond (responseLBS status200 [own] (BL.fromStrict "ok"))
+
+stub404 :: Application
+stub404 _ respond = respond (responseLBS status404 [] "")
+
+prop_middleware_adds_headers_200 :: Property
+prop_middleware_adds_headers_200 = once $ ioProperty $ do
+ let own = ("Content-Type", "text/html; charset=utf-8")
+ hs <- runMiddleware (stubApp own)
+ return $ all (`elem` hs) expectedHeaders
+ && own `elem` hs
+ && all (\(n, _) -> countName n hs == 1) expectedHeaders
+
+prop_middleware_adds_headers_404 :: Property
+prop_middleware_adds_headers_404 = once $ ioProperty $ do
+ hs <- runMiddleware stub404
+ return $ all (`elem` hs) expectedHeaders
+
+-- --------------------------------------------------------------------------
+-- Behaviour 4: static MIME types and cache policy.
+-- --------------------------------------------------------------------------
+
+prop_mime_css :: Bool
+prop_mime_css = mimeType ".css" == "text/css; charset=utf-8"
+
+prop_mime_png :: Bool
+prop_mime_png = mimeType ".png" == "image/png"
+
+prop_mime_unknown :: Bool
+prop_mime_unknown = and
+ [ mimeType "" == "application/octet-stream"
+ , mimeType ".exe" == "application/octet-stream"
+ , mimeType ".html" == "application/octet-stream"
+ , mimeType "css" == "application/octet-stream"
+ ]
+
+-- The stylesheet URL is unversioned, so it must be revalidatable after
+-- a redesign ships: no 'immutable', but still cacheable.
+prop_static_cache_not_immutable :: Bool
+prop_static_cache_not_immutable =
+ not (TL.isInfixOf "immutable" staticCacheControl)
+ && TL.isInfixOf "max-age=" staticCacheControl
+
+-- --------------------------------------------------------------------------
+-- Behaviour 5: repository name validation.
+-- --------------------------------------------------------------------------
+
+prop_repo_name_rejects :: Bool
+prop_repo_name_rejects = not $ any isValidRepoName
+ [ "", ".", "..", ".x", "a/b", "a\\b", "a..b"
+ , "a\NULb", "a\nb", "a\tb", "a\rb", "\DEL", "a\x85" ]
+
+prop_repo_name_accepts :: Bool
+prop_repo_name_accepts = all isValidRepoName
+ [ "proj", "my-repo_1.0", "projekt-\228", "a b" ]
+
+-- The guard that 'withRepo' used before this change. For every
+-- non-empty name without control characters the new predicate must
+-- agree with it exactly, so no previously reachable repo disappears and
+-- no previously rejected name becomes reachable.
+oldRepoGuardAccepts :: T.Text -> Bool
+oldRepoGuardAccepts name =
+ not (T.any (== '/') name || T.any (== '\\') name
+ || ".." `T.isInfixOf` name || T.isPrefixOf "." name)
+
+prop_repo_name_matches_old_guard :: Property
+prop_repo_name_matches_old_guard =
+ forAll nameGen $ \s ->
+ let t = T.pack s
+ in not (null s) && not (any isControl s) ==>
+ isValidRepoName t == oldRepoGuardAccepts t
+ where
+ nameGen = listOf (frequency [ (4, elements "./\\-_ a\228")
+ , (1, arbitrary) ])
+
+prop_repo_name_rejects_control :: Property
+prop_repo_name_rejects_control =
+ forAll (elements (filter isControl ['\0' .. '\x9f'])) $ \c ->
+ forAll (arbitrary :: Gen String) $ \s ->
+ not (isValidRepoName (T.pack ("r" ++ [c] ++ s)))
+
+-- --------------------------------------------------------------------------
+-- Behaviour 10: log lines are sanitised against log injection.
+-- --------------------------------------------------------------------------
+
+prop_sanitize_log_no_control :: Property
+prop_sanitize_log_no_control =
+ forAll (listOf (frequency [ (3, elements "\n\r\t\NUL\ESC\DEL\x85")
+ , (2, arbitrary) ])) $ \s ->
+ not (any isControl (sanitizeLogLine s))
+
+prop_sanitize_log_printable_unchanged :: Property
+prop_sanitize_log_printable_unchanged =
+ forAll (listOf (arbitrary `suchThat` (not . isControl))) $ \s ->
+ sanitizeLogLine s == s
+
+-- A multi-line exception message must collapse to a single log line.
+prop_sanitize_log_single_line :: Bool
+prop_sanitize_log_single_line =
+ let out = sanitizeLogLine "boom\nFAKE: admin logged in\r\n"
+ in notElem '\n' out && notElem '\r' out
+ && "FAKE: admin logged in" `isSubOf` out
+ where
+ isSubOf needle hay = T.isInfixOf (T.pack needle) (T.pack hay)
+
+-- --------------------------------------------------------------------------
+-- Test runner
+-- --------------------------------------------------------------------------
+
+tests :: IO Bool
+tests = fmap and $ sequence
+ [ run "1 header list exact" (property prop_header_list_exact)
+ , run "1 header list has no HSTS" (property prop_header_list_no_hsts)
+ , run "2 csp unchanged" (property prop_csp_exact)
+ , run "2 csp strict" (property prop_csp_strict)
+ , run "3 middleware headers on 200" prop_middleware_adds_headers_200
+ , run "3 middleware headers on 404" prop_middleware_adds_headers_404
+ , run "4 mime .css" (property prop_mime_css)
+ , run "4 mime .png" (property prop_mime_png)
+ , run "4 mime unknown ��� octet-stream" (property prop_mime_unknown)
+ , run "4 static cache not immutable" (property prop_static_cache_not_immutable)
+ , run "5 repo name rejects" (property prop_repo_name_rejects)
+ , run "5 repo name accepts" (property prop_repo_name_accepts)
+ , run "5 repo name matches old guard" prop_repo_name_matches_old_guard
+ , run "5 repo name rejects control" prop_repo_name_rejects_control
+ , run "10 sanitizeLogLine no control" prop_sanitize_log_no_control
+ , run "10 sanitizeLogLine printable id" prop_sanitize_log_printable_unchanged
+ , run "10 sanitizeLogLine single line" (property prop_sanitize_log_single_line)
+ ]
+ where
+ run name prop = do
+ putStr $ " " ++ name ++ ": "
+ r <- quickCheckWithResult stdArgs { maxSuccess = 200 } prop
+ return (isSuccess r)
hunk ./test/Spec.hs 10
+import qualified Properties.Http as Http
+import qualified Properties.Darcs as Darcs
hunk ./test/Spec.hs 39
- if htmlOk && cspOk && cloneOk && cfgOk
+ putStrLn "\n=== Running QuickCheck properties (HTTP) ==="
+ httpOk <- Http.tests
+
+ putStrLn "\n=== Running QuickCheck properties (Darcs IO) ==="
+ darcsOk <- Darcs.tests
+
+ if htmlOk && cspOk && cloneOk && cfgOk && httpOk && darcsOk
