mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-09-02 09:13:57 +00:00
89 lines
3.0 KiB
Haskell
89 lines
3.0 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE StrictData #-}
|
|
|
|
module Simplex.Messaging.Server.Names
|
|
( NamesConfig (..),
|
|
RpcAuth (..),
|
|
NamesEnv (..),
|
|
newNamesEnv,
|
|
closeNamesEnv,
|
|
pingEndpoint,
|
|
resolveName,
|
|
)
|
|
where
|
|
|
|
import qualified Control.Exception as E
|
|
import Control.Logger.Simple (logError)
|
|
import Data.Bifunctor (first)
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified Data.Text as T
|
|
import Simplex.Messaging.Protocol (NameErrorType (..), NameRecord)
|
|
import Simplex.Messaging.Server.Names.HttpResolver
|
|
( ResolverEnv,
|
|
ResolverError (..),
|
|
RpcAuth (..),
|
|
closeResolverEnv,
|
|
healthHttp,
|
|
newResolverEnv,
|
|
resolveHttp,
|
|
)
|
|
import Simplex.Messaging.SimplexName (SimplexDomain, fullDomainName)
|
|
import System.Timeout (timeout)
|
|
|
|
data NamesConfig = NamesConfig
|
|
{ resolverEndpoint :: String,
|
|
resolverAuth :: Maybe RpcAuth,
|
|
resolverTimeoutMs :: Int,
|
|
resolverMaxResponseBytes :: Int
|
|
}
|
|
deriving (Show)
|
|
|
|
data NamesEnv = NamesEnv
|
|
{ config :: NamesConfig,
|
|
resolverEnv :: ResolverEnv
|
|
}
|
|
|
|
newNamesEnv :: NamesConfig -> IO NamesEnv
|
|
newNamesEnv config = do
|
|
resolverEnv <- newResolverEnv (resolverEndpoint config) (resolverAuth config) (resolverTimeoutMs config) (resolverMaxResponseBytes config)
|
|
pure NamesEnv {config, resolverEnv}
|
|
|
|
closeNamesEnv :: NamesEnv -> IO ()
|
|
closeNamesEnv NamesEnv {resolverEnv} = closeResolverEnv resolverEnv
|
|
|
|
pingEndpoint :: NamesEnv -> IO (Either ResolverError ())
|
|
pingEndpoint NamesEnv {resolverEnv, config} =
|
|
fromMaybe (Left ResolverTimeout) <$> timeout (resolverTimeoutMs config * 1000) (healthHttp resolverEnv)
|
|
|
|
resolveName :: NamesEnv -> SimplexDomain -> IO (Either NameErrorType NameRecord)
|
|
resolveName env d = do
|
|
r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env d))
|
|
case r of
|
|
Right result -> pure (fromMaybe (Left (RESOLVER "timeout")) result)
|
|
Left e
|
|
| Just (_ :: E.SomeAsyncException) <- E.fromException e -> E.throwIO e
|
|
| otherwise -> do
|
|
logError $ "[NAMES] resolver fetch raised " <> T.pack (E.displayException e)
|
|
pure (Left (RESOLVER "resolver error"))
|
|
|
|
fetch :: NamesEnv -> SimplexDomain -> IO (Either NameErrorType NameRecord)
|
|
fetch NamesEnv {resolverEnv} d =
|
|
first mapResolverError <$> resolveHttp resolverEnv (fullDomainName d)
|
|
|
|
mapResolverError :: ResolverError -> NameErrorType
|
|
mapResolverError = \case
|
|
HttpStatusErr 404 -> NOT_FOUND
|
|
-- 410 is a lapsed registration (past expiry, in grace or beyond): a correct
|
|
-- answer about the name, not a resolver failure, so it must not become
|
|
-- RESOLVER - that is reserved for the backing resolver/RPC breaking.
|
|
HttpStatusErr 410 -> NOT_FOUND
|
|
HttpStatusErr 400 -> NOT_FOUND
|
|
HttpStatusErr code -> RESOLVER ("HTTP " <> T.pack (show code))
|
|
HttpFailure _ -> RESOLVER "transport failure"
|
|
BodyTooLarge -> RESOLVER "response too large"
|
|
InvalidJson _ -> RESOLVER "invalid response"
|
|
ResolverTimeout -> RESOLVER "timeout"
|