From 8c8a984c1ca6149127751e222862c78b2d70c68e Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Fri, 24 Feb 2023 13:40:26 +0000 Subject: [PATCH] xftp: add basic auth (#653) --- src/Simplex/FileTransfer/Client.hs | 8 ++-- src/Simplex/FileTransfer/Client/Main.hs | 14 +++--- src/Simplex/FileTransfer/Protocol.hs | 9 ++-- src/Simplex/FileTransfer/Server.hs | 58 +++++++++++++++---------- src/Simplex/FileTransfer/Server/Env.hs | 2 +- src/Simplex/Messaging/Protocol.hs | 5 ++- tests/XFTPServerTests.hs | 47 +++++++++++++++----- 7 files changed, 94 insertions(+), 49 deletions(-) diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index 27e0cdd70..cac7e68bc 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -33,7 +33,8 @@ import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Protocol - ( Protocol (..), + ( BasicAuth, + Protocol (..), ProtocolServer (..), RecipientId, SenderId, @@ -128,9 +129,10 @@ createXFTPChunk :: C.APrivateSignKey -> FileInfo -> NonEmpty C.APublicVerifyKey -> + Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) -createXFTPChunk c spKey file rsps = - sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case +createXFTPChunk c spKey file rsps auth_ = + sendXFTPCommand c spKey "" (FNEW file rsps auth_) Nothing >>= \case (FRSndIds sId rIds, body) -> noFile body (sId, rIds) (r, _) -> throwError . PCEUnexpectedResponse $ bshow r diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 63939c296..e8d3cafcf 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -37,7 +37,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Protocol (SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer) +import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer, XFTPServerWithAuth) import Simplex.Messaging.Server.CLI (getCliCommand') import Simplex.Messaging.Util (ifM, whenM) import System.Exit (exitFailure) @@ -79,7 +79,7 @@ data SendOptions = SendOptions { filePath :: FilePath, outputDir :: Maybe FilePath, numRecipients :: Int, - xftpServers :: [XFTPServer], + xftpServers :: [XFTPServerWithAuth], retryCount :: Int, tempPath :: Maybe FilePath } @@ -113,7 +113,7 @@ data RandomFileOptions = RandomFileOptions defaultRetryCount :: Int defaultRetryCount = 3 -defaultXFTPServers :: NonEmpty XFTPServer +defaultXFTPServers :: NonEmpty XFTPServerWithAuth defaultXFTPServers = L.fromList ["xftp://vr0bXzm4iKkLvleRMxLznTS-lHjXEyXunxn_7VJckk4=@localhost:443"] cliCommandP :: Parser CliCommand @@ -275,14 +275,14 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC -- TODO unshuffle chunks pure $ map snd sentChunks where - uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServer -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk) + uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServerWithAuth -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk) uploadFileChunk a gen srvs (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519) chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec - xftpServer <- liftIO $ getXFTPServer gen srvs + ProtoServerWithAuth xftpServer auth <- liftIO $ getXFTPServer gen srvs c <- withRetry retryCount $ getXFTPServerClient a xftpServer - (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo $ L.map fst rKeys + (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo (L.map fst rKeys) auth withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys replicas = [SentFileChunkReplica {server = xftpServer, recipients}] @@ -293,7 +293,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC hSeek h AbsoluteSeek $ fromIntegral chunkOffset digest <- LC.sha512Hash <$> LB.hGet h (fromIntegral chunkSize) pure FileInfo {sndKey, size = fromIntegral chunkSize, digest} - getXFTPServer :: TVar StdGen -> NonEmpty XFTPServer -> IO XFTPServer + getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth getXFTPServer gen = \case srv :| [] -> pure srv servers -> do diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 21e5e1cbe..954b3e81b 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -31,7 +31,8 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (ntfClientHandshake) import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol - ( CommandError (..), + ( BasicAuth, + CommandError (..), Protocol (..), ProtocolEncoding (..), ProtocolErrorType (..), @@ -157,7 +158,7 @@ instance Protocol XFTPErrorType FileResponse where _ -> Nothing data FileCommand (p :: FileParty) where - FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand FPSender + FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FPSender FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FPSender FPUT :: FileCommand FPSender FDEL :: FileCommand FPSender @@ -183,7 +184,7 @@ type XFTPFileId = ByteString instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where type Tag (FileCommand p) = FileCommandTag p encodeProtocol _v = \case - FNEW file rKeys -> e (FNEW_, ' ', file, rKeys) + FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_) FADD rKeys -> e (FADD_, ' ', rKeys) FPUT -> e FPUT_ FDEL -> e FDEL_ @@ -220,7 +221,7 @@ instance ProtocolEncoding XFTPErrorType FileCmd where protocolP _v = \case FCT SSender tag -> FileCmd SSender <$> case tag of - FNEW_ -> FNEW <$> _smpP <*> smpP + FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP FADD_ -> FADD <$> _smpP FPUT_ -> pure FPUT FDEL_ -> pure FDEL diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 38955fc4b..027493360 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -24,6 +24,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import qualified Data.Text as T @@ -42,7 +43,7 @@ import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RecipientId) +import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, RecipientId) import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature) import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.Stats @@ -196,7 +197,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult verifyXFTPTransmission sig_ signed fId cmd = case cmd of - FileCmd SSender (FNEW file rcps) -> pure $ XFTPReqNew file rcps `verifyWith` sndKey file + FileCmd SSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file FileCmd SRecipient PING -> pure $ VRVerified XFTPReqPing FileCmd party _ -> verifyCmd party where @@ -212,34 +213,45 @@ verifyXFTPTransmission sig_ signed fId cmd = processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile) processXFTPRequest HTTP2Body {bodyPart} = \case - XFTPReqNew file rcps -> do - st <- asks store - -- TODO validate body empty - -- TODO retry on duplicate IDs? - sId <- getFileId - rIds <- mapM (const getFileId) rcps - let rIdsKeys = L.zipWith FileRecipient rIds rcps - ts <- liftIO getSystemTime - withFileLog $ \sl -> do - logAddFile sl sId file ts - logAddRecipients sl sId rIdsKeys - r <- runExceptT $ do - ExceptT $ atomically $ addFile st sId file ts - forM rIdsKeys $ \rcp -> - ExceptT $ atomically $ addRecipient st sId rcp - noFile $ either FRErr (const $ FRSndIds sId rIds) r + XFTPReqNew file rcps auth -> + noFile + =<< ifM + allowNew + (createFile file rcps) + (pure $ FRErr AUTH) + where + allowNew = do + XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config + pure $ allowNewFiles && maybe True ((== auth) . Just) newFileBasicAuth XFTPReqCmd fId fr (FileCmd _ cmd) -> case cmd of FADD _rcps -> noFile FROk - FPUT -> (,Nothing) <$> receiveServerFile fr - FDEL -> (,Nothing) <$> deleteServerFile fr + FPUT -> noFile =<< receiveServerFile fr + FDEL -> noFile =<< deleteServerFile fr FGET rDhKey -> sendServerFile fr rDhKey - FACK -> (,Nothing) <$> ackFileReception fId fr - -- it should never get to the options below, they are passed in other constructors of XFTPRequest - FNEW _ _ -> noFile $ FRErr INTERNAL + FACK -> noFile =<< ackFileReception fId fr + -- it should never get to the commands below, they are passed in other constructors of XFTPRequest + FNEW {} -> noFile $ FRErr INTERNAL PING -> noFile FRPong XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) + createFile :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse + createFile file rcps = do + st <- asks store + -- TODO validate body empty + -- TODO retry on duplicate IDs? + sId <- getFileId + rIds <- mapM (const getFileId) rcps + let rIdsKeys = L.zipWith FileRecipient rIds rcps + ts <- liftIO getSystemTime + withFileLog $ \sl -> do + logAddFile sl sId file ts + logAddRecipients sl sId rIdsKeys + r <- runExceptT $ do + ExceptT $ atomically $ addFile st sId file ts + forM rIdsKeys $ \rcp -> + ExceptT $ atomically $ addRecipient st sId rcp + pure $ either FRErr (const $ FRSndIds sId rIds) r receiveServerFile :: FileRec -> M FileResponse receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of -- TODO do not allow repeated file upload diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index e52f69965..67ce8e08b 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -87,6 +87,6 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi pure XFTPEnv {config, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} data XFTPRequest - = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) + = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 998c1c66a..94c5e28fe 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -76,6 +76,7 @@ module Simplex.Messaging.Protocol pattern NtfServer, XFTPServer, pattern XFTPServer, + XFTPServerWithAuth, ProtoServerWithAuth (..), BasicAuth (..), SrvLoc (..), @@ -167,7 +168,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..)) -import Simplex.Messaging.Util (bshow, (<$?>), eitherToMaybe) +import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>)) import Simplex.Messaging.Version import Test.QuickCheck (Arbitrary (..)) @@ -632,6 +633,8 @@ pattern XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash {-# COMPLETE XFTPServer #-} +type XFTPServerWithAuth = ProtoServerWithAuth 'PXFTP + sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv' {-# INLINE sameSrvAddr' #-} diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 7d8129802..ca9d9d9bf 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -25,7 +25,7 @@ import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import Simplex.Messaging.Client (ProtocolClientError (..)) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC -import Simplex.Messaging.Protocol (SenderId) +import Simplex.Messaging.Protocol (BasicAuth, SenderId) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile) import System.FilePath (()) @@ -47,6 +47,13 @@ xftpServerTests = it "should expire chunks after set interval" testFileChunkExpiration it "should not allow uploading chunks after specified storage quota" testFileStorageQuota it "should store file records to log and restore them after server restart" testFileLog + describe "XFTP basic auth" $ do + -- allow FNEW | server auth | clnt auth | success + it "prohibited without basic auth" $ testFileBasicAuth True (Just "pwd") Nothing False + it "prohibited when auth is incorrect" $ testFileBasicAuth True (Just "pwd") (Just "wrong") False + it "prohibited when FNEW disabled" $ testFileBasicAuth False (Just "pwd") (Just "pwd") False + it "allowed with correct basic auth" $ testFileBasicAuth True (Just "pwd") (Just "pwd") True + it "allowed with auth on server without auth" $ testFileBasicAuth True Nothing (Just "any") True chSize :: Num n => n chSize = 128 * 1024 @@ -77,9 +84,9 @@ runTestFileChunkDelivery s r = do digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] + (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing uploadXFTPChunk s spKey sId chunkSpec - (sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey] + (sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey] Nothing uploadXFTPChunk s spKey sId' chunkSpec `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST)) liftIO $ readChunk sId `shouldReturn` bytes @@ -102,7 +109,7 @@ runTestFileChunkDelete s r = do digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] + (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing uploadXFTPChunk s spKey sId chunkSpec downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest @@ -130,7 +137,7 @@ runTestFileChunkAck s r = do digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] + (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing uploadXFTPChunk s spKey sId chunkSpec downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest @@ -151,7 +158,7 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] + (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing uploadXFTPChunk c spKey sId chunkSpec downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest @@ -177,14 +184,14 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J download rId = do downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes - (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] + (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing uploadXFTPChunk c spKey sId1 chunkSpec download rId1 - (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] + (sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing uploadXFTPChunk c spKey sId2 chunkSpec download rId2 - (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] + (sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing uploadXFTPChunk c spKey sId3 chunkSpec `catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA)) @@ -207,7 +214,7 @@ testFileLog = do let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} - (sId, [rId1, rId2]) <- createXFTPChunk c spKey file [rcvKey1, rcvKey2] + (sId, [rId1, rId2]) <- createXFTPChunk c spKey file [rcvKey1, rcvKey2] Nothing liftIO $ atomically $ do writeTVar sIdVar sId @@ -255,3 +262,23 @@ testFileLog = do download c rpKey rId digest bytes = do downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + +testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> IO () +testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success = + withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $ + \_ -> testXFTPClient $ \c -> runRight_ $ do + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + bytes <- liftIO $ createTestChunk testChunkPath + digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath + let file = FileInfo {sndKey, size = chSize, digest} + chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} + if success + then do + (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth + uploadXFTPChunk c spKey sId chunkSpec + downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes + else do + void (createXFTPChunk c spKey file [rcvKey] clntAuth) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))