XFTP error type

2026-05-15 11:45:12 +00:00 · 2023-02-17 22:27:36 +00:00
parent 15637e545b
commit bd0cc25083
6 changed files with 100 additions and 33 deletions
@@ -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
@@ -47,7 +47,7 @@ defaultXFTPClientAgentConfig =
          }
    }

-data XFTPClientAgentError = XFTPClientAgentError XFTPServer ProtocolClientError
+data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError
  deriving (Show, Exception)

 newXFTPAgent :: XFTPClientAgentConfig -> STM XFTPClientAgent
@@ -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
@@ -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
@@ -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
@@ -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