server: SMP basic auth (#561)

* server: SMP basic auth

* update ini default

* rfc, types

* tests

* update INI file

* typo

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>

* refactor

* update INI options, log new queue creation mode on start (on/off/requires auth)

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>

src/Simplex/Messaging/Agent.hs

@@ -120,7 +120,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg
 import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..))
 import Simplex.Messaging.Notifications.Types
 import Simplex.Messaging.Parsers (parse)
-import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, sameSrvAddr)
+import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, sameSrvAddr, sameSrvAddr')
 import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Util
@@ -248,7 +248,7 @@ getConnectionServers :: AgentErrorMonad m => AgentClient -> ConnId -> m Connecti
 getConnectionServers c = withAgentEnv c . getConnectionServers' c
 
 -- | Change servers to be used for creating new queues
-setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServer -> m ()
+setSMPServers :: AgentErrorMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m ()
 setSMPServers c = withAgentEnv c . setSMPServers' c
 
 setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m ()
@@ -430,7 +430,7 @@ newConn :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> SConnectionM
 newConn c connId asyncMode enableNtfs cMode clientData =
   getSMPServer c >>= newConnSrv c connId asyncMode enableNtfs cMode clientData
 
-newConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServer -> m (ConnId, ConnectionRequestUri c)
+newConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> SConnectionMode c -> Maybe CRClientData -> SMPServerWithAuth -> m (ConnId, ConnectionRequestUri c)
 newConnSrv c connId asyncMode enableNtfs cMode clientData srv = do
   AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
   (q, qUri) <- newRcvQueue c "" srv smpClientVRange
@@ -464,7 +464,7 @@ joinConn c connId asyncMode enableNtfs cReq cInfo = do
     _ -> getSMPServer c
   joinConnSrv c connId asyncMode enableNtfs cReq cInfo srv
 
-joinConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> SMPServer -> m ConnId
+joinConnSrv :: AgentMonad m => AgentClient -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> ConnInfo -> SMPServerWithAuth -> m ConnId
 joinConnSrv c connId asyncMode enableNtfs (CRInvitationUri ConnReqUriData {crAgentVRange, crSmpQueues = (qUri :| _)} e2eRcvParamsUri) cInfo srv = do
   AgentConfig {smpClientVRange, smpAgentVRange, e2eEncryptVRange} <- asks config
   case ( qUri `compatibleVersion` smpClientVRange,
@@ -516,7 +516,7 @@ joinConnSrv c connId False enableNtfs (CRContactUri ConnReqUriData {crAgentVRang
 joinConnSrv _c _connId True _enableNtfs (CRContactUri _) _cInfo _srv = do
   throwError $ CMD PROHIBITED
 
-createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServer -> m SMPQueueInfo
+createReplyQueue :: AgentMonad m => AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> m SMPQueueInfo
 createReplyQueue c ConnData {connId, enableNtfs} SndQueue {smpClientVersion} srv = do
   (rq, qUri) <- newRcvQueue c connId srv $ versionToRange smpClientVersion
   let qInfo = toVersionT qUri smpClientVersion
@@ -880,15 +880,15 @@ runCommandProcessing c@AgentClient {subQ} server_ = do
         internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command)
         cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId)
         notify cmd = atomically $ writeTBQueue subQ (corrId, connId, cmd)
-        withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServer -> m ()) -> m ()
+        withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServerWithAuth -> m ()) -> m ()
         withNextSrv usedSrvs initUsed action = do
           used <- readTVarIO usedSrvs
-          srv <- getNextSMPServer c used
+          srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c used
           atomically $ do
             srvs <- readTVar $ smpServers c
             let used' = if length used + 1 >= L.length srvs then initUsed else srv : used
             writeTVar usedSrvs used'
-          action srv
+          action srvAuth
 -- ^ ^ ^ async command processing /
 
 enqueueMessages :: AgentMonad m => AgentClient -> ConnData -> NonEmpty SndQueue -> MsgFlags -> AMessage -> m AgentMsgId
@@ -1124,8 +1124,8 @@ switchConnection' c connId = withConnLock c connId "switchConnection" $ do
     DuplexConnection cData rqs@(rq@RcvQueue {server, dbQueueId, sndId} :| rqs_) sqs -> do
       clientVRange <- asks $ smpClientVRange . config
       -- try to get the server that is different from all queues, or at least from the primary rcv queue
-      srv <- getNextSMPServer c $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
-      srv' <- if srv == server then getNextSMPServer c [server] else pure srv
+      srvAuth@(ProtoServerWithAuth srv _) <- getNextSMPServer c $ map qServer (L.toList rqs) <> map qServer (L.toList sqs)
+      srv' <- if srv == server then getNextSMPServer c [server] else pure srvAuth
       (q, qUri) <- newRcvQueue c connId srv' clientVRange
       let rq' = (q :: RcvQueue) {primary = True, dbReplaceQueueId = Just dbQueueId}
       void . withStore c $ \db -> addConnRcvQueue db connId rq'
@@ -1191,7 +1191,7 @@ connectionStats = \case
   NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []}
 
 -- | Change servers to be used for creating new queues, in Reader monad
-setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServer -> m ()
+setSMPServers' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m ()
 setSMPServers' c = atomically . writeTVar (smpServers c)
 
 registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus
@@ -1436,20 +1436,20 @@ debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs} = do
   where
     getLocks ls = atomically $ M.mapKeys (B.unpack . strEncode) . M.mapMaybe id <$> (mapM tryReadTMVar =<< readTVar ls)
 
-getSMPServer :: AgentMonad m => AgentClient -> m SMPServer
+getSMPServer :: AgentMonad m => AgentClient -> m SMPServerWithAuth
 getSMPServer c = readTVarIO (smpServers c) >>= pickServer
 
-pickServer :: AgentMonad m => NonEmpty SMPServer -> m SMPServer
+pickServer :: AgentMonad m => NonEmpty SMPServerWithAuth -> m SMPServerWithAuth
 pickServer = \case
   srv :| [] -> pure srv
   servers -> do
     gen <- asks randomServer
     atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1))
 
-getNextSMPServer :: AgentMonad m => AgentClient -> [SMPServer] -> m SMPServer
+getNextSMPServer :: AgentMonad m => AgentClient -> [SMPServer] -> m SMPServerWithAuth
 getNextSMPServer c usedSrvs = do
   srvs <- readTVarIO $ smpServers c
-  case L.nonEmpty $ deleteFirstsBy sameSrvAddr (L.toList srvs) usedSrvs of
+  case L.nonEmpty $ deleteFirstsBy sameSrvAddr' (L.toList srvs) (map noAuthSrv usedSrvs) of
     Just srvs' -> pickServer srvs'
     _ -> pickServer srvs
 
@@ -1766,7 +1766,7 @@ connectReplyQueues c cData@ConnData {connId} ownConnInfo (qInfo :| _) = do
       dbQueueId <- withStore c $ \db -> upgradeRcvConnToDuplex db connId sq
       enqueueConfirmation c cData sq {dbQueueId} ownConnInfo Nothing
 
-confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServer -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
+confirmQueue :: forall m. AgentMonad m => Compatible Version -> AgentClient -> ConnData -> SndQueue -> SMPServerWithAuth -> ConnInfo -> Maybe (CR.E2ERatchetParams 'C.X448) -> m ()
 confirmQueue (Compatible agentVersion) c cData@ConnData {connId} sq srv connInfo e2eEncryption = do
   aMessage <- mkAgentMessage agentVersion
   msg <- mkConfirmation aMessage

src/Simplex/Messaging/Agent/Client.hs

@@ -164,7 +164,7 @@ data AgentClient = AgentClient
     rcvQ :: TBQueue (ATransmission 'Client),
     subQ :: TBQueue (ATransmission 'Agent),
     msgQ :: TBQueue (ServerTransmission BrokerMsg),
-    smpServers :: TVar (NonEmpty SMPServer),
+    smpServers :: TVar (NonEmpty SMPServerWithAuth),
     smpClients :: TMap SMPServer SMPClientVar,
     ntfServers :: TVar [NtfServer],
     ntfClients :: TMap NtfServer NtfClientVar,
@@ -515,7 +515,7 @@ protocolClientError protocolError_ = \case
   e@PCESignatureError {} -> INTERNAL $ show e
   e@PCEIOError {} -> INTERNAL $ show e
 
-newRcvQueue :: AgentMonad m => AgentClient -> ConnId -> SMPServer -> VersionRange -> m (RcvQueue, SMPQueueUri)
+newRcvQueue :: AgentMonad m => AgentClient -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri)
 newRcvQueue c connId srv vRange =
   asks (cmdSignAlg . config) >>= \case
     C.SignAlg a -> newRcvQueue_ a c connId srv vRange
@@ -525,16 +525,16 @@ newRcvQueue_ ::
   C.SAlgorithm a ->
   AgentClient ->
   ConnId ->
-  SMPServer ->
+  SMPServerWithAuth ->
   VersionRange ->
   m (RcvQueue, SMPQueueUri)
-newRcvQueue_ a c connId srv vRange = do
+newRcvQueue_ a c connId (ProtoServerWithAuth srv auth) vRange = do
   (recipientKey, rcvPrivateKey) <- liftIO $ C.generateSignatureKeyPair a
   (dhKey, privDhKey) <- liftIO C.generateKeyPair'
   (e2eDhKey, e2ePrivKey) <- liftIO C.generateKeyPair'
   logServer "-->" c srv "" "NEW"
   QIK {rcvId, sndId, rcvPublicDhKey} <-
-    withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey
+    withClient c srv $ \smp -> createSMPQueue smp rcvPrivateKey recipientKey dhKey auth
   logServer "<--" c srv "" $ B.unwords ["IDS", logSecret rcvId, logSecret sndId]
   let rq =
         RcvQueue

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

@@ -59,7 +59,7 @@ import UnliftIO.STM
 type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m)
 
 data InitialAgentServers = InitialAgentServers
-  { smp :: NonEmpty SMPServer,
+  { smp :: NonEmpty SMPServerWithAuth,
     ntf :: [NtfServer],
     netCfg :: NetworkConfig
   }

src/Simplex/Messaging/Agent/Protocol.hs

@@ -61,9 +61,12 @@ module Simplex.Messaging.Agent.Protocol
     SndQAddr,
     SMPServer,
     pattern SMPServer,
+    pattern ProtoServerWithAuth,
+    SMPServerWithAuth,
     SrvLoc (..),
     SMPQueue (..),
     sameQAddress,
+    noAuthSrv,
     SMPQueueUri (..),
     SMPQueueInfo (..),
     SMPQueueAddress (..),
@@ -164,12 +167,15 @@ import Simplex.Messaging.Protocol
     NMsgMeta,
     ProtocolServer (..),
     SMPServer,
+    SMPServerWithAuth,
     SndPublicVerifyKey,
     SrvLoc (..),
     legacyEncodeServer,
     legacyServerP,
     legacyStrEncodeServer,
+    noAuthSrv,
     sameSrvAddr,
+    pattern ProtoServerWithAuth,
     pattern SMPServer,
   )
 import qualified Simplex.Messaging.Protocol as SMP

src/Simplex/Messaging/Client.hs

@@ -361,9 +361,10 @@ createSMPQueue ::
   RcvPrivateSignKey ->
   RcvPublicVerifyKey ->
   RcvPublicDhKey ->
+  Maybe BasicAuth ->
   ExceptT ProtocolClientError IO QueueIdsKeys
-createSMPQueue c rpKey rKey dhKey =
-  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey) >>= \case
+createSMPQueue c rpKey rKey dhKey auth =
+  sendSMPCommand c (Just rpKey) "" (NEW rKey dhKey auth) >>= \case
     IDS qik -> pure qik
     r -> throwE . PCEUnexpectedResponse $ bshow r
 

src/Simplex/Messaging/Protocol.hs

@@ -70,8 +70,11 @@ module Simplex.Messaging.Protocol
     ProtoServer,
     SMPServer,
     pattern SMPServer,
+    SMPServerWithAuth,
     NtfServer,
     pattern NtfServer,
+    ProtoServerWithAuth (..),
+    BasicAuth,
     SrvLoc (..),
     CorrId (..),
     QueueId,
@@ -116,6 +119,8 @@ module Simplex.Messaging.Protocol
     legacyServerP,
     legacyStrEncodeServer,
     sameSrvAddr,
+    sameSrvAddr',
+    noAuthSrv,
 
     -- * TCP transport functions
     tPut,
@@ -135,6 +140,7 @@ import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Char (isPrint, isSpace)
 import Data.Kind
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as L
@@ -250,7 +256,7 @@ type EntityId = ByteString
 -- | Parameterized type for SMP protocol commands from all clients.
 data Command (p :: Party) where
   -- SMP recipient commands
-  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Command Recipient
+  NEW :: RcvPublicVerifyKey -> RcvPublicDhKey -> Maybe BasicAuth -> Command Recipient
   SUB :: Command Recipient
   KEY :: SndPublicVerifyKey -> Command Recipient
   NKEY :: NtfPublicVerifyKey -> RcvNtfPublicDhKey -> Command Recipient
@@ -566,6 +572,8 @@ pattern SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash
 
 {-# COMPLETE SMPServer #-}
 
+type SMPServerWithAuth = ProtoServerWithAuth 'PSMP
+
 type NtfServer = ProtocolServer 'PNTF
 
 pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
@@ -573,6 +581,10 @@ pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash
 
 {-# COMPLETE NtfServer #-}
 
+sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
+sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
+{-# INLINE sameSrvAddr' #-}
+
 sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool
 sameSrvAddr ProtocolServer {host, port} ProtocolServer {host = h', port = p'} = host == h' && port == p'
 {-# INLINE sameSrvAddr #-}
@@ -667,20 +679,54 @@ instance ProtocolTypeI p => Encoding (ProtocolServer p) where
 
 instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
   strEncode ProtocolServer {scheme, host, port, keyHash} =
-    strEncodeServer scheme (strEncode host) port keyHash
-  strP = do
-    scheme <- strP <* "://"
-    keyHash <- strP <* A.char '@'
-    TransportHosts host <- strP
-    port <- portP <|> pure ""
-    pure ProtocolServer {scheme, host, port, keyHash}
-    where
-      portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
+    strEncodeServer scheme (strEncode host) port keyHash Nothing
+  strP =
+    serverStrP >>= \case
+      (srv, Nothing) -> pure srv
+      _ -> fail "ProtocolServer with basic auth not allowed"
 
 instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
   toJSON = strToJSON
   toEncoding = strToJEncoding
 
+newtype BasicAuth = BasicAuth ByteString
+  deriving (Eq, Show)
+
+instance IsString BasicAuth where fromString = BasicAuth . B.pack
+
+instance Encoding BasicAuth where
+  smpEncode (BasicAuth s) = smpEncode s
+  smpP = basicAuth <$?> smpP
+
+instance StrEncoding BasicAuth where
+  strEncode (BasicAuth s) = s
+  strP = basicAuth <$?> A.takeWhile1 (/= '@')
+
+basicAuth :: ByteString -> Either String BasicAuth
+basicAuth s
+  | B.all valid s = Right $ BasicAuth s
+  | otherwise = Left "invalid character in BasicAuth"
+  where
+    valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/'
+
+data ProtoServerWithAuth p = ProtoServerWithAuth (ProtocolServer p) (Maybe BasicAuth)
+  deriving (Show)
+
+instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
+  fromString = parseString strDecode
+
+instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
+  strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) =
+    strEncodeServer scheme (strEncode host) port keyHash auth_
+  strP = uncurry ProtoServerWithAuth <$> serverStrP
+
+instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
+noAuthSrv srv = ProtoServerWithAuth srv Nothing
+
 legacyEncodeServer :: ProtocolServer p -> ByteString
 legacyEncodeServer ProtocolServer {host, port, keyHash} =
   smpEncode (L.head host, port, keyHash)
@@ -692,14 +738,25 @@ legacyServerP = do
 
 legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
 legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
-  strEncodeServer scheme (strEncode $ L.head host) port keyHash
+  strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing
 
-strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> ByteString
-strEncodeServer scheme host port keyHash =
-  strEncode scheme <> "://" <> strEncode keyHash <> "@" <> host <> portStr
+strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe BasicAuth -> ByteString
+strEncodeServer scheme host port keyHash auth_ =
+  strEncode scheme <> "://" <> strEncode keyHash <> maybe "" ((":" <>) . strEncode) auth_ <> "@" <> host <> portStr
   where
     portStr = B.pack $ if null port then "" else ':' : port
 
+serverStrP :: ProtocolTypeI p => Parser (ProtocolServer p, Maybe BasicAuth)
+serverStrP = do
+  scheme <- strP <* "://"
+  keyHash <- strP
+  auth_ <- optional $ A.char ':' *> strP
+  TransportHosts host <- A.char '@' *> strP
+  port <- portP <|> pure ""
+  pure (ProtocolServer {scheme, host, port, keyHash}, auth_)
+  where
+    portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))
+
 data SrvLoc = SrvLoc HostName ServiceName
   deriving (Eq, Ord, Show)
 
@@ -870,7 +927,13 @@ class ProtocolMsgTag (Tag msg) => ProtocolEncoding msg where
 instance PartyI p => ProtocolEncoding (Command p) where
   type Tag (Command p) = CommandTag p
   encodeProtocol v = \case
-    NEW rKey dhKey -> e (NEW_, ' ', rKey, dhKey)
+    NEW rKey dhKey auth_ -> case auth_ of
+      Just auth
+        | v >= 5 -> new <> e ('A', auth)
+        | otherwise -> new
+      _ -> new
+      where
+        new = e (NEW_, ' ', rKey, dhKey)
     SUB -> e SUB_
     KEY k -> e (KEY_, ' ', k)
     NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
@@ -918,7 +981,11 @@ instance ProtocolEncoding Cmd where
   protocolP v = \case
     CT SRecipient tag ->
       Cmd SRecipient <$> case tag of
-        NEW_ -> NEW <$> _smpP <*> smpP
+        NEW_
+          | v >= 5 -> new <*> optional (A.char 'A' *> smpP)
+          | otherwise -> new <*> pure Nothing
+          where
+            new = NEW <$> _smpP <*> smpP
         SUB_ -> pure SUB
         KEY_ -> KEY <$> _smpP
         NKEY_ -> NKEY <$> _smpP <*> smpP

src/Simplex/Messaging/Server.hs

@@ -280,7 +280,7 @@ data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed
 verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult
 verifyTransmission sig_ signed queueId cmd = do
   case cmd of
-    Cmd SRecipient (NEW k _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
+    Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k
     Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey
     Cmd SSender SEND {} -> verifyCmd SSender $ verifyMaybe . senderKey
     Cmd SSender PING -> pure $ VRVerified Nothing
@@ -323,7 +323,7 @@ dummyKeyEd448 :: C.PublicKey 'C.Ed448
 dummyKeyEd448 = "MEMwBQYDK2VxAzoA6ibQc9XpkSLtwrf7PLvp81qW/etiumckVFImCMRdftcG/XopbOSaq9qyLhrgJWKOLyNrQPNVvpMA"
 
 client :: forall m. (MonadUnliftIO m, MonadReader Env m) => Client -> Server -> m ()
-client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
+client clnt@Client {thVersion, subscriptions, ntfSubscriptions, rcvQ, sndQ} Server {subscribedQ, ntfSubscribedQ, notifiers} =
   forever $
     atomically (readTBQueue rcvQ)
       >>= mapM processCommand
@@ -340,11 +340,15 @@ client clnt@Client {thVersion, sessionId, subscriptions, ntfSubscriptions, rcvQ,
         Cmd SNotifier NSUB -> subscribeNotifications
         Cmd SRecipient command ->
           case command of
-            NEW rKey dhKey ->
+            NEW rKey dhKey auth ->
               ifM
-                (asks $ allowNewQueues . config)
+                allowNew
                 (createQueue st rKey dhKey)
                 (pure (corrId, queueId, ERR AUTH))
+              where
+                allowNew = do
+                  ServerConfig {allowNewQueues, newQueueBasicAuth} <- asks config
+                  pure $ allowNewQueues && maybe True ((== auth) . Just) newQueueBasicAuth
             SUB -> withQueue (`subscribeQueue` queueId)
             GET -> withQueue getMessage
             ACK msgId -> withQueue (`acknowledgeMsg` msgId)

src/Simplex/Messaging/Server/CLI.hs

@@ -15,6 +15,7 @@ import qualified Data.ByteString.Char8 as B
 import Data.Either (fromRight)
 import Data.Ini (Ini, lookupValue, readIniFile)
 import Data.Maybe (fromMaybe)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket (HostName, ServiceName)
@@ -236,12 +237,12 @@ mkIniOptions ini =
       enableWebsockets = (== "on") $ strictIni "TRANSPORT" "websockets" ini
     }
 
-strictIni :: String -> String -> Ini -> T.Text
+strictIni :: Text -> Text -> Ini -> Text
 strictIni section key ini =
-  fromRight (error ("no key " <> key <> " in section " <> section)) $
-    lookupValue (T.pack section) (T.pack key) ini
+  fromRight (error . T.unpack $ "no key " <> key <> " in section " <> section) $
+    lookupValue section key ini
 
-readStrictIni :: Read a => String -> String -> Ini -> a
+readStrictIni :: Read a => Text -> Text -> Ini -> a
 readStrictIni section key = read . T.unpack . strictIni section key
 
 runServer :: ServerCLIConfig cfg -> (cfg -> IO ()) -> Ini -> IO ()

src/Simplex/Messaging/Server/Env/STM.hs

@@ -46,6 +46,8 @@ data ServerConfig = ServerConfig
     storeMsgsFile :: Maybe FilePath,
     -- | set to False to prohibit creating new queues
     allowNewQueues :: Bool,
+    -- | simple password that the clients need to pass in handshake to be able to create new queues
+    newQueueBasicAuth :: Maybe BasicAuth,
     -- | time after which the messages can be removed from the queues and check interval, seconds
     messageExpiration :: Maybe ExpirationConfig,
     -- | time after which the socket with inactive client can be disconnected (without any messages or commands, incl. PING),

src/Simplex/Messaging/Transport.hs

@@ -96,7 +96,7 @@ smpBlockSize :: Int
 smpBlockSize = 16384
 
 supportedSMPServerVRange :: VersionRange
-supportedSMPServerVRange = mkVersionRange 1 4
+supportedSMPServerVRange = mkVersionRange 1 5
 
 simplexMQVersion :: String
 simplexMQVersion = "3.4.0"