core: prevent remote controller from writing files outside files folder

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

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

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 ()

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

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