dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-07-28 07:50:12 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
91cb297e9ebc4b0a0be2477426f36a40fbe05ed6
simplexmq/src/Simplex/Messaging/Agent/Protocol.hs
T
shandGitHub ee2ff402fe agent: split SimplexNameDomain out of SimplexNameInfo (#1788) 
* agent: split SimplexNameDomain out of SimplexNameInfo

The type now separates the user-supplied type prefix (#/@) from the
domain itself:

  data SimplexNameInfo = SimplexNameInfo
    { nameType :: SimplexNameType
    , nameDomain :: SimplexNameDomain
    }

  data SimplexNameDomain = SimplexNameDomain
    { nameTLD :: SimplexTLD
    , domain :: Text
    , subDomain :: [Text]
    }

The domain is independent of the contact-vs-public-group distinction —
the same dotted-labels structure applies to both. Future code that
needs to talk about a domain without committing to a name type (e.g.
server-side TLD-based registry lookup) can use SimplexNameDomain
directly.

fullDomainName now operates on SimplexNameDomain rather than the
full info wrapper. Parser, StrEncoding instance, and aeson derivations
updated accordingly. No external callers needed updating.

* agent: split StrEncoding instance for SimplexNameDomain

* agent: flatten TLD case + use unless guard

* agent: address review - strict domain parser, permissive channel
2026-05-29 09:11:08 +01:00

2288 lines
78 KiB
Haskell
Raw Blame History

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
-- |
-- Module : Simplex.Messaging.Agent.Protocol
-- Copyright : (c) simplex.chat
-- License : AGPL-3
--
-- Maintainer : chat@simplex.chat
-- Stability : experimental
-- Portability : non-portable
--
-- Types, parsers, serializers and functions to send and receive SMP agent protocol commands and responses.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md
module Simplex.Messaging.Agent.Protocol
( -- * Protocol parameters
VersionSMPA,
VersionRangeSMPA,
pattern VersionSMPA,
duplexHandshakeSMPAgentVersion,
ratchetSyncSMPAgentVersion,
deliveryRcptsSMPAgentVersion,
pqdrSMPAgentVersion,
sndAuthKeySMPAgentVersion,
ratchetOnConfSMPAgentVersion,
currentSMPAgentVersion,
supportedSMPAgentVRange,
e2eEncConnInfoLength,
e2eEncAgentMsgLength,
-- * SMP agent protocol types
ConnInfo,
SndQueueSecured,
AEntityId,
ACommand (..),
AEvent (..),
AEvt (..),
ACommandTag (..),
AEventTag (..),
AEvtTag (..),
aCommandTag,
aEventTag,
AEntity (..),
SAEntity (..),
AEntityI (..),
MsgHash,
MsgMeta (..),
RcvQueueInfo (..),
SndQueueInfo (..),
SubscriptionStatus (..),
ConnectionStats (..),
SwitchPhase (..),
RcvSwitchStatus (..),
SndSwitchStatus (..),
QueueDirection (..),
RatchetSyncState (..),
SMPConfirmation (..),
AgentMsgEnvelope (..),
AgentMessage (..),
AgentMessageType (..),
APrivHeader (..),
AMessage (..),
AMessageReceipt (..),
MsgReceipt (..),
MsgReceiptInfo,
MsgReceiptStatus (..),
SndQAddr,
SMPServer,
pattern SMPServer,
pattern ProtoServerWithAuth,
SMPServerWithAuth,
SrvLoc (..),
SMPQueue (..),
qAddress,
sameQueue,
sameQAddress,
noAuthSrv,
SMPQueueUri (..),
SMPQueueInfo (..),
SMPQueueAddress (..),
ConnectionMode (..),
SConnectionMode (..),
AConnectionMode (..),
ConnectionModeI (..),
ConnectionRequestUri (..),
AConnectionRequestUri (..),
ShortLinkCreds (..),
ConnReqUriData (..),
CRClientData,
ServiceScheme,
FixedLinkData (..),
AConnLinkData (..),
ConnLinkData (..),
AUserConnLinkData (..),
UserConnLinkData (..),
UserContactData (..),
UserLinkData (..),
OwnerAuth (..),
OwnerId,
ConnectionLink (..),
AConnectionLink (..),
SimplexNameInfo (..),
SimplexNameDomain (..),
SimplexTLD (..),
SimplexNameType (..),
ConnShortLink (..),
AConnShortLink (..),
CreatedConnLink (..),
ACreatedConnLink (..),
ContactConnType (..),
ShortLinkScheme (..),
LinkKey (..),
PreparedLinkParams (..),
StoredClientService (..),
ClientService,
ClientServiceId,
validateOwners,
validateLinkOwners,
sameConnReqContact,
sameShortLinkContact,
simplexChat,
connReqUriP',
simplexConnReqUri,
simplexShortLink,
fullDomainName,
shortNameInfoStr,
AgentErrorType (..),
CommandErrorType (..),
ConnectionErrorType (..),
BrokerErrorType (..),
SMPAgentError (..),
DroppedMsg (..),
AgentCryptoError (..),
cryptoErrToSyncState,
ATransmission,
ConnId,
ConfirmationId,
InvitationId,
MsgIntegrity (..),
MsgErrorType (..),
QueueStatus (..),
UserId,
ACorrId,
AgentMsgId,
NotificationsMode (..),
NotificationInfo (..),
ConnMsgReq (..),
-- * Encode/decode
serializeCommand,
connMode,
connMode',
dbCommandP,
connModeT,
serializeQueueStatus,
queueStatusT,
agentMessageType,
aMessageType,
extraSMPServerHosts,
updateSMPServerHosts,
shortenShortLink,
restoreShortLink,
isPresetServer,
linkUserData,
linkUserData',
)
where
import Control.Applicative (optional, (<|>))
import Control.Exception (BlockedIndefinitelyOnMVar (..), BlockedIndefinitelyOnSTM (..), fromException)
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), (.:), (.:?))
import qualified Data.Aeson as J'
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.TH as J
import qualified Data.Aeson.Types as JT
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Attoparsec.Text as AT
import qualified Data.ByteString.Base64.URL as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlpha, isDigit, toLower, toUpper)
import Data.Foldable (find)
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.System (SystemTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32)
import Simplex.FileTransfer.Description
import Simplex.FileTransfer.Protocol (FileParty (..))
import Simplex.FileTransfer.Transport (XFTPErrorType)
import Simplex.FileTransfer.Types (FileErrorType)
import Simplex.Messaging.Agent.QueryString
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..), blobFieldDecoder, fromTextField_)
import Simplex.Messaging.Agent.Store.Entity
import Simplex.Messaging.Client (ProxyClientError)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.Ratchet
( InitialKeys (..),
PQEncryption (..),
PQSupport,
RcvE2ERatchetParams,
RcvE2ERatchetParamsUri,
SndE2ERatchetParams,
pattern PQSupportOff,
pattern PQSupportOn,
)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol
( AProtocolType,
BrokerErrorType (..),
ErrorType,
MsgBody,
MsgFlags,
MsgId,
NMsgMeta,
ProtocolServer (..),
QueueMode (..),
SMPClientVersion,
SMPServer,
SMPServerWithAuth,
SndPublicAuthKey,
SubscriptionMode,
VersionRangeSMPC,
VersionSMPC,
initialSMPClientVersion,
legacyEncodeServer,
legacyServerP,
legacyStrEncodeServer,
noAuthSrv,
sameSrvAddr,
senderCanSecure,
shortLinksSMPClientVersion,
sndAuthKeySMPClientVersion,
srvHostnamesSMPClientVersion,
pattern ProtoServerWithAuth,
pattern SMPServer,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.ServiceScheme
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts_ (..))
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal
import Simplex.RemoteControl.Types
import UnliftIO.Exception (Exception)
-- SMP agent protocol version history:
-- 1 - binary protocol encoding (1/1/2022)
-- 2 - "duplex" (more efficient) connection handshake (6/9/2022)
-- 3 - support ratchet renegotiation (6/30/2023)
-- 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
instance VersionScope SMPAgentVersion
type VersionSMPA = Version SMPAgentVersion
type VersionRangeSMPA = VersionRange SMPAgentVersion
pattern VersionSMPA :: Word16 -> VersionSMPA
pattern VersionSMPA v = Version v
duplexHandshakeSMPAgentVersion :: VersionSMPA
duplexHandshakeSMPAgentVersion = VersionSMPA 2
ratchetSyncSMPAgentVersion :: VersionSMPA
ratchetSyncSMPAgentVersion = VersionSMPA 3
deliveryRcptsSMPAgentVersion :: VersionSMPA
deliveryRcptsSMPAgentVersion = VersionSMPA 4
pqdrSMPAgentVersion :: VersionSMPA
pqdrSMPAgentVersion = VersionSMPA 5
sndAuthKeySMPAgentVersion :: VersionSMPA
sndAuthKeySMPAgentVersion = VersionSMPA 6
ratchetOnConfSMPAgentVersion :: VersionSMPA
ratchetOnConfSMPAgentVersion = VersionSMPA 7
minSupportedSMPAgentVersion :: VersionSMPA
minSupportedSMPAgentVersion = duplexHandshakeSMPAgentVersion
currentSMPAgentVersion :: VersionSMPA
currentSMPAgentVersion = VersionSMPA 7
supportedSMPAgentVRange :: VersionRangeSMPA
supportedSMPAgentVRange = mkVersionRange minSupportedSMPAgentVersion currentSMPAgentVersion
-- it is shorter to allow all handshake headers,
-- including E2E (double-ratchet) parameters and
-- signing key of the sender for the server
e2eEncConnInfoLength :: VersionSMPA -> PQSupport -> Int
e2eEncConnInfoLength v = \case
-- reduced by 3726 (roughly the increase of message ratchet header size + key and ciphertext in reply link)
PQSupportOn | v >= pqdrSMPAgentVersion -> 11106
_ -> 14832
e2eEncAgentMsgLength :: VersionSMPA -> PQSupport -> Int
e2eEncAgentMsgLength v = \case
-- reduced by 2222 (the increase of message ratchet header size)
PQSupportOn | v >= pqdrSMPAgentVersion -> 13618
_ -> 15840
-- | SMP agent event
type ATransmission = (ACorrId, AEntityId, AEvt)
type UserId = Int64
type AEntityId = ByteString
type ACorrId = ByteString
data AEntity = AEConn | AERcvFile | AESndFile | AENone
deriving (Eq, Show)
data SAEntity :: AEntity -> Type where
SAEConn :: SAEntity AEConn
SAERcvFile :: SAEntity AERcvFile
SAESndFile :: SAEntity AESndFile
SAENone :: SAEntity AENone
deriving instance Show (SAEntity e)
instance TestEquality SAEntity where
testEquality SAEConn SAEConn = Just Refl
testEquality SAERcvFile SAERcvFile = Just Refl
testEquality SAESndFile SAESndFile = Just Refl
testEquality SAENone SAENone = Just Refl
testEquality _ _ = Nothing
class AEntityI (e :: AEntity) where sAEntity :: SAEntity e
instance AEntityI AEConn where sAEntity = SAEConn
instance AEntityI AERcvFile where sAEntity = SAERcvFile
instance AEntityI AESndFile where sAEntity = SAESndFile
instance AEntityI AENone where sAEntity = SAENone
data AEvt = forall e. AEntityI e => AEvt (SAEntity e) (AEvent e)
instance Eq AEvt where
AEvt e evt == AEvt e' evt' = case testEquality e e' of
Just Refl -> evt == evt'
Nothing -> False
deriving instance Show AEvt
type ConnInfo = ByteString
type SndQueueSecured = Bool
-- | Parameterized type for SMP agent events
data AEvent (e :: AEntity) where
INV :: AConnectionRequestUri -> Maybe ClientServiceId -> AEvent AEConn
LINK :: ConnShortLink 'CMContact -> UserConnLinkData 'CMContact -> AEvent AEConn
LDATA :: FixedLinkData 'CMContact -> ConnLinkData 'CMContact -> AEvent AEConn
CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender
INFO :: PQSupport -> ConnInfo -> AEvent AEConn
CON :: PQEncryption -> AEvent AEConn -- notification that connection is established
END :: AEvent AEConn
DELD :: AEvent AEConn
CONNECT :: AProtocolType -> TransportHost -> AEvent AENone
DISCONNECT :: AProtocolType -> TransportHost -> AEvent AENone
DOWN :: SMPServer -> [ConnId] -> AEvent AENone
UP :: SMPServer -> [ConnId] -> AEvent AENone
SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> AEvent AEConn
RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> AEvent AEConn
SENT :: AgentMsgId -> Maybe SMPServer -> AEvent AEConn
MWARN :: AgentMsgId -> AgentErrorType -> AEvent AEConn
MERR :: AgentMsgId -> AgentErrorType -> AEvent AEConn
MERRS :: NonEmpty AgentMsgId -> AgentErrorType -> AEvent AEConn
MSG :: MsgMeta -> MsgFlags -> MsgBody -> AEvent AEConn
MSGNTF :: MsgId -> Maybe UTCTime -> AEvent AEConn
RCVD :: MsgMeta -> NonEmpty MsgReceipt -> AEvent AEConn
QCONT :: AEvent AEConn
DEL_RCVQS :: NonEmpty (ConnId, SMPServer, SMP.RecipientId, Maybe AgentErrorType) -> AEvent AEConn
DEL_CONNS :: NonEmpty ConnId -> AEvent AEConn
DEL_USER :: Int64 -> AEvent AENone
STAT :: ConnectionStats -> AEvent AEConn
OK :: AEvent AEConn
JOINED :: SndQueueSecured -> Maybe ClientServiceId -> AEvent AEConn
ERR :: AgentErrorType -> AEvent AEConn
ERRS :: NonEmpty (ConnId, AgentErrorType) -> AEvent AENone
SUSPENDED :: AEvent AENone
RFPROG :: Int64 -> Int64 -> AEvent AERcvFile
RFDONE :: FilePath -> AEvent AERcvFile
RFERR :: AgentErrorType -> AEvent AERcvFile
RFWARN :: AgentErrorType -> AEvent AERcvFile
SFPROG :: Int64 -> Int64 -> AEvent AESndFile
SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent AESndFile
SFERR :: AgentErrorType -> AEvent AESndFile
SFWARN :: AgentErrorType -> AEvent AESndFile
deriving instance Eq (AEvent e)
deriving instance Show (AEvent e)
data AEvtTag = forall e. AEntityI e => AEvtTag (SAEntity e) (AEventTag e)
instance Eq AEvtTag where
AEvtTag e evt == AEvtTag e' evt' = case testEquality e e' of
Just Refl -> evt == evt'
Nothing -> False
deriving instance Show AEvtTag
data ACommand
= NEW Bool AConnectionMode InitialKeys SubscriptionMode -- response INV
| LSET (UserConnLinkData 'CMContact) (Maybe CRClientData) -- response LINK
| LGET (ConnShortLink 'CMContact) -- response LDATA
| JOIN Bool AConnectionRequestUri PQSupport SubscriptionMode ConnInfo
| LET ConfirmationId ConnInfo -- ConnInfo is from client
| ACK AgentMsgId (Maybe MsgReceiptInfo)
| SWCH
| DEL
deriving (Eq, Show)
data ACommandTag
= NEW_
| LSET_
| LGET_
| JOIN_
| LET_
| ACK_
| SWCH_
| DEL_
deriving (Show)
data AEventTag (e :: AEntity) where
INV_ :: AEventTag AEConn
LINK_ :: AEventTag AEConn
LDATA_ :: AEventTag AEConn
CONF_ :: AEventTag AEConn
REQ_ :: AEventTag AEConn
INFO_ :: AEventTag AEConn
CON_ :: AEventTag AEConn
END_ :: AEventTag AEConn
DELD_ :: AEventTag AEConn
CONNECT_ :: AEventTag AENone
DISCONNECT_ :: AEventTag AENone
DOWN_ :: AEventTag AENone
UP_ :: AEventTag AENone
SWITCH_ :: AEventTag AEConn
RSYNC_ :: AEventTag AEConn
SENT_ :: AEventTag AEConn
MWARN_ :: AEventTag AEConn
MERR_ :: AEventTag AEConn
MERRS_ :: AEventTag AEConn
MSG_ :: AEventTag AEConn
MSGNTF_ :: AEventTag AEConn
RCVD_ :: AEventTag AEConn
QCONT_ :: AEventTag AEConn
DEL_RCVQS_ :: AEventTag AEConn
DEL_CONNS_ :: AEventTag AEConn
DEL_USER_ :: AEventTag AENone
STAT_ :: AEventTag AEConn
OK_ :: AEventTag AEConn
JOINED_ :: AEventTag AEConn
ERR_ :: AEventTag AEConn
ERRS_ :: AEventTag AENone
SUSPENDED_ :: AEventTag AENone
-- XFTP commands and responses
RFDONE_ :: AEventTag AERcvFile
RFPROG_ :: AEventTag AERcvFile
RFERR_ :: AEventTag AERcvFile
RFWARN_ :: AEventTag AERcvFile
SFPROG_ :: AEventTag AESndFile
SFDONE_ :: AEventTag AESndFile
SFERR_ :: AEventTag AESndFile
SFWARN_ :: AEventTag AESndFile
deriving instance Eq (AEventTag e)
deriving instance Show (AEventTag e)
aCommandTag :: ACommand -> ACommandTag
aCommandTag = \case
NEW {} -> NEW_
LSET {} -> LSET_
LGET _ -> LGET_
JOIN {} -> JOIN_
LET {} -> LET_
ACK {} -> ACK_
SWCH -> SWCH_
DEL -> DEL_
aEventTag :: AEvent e -> AEventTag e
aEventTag = \case
INV {} -> INV_
LINK {} -> LINK_
LDATA {} -> LDATA_
CONF {} -> CONF_
REQ {} -> REQ_
INFO {} -> INFO_
CON _ -> CON_
END -> END_
DELD -> DELD_
CONNECT {} -> CONNECT_
DISCONNECT {} -> DISCONNECT_
DOWN {} -> DOWN_
UP {} -> UP_
SWITCH {} -> SWITCH_
RSYNC {} -> RSYNC_
SENT {} -> SENT_
MWARN {} -> MWARN_
MERR {} -> MERR_
MERRS {} -> MERRS_
MSG {} -> MSG_
MSGNTF {} -> MSGNTF_
RCVD {} -> RCVD_
QCONT -> QCONT_
DEL_RCVQS _ -> DEL_RCVQS_
DEL_CONNS _ -> DEL_CONNS_
DEL_USER _ -> DEL_USER_
STAT _ -> STAT_
OK -> OK_
JOINED {} -> JOINED_
ERR _ -> ERR_
ERRS _ -> ERRS_
SUSPENDED -> SUSPENDED_
RFPROG {} -> RFPROG_
RFDONE {} -> RFDONE_
RFERR {} -> RFERR_
RFWARN {} -> RFWARN_
SFPROG {} -> SFPROG_
SFDONE {} -> SFDONE_
SFERR {} -> SFERR_
SFWARN {} -> SFWARN_
data QueueDirection = QDRcv | QDSnd
deriving (Eq, Show)
data SwitchPhase = SPStarted | SPConfirmed | SPSecured | SPCompleted
deriving (Eq, Show)
data RcvSwitchStatus
= RSSwitchStarted
| RSSendingQADD
| RSSendingQUSE
| RSReceivedMessage
deriving (Eq, Show)
instance StrEncoding RcvSwitchStatus where
strEncode = \case
RSSwitchStarted -> "switch_started"
RSSendingQADD -> "sending_qadd"
RSSendingQUSE -> "sending_quse"
RSReceivedMessage -> "received_message"
strP =
A.takeTill (== ' ') >>= \case
"switch_started" -> pure RSSwitchStarted
"sending_qadd" -> pure RSSendingQADD
"sending_quse" -> pure RSSendingQUSE
"received_message" -> pure RSReceivedMessage
_ -> fail "bad RcvSwitchStatus"
instance ToField RcvSwitchStatus where toField = toField . decodeLatin1 . strEncode
instance FromField RcvSwitchStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
instance ToJSON RcvSwitchStatus where
toEncoding = strToJEncoding
toJSON = strToJSON
instance FromJSON RcvSwitchStatus where
parseJSON = strParseJSON "RcvSwitchStatus"
data SndSwitchStatus
= SSSendingQKEY
| SSSendingQTEST
deriving (Eq, Show)
instance StrEncoding SndSwitchStatus where
strEncode = \case
SSSendingQKEY -> "sending_qkey"
SSSendingQTEST -> "sending_qtest"
strP =
A.takeTill (== ' ') >>= \case
"sending_qkey" -> pure SSSendingQKEY
"sending_qtest" -> pure SSSendingQTEST
_ -> fail "bad SndSwitchStatus"
instance ToField SndSwitchStatus where toField = toField . decodeLatin1 . strEncode
instance FromField SndSwitchStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
instance ToJSON SndSwitchStatus where
toEncoding = strToJEncoding
toJSON = strToJSON
instance FromJSON SndSwitchStatus where
parseJSON = strParseJSON "SndSwitchStatus"
data RatchetSyncState
= RSOk
| RSAllowed
| RSRequired
| RSStarted
| RSAgreed
deriving (Eq, Show)
instance StrEncoding RatchetSyncState where
strEncode = \case
RSOk -> "ok"
RSAllowed -> "allowed"
RSRequired -> "required"
RSStarted -> "started"
RSAgreed -> "agreed"
strP =
A.takeTill (== ' ') >>= \case
"ok" -> pure RSOk
"allowed" -> pure RSAllowed
"required" -> pure RSRequired
"started" -> pure RSStarted
"agreed" -> pure RSAgreed
_ -> fail "bad RatchetSyncState"
instance FromField RatchetSyncState where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
instance ToField RatchetSyncState where toField = toField . decodeLatin1 . strEncode
instance ToJSON RatchetSyncState where
toEncoding = strToJEncoding
toJSON = strToJSON
instance FromJSON RatchetSyncState where
parseJSON = strParseJSON "RatchetSyncState"
data RcvQueueInfo = RcvQueueInfo
{ rcvServer :: SMPServer,
status :: QueueStatus,
rcvSwitchStatus :: Maybe RcvSwitchStatus,
canAbortSwitch :: Bool,
subStatus :: SubscriptionStatus
}
deriving (Eq, Show)
data SndQueueInfo = SndQueueInfo
{ sndServer :: SMPServer,
status :: QueueStatus,
sndSwitchStatus :: Maybe SndSwitchStatus
}
deriving (Eq, Show)
data SubscriptionStatus
= SSActive
| SSPending
| SSRemoved {subError :: String}
| SSNoSub
deriving (Eq, Ord, Show)
data ConnectionStats = ConnectionStats
{ connAgentVersion :: VersionSMPA,
rcvQueuesInfo :: [RcvQueueInfo],
sndQueuesInfo :: [SndQueueInfo],
ratchetSyncState :: RatchetSyncState,
ratchetSyncSupported :: Bool,
subStatus :: Maybe SubscriptionStatus
}
deriving (Eq, Show)
data NotificationsMode = NMPeriodic | NMInstant
deriving (Eq, Show)
instance StrEncoding NotificationsMode where
strEncode = \case
NMPeriodic -> "PERIODIC"
NMInstant -> "INSTANT"
strP =
A.takeTill (== ' ') >>= \case
"PERIODIC" -> pure NMPeriodic
"INSTANT" -> pure NMInstant
_ -> fail "bad NotificationsMode"
instance ToJSON NotificationsMode where
toEncoding = strToJEncoding
toJSON = strToJSON
instance FromJSON NotificationsMode where
parseJSON = strParseJSON "NotificationsMode"
instance ToField NotificationsMode where toField = toField . decodeLatin1 . strEncode
instance FromField NotificationsMode where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
data NotificationInfo = NotificationInfo
{ ntfConnId :: ConnId,
ntfDbQueueId :: Int64,
ntfTs :: SystemTime,
-- Nothing means that the message failed to decrypt or to decode,
-- we can still show event notification
ntfMsgMeta :: Maybe NMsgMeta
}
deriving (Show)
data ConnMsgReq = ConnMsgReq
{ msgConnId :: ConnId,
msgDbQueueId :: Int64,
msgTs :: Maybe UTCTime
}
deriving (Show)
data ConnectionMode = CMInvitation | CMContact
deriving (Eq, Show)
data SConnectionMode (m :: ConnectionMode) where
SCMInvitation :: SConnectionMode CMInvitation
SCMContact :: SConnectionMode CMContact
deriving instance Eq (SConnectionMode m)
deriving instance Show (SConnectionMode m)
instance TestEquality SConnectionMode where
testEquality SCMInvitation SCMInvitation = Just Refl
testEquality SCMContact SCMContact = Just Refl
testEquality _ _ = Nothing
data AConnectionMode = forall m. ConnectionModeI m => ACM (SConnectionMode m)
instance Eq AConnectionMode where
ACM m == ACM m' = isJust $ testEquality m m'
deriving instance Show AConnectionMode
connMode :: SConnectionMode m -> ConnectionMode
connMode SCMInvitation = CMInvitation
connMode SCMContact = CMContact
{-# INLINE connMode #-}
connMode' :: ConnectionMode -> AConnectionMode
connMode' CMInvitation = ACM SCMInvitation
connMode' CMContact = ACM SCMContact
{-# INLINE connMode' #-}
class ConnectionModeI (m :: ConnectionMode) where sConnectionMode :: SConnectionMode m
instance ConnectionModeI CMInvitation where sConnectionMode = SCMInvitation
instance ConnectionModeI CMContact where sConnectionMode = SCMContact
type MsgHash = ByteString
-- | Agent message metadata sent to the client
data MsgMeta = MsgMeta
{ integrity :: MsgIntegrity,
recipient :: (AgentMsgId, UTCTime),
broker :: (MsgId, UTCTime),
sndMsgId :: AgentMsgId,
pqEncryption :: PQEncryption
}
deriving (Eq, Show)
data DroppedMsg = DroppedMsg
{ brokerTs :: UTCTime,
attempts :: Int
}
deriving (Eq, Show)
data SMPConfirmation = SMPConfirmation
{ -- | sender's public key to use for authentication of sender's commands at the recepient's server
senderKey :: Maybe SndPublicAuthKey,
-- | sender's DH public key for simple per-queue e2e encryption
e2ePubKey :: C.PublicKeyX25519,
-- | sender's information to be associated with the connection, e.g. sender's profile information
connInfo :: ConnInfo,
-- | optional reply queues included in confirmation (added in agent protocol v2)
smpReplyQueues :: [SMPQueueInfo],
-- | SMP client version
smpClientVersion :: VersionSMPC
}
deriving (Show)
data AgentMsgEnvelope
= AgentConfirmation
{ agentVersion :: VersionSMPA,
e2eEncryption_ :: Maybe (SndE2ERatchetParams 'C.X448),
encConnInfo :: ByteString
}
| AgentMsgEnvelope
{ agentVersion :: VersionSMPA,
encAgentMessage :: ByteString
}
| AgentInvitation -- the connInfo in contactInvite is only encrypted with per-queue E2E, not with double ratchet,
{ agentVersion :: VersionSMPA,
connReq :: ConnectionRequestUri 'CMInvitation,
connInfo :: ByteString -- this message is only encrypted with per-queue E2E, not with double ratchet,
}
| AgentRatchetKey
{ agentVersion :: VersionSMPA,
e2eEncryption :: RcvE2ERatchetParams 'C.X448,
info :: ByteString
}
deriving (Show)
instance Encoding AgentMsgEnvelope where
smpEncode = \case
AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo} ->
smpEncode (agentVersion, 'C', e2eEncryption_, Tail encConnInfo)
AgentMsgEnvelope {agentVersion, encAgentMessage} ->
smpEncode (agentVersion, 'M', Tail encAgentMessage)
AgentInvitation {agentVersion, connReq, connInfo} ->
smpEncode (agentVersion, 'I', Large $ strEncode connReq, Tail connInfo)
AgentRatchetKey {agentVersion, e2eEncryption, info} ->
smpEncode (agentVersion, 'R', e2eEncryption, Tail info)
smpP = do
agentVersion <- smpP
smpP >>= \case
'C' -> do
(e2eEncryption_, Tail encConnInfo) <- smpP
pure AgentConfirmation {agentVersion, e2eEncryption_, encConnInfo}
'M' -> do
Tail encAgentMessage <- smpP
pure AgentMsgEnvelope {agentVersion, encAgentMessage}
'I' -> do
connReq <- strDecode . unLarge <$?> smpP
Tail connInfo <- smpP
pure AgentInvitation {agentVersion, connReq, connInfo}
'R' -> do
e2eEncryption <- smpP
Tail info <- smpP
pure AgentRatchetKey {agentVersion, e2eEncryption, info}
_ -> fail "bad AgentMsgEnvelope"
-- SMP agent message formats (after double ratchet decryption,
-- or in case of AgentInvitation - in plain text body)
-- AgentRatchetInfo is not encrypted with double ratchet, but with per-queue E2E encryption
data AgentMessage
= -- used by the initiating party when confirming reply queue
AgentConnInfo ConnInfo
| -- AgentConnInfoReply is used by accepting party in duplexHandshake mode (v2), allowing to include reply queue(s) in the initial confirmation.
-- It made removed REPLY message unnecessary.
AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo
| AgentRatchetInfo ByteString
| AgentMessage APrivHeader AMessage
deriving (Show)
instance Encoding AgentMessage where
smpEncode = \case
AgentConnInfo cInfo -> smpEncode ('I', Tail cInfo)
AgentConnInfoReply smpQueues cInfo -> smpEncode ('D', smpQueues, Tail cInfo) -- 'D' stands for "duplex"
AgentRatchetInfo info -> smpEncode ('R', Tail info)
AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg)
smpP =
smpP >>= \case
'I' -> AgentConnInfo . unTail <$> smpP
'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP)
'R' -> AgentRatchetInfo . unTail <$> smpP
'M' -> AgentMessage <$> smpP <*> smpP
_ -> fail "bad AgentMessage"
-- internal type for storing message type in the database
data AgentMessageType
= AM_CONN_INFO
| AM_CONN_INFO_REPLY
| AM_RATCHET_INFO
| AM_HELLO_
| AM_A_MSG_
| AM_A_RCVD_
| AM_QCONT_
| AM_QADD_
| AM_QKEY_
| AM_QUSE_
| AM_QTEST_
| AM_EREADY_
deriving (Eq, Show)
instance Encoding AgentMessageType where
smpEncode = \case
AM_CONN_INFO -> "C"
AM_CONN_INFO_REPLY -> "D"
AM_RATCHET_INFO -> "S"
AM_HELLO_ -> "H"
AM_A_MSG_ -> "M"
AM_A_RCVD_ -> "V"
AM_QCONT_ -> "QC"
AM_QADD_ -> "QA"
AM_QKEY_ -> "QK"
AM_QUSE_ -> "QU"
AM_QTEST_ -> "QT"
AM_EREADY_ -> "E"
smpP =
A.anyChar >>= \case
'C' -> pure AM_CONN_INFO
'D' -> pure AM_CONN_INFO_REPLY
'S' -> pure AM_RATCHET_INFO
'H' -> pure AM_HELLO_
'M' -> pure AM_A_MSG_
'V' -> pure AM_A_RCVD_
'Q' ->
A.anyChar >>= \case
'C' -> pure AM_QCONT_
'A' -> pure AM_QADD_
'K' -> pure AM_QKEY_
'U' -> pure AM_QUSE_
'T' -> pure AM_QTEST_
_ -> fail "bad AgentMessageType"
'E' -> pure AM_EREADY_
_ -> fail "bad AgentMessageType"
agentMessageType :: AgentMessage -> AgentMessageType
agentMessageType = \case
AgentConnInfo _ -> AM_CONN_INFO
AgentConnInfoReply {} -> AM_CONN_INFO_REPLY
AgentRatchetInfo _ -> AM_RATCHET_INFO
AgentMessage _ aMsg -> aMessageType aMsg
data APrivHeader = APrivHeader
{ -- | sequential ID assigned by the sending agent
sndMsgId :: AgentMsgId,
-- | digest of the previous message
prevMsgHash :: MsgHash
}
deriving (Show)
instance Encoding APrivHeader where
smpEncode APrivHeader {sndMsgId, prevMsgHash} =
smpEncode (sndMsgId, prevMsgHash)
smpP = APrivHeader <$> smpP <*> smpP
data AMsgType
= HELLO_
| A_MSG_
| A_RCVD_
| A_QCONT_
| QADD_
| QKEY_
| QUSE_
| QTEST_
| EREADY_
deriving (Eq)
instance Encoding AMsgType where
smpEncode = \case
HELLO_ -> "H"
A_MSG_ -> "M"
A_RCVD_ -> "V"
A_QCONT_ -> "QC"
QADD_ -> "QA"
QKEY_ -> "QK"
QUSE_ -> "QU"
QTEST_ -> "QT"
EREADY_ -> "E"
smpP =
A.anyChar >>= \case
'H' -> pure HELLO_
'M' -> pure A_MSG_
'V' -> pure A_RCVD_
'Q' ->
A.anyChar >>= \case
'C' -> pure A_QCONT_
'A' -> pure QADD_
'K' -> pure QKEY_
'U' -> pure QUSE_
'T' -> pure QTEST_
_ -> fail "bad AMsgType"
'E' -> pure EREADY_
_ -> fail "bad AMsgType"
-- | Messages sent between SMP agents once SMP queue is secured.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/agent-protocol.md#messages-between-smp-agents
data AMessage
= -- | the first message in the queue to validate it is secured
HELLO
| -- | agent envelope for the client message
A_MSG MsgBody
| -- | agent envelope for delivery receipt
A_RCVD (NonEmpty AMessageReceipt)
| -- | the message instructing the client to continue sending messages (after ERR QUOTA)
A_QCONT SndQAddr
| -- add queue to connection (sent by recipient), with optional address of the replaced queue
QADD (NonEmpty (SMPQueueUri, Maybe SndQAddr))
| -- key to secure the added queues and agree e2e encryption key (sent by sender)
QKEY (NonEmpty (SMPQueueInfo, SndPublicAuthKey))
| -- inform that the queues are ready to use (sent by recipient)
QUSE (NonEmpty (SndQAddr, Bool))
| -- sent by the sender to test new queues and to complete switching
QTEST (NonEmpty SndQAddr)
| -- ratchet re-synchronization is complete, with last decrypted sender message id (recipient's `last_external_snd_msg_id`)
EREADY AgentMsgId
deriving (Show)
aMessageType :: AMessage -> AgentMessageType
aMessageType = \case
-- HELLO is used both in v1 and in v2, but differently.
-- - in v1 (and, possibly, in v2 for simplex connections) can be sent multiple times,
-- until the queue is secured - the OK response from the server instead of initial AUTH errors confirms it.
-- - in v2 duplexHandshake it is sent only once, when it is known that the queue was secured.
HELLO -> AM_HELLO_
A_MSG _ -> AM_A_MSG_
A_RCVD {} -> AM_A_RCVD_
A_QCONT _ -> AM_QCONT_
QADD _ -> AM_QADD_
QKEY _ -> AM_QKEY_
QUSE _ -> AM_QUSE_
QTEST _ -> AM_QTEST_
EREADY _ -> AM_EREADY_
-- | this type is used to send as part of the protocol between different clients
-- TODO possibly, rename fields and types referring to external and internal IDs to make them different
data AMessageReceipt = AMessageReceipt
{ agentMsgId :: AgentMsgId, -- this is an external snd message ID referenced by the message recipient
msgHash :: MsgHash,
rcptInfo :: MsgReceiptInfo
}
deriving (Show)
-- | this type is used as part of agent protocol to communicate with the user application
data MsgReceipt = MsgReceipt
{ agentMsgId :: AgentMsgId, -- this is an internal agent message ID of received message
msgRcptStatus :: MsgReceiptStatus
}
deriving (Eq, Show)
data MsgReceiptStatus = MROk | MRBadMsgHash
deriving (Eq, Show)
instance StrEncoding MsgReceiptStatus where
strEncode = \case
MROk -> "ok"
MRBadMsgHash -> "badMsgHash"
strP =
A.takeWhile1 (/= ' ') >>= \case
"ok" -> pure MROk
"badMsgHash" -> pure MRBadMsgHash
_ -> fail "bad MsgReceiptStatus"
instance ToJSON MsgReceiptStatus where
toJSON = strToJSON
toEncoding = strToJEncoding
instance FromJSON MsgReceiptStatus where
parseJSON = strParseJSON "MsgReceiptStatus"
type MsgReceiptInfo = ByteString
type SndQAddr = (SMPServer, SMP.SenderId)
instance Encoding AMessage where
smpEncode = \case
HELLO -> smpEncode HELLO_
A_MSG body -> smpEncode (A_MSG_, Tail body)
A_RCVD mrs -> smpEncode (A_RCVD_, mrs)
A_QCONT addr -> smpEncode (A_QCONT_, addr)
QADD qs -> smpEncode (QADD_, qs)
QKEY qs -> smpEncode (QKEY_, qs)
QUSE qs -> smpEncode (QUSE_, qs)
QTEST qs -> smpEncode (QTEST_, qs)
EREADY lastDecryptedMsgId -> smpEncode (EREADY_, lastDecryptedMsgId)
smpP =
smpP
>>= \case
HELLO_ -> pure HELLO
A_MSG_ -> A_MSG . unTail <$> smpP
A_RCVD_ -> A_RCVD <$> smpP
A_QCONT_ -> A_QCONT <$> smpP
QADD_ -> QADD <$> smpP
QKEY_ -> QKEY <$> smpP
QUSE_ -> QUSE <$> smpP
QTEST_ -> QTEST <$> smpP
EREADY_ -> EREADY <$> smpP
instance ToField AMessage where toField = toField . Binary . smpEncode
instance FromField AMessage where fromField = blobFieldDecoder smpDecode
instance Encoding AMessageReceipt where
smpEncode AMessageReceipt {agentMsgId, msgHash, rcptInfo} =
smpEncode (agentMsgId, msgHash, Large rcptInfo)
smpP = do
(agentMsgId, msgHash, Large rcptInfo) <- smpP
pure AMessageReceipt {agentMsgId, msgHash, rcptInfo}
instance ConnectionModeI m => StrEncoding (ConnectionRequestUri m) where
strEncode = \case
CRInvitationUri crData e2eParams -> crEncode "invitation" crData (Just e2eParams)
CRContactUri crData -> crEncode "contact" crData Nothing
where
crEncode :: ByteString -> ConnReqUriData -> Maybe (RcvE2ERatchetParamsUri 'C.X448) -> ByteString
crEncode crMode ConnReqUriData {crScheme, crAgentVRange, crSmpQueues, crClientData} e2eParams =
strEncode crScheme <> "/" <> crMode <> "#/?" <> queryStr
where
queryStr =
strEncode . QSP QEscape $
-- semicolon is used to separate SMP queues because comma is used to separate server address hostnames
[("v", strEncode crAgentVRange), ("smp", B.intercalate ";" $ map strEncode $ L.toList crSmpQueues)]
<> maybe [] (\e2e -> [("e2e", strEncode e2e)]) e2eParams
<> maybe [] (\cd -> [("data", encodeUtf8 cd)]) crClientData
strP = connReqUriP' (Just SSSimplex)
instance ConnectionModeI m => Encoding (ConnectionRequestUri m) where
smpEncode = \case
CRInvitationUri crData e2eParams -> smpEncode (CMInvitation, crData, e2eParams)
CRContactUri crData -> smpEncode (CMContact, crData)
smpP = (\(ACR _ cr) -> checkConnMode cr) <$?> smpP
{-# INLINE smpP #-}
instance Encoding AConnectionRequestUri where
smpEncode (ACR _ cr) = smpEncode cr
{-# INLINE smpEncode #-}
smpP =
smpP >>= \case
CMInvitation -> ACR SCMInvitation <$> (CRInvitationUri <$> smpP <*> smpP)
CMContact -> ACR SCMContact . CRContactUri <$> smpP
instance Encoding ConnReqUriData where
smpEncode ConnReqUriData {crAgentVRange, crSmpQueues, crClientData} =
smpEncode (crAgentVRange, crSmpQueues, Large . encodeUtf8 <$> crClientData)
smpP = do
(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
ACR m cr <- connReqUriP overrideScheme
case testEquality m $ sConnectionMode @m of
Just Refl -> pure cr
_ -> fail "bad connection request mode"
instance StrEncoding AConnectionRequestUri where
strEncode (ACR _ cr) = strEncode cr
strP = connReqUriP (Just SSSimplex)
connReqUriP :: Maybe ServiceScheme -> Parser AConnectionRequestUri
connReqUriP overrideScheme = do
crScheme <- (`fromMaybe` overrideScheme) <$> strP -- always parse, but use the passed one if any
crMode <- A.char '/' *> crModeP <* optional (A.char '/') <* "#/?"
query <- strP
aVRange <- queryParam "v" query
crSmpQueues <- queryParamParser queuesP "smp" query
let crClientData = safeDecodeUtf8 <$> queryParamStr "data" query
crData = ConnReqUriData {crScheme, crAgentVRange = aVRange, crSmpQueues, crClientData}
case crMode of
CMInvitation -> do
crE2eParams <- queryParam "e2e" query
pure . ACR SCMInvitation $ CRInvitationUri crData crE2eParams
-- contact links are adjusted to the minimum version supported by the agent
-- to preserve compatibility with the old links published online
CMContact -> pure . ACR SCMContact $ CRContactUri crData {crAgentVRange = adjustAgentVRange aVRange}
where
crModeP = "invitation" $> CMInvitation <|> "contact" $> CMContact
-- semicolon is used to separate SMP queues because comma is used to separate server address hostnames
queuesP = L.fromList <$> (strDecode <$?> A.takeTill (== ';')) `A.sepBy1'` A.char ';'
adjustAgentVRange vr =
let v = max minSupportedSMPAgentVersion $ minVersion vr
in fromMaybe vr $ safeVersionRange v (max v $ maxVersion vr)
instance ConnectionModeI m => FromJSON (ConnectionRequestUri m) where
parseJSON = strParseJSON "ConnectionRequestUri"
{-# INLINE parseJSON #-}
instance ConnectionModeI m => ToJSON (ConnectionRequestUri m) where
toJSON = strToJSON
{-# INLINE toJSON #-}
toEncoding = strToJEncoding
{-# INLINE toEncoding #-}
instance FromJSON AConnectionRequestUri where
parseJSON = strParseJSON "ConnectionRequestUri"
{-# INLINE parseJSON #-}
instance ToJSON AConnectionRequestUri where
toJSON = strToJSON
{-# INLINE toJSON #-}
toEncoding = strToJEncoding
{-# INLINE toEncoding #-}
instance ConnectionModeI m => FromJSON (ConnShortLink m) where
parseJSON = strParseJSON "ConnShortLink"
{-# INLINE parseJSON #-}
instance ConnectionModeI m => ToJSON (ConnShortLink m) where
toJSON = strToJSON
{-# INLINE toJSON #-}
toEncoding = strToJEncoding
{-# INLINE toEncoding #-}
instance FromJSON AConnShortLink where
parseJSON = strParseJSON "AConnShortLink"
{-# INLINE parseJSON #-}
instance ToJSON AConnShortLink where
toJSON = strToJSON
toEncoding = strToJEncoding
-- debug :: Show a => String -> a -> a
-- debug name value = unsafePerformIO (putStrLn $ name <> ": " <> show value) `seq` value
-- {-# INLINE debug #-}
instance StrEncoding ConnectionMode where
strEncode = \case
CMInvitation -> "INV"
CMContact -> "CON"
strP = "INV" $> CMInvitation <|> "CON" $> CMContact
instance StrEncoding AConnectionMode where
strEncode (ACM cMode) = strEncode $ connMode cMode
strP = connMode' <$> strP
instance Encoding ConnectionMode where
smpEncode = \case
CMInvitation -> "I"
CMContact -> "C"
smpP =
A.anyChar >>= \case
'I' -> pure CMInvitation
'C' -> pure CMContact
_ -> fail "bad connection mode"
instance ToJSON ConnectionMode where
toJSON = J'.String . T.toLower . decodeLatin1 . strEncode
{-# INLINE toJSON #-}
toEncoding = JE.text . T.toLower . decodeLatin1 . strEncode
{-# INLINE toEncoding #-}
instance FromJSON ConnectionMode where
parseJSON = J'.withText "ConnectionMode" $ either fail pure . parseAll strP . encodeUtf8 . T.toUpper
{-# INLINE parseJSON #-}
connModeT :: Text -> Maybe ConnectionMode
connModeT = \case
"INV" -> Just CMInvitation
"CON" -> Just CMContact
_ -> Nothing
-- | SMP agent connection ID.
type ConnId = ByteString
type ConfirmationId = ByteString
type InvitationId = ByteString
extraSMPServerHosts :: Map TransportHost TransportHost
extraSMPServerHosts =
M.fromList
[ ("smp4.simplex.im", "o5vmywmrnaxalvz6wi3zicyftgio6psuvyniis6gco6bp6ekl4cqj4id.onion"),
("smp5.simplex.im", "jjbyvoemxysm7qxap7m5d5m35jzv5qq6gnlv7s4rsn7tdwwmuqciwpid.onion"),
("smp6.simplex.im", "bylepyau3ty4czmn77q4fglvperknl4bi2eb2fdy2bh4jxtf32kf73yd.onion"),
("smp8.simplex.im", "beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion"),
("smp9.simplex.im", "jssqzccmrcws6bhmn77vgmhfjmhwlyr3u7puw4erkyoosywgl67slqqd.onion"),
("smp10.simplex.im", "rb2pbttocvnbrngnwziclp2f4ckjq65kebafws6g4hy22cdaiv5dwjqd.onion")
]
updateSMPServerHosts :: SMPServer -> SMPServer
updateSMPServerHosts srv@ProtocolServer {host} = case host of
h :| [] -> case M.lookup h extraSMPServerHosts of
Just h' -> srv {host = [h, h']}
_ -> srv
_ -> srv
class SMPQueue q where
qServer :: q -> SMPServer
queueId :: q -> SMP.QueueId
qAddress :: SMPQueue q => q -> (SMPServer, SMP.QueueId)
qAddress q = (qServer q, queueId q)
{-# INLINE qAddress #-}
sameQueue :: SMPQueue q => (SMPServer, SMP.QueueId) -> q -> Bool
sameQueue addr q = sameQAddress addr (qAddress q)
{-# INLINE sameQueue #-}
data SMPQueueInfo = SMPQueueInfo {clientVersion :: VersionSMPC, queueAddress :: SMPQueueAddress}
deriving (Eq, Show)
instance Encoding SMPQueueInfo where
smpEncode (SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode})
| clientVersion >= shortLinksSMPClientVersion = addrEnc <> maybe "" smpEncode queueMode
| clientVersion >= sndAuthKeySMPClientVersion && sndSecure = addrEnc <> smpEncode sndSecure
| clientVersion > initialSMPClientVersion = addrEnc
| otherwise = smpEncode clientVersion <> legacyEncodeServer smpServer <> smpEncode (senderId, dhPublicKey)
where
addrEnc = smpEncode (clientVersion, smpServer, senderId, dhPublicKey)
sndSecure = senderCanSecure queueMode
smpP = do
clientVersion <- smpP
smpServer <- if clientVersion > initialSMPClientVersion then smpP else updateSMPServerHosts <$> legacyServerP
(senderId, dhPublicKey) <- smpP
queueMode <- queueModeP
pure $ SMPQueueInfo clientVersion SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}
-- This instance seems contrived and there was a temptation to split a common part of both types.
-- But this is created to allow backward and forward compatibility where SMPQueueUri
-- could have more fields to convert to different versions of SMPQueueInfo in a different way,
-- and this instance would become non-trivial.
instance VersionI SMPClientVersion SMPQueueInfo where
type VersionRangeT SMPClientVersion SMPQueueInfo = SMPQueueUri
version = clientVersion
toVersionRangeT (SMPQueueInfo _v addr) vr = SMPQueueUri vr addr
instance VersionRangeI SMPClientVersion SMPQueueUri where
type VersionT SMPClientVersion SMPQueueUri = SMPQueueInfo
versionRange = clientVRange
toVersionT (SMPQueueUri _vr addr) v = SMPQueueInfo v addr
toVersionRange (SMPQueueUri _vr addr) vr = SMPQueueUri vr addr
-- | SMP queue information sent out-of-band.
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
data SMPQueueUri = SMPQueueUri {clientVRange :: VersionRangeSMPC, queueAddress :: SMPQueueAddress}
deriving (Eq, Show)
data SMPQueueAddress = SMPQueueAddress
{ smpServer :: SMPServer,
senderId :: SMP.SenderId,
dhPublicKey :: C.PublicKeyX25519,
queueMode :: Maybe QueueMode
}
deriving (Eq, Show)
instance SMPQueue SMPQueueUri where
qServer SMPQueueUri {queueAddress} = qServer queueAddress
{-# INLINE qServer #-}
queueId SMPQueueUri {queueAddress} = queueId queueAddress
{-# INLINE queueId #-}
instance SMPQueue SMPQueueInfo where
qServer SMPQueueInfo {queueAddress} = qServer queueAddress
{-# INLINE qServer #-}
queueId SMPQueueInfo {queueAddress} = queueId queueAddress
{-# INLINE queueId #-}
instance SMPQueue SMPQueueAddress where
qServer SMPQueueAddress {smpServer} = smpServer
{-# INLINE qServer #-}
queueId SMPQueueAddress {senderId} = senderId
{-# INLINE queueId #-}
sameQAddress :: (SMPServer, SMP.QueueId) -> (SMPServer, SMP.QueueId) -> Bool
sameQAddress (srv, qId) (srv', qId') = sameSrvAddr srv srv' && qId == qId'
{-# INLINE sameQAddress #-}
instance StrEncoding SMPQueueUri where
strEncode (SMPQueueUri vr SMPQueueAddress {smpServer = srv, senderId = qId, dhPublicKey, queueMode})
| minVersion vr >= srvHostnamesSMPClientVersion = strEncode srv <> "/" <> strEncode qId <> "#/?" <> query queryParams
| otherwise = legacyStrEncodeServer srv <> "/" <> strEncode qId <> "#/?" <> query (queryParams <> srvParam)
where
query = strEncode . QSP QEscape
queryParams = [("v", strEncode vr), ("dh", strEncode dhPublicKey)] <> queueModeParam <> sndSecureParam
where
queueModeParam = case queueMode of
Just QMMessaging -> [("q", "m")]
Just QMContact -> [("q", "c")]
Nothing -> []
sndSecureParam = [("k", "s") | senderCanSecure queueMode && minVersion vr < shortLinksSMPClientVersion]
srvParam = [("srv", strEncode $ TransportHosts_ hs) | not (null hs)]
hs = L.tail $ host srv
strP = do
srv@ProtocolServer {host = h :| host} <- strP <* A.char '/'
senderId <- strP <* optional (A.char '/') <* A.char '#'
(vr, hs, dhPublicKey, queueMode) <- versioned <|> unversioned
let srv' = srv {host = h :| host <> hs}
smpServer = if maxVersion vr < srvHostnamesSMPClientVersion then updateSMPServerHosts srv' else srv'
pure $ SMPQueueUri vr SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}
where
unversioned = (versionToRange initialSMPClientVersion,[],,Nothing) <$> strP <* A.endOfInput
versioned = do
dhKey_ <- optional strP
query <- optional (A.char '/') *> A.char '?' *> strP
vr <- queryParam "v" query
dhKey <- maybe (queryParam "dh" query) pure dhKey_
hs_ <- queryParam_ "srv" query
let queueMode = case queryParamStr "q" query of
Just "m" -> Just QMMessaging
Just "c" -> Just QMContact
_ | queryParamStr "k" query == Just "s" -> Just QMMessaging
_ -> Nothing
pure (vr, maybe [] thList_ hs_, dhKey, queueMode)
instance Encoding SMPQueueUri where
smpEncode (SMPQueueUri clientVRange@(VersionRange minV maxV) SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode})
-- The condition is for minVersion as earlier clients won't be able to support it.
-- The alternative would be to encode both queueMode and sndSecure
| minV >= shortLinksSMPClientVersion = addrEnc <> maybe "" smpEncode queueMode
-- Earlier versions won't be able to ignore sndSecure, so we don't include it when it is False
| minV >= sndAuthKeySMPClientVersion || (maxV >= sndAuthKeySMPClientVersion && sndSecure) = addrEnc <> smpEncode sndSecure
| otherwise = addrEnc
where
addrEnc = smpEncode (clientVRange, smpServer, senderId, dhPublicKey)
sndSecure = senderCanSecure queueMode
smpP = do
(clientVRange, smpServer, senderId, dhPublicKey) <- smpP
queueMode <- queueModeP
pure $ SMPQueueUri clientVRange SMPQueueAddress {smpServer, senderId, dhPublicKey, queueMode}
queueModeP :: Parser (Maybe QueueMode)
queueModeP = Just <$> smpP <|> optional ((\case True -> QMMessaging; _ -> QMContact) <$> smpP)
data ConnectionRequestUri (m :: ConnectionMode) where
CRInvitationUri :: ConnReqUriData -> RcvE2ERatchetParamsUri 'C.X448 -> ConnectionRequestUri CMInvitation
-- contact connection request does NOT contain E2E encryption parameters for double ratchet -
-- 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)
data AConnectionRequestUri = forall m. ConnectionModeI m => ACR (SConnectionMode m) (ConnectionRequestUri m)
instance Eq AConnectionRequestUri where
ACR m cr == ACR m' cr' = case testEquality m m' of
Just Refl -> cr == cr'
_ -> False
deriving instance Show AConnectionRequestUri
data ShortLinkCreds = ShortLinkCreds
{ shortLinkId :: SMP.LinkId,
shortLinkKey :: LinkKey,
linkPrivSigKey :: C.PrivateKeyEd25519,
linkRootSigKey :: Maybe C.PublicKeyEd25519, -- in case the current user is not the original owner, and the root key is different from linkPrivSigKey
linkEncFixedData :: SMP.EncFixedDataBytes
}
deriving (Show)
data ShortLinkScheme = SLSSimplex | SLSServer deriving (Eq, Show)
data ConnShortLink (m :: ConnectionMode) where
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)
instance ToField LinkKey where toField (LinkKey s) = toField $ Binary s
-- | Parameters for creating a connection with a prepared link.
data PreparedLinkParams = PreparedLinkParams
{ -- | Correlation ID / determines sender ID
plpNonce :: C.CbNonce,
-- | Queue E2EE DH key pair
plpQueueE2EKeys :: C.KeyPairX25519,
-- | For encrypting link data
plpLinkKey :: LinkKey,
-- | Root signing key (for signing link data)
plpRootPrivKey :: C.PrivateKeyEd25519,
-- | smpEncode of FixedLinkData (includes linkEntityId)
plpSignedFixedData :: ByteString,
-- | Server with basic auth (not stored in link)
plpSrvWithAuth :: SMPServerWithAuth
}
deriving (Show)
instance ConnectionModeI c => ToField (ConnectionLink c) where toField = toField . Binary . strEncode
instance (Typeable c, ConnectionModeI c) => FromField (ConnectionLink c) where fromField = blobFieldDecoder strDecode
instance ConnectionModeI c => ToField (ConnShortLink c) where toField = toField . Binary . strEncode
instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fromField = blobFieldDecoder strDecode
data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (Eq, Show)
data SimplexNameInfo = SimplexNameInfo
{ nameType :: SimplexNameType,
nameDomain :: SimplexNameDomain
}
deriving (Eq, Show)
data SimplexNameDomain = SimplexNameDomain
{ nameTLD :: SimplexTLD,
domain :: Text,
subDomain :: [Text] -- parent to child: ["b", "a"] for a.b.domain.simplex
}
deriving (Eq, Show)
data SimplexTLD = TLDSimplex | TLDTesting | TLDWeb
deriving (Eq, Show)
data SimplexNameType = NTPublicGroup | NTContact
deriving (Eq, Show)
instance StrEncoding SimplexNameType where
strEncode = \case
NTPublicGroup -> "#"
NTContact -> "@"
strP = A.char '#' $> NTPublicGroup <|> A.char '@' $> NTContact
nameLabelP :: AT.Parser Text
nameLabelP = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-'
where
isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f')
instance StrEncoding SimplexNameInfo where
strEncode SimplexNameInfo {nameType, nameDomain} =
"simplex:/name" <> strEncode nameType <> strEncode nameDomain
strP = optional "simplex:/name" *> ((strP >>= infoP) <|> infoP NTPublicGroup)
where
infoP NTPublicGroup = SimplexNameInfo NTPublicGroup <$> (strP <|> bareName)
infoP NTContact = SimplexNameInfo NTContact <$> strP
bareName = parseBare . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace)
parseBare s = (\name -> SimplexNameDomain TLDSimplex name []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s
instance StrEncoding SimplexNameDomain where
strEncode = encodeUtf8 . fullDomainName
strP = parseDomain . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace)
where
parseDomain s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkDomain
mkDomain labels = case reverse labels of
[] -> Left "empty name"
[_] -> Left "domain requires TLD"
"simplex" : name : sub -> Right $ SimplexNameDomain TLDSimplex name sub
"testing" : name : sub -> Right $ SimplexNameDomain TLDTesting name sub
_ -> Right $ SimplexNameDomain TLDWeb (T.intercalate "." labels) []
fullDomainName :: SimplexNameDomain -> Text
fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
where
tld' = case nameTLD of
TLDSimplex -> ["simplex"]
TLDTesting -> ["testing"]
TLDWeb -> []
shortNameInfoStr :: SimplexNameInfo -> Text
shortNameInfoStr = \case
SimplexNameInfo {nameType = NTPublicGroup, nameDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain, subDomain = []}} -> "#" <> domain
info -> pfx <> fullDomainName (nameDomain info)
where
pfx = case nameType info of
NTPublicGroup -> "#"
NTContact -> "@"
data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
instance Eq AConnShortLink where
ACSL m sl == ACSL m' sl' = case testEquality m m' of
Just Refl -> sl == sl'
Nothing -> False
deriving instance Show AConnShortLink
instance ToField AConnShortLink where toField = toField . Binary . strEncode
instance FromField AConnShortLink where fromField = blobFieldDecoder strDecode
data ConnectionLink m = CLFull (ConnectionRequestUri m) | CLShort (ConnShortLink m)
deriving (Eq, Show)
data CreatedConnLink m = CCLink {connFullLink :: ConnectionRequestUri m, connShortLink :: Maybe (ConnShortLink m)}
deriving (Eq, Show)
data ACreatedConnLink = forall m. ConnectionModeI m => ACCL (SConnectionMode m) (CreatedConnLink m)
instance Eq ACreatedConnLink where
ACCL m l == ACCL m' l' = case testEquality m m' of
Just Refl -> l == l'
_ -> False
deriving instance Show ACreatedConnLink
data AConnectionLink = forall m. ConnectionModeI m => ACL (SConnectionMode m) (ConnectionLink m)
instance Eq AConnectionLink where
ACL m cl == ACL m' cl' = case testEquality m m' of
Just Refl -> cl == cl'
_ -> False
deriving instance Show AConnectionLink
instance ConnectionModeI m => StrEncoding (ConnectionLink m) where
strEncode = \case
CLFull cr -> strEncode cr
CLShort sl -> strEncode sl
strP = (\(ACL _ cl) -> checkConnMode cl) <$?> strP
{-# INLINE strP #-}
instance StrEncoding AConnectionLink where
strEncode (ACL _ cl) = strEncode cl
{-# INLINE strEncode #-}
strP =
(\(ACR m cr) -> ACL m (CLFull cr)) <$> strP
<|> (\(ACSL m sl) -> ACL m (CLShort sl)) <$> strP
instance ConnectionModeI m => ToJSON (ConnectionLink m) where
toEncoding = strToJEncoding
toJSON = strToJSON
instance ConnectionModeI m => FromJSON (ConnectionLink m) where
parseJSON = strParseJSON "ConnectionLink"
instance ToJSON AConnectionLink where
toEncoding = strToJEncoding
toJSON = strToJSON
instance FromJSON AConnectionLink where
parseJSON = strParseJSON "AConnectionLink"
instance ConnectionModeI m => StrEncoding (ConnShortLink m) where
strEncode = \case
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
slEncode sch (SMPServer (h :| hs) port (C.KeyHash kh)) linkType lnkId k =
B.concat [authority, "/", B.singleton linkType, "#", lnkIdStr, B64.encodeUnpadded k, queryStr]
where
(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
(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
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
'R' -> pure CCTRelay
_ -> fail "unknown contact address type"
{-# INLINE ctTypeP #-}
ctTypeChar :: ContactConnType -> Char
ctTypeChar = \case
CCTContact -> 'A'
CCTChannel -> 'C'
CCTGroup -> 'G'
CCTRelay -> 'R'
{-# 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 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 (h :| _) _ _) =
if isPresetServer srv presetSrvs then SMPServerOnlyHost h else srv
isPresetServer :: Foldable t => SMPServer -> t SMPServer -> Bool
isPresetServer srv@(SMPServer hs p kh) presetSrvs = case findPresetServer srv presetSrvs of
Just (SMPServer hs' p' kh') ->
all (`elem` hs') hs
&& (p == p' || (null p' && (p == "443" || p == "5223")))
&& 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 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@(SMPServerOnlyHost _) -> fromMaybe s $ findPresetServer s presetSrvs
s -> s
findPresetServer :: Foldable t => SMPServer -> t SMPServer -> Maybe SMPServer
findPresetServer ProtocolServer {host = h :| _} = find (\ProtocolServer {host = h' :| _} -> h == h')
{-# INLINE findPresetServer #-}
sameConnReqContact :: ConnectionRequestUri 'CMContact -> ConnectionRequestUri 'CMContact -> Bool
sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUri ConnReqUriData {crSmpQueues = qs'}) =
L.length qs == L.length qs' && all same (L.zip qs qs')
where
same (q, q') = sameQAddress (qAddress q) (qAddress q')
sameShortLinkContact :: ConnShortLink 'CMContact -> ConnShortLink 'CMContact -> Bool
sameShortLinkContact (CSLContact _ ct srv k) (CSLContact _ ct' srv' k') =
ct == ct' && sameSrvAddr srv srv' && k == k'
checkConnMode :: forall t m m'. (ConnectionModeI m, ConnectionModeI m') => t m' -> Either String (t m)
checkConnMode c = case testEquality (sConnectionMode @m) (sConnectionMode @m') of
Just Refl -> Right c
Nothing -> Left "bad connection mode"
{-# INLINE checkConnMode #-}
data ConnReqUriData = ConnReqUriData
{ crScheme :: ServiceScheme,
crAgentVRange :: VersionRangeSMPA,
crSmpQueues :: NonEmpty SMPQueueUri,
crClientData :: Maybe CRClientData
}
deriving (Eq, Show)
type CRClientData = Text
data FixedLinkData c = FixedLinkData
{ agentVRange :: VersionRangeSMPA,
rootKey :: C.PublicKeyEd25519,
linkConnReq :: ConnectionRequestUri c,
linkEntityId :: Maybe ByteString
}
deriving (Eq, Show)
data ConnLinkData c where
InvitationLinkData :: VersionRangeSMPA -> UserLinkData -> ConnLinkData 'CMInvitation
ContactLinkData :: VersionRangeSMPA -> UserContactData -> ConnLinkData 'CMContact
deriving instance Eq (ConnLinkData c)
deriving instance Show (ConnLinkData c)
data UserContactData = UserContactData
{ -- 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 :: UserLinkData
}
deriving (Eq, Show)
newtype UserLinkData = UserLinkData ByteString
deriving (Eq, Show)
data AConnLinkData = forall m. ConnectionModeI m => ACLD (SConnectionMode m) (ConnLinkData m)
data UserConnLinkData c where
UserInvLinkData :: UserLinkData -> UserConnLinkData 'CMInvitation
UserContactLinkData :: UserContactData -> UserConnLinkData 'CMContact
deriving instance Eq (UserConnLinkData m)
deriving instance Show (UserConnLinkData m)
data AUserConnLinkData = forall m. ConnectionModeI m => AULD (SConnectionMode m) (UserConnLinkData m)
linkUserData :: ConnLinkData c -> UserLinkData
linkUserData = \case
InvitationLinkData _ d -> d
ContactLinkData _ UserContactData {userData} -> userData
{-# INLINE linkUserData #-}
linkUserData' :: ConnLinkData c -> ByteString
linkUserData' d = let UserLinkData s = linkUserData d in s
{-# INLINE linkUserData' #-}
type OwnerId = ByteString
data OwnerAuth = OwnerAuth
{ ownerId :: OwnerId, -- unique in the list, application specific - e.g., MemberId
ownerKey :: C.PublicKeyEd25519,
-- owner authorization by root or any previous owner, sig(ownerId || ownerKey, prevOwnerKey),
authOwnerSig :: C.Signature 'C.Ed25519
}
deriving (Eq, Show)
instance Encoding OwnerAuth where
smpEncode OwnerAuth {ownerId, ownerKey, authOwnerSig} =
-- It is additionally encoded as ByteString to have known length and allow OwnerAuth extension
smpEncode $ smpEncode (ownerId, ownerKey, C.signatureBytes authOwnerSig)
smpP = do
-- parseOnly ignores any unused extension
(ownerId, ownerKey, authOwnerSig) <- A.parseOnly smpP <$?> smpP
pure OwnerAuth {ownerId, ownerKey, authOwnerSig}
validateOwners :: Maybe ShortLinkCreds -> UserContactData -> Either String ()
validateOwners shortLink_ UserContactData {owners} = case shortLink_ of
Nothing
| null owners -> Right ()
| otherwise -> Left "no link credentials with additional owners"
Just ShortLinkCreds {linkPrivSigKey, linkRootSigKey}
| hasOwner -> validateLinkOwners (fromMaybe k linkRootSigKey) owners
| otherwise -> Left "no current owner in link data"
where
hasOwner = isNothing linkRootSigKey || any ((k ==) . ownerKey) owners
k = C.publicKey linkPrivSigKey
validateLinkOwners :: C.PublicKeyEd25519 -> [OwnerAuth] -> Either String ()
validateLinkOwners rootKey = go []
where
go _ [] = Right ()
go prev (o : os) = validOwner o >> go (o : prev) os
where
validOwner OwnerAuth {ownerId = oId, ownerKey = k, authOwnerSig = sig}
| k == rootKey = Left $ "owner key for ID " <> idStr <> " matches root key"
| any duplicate prev = Left $ "duplicate owner key or ID " <> idStr
| signedBy rootKey || any (signedBy . ownerKey) prev = Right ()
| otherwise = Left $ "invalid authorization of owner ID " <> idStr
where
duplicate OwnerAuth {ownerId, ownerKey} = oId == ownerId || k == ownerKey
idStr = B.unpack $ B64.encodeUnpadded oId
signedBy k' = C.verify' k' sig (oId <> C.encodePubKey k)
instance ConnectionModeI c => Encoding (FixedLinkData c) where
smpEncode FixedLinkData {agentVRange, rootKey, linkConnReq, linkEntityId} =
smpEncode (agentVRange, rootKey, linkConnReq) <> maybe "" smpEncode linkEntityId
smpP = do
(agentVRange, rootKey, linkConnReq) <- smpP
linkEntityId <- optional smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
pure FixedLinkData {agentVRange, rootKey, linkConnReq, linkEntityId}
instance ConnectionModeI c => Encoding (ConnLinkData c) where
smpEncode = \case
InvitationLinkData vr userData -> smpEncode (CMInvitation, vr, userData)
ContactLinkData vr cd -> smpEncode (CMContact, vr, cd)
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 <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
pure $ ACLD SCMInvitation $ InvitationLinkData vr userData
CMContact -> do
(vr, cd) <- smpP
pure $ ACLD SCMContact $ ContactLinkData vr cd
instance ConnectionModeI c => Encoding (UserConnLinkData c) where
smpEncode = \case
UserInvLinkData userData -> smpEncode (CMInvitation, userData)
UserContactLinkData cd -> smpEncode (CMContact, cd)
smpP = (\(AULD _ d) -> checkConnMode d) <$?> smpP
{-# INLINE smpP #-}
instance Encoding AUserConnLinkData where
smpEncode (AULD _ d) = smpEncode d
{-# INLINE smpEncode #-}
smpP =
smpP >>= \case
CMInvitation -> do
userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
pure $ AULD SCMInvitation $ UserInvLinkData userData
CMContact ->
AULD SCMContact . UserContactLinkData <$> smpP
instance ConnectionModeI c => StrEncoding (UserConnLinkData c) where
strEncode = smpEncode
{-# INLINE strEncode #-}
strP = smpP
{-# INLINE strP #-}
instance Encoding UserContactData where
smpEncode UserContactData {direct, owners, relays, userData} =
B.concat [smpEncode direct, smpEncodeList owners, smpEncodeList relays, smpEncode userData]
smpP = do
direct <- smpP
owners <- smpListP
relays <- smpListP
userData <- smpP <* A.takeByteString -- ignoring tail for forward compatibility with the future link data encoding
pure UserContactData {direct, owners, relays, userData}
instance Encoding UserLinkData where
smpEncode (UserLinkData s) = if B.length s <= 254 then smpEncode s else smpEncode ('\255', Large s)
{-# INLINE smpEncode #-}
smpP = UserLinkData <$> ((A.char '\255' *> (unLarge <$> smpP)) <|> smpP)
{-# INLINE smpP #-}
data StoredClientService (s :: DBStored) = ClientService
{ dbServiceId :: DBEntityId' s,
serviceId :: SMP.ServiceId
}
deriving (Eq, Show)
type ClientService = StoredClientService 'DBStored
type ClientServiceId = DBEntityId
-- | SMP queue status.
data QueueStatus
= -- | queue is created
New
| -- | queue is confirmed by the sender
Confirmed
| -- | queue is secured with sender key (only used by the queue recipient)
Secured
| -- | queue is active
Active
| -- | queue is disabled (only used by the queue recipient)
Disabled
deriving (Eq, Show, Read)
serializeQueueStatus :: QueueStatus -> Text
serializeQueueStatus = \case
New -> "new"
Confirmed -> "confirmed"
Secured -> "secured"
Active -> "active"
Disabled -> "disabled"
queueStatusT :: Text -> Maybe QueueStatus
queueStatusT = \case
"new" -> Just New
"confirmed" -> Just Confirmed
"secured" -> Just Secured
"active" -> Just Active
"disabled" -> Just Disabled
_ -> Nothing
type AgentMsgId = Int64
-- | Result of received message integrity validation.
data MsgIntegrity = MsgOk | MsgError {errorInfo :: MsgErrorType}
deriving (Eq, Show)
instance StrEncoding MsgIntegrity where
strP = "OK" $> MsgOk <|> "ERR " *> (MsgError <$> strP)
strEncode = \case
MsgOk -> "OK"
MsgError e -> "ERR " <> strEncode e
-- | Error of message integrity validation.
data MsgErrorType
= MsgSkipped {fromMsgId :: AgentMsgId, toMsgId :: AgentMsgId}
| MsgBadId {msgId :: AgentMsgId}
| MsgBadHash
| MsgDuplicate
deriving (Eq, Show)
instance StrEncoding MsgErrorType where
strP =
"ID " *> (MsgBadId <$> A.decimal)
<|> "NO_ID " *> (MsgSkipped <$> A.decimal <* A.space <*> A.decimal)
<|> "HASH" $> MsgBadHash
<|> "DUPLICATE" $> MsgDuplicate
strEncode = \case
MsgSkipped fromMsgId toMsgId ->
B.unwords ["NO_ID", bshow fromMsgId, bshow toMsgId]
MsgBadId aMsgId -> "ID " <> bshow aMsgId
MsgBadHash -> "HASH"
MsgDuplicate -> "DUPLICATE"
-- | Error type used in errors sent to agent clients.
data AgentErrorType
= -- | command or response error
CMD {cmdErr :: CommandErrorType, errContext :: String}
| -- | connection errors
CONN {connErr :: ConnectionErrorType, errContext :: String}
| -- | user not found in database
NO_USER
| -- | SMP protocol errors forwarded to agent clients
SMP {serverAddress :: String, smpErr :: ErrorType}
| -- | NTF protocol errors forwarded to agent clients
NTF {serverAddress :: String, ntfErr :: ErrorType}
| -- | XFTP protocol errors forwarded to agent clients
XFTP {serverAddress :: String, xftpErr :: XFTPErrorType}
| -- | XFTP agent errors
FILE {fileErr :: FileErrorType}
| -- | SMP proxy errors
PROXY {proxyServer :: String, relayServer :: String, proxyErr :: ProxyClientError}
| -- | XRCP protocol errors forwarded to agent clients
RCP {rcpErr :: RCErrorType}
| -- | SMP server errors
BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType}
| -- | errors of other agents
AGENT {agentErr :: SMPAgentError}
| -- | client notice
NOTICE {server :: Text, preset :: Bool, expiresAt :: Maybe UTCTime}
| -- | agent implementation or dependency errors
INTERNAL {internalErr :: String}
| -- | critical agent errors that should be shown to the user, optionally with restart button
CRITICAL {offerRestart :: Bool, criticalErr :: String}
| -- | agent inactive
INACTIVE
deriving (Eq, Show, Exception)
instance AnyError AgentErrorType where
fromSomeException e = case fromException e of
Just BlockedIndefinitelyOnSTM -> CRITICAL True "Thread blocked indefinitely in STM transaction"
_ -> case fromException e of
Just BlockedIndefinitelyOnMVar -> CRITICAL True "Thread blocked indefinitely on MVar"
_ -> INTERNAL $ show e
{-# INLINE fromSomeException #-}
-- | SMP agent protocol command or response error.
data CommandErrorType
= -- | command is prohibited in this context
PROHIBITED
| -- | command syntax is invalid
SYNTAX
| -- | entity ID is required with this command
NO_CONN
| -- | message size is not correct (no terminating space)
SIZE
| -- | message does not fit in SMP block
LARGE
deriving (Eq, Read, Show, Exception)
-- | Connection error.
data ConnectionErrorType
= -- | connection is not in the database
NOT_FOUND
| -- | connection already exists
DUPLICATE
| -- | connection is simplex, but operation requires another queue
SIMPLEX
| -- | connection not accepted on join HELLO after timeout
NOT_ACCEPTED
| -- | connection not available on reply confirmation/HELLO after timeout
NOT_AVAILABLE
deriving (Eq, Read, Show, Exception)
-- | Errors of another SMP agent.
data SMPAgentError
= -- | client or agent message that failed to parse
A_MESSAGE
| -- | prohibited SMP/agent message
A_PROHIBITED {prohibitedErr :: String}
| -- | incompatible version of SMP client, agent or encryption protocols
A_VERSION
| -- | failed signature, hash or senderId verification of retrieved link data
A_LINK {linkErr :: String}
| -- | cannot decrypt message
A_CRYPTO {cryptoErr :: AgentCryptoError}
| -- | duplicate message - this error is detected by ratchet decryption - this message will be ignored and not shown.
-- it may also indicate a loss of ratchet synchronization (when only one message is sent via copied ratchet).
-- when message is dropped after too many reception attempts, DroppedMsg is included.
A_DUPLICATE {droppedMsg_ :: Maybe DroppedMsg}
| -- | error in the message to add/delete/etc queue in connection
A_QUEUE {queueErr :: String}
deriving (Eq, Show, Exception)
data AgentCryptoError
= -- | AES decryption error
DECRYPT_AES
| -- CryptoBox decryption error
DECRYPT_CB
| -- | can't decrypt ratchet header, possibly ratchet out of sync due to device change
RATCHET_HEADER
| -- | earlier message number (or, possibly, skipped message that failed to decrypt?)
RATCHET_EARLIER Word32
| -- | too many skipped messages
RATCHET_SKIPPED Word32
| -- | ratchet synchronization error
RATCHET_SYNC
deriving (Eq, Read, Show, Exception)
cryptoErrToSyncState :: AgentCryptoError -> RatchetSyncState
cryptoErrToSyncState = \case
DECRYPT_AES -> RSAllowed
DECRYPT_CB -> RSAllowed
RATCHET_HEADER -> RSRequired
RATCHET_EARLIER _ -> RSAllowed
RATCHET_SKIPPED _ -> RSRequired
RATCHET_SYNC -> RSRequired
-- | SMP agent command and response parser for commands stored in db (fully parses binary bodies)
dbCommandP :: Parser ACommand
dbCommandP = commandP $ A.take =<< (A.decimal <* "\n")
instance StrEncoding ACommandTag where
strP =
A.takeTill (== ' ') >>= \case
"NEW" -> pure NEW_
"LSET" -> pure LSET_
"LGET" -> pure LGET_
"JOIN" -> pure JOIN_
"LET" -> pure LET_
"ACK" -> pure ACK_
"SWCH" -> pure SWCH_
"DEL" -> pure DEL_
_ -> fail "bad ACommandTag"
strEncode = \case
NEW_ -> "NEW"
LSET_ -> "LSET"
LGET_ -> "LGET"
JOIN_ -> "JOIN"
LET_ -> "LET"
ACK_ -> "ACK"
SWCH_ -> "SWCH"
DEL_ -> "DEL"
commandP :: Parser ByteString -> Parser ACommand
commandP binaryP =
strP
>>= \case
NEW_ -> s (NEW <$> strP_ <*> strP_ <*> pqIKP <*> (strP <|> pure SMP.SMSubscribe))
LSET_ -> s (LSET <$> strP <*> optional (A.space *> strP))
LGET_ -> s (LGET <$> strP)
JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> pqSupP <*> (strP_ <|> pure SMP.SMSubscribe) <*> binaryP)
LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP)
ACK_ -> s (ACK <$> A.decimal <*> optional (A.space *> binaryP))
SWCH_ -> pure SWCH
DEL_ -> pure DEL
where
s :: Parser a -> Parser a
s p = A.space *> p
pqIKP :: Parser InitialKeys
pqIKP = strP_ <|> pure (IKLinkPQ PQSupportOff)
pqSupP :: Parser PQSupport
pqSupP = strP_ <|> pure PQSupportOff
-- | Serialize SMP agent command.
serializeCommand :: ACommand -> ByteString
serializeCommand = \case
NEW ntfs cMode pqIK subMode -> s (NEW_, ntfs, cMode, pqIK, subMode)
LSET uld cd_ -> s (LSET_, uld) <> maybe "" (B.cons ' ' . s) cd_
LGET sl -> s (LGET_, sl)
JOIN ntfs cReq pqSup subMode cInfo -> s (JOIN_, ntfs, cReq, pqSup, subMode, Str $ serializeBinary cInfo)
LET confId cInfo -> B.unwords [s LET_, confId, serializeBinary cInfo]
ACK mId rcptInfo_ -> s (ACK_, mId) <> maybe "" (B.cons ' ' . serializeBinary) rcptInfo_
SWCH -> s SWCH_
DEL -> s DEL_
where
s :: StrEncoding a => a -> ByteString
s = strEncode
serializeBinary :: ByteString -> ByteString
serializeBinary body = bshow (B.length body) <> "\n" <> body
$(J.deriveJSON (enumJSON fstToLower) ''QueueStatus)
$(J.deriveJSON (sumTypeJSON $ dropPrefix "SS") ''SubscriptionStatus)
$(J.deriveJSON defaultJSON ''RcvQueueInfo)
$(J.deriveJSON defaultJSON ''SndQueueInfo)
$(J.deriveJSON defaultJSON ''ConnectionStats)
$(J.deriveJSON (sumTypeJSON fstToLower) ''MsgErrorType)
$(J.deriveJSON (sumTypeJSON fstToLower) ''MsgIntegrity)
$(J.deriveJSON (sumTypeJSON id) ''CommandErrorType)
$(J.deriveJSON (sumTypeJSON id) ''ConnectionErrorType)
$(J.deriveJSON (sumTypeJSON id) ''AgentCryptoError)
$(J.deriveJSON defaultJSON ''DroppedMsg)
$(J.deriveJSON (sumTypeJSON id) ''SMPAgentError)
$(J.deriveJSON (sumTypeJSON id) ''AgentErrorType)
$(J.deriveJSON (enumJSON $ dropPrefix "QD") ''QueueDirection)
$(J.deriveJSON (enumJSON $ dropPrefix "SP") ''SwitchPhase)
instance ConnectionModeI m => FromJSON (CreatedConnLink m) where
parseJSON = $(J.mkParseJSON defaultJSON ''CreatedConnLink)
instance ConnectionModeI m => ToJSON (CreatedConnLink m) where
toEncoding = $(J.mkToEncoding defaultJSON ''CreatedConnLink)
toJSON = $(J.mkToJSON defaultJSON ''CreatedConnLink)
instance FromJSON ACreatedConnLink where
parseJSON (Object v) = do
ACR m cReq <- v .: "connFullLink"
shortLink <- v .:? "connShortLink"
pure $ ACCL m $ CCLink cReq shortLink
parseJSON invalid =
JT.prependFailure "bad ACreatedConnLink, " (JT.typeMismatch "Object" invalid)
instance ToJSON ACreatedConnLink where
toEncoding (ACCL _ ccLink) = toEncoding ccLink
toJSON (ACCL _ ccLink) = toJSON ccLink
$(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD)
$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType)
$(J.deriveJSON defaultJSON ''SimplexNameDomain)
$(J.deriveJSON defaultJSON ''SimplexNameInfo)
Reference in New Issue View Git Blame Copy Permalink