diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 5aba9a58b..b26fc5fdf 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -107,8 +108,7 @@ instance Protocol FileResponse where _ -> Nothing data FileCommand (p :: FileParty) where - -- Sender key, recipients keys, chunk size - FNEW :: SndPublicVerifyKey -> NonEmpty RcvPublicVerifyKey -> Word32 -> FileCommand Sender + FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand Sender FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender FPUT :: FileCommand Sender FDEL :: FileCommand Sender @@ -122,14 +122,21 @@ data FileCmd = forall p. FilePartyI p => FileCmd (SFileParty p) (FileCommand p) deriving instance Show FileCmd +data FileInfo = FileInfo + { sndKey :: SndPublicVerifyKey, + size :: Word32, + digest :: ByteString + } + deriving (Eq, Show) + instance FilePartyI p => ProtocolEncoding (FileCommand p) where type Tag (FileCommand p) = FileCommandTag p encodeProtocol _v = \case - FNEW sKey dhKeys chunkSize -> e (FNEW_, ' ', sKey, dhKeys, chunkSize) - FADD dhKeys -> e (FADD_, ' ', dhKeys) + FNEW file rKeys -> e (FNEW_, ' ', file, rKeys) + FADD rKeys -> e (FADD_, ' ', rKeys) FPUT -> e FPUT_ FDEL -> e FDEL_ - FGET dhKey -> e (FGET_, ' ', dhKey) + FGET rKey -> e (FGET_, ' ', rKey) FACK -> e FACK_ PING -> e PING_ where @@ -155,7 +162,7 @@ instance ProtocolEncoding FileCmd where protocolP _v = \case FCT SSender tag -> FileCmd SSender <$> case tag of - FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP + FNEW_ -> FNEW <$> _smpP <*> smpP FADD_ -> FADD <$> _smpP FPUT_ -> pure FPUT FDEL_ -> pure FDEL @@ -167,6 +174,10 @@ instance ProtocolEncoding FileCmd where checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c +instance Encoding FileInfo where + smpEncode FileInfo {sndKey, size, digest} = smpEncode (sndKey, size, digest) + smpP = FileInfo <$> smpP <*> smpP <*> smpP + data FileResponseTag = FRChunkIds_ | FRRcvIds_ diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index ecd563d46..da6eb4331 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -17,6 +17,7 @@ import Control.Concurrent.STM import Data.Functor (($>)) import Data.Set (Set) import qualified Data.Set as S +import Simplex.FileTransfer.Protocol (FileInfo) import Simplex.Messaging.Protocol hiding (SParty, SRecipient, SSender) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM @@ -29,9 +30,9 @@ data FileStore = FileStore data FileRec = FileRec { senderId :: SenderId, - senderKey :: SndPublicVerifyKey, - recipientIds :: TVar (Set RecipientId), - filepath :: TVar (Maybe FilePath) + fileInfo :: FileInfo, + filePath :: TVar (Maybe FilePath), + recipientIds :: TVar (Set RecipientId) } deriving (Eq) @@ -41,23 +42,23 @@ newQueueStore = do recipients <- TM.empty pure FileStore {files, recipients} -addFile :: FileStore -> SenderId -> SndPublicVerifyKey -> STM (Either ErrorType ()) -addFile FileStore {files} sId sKey = +addFile :: FileStore -> SenderId -> FileInfo -> STM (Either ErrorType ()) +addFile FileStore {files} sId fileInfo = ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do - f <- newFileRec sId sKey + f <- newFileRec sId fileInfo TM.insert sId f files pure $ Right () -newFileRec :: SenderId -> SndPublicVerifyKey -> STM FileRec -newFileRec senderId senderKey = do +newFileRec :: SenderId -> FileInfo -> STM FileRec +newFileRec senderId fileInfo = do recipientIds <- newTVar S.empty - filepath <- newTVar Nothing - pure FileRec {senderId, senderKey, recipientIds, filepath} + filePath <- newTVar Nothing + pure FileRec {senderId, fileInfo, filePath, recipientIds} setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either ErrorType ()) setFilePath st sId fPath = - withFile st sId $ \FileRec {filepath} -> - writeTVar filepath (Just fPath) $> Right () + withFile st sId $ \FileRec {filePath} -> + writeTVar filePath (Just fPath) $> Right () addRecipient :: FileStore -> SenderId -> (RecipientId, RcvPublicVerifyKey) -> STM (Either ErrorType ()) addRecipient st@FileStore {recipients} senderId recipient@(rId, _) = @@ -82,8 +83,6 @@ deleteFile FileStore {files, recipients} senderId = do getFile :: FileStore -> SenderId -> STM (Either ErrorType FileRec) getFile st sId = withFile st sId $ pure . Right --- TODO possibly, if acknowledgement of file reception by the last recipient --- is going to lead to deleting the file this has to be updated and return some value to delete the actual file ackFile :: FileStore -> RecipientId -> STM (Either ErrorType ()) ackFile st@FileStore {recipients} recipientId = do TM.lookupDelete recipientId recipients >>= \case