{-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns, NumDecimals #-}
{-# LANGUAGE DeriveFoldable, TupleSections, LambdaCase, OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  NgxExport.Tools.Resolve
-- Copyright   :  (c) Alexey Radkov 2022-2024
-- License     :  BSD-style
--
-- Maintainer  :  alexey.radkov@gmail.com
-- Stability   :  experimental
-- Portability :  non-portable (requires Template Haskell)
--
-- DNS resolve utilities from the more extra tools collection for
-- <https://github.com/lyokha/nginx-haskell-module nginx-haskell-module>.
--
-----------------------------------------------------------------------------

module NgxExport.Tools.Resolve (
    -- * Dynamic upstreams in Nginx
    -- $dynamicUpstreams

    -- * Exported type declarations
                                UName
                               ,SAddress
                               ,UQuery (..)
                               ,WeightedList (..)
                               ,NameList
                               ,PriorityPolicy (..)
                               ,UNamePriorityPolicy
                               ,UData (..)
                               ,ServerData (..)
                               ,CollectedServerData
    -- * Exported functions
                               ,collectA
                               ,collectSRV
                               ,collectServerData
                               ) where

import           NgxExport
import           NgxExport.Tools.Combinators
import           NgxExport.Tools.SimpleService
import           NgxExport.Tools.TimeInterval

import           Network.DNS
import           Network.HTTP.Client
import           Network.HTTP.Client.TLS (newTlsManager)
import           Network.HTTP.Client.BrReadWithTimeout
import qualified Data.ByteString.Char8 as C8
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 qualified Data.Text.Encoding as T
import           Data.Maybe
import           Data.Aeson
import           Data.Function
import           Data.List
import           Data.Bits
import           Data.Ord
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

-- $dynamicUpstreams
--
-- With Nginx module
-- [nginx-upconf-module](https://github.com/lyokha/nginx-haskell-module/tree/master/examples/dynamicUpstreams),
-- it is possible to update servers inside upstreams dynamically. The module
-- requires an agent to update a bound variable with upstreams layout and also
-- signal that the variable has been altered. This module is such an agent. It
-- updates the variable with the upstreams layout in service
-- __/collectUpstreams/__ and signals about this in service callback
-- __/signalUpconf/__. Collecting upstreams encompasses DNS queries of /A/ and
-- /SRV/ records. The queries are configured independently for each managed
-- upstream. With both /A/ and /SRV/ queries, the module allows configuration
-- of complex hierarchies of priorities given that compound upstream containers
-- named /upstrands/ are in use (they are implemented in
-- [nginx-combined-upstreams-module](https://github.com/lyokha/nginx-combined-upstreams-module)).
--
-- Additionally, the module exports a number of functions and data types which
-- implement service /collectUpstreams/.
--
-- In the following example, we are going to extract IP addresses from an /SRV/
-- record for /_http._tcp.mycompany.com/ to inhabit upstream /utest/.
--
-- ==== File /test_tools_extra_prometheus.hs/
-- @
-- module TestToolsExtraResolve where
--
-- import NgxExport.Tools.Resolve ()
-- @
--
-- The file does not contain any significant declarations as we are going to use
-- only the exporters.
--
-- ==== File /nginx.conf/
-- @
-- user                    nginx;
-- worker_processes        4;
--
-- events {
--     worker_connections  1024;
-- }
--
-- http {
--     default_type        application\/octet-stream;
--     sendfile            on;
--
--     upstream __/utest/__ {
--         zone utest 64k;
--         upconf_round_robin;
--         server localhost:9000;
--     }
--
--     haskell load \/var\/lib\/nginx\/test_tools_extra_resolve.so;
--
--     haskell_run_service __/simpleService_collectUpstreams/__ $hs_upstreams
--         \'Conf { upstreams =
--                     ['UData' { 'uQuery' =
--                                  'QuerySRV'
--                                      ('Name' \"_http._tcp.mycompany.com\")
--                                          ('SinglePriority' \"__/utest/__\")
--                            , 'uMaxFails' = 1
--                            , 'uFailTimeout' = 10
--                            }
--                     ]
--               , maxWait = 'Sec' 300
--               , waitOnException = 'Sec' 2
--               , responseTimeout = 'Unset'
--               }\';
--
--     haskell_service_var_ignore_empty $hs_upstreams;
--     haskell_service_var_in_shm upstreams 64k \/tmp $hs_upstreams;
--
--     haskell_service_var_update_callback __/simpleService_signalUpconf/__ $hs_upstreams
--         \'[\"http:\/\/127.0.0.1:8010__/\/upconf/__\"]\';
--
--     server {
--         listen          localhost:8010;
--         server_name     main;
--
--         location __/\/upconf/__ {
--             upconf $hs_upstreams;
--
--             allow 127.0.0.1;
--             deny  all;
--         }
--
--         location \/upstreams {
--             default_type application\/json;
--             echo $hs_upstreams;
--
--             allow 127.0.0.1;
--             deny  all;
--         }
--
--         location \/ {
--             proxy_pass http:\/\/utest;
--         }
--     }
--
--     server {
--         listen          localhost:9000;
--         server_name     backend9000;
--
--         location \/ {
--             echo_status 503;
--             echo \"Not configured\";
--         }
--     }
-- }
-- @
--
-- At the start of Nginx, upstream /utest/ contains a statically declared server
-- which reports /Not configured/, but so soon as service /collectUpstreams/
-- collects servers for the upstream in variable __/$hs_upstreams/__, and then
-- the /upconf/ module gets notified about this via callback /signalUpconf/, the
-- upstream gets inhabited by the collected servers. Notice that /signalUpconf/
-- accepts a /list/ of URLs which means that it can broadcast collected servers
-- to multiple /upconf/ endpoints listening on this or other hosts.
--
-- The upstream contents will be re-checked within the time interval of
-- /(1 or waitOnException, maxWait)/. Particularly, if an exception happens
-- during the collection of the servers, then the service will restart in
-- /waitOnException/. If there were no exceptions and the smallest value of
-- /TTL/ calculated from all collected servers does not exceed the value of
-- /maxWait/, then the service will restart in this time.
--
-- Too big response times may also cause exceptions during the collection of the
-- servers. The timeout is defined by the value of /responseTimeout/. In our
-- example, the timeout is not set.
--
-- Notice that we used /QuerySRV/ and /SinglePriority \"utest\"/. The latter
-- means that all collected servers will inhabit upstream /utest/ regardless of
-- their priority values. To distribute collected servers among a number of
-- upstreams, we can use /PriorityList/.
--
-- ==== File /nginx.conf/: collect upstreams with /PriorityList/
-- @
--     haskell_run_service __/simpleService_collectUpstreams/__ $hs_upstreams
--         \'Conf { upstreams =
--                     ['UData' { 'uQuery' =
--                                  'QuerySRV'
--                                      ('Name' \"_http._tcp.mycompany.com\")
--                                          ('PriorityList' [\"__/utest/__\", \"__/utest1/__\"])
--                            , 'uMaxFails' = 1
--                            , 'uFailTimeout' = 10
--                            }
--                     ]
--               , maxWait = 'Sec' 300
--               , waitOnException = 'Sec' 2
--               , responseTimeout = 'Unset'
--               }\';
-- @
--
-- With this configuration, servers with the highest priority will inhabit
-- upstream /utest/, while servers with the less priority will inhabit upstream
-- /utest1/. Upstream /utest1/ must also be managed by the /upconf/ module.
-- Generally, given the number of upstreams in the priority list is \(N\) and
-- the number of all variations of server priorities collected in the response
-- is \(M\), and \(N\) is less than \(M\), then remaining \(M - N\) servers with
-- the lowest priorities won't be used in the upstreams at all, otherwise, if
-- \(N\) is greater than \(M\), then remaining \(N - M\) upstreams at the end of
-- the priority list will contain the same servers of the lowest priority.
--
-- Upstreams in the priority list can be put inside of an /upstrand/ to form the
-- main and the backup layers of servers.
--
-- ==== File /nginx.conf/: upstrand /utest/
-- @
--     upstream __/utest1/__ {
--         zone utest1 64k;
--         upconf_round_robin;
--         server localhost:9000;
--     }
--
--     __/upstrand utest/__ {
--         upstream __/utest/__;
--         upstream __/utest1/__;
--         order per_request;
--         next_upstream_statuses error timeout 5xx;
--         next_upstream_timeout 60s;
--     }
-- @
--
-- ==== File /nginx.conf/: location /\/upstrand/
-- @
--         location \/upstrand {
--             proxy_pass http:\/\/__/$upstrand\_utest/__;
--         }
-- @

-- | Upstream name.
type UName = Text

-- | Domain name or IP address with or without port.
type SAddress = Text

-- | DNS query model of the upstream(s).
--
-- There are 4 ways to get the list of server addresses:
--
-- - query /A/ records on a weighted list of domain names,
-- - the same as the previous, but distribute collected servers among a list of
--   upstreams according to the weights set in the name list,
-- - query an /SRV/ record on a single service name and then query /A/ records
--   on the collected list of domain names,
-- - the same as the previous, but distribute collected servers among a list of
--   upstreams according to the collected priorities.
--
-- Particularly, in /SRV/ queries priorities are taken from values of
-- 'srvPriority', the less this value the higher the priority. In /A/ queries
-- priorities are taken from v'WeightedList', the higher the weight the higher
-- the priority.
--
-- Weights of individual servers depend on both priority policy and type of the
-- query:
--
-- - /single priority, A query/: weights are taken from v'WeightedList',
-- - /priority list, A query/: no weights are specified as the values from
--   v'WeightedList' are used for the priority list parameterization,
-- - /single priority, SRV query/: no weights are specified as it is not clear
--   how to choose them correctly from the two parameters 'srvPriority' and
--   'srvWeight',
-- - /priority list, SRV query/: weights are taken from 'srvWeight'.
--
-- Names in the /QueryA/ name list may contain suffix /:port/ (a port number)
-- which is ignored in 'collectA' and only appended to values of 'sAddr'
-- collected by 'collectServerData'.
data UQuery = QueryA NameList UNamePriorityPolicy  -- ^ Query /A/ records
            | QuerySRV Name UNamePriorityPolicy    -- ^ Query an /SRV/ record
            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

-- | Weighted list.
--
-- A list of elements optionally annotated by weight values.
data WeightedList a = Singleton a               -- ^ List with a single element
                    | PlainList [a]             -- ^ Plain list without weights
                    | WeightedList [(a, Word)]  -- ^ Weighted list
                    deriving (ReadPrec [WeightedList a]
ReadPrec (WeightedList a)
Int -> ReadS (WeightedList a)
ReadS [WeightedList a]
(Int -> ReadS (WeightedList a))
-> ReadS [WeightedList a]
-> ReadPrec (WeightedList a)
-> ReadPrec [WeightedList a]
-> Read (WeightedList a)
forall a. Read a => ReadPrec [WeightedList a]
forall a. Read a => ReadPrec (WeightedList a)
forall a. Read a => Int -> ReadS (WeightedList a)
forall a. Read a => ReadS [WeightedList a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Read a => Int -> ReadS (WeightedList a)
readsPrec :: Int -> ReadS (WeightedList a)
$creadList :: forall a. Read a => ReadS [WeightedList a]
readList :: ReadS [WeightedList a]
$creadPrec :: forall a. Read a => ReadPrec (WeightedList a)
readPrec :: ReadPrec (WeightedList a)
$creadListPrec :: forall a. Read a => ReadPrec [WeightedList a]
readListPrec :: ReadPrec [WeightedList a]
Read, (forall m. Monoid m => WeightedList m -> m)
-> (forall m a. Monoid m => (a -> m) -> WeightedList a -> m)
-> (forall m a. Monoid m => (a -> m) -> WeightedList a -> m)
-> (forall a b. (a -> b -> b) -> b -> WeightedList a -> b)
-> (forall a b. (a -> b -> b) -> b -> WeightedList a -> b)
-> (forall b a. (b -> a -> b) -> b -> WeightedList a -> b)
-> (forall b a. (b -> a -> b) -> b -> WeightedList a -> b)
-> (forall a. (a -> a -> a) -> WeightedList a -> a)
-> (forall a. (a -> a -> a) -> WeightedList a -> a)
-> (forall a. WeightedList a -> [a])
-> (forall a. WeightedList a -> Bool)
-> (forall a. WeightedList a -> Int)
-> (forall a. Eq a => a -> WeightedList a -> Bool)
-> (forall a. Ord a => WeightedList a -> a)
-> (forall a. Ord a => WeightedList a -> a)
-> (forall a. Num a => WeightedList a -> a)
-> (forall a. Num a => WeightedList a -> a)
-> Foldable WeightedList
forall a. Eq a => a -> WeightedList a -> Bool
forall a. Num a => WeightedList a -> a
forall a. Ord a => WeightedList a -> a
forall m. Monoid m => WeightedList m -> m
forall a. WeightedList a -> Bool
forall a. WeightedList a -> Int
forall a. WeightedList a -> [a]
forall a. (a -> a -> a) -> WeightedList a -> a
forall m a. Monoid m => (a -> m) -> WeightedList a -> m
forall b a. (b -> a -> b) -> b -> WeightedList a -> b
forall a b. (a -> b -> b) -> b -> WeightedList a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => WeightedList m -> m
fold :: forall m. Monoid m => WeightedList m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> WeightedList a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> WeightedList a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> WeightedList a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> WeightedList a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> WeightedList a -> b
foldr :: forall a b. (a -> b -> b) -> b -> WeightedList a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> WeightedList a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> WeightedList a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> WeightedList a -> b
foldl :: forall b a. (b -> a -> b) -> b -> WeightedList a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> WeightedList a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> WeightedList a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> WeightedList a -> a
foldr1 :: forall a. (a -> a -> a) -> WeightedList a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> WeightedList a -> a
foldl1 :: forall a. (a -> a -> a) -> WeightedList a -> a
$ctoList :: forall a. WeightedList a -> [a]
toList :: forall a. WeightedList a -> [a]
$cnull :: forall a. WeightedList a -> Bool
null :: forall a. WeightedList a -> Bool
$clength :: forall a. WeightedList a -> Int
length :: forall a. WeightedList a -> Int
$celem :: forall a. Eq a => a -> WeightedList a -> Bool
elem :: forall a. Eq a => a -> WeightedList a -> Bool
$cmaximum :: forall a. Ord a => WeightedList a -> a
maximum :: forall a. Ord a => WeightedList a -> a
$cminimum :: forall a. Ord a => WeightedList a -> a
minimum :: forall a. Ord a => WeightedList a -> a
$csum :: forall a. Num a => WeightedList a -> a
sum :: forall a. Num a => WeightedList a -> a
$cproduct :: forall a. Num a => WeightedList a -> a
product :: forall a. Num a => WeightedList a -> a
Foldable)

-- | Weighted list of domain names.
type NameList = WeightedList Name

-- | Priority policy.
--
-- Specifies how to distribute collected items by priorities. In particular,
-- /PriorityPolicy UName/ specifies how to distribute collected servers among
-- the given upstreams.
data PriorityPolicy a = SinglePriority a  -- ^ All items go to a single element
                      | PriorityList [a]  -- ^ Distribute items by priorities
                      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

-- | Priority policy of upstream names.
type UNamePriorityPolicy = PriorityPolicy UName

-- | Upstream configuration.
--
-- Includes DNS query model and parameters for Nginx /server/ description.
-- Values of /uMaxFails/ and /uFailTimeout/ get assigned to each collected
-- server as /max_fails/ and /fail_timeout/ respectively. Note that setting of
-- parameters /max_conns/, /backup/ and /down/ is not supported.
data UData = UData { UData -> UQuery
uQuery       :: UQuery  -- ^ DNS query model
                   , UData -> Int
uMaxFails    :: Int     -- ^ /max_fails/
                   , UData -> Int
uFailTimeout :: Int     -- ^ /fail_timeout/
                   } 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

-- | Server data.
--
-- The fields map exactly to parameters from Nginx /server/ description.
data ServerData = ServerData { ServerData -> UName
sAddr        :: SAddress   -- ^ Server address
                             , ServerData -> UName
sHost        :: SAddress   -- ^ Server host name
                             , ServerData -> Maybe Int
sWeight      :: Maybe Int  -- ^ /weight/
                             , ServerData -> Maybe Int
sMaxFails    :: Maybe Int  -- ^ /max_fails/
                             , ServerData -> Maybe Int
sFailTimeout :: Maybe Int  -- ^ /fail_timeout/
                             } 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 ToJSON ServerData where
    toJSON :: ServerData -> Value
toJSON ServerData {Maybe Int
UName
sAddr :: ServerData -> UName
sHost :: ServerData -> UName
sWeight :: ServerData -> Maybe Int
sMaxFails :: ServerData -> Maybe Int
sFailTimeout :: ServerData -> Maybe Int
sAddr :: UName
sHost :: 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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=      UName
sAddr
                           , 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
"host"   Key -> UName -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=      UName
sHost
                           , (Key
"weight"       Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=) (Int -> Pair) -> Maybe Int -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
sFailTimeout
                           ]

-- | Collected server data.
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
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
{-# 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)
httpLbsBrReadWithTimeout Manager
httpManager

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

-- | Queries an /A/ record for the given domain name.
--
-- Returns a list of IP addresses and the minimum value of their TTLs. If the
-- list is empty, then the returned TTL value gets taken from the first
-- argument.
collectA
    :: TTL                      -- ^ Fallback TTL value
    -> Name                     -- ^ Domain name
    -> IO (TTL, [IPv4])
collectA :: TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL (Name ByteString
n) = do
    ![(TTL, IPv4)]
srv <- Name -> IO [(TTL, IPv4)]
queryA (Name -> IO [(TTL, IPv4)]) -> Name -> IO [(TTL, IPv4)]
forall a b. (a -> b) -> a -> b
$ ByteString -> Name
Name (ByteString -> Name) -> ByteString -> Name
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
C8.takeWhile (Char
':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) ByteString
n
    (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)

-- | Queries an /SRV/ record for the given service name.
--
-- After getting the /SRV/ record, runs 'collectA' for each collected element.
--
-- Returns a list of pairs /(Domain name, IP address)/ wrapped in an 'SRV'
-- container and the minimum value of their TTLs. If the list is empty, then
-- the returned TTL value gets taken from the first argument. Note that trailing
-- dots in the collected domain names (as in /www.mycompany.com./) get removed
-- in the returned list.
collectSRV
    :: TTL                      -- ^ Fallback TTL value
    -> Name                     -- ^ Service name
    -> IO (TTL, [SRV (Name, IPv4)])
collectSRV :: TTL -> Name -> IO (TTL, [SRV (Name, IPv4)])
collectSRV TTL
lTTL Name
name = do
    ![(TTL, SRV Name)]
srv <- Name -> IO [(TTL, SRV Name)]
querySRV Name
name
    ![(TTL, [SRV (Name, IPv4)])]
srv' <- ((TTL, SRV Name) -> IO (TTL, [SRV (Name, IPv4)]))
-> [(TTL, SRV Name)] -> IO [(TTL, [SRV (Name, IPv4)])]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently
                 ((\s :: SRV Name
s@SRV {Word16
Name
srvPriority :: forall l. SRV l -> Word16
srvWeight :: forall l. SRV l -> Word16
srvPriority :: Word16
srvWeight :: Word16
srvPort :: Word16
srvTarget :: Name
srvPort :: forall l. SRV l -> Word16
srvTarget :: forall l. SRV l -> l
..} ->
                     ([IPv4] -> [SRV (Name, IPv4)])
-> (TTL, [IPv4]) -> (TTL, [SRV (Name, IPv4)])
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 ((IPv4 -> SRV (Name, IPv4)) -> [IPv4] -> [SRV (Name, IPv4)]
forall a b. (a -> b) -> [a] -> [b]
map ((IPv4 -> SRV (Name, IPv4)) -> [IPv4] -> [SRV (Name, IPv4)])
-> (IPv4 -> SRV (Name, IPv4)) -> [IPv4] -> [SRV (Name, IPv4)]
forall a b. (a -> b) -> a -> b
$ \IPv4
v -> (, IPv4
v) (Name -> (Name, IPv4)) -> (Name -> Name) -> Name -> (Name, IPv4)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
removeTrailingDot (Name -> (Name, IPv4)) -> SRV Name -> SRV (Name, IPv4)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SRV Name
s) ((TTL, [IPv4]) -> (TTL, [SRV (Name, IPv4)]))
-> IO (TTL, [IPv4]) -> IO (TTL, [SRV (Name, IPv4)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL Name
srvTarget
                  ) (SRV Name -> IO (TTL, [SRV (Name, IPv4)]))
-> ((TTL, SRV Name) -> SRV Name)
-> (TTL, SRV Name)
-> IO (TTL, [SRV (Name, 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 (Name, IPv4)]) -> IO (TTL, [SRV (Name, 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 (Name, IPv4)]) -> TTL)
-> [(TTL, [SRV (Name, IPv4)])] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, [SRV (Name, IPv4)]) -> TTL
forall a b. (a, b) -> a
fst [(TTL, [SRV (Name, IPv4)])]
srv')
           ,((TTL, [SRV (Name, IPv4)]) -> [SRV (Name, IPv4)])
-> [(TTL, [SRV (Name, IPv4)])] -> [SRV (Name, IPv4)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TTL, [SRV (Name, IPv4)]) -> [SRV (Name, IPv4)]
forall a b. (a, b) -> b
snd [(TTL, [SRV (Name, IPv4)])]
srv'
           )
    where removeTrailingDot :: Name -> Name
removeTrailingDot (Name ByteString
v) = ByteString -> Name
Name (ByteString -> Name) -> ByteString -> Name
forall a b. (a -> b) -> a -> b
$
              ByteString
-> ((ByteString, Char) -> ByteString)
-> Maybe (ByteString, Char)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
v (\case (ByteString
v', Char
'.') -> ByteString
v'; (ByteString, Char)
_ -> ByteString
v) (Maybe (ByteString, Char) -> ByteString)
-> Maybe (ByteString, Char) -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (ByteString, Char)
C8.unsnoc ByteString
v

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
""

partitionByPriority :: (Eq b, Ord b) => (a -> b) -> [a] -> [[a]]
partitionByPriority :: forall b a. (Eq b, Ord b) => (a -> b) -> [a] -> [[a]]
partitionByPriority a -> b
f = (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) (b -> b -> Bool) -> (a -> b) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f) ([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn a -> b
f

zipWithOtherRepeatLast :: [a] -> [b] -> [(a, b)]
zipWithOtherRepeatLast :: forall a b. [a] -> [b] -> [(a, b)]
zipWithOtherRepeatLast [a]
_ [] = []
zipWithOtherRepeatLast [a]
xs [b]
other = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs ([b] -> [(a, b)]) -> [b] -> [(a, b)]
forall a b. (a -> b) -> a -> b
$ [b]
other [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ b -> [b]
forall a. a -> [a]
repeat ([b] -> b
forall a. HasCallStack => [a] -> a
last [b]
other)

ipv4ToServerData :: UData -> UNamePriorityPolicy -> Name -> Maybe Word ->
    IPv4 -> ServerData
ipv4ToServerData :: UData
-> UNamePriorityPolicy -> Name -> Maybe Word -> IPv4 -> ServerData
ipv4ToServerData UData {Int
UQuery
uQuery :: UData -> UQuery
uMaxFails :: UData -> Int
uFailTimeout :: UData -> Int
uQuery :: UQuery
uMaxFails :: Int
uFailTimeout :: Int
..} UNamePriorityPolicy
policy (Name ByteString
n) Maybe Word
weight IPv4
a =
    let (ByteString
n', ByteString
port) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.span (Char
':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=) ByteString
n
        showAddr :: IPv4 -> ByteString -> String
showAddr IPv4
i ByteString
p = IPv4 -> String
showIPv4 IPv4
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack ByteString
p
    in UName -> 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 -> ByteString -> String
showAddr IPv4
a ByteString
port) (ByteString -> UName
T.decodeUtf8 ByteString
n')
           (case UNamePriorityPolicy
policy of
                  SinglePriority UName
_ -> Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Maybe Word -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word
weight
                  PriorityList [UName]
_ -> 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 -> UNamePriorityPolicy -> SRV (Name, IPv4) ->
    ServerData
srvToServerData :: UData -> UNamePriorityPolicy -> SRV (Name, IPv4) -> ServerData
srvToServerData UData {Int
UQuery
uQuery :: UData -> UQuery
uMaxFails :: UData -> Int
uFailTimeout :: UData -> Int
uQuery :: UQuery
uMaxFails :: Int
uFailTimeout :: Int
..} UNamePriorityPolicy
policy SRV {Word16
(Name, IPv4)
srvPriority :: forall l. SRV l -> Word16
srvWeight :: forall l. SRV l -> Word16
srvPort :: forall l. SRV l -> Word16
srvTarget :: forall l. SRV l -> l
srvPriority :: Word16
srvWeight :: Word16
srvPort :: Word16
srvTarget :: (Name, IPv4)
..} =
    let (Name ByteString
n, IPv4
a) = (Name, IPv4)
srvTarget
        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
    in UName -> 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
a Word16
srvPort) (ByteString -> UName
T.decodeUtf8 ByteString
n)
          (case UNamePriorityPolicy
policy of
               SinglePriority UName
_ -> Maybe Int
forall a. Maybe a
Nothing
               PriorityList [UName]
_ -> 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)

-- | Collects server data for the given upstream configuration.
--
-- Returns the collected server data and the minimum value of all the collected
-- TTLs. If this TTL value, having been converted into a 'TimeInterval', is not
-- bigger than /maxWait/, then it defines in how long time service
-- /collectUpstreams/, which calls this function, will restart again.
collectServerData
    :: TTL                      -- ^ Fallback TTL value
    -> UData                    -- ^ Upstream configuration
    -> IO (TTL, CollectedServerData)
collectServerData :: TTL -> UData -> IO (TTL, CollectedServerData)
collectServerData TTL
lTTL (UData (QueryA NameList
ns UNamePriorityPolicy
p) Int
_ Int
_)
    | NameList -> Bool
forall a. WeightedList a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null NameList
ns = (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)
    | PriorityList [] <- UNamePriorityPolicy
p = (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
                                     (WeightedList [(Name, Word)]
ns) p :: UNamePriorityPolicy
p@(PriorityList [UName]
pl)
                                 ) Int
_ Int
_
                          ) = do
    [((Name, Word), (TTL, [IPv4]))]
a <- ((Name, Word) -> IO ((Name, Word), (TTL, [IPv4])))
-> [(Name, Word)] -> IO [((Name, Word), (TTL, [IPv4]))]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (\nw :: (Name, Word)
nw@(Name
n, Word
_) -> ((Name, Word)
nw, ) ((TTL, [IPv4]) -> ((Name, Word), (TTL, [IPv4])))
-> IO (TTL, [IPv4]) -> IO ((Name, Word), (TTL, [IPv4]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL Name
n) [(Name, Word)]
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)
-> ([[(Word, ServerData)]] -> CollectedServerData)
-> ([TTL], [[(Word, 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. Ord k => [(k, a)] -> Map k a
M.fromList ([(UName, [ServerData])] -> CollectedServerData)
-> ([[(Word, ServerData)]] -> [(UName, [ServerData])])
-> [[(Word, ServerData)]]
-> CollectedServerData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UName] -> [[ServerData]] -> [(UName, [ServerData])]
forall a b. [a] -> [b] -> [(a, b)]
zipWithOtherRepeatLast [UName]
pl
            ([[ServerData]] -> [(UName, [ServerData])])
-> ([[(Word, ServerData)]] -> [[ServerData]])
-> [[(Word, ServerData)]]
-> [(UName, [ServerData])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Word, ServerData)] -> [ServerData])
-> [[(Word, ServerData)]] -> [[ServerData]]
forall a b. (a -> b) -> [a] -> [b]
map (((Word, ServerData) -> ServerData)
-> [(Word, ServerData)] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (Word, ServerData) -> ServerData
forall a b. (a, b) -> b
snd) ([[(Word, ServerData)]] -> [[ServerData]])
-> ([[(Word, ServerData)]] -> [[(Word, ServerData)]])
-> [[(Word, ServerData)]]
-> [[ServerData]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word, ServerData) -> Down Word)
-> [(Word, ServerData)] -> [[(Word, ServerData)]]
forall b a. (Eq b, Ord b) => (a -> b) -> [a] -> [[a]]
partitionByPriority (Word -> Down Word
forall a. a -> Down a
Down (Word -> Down Word)
-> ((Word, ServerData) -> Word) -> (Word, ServerData) -> Down Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word, ServerData) -> Word
forall a b. (a, b) -> a
fst) ([(Word, ServerData)] -> [[(Word, ServerData)]])
-> ([[(Word, ServerData)]] -> [(Word, ServerData)])
-> [[(Word, ServerData)]]
-> [[(Word, ServerData)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Word, ServerData)]] -> [(Word, ServerData)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([TTL], [[(Word, ServerData)]]) -> (TTL, CollectedServerData))
-> ([TTL], [[(Word, ServerData)]]) -> (TTL, CollectedServerData)
forall a b. (a -> b) -> a -> b
$
                (((Name, Word), (TTL, [IPv4]))
 -> ([TTL], [[(Word, ServerData)]])
 -> ([TTL], [[(Word, ServerData)]]))
-> ([TTL], [[(Word, ServerData)]])
-> [((Name, Word), (TTL, [IPv4]))]
-> ([TTL], [[(Word, ServerData)]])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\((Name
n, Word
w), (TTL
t, [IPv4]
s)) ([TTL]
ts, [[(Word, ServerData)]]
ss) ->
                          (TTL
t TTL -> [TTL] -> [TTL]
forall a. a -> [a] -> [a]
: [TTL]
ts
                           -- sort is required because resolver may rotate
                           -- servers which means that the same data may differ
                           -- after every single check; this note regards to
                           -- other clauses of this function as well
                          ,[(Word, ServerData)] -> [(Word, ServerData)]
forall a. Ord a => [a] -> [a]
sort ((IPv4 -> (Word, ServerData)) -> [IPv4] -> [(Word, ServerData)]
forall a b. (a -> b) -> [a] -> [b]
map ((Word
w ,) (ServerData -> (Word, ServerData))
-> (IPv4 -> ServerData) -> IPv4 -> (Word, ServerData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                         UData
-> UNamePriorityPolicy -> Name -> Maybe Word -> IPv4 -> ServerData
ipv4ToServerData UData
ud UNamePriorityPolicy
p Name
n Maybe Word
forall a. Maybe a
Nothing
                                     ) [IPv4]
s
                                ) [(Word, ServerData)]
-> [[(Word, ServerData)]] -> [[(Word, ServerData)]]
forall a. a -> [a] -> [a]
: [[(Word, ServerData)]]
ss
                          )
                      ) ([], []) [((Name, Word), (TTL, [IPv4]))]
a
collectServerData TTL
lTTL ud :: UData
ud@(UData (QueryA NameList
ns UNamePriorityPolicy
p) Int
_ Int
_) = do
    let ns' :: [(Name, Maybe Word)]
ns' = case NameList
ns of
                  Singleton Name
n -> (Name, Maybe Word) -> [(Name, Maybe Word)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Maybe Word
forall a. Maybe a
Nothing)
                  PlainList [Name]
ns'' -> (Name -> (Name, Maybe Word)) -> [Name] -> [(Name, Maybe Word)]
forall a b. (a -> b) -> [a] -> [b]
map (, Maybe Word
forall a. Maybe a
Nothing) [Name]
ns''
                  WeightedList [(Name, Word)]
ns'' -> ((Name, Word) -> (Name, Maybe Word))
-> [(Name, Word)] -> [(Name, Maybe Word)]
forall a b. (a -> b) -> [a] -> [b]
map ((Word -> Maybe Word) -> (Name, Word) -> (Name, Maybe Word)
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 Word -> Maybe Word
forall a. a -> Maybe a
Just) [(Name, Word)]
ns''
    [((Name, Maybe Word), (TTL, [IPv4]))]
a <- ((Name, Maybe Word) -> IO ((Name, Maybe Word), (TTL, [IPv4])))
-> [(Name, Maybe Word)] -> IO [((Name, Maybe Word), (TTL, [IPv4]))]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (\nw :: (Name, Maybe Word)
nw@(Name
n, Maybe Word
_) -> ((Name, Maybe Word)
nw, ) ((TTL, [IPv4]) -> ((Name, Maybe Word), (TTL, [IPv4])))
-> IO (TTL, [IPv4]) -> IO ((Name, Maybe Word), (TTL, [IPv4]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL Name
n) [(Name, Maybe Word)]
ns'
    let f :: a -> Map UName a
f = case UNamePriorityPolicy
p of
                SinglePriority UName
u -> UName -> a -> Map UName a
forall k a. k -> a -> Map k a
M.singleton UName
u
                PriorityList [UName]
pl -> \a
v -> [(UName, a)] -> Map UName a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(UName, a)] -> Map UName a) -> [(UName, a)] -> Map UName a
forall a b. (a -> b) -> a -> b
$ (UName -> (UName, a)) -> [UName] -> [(UName, a)]
forall a b. (a -> b) -> [a] -> [b]
map (, a
v) [UName]
pl
    (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')
*** [ServerData] -> CollectedServerData
forall {a}. a -> Map UName a
f ([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
$
            (((Name, Maybe Word), (TTL, [IPv4]))
 -> ([TTL], [[ServerData]]) -> ([TTL], [[ServerData]]))
-> ([TTL], [[ServerData]])
-> [((Name, Maybe Word), (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 (\((Name
n, Maybe Word
w), (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
-> UNamePriorityPolicy -> Name -> Maybe Word -> IPv4 -> ServerData
ipv4ToServerData UData
ud UNamePriorityPolicy
p Name
n Maybe Word
w) [IPv4]
s) [ServerData] -> [[ServerData]] -> [[ServerData]]
forall a. a -> [a] -> [a]
: [[ServerData]]
ss)
                  ) ([], []) [((Name, Maybe Word), (TTL, [IPv4]))]
a
collectServerData TTL
lTTL ud :: UData
ud@(UData (QuerySRV Name
n p :: UNamePriorityPolicy
p@(SinglePriority UName
u)) Int
_ Int
_) = do
    (TTL
wt, [SRV (Name, IPv4)]
srv) <- TTL -> Name -> IO (TTL, [SRV (Name, 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 (Name, IPv4) -> ServerData)
-> [SRV (Name, IPv4)] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (UData -> UNamePriorityPolicy -> SRV (Name, IPv4) -> ServerData
srvToServerData UData
ud UNamePriorityPolicy
p) [SRV (Name, 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 p :: UNamePriorityPolicy
p@(PriorityList [UName]
pl)) Int
_ Int
_ ) = do
    (TTL
wt, [SRV (Name, IPv4)]
srv) <- TTL -> Name -> IO (TTL, [SRV (Name, IPv4)])
collectSRV TTL
lTTL Name
n
    let srv' :: [(UName, [SRV (Name, IPv4)])]
srv' = [UName] -> [[SRV (Name, IPv4)]] -> [(UName, [SRV (Name, IPv4)])]
forall a b. [a] -> [b] -> [(a, b)]
zipWithOtherRepeatLast [UName]
pl ([[SRV (Name, IPv4)]] -> [(UName, [SRV (Name, IPv4)])])
-> [[SRV (Name, IPv4)]] -> [(UName, [SRV (Name, IPv4)])]
forall a b. (a -> b) -> a -> b
$ (SRV (Name, IPv4) -> Word16)
-> [SRV (Name, IPv4)] -> [[SRV (Name, IPv4)]]
forall b a. (Eq b, Ord b) => (a -> b) -> [a] -> [[a]]
partitionByPriority SRV (Name, IPv4) -> Word16
forall l. SRV l -> Word16
srvPriority [SRV (Name, 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 (Name, IPv4)]) -> (UName, [ServerData]))
-> [(UName, [SRV (Name, IPv4)])] -> [(UName, [ServerData])]
forall a b. (a -> b) -> [a] -> [b]
map (([SRV (Name, IPv4)] -> [ServerData])
-> (UName, [SRV (Name, 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 (Name, IPv4)] -> [ServerData])
 -> (UName, [SRV (Name, IPv4)]) -> (UName, [ServerData]))
-> ([SRV (Name, IPv4)] -> [ServerData])
-> (UName, [SRV (Name, IPv4)])
-> (UName, [ServerData])
forall a b. (a -> b) -> a -> b
$ [ServerData] -> [ServerData]
forall a. Ord a => [a] -> [a]
sort ([ServerData] -> [ServerData])
-> ([SRV (Name, IPv4)] -> [ServerData])
-> [SRV (Name, IPv4)]
-> [ServerData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SRV (Name, IPv4) -> ServerData)
-> [SRV (Name, IPv4)] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (UData -> UNamePriorityPolicy -> SRV (Name, IPv4) -> ServerData
srvToServerData UData
ud UNamePriorityPolicy
p)) [(UName, [SRV (Name, IPv4)])]
srv'
           )

collectUpstreams :: Conf -> NgxExportService
collectUpstreams :: Conf -> NgxExportService
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 -> NgxExportService
forall a b. a -> b -> a
const (IO ByteString -> NgxExportService)
-> IO ByteString -> NgxExportService
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.
(HasCallStack, 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

-- a list of fully qualified URLs such as 'http://../..' or 'https://../..'
type Upconf = [Text]

signalUpconf :: Upconf -> NgxExportService
signalUpconf :: [UName] -> NgxExportService
signalUpconf = IO () -> NgxExportService
forall a b. IO a -> b -> IO ByteString
voidHandler' (IO () -> NgxExportService)
-> ([UName] -> IO ()) -> [UName] -> NgxExportService
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UName -> IO ByteString) -> [UName] -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ UName -> IO ByteString
getUrl

ngxExportSimpleServiceTyped 'signalUpconf ''Upconf $
    PersistentService Nothing