{-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns, NumDecimals #-}
{-# LANGUAGE OverloadedStrings #-}
module NgxExport.Tools.Resolve (
UName
,SAddress
,UQuery (..)
,PriorityPolicy (..)
,UData (..)
,ServerData (..)
,CollectedServerData
,collectA
,collectSRV
,collectServerData
) where
import NgxExport
import NgxExport.Tools.SimpleService
import NgxExport.Tools.TimeInterval
import Network.DNS
import Network.HTTP.Client
import qualified Data.ByteString.Lazy as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.IORef
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe
import Data.Aeson
import Data.Function
import Data.List
import Data.Bits
import Control.Concurrent.Async
import Control.Exception
import Control.Exception.Safe (handleAny)
import Control.Arrow
import Control.Monad
import System.IO.Unsafe
import System.Timeout
type UName = Text
type SUrl = Text
type SAddress = Text
data UQuery = QueryA [Name] UName
| QuerySRV Name (PriorityPolicy UName)
deriving ReadPrec [UQuery]
ReadPrec UQuery
Int -> ReadS UQuery
ReadS [UQuery]
(Int -> ReadS UQuery)
-> ReadS [UQuery]
-> ReadPrec UQuery
-> ReadPrec [UQuery]
-> Read UQuery
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS UQuery
readsPrec :: Int -> ReadS UQuery
$creadList :: ReadS [UQuery]
readList :: ReadS [UQuery]
$creadPrec :: ReadPrec UQuery
readPrec :: ReadPrec UQuery
$creadListPrec :: ReadPrec [UQuery]
readListPrec :: ReadPrec [UQuery]
Read
data PriorityPolicy a = SinglePriority a
| PriorityList [a]
deriving ReadPrec [PriorityPolicy a]
ReadPrec (PriorityPolicy a)
Int -> ReadS (PriorityPolicy a)
ReadS [PriorityPolicy a]
(Int -> ReadS (PriorityPolicy a))
-> ReadS [PriorityPolicy a]
-> ReadPrec (PriorityPolicy a)
-> ReadPrec [PriorityPolicy a]
-> Read (PriorityPolicy a)
forall a. Read a => ReadPrec [PriorityPolicy a]
forall a. Read a => ReadPrec (PriorityPolicy a)
forall a. Read a => Int -> ReadS (PriorityPolicy a)
forall a. Read a => ReadS [PriorityPolicy a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (PriorityPolicy a)
readsPrec :: Int -> ReadS (PriorityPolicy a)
$creadList :: forall a. Read a => ReadS [PriorityPolicy a]
readList :: ReadS [PriorityPolicy a]
$creadPrec :: forall a. Read a => ReadPrec (PriorityPolicy a)
readPrec :: ReadPrec (PriorityPolicy a)
$creadListPrec :: forall a. Read a => ReadPrec [PriorityPolicy a]
readListPrec :: ReadPrec [PriorityPolicy a]
Read
data UData = UData { UData -> UQuery
uQuery :: UQuery
, UData -> Int
uMaxFails :: Int
, UData -> Int
uFailTimeout :: Int
} deriving ReadPrec [UData]
ReadPrec UData
Int -> ReadS UData
ReadS [UData]
(Int -> ReadS UData)
-> ReadS [UData]
-> ReadPrec UData
-> ReadPrec [UData]
-> Read UData
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS UData
readsPrec :: Int -> ReadS UData
$creadList :: ReadS [UData]
readList :: ReadS [UData]
$creadPrec :: ReadPrec UData
readPrec :: ReadPrec UData
$creadListPrec :: ReadPrec [UData]
readListPrec :: ReadPrec [UData]
Read
data Conf = Conf { Conf -> [UData]
upstreams :: [UData]
, Conf -> TimeInterval
maxWait :: TimeInterval
, Conf -> TimeInterval
waitOnException :: TimeInterval
, Conf -> TimeInterval
responseTimeout :: TimeInterval
} deriving ReadPrec [Conf]
ReadPrec Conf
Int -> ReadS Conf
ReadS [Conf]
(Int -> ReadS Conf)
-> ReadS [Conf] -> ReadPrec Conf -> ReadPrec [Conf] -> Read Conf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Conf
readsPrec :: Int -> ReadS Conf
$creadList :: ReadS [Conf]
readList :: ReadS [Conf]
$creadPrec :: ReadPrec Conf
readPrec :: ReadPrec Conf
$creadListPrec :: ReadPrec [Conf]
readListPrec :: ReadPrec [Conf]
Read
newtype Upconf = Upconf { Upconf -> (UName, UName)
upconfAddr :: (SUrl, SAddress) } deriving ReadPrec [Upconf]
ReadPrec Upconf
Int -> ReadS Upconf
ReadS [Upconf]
(Int -> ReadS Upconf)
-> ReadS [Upconf]
-> ReadPrec Upconf
-> ReadPrec [Upconf]
-> Read Upconf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Upconf
readsPrec :: Int -> ReadS Upconf
$creadList :: ReadS [Upconf]
readList :: ReadS [Upconf]
$creadPrec :: ReadPrec Upconf
readPrec :: ReadPrec Upconf
$creadListPrec :: ReadPrec [Upconf]
readListPrec :: ReadPrec [Upconf]
Read
data ServerData = ServerData { ServerData -> UName
sAddr :: SAddress
, ServerData -> Maybe Int
sWeight :: Maybe Int
, ServerData -> Maybe Int
sMaxFails :: Maybe Int
, ServerData -> Maybe Int
sFailTimeout :: Maybe Int
} deriving (Int -> ServerData -> ShowS
[ServerData] -> ShowS
ServerData -> String
(Int -> ServerData -> ShowS)
-> (ServerData -> String)
-> ([ServerData] -> ShowS)
-> Show ServerData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerData -> ShowS
showsPrec :: Int -> ServerData -> ShowS
$cshow :: ServerData -> String
show :: ServerData -> String
$cshowList :: [ServerData] -> ShowS
showList :: [ServerData] -> ShowS
Show, ServerData -> ServerData -> Bool
(ServerData -> ServerData -> Bool)
-> (ServerData -> ServerData -> Bool) -> Eq ServerData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerData -> ServerData -> Bool
== :: ServerData -> ServerData -> Bool
$c/= :: ServerData -> ServerData -> Bool
/= :: ServerData -> ServerData -> Bool
Eq, Eq ServerData
Eq ServerData
-> (ServerData -> ServerData -> Ordering)
-> (ServerData -> ServerData -> Bool)
-> (ServerData -> ServerData -> Bool)
-> (ServerData -> ServerData -> Bool)
-> (ServerData -> ServerData -> Bool)
-> (ServerData -> ServerData -> ServerData)
-> (ServerData -> ServerData -> ServerData)
-> Ord ServerData
ServerData -> ServerData -> Bool
ServerData -> ServerData -> Ordering
ServerData -> ServerData -> ServerData
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ServerData -> ServerData -> Ordering
compare :: ServerData -> ServerData -> Ordering
$c< :: ServerData -> ServerData -> Bool
< :: ServerData -> ServerData -> Bool
$c<= :: ServerData -> ServerData -> Bool
<= :: ServerData -> ServerData -> Bool
$c> :: ServerData -> ServerData -> Bool
> :: ServerData -> ServerData -> Bool
$c>= :: ServerData -> ServerData -> Bool
>= :: ServerData -> ServerData -> Bool
$cmax :: ServerData -> ServerData -> ServerData
max :: ServerData -> ServerData -> ServerData
$cmin :: ServerData -> ServerData -> ServerData
min :: ServerData -> ServerData -> ServerData
Ord)
instance FromJSON ServerData where
parseJSON :: Value -> Parser ServerData
parseJSON = String
-> (Object -> Parser ServerData) -> Value -> Parser ServerData
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"server_options" ((Object -> Parser ServerData) -> Value -> Parser ServerData)
-> (Object -> Parser ServerData) -> Value -> Parser ServerData
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
UName
sAddr <- Object
o Object -> Key -> Parser UName
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"addr"
Maybe Int
sWeight <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"weight"
Maybe Int
sMaxFails <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"max_fails"
Maybe Int
sFailTimeout <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"fail_timeout"
ServerData -> Parser ServerData
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerData {Maybe Int
UName
sAddr :: UName
sWeight :: Maybe Int
sMaxFails :: Maybe Int
sFailTimeout :: Maybe Int
sAddr :: UName
sWeight :: Maybe Int
sMaxFails :: Maybe Int
sFailTimeout :: Maybe Int
..}
instance ToJSON ServerData where
toJSON :: ServerData -> Value
toJSON ServerData {Maybe Int
UName
sAddr :: ServerData -> UName
sWeight :: ServerData -> Maybe Int
sMaxFails :: ServerData -> Maybe Int
sFailTimeout :: ServerData -> Maybe Int
sAddr :: UName
sWeight :: Maybe Int
sMaxFails :: Maybe Int
sFailTimeout :: Maybe Int
..} =
[Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes [ Pair -> Maybe Pair
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"addr" Key -> UName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= UName
sAddr
, (Key
"weight" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.=) (Int -> Pair) -> Maybe Int -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
sWeight
, (Key
"max_fails" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.=) (Int -> Pair) -> Maybe Int -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
sMaxFails
, (Key
"fail_timeout" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.=) (Int -> Pair) -> Maybe Int -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
sFailTimeout
]
type CollectedServerData = Map UName [ServerData]
collectedServerData :: IORef (TimeInterval, CollectedServerData)
collectedServerData :: IORef (TimeInterval, CollectedServerData)
collectedServerData = IO (IORef (TimeInterval, CollectedServerData))
-> IORef (TimeInterval, CollectedServerData)
forall a. IO a -> a
unsafePerformIO (IO (IORef (TimeInterval, CollectedServerData))
-> IORef (TimeInterval, CollectedServerData))
-> IO (IORef (TimeInterval, CollectedServerData))
-> IORef (TimeInterval, CollectedServerData)
forall a b. (a -> b) -> a -> b
$ (TimeInterval, CollectedServerData)
-> IO (IORef (TimeInterval, CollectedServerData))
forall a. a -> IO (IORef a)
newIORef (TimeInterval
Unset, CollectedServerData
forall k a. Map k a
M.empty)
{-# NOINLINE collectedServerData #-}
httpManager :: Manager
httpManager :: Manager
httpManager = IO Manager -> Manager
forall a. IO a -> a
unsafePerformIO (IO Manager -> Manager) -> IO Manager -> Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
{-# NOINLINE httpManager #-}
getResponse :: Text -> (Request -> IO (Response L.ByteString)) ->
IO L.ByteString
getResponse :: UName -> (Request -> IO (Response ByteString)) -> IO ByteString
getResponse UName
url = (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response ByteString -> ByteString
forall body. Response body -> body
responseBody (IO (Response ByteString) -> IO ByteString)
-> ((Request -> IO (Response ByteString))
-> IO (Response ByteString))
-> (Request -> IO (Response ByteString))
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (UName -> String
T.unpack UName
url) IO Request
-> (Request -> IO (Response ByteString))
-> IO (Response ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
getUrl :: Text -> IO L.ByteString
getUrl :: UName -> IO ByteString
getUrl UName
url = UName -> (Request -> IO (Response ByteString)) -> IO ByteString
getResponse UName
url ((Request -> IO (Response ByteString)) -> IO ByteString)
-> (Request -> IO (Response ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (Request -> Manager -> IO (Response ByteString))
-> Manager -> Request -> IO (Response ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ByteString)
httpLbs Manager
httpManager
queryHTTP :: Text -> Text -> IO L.ByteString
queryHTTP :: UName -> UName -> IO ByteString
queryHTTP = (UName -> IO ByteString
getUrl (UName -> IO ByteString)
-> (UName -> UName) -> UName -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((UName -> UName) -> UName -> IO ByteString)
-> (UName -> UName -> UName) -> UName -> UName -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UName -> UName -> UName) -> UName -> UName -> UName
forall a b c. (a -> b -> c) -> b -> a -> c
flip UName -> UName -> UName
mkAddr
where mkAddr :: UName -> UName -> UName
mkAddr = ((UName
"http://" UName -> UName -> UName
`T.append`) (UName -> UName) -> (UName -> UName) -> UName -> UName
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((UName -> UName) -> UName -> UName)
-> (UName -> UName -> UName) -> UName -> UName -> UName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UName -> UName -> UName
T.append
minimumTTL :: TTL -> [TTL] -> TTL
minimumTTL :: TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL [] = TTL
lTTL
minimumTTL TTL
_ [TTL]
ttls = [TTL] -> TTL
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [TTL]
ttls
collectA
:: TTL
-> Name
-> IO (TTL, [IPv4])
collectA :: TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL Name
name = do
![(TTL, IPv4)]
srv <- Name -> IO [(TTL, IPv4)]
queryA Name
name
(TTL, [IPv4]) -> IO (TTL, [IPv4])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL ([TTL] -> TTL) -> [TTL] -> TTL
forall a b. (a -> b) -> a -> b
$ ((TTL, IPv4) -> TTL) -> [(TTL, IPv4)] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, IPv4) -> TTL
forall a b. (a, b) -> a
fst [(TTL, IPv4)]
srv, ((TTL, IPv4) -> IPv4) -> [(TTL, IPv4)] -> [IPv4]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, IPv4) -> IPv4
forall a b. (a, b) -> b
snd [(TTL, IPv4)]
srv)
collectSRV
:: TTL
-> Name
-> IO (TTL, [SRV IPv4])
collectSRV :: TTL -> Name -> IO (TTL, [SRV IPv4])
collectSRV TTL
lTTL Name
name = do
![(TTL, SRV Name)]
srv <- Name -> IO [(TTL, SRV Name)]
querySRV Name
name
![(TTL, [SRV IPv4])]
srv' <- ((TTL, SRV Name) -> IO (TTL, [SRV IPv4]))
-> [(TTL, SRV Name)] -> IO [(TTL, [SRV IPv4])]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently
((\s :: SRV Name
s@SRV {Word16
Name
srvWeight :: forall l. SRV l -> Word16
srvPriority :: Word16
srvWeight :: Word16
srvPort :: Word16
srvTarget :: Name
srvPriority :: forall l. SRV l -> Word16
srvPort :: forall l. SRV l -> Word16
srvTarget :: forall l. SRV l -> l
..} -> do
(TTL
t, [IPv4]
is) <- TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL Name
srvTarget
(TTL, [SRV IPv4]) -> IO (TTL, [SRV IPv4])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
t, (IPv4 -> SRV IPv4) -> [IPv4] -> [SRV IPv4]
forall a b. (a -> b) -> [a] -> [b]
map (\IPv4
v -> SRV Name
s { srvTarget :: IPv4
srvTarget = IPv4
v }) [IPv4]
is)
) (SRV Name -> IO (TTL, [SRV IPv4]))
-> ((TTL, SRV Name) -> SRV Name)
-> (TTL, SRV Name)
-> IO (TTL, [SRV IPv4])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TTL, SRV Name) -> SRV Name
forall a b. (a, b) -> b
snd
) [(TTL, SRV Name)]
srv
(TTL, [SRV IPv4]) -> IO (TTL, [SRV IPv4])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL -> TTL -> TTL
forall a. Ord a => a -> a -> a
min (TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL ([TTL] -> TTL) -> [TTL] -> TTL
forall a b. (a -> b) -> a -> b
$ ((TTL, SRV Name) -> TTL) -> [(TTL, SRV Name)] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, SRV Name) -> TTL
forall a b. (a, b) -> a
fst [(TTL, SRV Name)]
srv)
(TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL ([TTL] -> TTL) -> [TTL] -> TTL
forall a b. (a -> b) -> a -> b
$ ((TTL, [SRV IPv4]) -> TTL) -> [(TTL, [SRV IPv4])] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, [SRV IPv4]) -> TTL
forall a b. (a, b) -> a
fst [(TTL, [SRV IPv4])]
srv')
,((TTL, [SRV IPv4]) -> [SRV IPv4])
-> [(TTL, [SRV IPv4])] -> [SRV IPv4]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TTL, [SRV IPv4]) -> [SRV IPv4]
forall a b. (a, b) -> b
snd [(TTL, [SRV IPv4])]
srv'
)
showIPv4 :: IPv4 -> String
showIPv4 :: IPv4 -> String
showIPv4 (IPv4 Word32
w) =
Word32 -> ShowS
forall a. Show a => a -> ShowS
shows ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Word32 -> ShowS
forall a. Show a => a -> ShowS
shows ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Word32 -> ShowS
forall a. Show a => a -> ShowS
shows ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
Word32 -> ShowS
forall a. Show a => a -> ShowS
shows ( Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff)
String
""
ipv4ToServerData :: UData -> IPv4 -> ServerData
ipv4ToServerData :: UData -> IPv4 -> ServerData
ipv4ToServerData UData {Int
UQuery
uQuery :: UData -> UQuery
uMaxFails :: UData -> Int
uFailTimeout :: UData -> Int
uQuery :: UQuery
uMaxFails :: Int
uFailTimeout :: Int
..} IPv4
i =
UName -> Maybe Int -> Maybe Int -> Maybe Int -> ServerData
ServerData (String -> UName
T.pack (String -> UName) -> String -> UName
forall a b. (a -> b) -> a -> b
$ IPv4 -> String
forall a. Show a => a -> String
show IPv4
i) Maybe Int
forall a. Maybe a
Nothing (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
uMaxFails) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
uFailTimeout)
srvToServerData :: UData -> SRV IPv4 -> ServerData
srvToServerData :: UData -> SRV IPv4 -> ServerData
srvToServerData UData {Int
UQuery
uQuery :: UData -> UQuery
uMaxFails :: UData -> Int
uFailTimeout :: UData -> Int
uQuery :: UQuery
uMaxFails :: Int
uFailTimeout :: Int
..} SRV {Word16
IPv4
srvWeight :: forall l. SRV l -> Word16
srvPriority :: forall l. SRV l -> Word16
srvPort :: forall l. SRV l -> Word16
srvTarget :: forall l. SRV l -> l
srvPriority :: Word16
srvWeight :: Word16
srvPort :: Word16
srvTarget :: IPv4
..} =
UName -> Maybe Int -> Maybe Int -> Maybe Int -> ServerData
ServerData (String -> UName
T.pack (String -> UName) -> String -> UName
forall a b. (a -> b) -> a -> b
$ IPv4 -> Word16 -> String
forall {a}. Show a => IPv4 -> a -> String
showAddr IPv4
srvTarget Word16
srvPort)
(Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
srvWeight) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
uMaxFails) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
uFailTimeout)
where showAddr :: IPv4 -> a -> String
showAddr IPv4
i a
p = IPv4 -> String
showIPv4 IPv4
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: a -> String
forall a. Show a => a -> String
show a
p
collectServerData
:: TTL
-> UData
-> IO (TTL, CollectedServerData)
collectServerData :: TTL -> UData -> IO (TTL, CollectedServerData)
collectServerData TTL
lTTL (UData (QueryA [] UName
_) Int
_ Int
_) =
(TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
lTTL, CollectedServerData
forall k a. Map k a
M.empty)
collectServerData TTL
lTTL ud :: UData
ud@(UData (QueryA [Name]
ns UName
u) Int
_ Int
_) = do
[(TTL, [IPv4])]
a <- (Name -> IO (TTL, [IPv4])) -> [Name] -> IO [(TTL, [IPv4])]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL) [Name]
ns
(TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TTL, CollectedServerData) -> IO (TTL, CollectedServerData))
-> (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a b. (a -> b) -> a -> b
$
[TTL] -> TTL
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([TTL] -> TTL)
-> ([[ServerData]] -> CollectedServerData)
-> ([TTL], [[ServerData]])
-> (TTL, CollectedServerData)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** UName -> [ServerData] -> CollectedServerData
forall k a. k -> a -> Map k a
M.singleton UName
u ([ServerData] -> CollectedServerData)
-> ([[ServerData]] -> [ServerData])
-> [[ServerData]]
-> CollectedServerData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ServerData]] -> [ServerData]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([TTL], [[ServerData]]) -> (TTL, CollectedServerData))
-> ([TTL], [[ServerData]]) -> (TTL, CollectedServerData)
forall a b. (a -> b) -> a -> b
$
((TTL, [IPv4])
-> ([TTL], [[ServerData]]) -> ([TTL], [[ServerData]]))
-> ([TTL], [[ServerData]])
-> [(TTL, [IPv4])]
-> ([TTL], [[ServerData]])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(TTL
t, [IPv4]
s) ([TTL]
ts, [[ServerData]]
ss) ->
(TTL
t TTL -> [TTL] -> [TTL]
forall a. a -> [a] -> [a]
: [TTL]
ts, [ServerData] -> [ServerData]
forall a. Ord a => [a] -> [a]
sort ((IPv4 -> ServerData) -> [IPv4] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (UData -> IPv4 -> ServerData
ipv4ToServerData UData
ud) [IPv4]
s) [ServerData] -> [[ServerData]] -> [[ServerData]]
forall a. a -> [a] -> [a]
: [[ServerData]]
ss)
) ([], []) [(TTL, [IPv4])]
a
collectServerData TTL
lTTL ud :: UData
ud@(UData (QuerySRV Name
n (SinglePriority UName
u)) Int
_ Int
_) = do
(TTL
wt, [SRV IPv4]
srv) <- TTL -> Name -> IO (TTL, [SRV IPv4])
collectSRV TTL
lTTL Name
n
(TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
wt, UName -> [ServerData] -> CollectedServerData
forall k a. k -> a -> Map k a
M.singleton UName
u ([ServerData] -> CollectedServerData)
-> [ServerData] -> CollectedServerData
forall a b. (a -> b) -> a -> b
$ [ServerData] -> [ServerData]
forall a. Ord a => [a] -> [a]
sort ([ServerData] -> [ServerData]) -> [ServerData] -> [ServerData]
forall a b. (a -> b) -> a -> b
$ (SRV IPv4 -> ServerData) -> [SRV IPv4] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (UData -> SRV IPv4 -> ServerData
srvToServerData UData
ud) [SRV IPv4]
srv)
collectServerData TTL
lTTL (UData (QuerySRV Name
_ (PriorityList [])) Int
_ Int
_) =
(TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
lTTL, CollectedServerData
forall k a. Map k a
M.empty)
collectServerData TTL
lTTL ud :: UData
ud@(UData (QuerySRV Name
n (PriorityList [UName]
pl)) Int
_ Int
_ ) = do
(TTL
wt, [SRV IPv4]
srv) <- TTL -> Name -> IO (TTL, [SRV IPv4])
collectSRV TTL
lTTL Name
n
let srv' :: [(UName, [SRV IPv4])]
srv' = [UName] -> [[SRV IPv4]] -> [(UName, [SRV IPv4])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([UName] -> [UName]
forall {a}. [a] -> [a]
withTrail [UName]
pl) ([[SRV IPv4]] -> [(UName, [SRV IPv4])])
-> [[SRV IPv4]] -> [(UName, [SRV IPv4])]
forall a b. (a -> b) -> a -> b
$ [SRV IPv4] -> [[SRV IPv4]]
forall {l}. [SRV l] -> [[SRV l]]
partitionByPriority [SRV IPv4]
srv
(TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
wt
,[(UName, [ServerData])] -> CollectedServerData
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(UName, [ServerData])] -> CollectedServerData)
-> [(UName, [ServerData])] -> CollectedServerData
forall a b. (a -> b) -> a -> b
$ ((UName, [SRV IPv4]) -> (UName, [ServerData]))
-> [(UName, [SRV IPv4])] -> [(UName, [ServerData])]
forall a b. (a -> b) -> [a] -> [b]
map (([SRV IPv4] -> [ServerData])
-> (UName, [SRV IPv4]) -> (UName, [ServerData])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([SRV IPv4] -> [ServerData])
-> (UName, [SRV IPv4]) -> (UName, [ServerData]))
-> ([SRV IPv4] -> [ServerData])
-> (UName, [SRV IPv4])
-> (UName, [ServerData])
forall a b. (a -> b) -> a -> b
$ [ServerData] -> [ServerData]
forall a. Ord a => [a] -> [a]
sort ([ServerData] -> [ServerData])
-> ([SRV IPv4] -> [ServerData]) -> [SRV IPv4] -> [ServerData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SRV IPv4 -> ServerData) -> [SRV IPv4] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (UData -> SRV IPv4 -> ServerData
srvToServerData UData
ud)) [(UName, [SRV IPv4])]
srv'
)
where partitionByPriority :: [SRV l] -> [[SRV l]]
partitionByPriority =
(SRV l -> SRV l -> Bool) -> [SRV l] -> [[SRV l]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Word16 -> Word16 -> Bool)
-> (SRV l -> Word16) -> SRV l -> SRV l -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SRV l -> Word16
forall l. SRV l -> Word16
srvPriority) ([SRV l] -> [[SRV l]])
-> ([SRV l] -> [SRV l]) -> [SRV l] -> [[SRV l]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SRV l -> Word16) -> [SRV l] -> [SRV l]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn SRV l -> Word16
forall l. SRV l -> Word16
srvPriority
withTrail :: [a] -> [a]
withTrail = ([a] -> [a] -> [a]) -> ([a], [a]) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) (([a], [a]) -> [a]) -> ([a] -> ([a], [a])) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]
forall a. a -> a
id ([a] -> [a]) -> ([a] -> [a]) -> [a] -> ([a], [a])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> [a]
forall a. a -> [a]
repeat (a -> [a]) -> ([a] -> a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> a
forall a. HasCallStack => [a] -> a
last)
collectUpstreams :: Conf -> Bool -> IO L.ByteString
collectUpstreams :: Conf -> Bool -> IO ByteString
collectUpstreams Conf {[UData]
TimeInterval
upstreams :: Conf -> [UData]
maxWait :: Conf -> TimeInterval
waitOnException :: Conf -> TimeInterval
responseTimeout :: Conf -> TimeInterval
upstreams :: [UData]
maxWait :: TimeInterval
waitOnException :: TimeInterval
responseTimeout :: TimeInterval
..} = IO ByteString -> Bool -> IO ByteString
forall a b. a -> b -> a
const (IO ByteString -> Bool -> IO ByteString)
-> IO ByteString -> Bool -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
(TimeInterval
wt, CollectedServerData
old) <- IORef (TimeInterval, CollectedServerData)
-> IO (TimeInterval, CollectedServerData)
forall a. IORef a -> IO a
readIORef IORef (TimeInterval, CollectedServerData)
collectedServerData
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TimeInterval
wt TimeInterval -> TimeInterval -> Bool
forall a. Eq a => a -> a -> Bool
/= TimeInterval
Unset) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelaySec (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Int
toSec TimeInterval
wt
let (TTL
lTTL, TTL
hTTL) = (TimeInterval -> TTL
toTTL TimeInterval
waitOnException, TimeInterval -> TTL
toTTL TimeInterval
maxWait)
[(TTL, CollectedServerData)]
srv <- IO [(TTL, CollectedServerData)] -> IO [(TTL, CollectedServerData)]
forall {a}. IO a -> IO a
handleCollectErrors (IO [(TTL, CollectedServerData)]
-> IO [(TTL, CollectedServerData)])
-> IO [(TTL, CollectedServerData)]
-> IO [(TTL, CollectedServerData)]
forall a b. (a -> b) -> a -> b
$
(UData -> IO (TTL, CollectedServerData))
-> [UData] -> IO [(TTL, CollectedServerData)]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (IO (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall {a}. IO a -> IO a
withTimeout (IO (TTL, CollectedServerData) -> IO (TTL, CollectedServerData))
-> (UData -> IO (TTL, CollectedServerData))
-> UData
-> IO (TTL, CollectedServerData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TTL -> UData -> IO (TTL, CollectedServerData)
collectServerData TTL
lTTL) [UData]
upstreams
let nwt :: TimeInterval
nwt = TTL -> TimeInterval
fromTTL (TTL -> TimeInterval) -> TTL -> TimeInterval
forall a b. (a -> b) -> a -> b
$ TTL -> TTL -> TTL
forall a. Ord a => a -> a -> a
max (Int32 -> TTL
TTL Int32
1) (TTL -> TTL) -> TTL -> TTL
forall a b. (a -> b) -> a -> b
$ TTL -> TTL -> TTL
forall a. Ord a => a -> a -> a
min TTL
hTTL (TTL -> TTL) -> TTL -> TTL
forall a b. (a -> b) -> a -> b
$ TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL ([TTL] -> TTL) -> [TTL] -> TTL
forall a b. (a -> b) -> a -> b
$ ((TTL, CollectedServerData) -> TTL)
-> [(TTL, CollectedServerData)] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, CollectedServerData) -> TTL
forall a b. (a, b) -> a
fst [(TTL, CollectedServerData)]
srv
new :: CollectedServerData
new = [CollectedServerData] -> CollectedServerData
forall a. Monoid a => [a] -> a
mconcat ([CollectedServerData] -> CollectedServerData)
-> [CollectedServerData] -> CollectedServerData
forall a b. (a -> b) -> a -> b
$ ((TTL, CollectedServerData) -> CollectedServerData)
-> [(TTL, CollectedServerData)] -> [CollectedServerData]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, CollectedServerData) -> CollectedServerData
forall a b. (a, b) -> b
snd [(TTL, CollectedServerData)]
srv
if CollectedServerData
new CollectedServerData -> CollectedServerData -> Bool
forall a. Eq a => a -> a -> Bool
== CollectedServerData
old
then do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TimeInterval
nwt TimeInterval -> TimeInterval -> Bool
forall a. Eq a => a -> a -> Bool
/= TimeInterval
wt) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IORef (TimeInterval, CollectedServerData)
-> ((TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (TimeInterval, CollectedServerData)
collectedServerData (((TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData))
-> IO ())
-> ((TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (TimeInterval -> TimeInterval)
-> (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((TimeInterval -> TimeInterval)
-> (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData))
-> (TimeInterval -> TimeInterval)
-> (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData)
forall a b. (a -> b) -> a -> b
$ TimeInterval -> TimeInterval -> TimeInterval
forall a b. a -> b -> a
const TimeInterval
nwt
ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
else do
IORef (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (TimeInterval, CollectedServerData)
collectedServerData (TimeInterval
nwt, CollectedServerData
new)
ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ CollectedServerData -> ByteString
forall a. ToJSON a => a -> ByteString
encode CollectedServerData
new
where toTTL :: TimeInterval -> TTL
toTTL = Int32 -> TTL
TTL (Int32 -> TTL) -> (TimeInterval -> Int32) -> TimeInterval -> TTL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> (TimeInterval -> Int) -> TimeInterval -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterval -> Int
toSec
fromTTL :: TTL -> TimeInterval
fromTTL (TTL Int32
ttl) = Int -> TimeInterval
Sec (Int -> TimeInterval) -> Int -> TimeInterval
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ttl
handleCollectErrors :: IO a -> IO a
handleCollectErrors = (SomeException -> IO a) -> IO a -> IO a
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
handleAny ((SomeException -> IO a) -> IO a -> IO a)
-> (SomeException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
IORef (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (TimeInterval, CollectedServerData)
collectedServerData (TimeInterval
waitOnException, CollectedServerData
forall k a. Map k a
M.empty)
SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e
withTimeout :: IO b -> IO b
withTimeout IO b
act = do
Maybe b
r <- Int -> IO b -> IO (Maybe b)
forall a. Int -> IO a -> IO (Maybe a)
timeout (TimeInterval -> Int
toTimeout TimeInterval
responseTimeout) IO b
act
case Maybe b
r of
Maybe b
Nothing -> IOError -> IO b
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO b) -> IOError -> IO b
forall a b. (a -> b) -> a -> b
$
String -> IOError
userError String
"Collection of server data was timed out"
Just b
r' -> b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r'
toTimeout :: TimeInterval -> Int
toTimeout TimeInterval
Unset = -Int
1
toTimeout TimeInterval
v = TimeInterval -> Int
toSec TimeInterval
v Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1e6
ngxExportSimpleServiceTyped 'collectUpstreams ''Conf $
PersistentService Nothing
signalUpconf :: Upconf -> Bool -> IO L.ByteString
signalUpconf :: Upconf -> Bool -> IO ByteString
signalUpconf Upconf {(UName, UName)
upconfAddr :: Upconf -> (UName, UName)
upconfAddr :: (UName, UName)
..} = IO ByteString -> Bool -> IO ByteString
forall a b. a -> b -> a
const (IO ByteString -> Bool -> IO ByteString)
-> IO ByteString -> Bool -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ (UName -> UName -> IO ByteString)
-> (UName, UName) -> IO ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry UName -> UName -> IO ByteString
queryHTTP (UName, UName)
upconfAddr
ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
ngxExportSimpleServiceTyped 'signalUpconf ''Upconf $
PersistentService Nothing