Hardening the path evalation.

Diff

patch 39e063d43d20885f9e980a183480091eb52a43c7
Author: fritjof@alokat.org
Date:   Wed Mar 11 20:22:45 UTC 2026
  * Hardening the path evalation.
  
  So no one can access file, he is not allowed to.
hunk ./src/DarcsWeb/Darcs.hs 22
-                                   getFileSize)
+                                   getFileSize, canonicalizePath)
hunk ./src/DarcsWeb/Darcs.hs 151
+-- | Maximum blob size to serve (10 MiB)
+maxBlobSize :: Integer
+maxBlobSize = 10 * 1024 * 1024
+
+-- | Validate that a resolved path stays inside the jail directory.
+--   Canonicalizes the path to resolve symlinks before checking.
+jailCheck :: FilePath -> FilePath -> IO Bool
+jailCheck jail path = do
+    canonical <- canonicalizePath path
+    let jailSlash = if null jail then "/"
+                    else if last jail == '/' then jail else jail ++ "/"
+    return (jailSlash `isPrefixOf` canonical || canonical == init jailSlash)
+
+-- | Check whether a subpath is safe (no hidden/internal segments).
+isSafeSubPath :: FilePath -> Bool
+isSafeSubPath sub =
+    let segments = filter (not . null) $ splitPath sub
+    in not (null segments)
+       && all safeSegment segments
+  where
+    safeSegment s =
+      let name = filter (/= '/') s
+      in not (null name)
+         && name /= ".."
+         && name /= "."
+         && name /= "_darcs"
+         && name /= ".git"
+         && head name /= '.'
+
+-- | Split a file path on '/' separators.
+splitPath :: FilePath -> [String]
+splitPath [] = []
+splitPath s  = let (seg, rest) = break (== '/') s
+               in seg : case rest of
+                          []     -> []
+                          (_:xs) -> splitPath xs
+
hunk ./src/DarcsWeb/Darcs.hs 190
---   is not a directory or doesn't exist.
+--   is not a directory, doesn't exist, or escapes the repo jail.
hunk ./src/DarcsWeb/Darcs.hs 198
-        entries <- listDirectory fullDir
-        let visible = filter (\e -> e /= "_darcs" && not ("." `isPrefixOf` e)) entries
-        items <- mapM (mkEntry fullDir) (sortBy compare visible)
-        -- Sort: directories first, then files, alphabetically within each group
-        let (dirs, files) = partition teIsDir items
-        return (Just (dirs ++ files))
+        -- Verify the resolved path stays inside the repo
+        safe <- jailCheck repoPath fullDir
+        if not safe
+          then return Nothing
+          else do
+            entries <- listDirectory fullDir
+            let visible = filter (\e -> e /= "_darcs" && not ("." `isPrefixOf` e)
+                                     && e /= ".git") entries
+            items <- mapM (mkEntry fullDir) (sortBy compare visible)
+            let (dirs, files) = partition teIsDir items
+            return (Just (dirs ++ files))
hunk ./src/DarcsWeb/Darcs.hs 222
---   Returns Nothing if the file doesn't exist or is a directory.
+--   Returns Nothing if the file doesn't exist, is a directory, escapes
+--   the repo jail, or exceeds the size limit.
hunk ./src/DarcsWeb/Darcs.hs 226
-    let fullPath = repoPath </> subPath
-    exists <- doesFileExist fullPath
-    if not exists
+    -- Reject unsafe subpaths (hidden files, _darcs, etc.)
+    if not (isSafeSubPath subPath)
hunk ./src/DarcsWeb/Darcs.hs 230
-        txt <- T.pack <$> Prelude.readFile fullPath
-        return (Just txt)
+        let fullPath = repoPath </> subPath
+        exists <- doesFileExist fullPath
+        if not exists
+          then return Nothing
+          else do
+            -- Verify the resolved path stays inside the repo
+            safe <- jailCheck repoPath fullPath
+            if not safe
+              then return Nothing
+              else do
+                size <- getFileSize fullPath
+                if size > maxBlobSize
+                  then return Nothing
+                  else do
+                    txt <- T.pack <$> Prelude.readFile fullPath
+                    return (Just txt)
hunk ./src/Main.hs 258
-                html $ TL.fromStrict $ render404 "Directory not found."
+                html $ TL.fromStrict $ render404 "Not found."
hunk ./src/Main.hs 268
-            -- Reject paths with ".." to prevent directory traversal
-            if ".." `T.isInfixOf` subPath
-              then do
-                status status403
-                html $ TL.fromStrict $ render404 "Access denied."
-              else do
-                mContent <- liftIO $ getRepoBlob repoPath sub
-                case mContent of
-                  Nothing -> do
-                    status status404
-                    html $ TL.fromStrict $ render404 "File not found."
-                  Just content ->
-                    html $ TL.fromStrict $ renderBlob name subPath content
+            mContent <- liftIO $ getRepoBlob repoPath sub
+            case mContent of
+              Nothing -> do
+                status status404
+                html $ TL.fromStrict $ render404 "Not found."
+              Just content ->
+                html $ TL.fromStrict $ renderBlob name subPath content
hunk ./src/Main.hs 314
-        -- Canonicalize to resolve symlinks and verify jail
-        exists <- liftIO $ doesFileExist candidate
-        if not exists
+        -- Canonicalize first, then check existence on the canonical path
+        -- to avoid TOCTOU race conditions with symlinks.
+        canonical <- liftIO $ canonicalizePath candidate
+        let jailDir = addTrailingSlash (cfgStaticDir cfg)
+        if not (jailDir `isPrefixOf` canonical)
hunk ./src/Main.hs 323
-            canonical <- liftIO $ canonicalizePath candidate
-            let jailDir = addTrailingSlash (cfgStaticDir cfg)
-            if jailDir `isPrefixOf` canonical
+            exists <- liftIO $ doesFileExist canonical
+            if not exists
hunk ./src/Main.hs 326
+                status status404
+                html $ TL.fromStrict $ render404 "Not found."
+              else do
hunk ./src/Main.hs 331
-              else do
-                status status403
-                html $ TL.fromStrict $ render404 "Access denied."
hunk ./src/Main.hs 347
-            html $ TL.fromStrict $ render404 ("Repository not found: " <> name)
+            html $ TL.fromStrict $ render404 "Repository not found."
hunk ./src/Main.hs 367
+