diff --git a/src/Simplex/Chat/Files.hs b/src/Simplex/Chat/Files.hs index 0c04b22e28..ca36d2992e 100644 --- a/src/Simplex/Chat/Files.hs +++ b/src/Simplex/Chat/Files.hs @@ -1,15 +1,28 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} -module Simplex.Chat.Files where +module Simplex.Chat.Files + ( SafeFileName, + safeFileName, + uniqueCombine, + getChatTempDirectory, + getDefaultFilesFolder, + ) +where import Simplex.Chat.Controller import Simplex.Messaging.Util (ifM) -import System.FilePath (combine, splitExtensions) +import System.FilePath (combine, makeValid, splitExtensions, takeFileName) import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getHomeDirectory, getTemporaryDirectory) -uniqueCombine :: FilePath -> String -> IO FilePath -uniqueCombine fPath fName = tryCombine (0 :: Int) +-- | A file name with directory components removed, so combining it with a folder cannot escape that folder. +newtype SafeFileName = SafeFileName String + +safeFileName :: String -> SafeFileName +safeFileName = SafeFileName . makeValid . takeFileName + +uniqueCombine :: FilePath -> SafeFileName -> IO FilePath +uniqueCombine fPath (SafeFileName fName) = tryCombine (0 :: Int) where tryCombine n = let (name, ext) = splitExtensions fName diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index b8ee83afa4..f985358a32 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1135,7 +1135,7 @@ processChatCommand cxt nm = \case (doesFileExist fsFromPath) ( do newFileName <- liftIO $ maybe (pure fileName) (generateNewFileName fileName) $ mediaFilePrefix mc - fsNewPath <- liftIO $ filesFolder `uniqueCombine` newFileName + fsNewPath <- liftIO $ filesFolder `uniqueCombine` safeFileName newFileName liftIO $ B.writeFile fsNewPath "" -- create empty file encrypt <- chatReadVar encryptLocalFiles cfArgs <- if encrypt then Just <$> (atomically . CF.randomArgs =<< asks random) else pure Nothing diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index ca6440d155..3849a69ce2 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -852,10 +852,10 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of chatReadVar filesFolder >>= \case Nothing -> do defaultFolder <- lift getDefaultFilesFolder - fPath <- liftIO $ defaultFolder `uniqueCombine` fn + fPath <- liftIO $ defaultFolder `uniqueCombine` safeFileName fn createEmptyFile fPath $> fPath Just filesFolder -> do - fPath <- liftIO $ filesFolder `uniqueCombine` fn + fPath <- liftIO $ filesFolder `uniqueCombine` safeFileName fn createEmptyFile fPath pure $ takeFileName fPath Just fPath -> @@ -869,7 +869,7 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of where createInPassedDirectory :: FilePath -> CM FilePath createInPassedDirectory fPathDir = do - fPath <- liftIO $ fPathDir `uniqueCombine` fn + fPath <- liftIO $ fPathDir `uniqueCombine` safeFileName fn createEmptyFile fPath $> fPath createEmptyFile :: FilePath -> CM () createEmptyFile fPath = emptyFile `catchThrow` (ChatError . CEFileWrite fPath . show) @@ -1914,7 +1914,7 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus, cryptoArgs, fileInvitati when final $ do lift $ closeFileHandle fileId rcvFiles forM_ cryptoArgs $ \cfArgs -> do - tmpFile <- lift getChatTempDirectory >>= liftIO . (`uniqueCombine` fileName) + tmpFile <- lift getChatTempDirectory >>= liftIO . (`uniqueCombine` safeFileName fileName) tryAllErrors (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case Right () -> do removeFile fsFilePath `catchAllErrors` \_ -> pure () diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index 39405bd1ba..ae44132093 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -65,10 +65,10 @@ import Simplex.Messaging.Util import Simplex.RemoteControl.Client import Simplex.RemoteControl.Invitation (RCInvitation (..), RCSignedInvitation (..), RCVerifiedInvitation (..), verifySignedInvitation) import Simplex.RemoteControl.Types -import System.FilePath (takeFileName, ()) +import System.FilePath (takeDirectory, takeFileName, ()) import UnliftIO import UnliftIO.Concurrent (forkIO) -import UnliftIO.Directory (copyFile, createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive, renameFile) +import UnliftIO.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive, renameFile) remoteFilesFolder :: String remoteFilesFolder = "simplex_v1_files" @@ -361,7 +361,7 @@ storeRemoteFile rhId encrypted_ localPath = do encryptLocalFile = do tmpDir <- lift getChatTempDirectory createDirectoryIfMissing True tmpDir - tmpFile <- liftIO $ tmpDir `uniqueCombine` takeFileName localPath + tmpFile <- liftIO $ tmpDir `uniqueCombine` safeFileName localPath cfArgs <- atomically . CF.randomArgs =<< asks random liftError (ChatError . CEFileWrite tmpFile) $ encryptFile localPath tmpFile cfArgs pure $ CryptoFile tmpFile $ Just cfArgs @@ -574,10 +574,21 @@ handleStoreFile rfKN fileName fileSize fileDigest getChunk = Nothing -> storeFileTo =<< getDefaultFilesFolder storeFileTo :: FilePath -> CM' (Either RemoteProtocolError FilePath) storeFileTo dir = liftIO . tryAllErrors' $ do - filePath <- liftIO $ dir `uniqueCombine` fileName + safeName <- either throwError pure $ remoteFileName fileName + filePath <- liftIO $ dir `uniqueCombine` safeName + -- unreachable while safeName has no directory components - guards against a future change to either + inDir <- liftIO $ (==) <$> canonicalizePath dir <*> canonicalizePath (takeDirectory filePath) + unless inDir $ throwError $ RPEInvalidBody "file path outside of files folder" receiveEncryptedFile rfKN getChunk fileSize fileDigest filePath pure filePath +-- The controller only ever sends a bare file name (see storeRemoteFile), so a path is a protocol violation. +remoteFileName :: FilePath -> Either RemoteProtocolError SafeFileName +remoteFileName fName + | fName /= takeFileName fName || fName `elem` (["", ".", ".."] :: [FilePath]) = + Left $ RPEInvalidBody "invalid file name" + | otherwise = Right $ safeFileName fName + handleGetFile :: User -> RemoteFile -> Respond -> CM () handleGetFile User {userId} RemoteFile {userId = commandUserId, fileId, sent, fileSource = cf'@CryptoFile {filePath}} reply = do logDebug $ "GetFile: " <> tshow filePath diff --git a/tests/RemoteTests.hs b/tests/RemoteTests.hs index e96d531805..2b62dfdf28 100644 --- a/tests/RemoteTests.hs +++ b/tests/RemoteTests.hs @@ -14,13 +14,14 @@ import Control.Monad import qualified Data.Aeson as J import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Either (isLeft, isRight) import Data.List (find, isPrefixOf) import qualified Data.Map.Strict as M import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), versionNumber) import Simplex.Chat.Library.Commands (parseChatCommand) import qualified Simplex.Chat.Controller as Controller import Simplex.Chat.Mobile.File -import Simplex.Chat.Remote (remoteFilesFolder) +import Simplex.Chat.Remote (remoteFileName, remoteFilesFolder) import Simplex.Chat.Remote.Types import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Encoding.String (strEncode) @@ -40,6 +41,13 @@ remoteTests = describe "Remote" $ do `shouldSatisfy` \case Right (StartRemoteHost Nothing (Just (RCCtrlAddress _ "Ethernet 2")) (Just 12345)) -> True _ -> False + describe "stored file name" $ do + it "rejects names with directory components" $ \_ -> + filter (isRight . remoteFileName) ["../x", "../../etc/passwd", "/etc/cron.d/x", "a/b", "", ".", ".."] + `shouldBe` [] + it "accepts bare file names" $ \_ -> + filter (isLeft . remoteFileName) ["test.pdf", "test_1.pdf", ".hidden", "a b.tar.gz"] + `shouldBe` [] xdescribe "No compression" $ aroundWith (. ((False, False),)) runRemoteTests xdescribe "Mobile offers compression" $ aroundWith (. ((True, False),)) runRemoteTests xdescribe "Desktop offers compression" $ aroundWith (. ((False, True),)) runRemoteTests