From c18691def4cdb6e9c6d3bf9c127cb245d87df9c6 Mon Sep 17 00:00:00 2001 From: shum Date: Wed, 7 Oct 2026 08:21:37 +0000 Subject: [PATCH] protocol: make EntityId a ShortByteString --- src/Simplex/FileTransfer/Protocol.hs | 12 +++++----- src/Simplex/FileTransfer/Server.hs | 3 ++- .../FileTransfer/Server/Store/Postgres.hs | 7 +++--- src/Simplex/FileTransfer/Server/StoreLog.hs | 3 ++- src/Simplex/Messaging/Agent.hs | 5 ++-- src/Simplex/Messaging/Agent/Client.hs | 17 +++++++------- src/Simplex/Messaging/Agent/Protocol.hs | 5 ++-- .../Messaging/Agent/Store/AgentStore.hs | 5 ++-- src/Simplex/Messaging/Client.hs | 3 ++- src/Simplex/Messaging/Crypto/ShortLink.hs | 3 ++- .../Messaging/Notifications/Protocol.hs | 11 +++++---- src/Simplex/Messaging/Notifications/Server.hs | 3 ++- .../Notifications/Server/Store/Postgres.hs | 3 ++- src/Simplex/Messaging/Protocol.hs | 19 +++++++-------- src/Simplex/Messaging/Server.hs | 15 ++++++------ src/Simplex/Messaging/Server/Env/STM.hs | 3 +-- .../Messaging/Server/QueueStore/Postgres.hs | 5 ++-- src/Simplex/Messaging/Transport.hs | 17 ++++++++++++-- tests/CoreTests/BatchingTests.hs | 17 +++++++------- tests/CoreTests/MsgStoreTests.hs | 7 +++--- tests/CoreTests/StoreLogTests.hs | 7 +++--- tests/CoreTests/TSessionSubs.hs | 3 ++- tests/NtfClient.hs | 3 ++- tests/SMPClient.hs | 3 ++- tests/ServerTests.hs | 23 ++++++++++--------- tests/XFTPServerTests.hs | 3 ++- 26 files changed, 120 insertions(+), 85 deletions(-) diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 50c84e711..c9a81b8e0 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -38,7 +38,7 @@ module Simplex.FileTransfer.Protocol import qualified Data.Aeson.TH as J import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.Int (Int64) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) @@ -238,14 +238,14 @@ instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand -- FNEW must not have signature and chunk ID FNEW {} | isNothing auth -> Left $ CMD NO_AUTH - | not (B.null fileId) -> Left $ CMD HAS_AUTH + | not (SBS.null fileId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd PING - | isNothing auth && B.null fileId -> Right cmd + | isNothing auth && SBS.null fileId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and queue ID _ - | isNothing auth || B.null fileId -> Left $ CMD NO_AUTH + | isNothing auth || SBS.null fileId -> Left $ CMD NO_AUTH | otherwise -> Right cmd instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where @@ -363,11 +363,11 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where FRPong -> noEntity -- other server responses must have entity ID _ - | B.null entId -> Left $ CMD NO_ENTITY + | SBS.null entId -> Left $ CMD NO_ENTITY | otherwise -> Right cmd where noEntity - | B.null entId = Right cmd + | SBS.null entId = Right cmd | otherwise = Left $ CMD HAS_AUTH checkParty :: forall t p p'. (FilePartyI p, FilePartyI p') => t p' -> Either String (t p) diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 16a705690..ba92d8f6b 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -29,6 +29,7 @@ import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.ByteString.Short as SBS import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L @@ -716,7 +717,7 @@ randomId :: Int -> M s ByteString randomId n = atomically . C.randomBytes n =<< asks random getFileId :: M s XFTPFileId -getFileId = fmap EntityId . randomId =<< asks (fileIdSize . config) +getFileId = fmap (EntityId . SBS.toShort) . randomId =<< asks (fileIdSize . config) withFileLog :: (StoreLog 'WriteMode -> IO a) -> M s () withFileLog action = liftIO . mapM_ action =<< asks storeLog diff --git a/src/Simplex/FileTransfer/Server/Store/Postgres.hs b/src/Simplex/FileTransfer/Server/Store/Postgres.hs index c9e83c4c5..b6bea9dc2 100644 --- a/src/Simplex/FileTransfer/Server/Store/Postgres.hs +++ b/src/Simplex/FileTransfer/Server/Store/Postgres.hs @@ -25,6 +25,7 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Short as SBS import Data.Functor (($>)) import Data.Int (Int32, Int64) import Data.List (intersperse) @@ -333,7 +334,7 @@ fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, pure $ LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields path status) <> BB.char7 '\n' where fields path status = - [ renderField (toField (Binary (unEntityId sId))), + [ renderField (toField (Binary (SBS.fromShort $ unEntityId sId))), renderField (toField (fromIntegral size :: Int32)), renderField (toField (Binary digest)), renderField (toField (Binary (C.encodePubKey sndKey))), @@ -348,8 +349,8 @@ recipientToCSV rId sId rKey = LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields) <> BB.char7 '\n' where fields = - [ renderField (toField (Binary (unEntityId rId))), - renderField (toField (Binary (unEntityId sId))), + [ renderField (toField (Binary (SBS.fromShort $ unEntityId rId))), + renderField (toField (Binary (SBS.fromShort $ unEntityId sId))), renderField (toField (Binary (C.encodePubKey rKey))) ] diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs index 5a6d99c7a..c988ccbe5 100644 --- a/src/Simplex/FileTransfer/Server/StoreLog.hs +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -28,6 +28,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64.URL as B64 import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.ByteString.Short as SBS import Data.Composition ((.:), (.::.)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L @@ -103,7 +104,7 @@ logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO () logAckFile s = logFileStoreRecord s . AckFile serverFileName :: SenderId -> FilePath -serverFileName = B.unpack . B64.encode . unEntityId +serverFileName = B.unpack . B64.encode . SBS.fromShort . unEntityId readWriteFileStore :: FilePath -> STMFileStore -> IO (StoreLog 'WriteMode) readWriteFileStore = readWriteStoreLog readFileStore writeFileStore diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 05df98ecc..2fb4ddbee 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -173,6 +173,7 @@ import qualified Data.Aeson.TH as JQ import Data.Bifunctor (bimap, first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.Composition import Data.Either (fromRight, isRight, partitionEithers, rights) import Data.Foldable (foldl', toList) @@ -1044,7 +1045,7 @@ prepareConnectionLink' c userId rootKey@(_, plpRootPrivKey) linkEntityId checkNo plpNonce@(C.CbNonce corrId) <- atomically $ C.randomCbNonce g plpQueueE2EKeys@(e2ePubKey, _) <- atomically $ C.generateKeyPair g addrKeys_ <- if useDR then Just <$> generateAddressRatchetKeys pqInitKeys else pure Nothing - let sndId = SMP.EntityId $ B.take 24 $ C.sha3_384 corrId + let sndId = SMP.EntityId $ SBS.toShort $ B.take 24 $ C.sha3_384 corrId qUri = SMPQueueUri smpClientVRange $ SMPQueueAddress srv sndId e2ePubKey (Just QMContact) connReq = CRContactUri (ConnReqUriData SSSimplex smpAgentVRange [qUri] clientData) (fst <$> addrKeys_) (plpLinkKey, plpSignedFixedData) = SL.encodeSignFixedData rootKey smpAgentVRange connReq (Just linkEntityId) @@ -1360,7 +1361,7 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userLinkData_ clientData pqIni sigKeys@(_, privSigKey) <- atomically $ C.generateKeyPair @'C.Ed25519 g AgentConfig {smpClientVRange = vr, smpAgentVRange} <- asks config -- the remaining 24 bytes are reserved, possibly for notifier ID in the new notifications protocol - let sndId = SMP.EntityId $ B.take 24 $ C.sha3_384 corrId + let sndId = SMP.EntityId $ SBS.toShort $ B.take 24 $ C.sha3_384 corrId qm = case cMode of SCMContact -> QMContact; SCMInvitation -> QMMessaging qUri = SMPQueueUri vr $ SMPQueueAddress srv sndId e2eDhKey (Just qm) connReq <- createConnReq addrKeys_ qUri diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 3d8f8c1bd..3de62ed15 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -211,6 +211,7 @@ import Data.Bifunctor (bimap, first, second) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.Composition ((.:), (.:.)) import Data.Containers.ListUtils (nubOrd) import Data.Either (isRight, partitionEithers) @@ -1161,7 +1162,7 @@ withLogClient c nm tSess entId cmdStr action = withLogClient_ c nm tSess entId c withSMPClient :: SMPQueueRec q => AgentClient -> NetworkRequestMode -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> AM a withSMPClient c nm q cmdStr action = do tSess <- mkSMPTransportSessionIO c q - withLogClient c nm tSess (unEntityId $ queueId q) cmdStr $ action . connectedClient + withLogClient c nm tSess (SBS.fromShort $ unEntityId $ queueId q) cmdStr $ action . connectedClient sendOrProxySMPMessage :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> ConnId -> ByteString -> Maybe SMP.SndPrivateAuthKey -> SMP.SenderId -> MsgFlags -> SMP.MsgBody -> AM (Maybe SMPServer) sendOrProxySMPMessage c nm userId destSrv connId cmdStr spKey_ senderId msgFlags msg = @@ -1255,7 +1256,7 @@ sendOrProxySMPCommand c nm userId destSrv@ProtocolServer {host = destHosts} conn | serverHostError e -> ifM directAllowed ((Nothing,) <$> sendDirectly destSess) (throwE e) | otherwise -> throwE e sendDirectly tSess = - withLogClient_ c nm tSess (unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do + withLogClient_ c nm tSess (SBS.fromShort $ unEntityId entId) ("SEND " <> cmdStr) $ \(SMPConnectedClient smp _) -> do tryAllErrors (liftClient SMP (clientServer smp) $ sendCmdDirectly smp) >>= \case Right r -> r <$ atomically (incSMPServerStat c userId destSrv sentDirect) Left e -> throwE e @@ -1270,7 +1271,7 @@ ipAddressProtected NetworkConfig {socksProxy, socksMode, hostMode} (ProtocolServ isOnionHost = \case THOnionHost _ -> True; _ -> False withNtfClient :: AgentClient -> NetworkRequestMode -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> AM a -withNtfClient c nm srv (EntityId entId) = withLogClient c nm (0, srv, Nothing) entId +withNtfClient c nm srv (EntityId entId) = withLogClient c nm (0, srv, Nothing) $ SBS.fromShort entId withXFTPClient :: ProtocolServerClient v err msg => @@ -1929,7 +1930,7 @@ getSubscriptions = readTVarIO . subscrConns {-# INLINE getSubscriptions #-} logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> EntityId -> ByteString -> m () -logServer dir c srv = logServer' dir c srv . unEntityId +logServer dir c srv = logServer' dir c srv . SBS.fromShort . unEntityId {-# INLINE logServer #-} logServer' :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> ByteString -> ByteString -> m () @@ -1942,7 +1943,7 @@ showServer ProtocolServer {host, port} = {-# INLINE showServer #-} logSecret :: EntityId -> ByteString -logSecret = logSecret' . unEntityId +logSecret = logSecret' . SBS.fromShort . unEntityId {-# INLINE logSecret #-} logSecret' :: ByteString -> ByteString @@ -2007,14 +2008,14 @@ deleteQueueLink c nm rq@RcvQueue {rcvId, rcvPrivateKey} = secureGetQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> InvShortLink -> AM (SMP.SenderId, QueueLinkData) secureGetQueueLink c nm userId InvShortLink {server, linkId, sndPrivateKey} = - snd <$> sendOrProxySMPCommand c nm userId server (unEntityId linkId) "LKEY " linkId secureGetViaProxy secureGetDirectly + snd <$> sendOrProxySMPCommand c nm userId server (SBS.fromShort $ unEntityId linkId) "LKEY " linkId secureGetViaProxy secureGetDirectly where secureGetViaProxy smp proxySess = proxySecureGetSMPQueueLink smp nm proxySess sndPrivateKey linkId secureGetDirectly smp = secureGetSMPQueueLink smp nm sndPrivateKey linkId getQueueLink :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SMP.LinkId -> AM (SMP.SenderId, QueueLinkData) getQueueLink c nm userId server lnkId = - snd <$> sendOrProxySMPCommand c nm userId server (unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly + snd <$> sendOrProxySMPCommand c nm userId server (SBS.fromShort $ unEntityId lnkId) "LGET" lnkId getViaProxy getDirectly where getViaProxy smp proxySess = proxyGetSMPQueueLink smp nm proxySess lnkId getDirectly smp = getSMPQueueLink smp nm lnkId @@ -2148,7 +2149,7 @@ getQueueInfo c nm rq@RcvQueue {server, rcvId, rcvPrivateKey, sndId, status, clie let ntfId = enc . (\ClientNtfCreds {notifierId} -> notifierId) <$> clientNtfCreds pure ServerQueueInfo {server, rcvId = enc rcvId, sndId = enc sndId, ntfId, status = serializeQueueStatus status, info} where - enc = decodeLatin1 . B64.encode . unEntityId + enc = decodeLatin1 . B64.encode . SBS.fromShort . unEntityId agentNtfRegisterToken :: AgentClient -> NetworkRequestMode -> NtfToken -> SMP.NtfPublicAuthKey -> C.PublicKeyX25519 -> AM (NtfTokenId, C.PublicKeyX25519) agentNtfRegisterToken c nm NtfToken {deviceToken, ntfServer, ntfPrivKey} ntfPubKey pubDhKey = diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 5f7977e45..98d141001 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -212,6 +212,7 @@ import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Short as SBS import Data.Char (toLower, toUpper) import Data.Foldable (find) import Data.Functor (($>)) @@ -1720,7 +1721,7 @@ instance FromJSON AConnectionLink where instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case - CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) -> slEncode sch srv 'i' lnkId k + CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) -> slEncode sch srv 'i' (SBS.fromShort lnkId) k CSLContact sch ct srv (LinkKey k) -> slEncode sch srv (toLower $ ctTypeChar ct) "" k where slEncode sch (SMPServer (h :| hs) port (C.KeyHash kh)) linkType lnkId k = @@ -1750,7 +1751,7 @@ instance StrEncoding AConnShortLink where lnkId <- strP <* A.char '/' k <- strP srv <- serverQueryP h_ - pure $ ACSL SCMInvitation $ CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) + pure $ ACSL SCMInvitation $ CSLInvitation sch srv (SMP.EntityId $ SBS.toShort lnkId) (LinkKey k) Just ct -> do k <- strP srv <- serverQueryP h_ diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 21c087d46..dc7dd7ad3 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -296,6 +296,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Base64.URL as U import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Short as SBS import Data.Either (partitionEithers) import Data.Functor (($>)) import Data.Int (Int64) @@ -2265,9 +2266,9 @@ instance ToField (Version v) where toField (Version v) = toField v deriving newtype instance FromField (Version v) -instance ToField EntityId where toField (EntityId s) = toField $ Binary s +instance ToField EntityId where toField (EntityId s) = toField $ Binary $ SBS.fromShort s -deriving newtype instance FromField EntityId +instance FromField EntityId where fromField = blobFieldDecoder $ Right . EntityId . SBS.toShort deriving newtype instance ToField ChunkReplicaId diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 7a2eedeb9..2c25a121e 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -145,6 +145,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Short as SBS import Data.Functor (($>)) import Data.Int (Int64) import Data.List (find, isSuffixOf) @@ -1237,7 +1238,7 @@ proxySMPCommand c@ProtocolClient {thParams = proxyThParams, client_ = PClient {c et <- liftEitherWith PCECryptoError $ EncTransmission <$> C.cbEncrypt cmdSecret (encTransmissionNonce v nonce) b paddedProxiedTLength -- proxy interaction errors are wrapped let tOut = Just $ 2 * netTimeoutInt tcpTimeout nm - tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case + tryE (sendProtocolCommand_ c nm (Just nonce) tOut Nothing (EntityId $ SBS.toShort sessionId) (Cmd SProxiedClient (PFWD v cmdPubKey et))) >>= \case Right r -> case r of PRES nonce_ (EncResponse er) -> do -- server interaction errors are thrown directly diff --git a/src/Simplex/Messaging/Crypto/ShortLink.hs b/src/Simplex/Messaging/Crypto/ShortLink.hs index 840366543..5562fab8a 100644 --- a/src/Simplex/Messaging/Crypto/ShortLink.hs +++ b/src/Simplex/Messaging/Crypto/ShortLink.hs @@ -31,6 +31,7 @@ import Data.Bifunctor (first) import Data.Bitraversable (bimapM) import Data.ByteString (ByteString) import qualified Data.ByteString as B +import qualified Data.ByteString.Short as SBS import Simplex.Messaging.Agent.Client (cryptoError) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C @@ -47,7 +48,7 @@ userDataPaddedLength = 13784 -- 13824 - 24 - 16 contactShortLinkKdf :: LinkKey -> (LinkId, C.SbKey) contactShortLinkKdf (LinkKey k) = let (lnkId, sbKey) = B.splitAt 24 $ C.hkdf "" k "SimpleXContactLink" 56 - in (EntityId lnkId, C.unsafeSbKey sbKey) + in (EntityId $ SBS.toShort lnkId, C.unsafeSbKey sbKey) invShortLinkKdf :: LinkKey -> C.SbKey invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32 diff --git a/src/Simplex/Messaging/Notifications/Protocol.hs b/src/Simplex/Messaging/Notifications/Protocol.hs index 44f096f9b..81af311f2 100644 --- a/src/Simplex/Messaging/Notifications/Protocol.hs +++ b/src/Simplex/Messaging/Notifications/Protocol.hs @@ -47,6 +47,7 @@ import qualified Data.Aeson.Encoding as JE import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.Functor (($>)) import Data.Kind import Data.List.NonEmpty (NonEmpty (..)) @@ -248,16 +249,16 @@ instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) wh TNEW {} -> sigNoEntity SNEW {} -> sigNoEntity PING - | isNothing auth && B.null entityId -> Right cmd + | isNothing auth && SBS.null entityId -> Right cmd | otherwise -> Left $ CMD HAS_AUTH -- other client commands must have both signature and entity ID _ - | isNothing auth || B.null entityId -> Left $ CMD NO_AUTH + | isNothing auth || SBS.null entityId -> Left $ CMD NO_AUTH | otherwise -> Right cmd where sigNoEntity | isNothing auth = Left $ CMD NO_AUTH - | not (B.null entityId) = Left $ CMD HAS_AUTH + | not (SBS.null entityId) = Left $ CMD HAS_AUTH | otherwise = Right cmd instance ProtocolEncoding NTFVersion ErrorType NtfCmd where @@ -368,11 +369,11 @@ instance ProtocolEncoding NTFVersion ErrorType NtfResponse where NRPong -> noEntity -- other server responses must have entity ID _ - | B.null entId -> Left $ CMD NO_ENTITY + | SBS.null entId -> Left $ CMD NO_ENTITY | otherwise -> Right cmd where noEntity - | B.null entId = Right cmd + | SBS.null entId = Right cmd | otherwise = Left $ CMD HAS_AUTH data SMPQueueNtf = SMPQueueNtf diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index edcebb96f..695768556 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -32,6 +32,7 @@ import Control.Monad.Reader import Data.Bifunctor (first) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.Either (partitionEithers) import Data.Functor (($>)) import Data.Hashable (hash) @@ -948,7 +949,7 @@ client NtfServerClient {rcvQ, sndQ} ns@NtfSubscriber {smpAgent = ca} ps = PING -> pure NRPong NtfReqPing corrId entId -> pure (corrId, entId, NRPong) getId :: M NtfEntityId - getId = fmap EntityId . randomBytes =<< asks (subIdBytes . config) + getId = fmap (EntityId . SBS.toShort) . randomBytes =<< asks (subIdBytes . config) getRegCode :: M NtfRegCode getRegCode = NtfRegCode <$> (randomBytes =<< asks (regCodeBytes . config)) randomBytes :: Int -> M ByteString diff --git a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs index 7cf5a438b..262898ddb 100644 --- a/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs +++ b/src/Simplex/Messaging/Notifications/Server/Store/Postgres.hs @@ -62,6 +62,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Bitraversable (bimapM) import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Short as SBS import Data.Either (fromRight) import Data.Functor (($>)) import Data.Int (Int64) @@ -233,7 +234,7 @@ deleteNtfToken st tknId = toServerSubs :: SMPServerRow :. Only Text -> (SMPServer, [NotifierId]) toServerSubs (srv :. Only nIdsStr) = (rowToSrv srv, parseByteaString nIdsStr) parseByteaString :: Text -> [NotifierId] - parseByteaString s = mapMaybe (fmap EntityId . decodeHex . T.drop 2) $ T.splitOn "," s -- drop 2 to remove "\\x" + parseByteaString s = mapMaybe (fmap (EntityId . SBS.toShort) . decodeHex . T.drop 2) $ T.splitOn "," s -- drop 2 to remove "\\x" type SMPServerRow = (NonEmpty TransportHost, ServiceName, C.KeyHash) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index ab0f362f4..7b82b2c5e 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -248,6 +248,7 @@ import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Short as SBS import Data.Char (isPrint, isSpace) import Data.Constraint (Dict (..)) import Data.Functor (($>)) @@ -1553,7 +1554,7 @@ queueIdsHash :: [QueueId] -> IdsHash queueIdsHash = mconcat . map queueIdHash queueIdHash :: QueueId -> IdsHash -queueIdHash = IdsHash . C.md5Hash . unEntityId +queueIdHash = IdsHash . C.md5Hash . SBS.fromShort . unEntityId {-# INLINE queueIdHash #-} addServiceSubs :: (Int64, IdsHash) -> (Int64, IdsHash) -> (Int64, IdsHash) @@ -1868,11 +1869,11 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where -- NEW must have signature but NOT queue ID NEW {} | isNothing auth -> Left $ CMD NO_AUTH - | not (B.null entId) -> Left $ CMD HAS_AUTH + | not (SBS.null entId) -> Left $ CMD HAS_AUTH | otherwise -> Right cmd -- SEND must have queue ID, signature is not always required SEND {} - | B.null entId -> Left $ CMD NO_ENTITY + | SBS.null entId -> Left $ CMD NO_ENTITY | otherwise -> Right cmd LGET -> entityCmd PING -> noAuthCmd @@ -1884,22 +1885,22 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where NSUB -> serviceCmd -- other client commands must have both signature and queue ID _ - | isNothing auth || B.null entId -> Left $ CMD NO_AUTH + | isNothing auth || SBS.null entId -> Left $ CMD NO_AUTH | otherwise -> Right cmd where -- command must not have entity ID (queue or session ID) or signature noAuthCmd :: Either ErrorType (Command p) noAuthCmd - | isNothing auth && B.null entId = Right cmd + | isNothing auth && SBS.null entId = Right cmd | otherwise = Left $ CMD HAS_AUTH entityCmd :: Either ErrorType (Command p) entityCmd - | B.null entId = Left $ CMD NO_ENTITY + | SBS.null entId = Left $ CMD NO_ENTITY | isNothing auth = Right cmd | otherwise = Left $ CMD HAS_AUTH serviceCmd :: Either ErrorType (Command p) serviceCmd - | isNothing auth || B.null entId = Left $ CMD NO_AUTH + | isNothing auth || SBS.null entId = Left $ CMD NO_AUTH | otherwise = Right cmd instance ProtocolEncoding SMPVersion ErrorType Cmd where @@ -2086,12 +2087,12 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where RNAME {} -> noEntityMsg -- other broker responses must have queue ID _ - | B.null entId -> Left $ CMD NO_ENTITY + | SBS.null entId -> Left $ CMD NO_ENTITY | otherwise -> Right cmd where noEntityMsg :: Either ErrorType BrokerMsg noEntityMsg - | B.null entId = Right cmd + | SBS.null entId = Right cmd | otherwise = Left $ CMD HAS_AUTH -- | Parse SMP protocol commands and broker messages diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 29856098d..a9dd33250 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -62,6 +62,7 @@ import qualified Data.ByteString.Builder as BLD import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.ByteString.Short as SBS import Data.Constraint (Dict (..)) import Data.Dynamic (toDyn) import Data.Either (fromRight, partitionEithers) @@ -748,7 +749,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt getClientService :: s -> TVar ChaChaDRG -> Int -> SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId getClientService ms g idSize role cert fp = do - newServiceId <- EntityId <$> atomically (C.randomBytes idSize g) + newServiceId <- EntityId . SBS.toShort <$> atomically (C.randomBytes idSize g) ts <- liftIO getSystemDate let sr = ServiceRec {serviceId = newServiceId, serviceRole = role, serviceCert = cert, serviceCertHash = fp, serviceCreatedAt = ts} withExceptT (const $ TEHandshake BAD_SERVICE) $ ExceptT $ @@ -1452,7 +1453,7 @@ client ProxyAgent {smpAgent = a} <- asks proxyAgent ServerStats {pMsgFwds, pMsgFwdsOwn} <- asks serverStats let inc = mkIncProxyStats pMsgFwds pMsgFwdsOwn - liftIO (lookupSMPServerClient a sessId) >>= \case + liftIO (lookupSMPServerClient a $ SBS.fromShort sessId) >>= \case Just (own, smp) -> do inc own pRequests forkProxiedCmd $ do @@ -1574,9 +1575,9 @@ client ntfKeys_ <- forM ntfCreds $ \(NewNtfCreds notifierKey dhKey) -> do (ntfPubDhKey, ntfPrivDhKey) <- atomically $ C.generateKeyPair g pure (notifierKey, C.dh' dhKey ntfPrivDhKey, ntfPubDhKey) - let randId = EntityId <$> atomically (C.randomBytes idSize g) + let randId = EntityId . SBS.toShort <$> atomically (C.randomBytes idSize g) -- the remaining 24 bytes are reserved, possibly for notifier ID in the new notifications protocol - sndId' = B.take 24 $ C.sha3_384 (bs corrId) + sndId' = EntityId $ SBS.toShort $ B.take 24 $ C.sha3_384 (bs corrId) tryCreate 0 = pure $ ERR INTERNAL tryCreate n = do (sndId, clntIds, queueData) <- case queueReqData of @@ -1586,7 +1587,7 @@ client -- The condition that client-provided sender ID must match hash of correlation ID -- prevents "ID oracle" attack, when creating queue with supplied ID can be used to check -- if queue with this ID still exists. - if clntIds && unEntityId sndId /= sndId' + if clntIds && sndId /= sndId' then pure $ ERR $ CMD PROHIBITED else do rcvId <- randId @@ -2269,7 +2270,7 @@ randomId' :: Int -> M s ByteString randomId' n = atomically . C.randomBytes n =<< asks random randomId :: Int -> M s EntityId -randomId = fmap EntityId . randomId' +randomId = fmap (EntityId . SBS.toShort) . randomId' {-# INLINE randomId #-} saveServerMessages :: Bool -> MsgStore s -> IO () @@ -2394,7 +2395,7 @@ importMessages tty ms f old_ skipWarnings = do Right q -> addToQueue_ q rId msg Left AUTH -> liftIO $ do when tty $ putStrLn "" - warnOrExit $ "queue " <> safeDecodeUtf8 (encode $ unEntityId rId) <> " does not exist" + warnOrExit $ "queue " <> safeDecodeUtf8 (encode $ SBS.fromShort $ unEntityId rId) <> " does not exist" pure (Nothing, counts) Left e -> throwE e addToQueue_ q rId msg = diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 414352f7d..703a2c85c 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -88,7 +88,6 @@ import Control.Monad import qualified Crypto.PubKey.RSA as RSA import Crypto.Random import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as SBS import Data.Int (Int64) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM @@ -399,7 +398,7 @@ data SubscribedClients s = SubscribedClients (TMap SubKey (TVar (Maybe (Client s type SubKey = ShortByteString subKey :: EntityId -> SubKey -subKey = SBS.toShort . unEntityId +subKey = unEntityId {-# INLINE subKey #-} getSubscribedClients :: SubscribedClients s -> IO (Map SubKey (TVar (Maybe (Client s)))) diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 72f051fe3..8ddd7ac0c 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -48,6 +48,7 @@ import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Short as SBS import Data.Bitraversable (bimapM) import Data.Either (fromRight, lefts) import Data.Functor (($>)) @@ -801,9 +802,9 @@ instance ToField SMPServiceRole where toField = toField . decodeLatin1 . smpEnco instance FromField SMPServiceRole where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 #if !defined(dbPostgres) -instance ToField EntityId where toField (EntityId s) = toField $ Binary s +instance ToField EntityId where toField (EntityId s) = toField $ Binary $ SBS.fromShort s -deriving newtype instance FromField EntityId +instance FromField EntityId where fromField = blobFieldDecoder $ Right . EntityId . SBS.toShort instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 32e33ad1a..7d45ffeb2 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -120,6 +120,8 @@ import Data.Bitraversable (bimapM) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SBS import Data.Default (def) import Data.Functor (($>)) import Data.Int (Int64) @@ -526,9 +528,20 @@ type SessionId = ByteString type ServiceId = EntityId -- this type is used for server entities only -newtype EntityId = EntityId {unEntityId :: ByteString} +-- ShortByteString is unpinned, so long-lived IDs (map keys) do not retain the pinned block they were parsed from +newtype EntityId = EntityId {unEntityId :: ShortByteString} deriving (Eq, Ord, Show) - deriving newtype (Encoding, StrEncoding) + +instance Encoding EntityId where + smpEncode (EntityId s) = smpEncode $ SBS.fromShort s + {-# INLINE smpEncode #-} + smpP = EntityId . SBS.toShort <$> smpP + {-# INLINE smpP #-} + +instance StrEncoding EntityId where + strEncode (EntityId s) = strEncode $ SBS.fromShort s + strDecode = fmap (EntityId . SBS.toShort) . strDecode + strP = EntityId . SBS.toShort <$> strP pattern NoEntity :: EntityId pattern NoEntity = EntityId "" diff --git a/tests/CoreTests/BatchingTests.hs b/tests/CoreTests/BatchingTests.hs index 960c2113e..635bc6948 100644 --- a/tests/CoreTests/BatchingTests.hs +++ b/tests/CoreTests/BatchingTests.hs @@ -14,6 +14,7 @@ import Control.Monad import Crypto.Random (ChaChaDRG) import qualified Data.ByteString as B import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Short as SBS import qualified Data.List.NonEmpty as L import Data.Time.Clock.System (SystemTime, getSystemTime) import qualified Data.X509 as X @@ -182,7 +183,7 @@ randomSUB sessId = do (rKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g thAuth_ <- testTHandleAuth g rKey let thParams = testTHandleParams sessId - TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId rId, Cmd SRecipient SUB) + TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId (SBS.toShort rId), Cmd SRecipient SUB) pure $ (,tToSend) <$> authTransmission thAuth_ True (Just rpKey) nonce tForAuth randomSUBCmd :: ProtocolClient SMPVersion ErrorType BrokerMsg -> IO (PCTransmission ErrorType BrokerMsg) @@ -190,13 +191,13 @@ randomSUBCmd c = do g <- C.newRandom rId <- atomically $ C.randomBytes 24 g (_, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g - mkTransmission c (EntityId rId, Just rpKey, Cmd SRecipient SUB) + mkTransmission c (EntityId (SBS.toShort rId), Just rpKey, Cmd SRecipient SUB) randomENDCmd :: IO (Transmission BrokerMsg) randomENDCmd = do g <- C.newRandom rId <- atomically $ C.randomBytes 24 g - pure (CorrId "", EntityId rId, END) + pure (CorrId "", EntityId (SBS.toShort rId), END) randomNMSGCmd :: SystemTime -> IO (Transmission BrokerMsg) randomNMSGCmd ts = do @@ -207,14 +208,14 @@ randomNMSGCmd ts = do nonce <- atomically $ C.randomCbNonce g let msgMeta = NMsgMeta {msgId, msgTs = ts} Right encNMsgMeta <- pure $ C.cbEncrypt (C.dh' k pk) nonce (smpEncode msgMeta) 128 - pure (CorrId "", EntityId nId, NMSG nonce encNMsgMeta) + pure (CorrId "", EntityId (SBS.toShort nId), NMSG nonce encNMsgMeta) randomSOK :: IO (Transmission BrokerMsg) randomSOK = do g <- C.newRandom corrId <- atomically $ C.randomBytes 24 g rId <- atomically $ C.randomBytes 24 g - pure (CorrId corrId, EntityId rId, SOK Nothing) + pure (CorrId corrId, EntityId (SBS.toShort rId), SOK Nothing) randomMSG :: IO (Transmission BrokerMsg) randomMSG = do @@ -223,7 +224,7 @@ randomMSG = do rId <- atomically $ C.randomBytes 24 g msgId <- atomically $ C.randomBytes 24 g msg <- atomically $ C.randomBytes maxMessageLength g - pure (CorrId corrId, EntityId rId, MSG RcvMessage {msgId, msgBody = EncRcvMsgBody msg}) + pure (CorrId corrId, EntityId (SBS.toShort rId), MSG RcvMessage {msgId, msgBody = EncRcvMsgBody msg}) randomSEND :: ByteString -> Int -> IO (Either TransportError (Maybe TAuthorizations, ByteString)) randomSEND sessId len = do @@ -234,7 +235,7 @@ randomSEND sessId len = do thAuth_ <- testTHandleAuth g sKey msg <- atomically $ C.randomBytes len g let thParams = testTHandleParams sessId - TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId sId, Cmd SSender $ SEND noMsgFlags msg) + TransmissionForAuth {tForAuth, tToSend} = encodeTransmissionForAuth thParams (CorrId corrId, EntityId (SBS.toShort sId), Cmd SSender $ SEND noMsgFlags msg) pure $ (,tToSend) <$> authTransmission thAuth_ False (Just spKey) nonce tForAuth testTHandleParams :: ByteString -> THandleParams SMPVersion 'TClient @@ -269,7 +270,7 @@ randomSENDCmd c len = do sId <- atomically $ C.randomBytes 24 g (_, rpKey) <- atomically $ C.generateAuthKeyPair C.SX25519 g msg <- atomically $ C.randomBytes len g - mkTransmission c (EntityId sId, Just rpKey, Cmd SSender $ SEND noMsgFlags msg) + mkTransmission c (EntityId (SBS.toShort sId), Just rpKey, Cmd SSender $ SEND noMsgFlags msg) lenOk :: ByteString -> Bool lenOk s = 0 < B.length s && B.length s <= smpBlockSize - 2 diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index d4a2d7582..9c9fbabf8 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -26,6 +26,7 @@ import Control.Monad.Trans.Except import Crypto.Random (ChaChaDRG) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.Int (Int64) import Data.List (isPrefixOf, isSuffixOf) import Data.Maybe (fromJust) @@ -183,7 +184,7 @@ testNewQueueRecData g qm queueData = do } pure (rId, qr) where - rndId = atomically $ EntityId <$> C.randomBytes 24 g + rndId = atomically $ EntityId . SBS.toShort <$> C.randomBytes 24 g testGetQueue :: MsgStoreClass s => s -> IO () testGetQueue ms = do @@ -274,7 +275,7 @@ testLinkDataSecuredQueue ms = do (sKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g let st = queueStore ms ld = (EncDataBytes "fixed data", EncDataBytes "user data") - rndId = atomically $ EntityId <$> C.randomBytes 24 g + rndId = atomically $ EntityId . SBS.toShort <$> C.randomBytes 24 g (rId, qr) <- testNewQueueRec g QMMessaging (cId, cqr) <- testNewQueueRec g QMContact lnkId <- rndId @@ -459,7 +460,7 @@ testExpireMessagesInBatches ms = do testQueueState :: JournalMsgStore s -> IO () testQueueState ms = do g <- C.newRandom - rId <- EntityId <$> atomically (C.randomBytes 24 g) + rId <- EntityId . SBS.toShort <$> atomically (C.randomBytes 24 g) let dir = msgQueueDirectory ms rId statePath = msgQueueStatePath dir rId createDirectoryIfMissing True dir diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 81a0535d5..0a64d3be5 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -14,6 +14,7 @@ import Control.Monad import CoreTests.MsgStoreTests import Crypto.Random (ChaChaDRG) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.Either (partitionEithers) import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M @@ -79,7 +80,7 @@ storeLogTests = ((rId, qr), ntfCreds, date, sr@ServiceRec {serviceId}) <- runIO $ (,,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate <*> newTestServiceRec g ((rId', qr'), lnkId, qd) <- runIO $ do - lnkId <- atomically $ EntityId <$> C.randomBytes 24 g + lnkId <- atomically $ EntityId . SBS.toShort <$> C.randomBytes 24 g let qd = (EncDataBytes "fixed data", EncDataBytes "user data") q <- testNewQueueRecData g qm (Just (lnkId, qd)) pure (q, lnkId, qd) @@ -157,7 +158,7 @@ storeLogTests = newTestServiceRec :: TVar ChaChaDRG -> IO ServiceRec newTestServiceRec g = do - serviceId <- atomically $ EntityId <$> C.randomBytes 24 g + serviceId <- atomically $ EntityId . SBS.toShort <$> C.randomBytes 24 g (_, cert) <- genCredentials g Nothing (0, 2400) "ntf.example.com" serviceCreatedAt <- getSystemDate pure @@ -233,7 +234,7 @@ fileStoreLogTests :: Spec fileStoreLogTests = do g <- runIO C.newRandom (sndKey, _) <- runIO $ atomically $ C.generateAuthKeyPair C.SEd25519 g - sId <- runIO $ atomically $ EntityId <$> C.randomBytes 24 g + sId <- runIO $ atomically $ EntityId . SBS.toShort <$> C.randomBytes 24 g let file = FileInfo {sndKey, size = 16384, digest = "12345678"} createdAt = RoundedSystemTime 1600000000 expiresAt = RoundedSystemTime 1600172800 diff --git a/tests/CoreTests/TSessionSubs.hs b/tests/CoreTests/TSessionSubs.hs index 96975e9ef..f2d7c5063 100644 --- a/tests/CoreTests/TSessionSubs.hs +++ b/tests/CoreTests/TSessionSubs.hs @@ -10,6 +10,7 @@ module CoreTests.TSessionSubs where import AgentTests.EqInstances () import Control.Monad import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.List (foldl') import qualified Data.Map as M import Data.String (IsString (..)) @@ -27,7 +28,7 @@ import Util tSessionSubsTests :: Spec tSessionSubsTests = it "subscription lifecycle" $ testSessionSubs -instance IsString EntityId where fromString = EntityId . B.pack +instance IsString EntityId where fromString = EntityId . SBS.toShort . B.pack dumpSessionSubs :: SS.TSessionSubs -> IO (M.Map SMPTransportSession (Maybe SessionId, (M.Map RecipientId RcvQueueSub, M.Map RecipientId RcvQueueSub))) dumpSessionSubs = diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index b0ee811d3..93047e9bd 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -25,6 +25,7 @@ import qualified Data.Aeson.Types as JT import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import Data.Text (Text) @@ -208,7 +209,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h pure () tGet' h = do [(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h - pure (Nothing, corrId, qId, cmd) + pure (Nothing, corrId, SBS.fromShort qId, cmd) ntfTest :: Transport c => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation ntfTest _ test' = runNtfTest test' `shouldReturn` () diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index f1d5af1db..88f820406 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -18,6 +18,7 @@ module SMPClient where import Control.Monad import Control.Monad.Except (runExceptT) import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Short as SBS import Data.List.NonEmpty (NonEmpty) import qualified Data.X509 as X import qualified Data.X509.Validation as XV @@ -452,7 +453,7 @@ smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t > pure () tGet' h = do [(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h - pure (Nothing, corrId, qId, cmd) + pure (Nothing, corrId, SBS.fromShort qId, cmd) smpTest :: (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation smpTest _ msType test' = runSmpTest msType test' `shouldReturn` () diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 116b4f0ec..701c5be87 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -29,6 +29,7 @@ import Data.Bifunctor (first) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Short as SBS import Data.Foldable (foldrM) import Data.Hashable (hash) import qualified Data.IntSet as IS @@ -489,13 +490,13 @@ testDuplex = (bDhPub, bDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g Resp "abcd" _ (Ids bRcv bSnd bSrvDh) <- signSendRecv bob brKey ("abcd", NoEntity, New brPub bDhPub) let bDec = decryptMsgV3 $ C.dh' bSrvDh bDhPriv - Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> B64.encode (unEntityId bSnd)) + Resp "bcda" _ OK <- signSendRecv bob bsKey ("bcda", aSnd, _SEND $ "reply_id " <> B64.encode (SBS.fromShort $ unEntityId bSnd)) -- "reply_id ..." is ad-hoc, not a part of SMP protocol Resp "" _ (Msg mId2 msg2) <- tGet1 alice Resp "cdab" _ OK <- signSendRecv alice arKey ("cdab", aRcv, ACK mId2) Right ["reply_id", bId] <- pure $ B.words <$> aDec mId2 msg2 - (bId, B64.encode (unEntityId bSnd)) #== "reply queue ID received from Bob" + (bId, B64.encode (SBS.fromShort $ unEntityId bSnd)) #== "reply queue ID received from Bob" (asPub, asKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g Resp "dabc" _ OK <- sendRecv alice ("", "dabc", bSnd, _SEND $ "key " <> strEncode asPub) @@ -1161,9 +1162,9 @@ checkStats s qs sent received = do _msgSentNtf s `shouldBe` 0 _msgRecvNtf s `shouldBe` 0 let PeriodStatsData {_day, _week, _month} = _activeQueues s - IS.toList _day `shouldBe` map (hash . unEntityId) qs - IS.toList _week `shouldBe` map (hash . unEntityId) qs - IS.toList _month `shouldBe` map (hash . unEntityId) qs + IS.toList _day `shouldBe` map (hash . SBS.fromShort . unEntityId) qs + IS.toList _week `shouldBe` map (hash . SBS.fromShort . unEntityId) qs + IS.toList _month `shouldBe` map (hash . SBS.fromShort . unEntityId) qs testRestoreExpireMessages :: SpecWith (ASrvTransport, AStoreType) testRestoreExpireMessages = @@ -1616,7 +1617,7 @@ testInvQueueLinkData = (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g C.CbNonce corrId <- atomically $ C.randomCbNonce g - let sId = EntityId $ B.take 24 $ C.sha3_384 corrId + let sId = EntityId $ SBS.toShort $ B.take 24 $ C.sha3_384 corrId ld = (EncDataBytes "fixed data", EncDataBytes "user data") qrd = QRMessaging $ Just (sId, ld) -- sender ID must be derived from corrId @@ -1672,8 +1673,8 @@ testContactQueueLinkData = (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g C.CbNonce corrId <- atomically $ C.randomCbNonce g - lnkId <- EntityId <$> atomically (C.randomBytes 24 g) - let sId = EntityId $ B.take 24 $ C.sha3_384 corrId + lnkId <- EntityId . SBS.toShort <$> atomically (C.randomBytes 24 g) + let sId = EntityId $ SBS.toShort $ B.take 24 $ C.sha3_384 corrId ld = (EncDataBytes "fixed data", EncDataBytes "user data") qrd = QRContact $ Just (lnkId, (sId, ld)) -- sender ID must be derived from corrId @@ -1711,7 +1712,7 @@ testContactQueueLinkData = sId4 `shouldBe` sId ld3 `shouldBe` newLD - badLnkId <- EntityId <$> atomically (C.randomBytes 24 g) + badLnkId <- EntityId . SBS.toShort <$> atomically (C.randomBytes 24 g) Resp "9" _ (ERR AUTH) <- signSendRecv r rKey ("9", rId, LSET badLnkId newLD) let badLD = (EncDataBytes "changed fixed data", EncDataBytes "updated user data 2") @@ -1732,8 +1733,8 @@ testDuplicateQueueLinkData = (victimPub, victimKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (victimDhPub, _victimDhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g C.CbNonce corrId <- atomically $ C.randomCbNonce g - lnkId <- EntityId <$> atomically (C.randomBytes 24 g) - let victimSId = EntityId $ B.take 24 $ C.sha3_384 corrId + lnkId <- EntityId . SBS.toShort <$> atomically (C.randomBytes 24 g) + let victimSId = EntityId $ SBS.toShort $ B.take 24 $ C.sha3_384 corrId victimLD = (EncDataBytes "fixed data", EncDataBytes "victim user data") victimQRD = QRContact $ Just (lnkId, (victimSId, victimLD)) victimReq = NEW (NewQueueReq victimPub victimDhPub Nothing SMSubscribe (Just victimQRD) Nothing) diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 693856d9f..e86662100 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -20,6 +20,7 @@ import Data.ByteString.Builder (byteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.ByteString.Short as SBS import qualified Data.CaseInsensitive as CI import Data.List (find, isInfixOf) import Data.List.NonEmpty (NonEmpty) @@ -104,7 +105,7 @@ createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APu createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing readChunk :: XFTPFileId -> IO ByteString -readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode $ unEntityId sId)) +readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode $ SBS.fromShort $ unEntityId sId)) testFileChunkDelivery :: AFStoreType -> Expectation testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c