diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index e0528e0ce..bf64366e2 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -31,8 +31,7 @@ import Simplex.Messaging.Client ) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol - ( ErrorType (..), - ProtocolServer (ProtocolServer), + ( ProtocolServer (ProtocolServer), RcvPublicDhKey, RecipientId, SenderId, @@ -67,10 +66,12 @@ data XFTPChunkSpec = XFTPChunkSpec } deriving (Show) +type XFTPClientError = ProtocolClientError XFTPErrorType + defaultXFTPClientConfig :: XFTPClientConfig defaultXFTPClientConfig = XFTPClientConfig {networkConfig = defaultNetworkConfig} -getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> IO () -> IO (Either ProtocolClientError XFTPClient) +getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> IO () -> IO (Either XFTPClientError XFTPClient) getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {networkConfig} disconnected = runExceptT $ do let tcConfig = transportClientConfig networkConfig http2Config = xftpHTTP2Config tcConfig config @@ -89,13 +90,13 @@ xftpHTTP2Config transportConfig XFTPClientConfig {networkConfig = NetworkConfig transportConfig } -xftpClientError :: HTTP2ClientError -> ProtocolClientError +xftpClientError :: HTTP2ClientError -> XFTPClientError xftpClientError = \case HCResponseTimeout -> PCEResponseTimeout HCNetworkError -> PCENetworkError HCIOError e -> PCEIOError e -sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT ProtocolClientError IO (FileResponse, HTTP2Body) +sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) sendXFTPCommand XFTPClient {http2Client = http2@HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do t <- liftEither . first PCETransportError $ @@ -123,21 +124,21 @@ createXFTPChunk :: C.APrivateSignKey -> FileInfo -> NonEmpty C.APublicVerifyKey -> - ExceptT ProtocolClientError IO (SenderId, NonEmpty RecipientId) + ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) createXFTPChunk c spKey file rsps = sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case -- TODO check that body is empty (FRSndIds sId rIds, _body) -> pure (sId, rIds) (r, _) -> throwError . PCEUnexpectedResponse $ bshow r -uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT ProtocolClientError IO () +uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO () uploadXFTPChunk c spKey fId chunkSpec = sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= \case -- TODO check that body is empty (FROk, _body) -> pure () (r, _) -> throwError . PCEUnexpectedResponse $ bshow r -downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> ExceptT ProtocolClientError IO (RcvPublicDhKey, XFTPChunkBody) +downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> RcvPublicDhKey -> ExceptT XFTPClientError IO (RcvPublicDhKey, XFTPChunkBody) downloadXFTPChunk c rpKey fId rKey = sendXFTPCommand c rpKey fId (FGET rKey) Nothing >>= \case (FRFile sKey, http2Body@HTTP2Body {bodyHead, bodySize, bodyPart}) -> case bodyPart of @@ -145,10 +146,10 @@ downloadXFTPChunk c rpKey fId rKey = Just chunkPart -> do let chunk = XFTPChunkBody {chunkSize = bodySize - B.length bodyHead, chunkPart, http2Body} pure (sKey, chunk) - _ -> throwError $ PCEResponseError NO_MSG + _ -> throwError $ PCEResponseError NO_FILE (r, _) -> throwError . PCEUnexpectedResponse $ bshow r -receiveXFTPChunk :: XFTPChunkBody -> XFTPChunkSpec -> ExceptT ProtocolClientError IO () +receiveXFTPChunk :: XFTPChunkBody -> XFTPChunkSpec -> ExceptT XFTPClientError IO () receiveXFTPChunk XFTPChunkBody {chunkPart} XFTPChunkSpec {filePath, chunkOffset} = liftIO $ do withFile filePath AppendMode $ \h -> do -- hSeek h AbsoluteSeek $ fromIntegral chunkOffset diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs index 63cc77ed0..f52f229fc 100644 --- a/src/Simplex/FileTransfer/Client/Agent.hs +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -47,7 +47,7 @@ defaultXFTPClientAgentConfig = } } -data XFTPClientAgentError = XFTPClientAgentError XFTPServer ProtocolClientError +data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError deriving (Show, Exception) newXFTPAgent :: XFTPClientAgentConfig -> STM XFTPClientAgent diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 586c8290c..5d85d16fe 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -28,7 +28,6 @@ import Options.Applicative import Simplex.FileTransfer.Client import Simplex.FileTransfer.Client.Agent import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Description (FileSize (unFileSize)) import Simplex.FileTransfer.Protocol (FileInfo (..)) import Simplex.Messaging.Agent.Lock import qualified Simplex.Messaging.Crypto as C diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 36369d09f..3353e0e26 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,6 +13,7 @@ module Simplex.FileTransfer.Protocol where +import qualified Data.Attoparsec.ByteString.Char8 as A import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -19,15 +22,16 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) +import GHC.Generics (Generic) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Transport (ntfClientHandshake) import Simplex.Messaging.Protocol ( CommandError (..), - ErrorType (..), Protocol (..), ProtocolEncoding (..), + ProtocolErrorType (..), ProtocolMsgTag (..), ProtocolType (..), RcvPublicDhKey, @@ -119,7 +123,7 @@ instance ProtocolMsgTag FileCmdTag where instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where decodeTag s = decodeTag s >>= (\(FCT _ t) -> checkParty' t) -instance Protocol FileResponse where +instance Protocol XFTPErrorType FileResponse where type ProtoCommand FileResponse = FileCmd type ProtoType FileResponse = 'PXFTP protocolClientHandshake = ntfClientHandshake @@ -152,7 +156,7 @@ data FileInfo = FileInfo type XFTPFileId = ByteString -instance FilePartyI p => ProtocolEncoding (FileCommand p) where +instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where type Tag (FileCommand p) = FileCommandTag p encodeProtocol _v = \case FNEW file rKeys -> e (FNEW_, ' ', file, rKeys) @@ -168,6 +172,9 @@ instance FilePartyI p => ProtocolEncoding (FileCommand p) where protocolP v tag = (\(FileCmd _ c) -> checkParty c) <$?> protocolP v (FCT (sFileParty @p) tag) + fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse + {-# INLINE fromProtocolError #-} + checkCredentials (sig, _, fileId, _) cmd = case cmd of -- FNEW must not have signature and chunk ID FNEW {} @@ -182,7 +189,7 @@ instance FilePartyI p => ProtocolEncoding (FileCommand p) where | isNothing sig || B.null fileId -> Left $ CMD NO_AUTH | otherwise -> Right cmd -instance ProtocolEncoding FileCmd where +instance ProtocolEncoding XFTPErrorType FileCmd where type Tag FileCmd = FileCmdTag encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c @@ -199,6 +206,9 @@ instance ProtocolEncoding FileCmd where FACK_ -> pure FACK PING_ -> pure PING + fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse + {-# INLINE fromProtocolError #-} + checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c instance Encoding FileInfo where @@ -243,11 +253,11 @@ data FileResponse | FRRcvIds (NonEmpty RecipientId) | FRFile RcvPublicDhKey | FROk - | FRErr ErrorType + | FRErr XFTPErrorType | FRPong deriving (Show) -instance ProtocolEncoding FileResponse where +instance ProtocolEncoding XFTPErrorType FileResponse where type Tag FileResponse = FileResponseTag encodeProtocol _v = \case FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds) @@ -268,6 +278,13 @@ instance ProtocolEncoding FileResponse where FRErr_ -> FRErr <$> _smpP FRPong_ -> pure FRPong + fromProtocolError = \case + PECmdSyntax -> CMD SYNTAX + PECmdUnknown -> CMD UNKNOWN + PESession -> SESSION + PEBlock -> BLOCK + {-# INLINE fromProtocolError #-} + checkCredentials (_, _, entId, _) cmd = case cmd of FRSndIds {} -> noEntity -- ERR response does not always have entity ID @@ -283,6 +300,56 @@ instance ProtocolEncoding FileResponse where | B.null entId = Right cmd | otherwise = Left $ CMD HAS_AUTH +data XFTPErrorType + = -- | incorrect block format, encoding or signature size + BLOCK + | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929) + SESSION + | -- | SMP command is unknown or has invalid syntax + CMD {cmdErr :: CommandError} + | -- | command authorization error - bad signature or non-existing SMP queue + AUTH + | -- | incorrent file size + SIZE + | -- | incorrent file digest + DIGEST + | -- | no file body + NO_FILE + | -- | unexpected file body + HAS_FILE + | -- | internal server error + INTERNAL + | -- | used internally, never returned by the server (to be removed) + DUPLICATE_ -- not part of SMP protocol, used internally + deriving (Eq, Generic, Read, Show) + +instance Encoding XFTPErrorType where + smpEncode = \case + BLOCK -> "BLOCK" + SESSION -> "SESSION" + CMD err -> "CMD " <> smpEncode err + AUTH -> "AUTH" + SIZE -> "SIZE" + DIGEST -> "DIGEST" + NO_FILE -> "NO_FILE" + HAS_FILE -> "HAS_FILE" + INTERNAL -> "INTERNAL" + DUPLICATE_ -> "DUPLICATE_" + + smpP = + A.takeTill (== ' ') >>= \case + "BLOCK" -> pure BLOCK + "SESSION" -> pure SESSION + "CMD" -> CMD <$> _smpP + "AUTH" -> pure AUTH + "SIZE" -> pure SIZE + "DIGEST" -> pure DIGEST + "NO_FILE" -> pure NO_FILE + "HAS_FILE" -> pure HAS_FILE + "INTERNAL" -> pure INTERNAL + "DUPLICATE_" -> pure DUPLICATE_ + _ -> fail "bad error type" + checkParty :: forall t p p'. (FilePartyI p, FilePartyI p') => t p' -> Either String (t p) checkParty c = case testEquality (sFileParty @p) (sFileParty @p') of Just Refl -> Right c @@ -293,7 +360,7 @@ checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of Just Refl -> Just c _ -> Nothing -xftpEncodeTransmission :: ProtocolEncoding c => SessionId -> Maybe C.APrivateSignKey -> Transmission c -> Either TransportError ByteString +xftpEncodeTransmission :: ProtocolEncoding e c => SessionId -> Maybe C.APrivateSignKey -> Transmission c -> Either TransportError ByteString xftpEncodeTransmission sessionId pKey (corrId, fId, msg) = do let t = encodeTransmission currentXFTPVersion sessionId (corrId, fId, msg) xftpEncodeBatch1 $ signTransmission t @@ -307,9 +374,9 @@ xftpEncodeBatch1 (sig, t) = let t' = tEncodeBatch 1 . smpEncode . Large $ tEncode (sig, t) in first (const TELargeMsg) $ C.pad t' xftpBlockSize -xftpDecodeTransmission :: ProtocolEncoding c => SessionId -> ByteString -> Either ErrorType (SignedTransmission c) +xftpDecodeTransmission :: ProtocolEncoding e c => SessionId -> ByteString -> Either XFTPErrorType (SignedTransmission e c) xftpDecodeTransmission sessionId t = do - t' <- first (const LARGE_MSG) $ C.unPad t + t' <- first (const BLOCK) $ C.unPad t case tParse True t' of t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t'' _ -> Left BLOCK diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 26ba37ae5..a5f2b54bc 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -37,7 +37,7 @@ import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Transport (receiveFile, sendFile) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (CorrId, ErrorType (..), RcvPublicDhKey) +import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey) import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature) import Simplex.Messaging.Server.Stats import Simplex.Messaging.Server.StoreLog (StoreLog, closeStoreLog) @@ -207,7 +207,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case noFile resp = pure (resp, Nothing) receiveServerFile :: FileRec -> M FileResponse receiveServerFile FileRec {senderId, fileInfo, filePath} = case bodyPart of - Nothing -> pure $ FRErr QUOTA -- TODO file specific errors? + Nothing -> pure $ FRErr SIZE -- TODO file specific errors? Just getBody -> do -- TODO validate body size before downloading, once it's populated path <- asks $ filesPath . config @@ -216,7 +216,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case size' <- liftIO . withFile fPath WriteMode $ \h -> receiveFile h getBody 0 if size' == fromIntegral size -- TODO check digest then atomically $ writeTVar filePath (Just fPath) $> FROk - else whenM (doesFileExist fPath) (removeFile fPath) $> FRErr QUOTA + else whenM (doesFileExist fPath) (removeFile fPath) $> FRErr SIZE sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile) sendServerFile FileRec {filePath, fileInfo = FileInfo {size}} rKey = do readTVarIO filePath >>= \case diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index bbacd8335..9ea6f0496 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -20,9 +20,9 @@ import Control.Concurrent.STM import Data.Functor (($>)) import Data.Set (Set) import qualified Data.Set as S -import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPFileId) +import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPErrorType (..), XFTPFileId) import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Protocol hiding (SParty, SRecipient, SSender) +import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (ifM) @@ -46,7 +46,7 @@ newFileStore = do recipients <- TM.empty pure FileStore {files, recipients} -addFile :: FileStore -> SenderId -> FileInfo -> STM (Either ErrorType ()) +addFile :: FileStore -> SenderId -> FileInfo -> STM (Either XFTPErrorType ()) addFile FileStore {files} sId fileInfo = ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do f <- newFileRec sId fileInfo @@ -59,12 +59,12 @@ newFileRec senderId fileInfo = do filePath <- newTVar Nothing pure FileRec {senderId, fileInfo, filePath, recipientIds} -setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either ErrorType ()) +setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ()) setFilePath st sId fPath = withFile st sId $ \FileRec {filePath} -> writeTVar filePath (Just fPath) $> Right () -addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either ErrorType ()) +addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either XFTPErrorType ()) addRecipient st@FileStore {recipients} senderId (rId, rKey) = withFile st senderId $ \FileRec {recipientIds} -> do rIds <- readTVar recipientIds @@ -76,7 +76,7 @@ addRecipient st@FileStore {recipients} senderId (rId, rKey) = TM.insert rId (senderId, rKey) recipients pure $ Right () -deleteFile :: FileStore -> SenderId -> STM (Either ErrorType ()) +deleteFile :: FileStore -> SenderId -> STM (Either XFTPErrorType ()) deleteFile FileStore {files, recipients} senderId = do TM.lookupDelete senderId files >>= \case Just FileRec {recipientIds} -> do @@ -84,7 +84,7 @@ deleteFile FileStore {files, recipients} senderId = do pure $ Right () _ -> pure $ Left AUTH -getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either ErrorType (FileRec, C.APublicVerifyKey)) +getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey)) getFile st party fId = case party of SSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f)) SRecipient -> @@ -92,7 +92,7 @@ getFile st party fId = case party of Just (sId, rKey) -> withFile st sId $ pure . Right . (,rKey) _ -> pure $ Left AUTH -ackFile :: FileStore -> RecipientId -> STM (Either ErrorType ()) +ackFile :: FileStore -> RecipientId -> STM (Either XFTPErrorType ()) ackFile st@FileStore {recipients} recipientId = do TM.lookupDelete recipientId recipients >>= \case Just (sId, _) -> @@ -101,7 +101,7 @@ ackFile st@FileStore {recipients} recipientId = do pure $ Right () _ -> pure $ Left AUTH -withFile :: FileStore -> SenderId -> (FileRec -> STM (Either ErrorType a)) -> STM (Either ErrorType a) +withFile :: FileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a) withFile FileStore {files} sId a = TM.lookup sId files >>= \case Just f -> a f