{-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns, NumDecimals #-}
{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  NgxExport.Tools.Resolve
-- Copyright   :  (c) Alexey Radkov 2022
-- 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>.
--
-- __An important note.__ Currently, package /resolv/ at
-- [hackage.org](https://hackage.haskell.org/package/resolv) has
-- [a bug](https://github.com/haskell-hvr/resolv/pull/12) which leads to
-- memory leaks on every DNS query. This makes service /collectUpstreams/ 
-- from module /NgxExport.Tools.Resolve/ leak as well, because it makes DNS
-- queries regularly. To prevent memory leaks, you can clone /resolv/ from
-- [this fork](https://github.com/lyokha/resolv) and /v1-install/ it from
-- the source. Or, if you prefer /v2-build/, simply put lines
--
-- @
-- source-repository-package
--     type: git
--     location: https://github.com/lyokha/resolv.git
--     tag: 6a46c2659f79e78defd974849a8120548257cadc
--     post-checkout-command: autoreconf -i
-- @
--
-- into the /cabal.project/ file.

-----------------------------------------------------------------------------

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

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

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

import           Network.DNS
import           Network.HTTP.Client
import qualified Data.ByteString.Lazy as L
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import           Data.IORef
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Maybe
import           Data.Aeson
import           Data.Function
import           Data.List
import           Data.Bits
import           Control.Concurrent.Async
import           Control.Exception
import           Control.Exception.Safe (handleAny)
import           Control.Arrow
import           Control.Monad
import           System.IO.Unsafe
import           System.Timeout

-- $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 /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
--         \'Upconf { upconfAddr = (\"__/\/upconf/__\", \"127.0.0.1:8010\")
--                 }\';
--
--     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. 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 lesser priorities will inhabit upstream
-- /utest1/. Upstream /utest1/ must also be managed by the /upconf/ module. The
-- priority list may contain more than two upstreams, in which case upstreams
-- at the beginning of the list will take higher priorities found in the
-- collected servers, while the last upstream will take the remainder of the
-- priorities.
--
-- 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

-- URL, normally starts with /
type SUrl = Text

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

-- | DNS query model of the upstream(s).
--
-- There are 3 ways to get the list of server addresses:
--
-- - query /A/ records for a list of domain names,
-- - query an /SRV/ record for a single service name and then query /A/ records
--   for 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.
data UQuery = QueryA [Name] UName                   -- ^ Query /A/ records
            | QuerySRV Name (PriorityPolicy UName)  -- ^ 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

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

-- | 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. The weight of an
-- individual server gets picked from the value of 'srvWeight' collected in
-- /SRV/ queries. 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

newtype Upconf = Upconf { Upconf -> (UName, UName)
upconfAddr :: (SUrl, SAddress) } deriving ReadPrec [Upconf]
ReadPrec Upconf
Int -> ReadS Upconf
ReadS [Upconf]
(Int -> ReadS Upconf)
-> ReadS [Upconf]
-> ReadPrec Upconf
-> ReadPrec [Upconf]
-> Read Upconf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Upconf
readsPrec :: Int -> ReadS Upconf
$creadList :: ReadS [Upconf]
readList :: ReadS [Upconf]
$creadPrec :: ReadPrec Upconf
readPrec :: ReadPrec Upconf
$creadListPrec :: ReadPrec [Upconf]
readListPrec :: ReadPrec [Upconf]
Read

-- | Server data.
--
-- The fields map exactly to parameters from Nginx /server/ description.
data ServerData = ServerData { ServerData -> UName
sAddr        :: SAddress   -- ^ Server address
                             , 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 FromJSON ServerData where
    parseJSON :: Value -> Parser ServerData
parseJSON = String
-> (Object -> Parser ServerData) -> Value -> Parser ServerData
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"server_options" ((Object -> Parser ServerData) -> Value -> Parser ServerData)
-> (Object -> Parser ServerData) -> Value -> Parser ServerData
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        UName
sAddr        <- Object
o Object -> Key -> Parser UName
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"addr"
        Maybe Int
sWeight      <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"weight"
        Maybe Int
sMaxFails    <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"max_fails"
        Maybe Int
sFailTimeout <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"fail_timeout"
        ServerData -> Parser ServerData
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerData {Maybe Int
UName
sAddr :: UName
sWeight :: Maybe Int
sMaxFails :: Maybe Int
sFailTimeout :: Maybe Int
sAddr :: UName
sWeight :: Maybe Int
sMaxFails :: Maybe Int
sFailTimeout :: Maybe Int
..}

instance ToJSON ServerData where
    toJSON :: ServerData -> Value
toJSON ServerData {Maybe Int
UName
sAddr :: ServerData -> UName
sWeight :: ServerData -> Maybe Int
sMaxFails :: ServerData -> Maybe Int
sFailTimeout :: ServerData -> Maybe Int
sAddr :: UName
sWeight :: Maybe Int
sMaxFails :: Maybe Int
sFailTimeout :: Maybe Int
..} =
        [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes [ Pair -> Maybe Pair
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pair -> Maybe Pair) -> Pair -> Maybe Pair
forall a b. (a -> b) -> a -> b
$ Key
"addr"   Key -> UName -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.=      UName
sAddr
                           , (Key
"weight"       Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.=) (Int -> Pair) -> Maybe Int -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
sWeight
                           , (Key
"max_fails"    Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.=) (Int -> Pair) -> Maybe Int -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
sMaxFails
                           , (Key
"fail_timeout" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.=) (Int -> Pair) -> Maybe Int -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
sFailTimeout
                           ]

-- | 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 -> Manager) -> IO Manager -> Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
{-# NOINLINE httpManager #-}

getResponse :: Text -> (Request -> IO (Response L.ByteString)) ->
    IO L.ByteString
getResponse :: UName -> (Request -> IO (Response ByteString)) -> IO ByteString
getResponse UName
url = (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response ByteString -> ByteString
forall body. Response body -> body
responseBody (IO (Response ByteString) -> IO ByteString)
-> ((Request -> IO (Response ByteString))
    -> IO (Response ByteString))
-> (Request -> IO (Response ByteString))
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (UName -> String
T.unpack UName
url) IO Request
-> (Request -> IO (Response ByteString))
-> IO (Response ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)

getUrl :: Text -> IO L.ByteString
getUrl :: UName -> IO ByteString
getUrl UName
url = UName -> (Request -> IO (Response ByteString)) -> IO ByteString
getResponse UName
url ((Request -> IO (Response ByteString)) -> IO ByteString)
-> (Request -> IO (Response ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (Request -> Manager -> IO (Response ByteString))
-> Manager -> Request -> IO (Response ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ByteString)
httpLbs Manager
httpManager

queryHTTP :: Text -> Text -> IO L.ByteString
queryHTTP :: UName -> UName -> IO ByteString
queryHTTP = (UName -> IO ByteString
getUrl (UName -> IO ByteString)
-> (UName -> UName) -> UName -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((UName -> UName) -> UName -> IO ByteString)
-> (UName -> UName -> UName) -> UName -> UName -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UName -> UName -> UName) -> UName -> UName -> UName
forall a b c. (a -> b -> c) -> b -> a -> c
flip UName -> UName -> UName
mkAddr
    where mkAddr :: UName -> UName -> UName
mkAddr = ((UName
"http://" UName -> UName -> UName
`T.append`) (UName -> UName) -> (UName -> UName) -> UName -> UName
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((UName -> UName) -> UName -> UName)
-> (UName -> UName -> UName) -> UName -> UName -> UName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UName -> UName -> UName
T.append

minimumTTL :: TTL -> [TTL] -> TTL
minimumTTL :: TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL [] = TTL
lTTL
minimumTTL TTL
_ [TTL]
ttls = [TTL] -> TTL
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [TTL]
ttls

-- | 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
name = do
    ![(TTL, IPv4)]
srv <- Name -> IO [(TTL, IPv4)]
queryA Name
name
    (TTL, [IPv4]) -> IO (TTL, [IPv4])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL ([TTL] -> TTL) -> [TTL] -> TTL
forall a b. (a -> b) -> a -> b
$ ((TTL, IPv4) -> TTL) -> [(TTL, IPv4)] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, IPv4) -> TTL
forall a b. (a, b) -> a
fst [(TTL, IPv4)]
srv, ((TTL, IPv4) -> IPv4) -> [(TTL, IPv4)] -> [IPv4]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, IPv4) -> IPv4
forall a b. (a, b) -> b
snd [(TTL, IPv4)]
srv)

-- | Queries an /SRV/ record for the given service name.
--
-- After getting the /SRV/ record, runs 'collectA' for each collected element.
--
-- Returns a list of IP addresses 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.
collectSRV
    :: TTL                      -- ^ Fallback TTL value
    -> Name                     -- ^ Service name
    -> IO (TTL, [SRV IPv4])
collectSRV :: TTL -> Name -> IO (TTL, [SRV IPv4])
collectSRV TTL
lTTL Name
name = do
    ![(TTL, SRV Name)]
srv <- Name -> IO [(TTL, SRV Name)]
querySRV Name
name
    ![(TTL, [SRV IPv4])]
srv' <- ((TTL, SRV Name) -> IO (TTL, [SRV IPv4]))
-> [(TTL, SRV Name)] -> IO [(TTL, [SRV IPv4])]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently
                 ((\s :: SRV Name
s@SRV {Word16
Name
srvWeight :: forall l. SRV l -> Word16
srvPriority :: Word16
srvWeight :: Word16
srvPort :: Word16
srvTarget :: Name
srvPriority :: forall l. SRV l -> Word16
srvPort :: forall l. SRV l -> Word16
srvTarget :: forall l. SRV l -> l
..} -> do
                     (TTL
t, [IPv4]
is) <- TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL Name
srvTarget
                     (TTL, [SRV IPv4]) -> IO (TTL, [SRV IPv4])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
t, (IPv4 -> SRV IPv4) -> [IPv4] -> [SRV IPv4]
forall a b. (a -> b) -> [a] -> [b]
map (\IPv4
v -> SRV Name
s { srvTarget :: IPv4
srvTarget = IPv4
v }) [IPv4]
is)
                  ) (SRV Name -> IO (TTL, [SRV IPv4]))
-> ((TTL, SRV Name) -> SRV Name)
-> (TTL, SRV Name)
-> IO (TTL, [SRV IPv4])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TTL, SRV Name) -> SRV Name
forall a b. (a, b) -> b
snd
                 ) [(TTL, SRV Name)]
srv
    (TTL, [SRV IPv4]) -> IO (TTL, [SRV IPv4])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL -> TTL -> TTL
forall a. Ord a => a -> a -> a
min (TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL ([TTL] -> TTL) -> [TTL] -> TTL
forall a b. (a -> b) -> a -> b
$ ((TTL, SRV Name) -> TTL) -> [(TTL, SRV Name)] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, SRV Name) -> TTL
forall a b. (a, b) -> a
fst [(TTL, SRV Name)]
srv)
                (TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL ([TTL] -> TTL) -> [TTL] -> TTL
forall a b. (a -> b) -> a -> b
$ ((TTL, [SRV IPv4]) -> TTL) -> [(TTL, [SRV IPv4])] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, [SRV IPv4]) -> TTL
forall a b. (a, b) -> a
fst [(TTL, [SRV IPv4])]
srv')
           ,((TTL, [SRV IPv4]) -> [SRV IPv4])
-> [(TTL, [SRV IPv4])] -> [SRV IPv4]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TTL, [SRV IPv4]) -> [SRV IPv4]
forall a b. (a, b) -> b
snd [(TTL, [SRV IPv4])]
srv'
           )

showIPv4 :: IPv4 -> String
showIPv4 :: IPv4 -> String
showIPv4 (IPv4 Word32
w) =
  Word32 -> ShowS
forall a. Show a => a -> ShowS
shows ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Word32 -> ShowS
forall a. Show a => a -> ShowS
shows ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Word32 -> ShowS
forall a. Show a => a -> ShowS
shows ((Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR`  Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
  Word32 -> ShowS
forall a. Show a => a -> ShowS
shows ( Word32
w                    Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff)
  String
""

ipv4ToServerData :: UData -> IPv4 -> ServerData
ipv4ToServerData :: UData -> IPv4 -> ServerData
ipv4ToServerData UData {Int
UQuery
uQuery :: UData -> UQuery
uMaxFails :: UData -> Int
uFailTimeout :: UData -> Int
uQuery :: UQuery
uMaxFails :: Int
uFailTimeout :: Int
..} IPv4
i =
    UName -> Maybe Int -> Maybe Int -> Maybe Int -> ServerData
ServerData (String -> UName
T.pack (String -> UName) -> String -> UName
forall a b. (a -> b) -> a -> b
$ IPv4 -> String
forall a. Show a => a -> String
show IPv4
i) Maybe Int
forall a. Maybe a
Nothing (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
uMaxFails) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
uFailTimeout)

srvToServerData :: UData -> SRV IPv4 -> ServerData
srvToServerData :: UData -> SRV IPv4 -> ServerData
srvToServerData UData {Int
UQuery
uQuery :: UData -> UQuery
uMaxFails :: UData -> Int
uFailTimeout :: UData -> Int
uQuery :: UQuery
uMaxFails :: Int
uFailTimeout :: Int
..} SRV {Word16
IPv4
srvWeight :: forall l. SRV l -> Word16
srvPriority :: forall l. SRV l -> Word16
srvPort :: forall l. SRV l -> Word16
srvTarget :: forall l. SRV l -> l
srvPriority :: Word16
srvWeight :: Word16
srvPort :: Word16
srvTarget :: IPv4
..} =
    UName -> Maybe Int -> Maybe Int -> Maybe Int -> ServerData
ServerData (String -> UName
T.pack (String -> UName) -> String -> UName
forall a b. (a -> b) -> a -> b
$ IPv4 -> Word16 -> String
forall {a}. Show a => IPv4 -> a -> String
showAddr IPv4
srvTarget Word16
srvPort)
        (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
srvWeight) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
uMaxFails) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
uFailTimeout)
    where showAddr :: IPv4 -> a -> String
showAddr IPv4
i a
p = IPv4 -> String
showIPv4 IPv4
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: a -> String
forall a. Show a => a -> String
show a
p

-- | 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 [] UName
_) Int
_ Int
_) =
    (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
lTTL, CollectedServerData
forall k a. Map k a
M.empty)
collectServerData TTL
lTTL ud :: UData
ud@(UData (QueryA [Name]
ns UName
u) Int
_ Int
_) = do
    [(TTL, [IPv4])]
a <- (Name -> IO (TTL, [IPv4])) -> [Name] -> IO [(TTL, [IPv4])]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (TTL -> Name -> IO (TTL, [IPv4])
collectA TTL
lTTL) [Name]
ns
    (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TTL, CollectedServerData) -> IO (TTL, CollectedServerData))
-> (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a b. (a -> b) -> a -> b
$
        [TTL] -> TTL
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([TTL] -> TTL)
-> ([[ServerData]] -> CollectedServerData)
-> ([TTL], [[ServerData]])
-> (TTL, CollectedServerData)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** UName -> [ServerData] -> CollectedServerData
forall k a. k -> a -> Map k a
M.singleton UName
u ([ServerData] -> CollectedServerData)
-> ([[ServerData]] -> [ServerData])
-> [[ServerData]]
-> CollectedServerData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ServerData]] -> [ServerData]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([TTL], [[ServerData]]) -> (TTL, CollectedServerData))
-> ([TTL], [[ServerData]]) -> (TTL, CollectedServerData)
forall a b. (a -> b) -> a -> b
$
            ((TTL, [IPv4])
 -> ([TTL], [[ServerData]]) -> ([TTL], [[ServerData]]))
-> ([TTL], [[ServerData]])
-> [(TTL, [IPv4])]
-> ([TTL], [[ServerData]])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(TTL
t, [IPv4]
s) ([TTL]
ts, [[ServerData]]
ss) ->
                      -- 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
                      (TTL
t TTL -> [TTL] -> [TTL]
forall a. a -> [a] -> [a]
: [TTL]
ts, [ServerData] -> [ServerData]
forall a. Ord a => [a] -> [a]
sort ((IPv4 -> ServerData) -> [IPv4] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (UData -> IPv4 -> ServerData
ipv4ToServerData UData
ud) [IPv4]
s) [ServerData] -> [[ServerData]] -> [[ServerData]]
forall a. a -> [a] -> [a]
: [[ServerData]]
ss)
                  ) ([], []) [(TTL, [IPv4])]
a
collectServerData TTL
lTTL ud :: UData
ud@(UData (QuerySRV Name
n (SinglePriority UName
u)) Int
_ Int
_) = do
    (TTL
wt, [SRV IPv4]
srv) <- TTL -> Name -> IO (TTL, [SRV IPv4])
collectSRV TTL
lTTL Name
n
    (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
wt, UName -> [ServerData] -> CollectedServerData
forall k a. k -> a -> Map k a
M.singleton UName
u ([ServerData] -> CollectedServerData)
-> [ServerData] -> CollectedServerData
forall a b. (a -> b) -> a -> b
$ [ServerData] -> [ServerData]
forall a. Ord a => [a] -> [a]
sort ([ServerData] -> [ServerData]) -> [ServerData] -> [ServerData]
forall a b. (a -> b) -> a -> b
$ (SRV IPv4 -> ServerData) -> [SRV IPv4] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (UData -> SRV IPv4 -> ServerData
srvToServerData UData
ud) [SRV IPv4]
srv)
collectServerData TTL
lTTL (UData (QuerySRV Name
_ (PriorityList [])) Int
_ Int
_) =
    (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
lTTL, CollectedServerData
forall k a. Map k a
M.empty)
collectServerData TTL
lTTL ud :: UData
ud@(UData (QuerySRV Name
n (PriorityList [UName]
pl)) Int
_ Int
_ ) = do
    (TTL
wt, [SRV IPv4]
srv) <- TTL -> Name -> IO (TTL, [SRV IPv4])
collectSRV TTL
lTTL Name
n
    let srv' :: [(UName, [SRV IPv4])]
srv' = [UName] -> [[SRV IPv4]] -> [(UName, [SRV IPv4])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([UName] -> [UName]
forall {a}. [a] -> [a]
withTrail [UName]
pl) ([[SRV IPv4]] -> [(UName, [SRV IPv4])])
-> [[SRV IPv4]] -> [(UName, [SRV IPv4])]
forall a b. (a -> b) -> a -> b
$ [SRV IPv4] -> [[SRV IPv4]]
forall {l}. [SRV l] -> [[SRV l]]
partitionByPriority [SRV IPv4]
srv
    (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
wt
           ,[(UName, [ServerData])] -> CollectedServerData
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(UName, [ServerData])] -> CollectedServerData)
-> [(UName, [ServerData])] -> CollectedServerData
forall a b. (a -> b) -> a -> b
$ ((UName, [SRV IPv4]) -> (UName, [ServerData]))
-> [(UName, [SRV IPv4])] -> [(UName, [ServerData])]
forall a b. (a -> b) -> [a] -> [b]
map (([SRV IPv4] -> [ServerData])
-> (UName, [SRV IPv4]) -> (UName, [ServerData])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([SRV IPv4] -> [ServerData])
 -> (UName, [SRV IPv4]) -> (UName, [ServerData]))
-> ([SRV IPv4] -> [ServerData])
-> (UName, [SRV IPv4])
-> (UName, [ServerData])
forall a b. (a -> b) -> a -> b
$ [ServerData] -> [ServerData]
forall a. Ord a => [a] -> [a]
sort ([ServerData] -> [ServerData])
-> ([SRV IPv4] -> [ServerData]) -> [SRV IPv4] -> [ServerData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SRV IPv4 -> ServerData) -> [SRV IPv4] -> [ServerData]
forall a b. (a -> b) -> [a] -> [b]
map (UData -> SRV IPv4 -> ServerData
srvToServerData UData
ud)) [(UName, [SRV IPv4])]
srv'
           )
    where partitionByPriority :: [SRV l] -> [[SRV l]]
partitionByPriority =
              (SRV l -> SRV l -> Bool) -> [SRV l] -> [[SRV l]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Word16 -> Word16 -> Bool)
-> (SRV l -> Word16) -> SRV l -> SRV l -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SRV l -> Word16
forall l. SRV l -> Word16
srvPriority) ([SRV l] -> [[SRV l]])
-> ([SRV l] -> [SRV l]) -> [SRV l] -> [[SRV l]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SRV l -> Word16) -> [SRV l] -> [SRV l]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn SRV l -> Word16
forall l. SRV l -> Word16
srvPriority
          withTrail :: [a] -> [a]
withTrail = ([a] -> [a] -> [a]) -> ([a], [a]) -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) (([a], [a]) -> [a]) -> ([a] -> ([a], [a])) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]
forall a. a -> a
id ([a] -> [a]) -> ([a] -> [a]) -> [a] -> ([a], [a])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a -> [a]
forall a. a -> [a]
repeat (a -> [a]) -> ([a] -> a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> a
forall a. HasCallStack => [a] -> a
last)

collectUpstreams :: Conf -> Bool -> IO L.ByteString
collectUpstreams :: Conf -> Bool -> IO ByteString
collectUpstreams Conf {[UData]
TimeInterval
upstreams :: Conf -> [UData]
maxWait :: Conf -> TimeInterval
waitOnException :: Conf -> TimeInterval
responseTimeout :: Conf -> TimeInterval
upstreams :: [UData]
maxWait :: TimeInterval
waitOnException :: TimeInterval
responseTimeout :: TimeInterval
..} = IO ByteString -> Bool -> IO ByteString
forall a b. a -> b -> a
const (IO ByteString -> Bool -> IO ByteString)
-> IO ByteString -> Bool -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
    (TimeInterval
wt, CollectedServerData
old) <- IORef (TimeInterval, CollectedServerData)
-> IO (TimeInterval, CollectedServerData)
forall a. IORef a -> IO a
readIORef IORef (TimeInterval, CollectedServerData)
collectedServerData
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TimeInterval
wt TimeInterval -> TimeInterval -> Bool
forall a. Eq a => a -> a -> Bool
/= TimeInterval
Unset) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelaySec (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Int
toSec TimeInterval
wt
    let (TTL
lTTL, TTL
hTTL) = (TimeInterval -> TTL
toTTL TimeInterval
waitOnException, TimeInterval -> TTL
toTTL TimeInterval
maxWait)
    [(TTL, CollectedServerData)]
srv <- IO [(TTL, CollectedServerData)] -> IO [(TTL, CollectedServerData)]
forall {a}. IO a -> IO a
handleCollectErrors (IO [(TTL, CollectedServerData)]
 -> IO [(TTL, CollectedServerData)])
-> IO [(TTL, CollectedServerData)]
-> IO [(TTL, CollectedServerData)]
forall a b. (a -> b) -> a -> b
$
        (UData -> IO (TTL, CollectedServerData))
-> [UData] -> IO [(TTL, CollectedServerData)]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (IO (TTL, CollectedServerData) -> IO (TTL, CollectedServerData)
forall {a}. IO a -> IO a
withTimeout (IO (TTL, CollectedServerData) -> IO (TTL, CollectedServerData))
-> (UData -> IO (TTL, CollectedServerData))
-> UData
-> IO (TTL, CollectedServerData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TTL -> UData -> IO (TTL, CollectedServerData)
collectServerData TTL
lTTL) [UData]
upstreams
    let nwt :: TimeInterval
nwt = TTL -> TimeInterval
fromTTL (TTL -> TimeInterval) -> TTL -> TimeInterval
forall a b. (a -> b) -> a -> b
$ TTL -> TTL -> TTL
forall a. Ord a => a -> a -> a
max (Int32 -> TTL
TTL Int32
1) (TTL -> TTL) -> TTL -> TTL
forall a b. (a -> b) -> a -> b
$ TTL -> TTL -> TTL
forall a. Ord a => a -> a -> a
min TTL
hTTL (TTL -> TTL) -> TTL -> TTL
forall a b. (a -> b) -> a -> b
$ TTL -> [TTL] -> TTL
minimumTTL TTL
lTTL ([TTL] -> TTL) -> [TTL] -> TTL
forall a b. (a -> b) -> a -> b
$ ((TTL, CollectedServerData) -> TTL)
-> [(TTL, CollectedServerData)] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, CollectedServerData) -> TTL
forall a b. (a, b) -> a
fst [(TTL, CollectedServerData)]
srv
        new :: CollectedServerData
new = [CollectedServerData] -> CollectedServerData
forall a. Monoid a => [a] -> a
mconcat ([CollectedServerData] -> CollectedServerData)
-> [CollectedServerData] -> CollectedServerData
forall a b. (a -> b) -> a -> b
$ ((TTL, CollectedServerData) -> CollectedServerData)
-> [(TTL, CollectedServerData)] -> [CollectedServerData]
forall a b. (a -> b) -> [a] -> [b]
map (TTL, CollectedServerData) -> CollectedServerData
forall a b. (a, b) -> b
snd [(TTL, CollectedServerData)]
srv
    if CollectedServerData
new CollectedServerData -> CollectedServerData -> Bool
forall a. Eq a => a -> a -> Bool
== CollectedServerData
old
        then do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TimeInterval
nwt TimeInterval -> TimeInterval -> Bool
forall a. Eq a => a -> a -> Bool
/= TimeInterval
wt) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IORef (TimeInterval, CollectedServerData)
-> ((TimeInterval, CollectedServerData)
    -> (TimeInterval, CollectedServerData))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (TimeInterval, CollectedServerData)
collectedServerData (((TimeInterval, CollectedServerData)
  -> (TimeInterval, CollectedServerData))
 -> IO ())
-> ((TimeInterval, CollectedServerData)
    -> (TimeInterval, CollectedServerData))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (TimeInterval -> TimeInterval)
-> (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((TimeInterval -> TimeInterval)
 -> (TimeInterval, CollectedServerData)
 -> (TimeInterval, CollectedServerData))
-> (TimeInterval -> TimeInterval)
-> (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData)
forall a b. (a -> b) -> a -> b
$ TimeInterval -> TimeInterval -> TimeInterval
forall a b. a -> b -> a
const TimeInterval
nwt
            ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
        else do
            IORef (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (TimeInterval, CollectedServerData)
collectedServerData (TimeInterval
nwt, CollectedServerData
new)
            ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ CollectedServerData -> ByteString
forall a. ToJSON a => a -> ByteString
encode CollectedServerData
new
    where toTTL :: TimeInterval -> TTL
toTTL = Int32 -> TTL
TTL (Int32 -> TTL) -> (TimeInterval -> Int32) -> TimeInterval -> TTL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> (TimeInterval -> Int) -> TimeInterval -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterval -> Int
toSec
          fromTTL :: TTL -> TimeInterval
fromTTL (TTL Int32
ttl) = Int -> TimeInterval
Sec (Int -> TimeInterval) -> Int -> TimeInterval
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ttl
          handleCollectErrors :: IO a -> IO a
handleCollectErrors = (SomeException -> IO a) -> IO a -> IO a
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
handleAny ((SomeException -> IO a) -> IO a -> IO a)
-> (SomeException -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
              IORef (TimeInterval, CollectedServerData)
-> (TimeInterval, CollectedServerData) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (TimeInterval, CollectedServerData)
collectedServerData (TimeInterval
waitOnException, CollectedServerData
forall k a. Map k a
M.empty)
              SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e
          withTimeout :: IO b -> IO b
withTimeout IO b
act = do
              Maybe b
r <- Int -> IO b -> IO (Maybe b)
forall a. Int -> IO a -> IO (Maybe a)
timeout (TimeInterval -> Int
toTimeout TimeInterval
responseTimeout) IO b
act
              case Maybe b
r of
                  Maybe b
Nothing -> IOError -> IO b
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO b) -> IOError -> IO b
forall a b. (a -> b) -> a -> b
$
                      String -> IOError
userError String
"Collection of server data was timed out"
                  Just b
r' -> b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
r'
          toTimeout :: TimeInterval -> Int
toTimeout TimeInterval
Unset = -Int
1
          toTimeout TimeInterval
v = TimeInterval -> Int
toSec TimeInterval
v Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1e6

ngxExportSimpleServiceTyped 'collectUpstreams ''Conf $
    PersistentService Nothing

signalUpconf :: Upconf -> Bool -> IO L.ByteString
signalUpconf :: Upconf -> Bool -> IO ByteString
signalUpconf Upconf {(UName, UName)
upconfAddr :: Upconf -> (UName, UName)
upconfAddr :: (UName, UName)
..} = IO ByteString -> Bool -> IO ByteString
forall a b. a -> b -> a
const (IO ByteString -> Bool -> IO ByteString)
-> IO ByteString -> Bool -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
    IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ (UName -> UName -> IO ByteString)
-> (UName, UName) -> IO ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry UName -> UName -> IO ByteString
queryHTTP (UName, UName)
upconfAddr
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""

ngxExportSimpleServiceTyped 'signalUpconf ''Upconf $
    PersistentService Nothing