From c08946214db5c3e944fceb34421f96c3011b4777 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Mon, 24 Aug 2026 20:52:57 +0000 Subject: [PATCH] implementation --- simplexmq.cabal | 2 + src/Simplex/FileTransfer/Agent.hs | 31 ++++--- src/Simplex/FileTransfer/Client.hs | 26 +++++- src/Simplex/FileTransfer/Protocol.hs | 81 +++++++++++++++--- src/Simplex/FileTransfer/Server.hs | 82 +++++++++++++------ src/Simplex/FileTransfer/Server/Env.hs | 24 ++++-- src/Simplex/FileTransfer/Server/Main.hs | 17 +++- src/Simplex/FileTransfer/Server/Store.hs | 33 +++++--- .../FileTransfer/Server/Store/Postgres.hs | 46 ++++++----- .../Server/Store/Postgres/Migrations.hs | 18 +++- src/Simplex/FileTransfer/Server/StoreLog.hs | 41 +++++++--- src/Simplex/FileTransfer/Transport.hs | 6 +- src/Simplex/FileTransfer/Types.hs | 30 ++++++- src/Simplex/Messaging/Agent.hs | 18 +++- src/Simplex/Messaging/Agent/Client.hs | 32 +++++++- .../Messaging/Agent/Store/AgentStore.hs | 19 +++-- .../Agent/Store/Postgres/Migrations/App.hs | 4 +- .../M20260823_snd_files_entitlement.hs | 21 +++++ .../Agent/Store/SQLite/Migrations/App.hs | 4 +- .../M20260823_snd_files_entitlement.hs | 20 +++++ src/Simplex/Messaging/Crypto/BBS.hs | 5 ++ src/Simplex/Messaging/Crypto/Entitlement.hs | 17 ++++ tests/AgentTests/SQLiteTests.hs | 6 +- tests/CoreTests/CryptoTests.hs | 24 ++++++ tests/XFTPClient.hs | 1 + 25 files changed, 486 insertions(+), 122 deletions(-) create mode 100644 src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs create mode 100644 src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs diff --git a/simplexmq.cabal b/simplexmq.cabal index 12eac0e7f..2fce56fbd 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -193,6 +193,7 @@ library Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc + Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement else exposed-modules: Simplex.Messaging.Agent.Store.SQLite @@ -246,6 +247,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement Simplex.Messaging.Agent.Store.SQLite.Util if flag(client_postgres) || flag(server_postgres) exposed-modules: diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index a8b220327..b3a157da3 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -22,6 +22,7 @@ module Simplex.FileTransfer.Agent -- Sending files xftpSendFile', xftpSendDescription', + xftpSetFileTime', deleteSndFileInternal, deleteSndFilesInternal, deleteSndFileRemote, @@ -54,7 +55,7 @@ import Simplex.FileTransfer.Chunks (toKB) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize) import Simplex.FileTransfer.Crypto import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), GrantedStorage, SFileParty (..)) import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types @@ -68,6 +69,7 @@ import Simplex.Messaging.Agent.Stats import Simplex.Messaging.Agent.Store.AgentStore import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.Lazy as LC @@ -350,8 +352,8 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m () notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd) -xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId -xftpSendFile' c userId file numRecipients = do +xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AM SndFileId +xftpSendFile' c userId file numRecipients credential storageTime = do g <- asks random prefixPath <- lift $ getPrefixPath "snd.xftp" createDirectory prefixPath @@ -359,7 +361,7 @@ xftpSendFile' c userId file numRecipients = do key <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window - fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing + fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing credential storageTime lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -375,7 +377,7 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect) key <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g - fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest} + fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing FSTMax lift . void $ getXFTPSndWorker True c Nothing pure fId @@ -405,7 +407,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do prepareFile _ SndFile {prefixPath = Nothing} = throwE $ INTERNAL "no prefix path" prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do - SndFile {numRecipients, chunks} <- + SndFile {numRecipients, chunks, entitlementCredential, storageTime} <- if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting then do fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath @@ -424,7 +426,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do let (pendingChunks, preparedSrvs) = partitionEithers $ map srvOrPendingChunk chunks -- concurrently? -- separate worker to create chunks? record retries and delay on snd_file_chunks? - srvs <- forM pendingChunks $ createChunk numRecipients' + srvs <- forM pendingChunks $ createChunk numRecipients' entitlementCredential storageTime let allSrvs = S.fromList $ preparedSrvs <> srvs lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv) withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading @@ -454,8 +456,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of [] -> Left ch SndFileChunkReplica {server} : _ -> Right server - createChunk :: Int -> SndFileChunk -> AM (ProtocolServer 'PXFTP) - createChunk numRecipients' ch = do + createChunk :: Int -> Maybe EntitlementCredential -> FileStorageTime -> SndFileChunk -> AM (ProtocolServer 'PXFTP) + createChunk numRecipients' credential storageTime ch = do liftIO $ assertAgentForeground c (replica, ProtoServerWithAuth srv _) <- tryCreate withStore' c $ \db -> createSndFileReplica db ch replica @@ -482,7 +484,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId when deleted $ throwE $ FILE NO_FILE withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do - replica <- agentXFTPNewChunk c ch numRecipients' srvAuth + replica <- agentXFTPNewChunk c ch numRecipients' srvAuth credential storageTime pure (replica, srvAuth) sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM () @@ -639,6 +641,15 @@ deleteSndFilesInternal c sndFileEntityIds = do batchFiles_ :: (DB.Connection -> DBSndFileId -> IO a) -> [SndFile] -> AM' () batchFiles_ f sndFiles = void $ withStoreBatch' c $ \db -> map (\SndFile {sndFileId} -> f db sndFileId) sndFiles +xftpSetFileTime' :: AgentClient -> UserId -> ValidFileDescription 'FSender -> FileStorageTime -> Maybe EntitlementCredential -> AM [GrantedStorage] +xftpSetFileTime' c userId (ValidFileDescription FileDescription {chunks}) storageTime credential = + forM (mapMaybe chunkReplica chunks) $ \(server, replicaId, replicaKey, digest) -> + agentXFTPSetChunkTime c userId server replicaId replicaKey digest storageTime credential + where + chunkReplica = \case + FileChunk {digest, replicas = FileChunkReplica {server, replicaId, replicaKey} : _} -> Just (server, replicaId, replicaKey, digest) + _ -> Nothing + deleteSndFileRemote :: AgentClient -> UserId -> SndFileId -> ValidFileDescription 'FSender -> AM' () deleteSndFileRemote c userId sndFileEntityId sfd = deleteSndFilesRemote c userId [(sndFileEntityId, sfd)] diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index a5cd4acfe..151725d4d 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -20,6 +20,8 @@ module Simplex.FileTransfer.Client xftpClientServer, xftpTransportHost, createXFTPChunk, + createXFTPChunkStorage, + setXFTPChunkTime, addXFTPRecipients, uploadXFTPChunk, downloadXFTPChunk, @@ -57,6 +59,7 @@ import Network.Socket (HostName) import Simplex.FileTransfer.Chunks import Simplex.FileTransfer.Protocol import Simplex.FileTransfer.Transport +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.Messaging.Client ( NetworkConfig (..), NetworkRequestMode (..), @@ -254,9 +257,26 @@ createXFTPChunk :: NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) -createXFTPChunk c spKey file rcps auth_ = - sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case - (FRSndIds sId rIds, body) -> noFile body (sId, rIds) +createXFTPChunk c spKey file rcps auth_ = createXFTPChunkStorage c spKey file rcps auth_ FSTMax Nothing + +createXFTPChunkStorage :: + XFTPClient -> + C.APrivateAuthKey -> + FileInfo -> + NonEmpty C.APublicAuthKey -> + Maybe BasicAuth -> + FileStorageTime -> + Maybe EntitlementProof -> + ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) +createXFTPChunkStorage c spKey file rcps auth_ storageTime proof = + sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime proof) Nothing >>= \case + (FRSndIds sId rIds _, body) -> noFile body (sId, rIds) + (r, _) -> throwE $ unexpectedResponse r + +setXFTPChunkTime :: XFTPClient -> C.APrivateAuthKey -> SenderId -> FileStorageTime -> Maybe EntitlementProof -> ExceptT XFTPClientError IO GrantedStorage +setXFTPChunkTime c spKey sId storageTime proof = + sendXFTPCommand c spKey sId (FTTL storageTime proof) Nothing >>= \case + (FRFileTime gs, body) -> noFile body gs (r, _) -> throwE $ unexpectedResponse r addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId) diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 763142c72..75abd14aa 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -22,6 +22,10 @@ module Simplex.FileTransfer.Protocol FileCommand (..), FileCmd (..), FileInfo (..), + FileStorageTime (..), + GrantedStorage (..), + xftpNewProofHeader, + xftpTimeProofHeader, XFTPFileId, FileResponse (..), xftpBlockSize, @@ -38,14 +42,17 @@ import qualified Data.Aeson.TH as J import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) import Data.Type.Equality import Data.Word (Word32) -import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, xftpClientHandshakeStub) +import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, fileStorageTimeXFTPVersion, xftpClientHandshakeStub) import Simplex.Messaging.Client (authTransmission) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..)) +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers @@ -77,7 +84,7 @@ import Simplex.Messaging.Protocol tEncodeBatch1, tParse, ) -import Simplex.Messaging.Transport (THandleParams (..), TransportError (..), TransportPeer (..)) +import Simplex.Messaging.Transport (SessionId, THandleParams (..), TransportError (..), TransportPeer (..)) import Simplex.Messaging.Util ((<$?>)) xftpBlockSize :: Int @@ -123,6 +130,7 @@ data FileCommandTag (p :: FileParty) where FADD_ :: FileCommandTag FSender FPUT_ :: FileCommandTag FSender FDEL_ :: FileCommandTag FSender + FTTL_ :: FileCommandTag FSender FGET_ :: FileCommandTag FRecipient FACK_ :: FileCommandTag FRecipient PING_ :: FileCommandTag FRecipient @@ -137,6 +145,7 @@ instance FilePartyI p => Encoding (FileCommandTag p) where FADD_ -> "FADD" FPUT_ -> "FPUT" FDEL_ -> "FDEL" + FTTL_ -> "FTTL" FGET_ -> "FGET" FACK_ -> "FACK" PING_ -> "PING" @@ -152,6 +161,7 @@ instance ProtocolMsgTag FileCmdTag where "FADD" -> Just $ FCT SFSender FADD_ "FPUT" -> Just $ FCT SFSender FPUT_ "FDEL" -> Just $ FCT SFSender FDEL_ + "FTTL" -> Just $ FCT SFSender FTTL_ "FGET" -> Just $ FCT SFRecipient FGET_ "FACK" -> Just $ FCT SFRecipient FACK_ "PING" -> Just $ FCT SFRecipient PING_ @@ -175,10 +185,11 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where {-# INLINE protocolError #-} data FileCommand (p :: FileParty) where - FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender + FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileStorageTime -> Maybe EntitlementProof -> FileCommand FSender FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender FPUT :: FileCommand FSender FDEL :: FileCommand FSender + FTTL :: FileStorageTime -> Maybe EntitlementProof -> FileCommand FSender FGET :: RcvPublicDhKey -> FileCommand FRecipient FACK :: FileCommand FRecipient PING :: FileCommand FRecipient @@ -196,15 +207,50 @@ data FileInfo = FileInfo } deriving (Show) +data FileStorageTime = FSTMax | FSTFor Word32 + deriving (Eq, Show) + +instance Encoding FileStorageTime where + smpEncode = \case + FSTMax -> "M" + FSTFor hours -> smpEncode ('F', hours) + smpP = + smpP >>= \case + 'M' -> pure FSTMax + 'F' -> FSTFor <$> smpP + _ -> fail "bad FileStorageTime" + +data GrantedStorage = GrantedExpires Int64 | GrantedPermanent + deriving (Eq, Show) + +xftpNewProofHeader :: SessionId -> SndPublicAuthKey -> ByteString -> BBSPresHeader +xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEncode sndKey <> digest + +xftpTimeProofHeader :: SessionId -> SenderId -> BBSPresHeader +xftpTimeProofHeader sessionId sId = BBSPresHeader $ sessionId <> unEntityId sId + +instance Encoding GrantedStorage where + smpEncode = \case + GrantedExpires t -> smpEncode ('F', t) + GrantedPermanent -> "P" + smpP = + smpP >>= \case + 'F' -> GrantedExpires <$> smpP + 'P' -> pure GrantedPermanent + _ -> fail "bad GrantedStorage" + type XFTPFileId = EntityId instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where type Tag (FileCommand p) = FileCommandTag p - encodeProtocol _v = \case - FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_) + encodeProtocol v = \case + FNEW file rKeys auth_ st ep + | v >= fileStorageTimeXFTPVersion -> e (FNEW_, ' ', file, rKeys, auth_, st, ep) + | otherwise -> e (FNEW_, ' ', file, rKeys, auth_) FADD rKeys -> e (FADD_, ' ', rKeys) FPUT -> e FPUT_ FDEL -> e FDEL_ + FTTL st ep -> e (FTTL_, ' ', st, ep) FGET rKey -> e (FGET_, ' ', rKey) FACK -> e FACK_ PING -> e PING_ @@ -235,13 +281,16 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where type Tag FileCmd = FileCmdTag encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c - protocolP _v = \case + protocolP v = \case FCT SFSender tag -> FileCmd SFSender <$> case tag of - FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP + FNEW_ + | v >= fileStorageTimeXFTPVersion -> FNEW <$> _smpP <*> smpP <*> smpP <*> smpP <*> smpP + | otherwise -> FNEW <$> _smpP <*> smpP <*> smpP <*> pure FSTMax <*> pure Nothing FADD_ -> FADD <$> _smpP FPUT_ -> pure FPUT FDEL_ -> pure FDEL + FTTL_ -> FTTL <$> _smpP <*> smpP FCT SFRecipient tag -> FileCmd SFRecipient <$> case tag of FGET_ -> FGET <$> _smpP @@ -266,6 +315,7 @@ data FileResponseTag = FRSndIds_ | FRRcvIds_ | FRFile_ + | FRFileTime_ | FROk_ | FRErr_ | FRPong_ @@ -276,6 +326,7 @@ instance Encoding FileResponseTag where FRSndIds_ -> "SIDS" FRRcvIds_ -> "RIDS" FRFile_ -> "FILE" + FRFileTime_ -> "TTL" FROk_ -> "OK" FRErr_ -> "ERR" FRPong_ -> "PONG" @@ -286,15 +337,17 @@ instance ProtocolMsgTag FileResponseTag where "SIDS" -> Just FRSndIds_ "RIDS" -> Just FRRcvIds_ "FILE" -> Just FRFile_ + "TTL" -> Just FRFileTime_ "OK" -> Just FROk_ "ERR" -> Just FRErr_ "PONG" -> Just FRPong_ _ -> Nothing data FileResponse - = FRSndIds SenderId (NonEmpty RecipientId) + = FRSndIds SenderId (NonEmpty RecipientId) GrantedStorage | FRRcvIds (NonEmpty RecipientId) | FRFile RcvPublicDhKey C.CbNonce + | FRFileTime GrantedStorage | FROk | FRErr XFTPErrorType | FRPong @@ -303,9 +356,12 @@ data FileResponse instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where type Tag FileResponse = FileResponseTag encodeProtocol v = \case - FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds) + FRSndIds fId rIds gs + | v >= fileStorageTimeXFTPVersion -> e (FRSndIds_, ' ', fId, rIds, gs) + | otherwise -> e (FRSndIds_, ' ', fId, rIds) FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds) FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce) + FRFileTime gs -> e (FRFileTime_, ' ', gs) FROk -> e FROk_ FRErr err -> case err of BLOCKED _ | v < blockedFilesXFTPVersion -> e (FRErr_, ' ', AUTH) @@ -315,10 +371,13 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where e :: Encoding a => a -> ByteString e = smpEncode - protocolP _v = \case - FRSndIds_ -> FRSndIds <$> _smpP <*> smpP + protocolP v = \case + FRSndIds_ + | v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP + | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure GrantedPermanent FRRcvIds_ -> FRRcvIds <$> _smpP FRFile_ -> FRFile <$> _smpP <*> smpP + FRFileTime_ -> FRFileTime <$> _smpP FROk_ -> pure FROk FRErr_ -> FRErr <$> _smpP FRPong_ -> pure FRPong diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 9f7499782..085656ed4 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -30,6 +30,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map.Strict as M import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isJust) import qualified Data.Text as T @@ -54,6 +55,8 @@ import Simplex.FileTransfer.Server.Store import Simplex.FileTransfer.Server.StoreLog import Simplex.FileTransfer.Transport import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPresHeader) +import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), entitlementIssuerKeys, verifyEntitlement) import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -125,7 +128,7 @@ data Handshake xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s () xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do - mapM_ (expireServerFiles Nothing) fileExpiration + when (isJust fileExpiration) $ expireServerFiles Nothing restoreServerStats raceAny_ ( runServer @@ -252,7 +255,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira let interval = checkInterval expCfg * 1000000 forever $ do liftIO $ threadDelay' interval - expireServerFiles (Just 100000) expCfg + expireServerFiles (Just 100000) serverStatsThread_ :: XFTPServerConfig s -> [M s ()] serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = @@ -401,9 +404,9 @@ processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHea | otherwise = case xftpDecodeTServer thParams bodyHead of Right (Right t@(_, _, (corrId, fId, _))) -> do - let THandleParams {thAuth} = thParams + let THandleParams {thAuth, sessionId} = thParams verifyXFTPTransmission thAuth t >>= \case - VRVerified req -> uncurry send =<< processXFTPRequest body req + VRVerified req -> uncurry send =<< processXFTPRequest sessionId body req VRFailed e -> send (FRErr e) Nothing where send resp = sendXFTPResponse (corrId, fId, resp) @@ -443,7 +446,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType verifyXFTPTransmission :: forall s. FileStoreClass s => Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M s VerificationResult verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = case cmd of - FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file + FileCmd SFSender (FNEW file rcps auth' st ep) -> pure $ XFTPReqNew file rcps auth' st ep `verifyWith` sndKey file FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing FileCmd party _ -> verifyCmd party where @@ -464,9 +467,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) = -- TODO verify with DH authorization req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH -processXFTPRequest :: forall s. FileStoreClass s => HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile) -processXFTPRequest HTTP2Body {bodyPart} = \case - XFTPReqNew file rks auth -> noFile =<< ifM allowNew (createFile file rks) (pure $ FRErr AUTH) +processXFTPRequest :: forall s. FileStoreClass s => SessionId -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile) +processXFTPRequest sessionId HTTP2Body {bodyPart} = \case + XFTPReqNew file rks auth storageTime ep -> noFile =<< ifM allowNew (createFile file rks storageTime ep) (pure $ FRErr AUTH) where allowNew = do XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config @@ -477,35 +480,59 @@ processXFTPRequest HTTP2Body {bodyPart} = \case FDEL -> noFile =<< deleteServerFile fr FGET rDhKey -> sendServerFile fr rDhKey FACK -> noFile =<< ackFileReception fId fr + FTTL storageTime ep -> noFile =<< setFileTime fId storageTime ep -- it should never get to the commands below, they are passed in other constructors of XFTPRequest FNEW {} -> noFile $ FRErr INTERNAL PING -> noFile $ FRErr INTERNAL XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) - createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M s FileResponse - createFile file rks = do + createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> FileStorageTime -> Maybe EntitlementProof -> M s FileResponse + createFile file@FileInfo {sndKey, digest} rks storageTime ep = do st <- asks fileStore r <- runExceptT $ do sizes <- asks $ allowedChunkSizes . config unless (size file `elem` sizes) $ throwE SIZE ts <- liftIO getFileTime + maxSeconds <- lift $ storageMaxSeconds (xftpNewProofHeader sessionId sndKey digest) ep + let (expiresAt, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime -- TODO validate body empty - sId <- ExceptT $ addFileRetry st file 3 ts + sId <- ExceptT $ addFileRetry st file 3 ts expiresAt rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks lift $ withFileLog $ \sl -> do - logAddFile sl sId file ts EntityActive + logAddFile sl sId file ts expiresAt EntityActive logAddRecipients sl sId rcps stats <- asks serverStats lift $ incFileStat filesCreated liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks) let rIds = L.map (\(FileRecipient rId _) -> rId) rcps - pure $ FRSndIds sId rIds + pure $ FRSndIds sId rIds granted pure $ either FRErr id r - addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId) - addFileRetry st file n ts = + setFileTime :: XFTPFileId -> FileStorageTime -> Maybe EntitlementProof -> M s FileResponse + setFileTime sId storageTime ep = do + st <- asks fileStore + maxSeconds <- storageMaxSeconds (xftpTimeProofHeader sessionId sId) ep + now <- liftIO $ roundedSeconds <$> getSystemSeconds + let (expiresAt, granted) = resolveStorage now maxSeconds storageTime + liftIO (setFileExpiration st sId expiresAt) >>= \case + Right () -> do + withFileLog $ \sl -> logSetFileExpiration sl sId expiresAt + pure $ FRFileTime granted + Left e -> pure $ FRErr e + storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s (Maybe Int64) + storageMaxSeconds _ Nothing = asks $ fmap ttl . fileExpiration . config + storageMaxSeconds ph (Just proof@EntitlementProof {entitlement = ent}) = do + entCfg <- asks $ fileStorageEntitlements . config + defaultMax <- asks $ fmap ttl . fileExpiration . config + now <- liftIO getCurrentTime + let Entitlement {entitlementName, expiresAt} = ent + liftIO (verifyEntitlement entitlementIssuerKeys ph proof) >>= \case + Just True | expiresAt > now -> pure $ fromMaybe defaultMax $ M.lookup entitlementName entCfg + _ -> pure defaultMax + addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId) + addFileRetry st file n ts expiresAt = retryAdd n $ \sId -> runExceptT $ do - ExceptT $ addFile st sId file ts EntityActive + ExceptT $ addFile st sId file ts expiresAt EntityActive pure sId addRecipientRetry :: s -> Int -> XFTPFileId -> RcvPublicAuthKey -> M s (Either XFTPErrorType FileRecipient) addRecipientRetry st n sId rpk = @@ -643,21 +670,30 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce getFileTime :: IO RoundedFileTime getFileTime = getRoundedSystemTime -expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s () -expireServerFiles itemDelay expCfg = do +resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, GrantedStorage) +resolveStorage base maxSeconds storageTime = (expiresAt, granted) + where + reqSeconds = case storageTime of + FSTMax -> maxSeconds + FSTFor hours -> Just $ let hSec = fromIntegral hours * 3600 in maybe hSec (min hSec) maxSeconds + expiresAt = (\s -> RoundedSystemTime (base + s)) <$> reqSeconds + granted = maybe GrantedPermanent (\(RoundedSystemTime t) -> GrantedExpires t) expiresAt + +expireServerFiles :: FileStoreClass s => Maybe Int -> M s () +expireServerFiles itemDelay = do st <- asks fileStore us <- asks usedStorage usedStart <- readTVarIO us - old <- liftIO $ expireBeforeEpoch expCfg + now <- liftIO $ roundedSeconds <$> getSystemSeconds filesCount <- liftIO $ getFileCount st logNote $ "Expiration check: " <> tshow filesCount <> " files" - expireLoop st us old + expireLoop st us now usedEnd <- readTVarIO us logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed." where mbs bs = tshow (bs `div` 1048576) <> "mb" - expireLoop st us old = do - expired <- liftIO $ expiredFiles st old 10000 + expireLoop st us now = do + expired <- liftIO $ expiredFiles st now 10000 forM_ expired $ \(sId, filePath_, fileSize) -> do mapM_ threadDelay itemDelay forM_ filePath_ $ \fp -> @@ -670,7 +706,7 @@ expireServerFiles itemDelay expCfg = do unless (null sIds) $ do withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds liftIO $ deleteFiles st sIds - expireLoop st us old + expireLoop st us now randomId :: Int -> M s ByteString randomId n = atomically . C.randomBytes n =<< asks random diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index b816eb36b..5d465a824 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -37,12 +37,16 @@ import Control.Monad import Crypto.Random import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Data.Word (Word32) import Data.X509.Validation (Fingerprint (..)) import Network.Socket import qualified Network.TLS as T -import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId) +import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), FileStorageTime, XFTPFileId) +import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.FileTransfer.Server.Stats import Data.Either (fromRight) import Data.Ini (Ini, lookupValue) @@ -89,6 +93,8 @@ data XFTPServerConfig s = XFTPServerConfig controlPortAdminAuth :: Maybe BasicAuth, -- | time after which the files can be removed and check interval, seconds fileExpiration :: Maybe ExpirationConfig, + -- | maximum storage time per entitlement name, seconds; Nothing value is permanent + fileStorageEntitlements :: Map Text (Maybe Int64), -- | timeout to receive file fileTimeout :: Int, -- | time after which inactive clients can be disconnected and check interval, seconds @@ -160,9 +166,6 @@ fromFileStore = \case #endif {-# INLINE fromFileStore #-} -defFileExpirationHours :: Int64 -defFileExpirationHours = 48 - defaultFileExpiration :: ExpirationConfig defaultFileExpiration = ExpirationConfig @@ -170,8 +173,17 @@ defaultFileExpiration = checkInterval = 2 * 3600 -- seconds, 2 hours } +storageAtLeast :: Maybe Int64 -> Maybe Int64 -> Bool +storageAtLeast Nothing _ = True +storageAtLeast (Just _) Nothing = False +storageAtLeast (Just a) (Just b) = a >= b + newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s) -newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCredentials, httpCredentials} = do +newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do + let defaultMax = ttl <$> fileExpiration + unless (all (`storageAtLeast` defaultMax) (M.elems fileStorageEntitlements)) $ do + logError "STORE: entitlement storage time is below the default file expiration" + exitFailure random <- C.newRandom (store, storeLog) <- case serverStoreCfg of XSCMemory storeLogPath -> do @@ -196,7 +208,7 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCre pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats} data XFTPRequest - = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) + = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) FileStorageTime (Maybe EntitlementProof) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 070dc546f..591b878e3 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Simplex.FileTransfer.Server.Main @@ -16,11 +17,13 @@ module Simplex.FileTransfer.Server.Main import Control.Monad (unless, when) import Data.Either (fromRight) import Data.Functor (($>)) -import Data.Ini (lookupValue, readIniFile) +import Data.Ini (Ini, lookupValue, readIniFile) import Data.Int (Int64) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.List (find) import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -291,6 +294,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do defaultFileExpiration { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini }, + fileStorageEntitlements = iniEntitlements ini, fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk inactiveClientExpiration = settingIsOn "INACTIVE_CLIENTS" "disconnect" ini @@ -437,3 +441,12 @@ cliCommandP cfgPath logPath iniFile = ( command "import" (info (pure SCImport) (progDesc "Import store log file into PostgreSQL database")) <> command "export" (info (pure SCExport) (progDesc "Export PostgreSQL database to store log file")) ) + +iniEntitlements :: Ini -> Map T.Text (Maybe Int64) +iniEntitlements ini = + M.fromList $ mapMaybe readEntitlement [("supporter", "supporter_storage_hours"), ("legend", "legend_storage_hours"), ("investor", "investor_storage_hours")] + where + readEntitlement (name, key) = (name,) <$> (parseMax =<< eitherToMaybe (lookupValue "STORE_LOG" key ini)) + parseMax t = case T.strip t of + "permanent" -> Just Nothing + s -> Just . (3600 *) <$> (readMaybe (T.unpack s) :: Maybe Int64) diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs index 66d19d6de..e124953ac 100644 --- a/src/Simplex/FileTransfer/Server/Store.hs +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -16,6 +16,7 @@ module Simplex.FileTransfer.Server.Store STMFileStore (..), RoundedFileTime, fileTimePrecision, + defFileExpirationHours, ) where @@ -55,6 +56,7 @@ data FileRec = FileRec filePath :: TVar (Maybe FilePath), recipientIds :: TVar (Set RecipientId), createdAt :: RoundedFileTime, + expiresAt :: Maybe RoundedFileTime, fileStatus :: TVar ServerEntityStatus } @@ -63,6 +65,9 @@ type RoundedFileTime = RoundedSystemTime 3600 fileTimePrecision :: Int64 fileTimePrecision = 3600 +defFileExpirationHours :: Int64 +defFileExpirationHours = 48 + data FileRecipient = FileRecipient RecipientId C.APublicAuthKey deriving (Show) @@ -74,8 +79,9 @@ class FileStoreClass s where type FileStoreConfig s newFileStore :: FileStoreConfig s -> IO s closeFileStore :: s -> IO () - addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ()) + addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ()) setFilePath :: s -> SenderId -> FilePath -> IO (Either XFTPErrorType ()) + setFileExpiration :: s -> SenderId -> Maybe RoundedFileTime -> IO (Either XFTPErrorType ()) addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ()) deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ()) deleteFiles :: s -> [SenderId] -> IO () @@ -107,9 +113,9 @@ instance FileStoreClass STMFileStore where closeFileStore STMFileStore {stmStoreLog} = readTVarIO stmStoreLog >>= mapM_ closeStoreLog - addFile STMFileStore {files} sId fileInfo createdAt status = atomically $ + addFile STMFileStore {files} sId fileInfo createdAt expiresAt status = atomically $ ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do - f <- newFileRec sId fileInfo createdAt status + f <- newFileRec sId fileInfo createdAt expiresAt status TM.insert sId f files pure $ Right () @@ -124,6 +130,11 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH + setFileExpiration STMFileStore {files} sId expiresAt = atomically $ + TM.lookup sId files >>= \case + Just fr -> Right () <$ TM.insert sId fr {expiresAt = expiresAt} files + _ -> pure $ Left AUTH + addRecipient st@STMFileStore {recipients} senderId (FileRecipient rId rKey) = atomically $ withFile st senderId $ \FileRec {recipientIds} -> do rIds <- readTVar recipientIds @@ -166,14 +177,14 @@ instance FileStoreClass STMFileStore where pure $ Right () _ -> pure $ Left AUTH - expiredFiles STMFileStore {files} old _limit = do + expiredFiles STMFileStore {files} now _limit = do fs <- readTVarIO files - fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt}) -> - if createdAt + fileTimePrecision < old - then do + fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, expiresAt}) -> + case expiresAt of + Just (RoundedSystemTime t) | t < now -> do path <- readTVarIO filePath pure $ Just (sId, path, size) - else pure Nothing + _ -> pure Nothing getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files where @@ -184,12 +195,12 @@ instance FileStoreClass STMFileStore where -- Internal STM helpers -newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec -newFileRec senderId fileInfo createdAt status = do +newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec +newFileRec senderId fileInfo createdAt expiresAt status = do recipientIds <- newTVar S.empty filePath <- newTVar Nothing fileStatus <- newTVar status - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} withFile :: STMFileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a) withFile STMFileStore {files} sId a = diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index 3b1bee05d..87b579a9d 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -82,23 +82,28 @@ instance FileStoreClass PostgresFileStore where closeDBStore dbStore mapM_ closeStoreLog dbStoreLog - addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt status = + addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt status = E.uninterruptibleMask_ $ runExceptT $ do void $ withDB "addFile" st $ \db -> E.try ( DB.execute db - "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, status) VALUES (?,?,?,?,?,?)" - (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, status) + "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, expires_at, status) VALUES (?,?,?,?,?,?,?)" + (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, expiresAt, status) ) >>= either handleDuplicate (pure . Right) - withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt status + withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt status setFilePath st sId fPath = E.uninterruptibleMask_ $ runExceptT $ do assertUpdated $ withDB' "setFilePath" st $ \db -> DB.execute db "UPDATE files SET file_path = ? WHERE sender_id = ? AND file_path IS NULL AND status = 'active'" (fPath, sId) withLog "setFilePath" st $ \s -> logPutFile s sId fPath + setFileExpiration st sId expiresAt = E.uninterruptibleMask_ $ runExceptT $ do + assertUpdated $ withDB' "setFileExpiration" st $ \db -> + DB.execute db "UPDATE files SET expires_at = ? WHERE sender_id = ?" (expiresAt, sId) + withLog "setFileExpiration" st $ \s -> logSetFileExpiration s sId expiresAt + addRecipient st senderId (FileRecipient rId rKey) = E.uninterruptibleMask_ $ runExceptT $ do void $ withDB "addRecipient" st $ \db -> E.try @@ -131,13 +136,13 @@ instance FileStoreClass PostgresFileStore where getFile st party fId = runExceptT $ case party of SFSender -> do - row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files WHERE sender_id = ?" + row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files WHERE sender_id = ?" fr <- ExceptT $ rowToFileRec row pure (fr, sndKey (fileInfo fr)) SFRecipient -> do row :. Only rcpKeyBs <- loadFileRow - "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?" + "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.expires_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?" fr <- ExceptT $ rowToFileRec row rcpKey <- either (const $ throwE INTERNAL) pure $ C.decodePubKey rcpKeyBs pure (fr, rcpKey) @@ -152,12 +157,12 @@ instance FileStoreClass PostgresFileStore where DB.execute db "DELETE FROM recipients WHERE recipient_id = ?" (Only rId) withLog "ackFile" st $ \s -> logAckFile s rId - expiredFiles st old limit = + expiredFiles st now limit = fmap toResult $ withTransaction (dbStore st) $ \db -> DB.query db - "SELECT sender_id, file_path, file_size FROM files WHERE created_at + ? < ? ORDER BY created_at LIMIT ?" - (fileTimePrecision, old, limit) + "SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? ORDER BY expires_at LIMIT ?" + (now, limit) where toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)] toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size)) @@ -174,21 +179,21 @@ instance FileStoreClass PostgresFileStore where -- Internal helpers -mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> ServerEntityStatus -> IO FileRec -mkFileRec senderId fileInfo path createdAt status = do +mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec +mkFileRec senderId fileInfo path createdAt expiresAt status = do filePath <- newTVarIO path recipientIds <- newTVarIO S.empty fileStatus <- newTVarIO status - pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} -type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, ServerEntityStatus) +type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus) rowToFileRec :: FileRecRow -> IO (Either XFTPErrorType FileRec) -rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, status) = +rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, status) = case C.decodePubKey sndKeyBs of Right sndKey -> do let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest} - Right <$> mkFileRec sId fileInfo path createdAt status + Right <$> mkFileRec sId fileInfo path createdAt expiresAt status Left _ -> pure $ Left INTERNAL -- DB helpers @@ -243,7 +248,7 @@ importFileStore storeLogFilePath dbCfg = do fCnt <- withTransaction (dbStore pgStore) $ \db -> do DB.copy_ db - "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, status) FROM STDIN WITH (FORMAT csv)" + "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status) FROM STDIN WITH (FORMAT csv)" iforM_ (M.toList allFiles) $ \i (sId, fr) -> do DB.putCopyData db =<< fileRecToCSV sId fr when (i > 0 && i `mod` 10000 == 0) $ putStr (" " <> show i <> " files\r") >> hFlush stdout @@ -282,13 +287,13 @@ exportFileStore storeLogFilePath dbCfg = do !fCnt <- withTransaction (dbStore pgStore) $ \db -> DB.fold_ db - "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files ORDER BY created_at" + "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files ORDER BY created_at" (0 :: Int) - ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, status) -> + ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, status) -> case C.decodePubKey sndKeyBs of Right sndKey -> do let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest} - logAddFile sl sId fileInfo createdAt status + logAddFile sl sId fileInfo createdAt expiresAt status forM_ path $ logPutFile sl sId pure (fc + 1) Left _ -> do @@ -326,7 +331,7 @@ iforM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m () iforM_ xs f = zipWithM_ f [0 ..] xs fileRecToCSV :: SenderId -> FileRec -> IO ByteString -fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, fileStatus} = do +fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, expiresAt, fileStatus} = do path <- readTVarIO filePath status <- readTVarIO fileStatus pure $ LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields path status) <> BB.char7 '\n' @@ -338,6 +343,7 @@ fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, renderField (toField (Binary (C.encodePubKey sndKey))), nullable (toField <$> path), renderField (toField createdAt), + nullable (toField <$> expiresAt), quotedField (toField status) ] diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs b/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs index 5e84f97e7..89130d93a 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs @@ -14,7 +14,8 @@ import Text.RawString.QQ (r) xftpSchemaMigrations :: [(String, Text, Maybe Text)] xftpSchemaMigrations = - [ ("20260325_initial", m20260325_initial, Nothing) + [ ("20260325_initial", m20260325_initial, Nothing), + ("20260823_file_expiration", m20260823_file_expiration, Just down_m20260823_file_expiration) ] -- | The list of migrations in ascending order by date @@ -45,3 +46,18 @@ CREATE TABLE recipients ( CREATE INDEX idx_recipients_sender_id ON recipients (sender_id); CREATE INDEX idx_files_created_at ON files (created_at); |] + +m20260823_file_expiration :: Text +m20260823_file_expiration = + [r| +ALTER TABLE files ADD COLUMN expires_at BIGINT; +UPDATE files SET expires_at = created_at + 48 * 3600; +CREATE INDEX idx_files_expires_at ON files (expires_at); +|] + +down_m20260823_file_expiration :: Text +down_m20260823_file_expiration = + [r| +DROP INDEX idx_files_expires_at; +ALTER TABLE files DROP COLUMN expires_at; +|] diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 48ebb175e..4ee83f38e 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -12,6 +12,7 @@ module Simplex.FileTransfer.Server.StoreLog readWriteFileStore, writeFileStore, logAddFile, + logSetFileExpiration, logPutFile, logAddRecipients, logDeleteFile, @@ -26,7 +27,7 @@ import Control.Monad.Except import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB -import Data.Composition ((.:), (.::)) +import Data.Composition ((.:)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -38,41 +39,58 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (BlockingInfo, RcvPublicAuthKey, RecipientId, SenderId) import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..)) import Simplex.Messaging.Server.StoreLog +import Simplex.Messaging.SystemTime (RoundedSystemTime (..)) import Simplex.Messaging.Util (bshow) import System.IO data FileStoreLogRecord - = AddFile SenderId FileInfo RoundedFileTime ServerEntityStatus + = AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) ServerEntityStatus | PutFile SenderId FilePath | AddRecipients SenderId (NonEmpty FileRecipient) | DeleteFile SenderId | BlockFile SenderId BlockingInfo | AckFile RecipientId -- TODO add senderId as well? + | SetFileExpiration SenderId (Maybe RoundedFileTime) deriving (Show) instance StrEncoding FileStoreLogRecord where strEncode = \case - AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) + AddFile sId file createdAt expiresAt status -> strEncode (Str "FNEW", sId, file, createdAt, status) <> " " <> maybe "P" strEncode expiresAt PutFile sId path -> strEncode (Str "FPUT", sId, path) AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps) DeleteFile sId -> strEncode (Str "FDEL", sId) BlockFile sId info -> strEncode (Str "FBLK", sId, info) AckFile rId -> strEncode (Str "FACK", rId) + SetFileExpiration sId expiresAt -> strEncode (Str "FTTL", sId) <> " " <> maybe "P" strEncode expiresAt strP = A.choice - [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP <*> (_strP <|> pure EntityActive)), + [ "FNEW " *> addFileP, "FPUT " *> (PutFile <$> strP_ <*> strP), "FADD " *> (AddRecipients <$> strP_ <*> strP), "FDEL " *> (DeleteFile <$> strP), "FBLK " *> (BlockFile <$> strP_ <*> strP), - "FACK " *> (AckFile <$> strP) + "FACK " *> (AckFile <$> strP), + "FTTL " *> (SetFileExpiration <$> strP_ <*> expiryP) ] + where + addFileP = do + sId <- strP_ + file <- strP_ + createdAt <- strP + status <- _strP <|> pure EntityActive + expiresAt <- (A.space *> expiryP) <|> pure (Just $ legacyExpiry createdAt) + pure $ AddFile sId file createdAt expiresAt status + expiryP = (Nothing <$ A.char 'P') <|> (Just <$> strP) + legacyExpiry (RoundedSystemTime c) = RoundedSystemTime (c + defFileExpirationHours * 3600) logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () logFileStoreRecord = writeStoreLogRecord -logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO () -logAddFile s = logFileStoreRecord s .:: AddFile +logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO () +logAddFile s sId file createdAt expiresAt status = logFileStoreRecord s $ AddFile sId file createdAt expiresAt status + +logSetFileExpiration :: StoreLog 'WriteMode -> SenderId -> Maybe RoundedFileTime -> IO () +logSetFileExpiration s sId expiresAt = logFileStoreRecord s $ SetFileExpiration sId expiresAt logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () logPutFile s = logFileStoreRecord s .: PutFile @@ -102,14 +120,15 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s _ -> pure () addToStore = \case - AddFile sId file createdAt status - | size file > 0 -> addFile st sId file createdAt status + AddFile sId file createdAt expiresAt status + | size file > 0 -> addFile st sId file createdAt expiresAt status | otherwise -> pure $ Left SIZE PutFile qId path -> setFilePath st qId path AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps DeleteFile sId -> deleteFile st sId BlockFile sId info -> blockFile st sId info True AckFile rId -> ackFile st rId + SetFileExpiration sId expiresAt -> setFileExpiration st sId expiresAt addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps writeFileStore :: StoreLog 'WriteMode -> STMFileStore -> IO () @@ -118,9 +137,9 @@ writeFileStore s STMFileStore {files, recipients} = do readTVarIO files >>= mapM_ (logFile allRcps) where logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO () - logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} = do + logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} = do status <- readTVarIO fileStatus - logAddFile s senderId fileInfo createdAt status + logAddFile s senderId fileInfo createdAt expiresAt status (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index d55b25148..24fa3e13c 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -12,6 +12,7 @@ module Simplex.FileTransfer.Transport ( supportedFileServerVRange, authCmdsXFTPVersion, blockedFilesXFTPVersion, + fileStorageTimeXFTPVersion, xftpClientHandshakeStub, alpnSupportedXFTPhandshakes, xftpALPNv1, @@ -97,8 +98,11 @@ authCmdsXFTPVersion = VersionXFTP 2 blockedFilesXFTPVersion :: VersionXFTP blockedFilesXFTPVersion = VersionXFTP 3 +fileStorageTimeXFTPVersion :: VersionXFTP +fileStorageTimeXFTPVersion = VersionXFTP 4 + currentXFTPVersion :: VersionXFTP -currentXFTPVersion = VersionXFTP 3 +currentXFTPVersion = VersionXFTP 4 supportedFileServerVRange :: VersionRangeXFTP supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index ff70b8f13..4b762b113 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -29,16 +29,21 @@ module Simplex.FileTransfer.Types sndChunkSize, ) where +import qualified Data.Aeson as JD import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word32) +import Text.Read (readMaybe) import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (FileStorageTime (..)) +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) @@ -167,7 +172,9 @@ data SndFile = SndFile prefixPath :: Maybe FilePath, status :: SndFileStatus, deleted :: Bool, - redirect :: Maybe RedirectFileInfo + redirect :: Maybe RedirectFileInfo, + entitlementCredential :: Maybe EntitlementCredential, + storageTime :: FileStorageTime } deriving (Show) @@ -187,6 +194,25 @@ instance FromField SndFileStatus where fromField = fromTextField_ textDecode instance ToField SndFileStatus where toField = toField . textEncode +fileStorageTimeText :: FileStorageTime -> Text +fileStorageTimeText = \case + FSTMax -> "max" + FSTFor h -> "for " <> T.pack (show h) + +fileStorageTimeParse :: Text -> Maybe FileStorageTime +fileStorageTimeParse s = case T.words s of + ["max"] -> Just FSTMax + ["for", h] -> FSTFor <$> readMaybe (T.unpack h) + _ -> Nothing + +instance ToField FileStorageTime where toField = toField . fileStorageTimeText + +instance FromField FileStorageTime where fromField = fromTextField_ fileStorageTimeParse + +instance ToField EntitlementCredential where toField = toField . decodeUtf8 . LB.toStrict . JD.encode + +instance FromField EntitlementCredential where fromField = fromTextField_ (JD.decode . LB.fromStrict . encodeUtf8) + instance TextEncoding SndFileStatus where textDecode = \case "new" -> Just SFSNew diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 979704fd3..6ef64929b 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -128,7 +128,9 @@ module Simplex.Messaging.Agent xftpDeleteRcvFile, xftpDeleteRcvFiles, xftpSendFile, + xftpSendFileStorage, xftpSendDescription, + xftpSetFileTime, xftpDeleteSndFileInternal, xftpDeleteSndFilesInternal, xftpDeleteSndFileRemote, @@ -188,9 +190,9 @@ import Data.Time.Clock import Data.Time.Clock.System (systemToUTCTime) import Data.Traversable (mapAccumL) import Data.Word (Word16) -import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile') +import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile', xftpSetFileTime') import Simplex.FileTransfer.Description (ValidFileDescription) -import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), GrantedStorage) import Simplex.FileTransfer.Types (RcvFileId, SndFileId) import Simplex.FileTransfer.Util (removePath) import Simplex.Messaging.Agent.Client @@ -211,6 +213,7 @@ import Simplex.Messaging.Server.Information (ServerPublicInfo) import qualified Simplex.Messaging.Agent.TSessionSubs as SS import Simplex.Messaging.Client (NetworkRequestMode (..), ProtocolClientError (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, TransportSessionMode (..), nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs) import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR @@ -774,14 +777,23 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c -- | Send XFTP file xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId -xftpSendFile c = withAgentEnv c .:. xftpSendFile' c +xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing FSTMax {-# INLINE xftpSendFile #-} +xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AE SndFileId +xftpSendFileStorage c userId file numRecipients credential storageTime = withAgentEnv c $ xftpSendFile' c userId file numRecipients credential storageTime +{-# INLINE xftpSendFileStorage #-} + -- | Send XFTP file xftpSendDescription :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AE SndFileId xftpSendDescription c = withAgentEnv c .:. xftpSendDescription' c {-# INLINE xftpSendDescription #-} +-- | Set XFTP file storage time on the server (all chunks in the sender description) +xftpSetFileTime :: AgentClient -> UserId -> ValidFileDescription 'FSender -> FileStorageTime -> Maybe EntitlementCredential -> AE [GrantedStorage] +xftpSetFileTime c userId vfd storageTime credential = withAgentEnv c $ xftpSetFileTime' c userId vfd storageTime credential +{-# INLINE xftpSetFileTime #-} + -- | Delete XFTP snd file internally (deletes work files from file system and db records) xftpDeleteSndFileInternal :: AgentClient -> SndFileId -> IO () xftpDeleteSndFileInternal c = withAgentEnv' c . deleteSndFileInternal c diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 45e7695b8..2d4bc5402 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -94,6 +94,7 @@ module Simplex.Messaging.Agent.Client agentXFTPUploadChunk, agentXFTPAddRecipients, agentXFTPDeleteChunk, + agentXFTPSetChunkTime, agentCbDecrypt, cryptoError, sendAck, @@ -233,7 +234,7 @@ import Network.Socket (HostName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError) import qualified Simplex.FileTransfer.Client as X import Simplex.FileTransfer.Description (ChunkReplicaId (..), FileDigest (..), kb) -import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse) +import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, FileStorageTime, GrantedStorage, xftpNewProofHeader, xftpTimeProofHeader) import Simplex.FileTransfer.Transport (XFTPErrorType (DIGEST), XFTPRcvChunkSpec (..), XFTPVersion) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types (DeletedSndChunkReplica (..), NewSndChunkReplica (..), RcvFileChunkReplica (..), SndFileChunk (..), SndFileChunkReplica (..)) @@ -253,6 +254,7 @@ import Simplex.Messaging.Agent.TSessionSubs (TSessionSubs) import qualified Simplex.Messaging.Agent.TSessionSubs as SS import Simplex.Messaging.Client import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential (..), EntitlementProof, entitlementIssuerKeys, generateEntitlementProof) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Client @@ -2186,17 +2188,26 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se g <- asks random withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec -agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> AM NewSndChunkReplica -agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do +agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe EntitlementCredential -> FileStorageTime -> AM NewSndChunkReplica +agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) credential storageTime = do rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest} logServer "-->" c srv NoEntity "FNEW" tSess <- mkTransportSession c userId srv chunkDigest - (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth + (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> do + proof <- liftIO $ mkEntitlementProof (sessionId $ X.thParams xftp) sndKey chunkDigest credential + X.createXFTPChunkStorage xftp replicaKey fileInfo (L.map fst rKeys) auth storageTime proof logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId] pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys} +mkEntitlementProof :: SessionId -> C.APublicAuthKey -> ByteString -> Maybe EntitlementCredential -> IO (Maybe EntitlementProof) +mkEntitlementProof _ _ _ Nothing = pure Nothing +mkEntitlementProof sessId sndKey digest (Just cred@EntitlementCredential {issuerKeyIdx}) = + case M.lookup issuerKeyIdx entitlementIssuerKeys of + Nothing -> pure Nothing + Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpNewProofHeader sessId sndKey digest) + agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM () agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = withXFTPClient c (userId, server, chunkDigest) "FPUT" $ \xftp -> X.uploadXFTPChunk xftp replicaKey fId chunkSpec @@ -2211,6 +2222,19 @@ agentXFTPDeleteChunk :: AgentClient -> UserId -> DeletedSndChunkReplica -> AM () agentXFTPDeleteChunk c userId DeletedSndChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey, chunkDigest = FileDigest chunkDigest} = withXFTPClient c (userId, server, chunkDigest) "FDEL" $ \xftp -> X.deleteXFTPChunk xftp replicaKey fId +agentXFTPSetChunkTime :: AgentClient -> UserId -> XFTPServer -> ChunkReplicaId -> C.APrivateAuthKey -> FileDigest -> FileStorageTime -> Maybe EntitlementCredential -> AM GrantedStorage +agentXFTPSetChunkTime c userId server (ChunkReplicaId fId) replicaKey (FileDigest chunkDigest) storageTime credential = + withXFTPClient c (userId, server, chunkDigest) "FTTL" $ \xftp -> do + proof <- liftIO $ mkEntitlementTimeProof (sessionId $ X.thParams xftp) fId credential + X.setXFTPChunkTime xftp replicaKey fId storageTime proof + +mkEntitlementTimeProof :: SessionId -> SMP.SenderId -> Maybe EntitlementCredential -> IO (Maybe EntitlementProof) +mkEntitlementTimeProof _ _ Nothing = pure Nothing +mkEntitlementTimeProof sessId sId (Just cred@EntitlementCredential {issuerKeyIdx}) = + case M.lookup issuerKeyIdx entitlementIssuerKeys of + Nothing -> pure Nothing + Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpTimeProofHeader sessId sId) + xftpRcvKeys :: Int -> AM (NonEmpty C.AAuthKeyPair) xftpRcvKeys n = do rKeys <- atomically . replicateM n . C.generateAuthKeyPair C.SEd25519 =<< asks random diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 04fbcf729..19baa394b 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -309,8 +309,9 @@ import Network.Socket (ServiceName) import qualified Network.TLS as TLS import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description -import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..)) +import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), SFileParty (..)) import Simplex.FileTransfer.Types +import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval (RI2State (..)) import Simplex.Messaging.Agent.Stats @@ -3424,13 +3425,13 @@ getRcvFilesExpired db ttl = do |] (Only cutoffTs) -createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId) -createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ = +createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe EntitlementCredential -> FileStorageTime -> IO (Either StoreError SndFileId) +createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ entitlementCredential storageTime = createWithRandomId db gVar $ \sndFileEntityId -> DB.execute db - "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)" - ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_)) + "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest, entitlement_credential, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_, entitlementCredential, storageTime)) where (redirectSize_, redirectDigest_) = case redirect_ of @@ -3466,7 +3467,7 @@ getSndFile db sndFileId = runExceptT $ do DB.query db ( [sql| - SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest + SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest, entitlement_credential, storage_time FROM snd_files WHERE snd_file_id = ? |] @@ -3476,12 +3477,12 @@ getSndFile db sndFileId = runExceptT $ do ) (Only sndFileId) where - toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile - toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_)) = + toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe EntitlementCredential, FileStorageTime) -> SndFile + toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, entitlementCredential, storageTime)) = let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ srcFile = CryptoFile srcPath cfArgs redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_ - in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []} + in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, entitlementCredential, storageTime, chunks = []} getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk] getChunks sndFileEntityId userId numRecipients filePrefixPath = do chunks <- diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs index 1997b5c2a..de6e3f182 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs @@ -14,6 +14,7 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251230_strict_tables import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -27,7 +28,8 @@ schemaMigrations = ("20251230_strict_tables", m20251230_strict_tables, Just down_m20251230_strict_tables), ("20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts), ("20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs), - ("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc) + ("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc), + ("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs new file mode 100644 index 000000000..50b517c1a --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260823_snd_files_entitlement :: Text +m20260823_snd_files_entitlement = + [r| +ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; +ALTER TABLE snd_files ADD COLUMN storage_time TEXT NOT NULL DEFAULT 'max'; +|] + +down_m20260823_snd_files_entitlement :: Text +down_m20260823_snd_files_entitlement = + [r| +ALTER TABLE snd_files DROP COLUMN storage_time; +ALTER TABLE snd_files DROP COLUMN entitlement_credential; +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs index 69cc74cfe..3585f42c2 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs @@ -50,6 +50,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251230_strict_tables import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -99,7 +100,8 @@ schemaMigrations = ("m20251230_strict_tables", m20251230_strict_tables, Just down_m20251230_strict_tables), ("m20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts), ("m20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs), - ("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc) + ("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc), + ("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs new file mode 100644 index 000000000..859786ebb --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20260823_snd_files_entitlement :: Query +m20260823_snd_files_entitlement = + [sql| +ALTER TABLE snd_files ADD COLUMN entitlement_credential TEXT; +ALTER TABLE snd_files ADD COLUMN storage_time TEXT NOT NULL DEFAULT 'max'; + |] + +down_m20260823_snd_files_entitlement :: Query +down_m20260823_snd_files_entitlement = + [sql| +ALTER TABLE snd_files DROP COLUMN storage_time; +ALTER TABLE snd_files DROP COLUMN entitlement_credential; + |] diff --git a/src/Simplex/Messaging/Crypto/BBS.hs b/src/Simplex/Messaging/Crypto/BBS.hs index 7b19ca004..332124d36 100644 --- a/src/Simplex/Messaging/Crypto/BBS.hs +++ b/src/Simplex/Messaging/Crypto/BBS.hs @@ -33,6 +33,7 @@ import Data.Proxy (Proxy (..)) import Foreign import Foreign.C import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal) +import Simplex.Messaging.Encoding (Encoding (..), Large (..)) import Simplex.Messaging.Encoding.String import System.IO.Unsafe (unsafePerformIO) @@ -106,6 +107,10 @@ instance StrEncoding BBSProof where then pure (BBSProof bs) else fail $ "BBS: invalid proof length " <> show len +instance Encoding BBSProof where + smpEncode (BBSProof p) = smpEncode (Large p) + smpP = (\(Large p) -> BBSProof p) <$> smpP + -- FFI data BBS_Ciphersuite diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs index 106bb4683..529589a5c 100644 --- a/src/Simplex/Messaging/Crypto/Entitlement.hs +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -34,7 +34,9 @@ import qualified Data.Map.Strict as M import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) +import Data.Word (Word16) import Simplex.Messaging.Crypto.BBS +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON) @@ -68,6 +70,21 @@ data EntitlementProof = EntitlementProof } deriving (Eq, Show) +instance Encoding Entitlement where + smpEncode Entitlement {entitlementName, expiresAt, extraInfo} = + smpEncode (entitlementName, strEncode expiresAt, extraInfo) + smpP = do + (name, expBs, extra) <- smpP + expiresAt <- either fail pure $ strDecode (expBs :: ByteString) + pure Entitlement {entitlementName = name, expiresAt, extraInfo = extra} + +instance Encoding EntitlementProof where + smpEncode EntitlementProof {issuerKeyIdx, proof, entitlement} = + smpEncode (fromIntegral issuerKeyIdx :: Word16, proof, entitlement) + smpP = do + (idx, proof, entitlement) <- smpP + pure EntitlementProof {issuerKeyIdx = fromIntegral (idx :: Word16), proof, entitlement} + entitlementBBSHeader :: BBSHeader entitlementBBSHeader = BBSHeader "SimpleX entitlement v1" diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 6aea60ff3..157a03083 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -782,7 +782,7 @@ testGetNextSndFileToPrepare st = do -- Can't test it with strict tables -- Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing -- DB.execute_ db "UPDATE snd_files SET status = 'new', num_recipients = 'bad' WHERE snd_file_id = 1" - Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing + Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax DB.execute_ db "UPDATE snd_files SET status = 'new' WHERE snd_file_id = 2" -- Left e <- getNextSndFileToPrepare db 86400 @@ -808,13 +808,13 @@ testGetNextSndChunkToUpload st = do Right Nothing <- getNextSndChunkToUpload db xftpServer1 86400 -- create file 1 - Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing + Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax updateSndFileEncrypted db 1 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")] -- Can't test it with strict tables -- createSndFileReplica_ db 1 newSndChunkReplica1 -- DB.execute_ db "UPDATE snd_files SET num_recipients = 'bad' WHERE snd_file_id = 1" -- create file 2 - Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing + Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing FSTMax updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")] createSndFileReplica_ db 2 newSndChunkReplica1 diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index a7cf4f9ba..635b4ebf6 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -13,7 +13,10 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (isLeft, isRight) import Data.Int (Int64) +import qualified Data.Map.Strict as M import qualified Data.Text as T +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime (..)) import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LE @@ -25,6 +28,7 @@ import qualified SMPClient import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.Lazy as LC import Simplex.Messaging.Crypto.BBS +import Simplex.Messaging.Crypto.Entitlement import Simplex.Messaging.Crypto.SNTRUP761.Bindings import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines import Simplex.Messaging.Encoding (Large (..), smpDecode, smpEncode) @@ -119,6 +123,8 @@ cryptoTests = do it "should produce unlinkable proofs" testBBSUnlinkable it "should produce proof of expected size" testBBSProofSize it "should roundtrip JSON and reject wrong-length input" testBBSJSON + describe "Entitlement" $ do + it "should sign, prove and verify, bound to the presentation header" testEntitlementRoundtrip instance Eq C.APublicKey where C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of @@ -444,3 +450,21 @@ testBBSJSON = do -- FromJSON must reject wrong-length input (regression: StrJSON length validation) (J.decode (J.encode (BBSSecretKey (B.replicate 16 '\0'))) :: Maybe BBSSecretKey) `shouldBe` Nothing (J.decode (J.encode (BBSSignature (B.replicate 10 '\0'))) :: Maybe BBSSignature) `shouldBe` Nothing + +testEntitlementRoundtrip :: IO () +testEntitlementRoundtrip = do + Right (pk, sk) <- bbsKeyGen + let keys = M.singleton 1 pk + mk = MasterKey (B.replicate 32 '\7') + ent = Entitlement {entitlementName = "supporter", expiresAt = UTCTime (fromGregorian 2030 1 1) 0, extraInfo = ""} + ph = BBSPresHeader "session-id + snd-key + digest" + Right cred <- signEntitlement sk 1 mk ent + verifyCredential pk cred `shouldReturn` True + Right proof <- generateEntitlementProof pk cred ph + verifyEntitlement keys ph proof `shouldReturn` Just True + -- a different presentation header does not verify (session/chunk binding) + verifyEntitlement keys (BBSPresHeader "other") proof `shouldReturn` Just False + -- an unknown issuer key index yields Nothing + verifyEntitlement (M.singleton 2 pk) ph proof `shouldReturn` Nothing + -- the protocol encoding of the proof roundtrips + smpDecode (smpEncode proof) `shouldBe` Right proof diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index b306ae39c..d8280ef6e 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -182,6 +182,7 @@ testXFTPServerConfig = controlPortAdminAuth = Nothing, controlPortUserAuth = Nothing, fileExpiration = Just defaultFileExpiration, + fileStorageEntitlements = mempty, fileTimeout = 10000000, inactiveClientExpiration = Just defaultInactiveClientExpiration, xftpCredentials =