{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Simplex.FileTransfer.Transport
  ( supportedFileServerVRange,
    authCmdsXFTPVersion,
    blockedFilesXFTPVersion,
    xftpClientHandshakeStub,
    alpnSupportedXFTPhandshakes,
    xftpALPNv1,
    XFTPClientHandshake (..),
    -- xftpClientHandshake,
    XFTPServerHandshake (..),
    -- xftpServerHandshake,
    XFTPClientHello (..),
    THandleXFTP,
    THandleParamsXFTP,
    VersionXFTP,
    VersionRangeXFTP,
    XFTPVersion,
    pattern VersionXFTP,
    XFTPErrorType (..),
    XFTPRcvChunkSpec (..),
    ReceiveFileError (..),
    receiveFile,
    sendEncFile,
    receiveEncFile,
    receiveSbFile,
  )
where

import Control.Applicative (optional)
import qualified Control.Exception as E
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import qualified Data.Aeson.TH as J
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import qualified Data.ByteArray as BA
import Data.ByteString.Builder (Builder, byteString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Functor (($>))
import Data.Word (Word16, Word32)
import Network.HTTP2.Client (HTTP2Error)
import qualified Simplex.Messaging.Crypto as C
import qualified Simplex.Messaging.Crypto.Lazy as LC
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol (BlockingInfo, CommandError)
import Simplex.Messaging.Transport (ALPN, CertChainPubKey, ServiceCredentials, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
import Simplex.Messaging.Transport.HTTP2.File
import Simplex.Messaging.Util (bshow, tshow, (<$?>))
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import System.IO (Handle, IOMode (..), withFile)

data XFTPRcvChunkSpec = XFTPRcvChunkSpec
  { XFTPRcvChunkSpec -> FilePath
filePath :: FilePath,
    XFTPRcvChunkSpec -> Word32
chunkSize :: Word32,
    XFTPRcvChunkSpec -> ByteString
chunkDigest :: ByteString
  }
  deriving (Int -> XFTPRcvChunkSpec -> ShowS
[XFTPRcvChunkSpec] -> ShowS
XFTPRcvChunkSpec -> FilePath
(Int -> XFTPRcvChunkSpec -> ShowS)
-> (XFTPRcvChunkSpec -> FilePath)
-> ([XFTPRcvChunkSpec] -> ShowS)
-> Show XFTPRcvChunkSpec
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XFTPRcvChunkSpec -> ShowS
showsPrec :: Int -> XFTPRcvChunkSpec -> ShowS
$cshow :: XFTPRcvChunkSpec -> FilePath
show :: XFTPRcvChunkSpec -> FilePath
$cshowList :: [XFTPRcvChunkSpec] -> ShowS
showList :: [XFTPRcvChunkSpec] -> ShowS
Show)

data XFTPVersion

instance VersionScope XFTPVersion

type VersionXFTP = Version XFTPVersion

type VersionRangeXFTP = VersionRange XFTPVersion

pattern VersionXFTP :: Word16 -> VersionXFTP
pattern $mVersionXFTP :: forall {r}. VersionXFTP -> (Word16 -> r) -> ((# #) -> r) -> r
$bVersionXFTP :: Word16 -> VersionXFTP
VersionXFTP v = Version v

type THandleXFTP c p = THandle XFTPVersion c p
type THandleParamsXFTP p = THandleParams XFTPVersion p

initialXFTPVersion :: VersionXFTP
initialXFTPVersion :: VersionXFTP
initialXFTPVersion = Word16 -> VersionXFTP
VersionXFTP Word16
1

authCmdsXFTPVersion :: VersionXFTP
authCmdsXFTPVersion :: VersionXFTP
authCmdsXFTPVersion = Word16 -> VersionXFTP
VersionXFTP Word16
2

blockedFilesXFTPVersion :: VersionXFTP
blockedFilesXFTPVersion :: VersionXFTP
blockedFilesXFTPVersion = Word16 -> VersionXFTP
VersionXFTP Word16
3

currentXFTPVersion :: VersionXFTP
currentXFTPVersion :: VersionXFTP
currentXFTPVersion = Word16 -> VersionXFTP
VersionXFTP Word16
3

supportedFileServerVRange :: VersionRangeXFTP
supportedFileServerVRange :: VersionRangeXFTP
supportedFileServerVRange = VersionXFTP -> VersionXFTP -> VersionRangeXFTP
forall v. Version v -> Version v -> VersionRange v
mkVersionRange VersionXFTP
initialXFTPVersion VersionXFTP
currentXFTPVersion

-- XFTP protocol does not use this handshake method
xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
xftpClientHandshakeStub :: forall (c :: TransportPeer -> *).
c 'TClient
-> Maybe KeyPairX25519
-> KeyHash
-> VersionRangeXFTP
-> Bool
-> Maybe (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
xftpClientHandshakeStub c 'TClient
_c Maybe KeyPairX25519
_ks KeyHash
_keyHash VersionRangeXFTP
_xftpVRange Bool
_proxyServer Maybe (ServiceCredentials, KeyPairEd25519)
_serviceKeys = TransportError
-> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TransportError
TEVersion

alpnSupportedXFTPhandshakes :: [ALPN]
alpnSupportedXFTPhandshakes :: [ByteString]
alpnSupportedXFTPhandshakes = [ByteString
xftpALPNv1]

xftpALPNv1 :: ALPN
xftpALPNv1 :: ByteString
xftpALPNv1 = ByteString
"xftp/1"

data XFTPClientHello = XFTPClientHello
  { -- | a random string sent by the client to the server to prove that server has identity certificate
    XFTPClientHello -> Maybe ByteString
webChallenge :: Maybe ByteString
  }

data XFTPServerHandshake = XFTPServerHandshake
  { XFTPServerHandshake -> VersionRangeXFTP
xftpVersionRange :: VersionRangeXFTP,
    XFTPServerHandshake -> ByteString
sessionId :: SessionId,
    -- | pub key to agree shared secrets for command authorization and entity ID encryption.
    XFTPServerHandshake -> CertChainPubKey
authPubKey :: CertChainPubKey,
    -- | signed identity challenge from  XFTPClientHello
    XFTPServerHandshake -> Maybe ASignature
webIdentityProof :: Maybe C.ASignature
  }

data XFTPClientHandshake = XFTPClientHandshake
  { -- | agreed XFTP server protocol version
    XFTPClientHandshake -> VersionXFTP
xftpVersion :: VersionXFTP,
    -- | server identity - CA certificate fingerprint
    XFTPClientHandshake -> KeyHash
keyHash :: C.KeyHash
  }

instance Encoding XFTPClientHello where
  smpEncode :: XFTPClientHello -> ByteString
smpEncode XFTPClientHello {Maybe ByteString
$sel:webChallenge:XFTPClientHello :: XFTPClientHello -> Maybe ByteString
webChallenge :: Maybe ByteString
webChallenge} = Maybe ByteString -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode Maybe ByteString
webChallenge
  smpP :: Parser XFTPClientHello
smpP = do
    Maybe ByteString
webChallenge <- Parser (Maybe ByteString)
forall a. Encoding a => Parser a
smpP
    Maybe ByteString
-> (ByteString -> Parser ByteString ()) -> Parser ByteString ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ByteString
webChallenge ((ByteString -> Parser ByteString ()) -> Parser ByteString ())
-> (ByteString -> Parser ByteString ()) -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ \ByteString
challenge -> Bool -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
B.length ByteString
challenge Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
32) (Parser ByteString () -> Parser ByteString ())
-> Parser ByteString () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Parser ByteString ()
forall a. FilePath -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"bad XFTPClientHello webChallenge"
    Tail ByteString
_compat <- Parser Tail
forall a. Encoding a => Parser a
smpP
    XFTPClientHello -> Parser XFTPClientHello
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPClientHello {Maybe ByteString
$sel:webChallenge:XFTPClientHello :: Maybe ByteString
webChallenge :: Maybe ByteString
webChallenge}

instance Encoding XFTPClientHandshake where
  smpEncode :: XFTPClientHandshake -> ByteString
smpEncode XFTPClientHandshake {VersionXFTP
$sel:xftpVersion:XFTPClientHandshake :: XFTPClientHandshake -> VersionXFTP
xftpVersion :: VersionXFTP
xftpVersion, KeyHash
$sel:keyHash:XFTPClientHandshake :: XFTPClientHandshake -> KeyHash
keyHash :: KeyHash
keyHash} =
    (VersionXFTP, KeyHash) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionXFTP
xftpVersion, KeyHash
keyHash)
  smpP :: Parser XFTPClientHandshake
smpP = do
    (VersionXFTP
xftpVersion, KeyHash
keyHash) <- Parser (VersionXFTP, KeyHash)
forall a. Encoding a => Parser a
smpP
    Tail ByteString
_compat <- Parser Tail
forall a. Encoding a => Parser a
smpP
    XFTPClientHandshake -> Parser XFTPClientHandshake
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPClientHandshake {VersionXFTP
$sel:xftpVersion:XFTPClientHandshake :: VersionXFTP
xftpVersion :: VersionXFTP
xftpVersion, KeyHash
$sel:keyHash:XFTPClientHandshake :: KeyHash
keyHash :: KeyHash
keyHash}

instance Encoding XFTPServerHandshake where
  smpEncode :: XFTPServerHandshake -> ByteString
smpEncode XFTPServerHandshake {VersionRangeXFTP
$sel:xftpVersionRange:XFTPServerHandshake :: XFTPServerHandshake -> VersionRangeXFTP
xftpVersionRange :: VersionRangeXFTP
xftpVersionRange, ByteString
$sel:sessionId:XFTPServerHandshake :: XFTPServerHandshake -> ByteString
sessionId :: ByteString
sessionId, CertChainPubKey
$sel:authPubKey:XFTPServerHandshake :: XFTPServerHandshake -> CertChainPubKey
authPubKey :: CertChainPubKey
authPubKey, Maybe ASignature
$sel:webIdentityProof:XFTPServerHandshake :: XFTPServerHandshake -> Maybe ASignature
webIdentityProof :: Maybe ASignature
webIdentityProof} =
    (VersionRangeXFTP, ByteString, CertChainPubKey, ByteString)
-> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (VersionRangeXFTP
xftpVersionRange, ByteString
sessionId, CertChainPubKey
authPubKey, Maybe ASignature -> ByteString
forall s. CryptoSignature s => s -> ByteString
C.signatureBytes Maybe ASignature
webIdentityProof)
  smpP :: Parser XFTPServerHandshake
smpP = do
    (VersionRangeXFTP
xftpVersionRange, ByteString
sessionId, CertChainPubKey
authPubKey) <- Parser (VersionRangeXFTP, ByteString, CertChainPubKey)
forall a. Encoding a => Parser a
smpP
    Maybe ASignature
webIdentityProof <- Parser ByteString ASignature
-> Parser ByteString (Maybe ASignature)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ByteString ASignature
 -> Parser ByteString (Maybe ASignature))
-> Parser ByteString ASignature
-> Parser ByteString (Maybe ASignature)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath ASignature
forall s. CryptoSignature s => ByteString -> Either FilePath s
C.decodeSignature (ByteString -> Either FilePath ASignature)
-> Parser ByteString ByteString -> Parser ByteString ASignature
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either FilePath b) -> m a -> m b
<$?> Parser ByteString ByteString
forall a. Encoding a => Parser a
smpP
    Tail ByteString
_compat <- Parser Tail
forall a. Encoding a => Parser a
smpP
    XFTPServerHandshake -> Parser XFTPServerHandshake
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPServerHandshake {VersionRangeXFTP
$sel:xftpVersionRange:XFTPServerHandshake :: VersionRangeXFTP
xftpVersionRange :: VersionRangeXFTP
xftpVersionRange, ByteString
$sel:sessionId:XFTPServerHandshake :: ByteString
sessionId :: ByteString
sessionId, CertChainPubKey
$sel:authPubKey:XFTPServerHandshake :: CertChainPubKey
authPubKey :: CertChainPubKey
authPubKey, Maybe ASignature
$sel:webIdentityProof:XFTPServerHandshake :: Maybe ASignature
webIdentityProof :: Maybe ASignature
webIdentityProof}

sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
sendEncFile :: Handle -> (Builder -> IO ()) -> SbState -> Word32 -> IO ()
sendEncFile Handle
h Builder -> IO ()
send = SbState -> Word32 -> IO ()
go
  where
    go :: SbState -> Word32 -> IO ()
go SbState
sbState Word32
0 = do
      let authTag :: ByteString
authTag = Auth -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SbState -> Auth
LC.sbAuth SbState
sbState)
      Builder -> IO ()
send (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
authTag
    go SbState
sbState Word32
sz =
      Handle -> Word32 -> IO ByteString
getFileChunk Handle
h Word32
sz IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
ch -> do
        let (ByteString
encCh, SbState
sbState') = SbState -> ByteString -> (ByteString, SbState)
LC.sbEncryptChunk SbState
sbState ByteString
ch
        Builder -> IO ()
send (ByteString -> Builder
byteString ByteString
encCh) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException
e :: E.SomeException) -> SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
e IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO SomeException
e
        SbState -> Word32 -> IO ()
go SbState
sbState' (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word32
sz Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
ch)

receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveFile :: (Int -> IO ByteString)
-> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveFile Int -> IO ByteString
getBody XFTPRcvChunkSpec
chunk = IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ())
-> IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT XFTPErrorType IO () -> IO (Either XFTPErrorType ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ((Handle -> Word32 -> IO (Either XFTPErrorType ()))
-> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveFile_ Handle -> Word32 -> IO (Either XFTPErrorType ())
receive XFTPRcvChunkSpec
chunk) IO (Either XFTPErrorType ())
-> [Handler (Either XFTPErrorType ())]
-> IO (Either XFTPErrorType ())
forall a. IO a -> [Handler a] -> IO a
`E.catches` [Handler (Either XFTPErrorType ())]
forall {b}. [Handler (Either XFTPErrorType b)]
handlers
  where
    receive :: Handle -> Word32 -> IO (Either XFTPErrorType ())
receive Handle
h Word32
sz = (Int -> IO ByteString) -> Handle -> Word32 -> IO Int64
hReceiveFile Int -> IO ByteString
getBody Handle
h Word32
sz IO Int64
-> (Int64 -> IO (Either XFTPErrorType ()))
-> IO (Either XFTPErrorType ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int64
sz' -> Either XFTPErrorType () -> IO (Either XFTPErrorType ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either XFTPErrorType () -> IO (Either XFTPErrorType ()))
-> Either XFTPErrorType () -> IO (Either XFTPErrorType ())
forall a b. (a -> b) -> a -> b
$ if Int64
sz' Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0 then () -> Either XFTPErrorType ()
forall a b. b -> Either a b
Right () else XFTPErrorType -> Either XFTPErrorType ()
forall a b. a -> Either a b
Left XFTPErrorType
SIZE
    handlers :: [Handler (Either XFTPErrorType b)]
handlers =
      [ (HTTP2Error -> IO (Either XFTPErrorType b))
-> Handler (Either XFTPErrorType b)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((HTTP2Error -> IO (Either XFTPErrorType b))
 -> Handler (Either XFTPErrorType b))
-> (HTTP2Error -> IO (Either XFTPErrorType b))
-> Handler (Either XFTPErrorType b)
forall a b. (a -> b) -> a -> b
$ \(HTTP2Error
e :: HTTP2Error) -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logWarn (HTTP2Error -> Text
forall {a}. Show a => a -> Text
err HTTP2Error
e) IO () -> Either XFTPErrorType b -> IO (Either XFTPErrorType b)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> XFTPErrorType -> Either XFTPErrorType b
forall a b. a -> Either a b
Left XFTPErrorType
TIMEOUT,
        (SomeException -> IO (Either XFTPErrorType b))
-> Handler (Either XFTPErrorType b)
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((SomeException -> IO (Either XFTPErrorType b))
 -> Handler (Either XFTPErrorType b))
-> (SomeException -> IO (Either XFTPErrorType b))
-> Handler (Either XFTPErrorType b)
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: E.SomeException) -> Text -> IO ()
forall (m :: * -> *).
(?callStack::CallStack, MonadIO m) =>
Text -> m ()
logError (SomeException -> Text
forall {a}. Show a => a -> Text
err SomeException
e) IO () -> Either XFTPErrorType b -> IO (Either XFTPErrorType b)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> XFTPErrorType -> Either XFTPErrorType b
forall a b. a -> Either a b
Left XFTPErrorType
FILE_IO
      ]
    err :: a -> Text
err a
e = Text
"receiveFile error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall {a}. Show a => a -> Text
tshow a
e

receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveEncFile :: (Int -> IO ByteString)
-> SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveEncFile Int -> IO ByteString
getBody = (Handle -> Word32 -> IO (Either XFTPErrorType ()))
-> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveFile_ ((Handle -> Word32 -> IO (Either XFTPErrorType ()))
 -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ())
-> (SbState -> Handle -> Word32 -> IO (Either XFTPErrorType ()))
-> SbState
-> XFTPRcvChunkSpec
-> ExceptT XFTPErrorType IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SbState -> Handle -> Word32 -> IO (Either XFTPErrorType ())
receive
  where
    receive :: SbState -> Handle -> Word32 -> IO (Either XFTPErrorType ())
receive SbState
sbState Handle
h Word32
sz = (ReceiveFileError -> XFTPErrorType)
-> Either ReceiveFileError () -> Either XFTPErrorType ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ReceiveFileError -> XFTPErrorType
err (Either ReceiveFileError () -> Either XFTPErrorType ())
-> IO (Either ReceiveFileError ()) -> IO (Either XFTPErrorType ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IO ByteString)
-> Handle -> SbState -> Word32 -> IO (Either ReceiveFileError ())
receiveSbFile Int -> IO ByteString
getBody Handle
h SbState
sbState Word32
sz
    err :: ReceiveFileError -> XFTPErrorType
err ReceiveFileError
RFESize = XFTPErrorType
SIZE
    err ReceiveFileError
RFECrypto = XFTPErrorType
CRYPTO

data ReceiveFileError = RFESize | RFECrypto

receiveSbFile :: (Int -> IO ByteString) -> Handle -> LC.SbState -> Word32 -> IO (Either ReceiveFileError ())
receiveSbFile :: (Int -> IO ByteString)
-> Handle -> SbState -> Word32 -> IO (Either ReceiveFileError ())
receiveSbFile Int -> IO ByteString
getBody Handle
h = SbState -> Word32 -> IO (Either ReceiveFileError ())
receive
  where
    receive :: SbState -> Word32 -> IO (Either ReceiveFileError ())
receive SbState
sbState Word32
sz = do
      ByteString
ch <- Int -> IO ByteString
getBody Int
fileBlockSize
      let chSize :: Word32
chSize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
ch
      if
        | Word32
chSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
sz Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
authSz -> Either ReceiveFileError () -> IO (Either ReceiveFileError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ReceiveFileError () -> IO (Either ReceiveFileError ()))
-> Either ReceiveFileError () -> IO (Either ReceiveFileError ())
forall a b. (a -> b) -> a -> b
$ ReceiveFileError -> Either ReceiveFileError ()
forall a b. a -> Either a b
Left ReceiveFileError
RFESize
        | Word32
chSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0 -> do
            let (ByteString
ch', ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
sz) ByteString
ch
                (ByteString
decCh, SbState
sbState') = SbState -> ByteString -> (ByteString, SbState)
LC.sbDecryptChunk SbState
sbState ByteString
ch'
                sz' :: Word32
sz' = Word32
sz Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
ch')
            Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
decCh
            if Word32
sz' Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
0
              then SbState -> Word32 -> IO (Either ReceiveFileError ())
receive SbState
sbState' Word32
sz'
              else do
                let tag' :: ByteString
tag' = Int -> ByteString -> ByteString
B.take Int
C.authTagSize ByteString
rest
                    tagSz :: Int
tagSz = ByteString -> Int
B.length ByteString
tag'
                    tag :: Auth
tag = SbState -> Auth
LC.sbAuth SbState
sbState'
                ByteString
tag'' <- if Int
tagSz Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
C.authTagSize then ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
tag' else (ByteString
tag' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
getBody (Int
C.authTagSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tagSz)
                Either ReceiveFileError () -> IO (Either ReceiveFileError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ReceiveFileError () -> IO (Either ReceiveFileError ()))
-> Either ReceiveFileError () -> IO (Either ReceiveFileError ())
forall a b. (a -> b) -> a -> b
$ if ByteString -> Auth -> Bool
forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
BA.constEq ByteString
tag'' Auth
tag then () -> Either ReceiveFileError ()
forall a b. b -> Either a b
Right () else ReceiveFileError -> Either ReceiveFileError ()
forall a b. a -> Either a b
Left ReceiveFileError
RFECrypto
        | Bool
otherwise -> Either ReceiveFileError () -> IO (Either ReceiveFileError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ReceiveFileError () -> IO (Either ReceiveFileError ()))
-> Either ReceiveFileError () -> IO (Either ReceiveFileError ())
forall a b. (a -> b) -> a -> b
$ ReceiveFileError -> Either ReceiveFileError ()
forall a b. a -> Either a b
Left ReceiveFileError
RFESize
    authSz :: Word32
authSz = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
C.authTagSize

receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ()))
-> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO ()
receiveFile_ Handle -> Word32 -> IO (Either XFTPErrorType ())
receive XFTPRcvChunkSpec {FilePath
$sel:filePath:XFTPRcvChunkSpec :: XFTPRcvChunkSpec -> FilePath
filePath :: FilePath
filePath, Word32
$sel:chunkSize:XFTPRcvChunkSpec :: XFTPRcvChunkSpec -> Word32
chunkSize :: Word32
chunkSize, ByteString
$sel:chunkDigest:XFTPRcvChunkSpec :: XFTPRcvChunkSpec -> ByteString
chunkDigest :: ByteString
chunkDigest} = do
  IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ())
-> IO (Either XFTPErrorType ()) -> ExceptT XFTPErrorType IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> IOMode
-> (Handle -> IO (Either XFTPErrorType ()))
-> IO (Either XFTPErrorType ())
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
filePath IOMode
WriteMode (Handle -> Word32 -> IO (Either XFTPErrorType ())
`receive` Word32
chunkSize)
  ByteString
digest' <- IO ByteString -> ExceptT XFTPErrorType IO ByteString
forall a. IO a -> ExceptT XFTPErrorType IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ExceptT XFTPErrorType IO ByteString)
-> IO ByteString -> ExceptT XFTPErrorType IO ByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
LC.sha256Hash (LazyByteString -> ByteString)
-> IO LazyByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO LazyByteString
LB.readFile FilePath
filePath
  Bool -> ExceptT XFTPErrorType IO () -> ExceptT XFTPErrorType IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
digest' ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
chunkDigest) (ExceptT XFTPErrorType IO () -> ExceptT XFTPErrorType IO ())
-> ExceptT XFTPErrorType IO () -> ExceptT XFTPErrorType IO ()
forall a b. (a -> b) -> a -> b
$ XFTPErrorType -> ExceptT XFTPErrorType IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE XFTPErrorType
DIGEST

data XFTPErrorType
  = -- | incorrect block format, encoding or signature size
    BLOCK
  | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
    SESSION
  | -- | incorrect handshake command
    HANDSHAKE
  | -- | SMP command is unknown or has invalid syntax
    CMD {XFTPErrorType -> CommandError
cmdErr :: CommandError}
  | -- | command authorization error - bad signature or non-existing SMP queue
    AUTH
  | -- | command with the entity that was blocked
    BLOCKED {XFTPErrorType -> BlockingInfo
blockInfo :: BlockingInfo}
  | -- | incorrent file size
    SIZE
  | -- | storage quota exceeded
    QUOTA
  | -- | incorrent file digest
    DIGEST
  | -- | file encryption/decryption failed
    CRYPTO
  | -- | no expected file body in request/response or no file on the server
    NO_FILE
  | -- | unexpected file body
    HAS_FILE
  | -- | file IO error
    FILE_IO
  | -- | file sending or receiving timeout
    TIMEOUT
  | -- | internal server error
    INTERNAL
  | -- | used internally, never returned by the server (to be removed)
    DUPLICATE_ -- not part of SMP protocol, used internally
  deriving (XFTPErrorType -> XFTPErrorType -> Bool
(XFTPErrorType -> XFTPErrorType -> Bool)
-> (XFTPErrorType -> XFTPErrorType -> Bool) -> Eq XFTPErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: XFTPErrorType -> XFTPErrorType -> Bool
== :: XFTPErrorType -> XFTPErrorType -> Bool
$c/= :: XFTPErrorType -> XFTPErrorType -> Bool
/= :: XFTPErrorType -> XFTPErrorType -> Bool
Eq, Int -> XFTPErrorType -> ShowS
[XFTPErrorType] -> ShowS
XFTPErrorType -> FilePath
(Int -> XFTPErrorType -> ShowS)
-> (XFTPErrorType -> FilePath)
-> ([XFTPErrorType] -> ShowS)
-> Show XFTPErrorType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> XFTPErrorType -> ShowS
showsPrec :: Int -> XFTPErrorType -> ShowS
$cshow :: XFTPErrorType -> FilePath
show :: XFTPErrorType -> FilePath
$cshowList :: [XFTPErrorType] -> ShowS
showList :: [XFTPErrorType] -> ShowS
Show)

instance StrEncoding XFTPErrorType where
  strEncode :: XFTPErrorType -> ByteString
strEncode = \case
    XFTPErrorType
BLOCK -> ByteString
"BLOCK"
    XFTPErrorType
SESSION -> ByteString
"SESSION"
    XFTPErrorType
HANDSHAKE -> ByteString
"HANDSHAKE"
    CMD CommandError
e -> ByteString
"CMD " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> CommandError -> ByteString
forall a. Show a => a -> ByteString
bshow CommandError
e
    XFTPErrorType
AUTH -> ByteString
"AUTH"
    BLOCKED BlockingInfo
info -> ByteString
"BLOCKED " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> BlockingInfo -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode BlockingInfo
info
    XFTPErrorType
SIZE -> ByteString
"SIZE"
    XFTPErrorType
QUOTA -> ByteString
"QUOTA"
    XFTPErrorType
DIGEST -> ByteString
"DIGEST"
    XFTPErrorType
CRYPTO -> ByteString
"CRYPTO"
    XFTPErrorType
NO_FILE -> ByteString
"NO_FILE"
    XFTPErrorType
HAS_FILE -> ByteString
"HAS_FILE"
    XFTPErrorType
FILE_IO -> ByteString
"FILE_IO"
    XFTPErrorType
TIMEOUT -> ByteString
"TIMEOUT"
    XFTPErrorType
INTERNAL -> ByteString
"INTERNAL"
    XFTPErrorType
DUPLICATE_ -> ByteString
"DUPLICATE_"

  strP :: Parser XFTPErrorType
strP =
    (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString ByteString
-> (ByteString -> Parser XFTPErrorType) -> Parser XFTPErrorType
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"BLOCK" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
BLOCK
      ByteString
"SESSION" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
SESSION
      ByteString
"HANDSHAKE" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
HANDSHAKE
      ByteString
"CMD" -> CommandError -> XFTPErrorType
CMD (CommandError -> XFTPErrorType)
-> Parser ByteString CommandError -> Parser XFTPErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString CommandError
forall a. Read a => Parser a
parseRead1
      ByteString
"AUTH" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
AUTH
      ByteString
"BLOCKED" -> BlockingInfo -> XFTPErrorType
BLOCKED (BlockingInfo -> XFTPErrorType)
-> Parser ByteString BlockingInfo -> Parser XFTPErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString BlockingInfo
forall a. StrEncoding a => Parser a
_strP
      ByteString
"SIZE" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
SIZE
      ByteString
"QUOTA" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
QUOTA
      ByteString
"DIGEST" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
DIGEST
      ByteString
"CRYPTO" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
CRYPTO
      ByteString
"NO_FILE" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
NO_FILE
      ByteString
"HAS_FILE" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
HAS_FILE
      ByteString
"FILE_IO" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
FILE_IO
      ByteString
"TIMEOUT" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
TIMEOUT
      ByteString
"INTERNAL" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
INTERNAL
      ByteString
"DUPLICATE_" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
DUPLICATE_
      ByteString
_ -> FilePath -> Parser XFTPErrorType
forall a. FilePath -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"bad error type"

instance Encoding XFTPErrorType where
  smpEncode :: XFTPErrorType -> ByteString
smpEncode = \case
    XFTPErrorType
BLOCK -> ByteString
"BLOCK"
    XFTPErrorType
SESSION -> ByteString
"SESSION"
    XFTPErrorType
HANDSHAKE -> ByteString
"HANDSHAKE"
    CMD CommandError
err -> ByteString
"CMD " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> CommandError -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode CommandError
err
    XFTPErrorType
AUTH -> ByteString
"AUTH"
    BLOCKED BlockingInfo
info -> ByteString
"BLOCKED " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> BlockingInfo -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode BlockingInfo
info
    XFTPErrorType
SIZE -> ByteString
"SIZE"
    XFTPErrorType
QUOTA -> ByteString
"QUOTA"
    XFTPErrorType
DIGEST -> ByteString
"DIGEST"
    XFTPErrorType
CRYPTO -> ByteString
"CRYPTO"
    XFTPErrorType
NO_FILE -> ByteString
"NO_FILE"
    XFTPErrorType
HAS_FILE -> ByteString
"HAS_FILE"
    XFTPErrorType
FILE_IO -> ByteString
"FILE_IO"
    XFTPErrorType
TIMEOUT -> ByteString
"TIMEOUT"
    XFTPErrorType
INTERNAL -> ByteString
"INTERNAL"
    XFTPErrorType
DUPLICATE_ -> ByteString
"DUPLICATE_"

  smpP :: Parser XFTPErrorType
smpP =
    (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString ByteString
-> (ByteString -> Parser XFTPErrorType) -> Parser XFTPErrorType
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"BLOCK" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
BLOCK
      ByteString
"SESSION" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
SESSION
      ByteString
"HANDSHAKE" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
HANDSHAKE
      ByteString
"CMD" -> CommandError -> XFTPErrorType
CMD (CommandError -> XFTPErrorType)
-> Parser ByteString CommandError -> Parser XFTPErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString CommandError
forall a. Encoding a => Parser a
_smpP
      ByteString
"AUTH" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
AUTH
      ByteString
"BLOCKED" -> BlockingInfo -> XFTPErrorType
BLOCKED (BlockingInfo -> XFTPErrorType)
-> Parser ByteString BlockingInfo -> Parser XFTPErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString BlockingInfo
forall a. Encoding a => Parser a
_smpP
      ByteString
"SIZE" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
SIZE
      ByteString
"QUOTA" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
QUOTA
      ByteString
"DIGEST" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
DIGEST
      ByteString
"CRYPTO" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
CRYPTO
      ByteString
"NO_FILE" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
NO_FILE
      ByteString
"HAS_FILE" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
HAS_FILE
      ByteString
"FILE_IO" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
FILE_IO
      ByteString
"TIMEOUT" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
TIMEOUT
      ByteString
"INTERNAL" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
INTERNAL
      ByteString
"DUPLICATE_" -> XFTPErrorType -> Parser XFTPErrorType
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure XFTPErrorType
DUPLICATE_
      ByteString
_ -> FilePath -> Parser XFTPErrorType
forall a. FilePath -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"bad error type"

$(J.deriveJSON (sumTypeJSON id) ''XFTPErrorType)