From a9e8d02593f37fa8c5ba7944cb7bee1b1d1cc89f Mon Sep 17 00:00:00 2001
From: Evgeny <evgeny@poberezkin.com>
Date: Thu, 5 Sep 2024 13:48:09 +0100
Subject: [PATCH] server: bind control port server only to 127.0.0.1 for better
 security (in case of firewall misconfuguration) (#1280)

---
 src/Simplex/FileTransfer/Server.hs        |  4 ++--
 src/Simplex/Messaging/Server.hs           |  2 +-
 src/Simplex/Messaging/Transport/Server.hs | 16 ++++++++--------
 src/Simplex/RemoteControl/Discovery.hs    |  2 +-
 4 files changed, 12 insertions(+), 12 deletions(-)

diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs
index a5a0d5d56..a5bdd7877 100644
--- a/src/Simplex/FileTransfer/Server.hs
+++ b/src/Simplex/FileTransfer/Server.hs
@@ -65,7 +65,7 @@ import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
 import Simplex.Messaging.Transport.HTTP2.Server
-import Simplex.Messaging.Transport.Server (runTCPServer, tlsServerCredentials)
+import Simplex.Messaging.Transport.Server (runLocalTCPServer, tlsServerCredentials)
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
 import System.Exit (exitFailure)
@@ -249,7 +249,7 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       u <- askUnliftIO
       liftIO $ do
         labelMyThread "control port server"
-        runTCPServer cpStarted port $ runCPClient u
+        runLocalTCPServer cpStarted port $ runCPClient u
       where
         runCPClient :: UnliftIO (ReaderT XFTPEnv IO) -> Socket -> IO ()
         runCPClient u sock = do
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 0570a18ff..cffd1d6df 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -424,7 +424,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do
       u <- askUnliftIO
       liftIO $ do
         labelMyThread "control port server"
-        runTCPServer cpStarted port $ runCPClient u srv
+        runLocalTCPServer cpStarted port $ runCPClient u srv
       where
         runCPClient :: UnliftIO (ReaderT Env IO) -> Server -> Socket -> IO ()
         runCPClient u srv sock = do
diff --git a/src/Simplex/Messaging/Transport/Server.hs b/src/Simplex/Messaging/Transport/Server.hs
index 0b4da7833..28d4d354d 100644
--- a/src/Simplex/Messaging/Transport/Server.hs
+++ b/src/Simplex/Messaging/Transport/Server.hs
@@ -12,7 +12,7 @@ module Simplex.Messaging.Transport.Server
     newSocketState,
     runTransportServer,
     runTransportServerSocket,
-    runTCPServer,
+    runLocalTCPServer,
     runTCPServerSocket,
     startTCPServer,
     loadSupportedTLSServerParams,
@@ -80,7 +80,7 @@ runTransportServer started port params cfg server = do
   runTransportServerState ss started port params cfg server
 
 runTransportServerState :: forall c . Transport c => SocketState -> TMVar Bool -> ServiceName -> T.ServerParams -> TransportServerConfig -> (c -> IO ()) -> IO ()
-runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started port) (transportName (TProxy :: TProxy c))
+runTransportServerState ss started port = runTransportServerSocketState ss started (startTCPServer started Nothing port) (transportName (TProxy :: TProxy c))
 
 -- | Run a transport server with provided connection setup and handler.
 runTransportServerSocket :: Transport a => TMVar Bool -> IO Socket -> String -> T.ServerParams -> TransportServerConfig -> (a -> IO ()) -> IO ()
@@ -107,10 +107,10 @@ tlsServerCredentials serverParams = case T.sharedCredentials $ T.serverShared se
   _ -> error "server has more than one key"
 
 -- | Run TCP server without TLS
-runTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
-runTCPServer started port server = do
+runLocalTCPServer :: TMVar Bool -> ServiceName -> (Socket -> IO ()) -> IO ()
+runLocalTCPServer started port server = do
   ss <- newSocketState
-  runTCPServerSocket ss started (startTCPServer started port) server
+  runTCPServerSocket ss started (startTCPServer started (Just "127.0.0.1") port) server
 
 -- | Wrap socket provider in a TCP server bracket.
 runTCPServerSocket :: SocketState -> TMVar Bool -> IO Socket -> (Socket -> IO ()) -> IO ()
@@ -157,12 +157,12 @@ closeServer started clients sock = do
   close sock
   void . atomically $ tryPutTMVar started False
 
-startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
-startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
+startTCPServer :: TMVar Bool -> Maybe HostName -> ServiceName -> IO Socket
+startTCPServer started host port = withSocketsDo $ resolve >>= open >>= setStarted
   where
     resolve =
       let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
-       in select <$> getAddrInfo (Just hints) Nothing (Just port)
+       in select <$> getAddrInfo (Just hints) host (Just port)
     select as = fromJust $ family AF_INET6 <|> family AF_INET
       where
         family f = find ((== f) . addrFamily) as
diff --git a/src/Simplex/RemoteControl/Discovery.hs b/src/Simplex/RemoteControl/Discovery.hs
index e70eb1c25..8ee76c651 100644
--- a/src/Simplex/RemoteControl/Discovery.hs
+++ b/src/Simplex/RemoteControl/Discovery.hs
@@ -71,7 +71,7 @@ preferAddress RCCtrlAddress {address, interface} addrs =
 startTLSServer :: Maybe Word16 -> TMVar (Maybe N.PortNumber) -> TLS.Credentials -> TLS.ServerHooks -> (Transport.TLS -> IO ()) -> IO (Async ())
 startTLSServer port_ startedOnPort credentials hooks server = async . liftIO $ do
   started <- newEmptyTMVarIO
-  bracketOnError (startTCPServer started $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket ->
+  bracketOnError (startTCPServer started Nothing $ maybe "0" show port_) (\_e -> setPort Nothing) $ \socket ->
     ifM
       (atomically $ readTMVar started)
       (runServer started socket)