{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, RecordWildCards #-}
{-# LANGUAGE BangPatterns, 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>.
--
-----------------------------------------------------------------------------

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

    -- * Exported type declarations
                                UName
                               ,SAddress
                               ,UQuery (..)
                               ,PriorityList (..)
                               ,UData (..)
                               ,ServerData (..)
                               ,CollectedServerDataGen
                               ,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.Arrow
import           Control.Monad
import           System.IO.Unsafe

-- $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 = 0
--                            , uFailTimeout = 10
--                            }
--                     ]
--               , maxWait = Sec 300
--               , waitOnException = Sec 2
--               }\';
--
--     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.
--
-- 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 = 0
--                            , uFailTimeout = 10
--                            }
--                     ]
--               , maxWait = Sec 300
--               , waitOnException = Sec 2
--               }\';
-- @
--
-- 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 PriorityList  -- ^ 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

-- | Specifies how to distribute collected servers among the given upstreams.
data PriorityList = SinglePriority UName  -- ^ All servers to one upstream
                  | PriorityList [UName]  -- ^ Distribute servers by priorities
                  deriving ReadPrec [PriorityList]
ReadPrec PriorityList
Int -> ReadS PriorityList
ReadS [PriorityList]
(Int -> ReadS PriorityList)
-> ReadS [PriorityList]
-> ReadPrec PriorityList
-> ReadPrec [PriorityList]
-> Read PriorityList
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PriorityList
readsPrec :: Int -> ReadS PriorityList
$creadList :: ReadS [PriorityList]
readList :: ReadS [PriorityList]
$creadPrec :: ReadPrec PriorityList
readPrec :: ReadPrec PriorityList
$creadListPrec :: ReadPrec [PriorityList]
readListPrec :: ReadPrec [PriorityList]
Read

-- | Upstream configuration.
--
-- Includes DNS query model and data for Nginx /server/ description.
data UData = UData { UData -> UQuery
uQuery       :: UQuery  -- ^ DNS query model
                   , UData -> Int
uMaxFails    :: Int     -- ^ /maxFails/
                   , UData -> Int
uFailTimeout :: Int     -- ^ /failTimeout/
                   } 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
                 } 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 data 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  -- ^ /maxFails/
                             , ServerData -> Maybe Int
sFailTimeout :: Maybe Int  -- ^ /failTimeout/
                             } 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
                           ]

-- | Generic type to collect and store server data.
--
-- Type /a/ is instantiated either by 'TTL' (to collect) or 'TimeInterval'
-- (to store).
type CollectedServerDataGen a = (a, Map UName [ServerData])

-- | Collected server data.
--
-- The first element of the tuple gets transformed into the time interval before
-- the next run of the /collectUpstreams/ service. The second element contains
-- the collected data.
type CollectedServerData = CollectedServerDataGen TTL

type CollectedServerDataStore = CollectedServerDataGen TimeInterval

collectedServerData :: IORef CollectedServerDataStore
collectedServerData :: IORef CollectedServerDataStore
collectedServerData = IO (IORef CollectedServerDataStore)
-> IORef CollectedServerDataStore
forall a. IO a -> a
unsafePerformIO (IO (IORef CollectedServerDataStore)
 -> IORef CollectedServerDataStore)
-> IO (IORef CollectedServerDataStore)
-> IORef CollectedServerDataStore
forall a b. (a -> b) -> a -> b
$ CollectedServerDataStore -> IO (IORef CollectedServerDataStore)
forall a. a -> IO (IORef a)
newIORef (TimeInterval
Unset, Map UName [ServerData]
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 '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
srvPriority :: Word16
srvWeight :: Word16
srvPort :: Word16
srvTarget :: Name
srvPriority :: forall l. SRV l -> Word16
srvWeight :: 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
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 :: 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.
collectServerData
    :: TTL                      -- ^ Fallback TTL value
    -> UData                    -- ^ Upstream configuration
    -> IO CollectedServerData
collectServerData :: TTL -> UData -> IO CollectedServerData
collectServerData TTL
lTTL (UData (QueryA [] UName
u) Int
_ Int
_) =
    CollectedServerData -> IO CollectedServerData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
lTTL, UName -> [ServerData] -> Map UName [ServerData]
forall k a. k -> a -> Map k a
M.singleton UName
u [])
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
    CollectedServerData -> IO CollectedServerData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CollectedServerData -> IO CollectedServerData)
-> CollectedServerData -> IO 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]] -> Map UName [ServerData])
-> ([TTL], [[ServerData]])
-> 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] -> Map UName [ServerData]
forall k a. k -> a -> Map k a
M.singleton UName
u ([ServerData] -> Map UName [ServerData])
-> ([[ServerData]] -> [ServerData])
-> [[ServerData]]
-> Map UName [ServerData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[ServerData]] -> [ServerData]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([TTL], [[ServerData]]) -> CollectedServerData)
-> ([TTL], [[ServerData]]) -> 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
    CollectedServerData -> IO CollectedServerData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
wt, UName -> [ServerData] -> Map UName [ServerData]
forall k a. k -> a -> Map k a
M.singleton UName
u ([ServerData] -> Map UName [ServerData])
-> [ServerData] -> Map UName [ServerData]
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
_) =
    CollectedServerData -> IO CollectedServerData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
lTTL, Map UName [ServerData]
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
    CollectedServerData -> IO CollectedServerData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TTL
wt
           ,[(UName, [ServerData])] -> Map UName [ServerData]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(UName, [ServerData])] -> Map UName [ServerData])
-> [(UName, [ServerData])] -> Map UName [ServerData]
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)

handleCollectErrors :: TimeInterval -> IO [CollectedServerData] ->
    IO [CollectedServerData]
handleCollectErrors :: TimeInterval
-> IO [CollectedServerData] -> IO [CollectedServerData]
handleCollectErrors TimeInterval
wt =
    (SomeException -> IO [CollectedServerData])
-> IO [CollectedServerData] -> IO [CollectedServerData]
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
e :: SomeException) -> do
               IORef CollectedServerDataStore -> CollectedServerDataStore -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef CollectedServerDataStore
collectedServerData (TimeInterval
wt, Map UName [ServerData]
forall k a. Map k a
M.empty)
               SomeException -> IO [CollectedServerData]
forall e a. Exception e => e -> IO a
throwIO SomeException
e
           )

collectUpstreams :: Conf -> Bool -> IO L.ByteString
collectUpstreams :: Conf -> Bool -> IO ByteString
collectUpstreams Conf {[UData]
TimeInterval
upstreams :: Conf -> [UData]
maxWait :: Conf -> TimeInterval
waitOnException :: Conf -> TimeInterval
upstreams :: [UData]
maxWait :: TimeInterval
waitOnException :: 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, Map UName [ServerData]
old) <- IORef CollectedServerDataStore -> IO CollectedServerDataStore
forall a. IORef a -> IO a
readIORef IORef CollectedServerDataStore
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)
    [CollectedServerData]
srv <- TimeInterval
-> IO [CollectedServerData] -> IO [CollectedServerData]
handleCollectErrors TimeInterval
waitOnException (IO [CollectedServerData] -> IO [CollectedServerData])
-> IO [CollectedServerData] -> IO [CollectedServerData]
forall a b. (a -> b) -> a -> b
$
        (UData -> IO CollectedServerData)
-> [UData] -> IO [CollectedServerData]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (TTL -> UData -> IO 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
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
$ (CollectedServerData -> TTL) -> [CollectedServerData] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map CollectedServerData -> TTL
forall a b. (a, b) -> a
fst [CollectedServerData]
srv
        new :: Map UName [ServerData]
new = [Map UName [ServerData]] -> Map UName [ServerData]
forall a. Monoid a => [a] -> a
mconcat ([Map UName [ServerData]] -> Map UName [ServerData])
-> [Map UName [ServerData]] -> Map UName [ServerData]
forall a b. (a -> b) -> a -> b
$ (CollectedServerData -> Map UName [ServerData])
-> [CollectedServerData] -> [Map UName [ServerData]]
forall a b. (a -> b) -> [a] -> [b]
map CollectedServerData -> Map UName [ServerData]
forall a b. (a, b) -> b
snd [CollectedServerData]
srv
    if Map UName [ServerData]
new Map UName [ServerData] -> Map UName [ServerData] -> Bool
forall a. Eq a => a -> a -> Bool
== Map UName [ServerData]
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 CollectedServerDataStore
-> (CollectedServerDataStore -> CollectedServerDataStore) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef CollectedServerDataStore
collectedServerData ((CollectedServerDataStore -> CollectedServerDataStore) -> IO ())
-> (CollectedServerDataStore -> CollectedServerDataStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ (TimeInterval -> TimeInterval)
-> CollectedServerDataStore -> CollectedServerDataStore
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)
 -> CollectedServerDataStore -> CollectedServerDataStore)
-> (TimeInterval -> TimeInterval)
-> CollectedServerDataStore
-> CollectedServerDataStore
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 CollectedServerDataStore -> CollectedServerDataStore -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef CollectedServerDataStore
collectedServerData (TimeInterval
nwt, Map UName [ServerData]
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
$ Map UName [ServerData] -> ByteString
forall a. ToJSON a => a -> ByteString
encode Map UName [ServerData]
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

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