This commit is contained in:
Evgeny @ SimpleX Chat
2026-08-23 15:15:37 +00:00
parent add65420c7
commit 0df161a002
4 changed files with 152 additions and 24 deletions
+12 -13
View File
@@ -9,24 +9,23 @@ New module `Simplex.Messaging.Crypto.Entitlement`, over `Simplex.Messaging.Crypt
Types:
```
newtype EntitlementSecret = EntitlementSecret ByteString
newtype MasterKey = MasterKey ByteString
data Entitlement = Entitlement
{ level :: Text,
{ entitlementName :: Text,
expiresAt :: UTCTime,
extraInfo :: Text
}
data EntitlementCredential = EntitlementCredential
{ issuerKeyIdx :: Int,
holderSecret :: EntitlementSecret,
signature :: BBSSignature,
masterKey :: MasterKey,
issuerSignature :: BBSSignature,
entitlement :: Entitlement
}
data EntitlementProof = EntitlementProof
{ issuerKeyIdx :: Int,
presHeader :: BBSPresHeader,
proof :: BBSProof,
entitlement :: Entitlement
}
@@ -34,10 +33,10 @@ data EntitlementProof = EntitlementProof
Functions and constants:
- the disclosed-message encoding: the holder secret is message 0 and stays undisclosed; `expiresAt`, `level`, and `extraInfo` are messages 1 to 3 and are disclosed
- the disclosed-message encoding: the master key is message 0 and stays undisclosed; `expiresAt`, `entitlementName`, and `extraInfo` are messages 1 to 3 and are disclosed
- the BBS header string `"SimpleX entitlement v1"`, the message count, and the disclosed indexes
- `generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)`
- `verifyEntitlement :: Map Int BBSPublicKey -> EntitlementProof -> IO (Maybe Bool)`
- `verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool)` (the caller supplies the presentation header; the server reconstructs it, the proof never includes it)
- the issuer public keys constant `Map Int BBSPublicKey`
## simplexmq: protocol, new XFTP version
@@ -66,8 +65,8 @@ In `Simplex.FileTransfer.Server`:
In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`:
- read a maximum storage time for each entitlement level, and a default maximum, from the INI file, where each maximum is a number of hours or permanent
- exit at startup if any level maximum is below the default
- read a maximum storage time for each entitlement name, and a default maximum, from the INI file, where each maximum is a number of hours or permanent
- exit at startup if any name's maximum is below the default
- read the issuer public keys from the shared constant
## simplexmq: server store and expiration
@@ -75,8 +74,8 @@ In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`:
Common to both stores, in `Simplex.FileTransfer.Server.Store`:
- add `expiresAt :: Maybe RoundedFileTime` to `FileRec`, where `Nothing` is permanent storage
- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the requested time against the level maximum (a permanent maximum is unbounded), set `expiresAt` to the resolved expiration or `Nothing` when the result is permanent, and return it
- add the FTTL handler, which verifies the proof against `sessionId <> senderId`, sets `expiresAt` by the same resolution, and returns it
- in `createFile`, verify the proof against `sessionId <> sndKey <> digest`, resolve the requested time against the entitlement's maximum (a permanent maximum is unbounded), set `expiresAt` to the resolved expiration or `Nothing` when the result is permanent, and return it
- add the FTTL handler, which verifies the proof against `sessionId <> sndKey <> digest`, sets `expiresAt` by the same resolution, and returns it
- retain `created_at` for statistics and export
STM store:
@@ -115,12 +114,12 @@ Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`:
Set-time:
- for a completed file, generate a per-chunk proof bound to `sessionId <> senderId` and send FTTL, authorized with the sender key
- for a completed file, generate a per-chunk proof bound to `sessionId <> sndKey <> digest` and send FTTL, authorized with the sender key
## simplex-chat
- remove lifetime badges: make `badgeExpiry` a `UTCTime`, drop the `"lifetime"` encoding, and remove the lifetime option from the UI and the CLI
- map `BadgeInfo` to `Entitlement` (`level = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent
- map `BadgeInfo` to `Entitlement` (`entitlementName = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent
- pass the user's credential and `FSTMax` to `xftpSendFile`
- retain the `maxXFTPFileSize` size limit
- reuse `verifyEntitlement` for peer-badge verification
+10 -11
View File
@@ -6,13 +6,13 @@ The server stores a storage time for each file. The sender sets it in the FNEW c
## Entitlement
An entitlement is a level, an expiration, and an extra string. It is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server reads `entLevel` to select a maximum storage time, checks `entExpires`, and ignores `entExtra`; the interpretation of `entExtra` is out of scope here. The protocol references only the entitlement, never a badge; chat maps its own badge to an entitlement before it asks the agent to send.
An entitlement is a name, an expiration, and an extra string. It is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server reads `entName` to select a maximum storage time, checks `entExpires`, and ignores `entExtra`; the interpretation of `entExtra` is out of scope here. The protocol references only the entitlement, never a badge; chat maps its own badge to an entitlement before it asks the agent to send.
The proof discloses the entitlement and includes the issuer key index and the BBS proof. The holder's secret and the BBS signature remain with the sender and are never transmitted. The origin of the sender's signed entitlement, from the entitlement service, is out of scope here.
```
entitlement = entLevel entExpires entExtra
entLevel = shortString ; e.g. "supporter", "legend"
entitlement = entName entExpires entExtra
entName = shortString ; e.g. "supporter", "legend"
entExpires = shortString ; expiration, encoded as signed
entExtra = shortString ; opaque, interpretation out of scope
@@ -56,29 +56,28 @@ FNEW extends the SIDS response with the granted storage, and FTTL adds a respons
sndIds = %s"SIDS " senderId rcvIds grantedStorage
fileTime = %s"TTL " grantedStorage
grantedStorage = grantedExpires / grantedPerm
grantedExpires = %s"F" expiresSeconds
grantedExpires = %s"F" expiresAt
grantedPerm = %s"P"
expiresSeconds = 8*8 OCTET ; Int64 seconds since epoch, network byte order
expiresAt = 8*8 OCTET ; Int64, seconds since epoch (absolute UTC instant), network byte order
```
`grantedExpires` returns the absolute expiration, and `grantedPerm` indicates permanent storage. `senderId` and `rcvIds` are defined by the current XFTP protocol.
## Binding
The presentation header binds each proof to the TLS session and to the specific chunk. The server reconstructs it and rejects a proof generated for any other session or chunk.
The presentation header binds each proof to the TLS session and to the specific chunk. The server reconstructs it and rejects a proof generated for any other session or chunk. FNEW and FTTL use the same header.
```
fnewPresHeader = sessionId sndKey digest
fttlPresHeader = sessionId senderId
presHeader = sessionId sndKey digest
```
On FNEW the chunk is identified by the sender key and the digest, which the server verifies for every later command on the file. On FTTL the chunk is identified by `senderId`, which the server has assigned by then. `sessionId` is the TLS session identifier; `sndKey` and `digest` are the fields of `fileInfo`.
The chunk is identified by the sender key and the digest, which the server verifies for every command on the file. `sessionId` is the TLS session identifier; `sndKey` and `digest` are the fields of `fileInfo`.
## Maximum storage time
The server configures a maximum storage time for each entitlement level, and a default maximum for requests with no proof. Each maximum is a number of hours or permanent. The server exits at startup if any level 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 or permanent. 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.
If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request. `storageMax` yields permanent storage when the level maximum is permanent, and the finite maximum otherwise.
If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request. `storageMax` yields permanent storage when the entitlement's maximum is permanent, and the finite maximum otherwise.
## Encoding primitives
+1
View File
@@ -135,6 +135,7 @@ library
Simplex.Messaging.Crypto.Lazy
Simplex.Messaging.Crypto.Ratchet
Simplex.Messaging.Crypto.BBS
Simplex.Messaging.Crypto.Entitlement
Simplex.Messaging.Crypto.SNTRUP761
Simplex.Messaging.Crypto.SNTRUP761.Bindings
Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
+129
View File
@@ -0,0 +1,129 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- | A generic entitlement, proven with a BBS proof over the SHA-256 suite.
-- The holder secret (the master key) is the undisclosed message; the name, the
-- expiration, and the extra string are disclosed. The protocol and the server
-- reference the entitlement, never a badge; chat maps its own badge to an
-- entitlement.
module Simplex.Messaging.Crypto.Entitlement
( Entitlement (..),
EntitlementCredential (..),
EntitlementProof (..),
MasterKey (..),
entitlementIssuerKeys,
signEntitlement,
verifyCredential,
generateEntitlementProof,
verifyEntitlement,
)
where
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson.TH as JQ
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Either (fromRight)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime)
import Simplex.Messaging.Crypto.BBS
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON)
newtype MasterKey = MasterKey ByteString
deriving newtype (Eq, Show, StrEncoding)
deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey)
-- | The disclosed content of an entitlement proof.
data Entitlement = Entitlement
{ entitlementName :: Text,
expiresAt :: UTCTime,
extraInfo :: Text
}
deriving (Eq, Show)
-- | The signing form, held by the entitlement holder; never transmitted.
data EntitlementCredential = EntitlementCredential
{ issuerKeyIdx :: Int,
masterKey :: MasterKey,
issuerSignature :: BBSSignature,
entitlement :: Entitlement
}
deriving (Eq, Show)
-- | The proof form. The presentation header is not part of the proof: the
-- verifier supplies it, so a proof cannot claim its own binding.
data EntitlementProof = EntitlementProof
{ issuerKeyIdx :: Int,
proof :: BBSProof,
entitlement :: Entitlement
}
deriving (Eq, Show)
entitlementBBSHeader :: BBSHeader
entitlementBBSHeader = BBSHeader "SimpleX entitlement v1"
entitlementMessageCount :: Int
entitlementMessageCount = 4
entitlementDisclosedIndexes :: [Int]
entitlementDisclosedIndexes = [1, 2, 3]
entitlementMessages :: MasterKey -> Entitlement -> [ByteString]
entitlementMessages (MasterKey mk) ent = mk : disclosedMessages ent
disclosedMessages :: Entitlement -> [ByteString]
disclosedMessages Entitlement {entitlementName, expiresAt, extraInfo} =
[strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo]
-- | Issuer side: sign an entitlement for a holder master key.
signEntitlement :: BBSSecretKey -> Int -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential)
signEntitlement sk keyIdx mk ent =
fmap (\sig -> EntitlementCredential keyIdx mk sig ent) <$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent)
-- | Holder side: verify the credential received from the issuer.
verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool
verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitlement} =
bbsVerify pk issuerSignature entitlementBBSHeader (entitlementMessages masterKey entitlement)
-- | Holder side: generate a proof bound to the presentation header.
generateEntitlementProof :: BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)
generateEntitlementProof pk EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph =
fmap (\p -> EntitlementProof issuerKeyIdx p entitlement) <$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement)
-- | Verifier side: verify the proof with the configured key its index points to,
-- against the supplied presentation header. Nothing means the key index is not
-- among the configured keys.
verifyEntitlement :: Map Int BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO (Maybe Bool)
verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, proof, entitlement} = case M.lookup issuerKeyIdx keys of
Nothing -> pure Nothing
Just pk -> Just <$> bbsProofVerify pk proof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement)
entitlementIssuerKeys :: Map Int BBSPublicKey
entitlementIssuerKeys =
M.fromList
[ (1, key "mW_5Zp1wHnXDF56wOZwFcRjGrf0GLLsfyymIQDqYoWfjfvS7oQWSfi7hH65N8JhuE9x8wbKXHidnQLO4GnOSMP_bRKUMH1qIzv5SQKFHNM8G4PaWcTcri8iZLc-3xhSI"),
(2, key "odGCB7uVDXTURsHgSvSciByV4Q3-3ZvEB8myDsDJqm-PwOYc5-At36uc7n_pyUDxEQEHr9i4RJgFih2FSArPW-EQBXNPNf4wTtA0znn74qLEGc4fh9pVYPEIm_ZGbnsJ"),
(3, key "txkT2003WMjc43KvYvPKEcR970NLmw5UZY51eUqgk91sgp53idt1HTlKYvnrEttJDFMlctYf1-bpri0e9DhBQ-xk1J4WoLN2uif_1OcA1pGCobpk9lwtsq1Idek4biy0"),
(4, key "q_YzegihaLYrEm9z3cAghsfDGNZfXuEpQGMJERJQS4M0Szl4gvSC_fV_muKc3NIMA_8iYuBN8qyvb5U55RctCRn3kleFQ4sqf-WBgoydX6UVo7BsYcUbXWWEFZXlOGIH"),
(5, key "oqymHASH_okefShrnz4HnTooUNlE1WoDRnSrgd0bTCpOacgJWBsMpwZpdmYlX-vQAKAC_zmI4VdKoOznnhW-sdUXZw6bthCi5JYjGxCR1Co27i1tix5UXCTbR5Jp901-"),
(6, key "kDqaB6zKSRp_97QPFj5JPDlo0vzfSTLSp9goFx1qajv4q4H6dR6BbkmWZ4xx_9Q2AxmcpqcV0ethz1OH-Jk_Sz2J1mIz1PUVM9LkdLhi_PNtqhezzO5dbVs-HJ1fNqe6"),
(7, key "rl36D5mg2N3NmmEybxE_RBeU9YZ_zeXNPfp7ZMLtUEuf2Mo4OQM_Up1v5rX_IqICD-AIJcuyptEBsELx_PJQzpmiNuG5I4cWO6HkRKtc6fVFvgZMrDJjaascPd1CIyxX"),
(8, key "joM3Bnt7JPt5JiwQwERHGjro2iVZ0mPD_clUh4hzkhxvbjuFrWuTmfSNA8PWBqGKEGNl13aRi1pMf6yY14E27c5C71JxWm7T-rZaBrGPEUWifhD-qidWuf3PU7KJCCWd")
]
where
key = fromRight (error "bad base64 in entitlement issuer key") . strDecode . B.pack
$(JQ.deriveJSON defaultJSON ''Entitlement)
$(JQ.deriveJSON defaultJSON ''EntitlementCredential)
$(JQ.deriveJSON defaultJSON ''EntitlementProof)