diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 451de173ba..8ee1d75eca 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -48,6 +48,19 @@ jobs: - name: Set up Docker Buildx uses: simplex-chat/docker-setup-buildx-action@v3 + - name: Install PostgreSQL 15 client tools + if: matrix.os == '22.04' + shell: bash + run: | + # Import the repository signing key + sudo install -d /usr/share/postgresql-common/pgdg + sudo curl -o /usr/share/postgresql-common/pgdg/apt.postgresql.org.asc --fail https://www.postgresql.org/media/keys/ACCC4CF8.asc + # Add the PostgreSQL APT repository + sudo sh -c 'echo "deb [signed-by=/usr/share/postgresql-common/pgdg/apt.postgresql.org.asc] https://apt.postgresql.org/pub/repos/apt $(lsb_release -cs)-pgdg main" > /etc/apt/sources.list.d/pgdg.list' + # Update repository and install postgresql tools + sudo apt update + sudo apt -y install postgresql-client-15 + - name: Build and cache Docker image uses: simplex-chat/docker-build-push-action@v6 with: @@ -82,7 +95,7 @@ jobs: build/${{ matrix.platform_name }}:latest - name: Build smp-server (postgresql) and tests - shell: docker exec -t builder sh {0} + shell: docker exec -t builder sh -eu {0} run: | cabal update cabal build --jobs=$(nproc) --enable-tests -fserver_postgres @@ -106,7 +119,7 @@ jobs: docker cp builder:/out/smp-server ./smp-server-postgres-ubuntu-${{ matrix.platform_name }} - name: Build everything else (standard) - shell: docker exec -t builder sh {0} + shell: docker exec -t builder sh -eu {0} run: | cabal build --jobs=$(nproc) mkdir -p /out diff --git a/apps/smp-server/static/a/index.html b/apps/smp-server/static/a/index.html new file mode 120000 index 0000000000..fbab335f5d --- /dev/null +++ b/apps/smp-server/static/a/index.html @@ -0,0 +1 @@ +./apps/smp-server/static/link.html \ No newline at end of file diff --git a/apps/smp-server/static/c/index.html b/apps/smp-server/static/c/index.html new file mode 120000 index 0000000000..fbab335f5d --- /dev/null +++ b/apps/smp-server/static/c/index.html @@ -0,0 +1 @@ +./apps/smp-server/static/link.html \ No newline at end of file diff --git a/apps/smp-server/static/i/index.html b/apps/smp-server/static/i/index.html new file mode 120000 index 0000000000..fbab335f5d --- /dev/null +++ b/apps/smp-server/static/i/index.html @@ -0,0 +1 @@ +./apps/smp-server/static/link.html \ No newline at end of file diff --git a/apps/smp-server/web/Static.hs b/apps/smp-server/web/Static.hs index c4a3e84f7f..8d85c4b7fa 100644 --- a/apps/smp-server/web/Static.hs +++ b/apps/smp-server/web/Static.hs @@ -84,11 +84,16 @@ generateSite si onionHost sitePath = do B.writeFile (sitePath "index.html") $ serverInformation si onionHost createDirectoryIfMissing True $ sitePath "media" forM_ E.mediaContent $ \(path, bs) -> B.writeFile (sitePath "media" path) bs - createDirectoryIfMissing True $ sitePath "contact" - B.writeFile (sitePath "contact" "index.html") E.linkHtml - createDirectoryIfMissing True $ sitePath "invitation" - B.writeFile (sitePath "invitation" "index.html") E.linkHtml + createLinkPage "contact" + createLinkPage "invitation" + createLinkPage "a" + createLinkPage "c" + createLinkPage "i" logInfo $ "Generated static site contents at " <> tshow sitePath + where + createLinkPage path = do + createDirectoryIfMissing True $ sitePath path + B.writeFile (sitePath path "index.html") E.linkHtml serverInformation :: ServerInformation -> Maybe TransportHost -> ByteString serverInformation ServerInformation {config, information} onionHost = render E.indexHtml substs diff --git a/rfcs/2025-04-04-short-links-for-groups.md b/rfcs/2025-04-04-short-links-for-groups.md index 45f00d7089..90938acec0 100644 --- a/rfcs/2025-04-04-short-links-for-groups.md +++ b/rfcs/2025-04-04-short-links-for-groups.md @@ -59,45 +59,101 @@ While the server domain would be used as the hostname in group link, it may cont Pros: separates additional complexity to where it is needed, allowing reliability and redundancy for group ownership. Cons: complexity, coupling between SMP and chat protocol. -## Design ideas for group as a separate entity type +## Design for channel/group as a separate queue mode -The last solution approach seems both the most long-term and also provides the best functionality, so maybe it could be an extensible base. +Option 1. -Its advantage is that it does not require e2e encryption between owners, as only public keys are shared (although MITM is still possible without verification, mitigated by using multiple chat relays). +A queue mode "channel" when owners are represented by their individual queues (either a separate mode, or a submode of "channel", or just normal contact address queues). In this case sending message to channel queue would broadcast message to queue owners, without exposing even the number of owners. -The proposal is to have a new entity "asset", and a queue mode "asset". This entity represents a reference to some kind of digital asset, not part of SMP spec. Each link is managed by multiple owners, each represented with "asset" queue. +Pros: +- allows chat relays to send messages to all owners (e.g., channel can be secured with the list of snd keys, one per relay). +- quite easy to evolve from the current design. +- extensible. +Cons: +- close to "solution in search of a problem". +- does not require data model changes - channel queue would simply have a list of owner "recipient IDs", and each owner queue would also point to channel. + +Option 2. + +Also a separate queue mode "channel", but instead of having a linked owner queues, it would simply maintain a list of owner keys to maintain the data. In this case, messages cannot be sent to this "queue" at all. + +Pros: +- simpler design. +- we could allow sending messages to it too, with the "main" owner receiving them. This could be negotiated in the protocol. +- it may be easier to migrate the current groups, as the admin link would be this queue (although for public groups in directory it would have to be recreated anyway). +- Possibly, when queue is created there should be a flag whether it should accept unsigned messages - then contact addresses would be created with unsigned messages ON, messages queues, once SKEY is universally supported, with unsigned messages OFF, and channel queues with unsigned messages OFF too for new public queues. +Cons: +- if no messages are accepted, this is not even a queue. +- no way to directly contact owners (maybe it is not a downside, as for relays there would be a communication channel anyway as part of the group). + +Option 2 looks more simple and attractive, implementing server broadcast for SMP seems unnecessary, as while it could have been used for simple groups, it does not solve such problems as spam and pre-moderation anyway - it requires a higher level protocol. + +The command to update owner keys would be `RKEY` with the list of keys, and we can make `NEW` accept multiple keys too, although the use case here is less clear. + +## Multiple owners managing queue data. + +Option 1: Use the same keys in SMP as when signing queue data. + +Option 2: Use different keys. + +The value here could be that the server could validate these signatures too, and also maintain the chain of key changes. While tempting, it is probably unnecessary, and this chain of ownership is better to be maintained on chat relay level, as there are no size constraints on the size of this chain. Also, it is better for metadata privacy to not couple transport and chat protocol keys. + +We still need to bind the mutable data updates to the "genesis" signature key (the one included in the immutable data). + +The proposed design: -The change from the current design is simple - splitting the link and data from the queue table/record into a separate table, so that the same link can be referenced by multiple queues with different owner IDs. Any of the linked asset queue recipients can modify link data and delete link. The protocol encoding could support multisig, but it can be added later with a separate protocol version. But it would alread allow having multiple owners for link. +- when mutable data is signed by genesis key, then it is bound, and no changes is needed. +- mutable data may be signed by the key of the new owner, in which case mutable part itself must contain the binding. We could also use ring signature to sign the mutable data, concealing which owner signed the data - that would increase the signature size from 64 bytes to `32 * (n + 1)` bytes. -It is also probably correct to require that Ed25519 is used for recipient/owner authorization (and not X25519 authenticators that are used for senders). +Current mutable data: -Question 1: should the same signature key be used for signing server commands and owner-owner comms? There may be a benefit in having two different keys, and in contexts visible to both server and owners use server key, and in contexts visible to owners only use signature key inside data. +```haskell +data UserLinkData = UserLinkData + { agentVRange :: VersionRangeSMPA, + userData :: ConnInfo + } +``` -Question 2: should non-owners see server keys of owners? If not, does it suggest a third owner-only data blob? Or should the server simply maintain the currently signed ownership agreement? Or even the history of the agreement changes? +Proposed mutable data: -Question 3: how would the owner validate the correctness of ownership changes - where this chain will be maintained? Should it maybe be replicated to all owners' "asset" queues? Or will it be a separate "chain" that will be truncated once all owners acknowledge the change? Almost like a separate queue? +```haskell +data UserLinkData = UserLinkData + { agentVRange :: VersionRangeSMPA, + owners :: [OwnerInfo] + userData :: ConnInfo + } -The protocol change required would be to make sender ID optional in LNK response. Alternatively, link could have its own sender ID and broadcast messages to link owners, and a rule whether messages can be sent without key, and whether this link can be secured with SKEY. Depending on queue type it would be: +type OwnerId = ByteString -- "messaging" queue: can secure, can send messages. -- "contact" queue: cannot secure (only owner can secure), can send unsigned messages. -- "asset" queue: cannot secure, cannot send unsigned messages. +data OwnerInfo = OwnerInfo + { ownerId :: OwnerId, -- unique in the list, application specific - e.g., MemberId + ownerKey :: PublicKeyEd25519, + -- owner signature of sender ID, + -- confirms that the owner agreed with being the owner, + -- prevents a member being added as an owner without consent. + ownerSig :: SignatureEd25519, + -- owner authorization, sig(ownerId || ownerKey, prevKey), where prevKey is either a "genesis key" or some other key previously signed by the genesis key. + authOwnerId :: OwnerId, -- null for "genesis" + authOwnerSig :: SignatureEd25519 + } +``` -To allow multiple delegates the queue could allow multiple send keys. In case of delegates (chat relays), we could require that only Ed25519 keys are used (for non-repudiation). +The size of the OwnerInfo record encoding is: +- ownerId: 1 + 12 +- ownerKey: 1 + 32 +- ownerSig: 1 + 64 +- ownerAuthId: 1 + 12 +- ownerAuthSig: 1 + 64 -The additional commands required would be to add, get and delete link owners: -- invite owner (OADD): adds some random server-generated new owner ID to link - this token with the current owner's signature will be included in NEW command (the signed token to be passed out of band). Separate table? -- remove owner (ODEL): remove owner from link by owner ID (both before and after new owner accepted ownership). -- get owners (OGET): get current owner IDs and their public keys. -- how would notification be delivered to the owner when s/he is removed? Some event? Possibly all changes are delivered as messages to each "owner's" asset queue, probably with longer expiration periods? +~189 bytes, so we should practically limit the number of owners to say 8 - 1 original + 7 addiitonal. Original creator could use a different key as a "genesis" key, to conceal creator identity from other members, and it needs to include the record with memberId anyway. -While initially we don't need to build support for multisig in UX, it can be easily added later with this design. +The structure is simplified, and it does not allow arbitrary ownership changes. Its purpose is not to comprehensively manage ownership changes - while it is possible with a generic blockchain, it seems not appropriate at this stage, - but rather to ensure access continuity and that the server cannot modify the data (although nothing prevents the server from removing the data completely or from serving the previous version of the data). -The flow then would be, for new "asset" queue with link - it is created as usual, with "NEW" command, and queueMode QMAsset that is passed linkId and link data. +For example it would only allow any given owner to remove subsequenty added owners, preserving the group link and identity, but it won't allow removing owners that signed this owner authorization. So owners are not equal, with the creator having the highest rank and being able to remove all additional owners, and owners authorise by creator can remove all other owners but themselves and creator, and so on - they have to maintain the chain that authorized themselves, at least. We could explicitely include owner rank into OwnerInfo, or we could require that they are sorted by rank, or the rank can be simply derived from signatures. -When additional owners want to be added to the group, they would have to create "link" type queue without link ID (thus preventing non-consensual ownership transfer). The flow would be this: -- group owner(s) offer to become additional owner with the specific new multisig rule, this is sent as a message in chat with signed ID from `OADD` command. -- the proposed owner will validate that this offer is signed according to the current multisig rule, by loading queue data and current owners (possibly via its ID from `OADD` command, that would also secure this owner ID). -- if the proposed owner accepts it, s/he will create a new "asset" queue linking it with the same link ID - the server would also accept signed owner ID as a confirmation. +When additional owners want to be added to the group, they would have to provide any of the current owners: +- the key for SMP commands authorization - this will be passed to SMP server together with other keys. There could be either RKEY to pass all keys (some risk to miss some, or of race conditions), or RADD/RGET/RDEL to add and remove recipient keys, which has no risk of race conditions. +- the signature of the immutable data by their member key included in their profile. +- the current owner would then include their member key into the queue data, and update it with LSET command. In any case there should be some simple consensus protocol between owners for owner changes, and it has to be maintained as a blockchain by owners and by chat relays, as otherwise it may lead to race conditions with LSET command. -Alternatively, it could be an out-of-band exchange first, when existing owner sends an offer, the new owner accepts it and returns the key (and signed offer), and then this key is sent to the server by the old owner, returning owner ID to the new owner. +Potentially, there could be one command to update keys and link data, so that they are consistent. diff --git a/simplexmq.cabal b/simplexmq.cabal index d1f30a2b9a..677342ddce 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -482,6 +482,9 @@ test-suite simplexmq-test other-modules: AgentTests.SchemaDump AgentTests.SQLiteTests + if flag(server_postgres) + other-modules: + ServerTests.SchemaDump hs-source-dirs: tests apps/smp-server/web @@ -537,11 +540,13 @@ test-suite simplexmq-test if flag(client_postgres) cpp-options: -DdbPostgres else + build-depends: + memory + , sqlcipher-simple + if !flag(client_postgres) || flag(server_postgres) build-depends: deepseq ==1.4.* - , memory , process - , sqlcipher-simple if flag(client_postgres) || flag(server_postgres) build-depends: postgresql-simple ==0.7.* diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index dd457ebb09..34d6bbc970 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -200,6 +200,7 @@ import Simplex.Messaging.Protocol MsgFlags (..), NtfServer, ProtoServerWithAuth (..), + ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), QueueLinkData, @@ -379,7 +380,7 @@ deleteContactShortLink c = withAgentEnv c . deleteContactShortLink' c {-# INLINE deleteContactShortLink #-} -- | Get and verify data from short link. For 1-time invitations it preserves the key to allow retries -getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnInfo) +getConnShortLink :: AgentClient -> UserId -> ConnShortLink c -> AE (ConnectionRequestUri c, ConnLinkData c) getConnShortLink c = withAgentEnv c .: getConnShortLink' c {-# INLINE getConnShortLink #-} @@ -838,7 +839,7 @@ setContactShortLink' c connId userData = SomeConn _ (ContactConnection _ rq) -> do (lnkId, linkKey, d) <- prepareLinkData rq addQueueLink c rq lnkId d - pure $ CSLContact (qServer rq) CCTContact linkKey + pure $ CSLContact SLSServer CCTContact (qServer rq) linkKey _ -> throwE $ CMD PROHIBITED "setContactShortLink: not contact address" where prepareLinkData :: RcvQueue -> AM (SMP.LinkId, LinkKey, QueueLinkData) @@ -870,9 +871,9 @@ deleteContactShortLink' c connId = _ -> throwE $ CMD PROHIBITED "deleteContactShortLink: not contact address" -- TODO [short links] remove 1-time invitation data and link ID from the server after the message is sent. -getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnInfo) +getConnShortLink' :: forall c. AgentClient -> UserId -> ConnShortLink c -> AM (ConnectionRequestUri c, ConnLinkData c) getConnShortLink' c userId = \case - CSLInvitation srv linkId linkKey -> do + CSLInvitation _ srv linkId linkKey -> do g <- asks random invLink <- withStore' c $ \db -> do getInvShortLink db srv linkId >>= \case @@ -886,20 +887,22 @@ getConnShortLink' c userId = \case ld@(sndId, _) <- secureGetQueueLink c userId invLink withStore' c $ \db -> setInvShortLinkSndId db invLink sndId decryptData srv linkKey k ld - CSLContact srv _ linkKey -> do + CSLContact _ _ srv linkKey -> do let (linkId, k) = SL.contactShortLinkKdf linkKey ld <- getQueueLink c userId srv linkId decryptData srv linkKey k ld where - decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, QueueLinkData) -> AM (ConnectionRequestUri c, ConnInfo) + decryptData :: ConnectionModeI c => SMPServer -> LinkKey -> C.SbKey -> (SMP.SenderId, QueueLinkData) -> AM (ConnectionRequestUri c, ConnLinkData c) decryptData srv linkKey k (sndId, d) = do r@(cReq, _) <- liftEither $ SL.decryptLinkData @c linkKey k d - unless ((srv, sndId) `sameQAddress` qAddress (connReqQueue cReq)) $ + let (srv', sndId') = qAddress (connReqQueue cReq) + unless (srv `sameSrvHost` srv' && sndId == sndId') $ throwE $ AGENT $ A_LINK "different address" pure r + sameSrvHost ProtocolServer {host = h :| _} ProtocolServer {host = hs} = h `elem` hs deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM () -deleteLocalInvShortLink' c (CSLInvitation srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId +deleteLocalInvShortLink' c (CSLInvitation _ srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM () changeConnectionUser' c oldUserId connId newUserId = do @@ -978,12 +981,12 @@ newRcvConnSrv c userId connId enableNtfs cMode userData_ clientData pqInitKeys s Just ShortLinkCreds {shortLinkId, shortLinkKey} | qUri == qUri' -> let link = case cReq of - CRContactUri _ -> CSLContact srv CCTContact shortLinkKey - CRInvitationUri {} -> CSLInvitation srv shortLinkId shortLinkKey + CRContactUri _ -> CSLContact SLSServer CCTContact srv shortLinkKey + CRInvitationUri {} -> CSLInvitation SLSServer srv shortLinkId shortLinkKey in pure $ CCLink cReq (Just link) | otherwise -> throwE $ INTERNAL "different rcv queue address" Nothing -> - let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri] clientData) + let updated (ConnReqUriData _ vr _ _) = (ConnReqUriData SSSimplex vr [qUri'] clientData) cReq' = case cReq of CRContactUri crData -> CRContactUri (updated crData) CRInvitationUri crData e2eParams -> CRInvitationUri (updated crData) e2eParams diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index eced35c086..419ca1d914 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -102,8 +102,6 @@ module Simplex.Messaging.Agent.Protocol ConnectionMode (..), SConnectionMode (..), AConnectionMode (..), - cmInvitation, - cmContact, ConnectionModeI (..), ConnectionRequestUri (..), AConnectionRequestUri (..), @@ -111,17 +109,22 @@ module Simplex.Messaging.Agent.Protocol CRClientData, ServiceScheme, FixedLinkData (..), - UserLinkData (..), + ConnLinkData (..), + OwnerAuth (..), + OwnerId, ConnectionLink (..), AConnectionLink (..), ConnShortLink (..), AConnShortLink (..), CreatedConnLink (..), ContactConnType (..), + ShortLinkScheme (..), LinkKey (..), sameConnReqContact, simplexChat, connReqUriP', + simplexConnReqUri, + simplexShortLink, AgentErrorType (..), CommandErrorType (..), ConnectionErrorType (..), @@ -156,6 +159,7 @@ module Simplex.Messaging.Agent.Protocol updateSMPServerHosts, shortenShortLink, restoreShortLink, + linkUserData, ) where @@ -167,7 +171,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64.URL as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Char (isDigit) +import Data.Char (toLower, toUpper) import Data.Foldable (find) import Data.Functor (($>)) import Data.Int (Int64) @@ -251,6 +255,7 @@ import UnliftIO.Exception (Exception) -- 4 - delivery receipts (7/13/2023) -- 5 - post-quantum double ratchet (3/14/2024) -- 6 - secure reply queues with provided keys (6/14/2024) +-- 7 - initialize ratchet on processing confirmation (7/18/2024) data SMPAgentVersion @@ -695,14 +700,6 @@ data AConnectionMode = forall m. ConnectionModeI m => ACM (SConnectionMode m) instance Eq AConnectionMode where ACM m == ACM m' = isJust $ testEquality m m' -cmInvitation :: AConnectionMode -cmInvitation = ACM SCMInvitation -{-# INLINE cmInvitation #-} - -cmContact :: AConnectionMode -cmContact = ACM SCMContact -{-# INLINE cmContact #-} - deriving instance Show AConnectionMode connMode :: SConnectionMode m -> ConnectionMode @@ -711,8 +708,8 @@ connMode SCMContact = CMContact {-# INLINE connMode #-} connMode' :: ConnectionMode -> AConnectionMode -connMode' CMInvitation = cmInvitation -connMode' CMContact = cmContact +connMode' CMInvitation = ACM SCMInvitation +connMode' CMContact = ACM SCMContact {-# INLINE connMode' #-} class ConnectionModeI (m :: ConnectionMode) where sConnectionMode :: SConnectionMode m @@ -1084,8 +1081,16 @@ instance Encoding ConnReqUriData where smpEncode ConnReqUriData {crAgentVRange, crSmpQueues, crClientData} = smpEncode (crAgentVRange, crSmpQueues, Large . encodeUtf8 <$> crClientData) smpP = do - (crAgentVRange, crSmpQueues, clientData) <- smpP + (crAgentVRange, smpQueues, clientData) <- smpP + -- This patch to compensate for the fact that queueMode QMContact won't be included in queue encoding, + -- until min SMP client version is >= 3 (sndAuthKeySMPClientVersion). + -- This is possible because SMP encoding of ConnReqUriData was not used prior to SMP client version 4. + let crSmpQueues = L.map patchQueueMode smpQueues pure ConnReqUriData {crScheme = SSSimplex, crAgentVRange, crSmpQueues, crClientData = safeDecodeUtf8 . unLarge <$> clientData} + where + patchQueueMode q@SMPQueueUri {queueAddress = a} = case a of + SMPQueueAddress {queueMode = Nothing} -> q {queueAddress = a {queueMode = Just QMContact}} :: SMPQueueUri + _ -> q connReqUriP' :: forall m. ConnectionModeI m => Maybe ServiceScheme -> Parser (ConnectionRequestUri m) connReqUriP' overrideScheme = do @@ -1342,6 +1347,11 @@ data ConnectionRequestUri (m :: ConnectionMode) where -- they are passed in AgentInvitation message CRContactUri :: ConnReqUriData -> ConnectionRequestUri CMContact +simplexConnReqUri :: ConnectionRequestUri m -> ConnectionRequestUri m +simplexConnReqUri = \case + CRInvitationUri crData e2eParams -> CRInvitationUri crData {crScheme = SSSimplex} e2eParams + CRContactUri crData -> CRContactUri crData {crScheme = SSSimplex} + deriving instance Eq (ConnectionRequestUri m) deriving instance Show (ConnectionRequestUri m) @@ -1355,14 +1365,21 @@ instance Eq AConnectionRequestUri where deriving instance Show AConnectionRequestUri +data ShortLinkScheme = SLSSimplex | SLSServer deriving (Eq, Show) + data ConnShortLink (m :: ConnectionMode) where - CSLInvitation :: SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation - CSLContact :: SMPServer -> ContactConnType -> LinkKey -> ConnShortLink 'CMContact + CSLInvitation :: ShortLinkScheme -> SMPServer -> SMP.LinkId -> LinkKey -> ConnShortLink 'CMInvitation + CSLContact :: ShortLinkScheme -> ContactConnType -> SMPServer -> LinkKey -> ConnShortLink 'CMContact deriving instance Eq (ConnShortLink m) deriving instance Show (ConnShortLink m) +simplexShortLink :: ConnShortLink m -> ConnShortLink m +simplexShortLink = \case + CSLInvitation _ srv lnkId k -> CSLInvitation SLSSimplex srv lnkId k + CSLContact _ ct srv k -> CSLContact SLSSimplex ct srv k + newtype LinkKey = LinkKey ByteString -- sha3-256(fixed_data) deriving (Eq, Show) deriving newtype (FromField, StrEncoding) @@ -1377,7 +1394,7 @@ instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode -data ContactConnType = CCTContact | CCTGroup deriving (Eq, Show) +data ContactConnType = CCTContact | CCTChannel | CCTGroup deriving (Eq, Show) data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) @@ -1414,53 +1431,103 @@ instance ConnectionModeI m => FromJSON (ConnectionLink m) where instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case - CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) -> encLink srv (lnkId <> k) "i" - CSLContact srv ct (LinkKey k) -> encLink srv k $ case ct of CCTContact -> "c"; CCTGroup -> "g" + CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) -> slEncode sch srv 'i' lnkId k + CSLContact sch ct srv (LinkKey k) -> slEncode sch srv (toLower $ ctTypeChar ct) "" k where - encLink (SMPServer (h :| hs) port (C.KeyHash kh)) linkUri linkType = - "https://" <> strEncode h <> port' <> "/" <> linkType <> "#" <> khStr <> hosts <> B64.encodeUnpadded linkUri + slEncode sch (SMPServer (h :| hs) port (C.KeyHash kh)) linkType lnkId k = + B.concat [authority, "/", B.singleton linkType, "#", lnkIdStr, B64.encodeUnpadded k, queryStr] where - port' = if null port then "" else B.pack (':' : port) - hosts = if null hs then "" else strEncode (TransportHosts_ hs) <> "/" - khStr = if B.null kh then "" else B64.encodeUnpadded kh <> "@" - strP = do - ACSL m l <- strP - case testEquality m $ sConnectionMode @m of - Just Refl -> pure l - _ -> fail "bad short link mode" + (authority, paramHosts) = case sch of + SLSSimplex -> ("simplex:", h : hs) + SLSServer -> ("https://" <> strEncode h, hs) + lnkIdStr = if B.null lnkId then "" else B64.encodeUnpadded lnkId <> "/" + queryStr = if B.null query then "" else "?" <> query + query = + strEncode . QSP QEscape $ + [("h", strEncode (TransportHosts_ paramHosts)) | not (null paramHosts)] + <> [("p", B.pack port) | not (null port)] + <> [("c", B64.encodeUnpadded kh) | not (B.null kh)] + strP = (\(ACSL _ l) -> checkConnMode l) <$?> strP + {-# INLINE strP #-} instance StrEncoding AConnShortLink where strEncode (ACSL _ l) = strEncode l + {-# INLINE strEncode #-} strP = do - h <- "https://" *> strP - port <- A.char ':' *> (B.unpack <$> A.takeWhile1 isDigit) <|> pure "" - linkType <- A.char '/' *> A.anyChar - keyHash <- optional (A.char '/') *> A.char '#' *> (strP <* A.char '@' <|> pure (C.KeyHash "")) - TransportHosts_ hs <- strP <* "/" <|> pure (TransportHosts_ []) - linkUri <- strP - let srv = SMPServer (h :| hs) port keyHash - case linkType of - 'i' - | B.length linkUri == 56 -> - let (lnkId, k) = B.splitAt 24 linkUri - in pure $ ACSL SCMInvitation $ CSLInvitation srv (SMP.EntityId lnkId) (LinkKey k) - | otherwise -> fail "bad ConnShortLink: incorrect linkID and key length" - 'c' -> contactP srv CCTContact linkUri - 'g' -> contactP srv CCTGroup linkUri - _ -> fail "bad ConnShortLink: unknown link type" + (sch, h_) <- authorityP <* A.char '/' + ct_ <- contactTypeP <* optional (A.char '/') <* A.char '#' + case ct_ of + Nothing -> do + lnkId <- strP <* A.char '/' + k <- strP + srv <- serverQueryP h_ + pure $ ACSL SCMInvitation $ CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) + Just ct -> do + k <- strP + srv <- serverQueryP h_ + pure $ ACSL SCMContact $ CSLContact sch ct srv (LinkKey k) where - contactP srv ct k - | B.length k == 32 = pure $ ACSL SCMContact $ CSLContact srv ct (LinkKey k) - | otherwise = fail "bad ConnShortLink: incorrect key length" + authorityP = + "simplex:" $> (SLSSimplex, Nothing) + <|> "https://" *> ((SLSServer,) . Just <$> strP) + <|> fail "bad short link scheme" + contactTypeP = do + Just <$> (A.anyChar >>= ctTypeP . toUpper) + <|> A.char 'i' $> Nothing + <|> fail "unknown short link type" + serverQueryP h_ = + optional (A.char '?' *> strP) >>= \case + Nothing -> maybe noServer (pure . SMPServerOnlyHost) h_ + Just query -> do + hs <- maybe noServer pure . L.nonEmpty . maybe id (:) h_ . maybe [] thList_ =<< queryParam_ "h" query + p <- maybe "" show <$> queryParam_ @Word16 "p" query + kh <- fromMaybe (C.KeyHash "") <$> queryParam_ "c" query + pure $ SMPServer hs p kh + noServer = fail "short link without server" + +instance ConnectionModeI m => Encoding (ConnShortLink m) where + smpEncode = \case + CSLInvitation _ srv lnkId (LinkKey k) -> smpEncode (CMInvitation, srv, lnkId, k) + CSLContact _ ct srv (LinkKey k) -> smpEncode (CMContact, ctTypeChar ct, srv, k) + smpP = (\(ACSL _ l) -> checkConnMode l) <$?> smpP + {-# INLINE smpP #-} + +instance Encoding AConnShortLink where + smpEncode (ACSL _ l) = smpEncode l + {-# INLINE smpEncode #-} + smpP = + smpP >>= \case + CMInvitation -> do + (srv, lnkId, k) <- smpP + pure $ ACSL SCMInvitation $ CSLInvitation SLSServer srv lnkId (LinkKey k) + CMContact -> do + ct <- ctTypeP =<< A.anyChar + (srv, k) <- smpP + pure $ ACSL SCMContact $ CSLContact SLSServer ct srv (LinkKey k) + +ctTypeP :: Char -> Parser ContactConnType +ctTypeP = \case + 'A' -> pure CCTContact + 'C' -> pure CCTChannel + 'G' -> pure CCTGroup + _ -> fail "unknown contact address type" +{-# INLINE ctTypeP #-} + +ctTypeChar :: ContactConnType -> Char +ctTypeChar = \case + CCTContact -> 'A' + CCTChannel -> 'C' + CCTGroup -> 'G' +{-# INLINE ctTypeChar #-} -- the servers passed to this function should be all preset servers, not servers configured by the user. shortenShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m shortenShortLink presetSrvs = \case - CSLInvitation srv lnkId linkKey -> CSLInvitation (shortServer srv) lnkId linkKey - CSLContact srv ct linkKey -> CSLContact (shortServer srv) ct linkKey + CSLInvitation sch srv lnkId linkKey -> CSLInvitation sch (shortServer srv) lnkId linkKey + CSLContact sch ct srv linkKey -> CSLContact sch ct (shortServer srv) linkKey where shortServer srv@(SMPServer hs@(h :| _) p kh) = - if isPresetServer then SMPServer [h] "" (C.KeyHash "") else srv + if isPresetServer then SMPServerOnlyHost h else srv where isPresetServer = case findPresetServer srv presetSrvs of Just (SMPServer hs' p' kh') -> @@ -1469,14 +1536,20 @@ shortenShortLink presetSrvs = \case && kh == kh' Nothing -> False +-- explicit bidirectional is used for ghc 8.10.7 compatibility, [h]/[] patterns are not reversible. +pattern SMPServerOnlyHost :: TransportHost -> SMPServer +pattern SMPServerOnlyHost h <- SMPServer [h] "" (C.KeyHash "") + where + SMPServerOnlyHost h = SMPServer [h] "" (C.KeyHash "") + -- the servers passed to this function should be all preset servers, not servers configured by the user. restoreShortLink :: NonEmpty SMPServer -> ConnShortLink m -> ConnShortLink m restoreShortLink presetSrvs = \case - CSLInvitation srv lnkId linkKey -> CSLInvitation (fullServer srv) lnkId linkKey - CSLContact srv ct linkKey -> CSLContact (fullServer srv) ct linkKey + CSLInvitation sch srv lnkId linkKey -> CSLInvitation sch (fullServer srv) lnkId linkKey + CSLContact sch ct srv linkKey -> CSLContact sch ct (fullServer srv) linkKey where fullServer = \case - s@(SMPServer [_] "" (C.KeyHash "")) -> fromMaybe s $ findPresetServer s presetSrvs + s@(SMPServerOnlyHost _) -> fromMaybe s $ findPresetServer s presetSrvs s -> s findPresetServer :: SMPServer -> NonEmpty SMPServer -> Maybe SMPServer @@ -1507,28 +1580,83 @@ type CRClientData = Text data FixedLinkData c = FixedLinkData { agentVRange :: VersionRangeSMPA, - sigKey :: C.PublicKeyEd25519, + rootKey :: C.PublicKeyEd25519, connReq :: ConnectionRequestUri c } -data UserLinkData = UserLinkData - { agentVRange :: VersionRangeSMPA, - userData :: ConnInfo +data ConnLinkData c where + InvitationLinkData :: VersionRangeSMPA -> ConnInfo -> ConnLinkData 'CMInvitation + ContactLinkData :: + { agentVRange :: VersionRangeSMPA, + -- direct connection via connReq in fixed data is allowed. + direct :: Bool, + -- additional owner keys to sign changes of mutable data. + owners :: [OwnerAuth], + -- alternative addresses of chat relays that receive requests for this contact address. + relays :: [ConnShortLink 'CMContact], + userData :: ConnInfo + } -> ConnLinkData 'CMContact + +data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m) + +linkUserData :: ConnLinkData c -> ConnInfo +linkUserData = \case + InvitationLinkData _ d -> d + ContactLinkData {userData} -> userData + +type OwnerId = ByteString + +data OwnerAuth = OwnerAuth + { ownerId :: OwnerId, -- unique in the list, application specific - e.g., MemberId + ownerKey :: C.PublicKeyEd25519, + -- sender ID signed with ownerKey, + -- confirms that the owner accepts being the owner. + -- sender ID is used here as it is immutable for the queue, link data can be removed. + ownerSig :: C.Signature 'C.Ed25519, + -- null for root key authorization + authOwnerId :: OwnerId, + -- owner authorization, sig(ownerId || ownerKey, key(authOwnerId)), + -- where authOwnerId is either null for a root key or some other owner authorized by root key, etc. + -- Owner validation should detect and reject loops. + authOwnerSig :: C.Signature 'C.Ed25519 } -instance ConnectionModeI c => Encoding (FixedLinkData c) where - smpEncode FixedLinkData {agentVRange, sigKey, connReq} = - smpEncode (agentVRange, sigKey, connReq) +instance Encoding OwnerAuth where + smpEncode OwnerAuth {ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig} = + smpEncode (ownerId, ownerKey, C.signatureBytes ownerSig, authOwnerId, C.signatureBytes authOwnerSig) smpP = do - (agentVRange, sigKey, connReq) <- smpP - pure FixedLinkData {agentVRange, sigKey, connReq} + (ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig) <- smpP + pure OwnerAuth {ownerId, ownerKey, ownerSig, authOwnerId, authOwnerSig} -instance Encoding UserLinkData where - smpEncode UserLinkData {agentVRange, userData} = - smpEncode (agentVRange, Large userData) +instance ConnectionModeI c => Encoding (FixedLinkData c) where + smpEncode FixedLinkData {agentVRange, rootKey, connReq} = + smpEncode (agentVRange, rootKey, connReq) smpP = do - (agentVRange, Large userData) <- smpP - pure UserLinkData {agentVRange, userData} + (agentVRange, rootKey, connReq) <- smpP + pure FixedLinkData {agentVRange, rootKey, connReq} + +instance ConnectionModeI c => Encoding (ConnLinkData c) where + smpEncode = \case + InvitationLinkData vr userData -> smpEncode (CMInvitation, vr, userData) + ContactLinkData {agentVRange, direct, owners, relays, userData} -> + B.concat [smpEncode (CMContact, agentVRange, direct), smpEncodeList owners, smpEncodeList relays, smpEncode userData] + smpP = (\(ACLD _ d) -> checkConnMode d) <$?> smpP + {-# INLINE smpP #-} + +instance Encoding AConnLinkData where + smpEncode (ACLD _ d) = smpEncode d + {-# INLINE smpEncode #-} + smpP = + smpP >>= \case + CMInvitation -> do + (vr, userData) <- smpP + pure $ ACLD SCMInvitation $ InvitationLinkData vr userData + CMContact -> do + (agentVRange, direct) <- smpP + owners <- smpListP + relays <- smpListP + userData <- smpP + pure $ ACLD SCMContact ContactLinkData {agentVRange, direct, owners, relays, userData} -- | SMP queue status. data QueueStatus diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index 39fc653309..e3326b98a9 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -791,10 +791,19 @@ class CryptoSignature s where instance CryptoSignature (Signature s) => StrEncoding (Signature s) where strEncode = serializeSignature + {-# INLINE strEncode #-} strDecode = decodeSignature + {-# INLINE strDecode #-} + +instance CryptoSignature (Signature s) => Encoding (Signature s) where + smpEncode = smpEncode . signatureBytes + {-# INLINE smpEncode #-} + smpP = decodeSignature <$?> smpP + {-# INLINE smpP #-} instance CryptoSignature ASignature where signatureBytes (ASignature _ sig) = signatureBytes sig + {-# INLINE signatureBytes #-} decodeSignature s | B.length s == Ed25519.signatureSize = ASignature SEd25519 . SignatureEd25519 <$> ed Ed25519.signature s @@ -806,6 +815,7 @@ instance CryptoSignature ASignature where instance CryptoSignature (Maybe ASignature) where signatureBytes = maybe "" signatureBytes + {-# INLINE signatureBytes #-} decodeSignature s | B.null s = Right Nothing | otherwise = Just <$> decodeSignature s @@ -814,6 +824,7 @@ instance AlgorithmI a => CryptoSignature (Signature a) where signatureBytes = \case SignatureEd25519 s -> BA.convert s SignatureEd448 s -> BA.convert s + {-# INLINE signatureBytes #-} decodeSignature s = do ASignature _ sig <- decodeSignature s checkAlgorithm sig @@ -824,25 +835,31 @@ instance SignatureSize (Signature a) where signatureSize = \case SignatureEd25519 _ -> Ed25519.signatureSize SignatureEd448 _ -> Ed448.signatureSize + {-# INLINE signatureSize #-} instance SignatureSize ASignature where signatureSize (ASignature _ s) = signatureSize s + {-# INLINE signatureSize #-} instance SignatureSize APrivateSignKey where signatureSize (APrivateSignKey _ k) = signatureSize k + {-# INLINE signatureSize #-} instance SignatureSize APublicVerifyKey where signatureSize (APublicVerifyKey _ k) = signatureSize k + {-# INLINE signatureSize #-} instance SignatureAlgorithm a => SignatureSize (PrivateKey a) where signatureSize = \case PrivateKeyEd25519 _ _ -> Ed25519.signatureSize PrivateKeyEd448 _ _ -> Ed448.signatureSize + {-# INLINE signatureSize #-} instance SignatureAlgorithm a => SignatureSize (PublicKey a) where signatureSize = \case PublicKeyEd25519 _ -> Ed25519.signatureSize PublicKeyEd448 _ -> Ed448.signatureSize + {-# INLINE signatureSize #-} -- | Various cryptographic or related errors. data CryptoError diff --git a/src/Simplex/Messaging/Crypto/ShortLink.hs b/src/Simplex/Messaging/Crypto/ShortLink.hs index 0c269bc20f..8ea38f9fe0 100644 --- a/src/Simplex/Messaging/Crypto/ShortLink.hs +++ b/src/Simplex/Messaging/Crypto/ShortLink.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Simplex.Messaging.Crypto.ShortLink ( contactShortLinkKdf, @@ -45,18 +48,23 @@ contactShortLinkKdf (LinkKey k) = invShortLinkKdf :: LinkKey -> C.SbKey invShortLinkKdf (LinkKey k) = C.unsafeSbKey $ C.hkdf "" k "SimpleXInvLink" 32 -encodeSignLinkData :: ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString)) -encodeSignLinkData (sigKey, pk) agentVRange connReq userData = - let fd = smpEncode FixedLinkData {agentVRange, sigKey, connReq} - ud = smpEncode UserLinkData {agentVRange, userData} - in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk ud)) +encodeSignLinkData :: forall c. ConnectionModeI c => C.KeyPair 'C.Ed25519 -> VersionRangeSMPA -> ConnectionRequestUri c -> ConnInfo -> (LinkKey, (ByteString, ByteString)) +encodeSignLinkData (rootKey, pk) agentVRange connReq userData = + let fd = smpEncode FixedLinkData {agentVRange, rootKey, connReq} + md = smpEncode $ connLinkData @c agentVRange userData + in (LinkKey (C.sha3_256 fd), (encodeSign pk fd, encodeSign pk md)) encodeSignUserData :: C.PrivateKeyEd25519 -> VersionRangeSMPA -> ConnInfo -> ByteString encodeSignUserData pk agentVRange userData = - encodeSign pk $ smpEncode UserLinkData {agentVRange, userData} + encodeSign pk $ smpEncode $ connLinkData @'CMContact agentVRange userData + +connLinkData :: forall c. ConnectionModeI c => VersionRangeSMPA -> ConnInfo -> ConnLinkData c +connLinkData agentVRange userData = case sConnectionMode @c of + SCMInvitation -> InvitationLinkData agentVRange userData + SCMContact -> ContactLinkData {agentVRange, direct = True, owners = [], relays = [], userData} encodeSign :: C.PrivateKeyEd25519 -> ByteString -> ByteString -encodeSign pk s = smpEncode (C.signatureBytes $ C.sign' pk s) <> s +encodeSign pk s = smpEncode (C.sign' pk s) <> s encryptLinkData :: TVar ChaChaDRG -> C.SbKey -> (ByteString, ByteString) -> ExceptT AgentErrorType IO QueueLinkData encryptLinkData g k = bimapM (encrypt fixedDataPaddedLength) (encrypt userDataPaddedLength) @@ -72,22 +80,22 @@ encryptData g k len s = do ct <- liftEitherWith cryptoError $ C.sbEncrypt k nonce s len pure $ EncDataBytes $ smpEncode nonce <> ct -decryptLinkData :: ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnInfo) -decryptLinkData linkKey k (encFD, encUD) = do +decryptLinkData :: forall c. ConnectionModeI c => LinkKey -> C.SbKey -> QueueLinkData -> Either AgentErrorType (ConnectionRequestUri c, ConnLinkData c) +decryptLinkData linkKey k (encFD, encMD) = do (sig1, fd) <- decrypt encFD - (sig2, ud) <- decrypt encUD - FixedLinkData {sigKey, connReq} <- decode fd - UserLinkData {userData} <- decode ud + (sig2, md) <- decrypt encMD + FixedLinkData {rootKey, connReq} <- decode fd + md' <- decode @(ConnLinkData c) md if | LinkKey (C.sha3_256 fd) /= linkKey -> linkErr "link data hash" - | not (C.verify' sigKey sig1 fd) -> linkErr "link data signature" - | not (C.verify' sigKey sig2 ud) -> linkErr "user data signature" - | otherwise -> Right (connReq, userData) + | not (C.verify' rootKey sig1 fd) -> linkErr "link data signature" + | not (C.verify' rootKey sig2 md) -> linkErr "user data signature" + | otherwise -> Right (connReq, md') where decrypt (EncDataBytes d) = do (nonce, Tail ct) <- decode d - (sigBytes, Tail s) <- decode =<< first cryptoError (C.sbDecrypt k nonce ct) - (,s) <$> msgErr (C.decodeSignature sigBytes) + (sig, Tail s) <- decode =<< first cryptoError (C.sbDecrypt k nonce ct) + pure (sig, s) decode :: Encoding a => ByteString -> Either AgentErrorType a decode = msgErr . smpDecode msgErr = first (const $ AGENT A_MESSAGE) diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index b486a7a389..cb2eea43bf 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -241,6 +241,8 @@ import Simplex.Messaging.Version.Internal -- SMP client protocol version history: -- 1 - binary protocol encoding (1/1/2022) -- 2 - multiple server hostnames and versioned queue addresses (8/12/2022) +-- 3 - faster handshake: SKEY command for sender to secure queue (6/30/2024, SMP protocol version 9) +-- 4 - short connection links with stored data (3/30/2025, SMP protocol version 15) data SMPClientVersion @@ -419,6 +421,7 @@ data Command (p :: Party) where NEW :: NewQueueReq -> Command Recipient SUB :: Command Recipient KEY :: SndPublicAuthKey -> Command Recipient + RKEY :: NonEmpty RcvPublicAuthKey -> Command Recipient LSET :: LinkId -> QueueLinkData -> Command Recipient LDEL :: Command Recipient NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient @@ -770,6 +773,7 @@ data CommandTag (p :: Party) where NEW_ :: CommandTag Recipient SUB_ :: CommandTag Recipient KEY_ :: CommandTag Recipient + RKEY_ :: CommandTag Recipient LSET_ :: CommandTag Recipient LDEL_ :: CommandTag Recipient NKEY_ :: CommandTag Recipient @@ -825,6 +829,7 @@ instance PartyI p => Encoding (CommandTag p) where NEW_ -> "NEW" SUB_ -> "SUB" KEY_ -> "KEY" + RKEY_ -> "RKEY" LSET_ -> "LSET" LDEL_ -> "LDEL" NKEY_ -> "NKEY" @@ -850,6 +855,7 @@ instance ProtocolMsgTag CmdTag where "NEW" -> Just $ CT SRecipient NEW_ "SUB" -> Just $ CT SRecipient SUB_ "KEY" -> Just $ CT SRecipient KEY_ + "RKEY" -> Just $ CT SRecipient RKEY_ "LSET" -> Just $ CT SRecipient LSET_ "LDEL" -> Just $ CT SRecipient LDEL_ "NKEY" -> Just $ CT SRecipient NKEY_ @@ -1494,6 +1500,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where auth = maybe "" (e . ('A',)) auth_ SUB -> e SUB_ KEY k -> e (KEY_, ' ', k) + RKEY ks -> e (RKEY_, ' ', ks) LSET lnkId d -> e (LSET_, ' ', lnkId, d) LDEL -> e LDEL_ NKEY k dhKey -> e (NKEY_, ' ', k, dhKey) @@ -1577,6 +1584,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing SUB_ -> pure SUB KEY_ -> KEY <$> _smpP + RKEY_ -> RKEY <$> _smpP LSET_ -> LSET <$> _smpP <*> smpP LDEL_ -> pure LDEL NKEY_ -> NKEY <$> _smpP <*> smpP diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 8cf730e06e..32534ccf92 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -1062,7 +1062,7 @@ verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe (THandleAuth 'TSer verifyTransmission ms auth_ tAuth authorized queueId cmd = case cmd of Cmd SRecipient (NEW NewQueueReq {rcvAuthKey = k}) -> pure $ Nothing `verifiedWith` k - Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWith` recipientKey (snd q)) <$> get SRecipient + Cmd SRecipient _ -> verifyQueue (\q -> Just q `verifiedWithKeys` recipientKeys (snd q)) <$> get SRecipient Cmd SSender (SKEY k) -> verifySecure SSender k -- SEND will be accepted without authorization before the queue is secured with KEY, SKEY or LSKEY command Cmd SSender SEND {} -> verifyQueue (\q -> if maybe (isNothing tAuth) verify (senderKey $ snd q) then VRVerified (Just q) else VRFailed) <$> get SSender @@ -1082,6 +1082,8 @@ verifyTransmission ms auth_ tAuth authorized queueId cmd = verifySecure p k = verifyQueue (\q -> if k `allowedKey` snd q then Just q `verifiedWith` k else dummyVerify) <$> get p verifiedWith :: Maybe (StoreQueue s, QueueRec) -> C.APublicAuthKey -> VerificationResult s verifiedWith q_ k = if verify k then VRVerified q_ else VRFailed + verifiedWithKeys :: Maybe (StoreQueue s, QueueRec) -> NonEmpty C.APublicAuthKey -> VerificationResult s + verifiedWithKeys q_ ks = if any verify ks then VRVerified q_ else VRFailed allowedKey k = \case QueueRec {queueMode = Just QMMessaging, senderKey} -> maybe True (k ==) senderKey _ -> False @@ -1262,7 +1264,8 @@ client SUB -> withQueue subscribeQueue GET -> withQueue getMessage ACK msgId -> withQueue $ acknowledgeMsg msgId - KEY sKey -> withQueue $ \q _ -> (corrId,entId,) . either ERR id <$> secureQueue_ q sKey + KEY sKey -> withQueue $ \q _ -> either err (corrId,entId,) <$> secureQueue_ q sKey + RKEY rKeys -> withQueue $ \q qr -> checkMode QMContact qr $ OK <$$ liftIO (updateKeys (queueStore ms) q rKeys) LSET lnkId d -> withQueue $ \q qr -> checkMode QMContact qr $ liftIO $ case queueData qr of Just (lnkId', _) | lnkId' /= lnkId -> pure $ Left AUTH @@ -1311,7 +1314,7 @@ client qr = QueueRec { senderId = sndId, - recipientKey = rcvAuthKey, + recipientKeys = [rcvAuthKey], rcvDhSecret = C.dh' rcvDhKey privDhKey, senderKey = Nothing, queueMode, @@ -1340,7 +1343,7 @@ client checkMode :: QueueMode -> QueueRec -> M (Either ErrorType BrokerMsg) -> M (Transmission BrokerMsg) checkMode qm QueueRec {queueMode} a = - (corrId,entId,) . either ERR id + either err (corrId,entId,) <$> if queueMode == Just qm then a else pure $ Left AUTH secureQueue_ :: StoreQueue s -> SndPublicAuthKey -> M (Either ErrorType BrokerMsg) diff --git a/src/Simplex/Messaging/Server/MsgStore/Journal.hs b/src/Simplex/Messaging/Server/MsgStore/Journal.hs index 90ee2208dc..d28300a755 100644 --- a/src/Simplex/Messaging/Server/MsgStore/Journal.hs +++ b/src/Simplex/Messaging/Server/MsgStore/Journal.hs @@ -331,6 +331,8 @@ instance QueueStoreClass (JournalQueue s) (QStore s) where {-# INLINE deleteQueueLinkData #-} secureQueue = withQS secureQueue {-# INLINE secureQueue #-} + updateKeys = withQS updateKeys + {-# INLINE updateKeys #-} addQueueNotifier = withQS addQueueNotifier {-# INLINE addQueueNotifier #-} deleteQueueNotifier = withQS deleteQueueNotifier diff --git a/src/Simplex/Messaging/Server/QueueStore.hs b/src/Simplex/Messaging/Server/QueueStore.hs index d2492fe435..e90359d1d5 100644 --- a/src/Simplex/Messaging/Server/QueueStore.hs +++ b/src/Simplex/Messaging/Server/QueueStore.hs @@ -13,6 +13,7 @@ module Simplex.Messaging.Server.QueueStore where import Control.Applicative ((<|>)) import Data.Functor (($>)) import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol @@ -25,7 +26,7 @@ import Simplex.Messaging.Util (eitherToMaybe) #endif data QueueRec = QueueRec - { recipientKey :: RcvPublicAuthKey, + { recipientKeys :: NonEmpty RcvPublicAuthKey, rcvDhSecret :: RcvDhSecret, senderId :: SenderId, senderKey :: Maybe SndPublicAuthKey, diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs index 186a1574d9..f500a3f42e 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres.hs @@ -41,10 +41,10 @@ import Data.Either (fromRight) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock.System (SystemTime (..), getSystemTime) import Database.PostgreSQL.Simple (Binary (..), Only (..), Query, SqlError, (:.) (..)) import qualified Database.PostgreSQL.Simple as DB @@ -58,6 +58,8 @@ import Simplex.Messaging.Agent.Client (withLockMap) import Simplex.Messaging.Agent.Lock (Lock) import Simplex.Messaging.Agent.Store.Postgres (createDBStore, closeDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common +import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore @@ -74,8 +76,8 @@ import System.IO (IOMode (..), hFlush, stdout) import UnliftIO.STM #if !defined(dbPostgres) -import Simplex.Messaging.Agent.Store.Postgres.DB (blobFieldDecoder, fromTextField_) -import qualified Simplex.Messaging.Crypto as C +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_) import Simplex.Messaging.Encoding.String #endif @@ -257,6 +259,16 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where Just k | sKey /= k -> throwE AUTH _ -> pure () + updateKeys :: PostgresQueueStore q -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ()) + updateKeys st sq rKeys = + withQueueRec sq "updateKeys" $ \q -> do + assertUpdated $ withDB' "updateKeys" st $ \db -> + DB.execute db "UPDATE msg_queues SET recipient_keys = ? WHERE recipient_id = ? AND deleted_at IS NULL" (rKeys, rId) + atomically $ writeTVar (queueRec sq) $ Just q {recipientKeys = rKeys} + withLog "updateKeys" st $ \s -> logUpdateKeys s rId rKeys + where + rId = recipientId sq + addQueueNotifier :: PostgresQueueStore q -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) addQueueNotifier st sq ntfCreds@NtfCreds {notifierId = nId, notifierKey, rcvNtfDhSecret} = withQueueRec sq "addQueueNotifier" $ \q -> @@ -362,7 +374,7 @@ batchInsertQueues tty queues toStore = do let st = dbStore toStore count <- withConnection st $ \db -> do - DB.copy_ db "COPY msg_queues (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) FROM STDIN WITH (FORMAT CSV)" + DB.copy_ db "COPY msg_queues (recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, snd_secure, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at) FROM STDIN WITH (FORMAT CSV)" mapM_ (putQueue db) (zip [1..] qs) DB.putCopyEnd db Only qCnt : _ <- withConnection st (`DB.query_` "SELECT count(*) FROM msg_queues") @@ -378,7 +390,7 @@ insertQueueQuery :: Query insertQueueQuery = [sql| INSERT INTO msg_queues - (recipient_id, recipient_key, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data) + (recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, link_id, fixed_data, user_data) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] @@ -407,7 +419,7 @@ foldQueueRecs tty withData st skipOld_ f = do queueRecQuery :: Query queueRecQuery = [sql| - SELECT recipient_id, recipient_key, rcv_dh_secret, + SELECT recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, @@ -418,7 +430,7 @@ queueRecQuery = queueRecQueryWithData :: Query queueRecQueryWithData = [sql| - SELECT recipient_id, recipient_key, rcv_dh_secret, + SELECT recipient_id, recipient_keys, rcv_dh_secret, sender_id, sender_key, queue_mode, notifier_id, notifier_key, rcv_ntf_dh_secret, status, updated_at, @@ -426,23 +438,23 @@ queueRecQueryWithData = FROM msg_queues |] -type QueueRecRow = (RecipientId, RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, Maybe QueueMode, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId) +type QueueRecRow = (RecipientId, NonEmpty RcvPublicAuthKey, RcvDhSecret, SenderId, Maybe SndPublicAuthKey, Maybe QueueMode, Maybe NotifierId, Maybe NtfPublicAuthKey, Maybe RcvNtfDhSecret, ServerEntityStatus, Maybe RoundedSystemTime, Maybe LinkId) queueRecToRow :: (RecipientId, QueueRec) -> QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -queueRecToRow (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = - (rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt, linkId_) +queueRecToRow (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = + (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId <$> n, notifierKey <$> n, rcvNtfDhSecret <$> n, status, updatedAt, linkId_) :. (fst <$> queueData_, snd <$> queueData_) where (linkId_, queueData_) = queueDataColumns queueData queueRecToText :: (RecipientId, QueueRec) -> ByteString -queueRecToText (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = +queueRecToText (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier = n, status, updatedAt}) = LB.toStrict $ BB.toLazyByteString $ mconcat tabFields <> BB.char7 '\n' where tabFields = BB.char7 ',' `intersperse` fields fields = [ renderField (toField rId), - renderField (toField recipientKey), + renderField (toField recipientKeys), renderField (toField rcvDhSecret), renderField (toField senderId), nullable senderKey, @@ -473,17 +485,17 @@ queueDataColumns = \case Nothing -> (Nothing, Nothing) rowToQueueRec :: QueueRecRow -> (RecipientId, QueueRec) -rowToQueueRec (rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) = +rowToQueueRec (rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) = let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ queueData = (,(EncDataBytes "", EncDataBytes "")) <$> linkId_ - in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) + in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) rowToQueueRecWithData :: QueueRecRow :. (Maybe EncDataBytes, Maybe EncDataBytes) -> (RecipientId, QueueRec) -rowToQueueRecWithData ((rId, recipientKey, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) = +rowToQueueRecWithData ((rId, recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, notifierId_, notifierKey_, rcvNtfDhSecret_, status, updatedAt, linkId_) :. (immutableData_, userData_)) = let notifier = NtfCreds <$> notifierId_ <*> notifierKey_ <*> rcvNtfDhSecret_ encData = fromMaybe (EncDataBytes "") queueData = (,(encData immutableData_, encData userData_)) <$> linkId_ - in (rId, QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) + in (rId, QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt}) setStatusDB :: StoreQueueClass q => String -> PostgresQueueStore q -> q -> ServerEntityStatus -> ExceptT ErrorType IO () -> IO (Either ErrorType ()) setStatusDB op st sq status writeLog = @@ -528,6 +540,10 @@ instance ToField EntityId where toField (EntityId s) = toField $ Binary s deriving newtype instance FromField EntityId +instance ToField (NonEmpty C.APublicAuthKey) where toField = toField . Binary . smpEncode + +instance FromField (NonEmpty C.APublicAuthKey) where fromField = blobFieldDecoder smpDecode + #if !defined(dbPostgres) instance FromField QueueMode where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs index 9d0973976f..b1c5501f6d 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs @@ -77,6 +77,10 @@ UPDATE msg_queues SET queue_mode = 'M' WHERE snd_secure IS TRUE; ALTER TABLE msg_queues DROP COLUMN snd_secure; +UPDATE msg_queues SET recipient_key = ('\x01'::BYTEA || chr(length(recipient_key))::BYTEA || recipient_key); + +ALTER TABLE msg_queues RENAME COLUMN recipient_key TO recipient_keys; + CREATE UNIQUE INDEX idx_msg_queues_link_id ON msg_queues(link_id); |] @@ -88,11 +92,30 @@ ALTER TABLE msg_queues ADD COLUMN snd_secure BOOLEAN NOT NULL DEFAULT FALSE; UPDATE msg_queues SET snd_secure = TRUE WHERE queue_mode = 'M'; -ALTER TABLE +DROP INDEX idx_msg_queues_link_id; + +ALTER TABLE msg_queues DROP COLUMN queue_mode, DROP COLUMN link_id, DROP COLUMN fixed_data, DROP COLUMN user_data; -DROP INDEX idx_msg_queues_link_id; +DO $$ + DECLARE bad_id BYTEA; + BEGIN + SELECT recipient_id INTO bad_id + FROM msg_queues + WHERE get_byte(recipient_keys, 0) != 1 + OR get_byte(recipient_keys, 1) != length(recipient_keys) - 2 + LIMIT 1; + + IF bad_id IS NOT NULL + THEN RAISE EXCEPTION 'Cannot downgrade: many keys or incorrect length in recipient_keys for %', encode(bad_id, 'base64'); + END IF; + END; +$$; + +UPDATE msg_queues SET recipient_keys = substring(recipient_keys from 3); + +ALTER TABLE msg_queues RENAME COLUMN recipient_keys TO recipient_key; |] diff --git a/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql b/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql new file mode 100644 index 0000000000..2910b6959d --- /dev/null +++ b/src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql @@ -0,0 +1,74 @@ + + +SET statement_timeout = 0; +SET lock_timeout = 0; +SET idle_in_transaction_session_timeout = 0; +SET client_encoding = 'UTF8'; +SET standard_conforming_strings = on; +SELECT pg_catalog.set_config('search_path', '', false); +SET check_function_bodies = false; +SET xmloption = content; +SET client_min_messages = warning; +SET row_security = off; + + +CREATE SCHEMA smp_server; + + +SET default_table_access_method = heap; + + +CREATE TABLE smp_server.migrations ( + name text NOT NULL, + ts timestamp without time zone NOT NULL, + down text +); + + + +CREATE TABLE smp_server.msg_queues ( + recipient_id bytea NOT NULL, + recipient_keys bytea NOT NULL, + rcv_dh_secret bytea NOT NULL, + sender_id bytea NOT NULL, + sender_key bytea, + notifier_id bytea, + notifier_key bytea, + rcv_ntf_dh_secret bytea, + status text NOT NULL, + updated_at bigint, + deleted_at bigint, + queue_mode text, + link_id bytea, + fixed_data bytea, + user_data bytea +); + + + +ALTER TABLE ONLY smp_server.migrations + ADD CONSTRAINT migrations_pkey PRIMARY KEY (name); + + + +ALTER TABLE ONLY smp_server.msg_queues + ADD CONSTRAINT msg_queues_pkey PRIMARY KEY (recipient_id); + + + +CREATE UNIQUE INDEX idx_msg_queues_link_id ON smp_server.msg_queues USING btree (link_id); + + + +CREATE UNIQUE INDEX idx_msg_queues_notifier_id ON smp_server.msg_queues USING btree (notifier_id); + + + +CREATE UNIQUE INDEX idx_msg_queues_sender_id ON smp_server.msg_queues USING btree (sender_id); + + + +CREATE INDEX idx_msg_queues_updated_at ON smp_server.msg_queues USING btree (deleted_at, updated_at); + + + diff --git a/src/Simplex/Messaging/Server/QueueStore/STM.hs b/src/Simplex/Messaging/Server/QueueStore/STM.hs index dcd7fd5a01..61fa3af45e 100644 --- a/src/Simplex/Messaging/Server/QueueStore/STM.hs +++ b/src/Simplex/Messaging/Server/QueueStore/STM.hs @@ -28,6 +28,7 @@ import Control.Logger.Simple import Control.Monad import Data.Bitraversable (bimapM) import Data.Functor (($>)) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as M import qualified Data.Text as T import Simplex.Messaging.Protocol @@ -141,6 +142,14 @@ instance StoreQueueClass q => QueueStoreClass q (STMQueueStore q) where TM.delete lnkId $ links st writeTVar qr $ Just q {queueData = Nothing} + updateKeys :: STMQueueStore q -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ()) + updateKeys st sq rKeys = + withQueueRec qr update + $>> withLog "updateKeys" st (\s -> logUpdateKeys s (recipientId sq) rKeys) + where + qr = queueRec sq + update q = writeTVar qr $ Just q {recipientKeys = rKeys} + secureQueue :: STMQueueStore q -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) secureQueue st sq sKey = atomically (readQueueRec qr $>>= secure) diff --git a/src/Simplex/Messaging/Server/QueueStore/Types.hs b/src/Simplex/Messaging/Server/QueueStore/Types.hs index 2a4dbc3ea7..9a52a9df8d 100644 --- a/src/Simplex/Messaging/Server/QueueStore/Types.hs +++ b/src/Simplex/Messaging/Server/QueueStore/Types.hs @@ -10,6 +10,7 @@ module Simplex.Messaging.Server.QueueStore.Types where import Control.Concurrent.STM import Control.Monad import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) import Simplex.Messaging.Protocol import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.TMap (TMap) @@ -34,6 +35,7 @@ class StoreQueueClass q => QueueStoreClass q s where addQueueLinkData :: s -> q -> LinkId -> QueueLinkData -> IO (Either ErrorType ()) deleteQueueLinkData :: s -> q -> IO (Either ErrorType ()) secureQueue :: s -> q -> SndPublicAuthKey -> IO (Either ErrorType ()) + updateKeys :: s -> q -> NonEmpty RcvPublicAuthKey -> IO (Either ErrorType ()) addQueueNotifier :: s -> q -> NtfCreds -> IO (Either ErrorType (Maybe NotifierId)) deleteQueueNotifier :: s -> q -> IO (Either ErrorType (Maybe NotifierId)) suspendQueue :: s -> q -> IO (Either ErrorType ()) diff --git a/src/Simplex/Messaging/Server/StoreLog.hs b/src/Simplex/Messaging/Server/StoreLog.hs index 104a89fe8e..80a2b75aa2 100644 --- a/src/Simplex/Messaging/Server/StoreLog.hs +++ b/src/Simplex/Messaging/Server/StoreLog.hs @@ -21,6 +21,7 @@ module Simplex.Messaging.Server.StoreLog logCreateLink, logDeleteLink, logSecureQueue, + logUpdateKeys, logAddNotifier, logSuspendQueue, logBlockQueue, @@ -43,6 +44,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Functor (($>)) import Data.List (sort, stripPrefix) +import Data.List.NonEmpty (NonEmpty) import Data.Maybe (mapMaybe) import qualified Data.Text as T import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay) @@ -64,6 +66,7 @@ data StoreLogRecord | CreateLink RecipientId LinkId QueueLinkData | DeleteLink RecipientId | SecureQueue QueueId SndPublicAuthKey + | UpdateKeys RecipientId (NonEmpty RcvPublicAuthKey) | AddNotifier QueueId NtfCreds | SuspendQueue QueueId | BlockQueue QueueId BlockingInfo @@ -78,6 +81,7 @@ data SLRTag | CreateLink_ | DeleteLink_ | SecureQueue_ + | UpdateKeys_ | AddNotifier_ | SuspendQueue_ | BlockQueue_ @@ -87,9 +91,9 @@ data SLRTag | UpdateTime_ instance StrEncoding QueueRec where - strEncode QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} = + strEncode QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} = B.unwords - [ "rk=" <> strEncode recipientKey, + [ "rk=" <> strEncode recipientKeys, "rdh=" <> strEncode rcvDhSecret, "sid=" <> strEncode senderId, "sk=" <> strEncode senderKey @@ -108,7 +112,7 @@ instance StrEncoding QueueRec where _ -> " status=" <> strEncode status strP = do - recipientKey <- "rk=" *> strP_ + recipientKeys <- "rk=" *> strP_ rcvDhSecret <- "rdh=" *> strP_ senderId <- "sid=" *> strP_ senderKey <- "sk=" *> strP @@ -120,7 +124,7 @@ instance StrEncoding QueueRec where notifier <- optional $ " notifier=" *> strP updatedAt <- optional $ " updated_at=" *> strP status <- (" status=" *> strP) <|> pure EntityActive - pure QueueRec {recipientKey, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} + pure QueueRec {recipientKeys, rcvDhSecret, senderId, senderKey, queueMode, queueData, notifier, status, updatedAt} where toQueueMode sndSecure = Just $ if sndSecure then QMMessaging else QMContact @@ -130,6 +134,7 @@ instance StrEncoding SLRTag where CreateLink_ -> "LINK" DeleteLink_ -> "LDELETE" SecureQueue_ -> "SECURE" + UpdateKeys_ -> "KEYS" AddNotifier_ -> "NOTIFIER" SuspendQueue_ -> "SUSPEND" BlockQueue_ -> "BLOCK" @@ -144,6 +149,7 @@ instance StrEncoding SLRTag where "LINK" $> CreateLink_, "LDELETE" $> DeleteLink_, "SECURE" $> SecureQueue_, + "KEYS" $> UpdateKeys_, "NOTIFIER" $> AddNotifier_, "SUSPEND" $> SuspendQueue_, "BLOCK" $> BlockQueue_, @@ -159,6 +165,7 @@ instance StrEncoding StoreLogRecord where CreateLink rId lnkId d -> strEncode (CreateLink_, rId, lnkId, d) DeleteLink rId -> strEncode (DeleteLink_, rId) SecureQueue rId sKey -> strEncode (SecureQueue_, rId, sKey) + UpdateKeys rId rKeys -> strEncode (UpdateKeys_, rId, rKeys) AddNotifier rId ntfCreds -> strEncode (AddNotifier_, rId, ntfCreds) SuspendQueue rId -> strEncode (SuspendQueue_, rId) BlockQueue rId info -> strEncode (BlockQueue_, rId, info) @@ -173,6 +180,7 @@ instance StrEncoding StoreLogRecord where CreateLink_ -> CreateLink <$> strP_ <*> strP_ <*> strP DeleteLink_ -> DeleteLink <$> strP SecureQueue_ -> SecureQueue <$> strP_ <*> strP + UpdateKeys_ -> UpdateKeys <$> strP_ <*> strP AddNotifier_ -> AddNotifier <$> strP_ <*> strP SuspendQueue_ -> SuspendQueue <$> strP BlockQueue_ -> BlockQueue <$> strP_ <*> strP @@ -221,6 +229,9 @@ logDeleteLink s = writeStoreLogRecord s . DeleteLink logSecureQueue :: StoreLog 'WriteMode -> QueueId -> SndPublicAuthKey -> IO () logSecureQueue s qId sKey = writeStoreLogRecord s $ SecureQueue qId sKey +logUpdateKeys :: StoreLog 'WriteMode -> QueueId -> NonEmpty RcvPublicAuthKey -> IO () +logUpdateKeys s rId rKeys = writeStoreLogRecord s $ UpdateKeys rId rKeys + logAddNotifier :: StoreLog 'WriteMode -> QueueId -> NtfCreds -> IO () logAddNotifier s qId ntfCreds = writeStoreLogRecord s $ AddNotifier qId ntfCreds diff --git a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs index 5a8f1f46c1..bc576001ce 100644 --- a/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs +++ b/src/Simplex/Messaging/Server/StoreLog/ReadWrite.hs @@ -45,6 +45,7 @@ readQueueStore tty mkQ f st = readLogLines tty f $ \_ -> processLine CreateLink rId lnkId d -> withQueue rId "CreateLink" $ \q -> addQueueLinkData st q lnkId d DeleteLink rId -> withQueue rId "DeleteLink" $ \q -> deleteQueueLinkData st q SecureQueue qId sKey -> withQueue qId "SecureQueue" $ \q -> secureQueue st q sKey + UpdateKeys rId rKeys -> withQueue rId "UpdateKeys" $ \q -> updateKeys st q rKeys AddNotifier qId ntfCreds -> withQueue qId "AddNotifier" $ \q -> addQueueNotifier st q ntfCreds SuspendQueue qId -> withQueue qId "SuspendQueue" $ suspendQueue st BlockQueue qId info -> withQueue qId "BlockQueue" $ \q -> blockQueue st q info diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 458760a801..d749794347 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} @@ -40,11 +41,14 @@ queueAddr = { smpServer = srv, senderId = EntityId "\223\142z\251", dhPublicKey = testDhKey, - queueMode = Nothing + queueMode = Just QMMessaging } -queueAddrSK :: SMPQueueAddress -queueAddrSK = queueAddr {queueMode = Just QMMessaging} +queueAddrNoQM :: SMPQueueAddress +queueAddrNoQM = queueAddr {queueMode = Nothing} + +queueAddrContact :: SMPQueueAddress +queueAddrContact = queueAddr {queueMode = Just QMContact} queueAddr1 :: SMPQueueAddress queueAddr1 = queueAddr {smpServer = srv1} @@ -52,6 +56,9 @@ queueAddr1 = queueAddr {smpServer = srv1} queueAddrNoPort :: SMPQueueAddress queueAddrNoPort = queueAddr {smpServer = srv {port = ""}} +queueAddrNoPortNoQM :: SMPQueueAddress +queueAddrNoPortNoQM = queueAddrNoQM {smpServer = srv {port = ""}} + queueAddrNoPort1 :: SMPQueueAddress queueAddrNoPort1 = queueAddr {smpServer = srv1 {port = ""}} @@ -59,26 +66,32 @@ queueAddrNoPort1 = queueAddr {smpServer = srv1 {port = ""}} queue :: SMPQueueUri queue = SMPQueueUri supportedSMPClientVRange queueAddr -queueSK :: SMPQueueUri -queueSK = SMPQueueUri supportedSMPClientVRange queueAddrSK +queueNoQM :: SMPQueueUri +queueNoQM = SMPQueueUri supportedSMPClientVRange queueAddrNoQM + +queueContact :: SMPQueueUri +queueContact = SMPQueueUri supportedSMPClientVRange queueAddrContact queueStr :: ByteString -queueStr = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" +queueStr = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" + +queueStrNoQM :: ByteString +queueStrNoQM = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" -queueStrSK :: ByteString -queueStrSK = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" +queueStrContact :: ByteString +queueStrContact = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=c" <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" queue1 :: SMPQueueUri queue1 = SMPQueueUri supportedSMPClientVRange queueAddr1 queue1Str :: ByteString -queue1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr +queue1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" queueV1 :: SMPQueueUri -queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddr +queueV1 = SMPQueueUri (mkVersionRange (VersionSMPC 1) (VersionSMPC 1)) queueAddrNoQM queueV1NoPort :: SMPQueueUri -queueV1NoPort = (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPort} +queueV1NoPort = (queueV1 :: SMPQueueUri) {queueAddress = queueAddrNoPortNoQM} -- version range 2-3 uses new encoding -- it is fixed/changed in v5.8.2. @@ -86,10 +99,10 @@ queueNew :: SMPQueueUri queueNew = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr queueNewStr :: ByteString -queueNewStr = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr +queueNewStr = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" queueNewStr' :: ByteString -queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> testDhKeyStr +queueNewStr' = "smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#/?v=2-4&dh=" <> testDhKeyStr <> "&q=m&k=s" queueNewNoPort :: SMPQueueUri queueNewNoPort = (queueNew :: SMPQueueUri) {queueAddress = queueAddrNoPort} @@ -98,7 +111,7 @@ queueNew1 :: SMPQueueUri queueNew1 = SMPQueueUri (mkVersionRange (VersionSMPC 2) currentSMPClientVersion) queueAddr1 queueNew1Str :: ByteString -queueNew1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr +queueNew1Str = "smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr <> "&q=m&k=s" queueNew1NoPort :: SMPQueueUri queueNew1NoPort = (queueNew1 :: SMPQueueUri) {queueAddress = queueAddrNoPort1} @@ -118,8 +131,11 @@ connReqData = crClientData = Nothing } -connReqDataSK :: ConnReqUriData -connReqDataSK = connReqData {crSmpQueues = [queueSK]} +connReqDataNoQM :: ConnReqUriData +connReqDataNoQM = connReqData {crSmpQueues = [queueNoQM]} + +connReqDataContact :: ConnReqUriData +connReqDataContact = connReqData {crSmpQueues = [queueContact]} connReqData1 :: ConnReqUriData connReqData1 = connReqData {crSmpQueues = [queue1]} @@ -154,8 +170,11 @@ connectionRequest = ACR SCMInvitation invConnRequest invConnRequest :: ConnectionRequestUri 'CMInvitation invConnRequest = CRInvitationUri connReqData testE2ERatchetParams -connectionRequestSK :: AConnectionRequestUri -connectionRequestSK = ACR SCMInvitation $ CRInvitationUri connReqDataSK testE2ERatchetParams +connectionRequestNoQM :: AConnectionRequestUri +connectionRequestNoQM = ACR SCMInvitation $ CRInvitationUri connReqDataNoQM testE2ERatchetParams + +connectionRequestContact :: AConnectionRequestUri +connectionRequestContact = ACR SCMContact $ CRContactUri connReqDataContact connectionRequestV1 :: AConnectionRequestUri connectionRequestV1 = ACR SCMInvitation $ CRInvitationUri connReqDataV1 testE2ERatchetParams @@ -218,14 +237,15 @@ connectionRequestTests = describe "connection request parsing / serializing" $ do it "should serialize and parse SMP queue URIs" $ do queue #==# queueStr - queue #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-4&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") - queueSK #==# queueStrSK + queue #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#" <> testDhKeyStr <> "/?v=1-4&extra_param=abc&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&q=m&k=s") + queueNoQM #==# queueStrNoQM + queueContact #==# queueStrContact queue1 #==# queue1Str queueNew #==# queueNewStr queueNew #== queueNewStr' queueNew1 #==# queueNew1Str - queueNewNoPort #==# ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr) - queueNew1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr) + queueNewNoPort #==# ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr <> "&q=m&k=s") + queueNew1NoPort #==# ("smp://1234-w==@smp.simplex.im/3456-w==#/?v=2-4&dh=" <> url testDhKeyStr <> "&q=m&k=s") queueV1 #==# ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?v=1&dh=" <> url testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") queueV1 #== ("smp://1234-w==@smp.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion:5223/3456-w==#" <> testDhKeyStr) queueV1 #== ("smp://1234-w==@smp.simplex.im:5223/3456-w==#/?extra_param=abc&v=1&dh=" <> testDhKeyStr <> "&srv=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion") @@ -236,7 +256,7 @@ connectionRequestTests = it "should serialize and parse connection invitations and contact addresses" $ do connectionRequest #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) connectionRequest #== ("https://simplex.chat/invitation#/?v=2-7&smp=" <> url queueStr <> "&e2e=" <> testE2ERatchetParamsStrUri) - connectionRequestSK #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStrSK <> "&e2e=" <> testE2ERatchetParamsStrUri) + connectionRequestNoQM #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueStrNoQM <> "&e2e=" <> testE2ERatchetParamsStrUri) connectionRequest1 #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queue1Str <> "&e2e=" <> testE2ERatchetParamsStrUri) connectionRequest2queues #==# ("simplex:/invitation#/?v=2-7&smp=" <> url (queueStr <> ";" <> queueStr) <> "&e2e=" <> testE2ERatchetParamsStrUri) connectionRequestNew #==# ("simplex:/invitation#/?v=2-7&smp=" <> url queueNewStr <> "&e2e=" <> testE2ERatchetParamsStrUri) @@ -256,7 +276,8 @@ connectionRequestTests = contactAddressClientData #==# ("simplex:/contact#/?v=2-7&smp=" <> url queueStr <> "&data=" <> url "{\"type\":\"group_link\", \"group_link_id\":\"abc\"}") it "should serialize / parse queue address, connection invitations and contact addresses as binary" $ do smpEncodingTest queue - smpEncodingTest queueSK + smpEncodingTest queueNoQM -- this passes, no queue mode patch in SMPQueueUri encoding + -- smpEncodingTest queueContact -- this fails until SMP client min version is >= sndAuthKeySMPClientVersion smpEncodingTest queue1 smpEncodingTest queueNew smpEncodingTest queueNew1 @@ -265,7 +286,8 @@ connectionRequestTests = smpEncodingTest queueV1 smpEncodingTest queueV1NoPort smpEncodingTest connectionRequest - smpEncodingTest connectionRequestSK + -- smpEncodingTest connectionRequestNoQM -- this fails, because of queue mode patch + smpEncodingTest connectionRequestContact -- this passes because of queue mode patch in ConnReqUriData encoding smpEncodingTest connectionRequest1 smpEncodingTest connectionRequest2queues smpEncodingTest connectionRequestNew @@ -279,27 +301,46 @@ connectionRequestTests = smpEncodingTest contactAddressV2 smpEncodingTest contactAddressClientData it "should serialize / parse short links" $ do - CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/c#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" - CSLContact srv CCTGroup (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/g#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" - CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/c#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" - CSLInvitation srv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im:5223/i#1234-w@jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" - CSLInvitation shortSrv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLContact SLSServer CCTContact srv (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLContact SLSServer CCTGroup srv (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/g#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLContact SLSServer CCTContact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLInvitation SLSServer srv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLInvitation SLSServer shortSrv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "https://smp.simplex.im/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY" + CSLContact SLSSimplex CCTContact srv (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im%2Cjjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLContact SLSSimplex CCTGroup srv (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/g#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im%2Cjjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLContact SLSSimplex CCTContact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/a#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im" + CSLInvitation SLSSimplex srv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im%2Cjjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion&p=5223&c=1234-w" + CSLInvitation SLSSimplex shortSrv (EntityId "0123456789abcdef01234567") (LinkKey "0123456789abcdef0123456789abcdef") #==# "simplex:/i#MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3/MDEyMzQ1Njc4OWFiY2RlZjAxMjM0NTY3ODlhYmNkZWY?h=smp.simplex.im" it "should shorten / restore short links" $ do - shortenShortLink [srv] (CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") - shortenShortLink [srv] (CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef") - restoreShortLink [srv] (CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact srv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") - restoreShortLink [srv2] (CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact shortSrv CCTContact (LinkKey "0123456789abcdef0123456789abcdef") - restoreShortLink [srv] (CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef")) - `shouldBe` CSLContact srv2 CCTContact (LinkKey "0123456789abcdef0123456789abcdef") + let contact = CSLContact SLSServer CCTContact + shortenShortLink [srv] (contact srv (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") + -- won't shorten link that uses only onion host from preset server + shortenShortLink [srv] (contact srvOnion (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srvOnion (LinkKey "0123456789abcdef0123456789abcdef") + -- will shorten link that uses only public host from preset server + shortenShortLink [srv] (contact srv1 (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") + shortenShortLink [srv] (contact srv2 (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srv2 (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv] (contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srv (LinkKey "0123456789abcdef0123456789abcdef") + -- won't change link that has only public host of preset server with keyhash + restoreShortLink [srv] (contact srv1 (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srv1 (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv2] (contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact shortSrv (LinkKey "0123456789abcdef0123456789abcdef") + restoreShortLink [srv] (contact srv2 (LinkKey "0123456789abcdef0123456789abcdef")) + `shouldBe` contact srv2 (LinkKey "0123456789abcdef0123456789abcdef") where + smpEncodingTest :: (Encoding a, Eq a, Show a, HasCallStack) => a -> Expectation smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a shortSrv :: SMPServer shortSrv = SMPServer "smp.simplex.im" "" (C.KeyHash "") +srvOnion :: SMPServer +srvOnion = SMPServer "jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "" (C.KeyHash "\215m\248\251") + srv2 :: SMPServer srv2 = SMPServer "smp2.simplex.im,jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion" "" (C.KeyHash "\215m\248\251") diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index 6cc303513c..5b05444fc1 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -5,6 +5,7 @@ module AgentTests.EqInstances where import Data.Type.Equality +import Simplex.Messaging.Agent.Protocol (ConnLinkData (..), OwnerAuth (..)) import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client (ProxiedRelay (..)) @@ -27,6 +28,14 @@ deriving instance Eq ClientNtfCreds deriving instance Eq ShortLinkCreds +deriving instance Show (ConnLinkData c) + +deriving instance Eq (ConnLinkData c) + +deriving instance Show OwnerAuth + +deriving instance Eq OwnerAuth + deriving instance Show ProxiedRelay deriving instance Eq ProxiedRelay diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 179653a9fe..c49703d1c3 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -78,7 +78,7 @@ import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Word (Word16) import GHC.Stack (withFrozenCallStack) import SMPAgentClient -import SMPClient (cfgMS, cfgJ2QS, prevRange, prevVersion, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServers2, withSmpServerConfigOn, withSmpServerProxy, withSmpServersProxy2, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) +import SMPClient (cfgJ2QS, cfgMS, prevRange, prevVersion, proxyCfgJ2QS, proxyCfgMS, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServers2, withSmpServerConfigOn, withSmpServerProxy, withSmpServersProxy2, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent hiding (createConnection, joinConnection, sendMessage) import qualified Simplex.Messaging.Agent as A import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..), ServerQueueInfo (..), UserNetworkInfo (..), UserNetworkType (..), waitForUserNetwork) @@ -102,7 +102,7 @@ import Simplex.Messaging.Server.Env.STM (AServerStoreCfg (..), AStoreType (..), import Simplex.Messaging.Server.Expiration import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.QueueStore.QueueInfo -import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes) +import Simplex.Messaging.Transport (ATransport (..), SMPVersion, VersionSMP, authCmdsSMPVersion, currentServerSMPRelayVersion, minClientSMPRelayVersion, minServerSMPRelayVersion, sendingProxySMPVersion, sndAuthKeySMPVersion, supportedSMPHandshakes, supportedServerSMPRelayVRange) import Simplex.Messaging.Util (bshow, diffToMicroseconds) import Simplex.Messaging.Version (VersionRange (..)) import qualified Simplex.Messaging.Version as V @@ -315,6 +315,7 @@ functionalAPITests ps = do describe "should connect via 1-time short link with async join" $ testProxyMatrix ps testInviationShortLinkAsync describe "should connect via contact short link" $ testProxyMatrix ps testContactShortLink describe "should add short link to existing contact and connect" $ testProxyMatrix ps testAddContactShortLink + describe "try to create 1-time short link with prev versions" $ testProxyMatrixWithPrev ps testInviationShortLinkPrev describe "server restart" $ do it "should get 1-time link data after restart" $ testInviationShortLinkRestart ps it "should connect via contact short link after restart" $ testContactShortLinkRestart ps @@ -547,8 +548,21 @@ testServerMatrix2 ps runTest = do testProxyMatrix :: HasCallStack => (ATransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec testProxyMatrix ps runTest = do - it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 initAgentServers initAgentServers2 $ runTest False - it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 initAgentServersProxy initAgentServersProxy2 $ runTest True + it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False + it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True + +testProxyMatrixWithPrev :: HasCallStack => (ATransport, AStoreType) -> (Bool -> Bool -> AgentClient -> AgentClient -> IO ()) -> Spec +testProxyMatrixWithPrev ps@(t, msType@(ASType qs _ms)) runTest = do + it "2 servers, directly, curr clients, prev servers" $ withSmpServers2Prev $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False True + it "2 servers, via proxy, curr clients, prev servers" $ withSmpServersProxy2Prev $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True True + it "2 servers, directly, prev clients, curr servers" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServers) (agentCfgVPrevPQ, initAgentServers2) $ runTest False False + it "2 servers, via proxy, prev clients, curr servers" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfgVPrevPQ, initAgentServersProxy) (agentCfgVPrevPQ, initAgentServersProxy2) $ runTest True False + where + prev cfg' = cfg' {smpServerVRange = prevRange supportedServerSMPRelayVRange} + withSmpServers2Prev a = withServers2 (prev $ cfgMS msType) (prev $ cfgJ2QS qs) a + withSmpServersProxy2Prev a = withServers2 (prev $ proxyCfgMS msType) (prev $ proxyCfgJ2QS qs) a + withServers2 cfg1 cfg2 a = + withSmpServerConfigOn t cfg1 testPort $ \_ -> withSmpServerConfigOn t cfg2 testPort2 $ \_ -> a testPQMatrix2 :: HasCallStack => (ATransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2 = pqMatrix2_ True @@ -604,10 +618,10 @@ withAgentClientsCfgServers2 aCfg bCfg servers runTest = withAgent 2 bCfg servers testDB2 $ \b -> runTest a b -withAgentClientsServers2 :: HasCallStack => InitialAgentServers -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a -withAgentClientsServers2 aServers bServers runTest = - withAgent 1 agentCfg aServers testDB $ \a -> - withAgent 2 agentCfg bServers testDB2 $ \b -> +withAgentClientsServers2 :: HasCallStack => (AgentConfig, InitialAgentServers) -> (AgentConfig, InitialAgentServers) -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a +withAgentClientsServers2 (aCfg, aServers) (bCfg, bServers) runTest = + withAgent 1 aCfg aServers testDB $ \a -> + withAgent 2 bCfg bServers testDB2 $ \b -> runTest a b withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a @@ -1102,37 +1116,47 @@ testInviationShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do let userData = "some user data" (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- same user can get invitation link again - (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + (connReq2, connData2) <- runRight $ getConnShortLink b 1 shortLink connReq2 `shouldBe` connReq - userData2 `shouldBe` userData + linkUserData connData2 `shouldBe` userData -- another user cannot get the same invitation link runExceptT (getConnShortLink c 1 shortLink) >>= \case Left (SMP _ AUTH) -> pure () r -> liftIO $ expectationFailure ("unexpected result " <> show r) - runRight $ do - aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn - sndSecure <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe - liftIO $ sndSecure `shouldBe` True - ("", _, CONF confId _ "bob's connInfo") <- get a - allowConnection a bId confId "alice's connInfo" - get a ##> ("", bId, CON) - get b ##> ("", aId, INFO "alice's connInfo") - get b ##> ("", aId, CON) - exchangeGreetingsViaProxy viaProxy a bId b aId + runRight $ testJoinConn_ viaProxy True a bId b connReq + +testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO () +testJoinConn_ viaProxy sndSecure a bId b connReq = do + aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn + sndSecure' <- A.joinConnection b 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe + liftIO $ sndSecure' `shouldBe` sndSecure + ("", _, CONF confId _ "bob's connInfo") <- get a + allowConnection a bId confId "alice's connInfo" + get a ##> ("", bId, CON) + get b ##> ("", aId, INFO "alice's connInfo") + get b ##> ("", aId, CON) + exchangeGreetingsViaProxy viaProxy a bId b aId + +testInviationShortLinkPrev :: HasCallStack => Bool -> Bool -> AgentClient -> AgentClient -> IO () +testInviationShortLinkPrev viaProxy sndSecure a b = runRight_ $ do + let userData = "some user data" + -- can't create short link with previous version + (bId, CCLink connReq Nothing) <- A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKPQOn SMSubscribe + testJoinConn_ viaProxy sndSecure a bId b connReq testInviationShortLinkAsync :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () testInviationShortLinkAsync viaProxy a b = do let userData = "some user data" (bId, CCLink connReq (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMSubscribe - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData runRight $ do aId <- A.joinConnectionAsync b 1 "123" True connReq "bob's connInfo" PQSupportOn SMSubscribe get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False @@ -1149,18 +1173,18 @@ testContactShortLink viaProxy a b = let userData = "some user data" (contactId, CCLink connReq0 (Just shortLink)) <- runRight $ A.createConnection a 1 True SCMContact (Just userData) Nothing CR.IKPQOn SMSubscribe Right connReq <- pure $ smpDecode (smpEncode connReq0) - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- same user can get contact link again - (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + (connReq2, connData2) <- runRight $ getConnShortLink b 1 shortLink connReq2 `shouldBe` connReq - userData2 `shouldBe` userData + linkUserData connData2 `shouldBe` userData -- another user can get the same contact link - (connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink + (connReq3, connData3) <- runRight $ getConnShortLink c 1 shortLink connReq3 `shouldBe` connReq - userData3 `shouldBe` userData + linkUserData connData3 `shouldBe` userData runRight $ do (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe liftIO $ sndSecure `shouldBe` False @@ -1178,9 +1202,9 @@ testContactShortLink viaProxy a b = let updatedData = "updated user data" shortLink' <- runRight $ setContactShortLink a contactId updatedData shortLink' `shouldBe` shortLink - (connReq4, updatedData') <- runRight $ getConnShortLink c 1 shortLink + (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink connReq4 `shouldBe` connReq - updatedData' `shouldBe` updatedData + linkUserData updatedConnData' `shouldBe` updatedData -- one more time shortLink2 <- runRight $ setContactShortLink a contactId updatedData shortLink2 `shouldBe` shortLink @@ -1196,18 +1220,18 @@ testAddContactShortLink viaProxy a b = Right connReq <- pure $ smpDecode (smpEncode connReq0) -- let userData = "some user data" shortLink <- runRight $ setContactShortLink a contactId userData - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- same user can get contact link again - (connReq2, userData2) <- runRight $ getConnShortLink b 1 shortLink + (connReq2, connData2) <- runRight $ getConnShortLink b 1 shortLink connReq2 `shouldBe` connReq - userData2 `shouldBe` userData + linkUserData connData2 `shouldBe` userData -- another user can get the same contact link - (connReq3, userData3) <- runRight $ getConnShortLink c 1 shortLink + (connReq3, connData3) <- runRight $ getConnShortLink c 1 shortLink connReq3 `shouldBe` connReq - userData3 `shouldBe` userData + linkUserData connData3 `shouldBe` userData runRight $ do (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe liftIO $ sndSecure `shouldBe` False @@ -1225,9 +1249,9 @@ testAddContactShortLink viaProxy a b = let updatedData = "updated user data" shortLink' <- runRight $ setContactShortLink a contactId updatedData shortLink' `shouldBe` shortLink - (connReq4, updatedData') <- runRight $ getConnShortLink c 1 shortLink + (connReq4, updatedConnData') <- runRight $ getConnShortLink c 1 shortLink connReq4 `shouldBe` connReq - updatedData' `shouldBe` updatedData + linkUserData updatedConnData' `shouldBe` updatedData testInviationShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do @@ -1236,10 +1260,10 @@ testInviationShortLinkRestart ps = withAgentClients2 $ \a b -> do runRight $ A.createConnection a 1 True SCMInvitation (Just userData) Nothing CR.IKUsePQ SMOnlyCreate withSmpServer ps $ do runRight_ $ subscribeConnection a bId - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData testContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do @@ -1249,17 +1273,17 @@ testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do Right connReq <- pure $ smpDecode (smpEncode connReq0) let updatedData = "updated user data" withSmpServer ps $ do - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- update user data shortLink' <- runRight $ setContactShortLink a contactId updatedData shortLink' `shouldBe` shortLink withSmpServer ps $ do - (connReq4, updatedData') <- runRight $ getConnShortLink b 1 shortLink + (connReq4, updatedConnData') <- runRight $ getConnShortLink b 1 shortLink connReq4 `shouldBe` connReq - updatedData' `shouldBe` updatedData + linkUserData updatedConnData' `shouldBe` updatedData testAddContactShortLinkRestart :: HasCallStack => (ATransport, AStoreType) -> IO () testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do @@ -1270,17 +1294,17 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do Right connReq <- pure $ smpDecode (smpEncode connReq0) let updatedData = "updated user data" withSmpServer ps $ do - (connReq', userData') <- runRight $ getConnShortLink b 1 shortLink + (connReq', connData') <- runRight $ getConnShortLink b 1 shortLink strDecode (strEncode shortLink) `shouldBe` Right shortLink connReq' `shouldBe` connReq - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData -- update user data shortLink' <- runRight $ setContactShortLink a contactId updatedData shortLink' `shouldBe` shortLink withSmpServer ps $ do - (connReq4, updatedData') <- runRight $ getConnShortLink b 1 shortLink + (connReq4, updatedConnData') <- runRight $ getConnShortLink b 1 shortLink connReq4 `shouldBe` connReq - updatedData' `shouldBe` updatedData + linkUserData updatedConnData' `shouldBe` updatedData testIncreaseConnAgentVersion :: HasCallStack => (ATransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 376a13cb49..882dd685ca 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -63,12 +63,6 @@ testVerifyLintFKeyIndexes = do getLintFKeyIndexes testDB "tests/tmp/agent_lint.sql" `shouldReturn` savedLint removeFile testDB -withTmpFiles :: IO () -> IO () -withTmpFiles = - bracket_ - (createDirectoryIfMissing False "tests/tmp") - (removeDirectoryRecursive "tests/tmp") - testSchemaMigrations :: IO () testSchemaMigrations = do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) appMigrations diff --git a/tests/AgentTests/ShortLinkTests.hs b/tests/AgentTests/ShortLinkTests.hs index 3fd1033fd7..e91472f997 100644 --- a/tests/AgentTests/ShortLinkTests.hs +++ b/tests/AgentTests/ShortLinkTests.hs @@ -5,9 +5,10 @@ module AgentTests.ShortLinkTests (shortLinkTests) where import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest) +import AgentTests.EqInstances () import Control.Concurrent.STM import Control.Monad.Except -import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SMPAgentError (..), supportedSMPAgentVRange) +import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), ConnectionMode (..), LinkKey (..), SMPAgentError (..), linkUserData, supportedSMPAgentVRange) import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto.ShortLink as SL import Test.Hspec @@ -33,9 +34,9 @@ testInvShortLink = do k = SL.invShortLinkKdf linkKey Right srvData <- runExceptT $ SL.encryptLinkData g k linkData -- decrypt - Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData + Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k srvData connReq `shouldBe` invConnRequest - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData testInvShortLinkBadDataHash :: IO () testInvShortLinkBadDataHash = do @@ -62,9 +63,9 @@ testContactShortLink = do (_linkId, k) = SL.contactShortLinkKdf linkKey Right srvData <- runExceptT $ SL.encryptLinkData g k linkData -- decrypt - Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k srvData + Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k srvData connReq `shouldBe` contactConnRequest - userData' `shouldBe` userData + linkUserData connData' `shouldBe` userData testUpdateContactShortLink :: IO () testUpdateContactShortLink = do @@ -80,9 +81,9 @@ testUpdateContactShortLink = do signed = SL.encodeSignUserData (snd sigKeys) supportedSMPAgentVRange updatedUserData Right ud' <- runExceptT $ SL.encryptUserData g k signed -- decrypt - Right (connReq, userData') <- pure $ SL.decryptLinkData linkKey k (fd, ud') + Right (connReq, connData') <- pure $ SL.decryptLinkData linkKey k (fd, ud') connReq `shouldBe` contactConnRequest - userData' `shouldBe` updatedUserData + linkUserData connData' `shouldBe` updatedUserData testContactShortLinkBadDataHash :: IO () testContactShortLinkBadDataHash = do diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index 1b83526f18..5c0e7f95ba 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -117,11 +118,11 @@ testNewQueueRecData :: TVar ChaChaDRG -> QueueMode -> Maybe (LinkId, QueueLinkDa testNewQueueRecData g qm queueData = do rId <- rndId senderId <- rndId - (recipientKey, _) <- atomically $ C.generateAuthKeyPair C.SX25519 g + (rKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g (k, pk) <- atomically $ C.generateKeyPair @'C.X25519 g let qr = QueueRec - { recipientKey, + { recipientKeys = [rKey], rcvDhSecret = C.dh' k pk, senderId, senderKey = Nothing, diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 00e9456753..9556c67883 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -14,6 +14,7 @@ import CoreTests.MsgStoreTests import Crypto.Random (ChaChaDRG) import qualified Data.ByteString.Char8 as B import Data.Either (partitionEithers) +import qualified Data.List.NonEmpty as L import qualified Data.Map.Strict as M import SMPClient import qualified Simplex.Messaging.Crypto as C @@ -56,15 +57,16 @@ deriving instance Eq NtfCreds storeLogTests :: Spec storeLogTests = forM_ [QMMessaging, QMContact] $ \qm -> do - ((rId, qr), ntfCreds, date) <- runIO $ do - g <- C.newRandom + g <- runIO C.newRandom + ((rId, qr), ntfCreds, date) <- runIO $ (,,) <$> testNewQueueRec g qm <*> testNtfCreds g <*> getSystemDate ((rId', qr'), lnkId, qd) <- runIO $ do - g <- C.newRandom lnkId <- atomically $ EntityId <$> C.randomBytes 24 g let qd = (EncDataBytes "fixed data", EncDataBytes "user data") q <- testNewQueueRecData g qm (Just (lnkId, qd)) pure (q, lnkId, qd) + let pubKey = fst <$> atomically (C.generateAuthKeyPair C.SEd25519 g) + newKeys <- runIO $ L.fromList <$> sequence [pubKey, pubKey] testSMPStoreLog ("SMP server store log, queueMode = " <> show qm) [ SLTC @@ -120,6 +122,12 @@ storeLogTests = saved = [CreateQueue rId qr, UpdateTime rId date], compacted = [CreateQueue rId qr {updatedAt = Just date}], state = M.fromList [(rId, qr {updatedAt = Just date})] + }, + SLTC + { name = "update recipient keys", + saved = [CreateQueue rId qr, UpdateKeys rId newKeys], + compacted = [CreateQueue rId qr {recipientKeys = newKeys}], + state = M.fromList [(rId, qr {recipientKeys = newKeys})] } ] diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 00351befa1..df633b570b 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -60,6 +60,8 @@ serverTests = do describe "NEW and SKEY commands" $ do testCreateSndSecure testSndSecureProhibited + describe "RKEY command to add additional recipient keys" $ + testCreateUpdateKeys describe "NEW, OFF and DEL commands, SEND messages" testCreateDelete describe "Stress test" stressTest describe "allowNewQueues setting" testAllowNewQueues @@ -272,6 +274,38 @@ testSndSecureProhibited = (sId2, sId) #== "secures queue, same queue ID in response" (err, ERR AUTH) #== "rejects SKEY when not allowed in NEW command" +testCreateUpdateKeys :: SpecWith (ATransport, AStoreType) +testCreateUpdateKeys = + it "should create (NEW) and updated recipient keys (RKEY)" $ \(ATransport t, msType) -> + smpTest t msType $ \h -> do + g <- C.newRandom + (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g + (dhPub, _dhPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g + Resp "1" NoEntity (Ids rId _sId _srvDh) <- signSendRecv h rKey ("1", NoEntity, NEW (NewQueueReq rPub dhPub Nothing SMSubscribe (Just (QRContact Nothing)))) + (rPub', rKey') <- atomically $ C.generateAuthKeyPair C.SEd25519 g + Resp "2" rId1 OK <- signSendRecv h rKey ("2", rId, RKEY [rPub, rPub']) + rId1 `shouldBe` rId + -- old key still works + Resp "3" rId2 (INFO _) <- signSendRecv h rKey ("3", rId, QUE) + rId2 `shouldBe` rId + -- new key works too + Resp "4" _ (INFO _) <- signSendRecv h rKey ("4", rId, QUE) + -- remove old key, only keep the new one + Resp "5" _ OK <- signSendRecv h rKey' ("5", rId, RKEY [rPub']) + -- old key no longer works + Resp "6" _ (ERR AUTH) <- signSendRecv h rKey ("6", rId, QUE) + -- add old key back + Resp "7" _ OK <- signSendRecv h rKey' ("7", rId, RKEY [rPub, rPub']) + -- old key works again + Resp "8" _ (INFO _) <- signSendRecv h rKey ("8", rId, QUE) + -- key can remove itself + Resp "9" _ OK <- signSendRecv h rKey ("9", rId, RKEY [rPub']) + -- old key does not work + Resp "10" _ (ERR AUTH) <- signSendRecv h rKey ("10", rId, QUE) + -- new key works + Resp "11" _ (INFO _) <- signSendRecv h rKey' ("11", rId, QUE) + pure () + testCreateDelete :: SpecWith (ATransport, AStoreType) testCreateDelete = it "should create (NEW), suspend (OFF) and delete (DEL) queue" $ \(ATransport t, msType) -> diff --git a/tests/ServerTests/SchemaDump.hs b/tests/ServerTests/SchemaDump.hs new file mode 100644 index 0000000000..e3ffdb5cba --- /dev/null +++ b/tests/ServerTests/SchemaDump.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module ServerTests.SchemaDump where + +import Control.Concurrent (threadDelay) +import Control.DeepSeq +import Control.Monad (unless, void) +import qualified Data.ByteString.Char8 as B +import Data.List (dropWhileEnd) +import Data.Maybe (fromJust, isJust) +import SMPClient +import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) +import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) +import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) +import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) +import Simplex.Messaging.Util (ifM) +import System.Directory (doesFileExist, removeFile) +import System.Environment (lookupEnv) +import System.Process (readCreateProcess, readCreateProcessWithExitCode, shell) +import Test.Hspec + +testDBSchema :: B.ByteString +testDBSchema = "smp_server" + +serverSchemaPath :: FilePath +serverSchemaPath = "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql" + +testSchemaPath :: FilePath +testSchemaPath = "tests/tmp/test_server_schema.sql" + +testServerDBOpts :: DBOpts +testServerDBOpts = + DBOpts + { connstr = testServerDBConnstr, + schema = testDBSchema, + poolSize = 3, + createSchema = True + } + +serverSchemaDumpTest :: Spec +serverSchemaDumpTest = do + it "verify and overwrite schema dump" testVerifySchemaDump + it "verify schema down migrations" testSchemaMigrations + +testVerifySchemaDump :: IO () +testVerifySchemaDump = do + savedSchema <- ifM (doesFileExist serverSchemaPath) (readFile serverSchemaPath) (pure "") + savedSchema `deepseq` pure () + void $ createDBStore testServerDBOpts serverMigrations MCConsole + getSchema serverSchemaPath `shouldReturn` savedSchema + +testSchemaMigrations :: IO () +testSchemaMigrations = do + let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) serverMigrations + Right st <- createDBStore testServerDBOpts noDownMigrations MCError + mapM_ (testDownMigration st) $ drop (length noDownMigrations) serverMigrations + closeDBStore st + removeFile testSchemaPath + where + testDownMigration st m = do + putStrLn $ "down migration " <> name m + let downMigr = fromJust $ toDownMigration m + schema <- getSchema testSchemaPath + Migrations.run st $ MTRUp [m] + schema' <- getSchema testSchemaPath + schema' `shouldNotBe` schema + Migrations.run st $ MTRDown [downMigr] + unless (name m `elem` skipComparisonForDownMigrations) $ do + schema'' <- getSchema testSchemaPath + schema'' `shouldBe` schema + Migrations.run st $ MTRUp [m] + schema''' <- getSchema testSchemaPath + schema''' `shouldBe` schema' + +skipComparisonForDownMigrations :: [String] +skipComparisonForDownMigrations = + [ -- snd_secure moves to the bottom on down migration + "20250320_short_links" + ] + +getSchema :: FilePath -> IO String +getSchema schemaPath = do + ci <- (Just "true" ==) <$> lookupEnv "CI" + let cmd = + ("pg_dump " <> B.unpack testServerDBConnstr <> " --schema " <> B.unpack testDBSchema) + <> " --schema-only --no-owner --no-privileges --no-acl --no-subscriptions --no-tablespaces > " + <> schemaPath + (code, out, err) <- readCreateProcessWithExitCode (shell cmd) "" + print code + putStrLn $ "out: " <> out + putStrLn $ "err: " <> err + threadDelay 20000 + let sed = (if ci then "sed -i" else "sed -i ''") + void $ readCreateProcess (shell $ sed <> " '/^--/d' " <> schemaPath) "" + sch <- readFile schemaPath + sch `deepseq` pure sch diff --git a/tests/Test.hs b/tests/Test.hs index 1e29fa1582..674c1aa182 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -44,6 +44,7 @@ import AgentTests.SchemaDump (schemaDumpTest) #if defined(dbServerPostgres) import SMPClient (testServerDBConnectInfo) +import ServerTests.SchemaDump #endif #if defined(dbPostgres) || defined(dbServerPostgres) @@ -85,8 +86,10 @@ main = do describe "Util tests" utilTests describe "Agent core tests" agentCoreTests #if defined(dbServerPostgres) - aroundAll_ (postgressBracket testServerDBConnectInfo) - $ describe "SMP server via TLS, postgres+jornal message store" $ + around_ (postgressBracket testServerDBConnectInfo) $ + describe "Server schema dump" serverSchemaDumpTest + aroundAll_ (postgressBracket testServerDBConnectInfo) $ + describe "SMP server via TLS, postgres+jornal message store" $ before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests #endif describe "SMP server via TLS, jornal message store" $ do