mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-13 02:26:01 +00:00
84 lines
3.1 KiB
Haskell
84 lines
3.1 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
-- | Name resolver mock
|
|
module NamesResolverServer
|
|
( withResolverServer,
|
|
withResolverServerDelayed,
|
|
resolveResp,
|
|
testNamesConfig,
|
|
memCfg,
|
|
memProxyCfg,
|
|
memCfg2,
|
|
withNames,
|
|
)
|
|
where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Monad (when)
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import Data.IORef (IORef, atomicModifyIORef', newIORef)
|
|
import Data.Text (Text)
|
|
import Network.HTTP.Types (Status, hContentType, notFound404, ok200)
|
|
import Network.Wai (Application, pathInfo, responseLBS)
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import SMPClient (AServerConfig (..), cfgMS, proxyCfgMS, testStoreLogFile2, testStoreMsgsFile2, updateCfg)
|
|
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
|
|
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
|
|
import Simplex.Messaging.Server.Names (NamesConfig (..))
|
|
|
|
-- | Run an action with a local HTTP resolver on a free port.
|
|
withResolverServer :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a
|
|
withResolverServer = withResolverServerDelayed 0
|
|
|
|
withResolverServerDelayed :: Int -> ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a
|
|
withResolverServerDelayed delayMs handler action = do
|
|
reqs <- newIORef []
|
|
Warp.withApplication (pure (app reqs)) $ \port -> action port reqs
|
|
where
|
|
app :: IORef [[Text]] -> Application
|
|
app reqs req send = do
|
|
atomicModifyIORef' reqs $ \rs -> (rs <> [pathInfo req], ())
|
|
when (delayMs > 0) $ threadDelay (delayMs * 1000)
|
|
let (st, body) = handler (pathInfo req)
|
|
send $ responseLBS st [(hContentType, "application/json")] body
|
|
|
|
-- | The resolver API is versioned on its own: v2 answers with NameRegistration
|
|
-- JSON, which is the only shape the server asks for.
|
|
resolveResp :: Status -> LB.ByteString -> [Text] -> (Status, LB.ByteString)
|
|
resolveResp st body = \case
|
|
["health"] -> (ok200, "{}")
|
|
("v2" : "resolve" : _) -> (st, body)
|
|
_ -> (notFound404, "{}")
|
|
|
|
testNamesConfig :: Int -> NamesConfig
|
|
testNamesConfig port =
|
|
NamesConfig
|
|
{ resolverEndpoint = "http://127.0.0.1:" <> show port,
|
|
resolverAuth = Nothing,
|
|
resolverTimeoutMs = 1000,
|
|
resolverMaxResponseBytes = 65536
|
|
}
|
|
|
|
memCfg :: AServerConfig
|
|
memCfg = cfgMS (ASType SQSMemory SMSMemory)
|
|
|
|
memProxyCfg :: AServerConfig
|
|
memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory)
|
|
|
|
memCfg2 :: AServerConfig
|
|
memCfg2 = case memCfg of
|
|
ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)}
|
|
where
|
|
newStoreCfg :: ServerStoreCfg s -> ServerStoreCfg s
|
|
newStoreCfg = \case
|
|
SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2})
|
|
other -> other
|
|
|
|
withNames :: Int -> AServerConfig -> AServerConfig
|
|
withNames port c = updateCfg c $ \cfg_ -> cfg_ {namesConfig = Just (testNamesConfig port)}
|