diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index c5a92f58e..1cdbb0c2c 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -50,6 +50,7 @@ import qualified Data.Set as S import Data.Text (Text, pack) import Data.Time.Clock (getCurrentTime) import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Word (Word32) import Simplex.FileTransfer.Chunks (toKB) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize) import Simplex.FileTransfer.Crypto @@ -351,7 +352,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 Int64 -> AM SndFileId +xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AM SndFileId xftpSendFile' c userId file numRecipients storageTime = do g <- asks random prefixPath <- lift $ getPrefixPath "snd.xftp" @@ -455,7 +456,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of [] -> Left ch SndFileChunkReplica {server} : _ -> Right server - createChunk :: Int -> Maybe Int64 -> SndFileChunk -> AM (ProtocolServer 'PXFTP) + createChunk :: Int -> Maybe Word32 -> SndFileChunk -> AM (ProtocolServer 'PXFTP) createChunk numRecipients' storageTime ch = do liftIO $ assertAgentForeground c (replica, ProtoServerWithAuth srv _) <- tryCreate diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs index b03881844..f84080cc0 100644 --- a/src/Simplex/FileTransfer/Client.hs +++ b/src/Simplex/FileTransfer/Client.hs @@ -256,7 +256,7 @@ createXFTPChunk :: FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> - Maybe Int64 -> + Maybe Word32 -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime) createXFTPChunk c spKey file rcps auth_ storageTime = sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageTime) Nothing >>= \case diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 84a256f83..50c84e711 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -177,7 +177,7 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where {-# INLINE protocolError #-} data FileCommand (p :: FileParty) where - FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> Maybe Int64 -> FileCommand FSender + FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> Maybe Word32 -> FileCommand FSender FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender FPUT :: FileCommand FSender FDEL :: FileCommand FSender diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 8b2d38c1c..3170ae52a 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -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 (..), addUTCTime, diffTimeToPicoseconds, getCurrentTime, nominalDay) +import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) import Data.Time.Clock.System (systemSeconds, utcToSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) import Data.Word (Word32) @@ -498,7 +498,7 @@ processXFTPRequest ent HTTP2Body {bodyPart} = \case XFTPReqPing -> noFile FRPong where noFile resp = pure (resp, Nothing) - createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Int64 -> M s FileResponse + createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Word32 -> M s FileResponse createFile file rks storageTime = do st <- asks fileStore r <- runExceptT $ do @@ -507,7 +507,7 @@ processXFTPRequest ent HTTP2Body {bodyPart} = \case ts <- liftIO getFileTime now <- liftIO getSystemSeconds maxSeconds <- lift $ storageMaxSeconds now - let secs = maybe maxSeconds (min maxSeconds . (* 3600)) storageTime + let secs = maybe maxSeconds (\hours -> min maxSeconds (fromIntegral hours * 3600)) storageTime fileExpiresAt = RoundedSystemTime $ ((roundedSeconds now + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision -- TODO validate body empty sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt) diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index ff23c8402..5e31e2159 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -47,7 +47,6 @@ import Network.Socket import qualified Network.TLS as T import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId) import Simplex.Messaging.Crypto.BBS (BBSPublicKey) -import Simplex.Messaging.Crypto.Entitlement (EntitlementProof) import Simplex.FileTransfer.Server.Stats import Data.Either (fromRight) import Data.Ini (Ini, lookupValue) @@ -182,8 +181,10 @@ defaultFileExpiration = newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s) newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do let defaultMax = ttl fileExpiration - unless (all ((>= defaultMax) . storageTime) (M.elems fileStorageEntitlements)) $ do - logError "STORE: entitlement storage time is below the default file expiration" + belowDefault = M.filter ((< defaultMax) . storageTime) fileStorageEntitlements + unless (M.null belowDefault) $ do + forM_ (M.assocs belowDefault) $ \(name, EntitlementConfig {storageTime}) -> + logError $ "STORE: storage time for " <> name <> " is " <> tshow storageTime <> " seconds, below the default file expiration " <> tshow defaultMax <> " seconds" exitFailure random <- C.newRandom (store, storeLog) <- case serverStoreCfg of @@ -209,7 +210,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) (Maybe Int64) + = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Word32) | XFTPReqCmd XFTPFileId FileRec FileCmd | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 51d692dd5..1188de0ce 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -14,7 +14,7 @@ module Simplex.FileTransfer.Server.Main xftpServerCLI_, ) where -import Control.Monad (unless, when) +import Control.Monad (forM_, unless, when) import Data.Either (fromRight) import Data.Functor (($>)) import Data.Ini (Ini, lookupValue, readIniFile) @@ -162,6 +162,10 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do \# db_store_log = off\n\n" <> "# Expire files after the specified number of hours.\n" <> ("expire_files_hours = " <> tshow defFileExpirationHours <> "\n\n") + <> "# Expire files after the specified number of hours for the senders that present\n\ + \# a proof of the entitlement. Must not be below expire_files_hours.\n\ + \# expire_files_hours_for_supporter = 168\n\ + \# expire_files_hours_for_legend = 504\n\n" <> "log_stats = off\n\ \\n\ \# Log interval for real-time Prometheus metrics\n\ @@ -240,11 +244,13 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do enableStoreLog = settingIsOn "STORE_LOG" "enable" ini logStats = settingIsOn "STORE_LOG" "log_stats" ini c = combine cfgPath . ($ defaultX509Config) - printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, inactiveClientExpiration} = do + printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, fileStorageEntitlements, inactiveClientExpiration} = do putStrLn $ case storeLogFile of Just f -> "Store log: " <> f _ -> "Store log disabled." putStrLn $ "expiring files after " <> showTTL (ttl fileExpiration) + forM_ (M.assocs fileStorageEntitlements) $ \(name, EntitlementConfig {storageTime}) -> + putStrLn $ "expiring files of " <> T.unpack name <> " after " <> showTTL storageTime putStrLn $ case inactiveClientExpiration of Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds" _ -> "not expiring inactive clients" diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index 887ea23ed..3b389b7fc 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -156,8 +156,8 @@ instance FileStoreClass PostgresFileStore where 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, old - fileTimePrecision, limit) + "(SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? LIMIT ?) UNION ALL (SELECT sender_id, file_path, file_size FROM files WHERE expires_at IS NULL AND created_at < ? LIMIT ?)" + (now, limit, old - fileTimePrecision, limit) where toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)] toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size)) diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index 9742430f3..eb9677bdf 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -37,7 +37,7 @@ module Simplex.FileTransfer.Transport ) where -import Control.Applicative (optional, (<|>)) +import Control.Applicative (optional) import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad @@ -150,13 +150,16 @@ instance Encoding XFTPClientHello where pure XFTPClientHello {webChallenge} instance Encoding XFTPClientHandshake where - smpEncode XFTPClientHandshake {xftpVersion, keyHash, entitlementProof} = - smpEncode (xftpVersion, keyHash, entitlementProof) + smpEncode XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} = + smpEncode (v, keyHash) <> ifHasEntitlement v (smpEncode entitlementProof) "" smpP = do - (xftpVersion, keyHash) <- smpP - entitlementProof <- smpP <|> pure Nothing + (v, keyHash) <- smpP + entitlementProof <- ifHasEntitlement v smpP (pure Nothing) Tail _compat <- smpP - pure XFTPClientHandshake {xftpVersion, keyHash, entitlementProof} + pure XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} + +ifHasEntitlement :: VersionXFTP -> a -> a -> a +ifHasEntitlement v a b = if v >= fileStorageTimeXFTPVersion then a else b instance Encoding XFTPServerHandshake where smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof} = diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs index d772e46d5..e782ef1d6 100644 --- a/src/Simplex/FileTransfer/Types.hs +++ b/src/Simplex/FileTransfer/Types.hs @@ -172,7 +172,7 @@ data SndFile = SndFile status :: SndFileStatus, deleted :: Bool, redirect :: Maybe RedirectFileInfo, - storageTime :: Maybe Int64 + storageTime :: Maybe Word32 } deriving (Show) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 3522596d2..744b456a8 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -188,7 +188,7 @@ import qualified Data.Text as T import Data.Time.Clock import Data.Time.Clock.System (systemToUTCTime) import Data.Traversable (mapAccumL) -import Data.Word (Word16) +import Data.Word (Word16, Word32) 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 (..)) @@ -775,7 +775,7 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c {-# INLINE xftpDeleteRcvFiles #-} -- | Send XFTP file -xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Int64 -> AE SndFileId +xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AE SndFileId xftpSendFile c = withAgentEnv c .:: xftpSendFile' c {-# INLINE xftpSendFile #-} diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 5bcdf8a54..6e5ce8cfe 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -228,7 +228,7 @@ import Data.Text (Text) import Data.Text.Encoding import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime) import Data.Time.Clock.System (getSystemTime) -import Data.Word (Word16) +import Data.Word (Word16, Word32) import qualified Data.X509.Validation as XV import Network.Socket (HostName) import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError) @@ -2211,7 +2211,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 Int64 -> AM NewSndChunkReplica +agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe Word32 -> AM NewSndChunkReplica agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageTime = do rKeys <- xftpRcvKeys n (sndKey, replicaKey) <- atomically . 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 b472cb5b7..22bd8e620 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -311,7 +311,6 @@ import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) import Simplex.FileTransfer.Description import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..), 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 @@ -3425,7 +3424,7 @@ getRcvFilesExpired db ttl = do |] (Only cutoffTs) -createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe Int64 -> IO (Either StoreError SndFileId) +createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe Word32 -> IO (Either StoreError SndFileId) createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageTime = createWithRandomId db gVar $ \sndFileEntityId -> DB.execute @@ -3477,7 +3476,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 Int64) -> 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 Word32) -> SndFile toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageTime)) = let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_ srcFile = CryptoFile srcPath cfArgs diff --git a/src/Simplex/Messaging/Crypto/BBS.hs b/src/Simplex/Messaging/Crypto/BBS.hs index 45c83e6f1..cdbb9a792 100644 --- a/src/Simplex/Messaging/Crypto/BBS.hs +++ b/src/Simplex/Messaging/Crypto/BBS.hs @@ -17,6 +17,7 @@ module Simplex.Messaging.Crypto.BBS BBSProof (..), BBSHeader (..), BBSPresHeader (..), + FixedBS (..), bbsKeyGen, bbsPublicKey, bbsSign, @@ -35,6 +36,7 @@ import Foreign.C import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal) import Simplex.Messaging.Encoding (Encoding (..), Large (..)) import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Util ((<$?>)) import System.IO.Unsafe (unsafePerformIO) -- Note: the data constructors below are unchecked escape hatches for trusted, @@ -72,8 +74,8 @@ newtype BBSPresHeader = BBSPresHeader ByteString deriving (ToJSON, FromJSON) via (StrJSON "BBSPresHeader" BBSPresHeader) -- | A ByteString validated to be exactly @n@ bytes when parsed via StrEncoding --- (and the JSON derived from it). Local to BBS, where every key/signature is a --- fixed size; @name@ appears in the decode error only. +-- (and the JSON derived from it), for keys and signatures of a fixed size; +-- @name@ appears in the decode error only. newtype FixedBS (name :: Symbol) (n :: Nat) = FixedBS ByteString instance forall name n. (KnownSymbol name, KnownNat n) => StrEncoding (FixedBS name n) where @@ -98,18 +100,20 @@ bbsProofLen :: Int -> Int bbsProofLen numUndisclosed = bbsProofBaseLen + numUndisclosed * bbsProofUdElemLen -- | A proof is @bbsProofBaseLen + 32 * numUndisclosed@ bytes; reject anything else. +mkBBSProof :: ByteString -> Either String BBSProof +mkBBSProof bs + | len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0 = Right $ BBSProof bs + | otherwise = Left $ "BBS: invalid proof length " <> show len + where + len = B.length bs + instance StrEncoding BBSProof where strEncode (BBSProof bs) = strEncode bs - strP = do - bs <- base64urlP - let len = B.length bs - if len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0 - then pure (BBSProof bs) - else fail $ "BBS: invalid proof length " <> show len + strP = mkBBSProof <$?> base64urlP instance Encoding BBSProof where smpEncode (BBSProof p) = smpEncode (Large p) - smpP = BBSProof . unLarge <$> smpP + smpP = mkBBSProof . unLarge <$?> smpP -- FFI diff --git a/src/Simplex/Messaging/Crypto/Entitlement.hs b/src/Simplex/Messaging/Crypto/Entitlement.hs index 049954b10..1e62c4754 100644 --- a/src/Simplex/Messaging/Crypto/Entitlement.hs +++ b/src/Simplex/Messaging/Crypto/Entitlement.hs @@ -11,6 +11,7 @@ module Simplex.Messaging.Crypto.Entitlement EntitlementCredential (..), EntitlementProof (..), MasterKey (..), + randomMasterKey, entitlementBBSHeader, entitlementIssuerKeys, signEntitlement, @@ -20,7 +21,9 @@ module Simplex.Messaging.Crypto.Entitlement ) where +import Control.Concurrent.STM import Control.Monad (forM) +import Crypto.Random (ChaChaDRG) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as JQ import Data.ByteString.Char8 (ByteString) @@ -29,9 +32,10 @@ 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.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Word (Word16) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -39,7 +43,8 @@ import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Util ((<$$>)) newtype MasterKey = MasterKey ByteString - deriving newtype (Eq, Show, StrEncoding) + deriving newtype (Eq, Show) + deriving (StrEncoding) via (FixedBS "MasterKey" 32) deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey) data Entitlement = Entitlement @@ -66,10 +71,11 @@ data EntitlementProof = EntitlementProof instance Encoding Entitlement where smpEncode Entitlement {entitlementName, expiresAt, extraInfo} = - smpEncode (entitlementName, strEncode expiresAt, extraInfo) + smpEncode (entitlementName, strEncode expiresAt, Large $ encodeUtf8 extraInfo) smpP = do - (entitlementName, expBs, extraInfo) <- smpP + (entitlementName, expBs, Large extraBs) <- smpP expiresAt <- either fail pure $ strDecode (expBs :: ByteString) + extraInfo <- either (fail . show) pure $ decodeUtf8' extraBs pure Entitlement {entitlementName, expiresAt, extraInfo} instance Encoding EntitlementProof where @@ -95,6 +101,9 @@ disclosedMessages :: Entitlement -> [ByteString] disclosedMessages Entitlement {entitlementName, expiresAt, extraInfo} = [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo] +randomMasterKey :: TVar ChaChaDRG -> STM MasterKey +randomMasterKey g = MasterKey <$> C.randomBytes 32 g + signEntitlement :: BBSSecretKey -> Word16 -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential) signEntitlement sk keyIdx mk ent = EntitlementCredential keyIdx mk ent <$$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent)