mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-01 18:08:36 +00:00
refactor
This commit is contained in:
Evgeny @ SimpleX Chat
@@ -58,7 +58,7 @@ xftpSubsts XFTPServerConfig {fileExpiration, logStatsInterval, allowNewFiles, ne
|
||||
[("smpConfig", Nothing), ("xftpConfig", Just "y")] <> substConfig <> serverInfoSubsts simplexmqSource information <> [("onionHost", strEncode <$> onionHost), ("iniFileName", Just "file-server.ini")]
|
||||
where
|
||||
substConfig =
|
||||
[ ("fileExpiration", Just $ maybe "Never" (fromString . timedTTLText . ttl) fileExpiration),
|
||||
[ ("fileExpiration", Just . fromString . timedTTLText . ttl $ fileExpiration),
|
||||
("statsEnabled", Just . yesNo $ isJust logStatsInterval),
|
||||
("newUploadsAllowed", Just . yesNo $ allowNewFiles),
|
||||
("basicAuthEnabled", Just . yesNo $ isJust newFileBasicAuth)
|
||||
|
||||
@@ -47,20 +47,14 @@ In `Simplex.FileTransfer.Transport`:
|
||||
|
||||
In `Simplex.FileTransfer.Protocol`:
|
||||
|
||||
- add `FileStorageTime` and its encoding:
|
||||
|
||||
```
|
||||
data FileStorageTime = FSMaxTime | FSTime {hours :: Word32}
|
||||
```
|
||||
|
||||
- add `GrantedStorageTime` and its encoding; retain the one-character sum prefix for future variants:
|
||||
|
||||
```
|
||||
data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
|
||||
```
|
||||
|
||||
- add the `FileStorageTime` and `Maybe EntitlementProof` fields to `FNEW`
|
||||
- add the granted storage to `FRSndIds`
|
||||
- add the storage time (`Maybe Int64`: `Nothing` requests the server maximum, `Just` a number of hours) and `Maybe EntitlementProof` fields to `FNEW`
|
||||
- add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version)
|
||||
- build the presentation header for FNEW
|
||||
|
||||
In `Simplex.FileTransfer.Server`:
|
||||
@@ -71,30 +65,32 @@ In `Simplex.FileTransfer.Server`:
|
||||
|
||||
In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`:
|
||||
|
||||
- read a maximum storage time for each entitlement name from the INI file, as a number of hours
|
||||
- make `fileExpiration` non-optional (`ExpirationConfig`, no longer `Maybe`); the server always expires files, so the server maximum is always a concrete number of seconds
|
||||
- read a maximum storage time (a number of hours) for each entitlement name from the `[STORE_LOG]` INI section, from the keys `expire_files_hours_for_supporter` and `expire_files_hours_for_legend`
|
||||
- exit at startup if any name's maximum is below the default file expiration
|
||||
- read the issuer public keys from the shared constant
|
||||
|
||||
## simplexmq: server store and expiration
|
||||
|
||||
The `files` table gets a nullable `expires_at`. `expires_at IS NULL` means "no explicit expiry — apply the configured default" (`created_at + ttl`); this covers legacy rows, which the migration must not re-date, since it has no access to the operator's configured TTL.
|
||||
The `files` table gets a nullable `expires_at`. Every new file stores a concrete `expires_at`. It is NULL only for pre-feature rows, which the migration must not re-date (it has no access to the operator's configured TTL); those are expired at query time as `created_at + ttl`.
|
||||
|
||||
Common to both stores, in `Simplex.FileTransfer.Server.Store`:
|
||||
|
||||
- add `expiresAt :: Maybe RoundedFileTime` to `FileRec`
|
||||
- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the requested time against the entitlement's maximum, store `expiresAt` from the resolution, and return the granted storage
|
||||
- `expiredFiles` takes the configured default TTL and expires a file when `COALESCE(expiresAt, created_at + ttl) < now`
|
||||
- retain `created_at` for statistics, export, and the default-expiry fallback
|
||||
- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, cap the requested hours at the entitlement's maximum, round the expiry up to the hour, store it, and return that same value as the granted storage
|
||||
- a valid proof raises the maximum to the entitlement's configured value; a proof that fails verification, carries an unknown issuer key, or whose entitlement expired more than 24 hours ago falls back to the default maximum. The entitlement is honoured for 24 hours after its `expiresAt`.
|
||||
- `expiredFiles` receives `now` and `old` (= `now - ttl`). A stored expiry is deleted when `expires_at < now` (no grace — it is already rounded up); a legacy row (no `expires_at`) is deleted when `created_at + fileTimePrecision < old` (the grace covers `created_at` being floored to the hour)
|
||||
- retain `created_at` for statistics, export, and the legacy fallback
|
||||
|
||||
STM store:
|
||||
|
||||
- in `expiredFiles`, expire a file when `maybe (created_at + ttl) roundedSeconds expiresAt < now`
|
||||
- in `expiredFiles`, expire a new file when `roundedSeconds expiresAt < now`, and a legacy file (no `expiresAt`) when `created_at + fileTimePrecision < old`
|
||||
|
||||
PostgreSQL store, in `Simplex.FileTransfer.Server.Store.Postgres` and its migrations:
|
||||
|
||||
- add the nullable column `expires_at BIGINT` (no backfill)
|
||||
- add one composite index `idx_files_expiry ON files (expires_at, created_at)`
|
||||
- `expiredFiles` query: `WHERE (expires_at < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?` with `(now, now - ttl)`. Keep the `OR` at the top level so each disjunct is independently indexable (BitmapOr on the composite index): `expires_at` covers arm 1's range and arm 2's `IS NULL` group, and `created_at` orders arm 2 within that group. A `COALESCE(expires_at, created_at + ttl)` predicate is avoided (not sargable, would force a sequential scan). No `ORDER BY` — the batch loop deletes all expired rows regardless of order.
|
||||
- `expiredFiles` query: `WHERE (expires_at < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?` with `(now, old - fileTimePrecision)`. The first arm deletes stored (already rounded-up) expiries; the second drains legacy rows, with the grace folded into `old - fileTimePrecision` so the columns stay bare and sargable. Keep the `OR` at the top level so each disjunct is independently indexable (BitmapOr on the composite index): `expires_at` covers arm 1's range and arm 2's `IS NULL` group, and `created_at` orders arm 2 within that group. A `COALESCE(expires_at, created_at + ttl)` predicate is avoided (not sargable, would force a sequential scan). No `ORDER BY` — the batch loop deletes all expired rows regardless of order.
|
||||
|
||||
Store log, in `Simplex.FileTransfer.Server.StoreLog`:
|
||||
|
||||
@@ -104,11 +100,11 @@ Store log, in `Simplex.FileTransfer.Server.StoreLog`:
|
||||
|
||||
Public API in `Simplex.Messaging.Agent`:
|
||||
|
||||
- add `Maybe EntitlementCredential` and `FileStorageTime` parameters to `xftpSendFile` and `xftpSendDescription`
|
||||
- add `Maybe EntitlementCredential` and storage time (`Maybe Int64` hours) parameters to `xftpSendFile`
|
||||
|
||||
Store, in both the SQLite and PostgreSQL agent stores:
|
||||
|
||||
- add a nullable entitlement credential column and a storage time column to `snd_files`
|
||||
- add a nullable entitlement credential column (JSON text) and a nullable storage time column (integer hours; NULL means the server maximum) to `snd_files`
|
||||
- add the migration to both stores
|
||||
- in `createSndFile`, store the credential and the storage time
|
||||
|
||||
@@ -130,7 +126,7 @@ Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`:
|
||||
## Order
|
||||
|
||||
1. Add the entitlement crypto module; move chat's badge verification onto it and remove lifetime badges.
|
||||
2. Add `FileStorageTime`, the new XFTP version, the FNEW protocol change, and the response.
|
||||
2. Add the new XFTP version, the FNEW protocol change (storage time + proof), and the response.
|
||||
3. Change the server configuration, store, expiration, and store log.
|
||||
4. Change the agent store and add proof generation on upload.
|
||||
5. Wire chat to pass the credential and the storage time.
|
||||
|
||||
@@ -26,13 +26,11 @@ The presentation header that the BBS proof is generated over is not transmitted;
|
||||
## Storage time
|
||||
|
||||
```
|
||||
fileStorageTime = storageMax / storageFor
|
||||
storageMax = %s"M"
|
||||
storageFor = %s"F" storageHours
|
||||
storageHours = 4*4 OCTET ; Word32, network byte order
|
||||
fileStorageTime = %s"0" / (%s"1" storageHours)
|
||||
storageHours = 8*8 OCTET ; Int64, network byte order
|
||||
```
|
||||
|
||||
`storageMax` requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. `storageFor` requests a specific number of hours.
|
||||
The storage time is an optional number of hours. Absent (`%s"0"`) requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value (`%s"1"` with hours) requests a specific number of hours.
|
||||
|
||||
## Commands, new XFTP version
|
||||
|
||||
@@ -50,13 +48,14 @@ optEntitlementProof = %s"0" / (%s"1" entitlementProof)
|
||||
FNEW extends the SIDS response with the granted storage.
|
||||
|
||||
```
|
||||
sndIds = %s"SIDS " senderId rcvIds grantedStorageTime
|
||||
sndIds = %s"SIDS " senderId rcvIds optGrantedStorageTime
|
||||
optGrantedStorageTime = %s"0" / (%s"1" grantedStorageTime)
|
||||
grantedStorageTime = grantedExpires
|
||||
grantedExpires = %s"F" expiresAt
|
||||
grantedExpires = %s"T" expiresAt
|
||||
expiresAt = 8*8 OCTET ; Int64, seconds since epoch (absolute UTC instant), network byte order
|
||||
```
|
||||
|
||||
`grantedExpires` returns the absolute expiration. The sum encoding retains a one-character prefix so further variants can be added. `senderId` and `rcvIds` are defined by the current XFTP protocol.
|
||||
`grantedExpires` returns the absolute expiration — the same value stored for the file. The sum encoding retains a one-character prefix so further variants can be added. Version 3 and earlier omit `optGrantedStorageTime` entirely; a client decoding such a response reads it as absent. `senderId` and `rcvIds` are defined by the current XFTP protocol.
|
||||
|
||||
## Binding
|
||||
|
||||
@@ -70,9 +69,9 @@ The chunk is identified by the sender key and the digest, which the server verif
|
||||
|
||||
## Maximum storage time
|
||||
|
||||
The server configures a maximum storage time for each entitlement name, and a default maximum for requests with no proof. Each maximum is a number of hours. The server exits at startup if any name's maximum is below the default, so a proof never reduces the allowed time. The server treats an entitlement whose expiration has passed as no proof.
|
||||
The server configures a maximum storage time for each entitlement name, and a default maximum for requests with no proof. Each maximum is a number of hours. The server exits at startup if any name's maximum is below the default, so a proof never reduces the allowed time. The server honours an entitlement for 24 hours after its expiration; past that grace it is treated as no proof.
|
||||
|
||||
If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request.
|
||||
If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request. The expiration is rounded up to the hour, stored, and returned as `grantedExpires`.
|
||||
|
||||
## Encoding primitives
|
||||
|
||||
|
||||
@@ -54,7 +54,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 (..), FileStorageTime (..), SFileParty (..))
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
|
||||
import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
|
||||
import qualified Simplex.FileTransfer.Transport as XFTP
|
||||
import Simplex.FileTransfer.Types
|
||||
@@ -351,7 +351,7 @@ 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 -> Maybe EntitlementCredential -> FileStorageTime -> AM SndFileId
|
||||
xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AM SndFileId
|
||||
xftpSendFile' c userId file numRecipients credential storageTime = do
|
||||
g <- asks random
|
||||
prefixPath <- lift $ getPrefixPath "snd.xftp"
|
||||
@@ -376,7 +376,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}) Nothing FSMaxTime
|
||||
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing Nothing
|
||||
lift . void $ getXFTPSndWorker True c Nothing
|
||||
pure fId
|
||||
|
||||
@@ -455,7 +455,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
|
||||
srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of
|
||||
[] -> Left ch
|
||||
SndFileChunkReplica {server} : _ -> Right server
|
||||
createChunk :: Int -> Maybe EntitlementCredential -> FileStorageTime -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
|
||||
createChunk :: Int -> Maybe EntitlementCredential -> Maybe Int64 -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
|
||||
createChunk numRecipients' credential storageTime ch = do
|
||||
liftIO $ assertAgentForeground c
|
||||
(replica, ProtoServerWithAuth srv _) <- tryCreate
|
||||
|
||||
@@ -20,7 +20,6 @@ module Simplex.FileTransfer.Client
|
||||
xftpClientServer,
|
||||
xftpTransportHost,
|
||||
createXFTPChunk,
|
||||
createXFTPChunkStorage,
|
||||
addXFTPRecipients,
|
||||
uploadXFTPChunk,
|
||||
downloadXFTPChunk,
|
||||
@@ -255,19 +254,10 @@ createXFTPChunk ::
|
||||
FileInfo ->
|
||||
NonEmpty C.APublicAuthKey ->
|
||||
Maybe BasicAuth ->
|
||||
ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
|
||||
createXFTPChunk c spKey file rcps auth_ = createXFTPChunkStorage c spKey file rcps auth_ FSMaxTime Nothing
|
||||
|
||||
createXFTPChunkStorage ::
|
||||
XFTPClient ->
|
||||
C.APrivateAuthKey ->
|
||||
FileInfo ->
|
||||
NonEmpty C.APublicAuthKey ->
|
||||
Maybe BasicAuth ->
|
||||
FileStorageTime ->
|
||||
Maybe Int64 ->
|
||||
Maybe EntitlementProof ->
|
||||
ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
|
||||
createXFTPChunkStorage c spKey file rcps auth_ storageTime proof =
|
||||
createXFTPChunk 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
|
||||
|
||||
@@ -328,7 +328,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
|
||||
digest <- liftIO $ getChunkDigest chunkSpec
|
||||
let ch = FileInfo {sndKey, size = chunkSize, digest}
|
||||
c <- withRetry retryCount $ getXFTPServerClient a xftpServer
|
||||
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
|
||||
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth Nothing Nothing
|
||||
withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
|
||||
logDebug $ "uploaded chunk " <> tshow chunkNo
|
||||
uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
|
||||
|
||||
@@ -22,7 +22,6 @@ module Simplex.FileTransfer.Protocol
|
||||
FileCommand (..),
|
||||
FileCmd (..),
|
||||
FileInfo (..),
|
||||
FileStorageTime (..),
|
||||
GrantedStorageTime (..),
|
||||
xftpNewProofHeader,
|
||||
XFTPFileId,
|
||||
@@ -181,7 +180,7 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where
|
||||
{-# INLINE protocolError #-}
|
||||
|
||||
data FileCommand (p :: FileParty) where
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileStorageTime -> Maybe EntitlementProof -> FileCommand FSender
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> Maybe Int64 -> Maybe EntitlementProof -> FileCommand FSender
|
||||
FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender
|
||||
FPUT :: FileCommand FSender
|
||||
FDEL :: FileCommand FSender
|
||||
@@ -202,19 +201,6 @@ data FileInfo = FileInfo
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data FileStorageTime = FSMaxTime | FSTime {hours :: Word32}
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Encoding FileStorageTime where
|
||||
smpEncode = \case
|
||||
FSMaxTime -> "M"
|
||||
FSTime hours -> smpEncode ('F', hours)
|
||||
smpP =
|
||||
smpP >>= \case
|
||||
'M' -> pure FSMaxTime
|
||||
'F' -> FSTime <$> smpP
|
||||
_ -> fail "bad FileStorageTime"
|
||||
|
||||
data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -223,10 +209,10 @@ xftpNewProofHeader sessionId sndKey digest = BBSPresHeader $ sessionId <> smpEnc
|
||||
|
||||
instance Encoding GrantedStorageTime where
|
||||
smpEncode = \case
|
||||
GSTExpires t -> smpEncode ('F', t)
|
||||
GSTExpires t -> smpEncode ('T', t)
|
||||
smpP =
|
||||
smpP >>= \case
|
||||
'F' -> GSTExpires <$> smpP
|
||||
'T' -> GSTExpires <$> smpP
|
||||
_ -> fail "bad GrantedStorageTime"
|
||||
|
||||
type XFTPFileId = EntityId
|
||||
@@ -235,8 +221,10 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand
|
||||
type Tag (FileCommand p) = FileCommandTag p
|
||||
encodeProtocol v = \case
|
||||
FNEW file rKeys auth_ st ep
|
||||
| v >= fileStorageTimeXFTPVersion -> e (FNEW_, ' ', file, rKeys, auth_, st, ep)
|
||||
| otherwise -> e (FNEW_, ' ', file, rKeys, auth_)
|
||||
| v >= fileStorageTimeXFTPVersion -> fnew <> e (st, ep)
|
||||
| otherwise -> fnew
|
||||
where
|
||||
fnew = e (FNEW_, ' ', file, rKeys, auth_)
|
||||
FADD rKeys -> e (FADD_, ' ', rKeys)
|
||||
FPUT -> e FPUT_
|
||||
FDEL -> e FDEL_
|
||||
@@ -274,8 +262,10 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
|
||||
FCT SFSender tag ->
|
||||
FileCmd SFSender <$> case tag of
|
||||
FNEW_
|
||||
| v >= fileStorageTimeXFTPVersion -> FNEW <$> _smpP <*> smpP <*> smpP <*> smpP <*> smpP
|
||||
| otherwise -> FNEW <$> _smpP <*> smpP <*> smpP <*> pure FSMaxTime <*> pure Nothing
|
||||
| v >= fileStorageTimeXFTPVersion -> fnewP smpP smpP
|
||||
| otherwise -> fnewP (pure Nothing) (pure Nothing)
|
||||
where
|
||||
fnewP stP epP = FNEW <$> _smpP <*> smpP <*> smpP <*> stP <*> epP
|
||||
FADD_ -> FADD <$> _smpP
|
||||
FPUT_ -> pure FPUT
|
||||
FDEL_ -> pure FDEL
|
||||
@@ -329,7 +319,7 @@ instance ProtocolMsgTag FileResponseTag where
|
||||
_ -> Nothing
|
||||
|
||||
data FileResponse
|
||||
= FRSndIds SenderId (NonEmpty RecipientId) GrantedStorageTime
|
||||
= FRSndIds SenderId (NonEmpty RecipientId) (Maybe GrantedStorageTime)
|
||||
| FRRcvIds (NonEmpty RecipientId)
|
||||
| FRFile RcvPublicDhKey C.CbNonce
|
||||
| FROk
|
||||
@@ -357,7 +347,7 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
|
||||
protocolP v = \case
|
||||
FRSndIds_
|
||||
| v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP
|
||||
| otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure (GSTExpires 0)
|
||||
| otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure Nothing
|
||||
FRRcvIds_ -> FRRcvIds <$> _smpP
|
||||
FRFile_ -> FRFile <$> _smpP <*> smpP
|
||||
FROk_ -> pure FROk
|
||||
|
||||
@@ -35,7 +35,7 @@ import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
|
||||
import Data.Time.Clock (UTCTime (..), addUTCTime, diffTimeToPicoseconds, getCurrentTime, nominalDay)
|
||||
import Data.Time.Format.ISO8601 (iso8601Show)
|
||||
import Data.Word (Word32)
|
||||
import qualified Data.X509 as X
|
||||
@@ -128,12 +128,12 @@ data Handshake
|
||||
|
||||
xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s ()
|
||||
xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
|
||||
when (isJust fileExpiration) $ expireServerFiles Nothing
|
||||
expireServerFiles Nothing fileExpiration
|
||||
restoreServerStats
|
||||
raceAny_
|
||||
( runServer
|
||||
: expireFilesThread_ cfg
|
||||
<> serverStatsThread_ cfg
|
||||
: expireFiles fileExpiration
|
||||
: serverStatsThread_ cfg
|
||||
<> prometheusMetricsThread_ cfg
|
||||
<> controlPortThread_ cfg
|
||||
)
|
||||
@@ -246,16 +246,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
saveServerStats
|
||||
logNote "Server stopped"
|
||||
|
||||
expireFilesThread_ :: XFTPServerConfig s -> [M s ()]
|
||||
expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
|
||||
expireFilesThread_ _ = []
|
||||
|
||||
expireFiles :: ExpirationConfig -> M s ()
|
||||
expireFiles expCfg = do
|
||||
let interval = checkInterval expCfg * 1000000
|
||||
forever $ do
|
||||
liftIO $ threadDelay' interval
|
||||
expireServerFiles (Just 100000)
|
||||
expireServerFiles (Just 100000) expCfg
|
||||
|
||||
serverStatsThread_ :: XFTPServerConfig s -> [M s ()]
|
||||
serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} =
|
||||
@@ -486,36 +482,38 @@ processXFTPRequest sessionId HTTP2Body {bodyPart} = \case
|
||||
XFTPReqPing -> noFile FRPong
|
||||
where
|
||||
noFile resp = pure (resp, Nothing)
|
||||
createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> FileStorageTime -> Maybe EntitlementProof -> M s FileResponse
|
||||
createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Int64 -> 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
|
||||
now <- liftIO $ roundedSeconds <$> getSystemSeconds
|
||||
maxSeconds <- lift $ storageMaxSeconds (xftpNewProofHeader sessionId sndKey digest) ep
|
||||
let (expiresAt, granted) = resolveStorage (roundedSeconds ts) maxSeconds storageTime
|
||||
let secs = maybe maxSeconds (\hours -> min (hours * 3600) maxSeconds) storageTime
|
||||
fileExpiresAt = RoundedSystemTime $ ((now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision
|
||||
-- TODO validate body empty
|
||||
sId <- ExceptT $ addFileRetry st file 3 ts expiresAt
|
||||
sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt)
|
||||
rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
|
||||
lift $ withFileLog $ \sl -> do
|
||||
logAddFile sl sId file ts expiresAt EntityActive
|
||||
logAddFile sl sId file ts (Just fileExpiresAt) 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 granted
|
||||
pure $ FRSndIds sId rIds (Just (GSTExpires (roundedSeconds fileExpiresAt)))
|
||||
pure $ either FRErr id r
|
||||
storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s (Maybe Int64)
|
||||
storageMaxSeconds _ Nothing = asks $ fmap ttl . fileExpiration . config
|
||||
storageMaxSeconds :: BBSPresHeader -> Maybe EntitlementProof -> M s Int64
|
||||
storageMaxSeconds _ Nothing = asks $ ttl . fileExpiration . config
|
||||
storageMaxSeconds ph (Just proof@EntitlementProof {entitlement = ent}) = do
|
||||
entCfg <- asks $ fileStorageEntitlements . config
|
||||
defaultMax <- asks $ fmap ttl . fileExpiration . config
|
||||
defaultMax <- asks $ ttl . fileExpiration . config
|
||||
now <- liftIO getCurrentTime
|
||||
let Entitlement {entitlementName, expiresAt} = ent
|
||||
liftIO (verifyEntitlement entitlementIssuerKeys ph proof) >>= \case
|
||||
Just True | expiresAt > now -> pure $ maybe defaultMax Just (M.lookup entitlementName entCfg)
|
||||
Just True | addUTCTime nominalDay 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 =
|
||||
@@ -658,33 +656,22 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce
|
||||
getFileTime :: IO RoundedFileTime
|
||||
getFileTime = getRoundedSystemTime
|
||||
|
||||
resolveStorage :: Int64 -> Maybe Int64 -> FileStorageTime -> (Maybe RoundedFileTime, GrantedStorageTime)
|
||||
resolveStorage base maxSeconds storageTime = (expiresAt, granted)
|
||||
where
|
||||
reqSeconds = case storageTime of
|
||||
FSMaxTime -> maxSeconds
|
||||
FSTime hours -> Just $ let hSec = fromIntegral hours * 3600 in maybe hSec (min hSec) maxSeconds
|
||||
expiresAt = (\s -> RoundedSystemTime (base + s)) <$> reqSeconds
|
||||
granted = GSTExpires $ base + fromMaybe 0 reqSeconds
|
||||
|
||||
expireServerFiles :: FileStoreClass s => Maybe Int -> M s ()
|
||||
expireServerFiles itemDelay =
|
||||
asks (fileExpiration . config) >>= \case
|
||||
Nothing -> pure ()
|
||||
Just ExpirationConfig {ttl = defaultTtl} -> do
|
||||
st <- asks fileStore
|
||||
us <- asks usedStorage
|
||||
usedStart <- readTVarIO us
|
||||
now <- liftIO $ roundedSeconds <$> getSystemSeconds
|
||||
filesCount <- liftIO $ getFileCount st
|
||||
logNote $ "Expiration check: " <> tshow filesCount <> " files"
|
||||
expireLoop st us now defaultTtl
|
||||
usedEnd <- readTVarIO us
|
||||
logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
|
||||
expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s ()
|
||||
expireServerFiles itemDelay expCfg = do
|
||||
st <- asks fileStore
|
||||
us <- asks usedStorage
|
||||
usedStart <- readTVarIO us
|
||||
now <- liftIO $ roundedSeconds <$> getSystemSeconds
|
||||
old <- liftIO $ expireBeforeEpoch expCfg
|
||||
filesCount <- liftIO $ getFileCount st
|
||||
logNote $ "Expiration check: " <> tshow filesCount <> " files"
|
||||
expireLoop st us now old
|
||||
usedEnd <- readTVarIO us
|
||||
logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
|
||||
where
|
||||
mbs bs = tshow (bs `div` 1048576) <> "mb"
|
||||
expireLoop st us now defaultTtl = do
|
||||
expired <- liftIO $ expiredFiles st now defaultTtl 10000
|
||||
expireLoop st us now old = do
|
||||
expired <- liftIO $ expiredFiles st now old 10000
|
||||
forM_ expired $ \(sId, filePath_, fileSize) -> do
|
||||
mapM_ threadDelay itemDelay
|
||||
forM_ filePath_ $ \fp ->
|
||||
@@ -697,7 +684,7 @@ expireServerFiles itemDelay =
|
||||
unless (null sIds) $ do
|
||||
withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds
|
||||
liftIO $ deleteFiles st sIds
|
||||
expireLoop st us now defaultTtl
|
||||
expireLoop st us now old
|
||||
|
||||
randomId :: Int -> M s ByteString
|
||||
randomId n = atomically . C.randomBytes n =<< asks random
|
||||
|
||||
@@ -45,7 +45,7 @@ import Data.Word (Word32)
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket
|
||||
import qualified Network.TLS as T
|
||||
import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), FileStorageTime, XFTPFileId)
|
||||
import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
|
||||
import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
|
||||
import Simplex.FileTransfer.Server.Stats
|
||||
import Data.Either (fromRight)
|
||||
@@ -92,7 +92,7 @@ data XFTPServerConfig s = XFTPServerConfig
|
||||
controlPortUserAuth :: Maybe BasicAuth,
|
||||
controlPortAdminAuth :: Maybe BasicAuth,
|
||||
-- | time after which the files can be removed and check interval, seconds
|
||||
fileExpiration :: Maybe ExpirationConfig,
|
||||
fileExpiration :: ExpirationConfig,
|
||||
-- | maximum storage time per entitlement name, seconds
|
||||
fileStorageEntitlements :: Map Text Int64,
|
||||
-- | timeout to receive file
|
||||
@@ -166,6 +166,9 @@ fromFileStore = \case
|
||||
#endif
|
||||
{-# INLINE fromFileStore #-}
|
||||
|
||||
defFileExpirationHours :: Int64
|
||||
defFileExpirationHours = 48
|
||||
|
||||
defaultFileExpiration :: ExpirationConfig
|
||||
defaultFileExpiration =
|
||||
ExpirationConfig
|
||||
@@ -173,14 +176,10 @@ defaultFileExpiration =
|
||||
checkInterval = 2 * 3600 -- seconds, 2 hours
|
||||
}
|
||||
|
||||
storageAtLeast :: Int64 -> Maybe Int64 -> Bool
|
||||
storageAtLeast _ Nothing = True
|
||||
storageAtLeast a (Just b) = a >= b
|
||||
|
||||
newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
|
||||
newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do
|
||||
let defaultMax = ttl <$> fileExpiration
|
||||
unless (all (`storageAtLeast` defaultMax) (M.elems fileStorageEntitlements)) $ do
|
||||
let defaultMax = ttl fileExpiration
|
||||
unless (all (>= defaultMax) (M.elems fileStorageEntitlements)) $ do
|
||||
logError "STORE: entitlement storage time is below the default file expiration"
|
||||
exitFailure
|
||||
random <- C.newRandom
|
||||
@@ -207,7 +206,7 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExp
|
||||
pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
data XFTPRequest
|
||||
= XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) FileStorageTime (Maybe EntitlementProof)
|
||||
= XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Int64) (Maybe EntitlementProof)
|
||||
| XFTPReqCmd XFTPFileId FileRec FileCmd
|
||||
| XFTPReqPing
|
||||
|
||||
|
||||
@@ -242,9 +242,7 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
|
||||
putStrLn $ case storeLogFile of
|
||||
Just f -> "Store log: " <> f
|
||||
_ -> "Store log disabled."
|
||||
putStrLn $ case fileExpiration of
|
||||
Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl
|
||||
_ -> "not expiring files"
|
||||
putStrLn $ "expiring files after " <> showTTL (ttl fileExpiration)
|
||||
putStrLn $ case inactiveClientExpiration of
|
||||
Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
|
||||
_ -> "not expiring inactive clients"
|
||||
@@ -290,10 +288,9 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
|
||||
controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini,
|
||||
controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini,
|
||||
fileExpiration =
|
||||
Just
|
||||
defaultFileExpiration
|
||||
{ ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
|
||||
},
|
||||
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 =
|
||||
@@ -444,7 +441,7 @@ cliCommandP cfgPath logPath iniFile =
|
||||
|
||||
iniEntitlements :: Ini -> Map T.Text Int64
|
||||
iniEntitlements ini =
|
||||
M.fromList $ mapMaybe readEntitlement [("supporter", "supporter_storage_hours"), ("legend", "legend_storage_hours"), ("investor", "investor_storage_hours")]
|
||||
M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")]
|
||||
where
|
||||
readEntitlement (name, key) = (name,) <$> (parseMax =<< eitherToMaybe (lookupValue "STORE_LOG" key ini))
|
||||
parseMax t = (3600 *) <$> (readMaybe (T.unpack (T.strip t)) :: Maybe Int64)
|
||||
|
||||
@@ -16,7 +16,6 @@ module Simplex.FileTransfer.Server.Store
|
||||
STMFileStore (..),
|
||||
RoundedFileTime,
|
||||
fileTimePrecision,
|
||||
defFileExpirationHours,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -65,9 +64,6 @@ type RoundedFileTime = RoundedSystemTime 3600
|
||||
fileTimePrecision :: Int64
|
||||
fileTimePrecision = 3600
|
||||
|
||||
defFileExpirationHours :: Int64
|
||||
defFileExpirationHours = 48
|
||||
|
||||
data FileRecipient = FileRecipient RecipientId C.APublicAuthKey
|
||||
deriving (Show)
|
||||
|
||||
@@ -171,11 +167,13 @@ instance FileStoreClass STMFileStore where
|
||||
pure $ Right ()
|
||||
_ -> pure $ Left AUTH
|
||||
|
||||
expiredFiles STMFileStore {files} now defaultTtl _limit = do
|
||||
expiredFiles STMFileStore {files} now old _limit = do
|
||||
fs <- readTVarIO files
|
||||
fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) ->
|
||||
let effExpiry = maybe (createdAt + defaultTtl) roundedSeconds expiresAt
|
||||
in if effExpiry < now
|
||||
let expired = case expiresAt of
|
||||
Just e -> roundedSeconds e < now
|
||||
Nothing -> createdAt + fileTimePrecision < old
|
||||
in if expired
|
||||
then do
|
||||
path <- readTVarIO filePath
|
||||
pure $ Just (sId, path, size)
|
||||
|
||||
@@ -152,12 +152,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 now defaultTtl limit =
|
||||
expiredFiles st now old limit =
|
||||
fmap toResult $ withTransaction (dbStore st) $ \db ->
|
||||
DB.query
|
||||
db
|
||||
"SELECT sender_id, file_path, file_size FROM files WHERE (expires_at < ?) OR (expires_at IS NULL AND created_at < ?) LIMIT ?"
|
||||
(now, now - defaultTtl, limit)
|
||||
(now, old - fileTimePrecision, limit)
|
||||
where
|
||||
toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)]
|
||||
toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size))
|
||||
|
||||
@@ -39,10 +39,8 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
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
|
||||
@@ -174,7 +172,7 @@ data SndFile = SndFile
|
||||
deleted :: Bool,
|
||||
redirect :: Maybe RedirectFileInfo,
|
||||
entitlementCredential :: Maybe EntitlementCredential,
|
||||
storageTime :: FileStorageTime
|
||||
storageTime :: Maybe Int64
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
@@ -194,21 +192,6 @@ instance FromField SndFileStatus where fromField = fromTextField_ textDecode
|
||||
|
||||
instance ToField SndFileStatus where toField = toField . textEncode
|
||||
|
||||
fileStorageTimeText :: FileStorageTime -> Text
|
||||
fileStorageTimeText = \case
|
||||
FSMaxTime -> "max"
|
||||
FSTime h -> "for " <> T.pack (show h)
|
||||
|
||||
fileStorageTimeParse :: Text -> Maybe FileStorageTime
|
||||
fileStorageTimeParse s = case T.words s of
|
||||
["max"] -> Just FSMaxTime
|
||||
["for", h] -> FSTime <$> 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)
|
||||
|
||||
@@ -191,7 +191,7 @@ 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.Description (ValidFileDescription)
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..))
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..))
|
||||
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
|
||||
import Simplex.FileTransfer.Util (removePath)
|
||||
import Simplex.Messaging.Agent.Client
|
||||
@@ -776,10 +776,10 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c
|
||||
|
||||
-- | Send XFTP file
|
||||
xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId
|
||||
xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing FSMaxTime
|
||||
xftpSendFile c userId file numRecipients = xftpSendFileStorage c userId file numRecipients Nothing Nothing
|
||||
{-# INLINE xftpSendFile #-}
|
||||
|
||||
xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> FileStorageTime -> AE SndFileId
|
||||
xftpSendFileStorage :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe EntitlementCredential -> Maybe Int64 -> AE SndFileId
|
||||
xftpSendFileStorage c userId file numRecipients credential storageTime = withAgentEnv c $ xftpSendFile' c userId file numRecipients credential storageTime
|
||||
{-# INLINE xftpSendFileStorage #-}
|
||||
|
||||
|
||||
@@ -233,7 +233,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, FileStorageTime, xftpNewProofHeader)
|
||||
import Simplex.FileTransfer.Protocol (FileInfo (..), FileResponse, xftpNewProofHeader)
|
||||
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,7 +253,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.Crypto.Entitlement (EntitlementCredential (..), entitlementIssuerKeys, generateEntitlementProof)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Client
|
||||
@@ -1346,7 +1346,7 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize}
|
||||
r <- runExceptT $ do
|
||||
(sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth
|
||||
(sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth Nothing Nothing
|
||||
liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
|
||||
liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
|
||||
rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
|
||||
@@ -2187,7 +2187,7 @@ 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 -> Maybe EntitlementCredential -> FileStorageTime -> AM NewSndChunkReplica
|
||||
agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe EntitlementCredential -> Maybe Int64 -> 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
|
||||
@@ -2195,18 +2195,15 @@ agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize},
|
||||
logServer "-->" c srv NoEntity "FNEW"
|
||||
tSess <- mkTransportSession c userId srv chunkDigest
|
||||
(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
|
||||
proof <- liftIO $ case credential of
|
||||
Nothing -> pure Nothing
|
||||
Just cred@EntitlementCredential {issuerKeyIdx} -> case M.lookup issuerKeyIdx entitlementIssuerKeys of
|
||||
Nothing -> pure Nothing
|
||||
Just pk -> either (const Nothing) Just <$> generateEntitlementProof pk cred (xftpNewProofHeader (sessionId $ X.thParams xftp) sndKey chunkDigest)
|
||||
X.createXFTPChunk 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
|
||||
|
||||
@@ -309,7 +309,7 @@ import Network.Socket (ServiceName)
|
||||
import qualified Network.TLS as TLS
|
||||
import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
|
||||
import Simplex.FileTransfer.Description
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), FileStorageTime (..), SFileParty (..))
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
|
||||
import Simplex.FileTransfer.Types
|
||||
import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
@@ -3425,7 +3425,7 @@ getRcvFilesExpired db ttl = do
|
||||
|]
|
||||
(Only cutoffTs)
|
||||
|
||||
createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe EntitlementCredential -> FileStorageTime -> IO (Either StoreError SndFileId)
|
||||
createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe EntitlementCredential -> Maybe Int64 -> IO (Either StoreError SndFileId)
|
||||
createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ entitlementCredential storageTime =
|
||||
createWithRandomId db gVar $ \sndFileEntityId ->
|
||||
DB.execute
|
||||
@@ -3477,7 +3477,7 @@ 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, Maybe EntitlementCredential, FileStorageTime) -> SndFile
|
||||
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, Maybe Int64) -> 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
|
||||
|
||||
+1
-1
@@ -10,7 +10,7 @@ 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';
|
||||
ALTER TABLE snd_files ADD COLUMN storage_time BIGINT;
|
||||
|]
|
||||
|
||||
down_m20260823_snd_files_entitlement :: Text
|
||||
|
||||
+1
-1
@@ -9,7 +9,7 @@ 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';
|
||||
ALTER TABLE snd_files ADD COLUMN storage_time INTEGER;
|
||||
|]
|
||||
|
||||
down_m20260823_snd_files_entitlement :: Query
|
||||
|
||||
@@ -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 Nothing FSMaxTime
|
||||
Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing Nothing
|
||||
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 Nothing FSMaxTime
|
||||
Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing Nothing
|
||||
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 Nothing FSMaxTime
|
||||
Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing Nothing
|
||||
updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
|
||||
createSndFileReplica_ db 2 newSndChunkReplica1
|
||||
|
||||
|
||||
+1
-1
@@ -619,7 +619,7 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer te
|
||||
|
||||
testXFTPAgentExpiredOnServer :: HasCallStack => AFStoreType -> IO ()
|
||||
testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $
|
||||
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = Just fastExpiration}) . const $ do
|
||||
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = fastExpiration}) . const $ do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
|
||||
-- send file 1
|
||||
|
||||
+1
-1
@@ -181,7 +181,7 @@ testXFTPServerConfig =
|
||||
newFileBasicAuth = Nothing,
|
||||
controlPortAdminAuth = Nothing,
|
||||
controlPortUserAuth = Nothing,
|
||||
fileExpiration = Just defaultFileExpiration,
|
||||
fileExpiration = defaultFileExpiration,
|
||||
fileStorageEntitlements = mempty,
|
||||
fileTimeout = 10000000,
|
||||
inactiveClientExpiration = Just defaultInactiveClientExpiration,
|
||||
|
||||
@@ -28,7 +28,8 @@ import Data.X509.Validation (Fingerprint (..), getFingerprint)
|
||||
import Network.HPACK.Token (tokenKey)
|
||||
import qualified Network.HTTP2.Client as H2
|
||||
import ServerTests (logSize)
|
||||
import Simplex.FileTransfer.Client
|
||||
import Simplex.FileTransfer.Client hiding (createXFTPChunk)
|
||||
import qualified Simplex.FileTransfer.Client as A
|
||||
import Simplex.FileTransfer.Description (kb)
|
||||
import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPFileId, xftpBlockSize)
|
||||
import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..))
|
||||
@@ -37,7 +38,8 @@ import Simplex.Messaging.Client (ProtocolClientError (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), pattern NoEntity)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), RecipientId, SenderId, pattern NoEntity)
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import Simplex.Messaging.Transport (CertChainPubKey (..), TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTLSTransportClient)
|
||||
@@ -100,6 +102,9 @@ createTestChunk fp = do
|
||||
B.writeFile fp bytes
|
||||
pure bytes
|
||||
|
||||
createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
|
||||
createXFTPChunk c spKey file rcps auth = A.createXFTPChunk c spKey file rcps auth Nothing Nothing
|
||||
|
||||
readChunk :: XFTPFileId -> IO ByteString
|
||||
readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode $ unEntityId sId))
|
||||
|
||||
@@ -240,7 +245,7 @@ testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fs
|
||||
deleteXFTPChunk c spKey sId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
where
|
||||
fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
|
||||
fileExpiration = ExpirationConfig {ttl = 1, checkInterval = 1}
|
||||
|
||||
testInactiveClientExpiration :: AFStoreType -> Expectation
|
||||
testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {inactiveClientExpiration}) $ \_ -> runRight_ $ do
|
||||
|
||||
Reference in New Issue
Block a user