server: SMP basic auth

apps/smp-server/Main.hs

@@ -1,13 +1,16 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Main where
 
 import Control.Logger.Simple
 import Data.Functor (($>))
 import Data.Ini (lookupValue)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Server (runSMPServer)
 import Simplex.Messaging.Server.CLI (ServerCLIConfig (..), protocolServerCLI, readStrictIni)
 import Simplex.Messaging.Server.Env.STM (ServerConfig (..), defaultInactiveClientExpiration, defaultMessageExpiration)
@@ -31,6 +34,11 @@ main = do
     putStrLn $ case inactiveClientExpiration of
       Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
       _ -> "not expiring inactive clients"
+    putStrLn $
+      "creating new queues "
+        <> if allowNewQueues cfg
+          then maybe "allowed" (const "requires basic auth") $ newQueueBasicAuth cfg
+          else "NOT allowed"
     runSMPServer cfg
 
 smpServerCLIConfig :: ServerCLIConfig ServerConfig
@@ -62,7 +70,17 @@ smpServerCLIConfig =
               <> "# Undelivered messages are optionally saved and restored when the server restarts,\n\
                  \# they are preserved in the .bak file until the next restart.\n"
               <> ("restore_messages: " <> (if enableStoreLog then "on" else "off") <> "\n")
-              <> ("log_stats: off\n\n")
+              <> "log_stats: off\n\n"
+              <> "[AUTH]\n"
+              <> "# Set new_queues option to off to completely prohibit creating new messaging queues.\n"
+              <> "# This can be useful when you want to decommission the server, but not all connections are switched yet.\n"
+              <> "new_queues: on\n\n"
+              <> "# Use create_password option to enable basic auth to create new messaging queues.\n"
+              <> "# The password should be used as part of server address in client configuration:\n"
+              <> "# smp://fingerprint:password@host1,host2\n"
+              <> "# The password will not be shared with the connecting contacts, you must share it only\n"
+              <> "# with the users who you want to allow creating messaging queues on your server.\n"
+              <> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')\n\n"
               <> "[TRANSPORT]\n"
               <> ("port: " <> defaultServerPort <> "\n")
               <> "websockets: off\n\n"
@@ -72,7 +90,12 @@ smpServerCLIConfig =
               <> ("# ttl: " <> show (ttl defaultInactiveClientExpiration) <> "\n")
               <> ("# check_interval: " <> show (checkInterval defaultInactiveClientExpiration) <> "\n"),
           mkServerConfig = \storeLogFile transports ini ->
-            let settingIsOn section name = if lookupValue section name ini == Right "on" then Just () else Nothing
+            let onOff section name = case lookupValue section name ini of
+                  Right "on" -> Just True
+                  Right "off" -> Just False
+                  Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s
+                  _ -> Nothing
+                settingIsOn section name = if onOff section name == Just True then Just () else Nothing
                 logStats = settingIsOn "STORE_LOG" "log_stats"
              in ServerConfig
                   { transports,
@@ -87,12 +110,16 @@ smpServerCLIConfig =
                     storeLogFile,
                     storeMsgsFile =
                       let messagesPath = combine logPath "smp-server-messages.log"
-                       in case lookupValue "STORE_LOG" "restore_messages" ini of
-                            Right "on" -> Just messagesPath
-                            Right _ -> Nothing
+                       in case onOff "STORE_LOG" "restore_messages" of
+                            Just True -> Just messagesPath
+                            Just False -> Nothing
                             -- if the setting is not set, it is enabled when store log is enabled
                             _ -> storeLogFile $> messagesPath,
-                    allowNewQueues = True,
+                    -- allow creating new queues by default
+                    allowNewQueues = fromMaybe True $ onOff "AUTH" "new_queues",
+                    newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of
+                      Right auth -> either error Just . strDecode $ encodeUtf8 auth
+                      _ -> Nothing,
                     messageExpiration = Just defaultMessageExpiration,
                     inactiveClientExpiration =
                       settingIsOn "INACTIVE_CLIENTS" "disconnect"

rfcs/2022-11-11-smp-basic-auth.md

@@ -0,0 +1,27 @@
+# SMP Basic Auth
+
+## Problem
+
+Users who host their own servers do not want unknown people to be able to create messaging queues on their servers after discovering server address in groups or after making a connection. As the number of self-hosted servers is growing it became more important than it was when we excluded it from the original design.
+
+## Solution
+
+Single access password that can be optionally included in server address that is passed to app configuration. It will not be allowed in the existing contexts (and parsing will fail), to avoid accidentally leaking it. Server address with password will look this way: `smp://fingerprint:password@hosts`
+
+## Implementation plan
+
+1. A separate type to include server and password, so it can only be used where allowed.
+
+2. Server password to create queues will be configured in TRANSPORT section of INI file, as `create_password` parameter.
+
+3. The password will only be required in server configuration/address to create queues only, it won't be required for other receiving queue operations on already existing queues.
+
+4. If new command is attempted in the session that does not allow creating queues, the server will send `ERR AUTH` response
+
+5. Passing password to the server can be done in one of the several ways, we need to decide:
+
+  - as a parameter of NEW command. Pros: a local change, that only needs checking when queue is created. Cons: protocol version change.
+  - as a separate command AUTH. Pros: allows to include additional parameters and potentially be extended beyond basic auth. Cons: more complex to manage server state, can be more difficult syntax in the future, if extended.
+  - as part of handshake (we currently ignore the unparsed part of handshake block, so it can be extended). Pros: probably, the simplest, and independent of the commands protocol – establishes create permission for the current session. Cons: the client won't know about whether it is able to create the queue until it tries (same as in case 1).
+
+  My preference is the last option. As a variant of the last option, we can add a server response/message that includes permission to create queues - it will only be sent to the clients who pass credential in handshake - that might simplify testing server connection (we currently do not do it). It might be unnecessary, as we could simply create and delete queue in case credential is passed as part of testing connection (and even sending a message to it).

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