{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

-- | Name resolver mock
module NamesResolverServer
  ( withResolverServer,
    withResolverServerDelayed,
    withResolverServerConns,
    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 = withResolverServer_ delayMs handler $ \port reqs _ -> action port reqs

-- | Also counts the TCP connections the resolver accepted.
withResolverServerConns :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IORef Int -> IO a) -> IO a
withResolverServerConns = withResolverServer_ 0

withResolverServer_ :: Int -> ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IORef Int -> IO a) -> IO a
withResolverServer_ delayMs handler action = do
  reqs <- newIORef []
  conns <- newIORef 0
  let settings = Warp.setOnOpen (\_ -> True <$ atomicModifyIORef' conns (\n -> (n + 1, ()))) Warp.defaultSettings
  Warp.withApplicationSettings settings (pure (app reqs)) $ \port -> action port reqs conns
  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,
      resolverGlobalConcurrency = 8
    }

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)}