diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs index 1e1a34eb3..5b526e692 100644 --- a/src/Simplex/FileTransfer/Server.hs +++ b/src/Simplex/FileTransfer/Server.hs @@ -197,17 +197,32 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira hSetBuffering h LineBuffering hSetNewlineMode h universalNewlineMode hPutStrLn h "XFTP server control port\n'help' for supported commands" - cpLoop h + role <- newTVarIO CPRNone + cpLoop h role where - cpLoop h = do - s <- B.hGetLine h - case strDecode $ trimCR s of + cpLoop h role = do + s <- trimCR <$> B.hGetLine h + case strDecode s of Right CPQuit -> hClose h - Right cmd -> processCP h cmd >> cpLoop h - Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h - processCP h = \case + Right cmd -> logCmd s cmd >> processCP h role cmd >> cpLoop h role + Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h role + logCmd s cmd = when shouldLog $ logWarn $ "ControlPort: " <> tshow s + where + shouldLog = case cmd of + CPAuth _ -> False + CPHelp -> False + CPQuit -> False + CPSkip -> False + _ -> True + processCP h role = \case + CPAuth auth -> atomically $ writeTVar role $! newRole cfg + where + newRole XFTPServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} + | Just auth == admin = CPRAdmin + | Just auth == user = CPRUser + | otherwise = CPRNone CPStatsRTS -> E.tryAny getRTSStats >>= either (hPrint h) (hPrint h) - CPDelete fileId fKey -> unliftIO u $ do + CPDelete fileId fKey -> withUserRole $ unliftIO u $ do fs <- asks store r <- runExceptT $ do let asSender = ExceptT . atomically $ getFile fs SFSender fileId @@ -220,6 +235,13 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit" CPQuit -> pure () CPSkip -> pure () + where + withUserRole action = readTVarIO role >>= \case + CPRAdmin -> action + CPRUser -> action + _ -> do + logError "Unauthorized control port command" + hPutStrLn h "AUTH" data ServerFile = ServerFile { filePath :: FilePath, diff --git a/src/Simplex/FileTransfer/Server/Control.hs b/src/Simplex/FileTransfer/Server/Control.hs index 0bd2f742c..d8d0c425f 100644 --- a/src/Simplex/FileTransfer/Server/Control.hs +++ b/src/Simplex/FileTransfer/Server/Control.hs @@ -7,9 +7,13 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString (ByteString) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (BasicAuth) + +data CPClientRole = CPRNone | CPRUser | CPRAdmin data ControlProtocol - = CPStatsRTS + = CPAuth BasicAuth + | CPStatsRTS | CPDelete ByteString C.APublicAuthKey | CPHelp | CPQuit @@ -17,6 +21,7 @@ data ControlProtocol instance StrEncoding ControlProtocol where strEncode = \case + CPAuth tok -> "auth " <> strEncode tok CPStatsRTS -> "stats-rts" CPDelete fId fKey -> strEncode (Str "delete", fId, fKey) CPHelp -> "help" @@ -24,6 +29,7 @@ instance StrEncoding ControlProtocol where CPSkip -> "" strP = A.takeTill (== ' ') >>= \case + "auth" -> CPAuth <$> _strP "stats-rts" -> pure CPStatsRTS "delete" -> CPDelete <$> _strP <*> _strP "help" -> pure CPHelp diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs index e699119b9..d71864a43 100644 --- a/src/Simplex/FileTransfer/Server/Env.hs +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -46,6 +46,9 @@ data XFTPServerConfig = XFTPServerConfig allowNewFiles :: Bool, -- | simple password that the clients need to pass in handshake to be able to create new files newFileBasicAuth :: Maybe BasicAuth, + -- | control port passwords, + controlPortUserAuth :: Maybe BasicAuth, + controlPortAdminAuth :: Maybe BasicAuth, -- | time after which the files can be removed and check interval, seconds fileExpiration :: Maybe ExpirationConfig, -- | timeout to receive file diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs index 269ada69a..91ba17ff3 100644 --- a/src/Simplex/FileTransfer/Server/Main.hs +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -97,6 +97,8 @@ xftpServerCLI cfgPath logPath = do \# with the users who you want to allow uploading files to your server.\n\ \# create_password: password to upload files (any printable ASCII characters without whitespace, '@', ':' and '/')\n\ \\n\ + \# control_port_admin_password:\n\ + \# control_port_user_password:\n\ \[TRANSPORT]\n\ \# host is only used to print server address on start\n" <> ("host: " <> host <> "\n") @@ -155,6 +157,8 @@ xftpServerCLI cfgPath logPath = do allowedChunkSizes = serverChunkSizes, allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini, newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini, + controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini, + controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini, fileExpiration = Just defaultFileExpiration diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 01977ea56..181af8fac 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -284,18 +284,33 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do hSetBuffering h LineBuffering hSetNewlineMode h universalNewlineMode hPutStrLn h "SMP server control port\n'help' for supported commands" - cpLoop h + role <- newTVarIO CPRNone + cpLoop h role where - cpLoop h = do - s <- B.hGetLine h - case strDecode $ trimCR s of + cpLoop h role = do + s <- trimCR <$> B.hGetLine h + case strDecode s of Right CPQuit -> hClose h - Right cmd -> processCP h cmd >> cpLoop h - Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h - processCP h = \case - CPSuspend -> hPutStrLn h "suspend not implemented" - CPResume -> hPutStrLn h "resume not implemented" - CPClients -> do + Right cmd -> logCmd s cmd >> processCP h role cmd >> cpLoop h role + Left err -> hPutStrLn h ("error: " <> err) >> cpLoop h role + logCmd s cmd = when shouldLog $ logWarn $ "ControlPort: " <> tshow s + where + shouldLog = case cmd of + CPAuth _ -> False + CPHelp -> False + CPQuit -> False + CPSkip -> False + _ -> True + processCP h role = \case + CPAuth auth -> atomically $ writeTVar role $! newRole cfg + where + newRole ServerConfig {controlPortUserAuth = user, controlPortAdminAuth = admin} + | Just auth == admin = CPRAdmin + | Just auth == user = CPRUser + | otherwise = CPRNone + CPSuspend -> withAdminRole $ hPutStrLn h "suspend not implemented" + CPResume -> withAdminRole $ hPutStrLn h "resume not implemented" + CPClients -> withAdminRole $ do active <- unliftIO u (asks clients) >>= readTVarIO hPutStrLn h $ "clientId,sessionId,connected,createdAt,rcvActiveAt,sndActiveAt,age,subscriptions" forM_ (IM.toList active) $ \(cid, Client {sessionId, connected, createdAt, rcvActiveAt, sndActiveAt, subscriptions}) -> do @@ -306,7 +321,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do let age = systemSeconds now - systemSeconds createdAt subscriptions' <- bshow . M.size <$> readTVarIO subscriptions hPutStrLn h . B.unpack $ B.intercalate "," [bshow cid, encode sessionId, connected', strEncode createdAt, rcvActiveAt', sndActiveAt', bshow age, subscriptions'] - CPStats -> do + CPStats -> withAdminRole $ do ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedNew, qDeletedSecured, msgSent, msgRecv, msgSentNtf, msgRecvNtf, qCount, msgCount} <- unliftIO u $ asks serverStats putStat "fromTime" fromTime putStat "qCreated" qCreated @@ -324,7 +339,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do putStat :: Show a => String -> TVar a -> IO () putStat label var = readTVarIO var >>= \v -> hPutStrLn h $ label <> ": " <> show v CPStatsRTS -> getRTSStats >>= hPrint h - CPThreads -> do + CPThreads -> withAdminRole $ do #if MIN_VERSION_base(4,18,0) threads <- liftIO listThreads hPutStrLn h $ "Threads: " <> show (length threads) @@ -335,7 +350,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do #else hPutStrLn h "Not available on GHC 8.10" #endif - CPSockets -> do + CPSockets -> withAdminRole $ do (accepted', closed', active') <- unliftIO u $ asks sockets (accepted, closed, active) <- atomically $ (,,) <$> readTVar accepted' <*> readTVar closed' <*> readTVar active' hPutStrLn h "Sockets: " @@ -343,7 +358,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do hPutStrLn h $ "closed: " <> show closed hPutStrLn h $ "active: " <> show (IM.size active) hPutStrLn h $ "leaked: " <> show (accepted - closed - IM.size active) - CPSocketThreads -> do + CPSocketThreads -> withAdminRole $ do #if MIN_VERSION_base(4,18,0) (_, _, active') <- unliftIO u $ asks sockets active <- readTVarIO active' @@ -357,7 +372,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do #else hPutStrLn h "Not available on GHC 8.10" #endif - CPDelete queueId' -> unliftIO u $ do + CPDelete queueId' -> withUserRole $ unliftIO u $ do st <- asks queueStore ms <- asks msgStore queueId <- atomically (getQueue st SSender queueId') >>= \case @@ -372,13 +387,25 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg} = do withLog (`logDeleteQueue` queueId) updateDeletedStats q liftIO . hPutStrLn h $ "ok, " <> show numDeleted <> " messages deleted" - CPSave -> withLock (savingLock srv) "control" $ do + CPSave -> withAdminRole $ withLock (savingLock srv) "control" $ do hPutStrLn h "saving server state..." unliftIO u $ saveServer True hPutStrLn h "server state saved!" CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, delete, save, help, quit" CPQuit -> pure () CPSkip -> pure () + where + withUserRole action = readTVarIO role >>= \case + CPRAdmin -> action + CPRUser -> action + _ -> do + logError "Unauthorized control port command" + hPutStrLn h "AUTH" + withAdminRole action = readTVarIO role >>= \case + CPRAdmin -> action + _ -> do + logError "Unauthorized control port command" + hPutStrLn h "AUTH" runClientTransport :: Transport c => THandleSMP c -> M () runClientTransport th@THandle {params = THandleParams {thVersion, sessionId}} = do diff --git a/src/Simplex/Messaging/Server/Control.hs b/src/Simplex/Messaging/Server/Control.hs index 077c8a340..9463fa777 100644 --- a/src/Simplex/Messaging/Server/Control.hs +++ b/src/Simplex/Messaging/Server/Control.hs @@ -6,9 +6,13 @@ module Simplex.Messaging.Server.Control where import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString (ByteString) import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (BasicAuth) + +data CPClientRole = CPRNone | CPRUser | CPRAdmin data ControlProtocol - = CPSuspend + = CPAuth BasicAuth + | CPSuspend | CPResume | CPClients | CPStats @@ -24,6 +28,7 @@ data ControlProtocol instance StrEncoding ControlProtocol where strEncode = \case + CPAuth bs -> "auth " <> strEncode bs CPSuspend -> "suspend" CPResume -> "resume" CPClients -> "clients" @@ -39,6 +44,7 @@ instance StrEncoding ControlProtocol where CPSkip -> "" strP = A.takeTill (== ' ') >>= \case + "auth" -> CPAuth <$> (A.space *> strP) "suspend" -> pure CPSuspend "resume" -> pure CPResume "clients" -> pure CPClients diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 7b9fef0b3..9d783fba9 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -53,6 +53,9 @@ data ServerConfig = ServerConfig allowNewQueues :: Bool, -- | simple password that the clients need to pass in handshake to be able to create new queues newQueueBasicAuth :: Maybe BasicAuth, + -- | control port passwords, + controlPortUserAuth :: Maybe BasicAuth, + controlPortAdminAuth :: 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), diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index cfe08c621..a7844cc95 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -128,6 +128,8 @@ smpServerCLI cfgPath logPath = _ -> "# create_password: password to create new queues (any printable ASCII characters without whitespace, '@', ':' and '/')" ) <> "\n\n\ + \# control_port_admin_password:\n\ + \# control_port_user_password:\n\ \[TRANSPORT]\n\ \# host is only used to print server address on start\n" <> ("host: " <> host <> "\n") @@ -189,6 +191,8 @@ smpServerCLI cfgPath logPath = -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini, + controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini, + controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini, messageExpiration = Just defaultMessageExpiration diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 871652f53..87163483f 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -95,6 +95,8 @@ cfg = storeMsgsFile = Nothing, allowNewQueues = True, newQueueBasicAuth = Nothing, + controlPortUserAuth = Nothing, + controlPortAdminAuth = Nothing, messageExpiration = Just defaultMessageExpiration, inactiveClientExpiration = Just defaultInactiveClientExpiration, logStatsInterval = Nothing, diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index e411ea42b..113f314a7 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -105,6 +105,8 @@ testXFTPServerConfig = allowedChunkSizes = [kb 64, kb 128, kb 256, mb 1, mb 4], allowNewFiles = True, newFileBasicAuth = Nothing, + controlPortAdminAuth = Nothing, + controlPortUserAuth = Nothing, fileExpiration = Just defaultFileExpiration, fileTimeout = 10000000, inactiveClientExpiration = Just defaultInactiveClientExpiration,