From cdb0d054c2a7312cc8fc2ccfd2c6485cdad771ba Mon Sep 17 00:00:00 2001 From: hololeap Date: Mon, 29 Nov 2021 19:17:19 -0700 Subject: [PATCH 1/3] Remove dependency on deprecated system-filepath This patch removes `system-filepath` and tries to replace any existing functionality that that package provides. `system-filepath` has been deprecated in favor of `filepath`: https://hackage.haskell.org/package/system-filepath --- happstack-server.cabal | 1 - .../Server/FileServe/BuildingBlocks.hs | 56 ++++++++++++++----- 2 files changed, 43 insertions(+), 14 deletions(-) diff --git a/happstack-server.cabal b/happstack-server.cabal index 5ab0c99..8d2b7ce 100644 --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -84,7 +84,6 @@ Library process, semigroups >= 0.16, sendfile >= 0.7.1 && < 0.8, - system-filepath >= 0.3.1, syb, text >= 0.10 && < 1.3, time, diff --git a/src/Happstack/Server/FileServe/BuildingBlocks.hs b/src/Happstack/Server/FileServe/BuildingBlocks.hs index dc25ff8..0825c6e 100644 --- a/src/Happstack/Server/FileServe/BuildingBlocks.hs +++ b/src/Happstack/Server/FileServe/BuildingBlocks.hs @@ -60,16 +60,18 @@ import Control.Monad.Trans (MonadIO(liftIO)) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import Data.Data (Data, Typeable) -import Data.List (sort) +import Data.Foldable (toList, foldl') +import Data.List (sort, isPrefixOf) import Data.Maybe (fromMaybe) import Data.Map (Map) import qualified Data.Map as Map -import Filesystem.Path.CurrentOS (commonPrefix, encodeString, decodeString, collapse, append) +import Data.Sequence (Seq ((:|>), (:<|)), (|>), (<|)) +import qualified Data.Sequence as Seq import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad) import Happstack.Server.Response (ToMessage(toResponse), ifModifiedSince, forbidden, ok, seeOther) import Happstack.Server.Types (Length(ContentLength), Request(rqPaths, rqUri), Response(SendFile), RsFlags(rsfLength), nullRsFlags, result, resultBS, setHeader) -import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime) -import System.FilePath ((), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, takeExtension, isValid) +import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents, getModificationTime, makeAbsolute) +import System.FilePath ((), addTrailingPathSeparator, hasDrive, isPathSeparator, joinPath, takeExtension, isValid, normalise, splitDirectories, isAbsolute) import System.IO (IOMode(ReadMode), hFileSize, hClose, openBinaryFile, withBinaryFile) import System.Log.Logger (Priority(DEBUG), logM) import Text.Blaze.Html ((!)) @@ -319,7 +321,7 @@ serveFileFrom :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) -> FilePath -- ^ path to the file to serve -> m Response serveFileFrom root mimeFn fp = - maybe no yes $ combineSafe root fp + combineSafe root fp >>= maybe no yes where no = forbidden $ toResponse "Directory traversal forbidden" yes = serveFile mimeFn @@ -383,15 +385,43 @@ fileServe' serveFn mimeFn indexFn localPath = do -- Nothing -- >>> combineSafe "/var/uploads/" "../uploads/home/../etc/passwd" -- Just "/var/uploads/etc/passwd" -combineSafe :: FilePath -> FilePath -> Maybe FilePath -combineSafe root path = - if commonPrefix [root', joined] == root' - then Just $ encodeString joined - else Nothing +combineSafe :: MonadIO m => FilePath -> FilePath -> m (Maybe FilePath) +combineSafe root path = do + root' <- liftIO $ makeAbsolute root + let path' = normalise path + pure $ + case combineReduce root' path' of + Just combined | root' `isPrefixOf` combined -> + Just combined + _ -> + Nothing where - root' = decodeString root - path' = decodeString path - joined = collapse $ append root' path' + -- Combine an absolute path with another path, reducing any @..@ elements + combineReduce :: FilePath -> FilePath -> Maybe FilePath + combineReduce r p + | isAbsolute r = Just $ + let splitP = splitDirectories p + splitR = splitDirectories r + -- Split off the head and re-add it after processing the tail with @go@ + headP :<| tailP = Seq.fromList splitP + headR :<| tailR = Seq.fromList splitR + in joinPath $ toList $ + -- If @p@ is absolute, then process it against the root path, dropping @r@ completely + if isAbsolute p + then headP <| foldl' go Seq.Empty (toList tailP) + else headR <| foldl' go tailR splitP + -- If the root is not absolute, it is unclear how to handle arbitrary @..@ elements in a safe way + | otherwise = Nothing + + -- | Build up a 'Seq' representation of @path@, reducing any @..@ elements + -- This function assumes the 'Seq' is a split absolute path, with the beginning part removed. + -- + -- Note that this functionality has been removed from the filepath package + -- See: + go :: Seq FilePath -> FilePath -> Seq FilePath + go Seq.Empty ".." = Seq.Empty -- Going up beyond the top level just returns the top level + go (s :|> _) ".." = s -- Going up a level pops an element off the right side of the Seq + go s p = s |> p -- Just add an element to the right side of the Seq isSafePath :: [FilePath] -> Bool isSafePath [] = True From cb4c162e31522ed4f01ece0faabb8f96033361b9 Mon Sep 17 00:00:00 2001 From: hololeap Date: Wed, 1 Dec 2021 06:43:52 -0700 Subject: [PATCH 2/3] Add test for combineSafe --- tests/Happstack/Server/Tests.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/tests/Happstack/Server/Tests.hs b/tests/Happstack/Server/Tests.hs index 5dfc093..d58c24a 100644 --- a/tests/Happstack/Server/Tests.hs +++ b/tests/Happstack/Server/Tests.hs @@ -13,7 +13,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import Happstack.Server ( Request(..), Method(..), Response(..), ServerPart, Headers, RqBody(Body), HttpVersion(..) , ToMessage(..), HeaderPair(..), ok, dir, simpleHTTP'', composeFilter, noContentLength, matchMethod) -import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse) +import Happstack.Server.FileServe.BuildingBlocks (sendFileResponse, combineSafe) import Happstack.Server.Cookie import Happstack.Server.Internal.Compression import Happstack.Server.Internal.Cookie @@ -34,6 +34,7 @@ allTests = , matchMethodTest , cookieHeaderOrderTest , pContentDispositionFilename + , combineSafeTest ] cookieParserTest :: Test @@ -247,3 +248,18 @@ pContentDispositionFilename = do let doesNotWorkWithOldParserButWithNew = "form-data; filename=\"file.pdf\"; name=\"file\"" :: String c <- parseContentDisposition doesNotWorkWithOldParserButWithNew assertEqual "parseContentDisposition" c (ContentDisposition "form-data" [("filename","file.pdf"),("name","file")]) + +-- | Make sure 'combineSafe' works correctly +combineSafeTest :: Test +combineSafeTest = + "combineSafeTest" ~: + do r1 <- combineSafe "/var/uploads/" "etc/passwd" + r2 <- combineSafe "/var/uploads/" "/etc/passwd" + r3 <- combineSafe "/var/uploads/" "../../etc/passwd" + r4 <- combineSafe "/var/uploads/" "../uploads/home/../etc/passwd" + r5 <- combineSafe "/var/uploads/" "../../../../var/uploads/etc" + r1 @?= Just "/var/uploads/etc/passwd" + r2 @?= Nothing + r3 @?= Nothing + r4 @?= Just "/var/uploads/etc/passwd" + r5 @?= Just "/var/uploads/etc" From aff4c78b6bc5cb9831b9612a3c1dda0736095f57 Mon Sep 17 00:00:00 2001 From: hololeap Date: Wed, 1 Dec 2021 13:25:40 -0700 Subject: [PATCH 3/3] .gitignore: Add cabal.project.local and hie.yaml `hie.yaml` is generated by [implicit-hie][1], part of the [haskell-language-server][2] project. [1]: https://github.com/Avi-D-coder/implicit-hie#readme [2]: https://github.com/haskell/haskell-language-server --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index ae32c83..e66d158 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,5 @@ dist .env .anvil .ghc.environment.* +cabal.project.local +hie.yaml