{-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns, NumDecimals #-}
{-# LANGUAGE DerivingStrategies, DeriveAnyClass, DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric, 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           Language.Haskell.TH hiding (Name)
import           Network.DNS
import           Network.HTTP.Client
import           Network.HTTP.Client.TLS (newTlsManager)
import           Network.HTTP.Client.BrReadWithTimeout
import           Data.ByteString (ByteString)
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 qualified Data.HashMap.Strict as HM
import           Data.HashMap.Strict (HashMap)
import           Data.Hashable
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
import           Unsafe.Coerce
import           GHC.Generics

-- $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, WeightedList a -> WeightedList a -> Bool
(WeightedList a -> WeightedList a -> Bool)
-> (WeightedList a -> WeightedList a -> Bool)
-> Eq (WeightedList a)
forall a. Eq a => WeightedList a -> WeightedList a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => WeightedList a -> WeightedList a -> Bool
== :: WeightedList a -> WeightedList a -> Bool
$c/= :: forall a. Eq a => WeightedList a -> WeightedList a -> Bool
/= :: WeightedList a -> WeightedList a -> Bool
Eq, (forall x. WeightedList a -> Rep (WeightedList a) x)
-> (forall x. Rep (WeightedList a) x -> WeightedList a)
-> Generic (WeightedList a)
forall x. Rep (WeightedList a) x -> WeightedList a
forall x. WeightedList a -> Rep (WeightedList a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (WeightedList a) x -> WeightedList a
forall a x. WeightedList a -> Rep (WeightedList a) x
$cfrom :: forall a x. WeightedList a -> Rep (WeightedList a) x
from :: forall x. WeightedList a -> Rep (WeightedList a) x
$cto :: forall a x. Rep (WeightedList a) x -> WeightedList a
to :: forall x. Rep (WeightedList a) x -> WeightedList a
Generic, (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)
                    deriving anyclass Eq (WeightedList a)
Eq (WeightedList a) =>
(Int -> WeightedList a -> Int)
-> (WeightedList a -> Int) -> Hashable (WeightedList a)
Int -> WeightedList a -> Int
WeightedList a -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall a. Hashable a => Eq (WeightedList a)
forall a. Hashable a => Int -> WeightedList a -> Int
forall a. Hashable a => WeightedList a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> WeightedList a -> Int
hashWithSalt :: Int -> WeightedList a -> Int
$chash :: forall a. Hashable a => WeightedList a -> Int
hash :: WeightedList a -> Int
Hashable

-- | 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, PriorityPolicy a -> PriorityPolicy a -> Bool
(PriorityPolicy a -> PriorityPolicy a -> Bool)
-> (PriorityPolicy a -> PriorityPolicy a -> Bool)
-> Eq (PriorityPolicy a)
forall a. Eq a => PriorityPolicy a -> PriorityPolicy a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PriorityPolicy a -> PriorityPolicy a -> Bool
== :: PriorityPolicy a -> PriorityPolicy a -> Bool
$c/= :: forall a. Eq a => PriorityPolicy a -> PriorityPolicy a -> Bool
/= :: PriorityPolicy a -> PriorityPolicy a -> Bool
Eq, (forall x. PriorityPolicy a -> Rep (PriorityPolicy a) x)
-> (forall x. Rep (PriorityPolicy a) x -> PriorityPolicy a)
-> Generic (PriorityPolicy a)
forall x. Rep (PriorityPolicy a) x -> PriorityPolicy a
forall x. PriorityPolicy a -> Rep (PriorityPolicy a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PriorityPolicy a) x -> PriorityPolicy a
forall a x. PriorityPolicy a -> Rep (PriorityPolicy a) x
$cfrom :: forall a x. PriorityPolicy a -> Rep (PriorityPolicy a) x
from :: forall x. PriorityPolicy a -> Rep (PriorityPolicy a) x
$cto :: forall a x. Rep (PriorityPolicy a) x -> PriorityPolicy a
to :: forall x. Rep (PriorityPolicy a) x -> PriorityPolicy a
Generic)
                      deriving anyclass Eq (PriorityPolicy a)
Eq (PriorityPolicy a) =>
(Int -> PriorityPolicy a -> Int)
-> (PriorityPolicy a -> Int) -> Hashable (PriorityPolicy a)
Int -> PriorityPolicy a -> Int
PriorityPolicy a -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall a. Hashable a => Eq (PriorityPolicy a)
forall a. Hashable a => Int -> PriorityPolicy a -> Int
forall a. Hashable a => PriorityPolicy a -> Int
$chashWithSalt :: forall a. Hashable a => Int -> PriorityPolicy a -> Int
hashWithSalt :: Int -> PriorityPolicy a -> Int
$chash :: forall a. Hashable a => PriorityPolicy a -> Int
hash :: PriorityPolicy a -> Int
Hashable

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

-- FIXME: an awkward hack to avoid using orphan instance Hashable Name,
-- the Template Haskell splice below produces the following definitions:
--   1. data HashUQuery deriving Hashable which is essentially data UQuery
--      with all Name entries replaced with ByteString,
--   2. hashUQuery :: UQuery -> HashUQuery which is mere unsafeCoerce
do
    TyConI (DataD [] name [] Nothing cs _) <- reify ''UQuery
    let name' = nameBase name
        (hashU, hashL) = ("Hash", "hash")
        nameHashT = mkName $ hashU ++ name'
        nameHashF = mkName $ hashL ++ name'
    sequence
        [dataD (return []) nameHashT [] Nothing
            (map (\case
                      NormalC n ts ->
                          normalC (mkName $ hashU ++ nameBase n) $
                              map (\(b, t) -> bangType (return b) $
                                      case t of
                                          ConT c
                                              | c == ''Name -> [t|ByteString|]
                                              | c == ''NameList ->
                                                  [t|WeightedList ByteString|]
                                          _ -> return t
                                  ) ts
                      _ -> undefined
                 ) cs
            ) [derivClause Nothing [[t|Eq|], [t|Generic|]]
              ,derivClause (Just AnyclassStrategy) [[t|Hashable|]]
              ]
        ,sigD nameHashF [t|$(conT name) -> $(conT nameHashT)|]
        ,funD nameHashF [clause [] (normalB [|unsafeCoerce|]) []]
        ]

collectedServerData ::
    IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
collectedServerData :: IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
collectedServerData = IO (IORef (TimeInterval, HashMap HashUQuery CollectedServerData))
-> IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
forall a. IO a -> a
unsafePerformIO (IO (IORef (TimeInterval, HashMap HashUQuery CollectedServerData))
 -> IORef (TimeInterval, HashMap HashUQuery CollectedServerData))
-> IO
     (IORef (TimeInterval, HashMap HashUQuery CollectedServerData))
-> IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
forall a b. (a -> b) -> a -> b
$ (TimeInterval, HashMap HashUQuery CollectedServerData)
-> IO
     (IORef (TimeInterval, HashMap HashUQuery CollectedServerData))
forall a. a -> IO (IORef a)
newIORef (TimeInterval
Unset, HashMap HashUQuery CollectedServerData
forall k v. HashMap k v
HM.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 port :: ByteString
port = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ (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, HashMap HashUQuery CollectedServerData
old) <- IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
-> IO (TimeInterval, HashMap HashUQuery CollectedServerData)
forall a. IORef a -> IO a
readIORef IORef (TimeInterval, HashMap HashUQuery 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)
    [(HashUQuery, (TTL, CollectedServerData))]
srv <- TimeInterval
-> IO [(HashUQuery, (TTL, CollectedServerData))]
-> IO [(HashUQuery, (TTL, CollectedServerData))]
forall {a}. TimeInterval -> IO a -> IO a
handleCollectErrors TimeInterval
waitOnException (IO [(HashUQuery, (TTL, CollectedServerData))]
 -> IO [(HashUQuery, (TTL, CollectedServerData))])
-> IO [(HashUQuery, (TTL, CollectedServerData))]
-> IO [(HashUQuery, (TTL, CollectedServerData))]
forall a b. (a -> b) -> a -> b
$
        (UData -> IO (HashUQuery, (TTL, CollectedServerData)))
-> [UData] -> IO [(HashUQuery, (TTL, CollectedServerData))]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (\u :: UData
u@UData {Int
UQuery
uQuery :: UData -> UQuery
uMaxFails :: UData -> Int
uFailTimeout :: UData -> Int
uQuery :: UQuery
uMaxFails :: Int
uFailTimeout :: Int
..} -> (UQuery -> HashUQuery
hashUQuery UQuery
uQuery, ) ((TTL, CollectedServerData)
 -> (HashUQuery, (TTL, CollectedServerData)))
-> IO (TTL, CollectedServerData)
-> IO (HashUQuery, (TTL, CollectedServerData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            TimeInterval
-> IO (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall {a}. TimeInterval -> IO a -> IO a
withTimeout TimeInterval
responseTimeout
                                (TTL -> UData -> IO (TTL, CollectedServerData)
collectServerData TTL
lTTL UData
u)
                        ) [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
$
            ((HashUQuery, (TTL, CollectedServerData)) -> TTL)
-> [(HashUQuery, (TTL, CollectedServerData))] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map ((TTL, CollectedServerData) -> TTL
forall a b. (a, b) -> a
fst ((TTL, CollectedServerData) -> TTL)
-> ((HashUQuery, (TTL, CollectedServerData))
    -> (TTL, CollectedServerData))
-> (HashUQuery, (TTL, CollectedServerData))
-> TTL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashUQuery, (TTL, CollectedServerData))
-> (TTL, CollectedServerData)
forall a b. (a, b) -> b
snd) [(HashUQuery, (TTL, CollectedServerData))]
srv
        new :: HashMap HashUQuery CollectedServerData
new = [(HashUQuery, CollectedServerData)]
-> HashMap HashUQuery CollectedServerData
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(HashUQuery, CollectedServerData)]
 -> HashMap HashUQuery CollectedServerData)
-> [(HashUQuery, CollectedServerData)]
-> HashMap HashUQuery CollectedServerData
forall a b. (a -> b) -> a -> b
$ ((HashUQuery, (TTL, CollectedServerData))
 -> (HashUQuery, CollectedServerData))
-> [(HashUQuery, (TTL, CollectedServerData))]
-> [(HashUQuery, CollectedServerData)]
forall a b. (a -> b) -> [a] -> [b]
map (((TTL, CollectedServerData) -> CollectedServerData)
-> (HashUQuery, (TTL, CollectedServerData))
-> (HashUQuery, CollectedServerData)
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 (TTL, CollectedServerData) -> CollectedServerData
forall a b. (a, b) -> b
snd) [(HashUQuery, (TTL, CollectedServerData))]
srv
    -- FIXME: when there are multiple instances of the service, a healthy
    -- instance may overwrite a short TTL written by an unhealthy instance which
    -- causes the latter restarts later, and vice versa, an unhealthy instance
    -- may write a short TTL which causes a healthy instance restarts sooner
    if HashMap HashUQuery CollectedServerData
new HashMap HashUQuery CollectedServerData
-> HashMap HashUQuery CollectedServerData -> Bool
forall k v.
(Eq k, Hashable k, Eq v) =>
HashMap k v -> HashMap k v -> Bool
`HM.isSubmapOf` HashMap HashUQuery CollectedServerData
old
        then IO () -> IO ByteString
forall a. IO a -> IO ByteString
voidHandler (IO () -> IO ByteString) -> IO () -> IO ByteString
forall a b. (a -> b) -> a -> b
$
            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, HashMap HashUQuery CollectedServerData)
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
collectedServerData (((TimeInterval, HashMap HashUQuery CollectedServerData)
  -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
 -> IO ())
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
                    (, ()) ((TimeInterval, HashMap HashUQuery CollectedServerData)
 -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> (TimeInterval, HashMap HashUQuery CollectedServerData))
-> (TimeInterval, HashMap HashUQuery CollectedServerData)
-> ((TimeInterval, HashMap HashUQuery CollectedServerData), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeInterval -> TimeInterval)
-> (TimeInterval, HashMap HashUQuery CollectedServerData)
-> (TimeInterval, HashMap HashUQuery 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
forall a b. a -> b -> a
const TimeInterval
nwt)
        else do
            IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
collectedServerData (((TimeInterval, HashMap HashUQuery CollectedServerData)
  -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
 -> IO ())
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
                (, ()) ((TimeInterval, HashMap HashUQuery CollectedServerData)
 -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> (TimeInterval, HashMap HashUQuery CollectedServerData))
-> (TimeInterval, HashMap HashUQuery CollectedServerData)
-> ((TimeInterval, HashMap HashUQuery CollectedServerData), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeInterval -> TimeInterval -> TimeInterval
forall a b. a -> b -> a
const TimeInterval
nwt (TimeInterval -> TimeInterval)
-> (HashMap HashUQuery CollectedServerData
    -> HashMap HashUQuery CollectedServerData)
-> (TimeInterval, HashMap HashUQuery CollectedServerData)
-> (TimeInterval, HashMap HashUQuery 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')
*** (HashMap HashUQuery CollectedServerData
new HashMap HashUQuery CollectedServerData
-> HashMap HashUQuery CollectedServerData
-> HashMap HashUQuery CollectedServerData
forall k v. Eq k => HashMap k v -> HashMap k v -> HashMap k v
`HM.union`))
            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 -> ByteString)
-> CollectedServerData -> ByteString
forall a b. (a -> b) -> a -> b
$ [CollectedServerData] -> CollectedServerData
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ([CollectedServerData] -> CollectedServerData)
-> [CollectedServerData] -> CollectedServerData
forall a b. (a -> b) -> a -> b
$ HashMap HashUQuery CollectedServerData -> [CollectedServerData]
forall k v. HashMap k v -> [v]
HM.elems HashMap HashUQuery 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 :: TimeInterval -> IO a -> IO a
handleCollectErrors TimeInterval
t = (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, HashMap HashUQuery CollectedServerData)
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (TimeInterval, HashMap HashUQuery CollectedServerData)
collectedServerData (((TimeInterval, HashMap HashUQuery CollectedServerData)
  -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
 -> IO ())
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) ((TimeInterval, HashMap HashUQuery CollectedServerData)
 -> ((TimeInterval, HashMap HashUQuery CollectedServerData), ()))
-> ((TimeInterval, HashMap HashUQuery CollectedServerData)
    -> (TimeInterval, HashMap HashUQuery CollectedServerData))
-> (TimeInterval, HashMap HashUQuery CollectedServerData)
-> ((TimeInterval, HashMap HashUQuery CollectedServerData), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeInterval -> TimeInterval)
-> (TimeInterval, HashMap HashUQuery CollectedServerData)
-> (TimeInterval, HashMap HashUQuery 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
forall a b. a -> b -> a
const TimeInterval
t)
              SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e
          withTimeout :: TimeInterval -> IO b -> IO b
withTimeout TimeInterval
t 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
t) 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