Merge branch 'master' into v5

src/Simplex/Messaging/Agent.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -127,11 +128,11 @@ disconnectAgentClient c = closeAgentClient c >> logConnection c False
 type AgentErrorMonad m = (MonadUnliftIO m, MonadError AgentErrorType m)
 
 -- | Create SMP agent connection (NEW command)
-createConnection :: AgentErrorMonad m => AgentClient -> m (ConnId, SMPQueueInfo)
+createConnection :: AgentErrorMonad m => AgentClient -> m (ConnId, ConnectionRequest)
 createConnection c = withAgentEnv c $ newConn c ""
 
 -- | Join SMP agent connection (JOIN command)
-joinConnection :: AgentErrorMonad m => AgentClient -> SMPQueueInfo -> ConnInfo -> m ConnId
+joinConnection :: AgentErrorMonad m => AgentClient -> ConnectionRequest -> ConnInfo -> m ConnId
 joinConnection c = withAgentEnv c .: joinConn c ""
 
 -- | Approve confirmation (LET command)
@@ -235,7 +236,7 @@ withStore action = do
 processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent)
 processCommand c (connId, cmd) = case cmd of
   NEW -> second INV <$> newConn c connId
-  JOIN smpQueueInfo connInfo -> (,OK) <$> joinConn c connId smpQueueInfo connInfo
+  JOIN smpQueueUri connInfo -> (,OK) <$> joinConn c connId smpQueueUri connInfo
   ACPT confId ownConnInfo -> acceptConnection' c connId confId ownConnInfo $> (connId, OK)
   SUB -> subscribeConnection' c connId $> (connId, OK)
   SEND msgBody -> (connId,) . MID <$> sendMessage' c connId msgBody
@@ -243,19 +244,19 @@ processCommand c (connId, cmd) = case cmd of
   OFF -> suspendConnection' c connId $> (connId, OK)
   DEL -> deleteConnection' c connId $> (connId, OK)
 
-newConn :: AgentMonad m => AgentClient -> ConnId -> m (ConnId, SMPQueueInfo)
+newConn :: AgentMonad m => AgentClient -> ConnId -> m (ConnId, ConnectionRequest)
 newConn c connId = do
   srv <- getSMPServer
-  (rq, qInfo) <- newRcvQueue c srv
+  (rq, qUri, encryptKey) <- newRcvQueue c srv
   g <- asks idsDrg
   let cData = ConnData {connId}
   connId' <- withStore $ \st -> createRcvConn st g cData rq
   addSubscription c rq connId'
-  pure (connId', qInfo)
+  pure (connId', ConnectionRequest simplexChat CRAConnect [qUri] encryptKey)
 
-joinConn :: AgentMonad m => AgentClient -> ConnId -> SMPQueueInfo -> ConnInfo -> m ConnId
-joinConn c connId qInfo cInfo = do
-  (sq, senderKey, verifyKey) <- newSndQueue qInfo
+joinConn :: AgentMonad m => AgentClient -> ConnId -> ConnectionRequest -> ConnInfo -> m ConnId
+joinConn c connId (ConnectionRequest _ CRAConnect (qUri :| _) encryptKey) cInfo = do
+  (sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey
   g <- asks idsDrg
   cfg <- asks config
   let cData = ConnData {connId}
@@ -271,10 +272,10 @@ activateQueueJoining c connId sq verifyKey retryInterval =
     createReplyQueue :: m ()
     createReplyQueue = do
       srv <- getSMPServer
-      (rq, qInfo') <- newRcvQueue c srv
+      (rq, qUri', encryptKey) <- newRcvQueue c srv
       addSubscription c rq connId
       withStore $ \st -> upgradeSndConnToDuplex st connId rq
-      sendControlMessage c sq $ REPLY qInfo'
+      sendControlMessage c sq . REPLY $ ConnectionRequest CRSSimplex CRAConnect [qUri'] encryptKey
 
 -- | Approve confirmation (LET command) in Reader monad
 acceptConnection' :: AgentMonad m => AgentClient -> ConnId -> ConfirmationId -> ConnInfo -> m ()
@@ -498,7 +499,7 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
             Right SMPMessage {agentMessage, senderMsgId, senderTimestamp, previousMsgHash} ->
               case agentMessage of
                 HELLO verifyKey _ -> helloMsg verifyKey msgBody >> sendAck c rq
-                REPLY qInfo -> replyMsg qInfo >> sendAck c rq
+                REPLY cReq -> replyMsg cReq >> sendAck c rq
                 A_MSG body -> agentClientMsg previousMsgHash (senderMsgId, senderTimestamp) (srvMsgId, srvTs) body msgHash
         SMP.END -> do
           removeSubscription c connId
@@ -542,13 +543,13 @@ processSMPTransmission c@AgentClient {subQ} (srv, rId, cmd) = do
                 SCDuplex -> notifyConnected c connId
                 _ -> pure ()
 
-        replyMsg :: SMPQueueInfo -> m ()
-        replyMsg qInfo = do
+        replyMsg :: ConnectionRequest -> m ()
+        replyMsg (ConnectionRequest _ CRAConnect (qUri :| _) encryptKey) = do
           logServer "<--" c srv rId "MSG <REPLY>"
           case cType of
             SCRcv -> do
               AcceptedConfirmation {ownConnInfo} <- withStore (`getAcceptedConfirmation` connId)
-              (sq, senderKey, verifyKey) <- newSndQueue qInfo
+              (sq, senderKey, verifyKey) <- newSndQueue qUri encryptKey
               withStore $ \st -> upgradeRcvConnToDuplex st connId sq
               confirmQueue c sq senderKey ownConnInfo
               withStore (`removeConfirmations` connId)
@@ -603,17 +604,18 @@ notifyConnected :: AgentMonad m => AgentClient -> ConnId -> m ()
 notifyConnected c connId = atomically $ writeTBQueue (subQ c) ("", connId, CON)
 
 newSndQueue ::
-  (MonadUnliftIO m, MonadReader Env m) => SMPQueueInfo -> m (SndQueue, SenderPublicKey, C.APublicVerifyKey)
-newSndQueue qInfo =
+  (MonadUnliftIO m, MonadReader Env m) => SMPQueueUri -> C.APublicEncryptKey -> m (SndQueue, SenderPublicKey, C.APublicVerifyKey)
+newSndQueue qUri encryptKey =
   asks (cmdSignAlg . config) >>= \case
-    C.SignAlg a -> newSndQueue_ a qInfo
+    C.SignAlg a -> newSndQueue_ a qUri encryptKey
 
 newSndQueue_ ::
   (C.SignatureAlgorithm a, C.AlgorithmI a, MonadUnliftIO m, MonadReader Env m) =>
   C.SAlgorithm a ->
-  SMPQueueInfo ->
+  SMPQueueUri ->
+  C.APublicEncryptKey ->
   m (SndQueue, SenderPublicKey, C.APublicVerifyKey)
-newSndQueue_ a (SMPQueueInfo smpServer senderId encryptKey) = do
+newSndQueue_ a (SMPQueueUri smpServer senderId _) encryptKey = do
   size <- asks $ rsaKeySize . config
   (senderKey, sndPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a
   (verifyKey, signKey) <- liftIO $ C.generateSignatureKeyPair size C.SRSA

src/Simplex/Messaging/Agent/Client.hs

@@ -223,7 +223,7 @@ smpClientError = \case
   SMPTransportError e -> BROKER $ TRANSPORT e
   e -> INTERNAL $ show e
 
-newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueInfo)
+newRcvQueue :: AgentMonad m => AgentClient -> SMPServer -> m (RcvQueue, SMPQueueUri, C.APublicEncryptKey)
 newRcvQueue c srv =
   asks (cmdSignAlg . config) >>= \case
     C.SignAlg a -> newRcvQueue_ a c srv
@@ -233,7 +233,7 @@ newRcvQueue_ ::
   C.SAlgorithm a ->
   AgentClient ->
   SMPServer ->
-  m (RcvQueue, SMPQueueInfo)
+  m (RcvQueue, SMPQueueUri, C.APublicEncryptKey)
 newRcvQueue_ a c srv = do
   size <- asks $ rsaKeySize . config
   (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair size a
@@ -251,7 +251,7 @@ newRcvQueue_ a c srv = do
             verifyKey = Nothing,
             status = New
           }
-  return (rq, SMPQueueInfo srv sId encryptKey)
+  pure (rq, SMPQueueUri srv sId reservedServerKey, encryptKey)
 
 subscribeQueue :: AgentMonad m => AgentClient -> RcvQueue -> ConnId -> m ()
 subscribeQueue c rq@RcvQueue {server, rcvPrivateKey, rcvId} connId = do

src/Simplex/Messaging/Agent/Protocol.hs

@@ -37,7 +37,11 @@ module Simplex.Messaging.Agent.Protocol
     SMPMessage (..),
     AMessage (..),
     SMPServer (..),
-    SMPQueueInfo (..),
+    SMPQueueUri (..),
+    ConnectionRequest (..),
+    ConnReqScheme (..),
+    simplexChat,
+    ConnReqAction (..),
     AgentErrorType (..),
     CommandErrorType (..),
     ConnectionErrorType (..),
@@ -63,14 +67,18 @@ module Simplex.Messaging.Agent.Protocol
     serializeSMPMessage,
     serializeMsgIntegrity,
     serializeServer,
-    serializeSmpQueueInfo,
+    serializeSMPQueueUri,
+    reservedServerKey, -- TODO remove
+    serializeConnReq,
     serializeAgentError,
     commandP,
     parseSMPMessage,
     smpServerP,
-    smpQueueInfoP,
+    smpQueueUriP,
+    connReqP,
     msgIntegrityP,
     agentErrorTypeP,
+    agentMessageP,
 
     -- * TCP transport functions
     tPut,
@@ -82,14 +90,18 @@ where
 
 import Control.Applicative (optional, (<|>))
 import Control.Monad.IO.Class
+import qualified Crypto.PubKey.RSA as R
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Base64
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.Kind (Type)
+import Data.List (find)
+import qualified Data.List.NonEmpty as L
 import Data.String (IsString (..))
 import Data.Time.Clock (UTCTime)
 import Data.Time.ISO8601
@@ -97,6 +109,7 @@ import Data.Type.Equality
 import Data.Typeable ()
 import GHC.Generics (Generic)
 import Generic.Random (genericArbitraryU)
+import Network.HTTP.Types (parseSimpleQuery, renderSimpleQuery)
 import Network.Socket (HostName, ServiceName)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Parsers
@@ -151,8 +164,8 @@ type ConnInfo = ByteString
 -- | Parameterized type for SMP agent protocol commands and responses from all participants.
 data ACommand (p :: AParty) where
   NEW :: ACommand Client -- response INV
-  INV :: SMPQueueInfo -> ACommand Agent
-  JOIN :: SMPQueueInfo -> ConnInfo -> ACommand Client -- response OK
+  INV :: ConnectionRequest -> ACommand Agent
+  JOIN :: ConnectionRequest -> ConnInfo -> ACommand Client -- response OK
   REQ :: ConfirmationId -> ConnInfo -> ACommand Agent -- ConnInfo is from sender
   ACPT :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client
   INFO :: ConnInfo -> ACommand Agent
@@ -221,7 +234,7 @@ data AMessage where
   -- | the first message in the queue to validate it is secured
   HELLO :: C.APublicVerifyKey -> AckMode -> AMessage
   -- | reply queue information
-  REPLY :: SMPQueueInfo -> AMessage
+  REPLY :: ConnectionRequest -> AMessage
   -- | agent envelope for the client message
   A_MSG :: MsgBody -> AMessage
   deriving (Show)
@@ -266,15 +279,10 @@ agentMessageP =
     <|> "MSG " *> a_msg
   where
     hello = HELLO <$> C.strKeyP <*> ackMode
-    reply = REPLY <$> smpQueueInfoP
+    reply = REPLY <$> connReqP
     a_msg = A_MSG <$> binaryBodyP <* A.endOfLine
     ackMode = AckMode <$> (" NO_ACK" $> Off <|> pure On)
 
--- | SMP queue information parser.
-smpQueueInfoP :: Parser SMPQueueInfo
-smpQueueInfoP =
-  "smp::" *> (SMPQueueInfo <$> smpServerP <* "::" <*> base64P <* "::" <*> C.strKeyP)
-
 -- | SMP server location parser.
 smpServerP :: Parser SMPServer
 smpServerP = SMPServer <$> server <*> optional port <*> optional kHash
@@ -286,19 +294,74 @@ smpServerP = SMPServer <$> server <*> optional port <*> optional kHash
 serializeAgentMessage :: AMessage -> ByteString
 serializeAgentMessage = \case
   HELLO verifyKey ackMode -> "HELLO " <> C.serializeKey verifyKey <> if ackMode == AckMode Off then " NO_ACK" else ""
-  REPLY qInfo -> "REPLY " <> serializeSmpQueueInfo qInfo
+  REPLY cReq -> "REPLY " <> serializeConnReq cReq
   A_MSG body -> "MSG " <> serializeBinary body <> "\n"
 
 -- | Serialize SMP queue information that is sent out-of-band.
-serializeSmpQueueInfo :: SMPQueueInfo -> ByteString
-serializeSmpQueueInfo (SMPQueueInfo srv qId ek) =
-  B.intercalate "::" ["smp", serializeServer srv, encode qId, C.serializeKey ek]
+serializeSMPQueueUri :: SMPQueueUri -> ByteString
+serializeSMPQueueUri (SMPQueueUri srv qId _) =
+  serializeServerUri srv <> "/" <> U.encode qId <> "#"
+
+-- | SMP queue information parser.
+smpQueueUriP :: Parser SMPQueueUri
+smpQueueUriP =
+  SMPQueueUri <$> smpServerUriP <* "/" <*> base64UriP <* "#" <*> pure reservedServerKey
+
+reservedServerKey :: C.APublicVerifyKey
+reservedServerKey = C.APublicVerifyKey C.SRSA (C.PublicKeyRSA $ R.PublicKey 1 0 0)
+
+serializeConnReq :: ConnectionRequest -> ByteString
+serializeConnReq (ConnectionRequest scheme action smpQueues encryptionKey) =
+  sch <> "/" <> act <> "#/" <> queryStr
+  where
+    sch = case scheme of
+      CRSSimplex -> "simplex:"
+      CRSAppServer host port -> B.pack $ "https://" <> host <> maybe "" (':' :) port
+    act = case action of
+      CRAConnect -> "connect"
+    queryStr = renderSimpleQuery True [("smp", queues), ("e2e", key)]
+    queues = B.intercalate "," . map serializeSMPQueueUri $ L.toList smpQueues
+    key = C.serializeKey encryptionKey
+
+connReqP :: Parser ConnectionRequest
+connReqP = do
+  crScheme <- "simplex:" $> CRSSimplex <|> "https://" *> appServer
+  crAction <- "/" *> ("connect" $> CRAConnect) <* "#/?"
+  query <- parseSimpleQuery <$> A.takeTill (\c -> c == ' ' || c == '\n')
+  crSmpQueues <- paramP "smp" smpQueues query
+  crEncryptKey <- paramP "e2e" C.strKeyP query
+  pure ConnectionRequest {crScheme, crAction, crSmpQueues, crEncryptKey}
+  where
+    appServer = CRSAppServer <$> host <*> optional port
+    host = B.unpack <$> A.takeTill (\c -> c == ':' || c == '/')
+    port = B.unpack <$> (A.char ':' *> A.takeTill (== '/'))
+    paramP param parser query =
+      let p = maybe (fail "") (pure . snd) $ find ((== param) . fst) query
+       in parseAll parser <$?> p
+    smpQueues =
+      maybe (fail "no SMP queues") pure . L.nonEmpty
+        =<< (smpQueue `A.sepBy1'` A.char ',')
+    smpQueue = parseAll smpQueueUriP <$?> A.takeTill (== ',')
 
 -- | Serialize SMP server location.
 serializeServer :: SMPServer -> ByteString
 serializeServer SMPServer {host, port, keyHash} =
   B.pack $ host <> maybe "" (':' :) port <> maybe "" (('#' :) . B.unpack . encode . C.unKeyHash) keyHash
 
+serializeServerUri :: SMPServer -> ByteString
+serializeServerUri SMPServer {host, port, keyHash} = "smp://" <> kh <> B.pack host <> p
+  where
+    kh = maybe "" ((<> "@") . U.encode . C.unKeyHash) keyHash
+    p = B.pack $ maybe "" (':' :) port
+
+smpServerUriP :: Parser SMPServer
+smpServerUriP = do
+  _ <- "smp://"
+  keyHash <- optional $ C.KeyHash <$> (U.decode <$?> A.takeTill (== '@') <* A.char '@')
+  host <- B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
+  port <- optional $ B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
+  pure SMPServer {host, port, keyHash}
+
 -- | SMP server location and transport key digest (hash).
 data SMPServer = SMPServer
   { host :: HostName,
@@ -328,9 +391,29 @@ newtype AckMode = AckMode OnOff deriving (Eq, Show)
 -- | SMP queue information sent out-of-band.
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#out-of-band-messages
-data SMPQueueInfo = SMPQueueInfo SMPServer SMP.SenderId C.APublicEncryptKey
+data SMPQueueUri = SMPQueueUri
+  { smpServer :: SMPServer,
+    senderId :: SMP.SenderId,
+    serverVerifyKey :: C.APublicVerifyKey
+  }
   deriving (Eq, Show)
 
+data ConnectionRequest = ConnectionRequest
+  { crScheme :: ConnReqScheme,
+    crAction :: ConnReqAction,
+    crSmpQueues :: L.NonEmpty SMPQueueUri,
+    crEncryptKey :: C.APublicEncryptKey
+  }
+  deriving (Eq, Show)
+
+data ConnReqScheme = CRSSimplex | CRSAppServer HostName (Maybe ServiceName)
+  deriving (Eq, Show)
+
+simplexChat :: ConnReqScheme
+simplexChat = CRSAppServer "simplex.chat" Nothing
+
+data ConnReqAction = CRAConnect deriving (Eq, Show)
+
 data QueueDirection = SND | RCV deriving (Show)
 
 -- | SMP queue status.
@@ -460,8 +543,8 @@ commandP =
     <|> "CON" $> ACmd SAgent CON
     <|> "OK" $> ACmd SAgent OK
   where
-    invResp = ACmd SAgent . INV <$> smpQueueInfoP
-    joinCmd = ACmd SClient <$> (JOIN <$> smpQueueInfoP <* A.space <*> A.takeByteString)
+    invResp = ACmd SAgent . INV <$> connReqP
+    joinCmd = ACmd SClient <$> (JOIN <$> connReqP <* A.space <*> A.takeByteString)
     reqCmd = ACmd SAgent <$> (REQ <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)
     acptCmd = ACmd SClient <$> (ACPT <$> A.takeTill (== ' ') <* A.space <*> A.takeByteString)
     infoCmd = ACmd SAgent . INFO <$> A.takeByteString
@@ -497,8 +580,8 @@ parseCommand = parse commandP $ CMD SYNTAX
 serializeCommand :: ACommand p -> ByteString
 serializeCommand = \case
   NEW -> "NEW"
-  INV qInfo -> "INV " <> serializeSmpQueueInfo qInfo
-  JOIN qInfo cInfo -> "JOIN " <> serializeSmpQueueInfo qInfo <> " " <> serializeBinary cInfo
+  INV cReq -> "INV " <> serializeConnReq cReq
+  JOIN cReq cInfo -> "JOIN " <> serializeConnReq cReq <> " " <> serializeBinary cInfo
   REQ confId cInfo -> "REQ " <> confId <> " " <> serializeBinary cInfo
   ACPT confId cInfo -> "ACPT " <> confId <> " " <> serializeBinary cInfo
   INFO cInfo -> "INFO " <> serializeBinary cInfo
@@ -614,7 +697,7 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody
     cmdWithMsgBody = \case
       SEND body -> SEND <$$> getBody body
       MSG msgMeta body -> MSG msgMeta <$$> getBody body
-      JOIN qInfo cInfo -> JOIN qInfo <$$> getBody cInfo
+      JOIN qUri cInfo -> JOIN qUri <$$> getBody cInfo
       REQ confId cInfo -> REQ confId <$$> getBody cInfo
       ACPT confId cInfo -> ACPT confId <$$> getBody cInfo
       INFO cInfo -> INFO <$$> getBody cInfo

src/Simplex/Messaging/Agent/Store/SQLite.hs

@@ -490,9 +490,13 @@ instance ToField MsgIntegrity where toField = toField . serializeMsgIntegrity
 
 instance FromField MsgIntegrity where fromField = blobFieldParser msgIntegrityP
 
-instance ToField SMPQueueInfo where toField = toField . serializeSmpQueueInfo
+instance ToField SMPQueueUri where toField = toField . serializeSMPQueueUri
 
-instance FromField SMPQueueInfo where fromField = blobFieldParser smpQueueInfoP
+instance FromField SMPQueueUri where fromField = blobFieldParser smpQueueUriP
+
+instance ToField ConnectionRequest where toField = toField . serializeConnReq
+
+instance FromField ConnectionRequest where fromField = blobFieldParser connReqP
 
 fromTextField_ :: (E.Typeable a) => (Text -> Maybe a) -> Field -> Ok a
 fromTextField_ fromText = \case

src/Simplex/Messaging/Parsers.hs

@@ -7,6 +7,7 @@ import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
 import Data.ByteString.Base64
+import qualified Data.ByteString.Base64.URL as U
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isAlphaNum)
@@ -24,10 +25,24 @@ base64P :: Parser ByteString
 base64P = decode <$?> base64StringP
 
 base64StringP :: Parser ByteString
-base64StringP = do
-  str <- A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
-  pad <- A.takeWhile (== '=')
-  pure $ str <> pad
+base64StringP = paddedBase64 rawBase64P
+
+base64UriP :: Parser ByteString
+base64UriP = U.decode <$?> base64UriStringP
+
+base64UriStringP :: Parser ByteString
+base64UriStringP = paddedBase64 rawBase64UriP
+
+paddedBase64 :: Parser ByteString -> Parser ByteString
+paddedBase64 raw = (<>) <$> raw <*> pad
+  where
+    pad = A.takeWhile (== '=')
+
+rawBase64P :: Parser ByteString
+rawBase64P = A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
+
+rawBase64UriP :: Parser ByteString
+rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')
 
 tsISO8601P :: Parser UTCTime
 tsISO8601P = maybe (fail "timestamp") pure . parseISO8601 . B.unpack =<< A.takeTill wordEnd