{-# LANGUAGE CPP, TemplateHaskell, ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings, BangPatterns, ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables, TupleSections, NumDecimals #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  NgxExport.Healthcheck
-- Copyright   :  (c) Alexey Radkov 2022-2023
-- License     :  BSD-style
--
-- Maintainer  :  alexey.radkov@gmail.com
-- Stability   :  stable
-- Portability :  non-portable (requires Template Haskell)
--
-- Active health checks and monitoring of Nginx upstreams.
--
-----------------------------------------------------------------------------

module NgxExport.Healthcheck (module Types) where

import           NgxExport
import           NgxExport.Healthcheck.Types as Types
import           Network.HTTP.Client
import           Network.HTTP.Client.BrReadWithTimeout
import           Network.HTTP.Types.Status
import           Data.Map (Map)
import qualified Data.Map.Strict as M
import qualified Data.Map.Lazy as ML
import           Control.Monad
import           Control.Arrow
import           Control.Concurrent
import           Control.Concurrent.Async
import           Control.Exception
import           System.IO.Unsafe
import           Data.IORef
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Unsafe as B
import qualified Data.Vector.Mutable as MV
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Data.Maybe
import           Data.List
import           Data.Char
import           Data.Ord
import           Data.Function
import           Foreign.C.Types
import           Foreign.C.String
import           Foreign.Ptr
import           Foreign.Storable
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Utils
import           Data.Aeson
#if MIN_VERSION_time(1,9,1)
import           Data.Fixed
#endif
import           Data.Int
import           Data.Time.Clock
import           Data.Time.Calendar
import           Safe

#ifdef HEALTHCHECK_HTTPS
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import           Data.Default.Class
import           Network.HTTP.Client.TLS
import           Network.Connection
import           Network.TLS hiding (HashSHA256)
import           Network.TLS.Extra.Cipher
import           System.X509 (getSystemCertificateStore)
import qualified Data.X509.Validation as X509
import           Data.X509 (HashALG (..))
#endif

#ifdef SNAP_STATS_SERVER
import           Control.Monad.IO.Class
import           Control.Exception.Enclosed (handleAny)
import           Snap.Http.Server
import           Snap.Core
#endif

type Url = String
type HttpStatus = Int

data Conf = Conf { Conf -> FlatPeers
upstreams     :: [Upstream]
                 , Conf -> TimeInterval
interval      :: TimeInterval
                 , Conf -> TimeInterval
peerTimeout   :: TimeInterval
                 , Conf -> Maybe Endpoint
endpoint      :: Maybe Endpoint
                 , Conf -> Maybe Int
sendStatsPort :: Maybe Int
                 } 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

data Endpoint = Endpoint { Endpoint -> [Char]
epUrl      :: Url
                         , Endpoint -> TransportProtocol
epProto    :: TransportProtocol
                         , Endpoint -> PassRule
epPassRule :: PassRule
                         } deriving ReadPrec [Endpoint]
ReadPrec Endpoint
Int -> ReadS Endpoint
ReadS [Endpoint]
(Int -> ReadS Endpoint)
-> ReadS [Endpoint]
-> ReadPrec Endpoint
-> ReadPrec [Endpoint]
-> Read Endpoint
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Endpoint
readsPrec :: Int -> ReadS Endpoint
$creadList :: ReadS [Endpoint]
readList :: ReadS [Endpoint]
$creadPrec :: ReadPrec Endpoint
readPrec :: ReadPrec Endpoint
$creadListPrec :: ReadPrec [Endpoint]
readListPrec :: ReadPrec [Endpoint]
Read

data TransportProtocol = Http | Https deriving ReadPrec [TransportProtocol]
ReadPrec TransportProtocol
Int -> ReadS TransportProtocol
ReadS [TransportProtocol]
(Int -> ReadS TransportProtocol)
-> ReadS [TransportProtocol]
-> ReadPrec TransportProtocol
-> ReadPrec [TransportProtocol]
-> Read TransportProtocol
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TransportProtocol
readsPrec :: Int -> ReadS TransportProtocol
$creadList :: ReadS [TransportProtocol]
readList :: ReadS [TransportProtocol]
$creadPrec :: ReadPrec TransportProtocol
readPrec :: ReadPrec TransportProtocol
$creadListPrec :: ReadPrec [TransportProtocol]
readListPrec :: ReadPrec [TransportProtocol]
Read

data PassRule = DefaultPassRule
              | PassRuleByHttpStatus [HttpStatus]
              deriving ReadPrec [PassRule]
ReadPrec PassRule
Int -> ReadS PassRule
ReadS [PassRule]
(Int -> ReadS PassRule)
-> ReadS [PassRule]
-> ReadPrec PassRule
-> ReadPrec [PassRule]
-> Read PassRule
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PassRule
readsPrec :: Int -> ReadS PassRule
$creadList :: ReadS [PassRule]
readList :: ReadS [PassRule]
$creadPrec :: ReadPrec PassRule
readPrec :: ReadPrec PassRule
$creadListPrec :: ReadPrec [PassRule]
readListPrec :: ReadPrec [PassRule]
Read

newtype PassRuleParams = PassRuleParams { PassRuleParams -> Int
responseHttpStatus :: HttpStatus }

defaultPassRuleParams :: PassRuleParams
defaultPassRuleParams :: PassRuleParams
defaultPassRuleParams = PassRuleParams { responseHttpStatus :: Int
responseHttpStatus = Int
200 }

data TimeInterval = Hr Int
                  | Min Int
                  | Sec Int
                  | HrMin Int Int
                  | MinSec Int Int
                  deriving ReadPrec [TimeInterval]
ReadPrec TimeInterval
Int -> ReadS TimeInterval
ReadS [TimeInterval]
(Int -> ReadS TimeInterval)
-> ReadS [TimeInterval]
-> ReadPrec TimeInterval
-> ReadPrec [TimeInterval]
-> Read TimeInterval
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS TimeInterval
readsPrec :: Int -> ReadS TimeInterval
$creadList :: ReadS [TimeInterval]
readList :: ReadS [TimeInterval]
$creadPrec :: ReadPrec TimeInterval
readPrec :: ReadPrec TimeInterval
$creadListPrec :: ReadPrec [TimeInterval]
readListPrec :: ReadPrec [TimeInterval]
Read

terminateWorkerProcess :: String -> IO a
terminateWorkerProcess :: forall a. [Char] -> IO a
terminateWorkerProcess = TerminateWorkerProcess -> IO a
forall e a. Exception e => e -> IO a
throwIO (TerminateWorkerProcess -> IO a)
-> ([Char] -> TerminateWorkerProcess) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> TerminateWorkerProcess
TerminateWorkerProcess

conf :: IORef (Map ServiceKey Conf)
conf :: IORef (Map ServiceKey Conf)
conf = IO (IORef (Map ServiceKey Conf)) -> IORef (Map ServiceKey Conf)
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map ServiceKey Conf)) -> IORef (Map ServiceKey Conf))
-> IO (IORef (Map ServiceKey Conf)) -> IORef (Map ServiceKey Conf)
forall a b. (a -> b) -> a -> b
$ Map ServiceKey Conf -> IO (IORef (Map ServiceKey Conf))
forall a. a -> IO (IORef a)
newIORef Map ServiceKey Conf
forall k a. Map k a
M.empty
{-# NOINLINE conf #-}

type NamedPeers = (Maybe PeerHostName, Peers)

peers :: IORef (MServiceKey NamedPeers)
peers :: IORef (MServiceKey NamedPeers)
peers = IO (IORef (MServiceKey NamedPeers))
-> IORef (MServiceKey NamedPeers)
forall a. IO a -> a
unsafePerformIO (IO (IORef (MServiceKey NamedPeers))
 -> IORef (MServiceKey NamedPeers))
-> IO (IORef (MServiceKey NamedPeers))
-> IORef (MServiceKey NamedPeers)
forall a b. (a -> b) -> a -> b
$ MServiceKey NamedPeers -> IO (IORef (MServiceKey NamedPeers))
forall a. a -> IO (IORef a)
newIORef MServiceKey NamedPeers
forall k a. Map k a
M.empty
{-# NOINLINE peers #-}

active :: IORef [ServiceKey]
active :: IORef FlatPeers
active = IO (IORef FlatPeers) -> IORef FlatPeers
forall a. IO a -> a
unsafePerformIO (IO (IORef FlatPeers) -> IORef FlatPeers)
-> IO (IORef FlatPeers) -> IORef FlatPeers
forall a b. (a -> b) -> a -> b
$ FlatPeers -> IO (IORef FlatPeers)
forall a. a -> IO (IORef a)
newIORef []
{-# NOINLINE active #-}

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


#ifdef HEALTHCHECK_HTTPS

httpsManager :: IORef (HashMap PeerHostName Manager)
httpsManager :: IORef (HashMap ServiceKey Manager)
httpsManager = IO (IORef (HashMap ServiceKey Manager))
-> IORef (HashMap ServiceKey Manager)
forall a. IO a -> a
unsafePerformIO (IO (IORef (HashMap ServiceKey Manager))
 -> IORef (HashMap ServiceKey Manager))
-> IO (IORef (HashMap ServiceKey Manager))
-> IORef (HashMap ServiceKey Manager)
forall a b. (a -> b) -> a -> b
$ HashMap ServiceKey Manager
-> IO (IORef (HashMap ServiceKey Manager))
forall a. a -> IO (IORef a)
newIORef HashMap ServiceKey Manager
forall k v. HashMap k v
HM.empty
{-# NOINLINE httpsManager #-}

foreign import ccall unsafe "plugin_ngx_http_haskell_healthcheck_srv"
    c_healthcheck_srv :: Ptr () -> Ptr () -> CString -> Ptr CString ->
                         Ptr CSize -> IO CIntPtr

mkHttpsManager :: [Upstream] -> Maybe PeerHostName -> IO ()
mkHttpsManager :: FlatPeers -> Maybe ServiceKey -> IO ()
mkHttpsManager FlatPeers
us Maybe ServiceKey
hname = do
    FlatPeers
hnames <-
        case Maybe ServiceKey
hname of
            Maybe ServiceKey
Nothing -> [FlatPeers] -> FlatPeers
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([FlatPeers] -> FlatPeers) -> IO [FlatPeers] -> IO FlatPeers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ServiceKey -> IO FlatPeers) -> FlatPeers -> IO [FlatPeers]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM
                (\ServiceKey
ps -> do
                    Ptr ()
c   <- IO (Ptr ())
ngxCyclePtr
                    Ptr ()
umc <- IO (Ptr ())
ngxUpstreamMainConfPtr
                    ByteString -> (CString -> IO FlatPeers) -> IO FlatPeers
forall a. ByteString -> (CString -> IO a) -> IO a
B.useAsCString (ServiceKey -> ByteString
T.encodeUtf8 ServiceKey
ps) ((CString -> IO FlatPeers) -> IO FlatPeers)
-> (CString -> IO FlatPeers) -> IO FlatPeers
forall a b. (a -> b) -> a -> b
$ \CString
ps' ->
                        (Ptr CString -> IO FlatPeers) -> IO FlatPeers
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CString -> IO FlatPeers) -> IO FlatPeers)
-> (Ptr CString -> IO FlatPeers) -> IO FlatPeers
forall a b. (a -> b) -> a -> b
$ \Ptr CString
pv ->
                            (Ptr CSize -> IO FlatPeers) -> IO FlatPeers
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO FlatPeers) -> IO FlatPeers)
-> (Ptr CSize -> IO FlatPeers) -> IO FlatPeers
forall a b. (a -> b) -> a -> b
$ \Ptr CSize
pl -> do
                                ((CIntPtr
0 CIntPtr -> CIntPtr -> Bool
forall a. Eq a => a -> a -> Bool
==) -> !Bool
ok) <-
                                    Ptr ()
-> Ptr () -> CString -> Ptr CString -> Ptr CSize -> IO CIntPtr
c_healthcheck_srv Ptr ()
c Ptr ()
umc CString
ps' Ptr CString
pv Ptr CSize
pl
                                if Bool
ok
                                    then do
                                        CString
v <- Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek Ptr CString
pv
                                        (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
l) <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pl
                                        (IO FlatPeers -> IO () -> IO FlatPeers)
-> IO () -> IO FlatPeers -> IO FlatPeers
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO FlatPeers -> IO () -> IO FlatPeers
forall a b. IO a -> IO b -> IO a
finally (CString -> IO ()
forall a. Ptr a -> IO ()
free CString
v) (IO FlatPeers -> IO FlatPeers) -> IO FlatPeers -> IO FlatPeers
forall a b. (a -> b) -> a -> b
$ do
                                            (ByteString -> ServiceKey
T.decodeUtf8 -> !ServiceKey
v') <-
                                                CStringLen -> IO ByteString
B.unsafePackCStringLen (CString
v, Int
l)
                                            FlatPeers -> IO FlatPeers
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FlatPeers -> IO FlatPeers) -> FlatPeers -> IO FlatPeers
forall a b. (a -> b) -> a -> b
$ (ServiceKey -> Bool) -> FlatPeers -> FlatPeers
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ServiceKey -> Bool) -> ServiceKey -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> Bool
T.null) (FlatPeers -> FlatPeers) -> FlatPeers -> FlatPeers
forall a b. (a -> b) -> a -> b
$
                                                (Char -> Bool) -> ServiceKey -> FlatPeers
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') ServiceKey
v'
                                    else [Char] -> IO FlatPeers
forall a. [Char] -> IO a
terminateWorkerProcess ([Char] -> IO FlatPeers) -> [Char] -> IO FlatPeers
forall a b. (a -> b) -> a -> b
$
                                        [Char]
"Failed to get servers in upstream " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                            ServiceKey -> [Char]
T.unpack ServiceKey
ps [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!"
                ) FlatPeers
us
            Just ServiceKey
v -> FlatPeers -> IO FlatPeers
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ServiceKey
v]
    [(ServiceKey, Manager)]
man <- (ServiceKey -> IO (ServiceKey, Manager))
-> FlatPeers -> IO [(ServiceKey, Manager)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ServiceKey
name -> (ServiceKey
name, ) (Manager -> (ServiceKey, Manager))
-> IO Manager -> IO (ServiceKey, Manager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServiceKey -> IO Manager
mkManager ServiceKey
name) FlatPeers
hnames
    IORef (HashMap ServiceKey Manager)
-> (HashMap ServiceKey Manager -> (HashMap ServiceKey Manager, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashMap ServiceKey Manager)
httpsManager ((HashMap ServiceKey Manager -> (HashMap ServiceKey Manager, ()))
 -> IO ())
-> (HashMap ServiceKey Manager -> (HashMap ServiceKey Manager, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) (HashMap ServiceKey Manager -> (HashMap ServiceKey Manager, ()))
-> (HashMap ServiceKey Manager -> HashMap ServiceKey Manager)
-> HashMap ServiceKey Manager
-> (HashMap ServiceKey Manager, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap ServiceKey Manager
-> HashMap ServiceKey Manager -> HashMap ServiceKey Manager
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union` [(ServiceKey, Manager)] -> HashMap ServiceKey Manager
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(ServiceKey, Manager)]
man)
    where mkManager :: ServiceKey -> IO Manager
mkManager ServiceKey
name = do
              CertificateStore
systemCAStore <- IO CertificateStore
getSystemCertificateStore
              let (ServiceKey -> [Char]
T.unpack -> [Char]
h, ServiceKey -> ByteString
T.encodeUtf8 -> ByteString
p) =
                      (ServiceKey -> ServiceKey)
-> (ServiceKey, ServiceKey) -> (ServiceKey, ServiceKey)
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 (ServiceKey -> Maybe ServiceKey -> ServiceKey
forall a. a -> Maybe a -> a
fromMaybe ServiceKey
"" (Maybe ServiceKey -> ServiceKey)
-> (ServiceKey -> Maybe ServiceKey) -> ServiceKey -> ServiceKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, ServiceKey) -> ServiceKey)
-> Maybe (Char, ServiceKey) -> Maybe ServiceKey
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char, ServiceKey) -> ServiceKey
forall a b. (a, b) -> b
snd (Maybe (Char, ServiceKey) -> Maybe ServiceKey)
-> (ServiceKey -> Maybe (Char, ServiceKey))
-> ServiceKey
-> Maybe ServiceKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> Maybe (Char, ServiceKey)
T.uncons) ((ServiceKey, ServiceKey) -> (ServiceKey, ServiceKey))
-> (ServiceKey, ServiceKey) -> (ServiceKey, ServiceKey)
forall a b. (a -> b) -> a -> b
$
                          (Char -> Bool) -> ServiceKey -> (ServiceKey, ServiceKey)
T.break (Char
':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) ServiceKey
name
                  validateName :: [Char] -> b -> Certificate -> [FailedReason]
validateName = (Certificate -> [FailedReason])
-> b -> Certificate -> [FailedReason]
forall a b. a -> b -> a
const ((Certificate -> [FailedReason])
 -> b -> Certificate -> [FailedReason])
-> ([Char] -> Certificate -> [FailedReason])
-> [Char]
-> b
-> Certificate
-> [FailedReason]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationHooks -> [Char] -> Certificate -> [FailedReason]
hookValidateName ValidationHooks
X509.defaultHooks
                  defaultParams :: ClientParams
defaultParams = ([Char] -> ByteString -> ClientParams
defaultParamsClient [Char]
h ByteString
p)
                      { clientShared = def
                          { sharedCAStore = systemCAStore }
                      , clientHooks = def
                          { onServerCertificate = X509.validate HashSHA256
                              X509.defaultHooks
                                  { hookValidateName = validateName h }
                              X509.defaultChecks
                          }
                      , clientSupported = def
                          { supportedCiphers = ciphersuite_default }
                      }
              ManagerSettings -> IO Manager
forall (m :: * -> *). MonadIO m => ManagerSettings -> m Manager
newTlsManagerWith (ManagerSettings -> IO Manager) -> ManagerSettings -> IO Manager
forall a b. (a -> b) -> a -> b
$
                  TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings (ClientParams -> TLSSettings
TLSSettings ClientParams
defaultParams) Maybe SockSettings
forall a. Maybe a
Nothing

#endif


data StatsServerConf = StatsServerConf { StatsServerConf -> Int
ssPort          :: Int
                                       , StatsServerConf -> TimeInterval
ssPurgeInterval :: TimeInterval
                                       } deriving ReadPrec [StatsServerConf]
ReadPrec StatsServerConf
Int -> ReadS StatsServerConf
ReadS [StatsServerConf]
(Int -> ReadS StatsServerConf)
-> ReadS [StatsServerConf]
-> ReadPrec StatsServerConf
-> ReadPrec [StatsServerConf]
-> Read StatsServerConf
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS StatsServerConf
readsPrec :: Int -> ReadS StatsServerConf
$creadList :: ReadS [StatsServerConf]
readList :: ReadS [StatsServerConf]
$creadPrec :: ReadPrec StatsServerConf
readPrec :: ReadPrec StatsServerConf
$creadListPrec :: ReadPrec [StatsServerConf]
readListPrec :: ReadPrec [StatsServerConf]
Read

stats :: IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
stats :: IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
stats = IO (IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers)))
-> IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
forall a. IO a -> a
unsafePerformIO (IO (IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers)))
 -> IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers)))
-> IO (IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers)))
-> IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
forall a b. (a -> b) -> a -> b
$ (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
-> IO (IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers)))
forall a. a -> IO (IORef a)
newIORef (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) DiffTime
0, Map Int32 (UTCTime, MServiceKey Peers)
forall k a. Map k a
M.empty)
{-# NOINLINE stats #-}

both :: Arrow a => a b c -> a (b, b) (c, c)
both :: forall (a :: * -> * -> *) b c. Arrow a => a b c -> a (b, b) (c, c)
both = (a b c -> a b c -> a (b, b) (c, c)) -> a b c -> a (b, b) (c, c)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join a b c -> a b c -> a (b, b) (c, c)
forall b c b' c'. a b c -> a b' c' -> a (b, b') (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***)

#if MIN_VERSION_time(1,9,1)
asIntegerPart :: forall a. HasResolution a => Integer -> Fixed a
asIntegerPart :: forall a. HasResolution a => Integer -> Fixed a
asIntegerPart = Integer -> Fixed a
forall k (a :: k). Integer -> Fixed a
MkFixed (Integer -> Fixed a) -> (Integer -> Integer) -> Integer -> Fixed a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fixed a -> Integer
forall k (a :: k) (p :: k -> *). HasResolution a => p a -> Integer
forall (p :: * -> *). p a -> Integer
resolution (Fixed a
forall a. HasCallStack => a
undefined :: Fixed a) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*)
{-# SPECIALIZE INLINE asIntegerPart :: Integer -> Pico #-}
#endif

toNominalDiffTime :: TimeInterval -> NominalDiffTime
toNominalDiffTime :: TimeInterval -> NominalDiffTime
toNominalDiffTime =
#if MIN_VERSION_time(1,9,1)
    Pico -> NominalDiffTime
secondsToNominalDiffTime (Pico -> NominalDiffTime)
-> (TimeInterval -> Pico) -> TimeInterval -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Pico
forall a. HasResolution a => Integer -> Fixed a
asIntegerPart
#else
    fromRational . toRational . secondsToDiffTime
#endif
    (Integer -> Pico)
-> (TimeInterval -> Integer) -> TimeInterval -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer)
-> (TimeInterval -> Int) -> TimeInterval -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterval -> Int
toSec

getUrl :: Url -> Manager -> PeerHostName -> TimeInterval -> IO HttpStatus
getUrl :: [Char] -> Manager -> ServiceKey -> TimeInterval -> IO Int
getUrl [Char]
url Manager
man ServiceKey
hname ((Int
1e6 Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> (TimeInterval -> Int) -> TimeInterval -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterval -> Int
toSec -> Int
tmo) = do
    -- Note: using here httpNoBody makes Nginx backends claim about closed
    -- keepalive connections!
    Request
request <- [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
url
    Status -> Int
statusCode (Status -> Int)
-> (Response ByteString -> Status) -> Response ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response ByteString -> Status
forall body. Response body -> Status
responseStatus (Response ByteString -> Int) -> IO (Response ByteString) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Request -> Manager -> IO (Response ByteString)
httpLbsBrReadWithTimeout
            (Request
request { responseTimeout = responseTimeoutMicro tmo
                     , requestHeaders = [("Host", T.encodeUtf8 hname)]
                     }
            ) Manager
man

query :: Url -> TransportProtocol -> Maybe PeerHostName -> Peer ->
    TimeInterval -> IO (Peer, HttpStatus)
query :: [Char]
-> TransportProtocol
-> Maybe ServiceKey
-> (ServiceKey, ServiceKey)
-> TimeInterval
-> IO ((ServiceKey, ServiceKey), Int)
query [Char]
url TransportProtocol
proto Maybe ServiceKey
hname p :: (ServiceKey, ServiceKey)
p@(ServiceKey
addr, ServiceKey
hname') TimeInterval
tmo = do
    let name :: ServiceKey
name = ServiceKey -> Maybe ServiceKey -> ServiceKey
forall a. a -> Maybe a -> a
fromMaybe ServiceKey
hname' Maybe ServiceKey
hname
    Manager
man <- TransportProtocol -> ServiceKey -> IO Manager
getManager TransportProtocol
proto ServiceKey
name
    ((ServiceKey, ServiceKey)
p, ) (Int -> ((ServiceKey, ServiceKey), Int))
-> IO Int -> IO ((ServiceKey, ServiceKey), Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Manager -> ServiceKey -> TimeInterval -> IO Int
getUrl (ServiceKey -> [Char] -> [Char]
mkAddr ServiceKey
addr [Char]
url) Manager
man ServiceKey
name TimeInterval
tmo
    where mkAddr :: ServiceKey -> [Char] -> [Char]
mkAddr = ((TransportProtocol -> [Char]
forall {a}. IsString a => TransportProtocol -> a
getPrefix TransportProtocol
proto [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([Char] -> [Char]) -> [Char] -> [Char])
-> (ServiceKey -> [Char] -> [Char])
-> ServiceKey
-> [Char]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++) ([Char] -> [Char] -> [Char])
-> (ServiceKey -> [Char]) -> ServiceKey -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> [Char]
T.unpack
          getPrefix :: TransportProtocol -> a
getPrefix TransportProtocol
Http  = a
"http://"
          getPrefix TransportProtocol
Https = a
"https://"
          getManager :: TransportProtocol -> ServiceKey -> IO Manager
getManager TransportProtocol
Http ServiceKey
_ = Manager -> IO Manager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Manager
httpManager
          getManager TransportProtocol
Https ServiceKey
name =
#ifdef HEALTHCHECK_HTTPS
              ServiceKey -> HashMap ServiceKey Manager -> Maybe Manager
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup ServiceKey
name (HashMap ServiceKey Manager -> Maybe Manager)
-> IO (HashMap ServiceKey Manager) -> IO (Maybe Manager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (HashMap ServiceKey Manager)
-> IO (HashMap ServiceKey Manager)
forall a. IORef a -> IO a
readIORef IORef (HashMap ServiceKey Manager)
httpsManager IO (Maybe Manager) -> (Maybe Manager -> IO Manager) -> IO Manager
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                  IO Manager
-> (Manager -> IO Manager) -> Maybe Manager -> IO Manager
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO Manager
forall a. [Char] -> IO a
throwUserError ([Char] -> IO Manager) -> [Char] -> IO Manager
forall a b. (a -> b) -> a -> b
$
                            [Char]
"Https manager for name " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ServiceKey -> [Char]
T.unpack ServiceKey
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                [Char]
" wasn't found!"
                        ) Manager -> IO Manager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
#else
              name `seq` undefined
#endif

catchBadResponse :: Peer -> IO (Peer, HttpStatus) -> IO (Peer, HttpStatus)
catchBadResponse :: (ServiceKey, ServiceKey)
-> IO ((ServiceKey, ServiceKey), Int)
-> IO ((ServiceKey, ServiceKey), Int)
catchBadResponse (ServiceKey, ServiceKey)
p = (SomeException -> IO ((ServiceKey, ServiceKey), Int))
-> IO ((ServiceKey, ServiceKey), Int)
-> IO ((ServiceKey, ServiceKey), Int)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ((SomeException -> IO ((ServiceKey, ServiceKey), Int))
 -> IO ((ServiceKey, ServiceKey), Int)
 -> IO ((ServiceKey, ServiceKey), Int))
-> (SomeException -> IO ((ServiceKey, ServiceKey), Int))
-> IO ((ServiceKey, ServiceKey), Int)
-> IO ((ServiceKey, ServiceKey), Int)
forall a b. (a -> b) -> a -> b
$ \(SomeException
_ :: SomeException) -> ((ServiceKey, ServiceKey), Int)
-> IO ((ServiceKey, ServiceKey), Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ServiceKey, ServiceKey)
p, Int
0)

threadDelaySec :: Int -> IO ()
threadDelaySec :: Int -> IO ()
threadDelaySec = Int -> IO ()
threadDelay (Int -> IO ()) -> (Int -> Int) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1e6)

toSec :: TimeInterval -> Int
toSec :: TimeInterval -> Int
toSec (Hr Int
h)       = Int
3600 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h
toSec (Min Int
m)      = Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
m
toSec (Sec Int
s)      = Int
s
toSec (HrMin Int
h Int
m)  = Int
3600 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
m
toSec (MinSec Int
m Int
s) = Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s

byPassRule :: PassRule -> PassRuleParams -> Bool
byPassRule :: PassRule -> PassRuleParams -> Bool
byPassRule PassRule
DefaultPassRule
    PassRuleParams { responseHttpStatus :: PassRuleParams -> Int
responseHttpStatus = Int
st } = Int
st Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
200
byPassRule (PassRuleByHttpStatus [Int]
sts)
    PassRuleParams { responseHttpStatus :: PassRuleParams -> Int
responseHttpStatus = Int
st } = Int
st Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
sts

isActive :: ServiceKey -> IO Bool
isActive :: ServiceKey -> IO Bool
isActive ServiceKey
skey = (ServiceKey
skey ServiceKey -> FlatPeers -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) (FlatPeers -> Bool) -> IO FlatPeers -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef FlatPeers -> IO FlatPeers
forall a. IORef a -> IO a
readIORef IORef FlatPeers
active

lookupServiceKey :: ServiceKey -> MServiceKey a -> MUpstream a
lookupServiceKey :: forall a. ServiceKey -> MServiceKey a -> MUpstream a
lookupServiceKey = (MUpstream a -> Maybe (MUpstream a) -> MUpstream a
forall a. a -> Maybe a -> a
fromMaybe MUpstream a
forall k a. Map k a
M.empty (Maybe (MUpstream a) -> MUpstream a)
-> (MServiceKey a -> Maybe (MUpstream a))
-> MServiceKey a
-> MUpstream a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((MServiceKey a -> Maybe (MUpstream a))
 -> MServiceKey a -> MUpstream a)
-> (ServiceKey -> MServiceKey a -> Maybe (MUpstream a))
-> ServiceKey
-> MServiceKey a
-> MUpstream a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> MServiceKey a -> Maybe (MUpstream a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup
{-# SPECIALIZE INLINE lookupServiceKey ::
    ServiceKey -> MServiceKey NamedPeers -> MUpstream NamedPeers #-}

toHostName :: ServiceKey -> Maybe PeerHostName
toHostName :: ServiceKey -> Maybe ServiceKey
toHostName ServiceKey
key = let (ServiceKey
_, ServiceKey
t) = (Char -> Bool) -> ServiceKey -> (ServiceKey, ServiceKey)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') ServiceKey
key
                 in if ServiceKey -> Int
T.length ServiceKey
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
                        then ServiceKey -> Maybe ServiceKey
forall a. a -> Maybe a
Just (ServiceKey -> Maybe ServiceKey) -> ServiceKey -> Maybe ServiceKey
forall a b. (a -> b) -> a -> b
$ HasCallStack => ServiceKey -> ServiceKey
ServiceKey -> ServiceKey
T.tail ServiceKey
t
                        else if ServiceKey -> Int
T.length ServiceKey
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
                                 then Maybe ServiceKey
forall a. Maybe a
Nothing
                                 else ServiceKey -> Maybe ServiceKey
forall a. a -> Maybe a
Just ServiceKey
key

throwUserError :: String -> IO a
throwUserError :: forall a. [Char] -> IO a
throwUserError = IOError -> IO a
forall a. IOError -> IO a
ioError (IOError -> IO a) -> ([Char] -> IOError) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IOError
userError

throwWhenPeersUninitialized :: ServiceKey -> MUpstream a -> IO ()
throwWhenPeersUninitialized :: forall a. ServiceKey -> MUpstream a -> IO ()
throwWhenPeersUninitialized ServiceKey
skey MUpstream a
ps = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MUpstream a -> Bool
forall k a. Map k a -> Bool
M.null MUpstream a
ps) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. [Char] -> IO a
throwUserError ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [Char]
"Peers were not initialized for service set " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ServiceKey -> [Char]
T.unpack ServiceKey
skey [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!"
{-# SPECIALIZE INLINE throwWhenPeersUninitialized ::
    ServiceKey -> MUpstream NamedPeers -> IO () #-}

reportStats :: Int -> (Int32, ServiceKey, MUpstream Peers) -> IO ()
reportStats :: Int -> (Int32, ServiceKey, MUpstream Peers) -> IO ()
reportStats Int
ssp (Int32, ServiceKey, MUpstream Peers)
v = do
    (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
_ :: SomeException) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Request
req <- [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
"POST http://127.0.0.1"
        let !req' :: Request
req' = Request
req { requestBody = RequestBodyLBS $ encode v
                        , port = ssp
                        , Network.HTTP.Client.path = "report"
                        }
        IO (Response ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Response ()) -> IO ()) -> IO (Response ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ())
httpNoBody Request
req' Manager
httpManager

checkPeers :: ByteString -> Bool -> IO L.ByteString
checkPeers :: ByteString -> Bool -> IO ByteString
checkPeers ByteString
cf Bool
fstRun = do
    let (ByteString
skey, ByteString
cf') = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break Char -> Bool
isSpace (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
C8.dropWhile Char -> Bool
isSpace ByteString
cf
        skey' :: ServiceKey
skey' = ByteString -> ServiceKey
T.decodeUtf8 ByteString
skey
    Conf
cf'' <- IORef (Map ServiceKey Conf) -> IO (Map ServiceKey Conf)
forall a. IORef a -> IO a
readIORef IORef (Map ServiceKey Conf)
conf IO (Map ServiceKey Conf)
-> (Map ServiceKey Conf -> IO Conf) -> IO Conf
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        IO Conf -> (Conf -> IO Conf) -> Maybe Conf -> IO Conf
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (do
                  let cf'' :: Maybe Conf
cf'' = [Char] -> Maybe Conf
forall a. Read a => [Char] -> Maybe a
readMay ([Char] -> Maybe Conf) -> [Char] -> Maybe Conf
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
C8.unpack ByteString
cf'
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Conf -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Conf
cf'') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                      [Char] -> IO ()
forall a. [Char] -> IO a
terminateWorkerProcess [Char]
"Unreadable peers configuration!"
                  let cf''' :: Conf
cf''' = Maybe Conf -> Conf
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Conf
cf''
                  IORef (Map ServiceKey Conf)
-> (Map ServiceKey Conf -> (Map ServiceKey Conf, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map ServiceKey Conf)
conf ((Map ServiceKey Conf -> (Map ServiceKey Conf, ())) -> IO ())
-> (Map ServiceKey Conf -> (Map ServiceKey Conf, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) (Map ServiceKey Conf -> (Map ServiceKey Conf, ()))
-> (Map ServiceKey Conf -> Map ServiceKey Conf)
-> Map ServiceKey Conf
-> (Map ServiceKey Conf, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> Conf -> Map ServiceKey Conf -> Map ServiceKey Conf
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ServiceKey
skey' Conf
cf'''
                  Conf -> IO Conf
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Conf
cf'''
              ) Conf -> IO Conf
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Conf -> IO Conf)
-> (Map ServiceKey Conf -> Maybe Conf)
-> Map ServiceKey Conf
-> IO Conf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> Map ServiceKey Conf -> Maybe Conf
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
skey'
    let !us :: FlatPeers
us  = Conf -> FlatPeers
upstreams Conf
cf''
        ep :: Maybe Endpoint
ep   = Conf -> Maybe Endpoint
endpoint Conf
cf''
        int :: TimeInterval
int  = Conf -> TimeInterval
interval Conf
cf''
        pto :: TimeInterval
pto  = Conf -> TimeInterval
peerTimeout Conf
cf''
        !ssp :: Maybe Int
ssp = Conf -> Maybe Int
sendStatsPort Conf
cf''
    if Bool
fstRun
        then do
            MUpstream NamedPeers
peers' <- ServiceKey -> MServiceKey NamedPeers -> MUpstream NamedPeers
forall a. ServiceKey -> MServiceKey a -> MUpstream a
lookupServiceKey ServiceKey
skey' (MServiceKey NamedPeers -> MUpstream NamedPeers)
-> IO (MServiceKey NamedPeers) -> IO (MUpstream NamedPeers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (MServiceKey NamedPeers) -> IO (MServiceKey NamedPeers)
forall a. IORef a -> IO a
readIORef IORef (MServiceKey NamedPeers)
peers
            let hname :: Maybe ServiceKey
hname = ServiceKey -> Maybe ServiceKey
toHostName ServiceKey
skey'
                peers'' :: MUpstream NamedPeers
peers'' = (ServiceKey -> MUpstream NamedPeers -> MUpstream NamedPeers)
-> MUpstream NamedPeers -> FlatPeers -> MUpstream NamedPeers
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ServiceKey
 -> NamedPeers -> MUpstream NamedPeers -> MUpstream NamedPeers)
-> NamedPeers
-> ServiceKey
-> MUpstream NamedPeers
-> MUpstream NamedPeers
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((NamedPeers -> NamedPeers -> NamedPeers)
-> ServiceKey
-> NamedPeers
-> MUpstream NamedPeers
-> MUpstream NamedPeers
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith ((NamedPeers -> NamedPeers -> NamedPeers)
 -> ServiceKey
 -> NamedPeers
 -> MUpstream NamedPeers
 -> MUpstream NamedPeers)
-> (NamedPeers -> NamedPeers -> NamedPeers)
-> ServiceKey
-> NamedPeers
-> MUpstream NamedPeers
-> MUpstream NamedPeers
forall a b. (a -> b) -> a -> b
$ (NamedPeers -> NamedPeers)
-> NamedPeers -> NamedPeers -> NamedPeers
forall a b. a -> b -> a
const NamedPeers -> NamedPeers
forall a. a -> a
id) (Maybe ServiceKey
hname, []))
                              MUpstream NamedPeers
peers' FlatPeers
us
            IORef (MServiceKey NamedPeers)
-> (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (MServiceKey NamedPeers)
peers ((MServiceKey NamedPeers -> (MServiceKey NamedPeers, ())) -> IO ())
-> (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> (MServiceKey NamedPeers -> MServiceKey NamedPeers)
-> MServiceKey NamedPeers
-> (MServiceKey NamedPeers, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey
-> MUpstream NamedPeers
-> MServiceKey NamedPeers
-> MServiceKey NamedPeers
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ServiceKey
skey' MUpstream NamedPeers
peers''
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Endpoint -> Bool
forall a. Maybe a -> Bool
isJust Maybe Endpoint
ep) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case Endpoint -> TransportProtocol
epProto (Endpoint -> TransportProtocol) -> Endpoint -> TransportProtocol
forall a b. (a -> b) -> a -> b
$ Maybe Endpoint -> Endpoint
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Endpoint
ep of
                TransportProtocol
Https ->
#ifdef HEALTHCHECK_HTTPS
                    FlatPeers -> Maybe ServiceKey -> IO ()
mkHttpsManager FlatPeers
us Maybe ServiceKey
hname
#else
                    terminateWorkerProcess
                        "Healthcheck plugin wasn't built with support for https"
#endif
                TransportProtocol
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            IORef FlatPeers -> (FlatPeers -> (FlatPeers, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef FlatPeers
active ((FlatPeers -> (FlatPeers, ())) -> IO ())
-> (FlatPeers -> (FlatPeers, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) (FlatPeers -> (FlatPeers, ()))
-> (FlatPeers -> FlatPeers) -> FlatPeers -> (FlatPeers, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServiceKey
skey' ServiceKey -> FlatPeers -> FlatPeers
forall a. a -> [a] -> [a]
:)
        else Int -> IO ()
threadDelaySec (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ TimeInterval -> Int
toSec TimeInterval
int
    MUpstream NamedPeers
peers' <- ServiceKey -> MServiceKey NamedPeers -> MUpstream NamedPeers
forall a. ServiceKey -> MServiceKey a -> MUpstream a
lookupServiceKey ServiceKey
skey' (MServiceKey NamedPeers -> MUpstream NamedPeers)
-> IO (MServiceKey NamedPeers) -> IO (MUpstream NamedPeers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (MServiceKey NamedPeers) -> IO (MServiceKey NamedPeers)
forall a. IORef a -> IO a
readIORef IORef (MServiceKey NamedPeers)
peers
    ServiceKey -> MUpstream NamedPeers -> IO ()
forall a. ServiceKey -> MUpstream a -> IO ()
throwWhenPeersUninitialized ServiceKey
skey' MUpstream NamedPeers
peers'
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust Maybe Int
ssp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (CPid -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int32
pid) <- IO CPid
ngxCachedPid
        IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Int -> (Int32, ServiceKey, MUpstream Peers) -> IO ()
reportStats (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
ssp)
            (Int32
pid, ServiceKey
skey', (Peers -> Bool) -> MUpstream Peers -> MUpstream Peers
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool) -> (Peers -> Bool) -> Peers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peers -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (MUpstream Peers -> MUpstream Peers)
-> MUpstream Peers -> MUpstream Peers
forall a b. (a -> b) -> a -> b
$ (NamedPeers -> Peers) -> MUpstream NamedPeers -> MUpstream Peers
forall a b k. (a -> b) -> Map k a -> Map k b
M.map NamedPeers -> Peers
forall a b. (a, b) -> b
snd MUpstream NamedPeers
peers')
    let concatResult :: [ByteString] -> ByteString
concatResult = ByteString -> ByteString
L.fromStrict (ByteString -> ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat
    if Maybe Endpoint -> Bool
forall a. Maybe a -> Bool
isJust Maybe Endpoint
ep
        then do
            let ep' :: Endpoint
ep' = Maybe Endpoint -> Endpoint
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Endpoint
ep
            ((ServiceKey -> ByteString) -> FlatPeers -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString -> ByteString)
-> ByteString -> ByteString -> ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> ByteString -> ByteString
B.append ByteString
"\0\n" (ByteString -> ByteString)
-> (ServiceKey -> ByteString) -> ServiceKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> ByteString
T.encodeUtf8) -> [ByteString]
peers'') <-
                FlatPeers -> (ServiceKey -> IO ServiceKey) -> IO FlatPeers
forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
forConcurrently FlatPeers
us ((ServiceKey -> IO ServiceKey) -> IO FlatPeers)
-> (ServiceKey -> IO ServiceKey) -> IO FlatPeers
forall a b. (a -> b) -> a -> b
$ \ServiceKey
u -> do
                    let (Maybe ServiceKey
hname, !Peers
ps) = Maybe NamedPeers -> NamedPeers
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe NamedPeers -> NamedPeers) -> Maybe NamedPeers -> NamedPeers
forall a b. (a -> b) -> a -> b
$ ServiceKey -> MUpstream NamedPeers -> Maybe NamedPeers
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
u MUpstream NamedPeers
peers'
                    [((ServiceKey, ServiceKey), Int)]
ps' <- Peers
-> ((ServiceKey, ServiceKey) -> IO ((ServiceKey, ServiceKey), Int))
-> IO [((ServiceKey, ServiceKey), Int)]
forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
forConcurrently Peers
ps (((ServiceKey, ServiceKey) -> IO ((ServiceKey, ServiceKey), Int))
 -> IO [((ServiceKey, ServiceKey), Int)])
-> ((ServiceKey, ServiceKey) -> IO ((ServiceKey, ServiceKey), Int))
-> IO [((ServiceKey, ServiceKey), Int)]
forall a b. (a -> b) -> a -> b
$ \(ServiceKey, ServiceKey)
p ->
                        (ServiceKey, ServiceKey)
-> IO ((ServiceKey, ServiceKey), Int)
-> IO ((ServiceKey, ServiceKey), Int)
catchBadResponse (ServiceKey, ServiceKey)
p (IO ((ServiceKey, ServiceKey), Int)
 -> IO ((ServiceKey, ServiceKey), Int))
-> IO ((ServiceKey, ServiceKey), Int)
-> IO ((ServiceKey, ServiceKey), Int)
forall a b. (a -> b) -> a -> b
$
                            [Char]
-> TransportProtocol
-> Maybe ServiceKey
-> (ServiceKey, ServiceKey)
-> TimeInterval
-> IO ((ServiceKey, ServiceKey), Int)
query (Endpoint -> [Char]
epUrl Endpoint
ep') (Endpoint -> TransportProtocol
epProto Endpoint
ep') Maybe ServiceKey
hname (ServiceKey, ServiceKey)
p TimeInterval
pto
                    let (FlatPeers
psGood, FlatPeers
psBad) = ([(ServiceKey, Int)] -> FlatPeers)
-> ([(ServiceKey, Int)], [(ServiceKey, Int)])
-> (FlatPeers, FlatPeers)
forall (a :: * -> * -> *) b c. Arrow a => a b c -> a (b, b) (c, c)
both (((ServiceKey, Int) -> ServiceKey)
-> [(ServiceKey, Int)] -> FlatPeers
forall a b. (a -> b) -> [a] -> [b]
map (ServiceKey, Int) -> ServiceKey
forall a b. (a, b) -> a
fst) (([(ServiceKey, Int)], [(ServiceKey, Int)])
 -> (FlatPeers, FlatPeers))
-> ([(ServiceKey, Int)], [(ServiceKey, Int)])
-> (FlatPeers, FlatPeers)
forall a b. (a -> b) -> a -> b
$
                            ((ServiceKey, Int) -> Bool)
-> [(ServiceKey, Int)]
-> ([(ServiceKey, Int)], [(ServiceKey, Int)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (PassRule -> PassRuleParams -> Bool
byPassRule (Endpoint -> PassRule
epPassRule Endpoint
ep')
                                      (PassRuleParams -> Bool)
-> ((ServiceKey, Int) -> PassRuleParams)
-> (ServiceKey, Int)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Int
st -> PassRuleParams
defaultPassRuleParams
                                            { responseHttpStatus = st }
                                        )
                                      (Int -> PassRuleParams)
-> ((ServiceKey, Int) -> Int)
-> (ServiceKey, Int)
-> PassRuleParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServiceKey, Int) -> Int
forall a b. (a, b) -> b
snd
                                      ) ([(ServiceKey, Int)] -> ([(ServiceKey, Int)], [(ServiceKey, Int)]))
-> [(ServiceKey, Int)]
-> ([(ServiceKey, Int)], [(ServiceKey, Int)])
forall a b. (a -> b) -> a -> b
$ (((ServiceKey, ServiceKey), Int) -> (ServiceKey, Int))
-> [((ServiceKey, ServiceKey), Int)] -> [(ServiceKey, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (((ServiceKey, ServiceKey) -> ServiceKey)
-> ((ServiceKey, ServiceKey), Int) -> (ServiceKey, Int)
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 (ServiceKey, ServiceKey) -> ServiceKey
forall a b. (a, b) -> a
fst) [((ServiceKey, ServiceKey), Int)]
ps'
                        ic :: FlatPeers -> ServiceKey
ic = ServiceKey -> FlatPeers -> ServiceKey
T.intercalate ServiceKey
","
                    ServiceKey -> IO ServiceKey
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServiceKey -> IO ServiceKey) -> ServiceKey -> IO ServiceKey
forall a b. (a -> b) -> a -> b
$ FlatPeers -> ServiceKey
T.concat [ServiceKey
u, ServiceKey
"|", FlatPeers -> ServiceKey
ic FlatPeers
psBad, ServiceKey
"/", FlatPeers -> ServiceKey
ic FlatPeers
psGood]
            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
$ [ByteString] -> ByteString
concatResult [ByteString
"1", ByteString
skey, ByteString
"\n", [ByteString] -> ByteString
B.concat [ByteString]
peers'']
        else 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
$ [ByteString] -> ByteString
concatResult ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
            ByteString
"0" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
skey ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
"\n" ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: (ServiceKey -> ByteString) -> FlatPeers -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ServiceKey -> ByteString
T.encodeUtf8 (ServiceKey -> ByteString)
-> (ServiceKey -> ServiceKey) -> ServiceKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServiceKey -> ServiceKey -> ServiceKey
`T.append` ServiceKey
"|\0\n")) FlatPeers
us
ngxExportServiceIOYY 'checkPeers

readFlag :: ByteString -> CUIntPtr
readFlag :: ByteString -> CUIntPtr
readFlag ByteString
"0" = CUIntPtr
0
readFlag ByteString
"1" = CUIntPtr
1
readFlag ByteString
""  = [Char] -> CUIntPtr
forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpectedly empty check peers flag!"
readFlag ByteString
x   = [Char] -> CUIntPtr
forall a. HasCallStack => [Char] -> a
error ([Char] -> CUIntPtr) -> [Char] -> CUIntPtr
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected check peers flag " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
C8.unpack ByteString
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!"

foreign import ccall unsafe "plugin_ngx_http_haskell_healthcheck"
    c_healthcheck :: Ptr () -> Ptr () -> Ptr () -> CUIntPtr -> CUIntPtr ->
                     CString -> Ptr CString -> Ptr CSize -> IO CIntPtr

updatePeers :: ByteString -> IO L.ByteString
updatePeers :: ByteString -> IO ByteString
updatePeers (ByteString -> [ByteString]
C8.lines -> [ByteString]
ls)
    | (Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
1 -> (ByteString -> CUIntPtr
readFlag -> CUIntPtr
ck, ByteString
skey)) : [ByteString]
us <- [ByteString]
ls = do
        let skey' :: ServiceKey
skey'  = ByteString -> ServiceKey
T.decodeUtf8 ByteString
skey
            skey'' :: ByteString
skey'' = ByteString -> ByteString
L.fromStrict ByteString
skey
        Ptr ()
c   <- IO (Ptr ())
ngxCyclePtr
        Ptr ()
umc <- IO (Ptr ())
ngxUpstreamMainConfPtr
        Ptr ()
t   <- IO (Ptr (Ptr ()))
ngxCachedTimePtr IO (Ptr (Ptr ())) -> (Ptr (Ptr ()) -> IO (Ptr ())) -> IO (Ptr ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr (Ptr ()) -> IO (Ptr ())
forall a. Storable a => Ptr a -> IO a
peek
        Bool
a   <- ServiceKey -> IO Bool
isActive ServiceKey
skey'
        MUpstream NamedPeers
peers' <- ServiceKey -> MServiceKey NamedPeers -> MUpstream NamedPeers
forall a. ServiceKey -> MServiceKey a -> MUpstream a
lookupServiceKey ServiceKey
skey' (MServiceKey NamedPeers -> MUpstream NamedPeers)
-> IO (MServiceKey NamedPeers) -> IO (MUpstream NamedPeers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (MServiceKey NamedPeers) -> IO (MServiceKey NamedPeers)
forall a. IORef a -> IO a
readIORef IORef (MServiceKey NamedPeers)
peers
        if Bool
a
            then ServiceKey -> MUpstream NamedPeers -> IO ()
forall a. ServiceKey -> MUpstream a -> IO ()
throwWhenPeersUninitialized ServiceKey
skey' MUpstream NamedPeers
peers'
            else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe NamedPeers -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe NamedPeers -> Bool) -> Maybe NamedPeers -> Bool
forall a b. (a -> b) -> a -> b
$ ServiceKey -> MUpstream NamedPeers -> Maybe NamedPeers
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
skey' MUpstream NamedPeers
peers') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IORef (MServiceKey NamedPeers)
-> (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (MServiceKey NamedPeers)
peers ((MServiceKey NamedPeers -> (MServiceKey NamedPeers, ())) -> IO ())
-> (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> (MServiceKey NamedPeers -> MServiceKey NamedPeers)
-> MServiceKey NamedPeers
-> (MServiceKey NamedPeers, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey
-> MUpstream NamedPeers
-> MServiceKey NamedPeers
-> MServiceKey NamedPeers
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ServiceKey
skey' MUpstream NamedPeers
forall k a. Map k a
M.empty
        MVector RealWorld (Maybe ServiceKey)
usBad <- Int
-> Maybe ServiceKey
-> IO (MVector (PrimState IO) (Maybe ServiceKey))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MV.replicate ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
us) Maybe ServiceKey
forall a. Maybe a
Nothing
        [ByteString] -> (ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ByteString]
us ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ByteString
ps -> do
            let (ByteString -> ServiceKey
T.decodeUtf8 (ByteString -> ServiceKey)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> ServiceKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst -> !ServiceKey
u) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
C8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'|') ByteString
ps
            ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
B.unsafeUseAsCString ByteString
ps ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
ps' ->
                (Ptr CString -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CString -> IO ()) -> IO ())
-> (Ptr CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CString
pv ->
                    (Ptr CSize -> IO ()) -> IO ()
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO ()) -> IO ()) -> (Ptr CSize -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr CSize
pl -> do
                        ((CIntPtr
0 CIntPtr -> CIntPtr -> Bool
forall a. Eq a => a -> a -> Bool
==) -> !Bool
ok) <-
                            Ptr ()
-> Ptr ()
-> Ptr ()
-> CUIntPtr
-> CUIntPtr
-> CString
-> Ptr CString
-> Ptr CSize
-> IO CIntPtr
c_healthcheck Ptr ()
c Ptr ()
umc Ptr ()
t CUIntPtr
ck (Bool -> CUIntPtr
forall a. Num a => Bool -> a
fromBool Bool
a) CString
ps' Ptr CString
pv Ptr CSize
pl
                        if Bool
ok
                            then do
                                CString
v <- Ptr CString -> IO CString
forall a. Storable a => Ptr a -> IO a
peek Ptr CString
pv
                                (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
l) <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pl
                                ((ServiceKey -> (ServiceKey, ServiceKey)) -> FlatPeers -> Peers
forall a b. (a -> b) -> [a] -> [b]
map ((ServiceKey -> ServiceKey)
-> (ServiceKey, ServiceKey) -> (ServiceKey, ServiceKey)
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 (ServiceKey
-> ((Char, ServiceKey) -> ServiceKey)
-> Maybe (Char, ServiceKey)
-> ServiceKey
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ServiceKey
T.empty (Char, ServiceKey) -> ServiceKey
forall a b. (a, b) -> b
snd (Maybe (Char, ServiceKey) -> ServiceKey)
-> (ServiceKey -> Maybe (Char, ServiceKey))
-> ServiceKey
-> ServiceKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> Maybe (Char, ServiceKey)
T.uncons)
                                      ((ServiceKey, ServiceKey) -> (ServiceKey, ServiceKey))
-> (ServiceKey -> (ServiceKey, ServiceKey))
-> ServiceKey
-> (ServiceKey, ServiceKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ServiceKey -> (ServiceKey, ServiceKey)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')
                                     )
                                     (FlatPeers -> Peers)
-> (ByteString -> FlatPeers) -> ByteString -> Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServiceKey -> Bool) -> FlatPeers -> FlatPeers
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ServiceKey -> Bool) -> ServiceKey -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> Bool
T.null) (FlatPeers -> FlatPeers)
-> (ByteString -> FlatPeers) -> ByteString -> FlatPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ServiceKey -> FlatPeers
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')
                                    (ServiceKey -> FlatPeers)
-> (ByteString -> ServiceKey) -> ByteString -> FlatPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ServiceKey
T.decodeUtf8 -> Peers
ps'') <-
                                    CStringLen -> IO ByteString
B.unsafePackCStringLen (CString
v, Int
l)
                                let (Maybe ServiceKey
hname, Peers
peers'') =
                                        NamedPeers -> Maybe NamedPeers -> NamedPeers
forall a. a -> Maybe a -> a
fromMaybe (ServiceKey -> Maybe ServiceKey
toHostName ServiceKey
skey', []) (Maybe NamedPeers -> NamedPeers) -> Maybe NamedPeers -> NamedPeers
forall a b. (a -> b) -> a -> b
$
                                            ServiceKey -> MUpstream NamedPeers -> Maybe NamedPeers
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
u MUpstream NamedPeers
peers'
                                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Peers -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Peers
peers'' Bool -> Bool -> Bool
&& Peers -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Peers
ps'') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                    IORef (MServiceKey NamedPeers)
-> (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (MServiceKey NamedPeers)
peers ((MServiceKey NamedPeers -> (MServiceKey NamedPeers, ())) -> IO ())
-> (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
                                        (, ()) (MServiceKey NamedPeers -> (MServiceKey NamedPeers, ()))
-> (MServiceKey NamedPeers -> MServiceKey NamedPeers)
-> MServiceKey NamedPeers
-> (MServiceKey NamedPeers, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MUpstream NamedPeers -> Maybe (MUpstream NamedPeers))
-> ServiceKey -> MServiceKey NamedPeers -> MServiceKey NamedPeers
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update
                                                 (MUpstream NamedPeers -> Maybe (MUpstream NamedPeers)
forall a. a -> Maybe a
Just
                                                 (MUpstream NamedPeers -> Maybe (MUpstream NamedPeers))
-> (MUpstream NamedPeers -> MUpstream NamedPeers)
-> MUpstream NamedPeers
-> Maybe (MUpstream NamedPeers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey
-> NamedPeers -> MUpstream NamedPeers -> MUpstream NamedPeers
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ServiceKey
u (Maybe ServiceKey
hname, Peers
ps'')
                                                 ) ServiceKey
skey'
                            else do
                                Vector (Maybe ServiceKey)
usBad' <- MVector (PrimState IO) (Maybe ServiceKey)
-> IO (Vector (Maybe ServiceKey))
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector RealWorld (Maybe ServiceKey)
MVector (PrimState IO) (Maybe ServiceKey)
usBad
                                let idx :: Int
idx = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
                                        (Maybe ServiceKey -> Bool)
-> Vector (Maybe ServiceKey) -> Maybe Int
forall a. (a -> Bool) -> Vector a -> Maybe Int
V.findIndex (Maybe ServiceKey -> Maybe ServiceKey -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ServiceKey
forall a. Maybe a
Nothing) Vector (Maybe ServiceKey)
usBad'
                                MVector RealWorld (Maybe ServiceKey)
usBad'' <- Vector (Maybe ServiceKey)
-> IO (MVector (PrimState IO) (Maybe ServiceKey))
forall (m :: * -> *) a.
PrimMonad m =>
Vector a -> m (MVector (PrimState m) a)
V.unsafeThaw Vector (Maybe ServiceKey)
usBad'
                                MVector (PrimState IO) (Maybe ServiceKey)
-> Int -> Maybe ServiceKey -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.unsafeWrite MVector RealWorld (Maybe ServiceKey)
MVector (PrimState IO) (Maybe ServiceKey)
usBad'' Int
idx (Maybe ServiceKey -> IO ()) -> Maybe ServiceKey -> IO ()
forall a b. (a -> b) -> a -> b
$ ServiceKey -> Maybe ServiceKey
forall a. a -> Maybe a
Just ServiceKey
u
        (Vector (Maybe ServiceKey) -> [Maybe ServiceKey]
forall a. Vector a -> [a]
V.toList -> [Maybe ServiceKey]
usBad') <- MVector (PrimState IO) (Maybe ServiceKey)
-> IO (Vector (Maybe ServiceKey))
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector RealWorld (Maybe ServiceKey)
MVector (PrimState IO) (Maybe ServiceKey)
usBad
        let usBad'' :: ByteString
usBad'' = ByteString -> ByteString
L.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ServiceKey -> ByteString
T.encodeUtf8 (ServiceKey -> ByteString) -> ServiceKey -> ByteString
forall a b. (a -> b) -> a -> b
$ ServiceKey -> FlatPeers -> ServiceKey
T.intercalate ServiceKey
", " (FlatPeers -> ServiceKey) -> FlatPeers -> ServiceKey
forall a b. (a -> b) -> a -> b
$
                (Maybe ServiceKey -> ServiceKey) -> [Maybe ServiceKey] -> FlatPeers
forall a b. (a -> b) -> [a] -> [b]
map Maybe ServiceKey -> ServiceKey
forall a. HasCallStack => Maybe a -> a
fromJust ([Maybe ServiceKey] -> FlatPeers)
-> [Maybe ServiceKey] -> FlatPeers
forall a b. (a -> b) -> a -> b
$ (Maybe ServiceKey -> Bool)
-> [Maybe ServiceKey] -> [Maybe ServiceKey]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Maybe ServiceKey -> Maybe ServiceKey -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ServiceKey
forall a. Maybe a
Nothing) [Maybe ServiceKey]
usBad'
        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
$ if ByteString -> Bool
L.null ByteString
usBad''
                     then ByteString
""
                     else [ByteString] -> ByteString
L.concat [ByteString
"Healthcheck: upstreams [", ByteString
usBad''
                                   ,ByteString
"] from service set ", ByteString
skey''
                                   ,ByteString
" have failed to process"
                                   ]
    | Bool
otherwise = [Char] -> IO ByteString
forall a. [Char] -> IO a
throwUserError [Char]
"Parse error when reading saved peers data!"
ngxExportServiceHook 'updatePeers

updateStats :: L.ByteString -> NominalDiffTime -> IO ()
updateStats :: ByteString -> NominalDiffTime -> IO ()
updateStats ByteString
v NominalDiffTime
int = do
    let s :: Maybe (Int32, ServiceKey, MUpstream Peers)
s = ByteString -> Maybe (Int32, ServiceKey, MUpstream Peers)
forall a. FromJSON a => ByteString -> Maybe a
decode' ByteString
v
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Int32, ServiceKey, MUpstream Peers) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Int32, ServiceKey, MUpstream Peers)
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. [Char] -> IO a
throwUserError [Char]
"Unreadable stats!"
    let (Int32
pid, ServiceKey
skey, MUpstream Peers
ps) = Maybe (Int32, ServiceKey, MUpstream Peers)
-> (Int32, ServiceKey, MUpstream Peers)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Int32, ServiceKey, MUpstream Peers)
s
    !UTCTime
t <- IO UTCTime
getCurrentTime
    IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
-> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
    -> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers)), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
stats (((UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
  -> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers)), ()))
 -> IO ())
-> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
    -> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers)), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
        (, ()) ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
 -> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers)), ()))
-> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
    -> (UTCTime, Map Int32 (UTCTime, MServiceKey Peers)))
-> (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
-> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers)), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(UTCTime
t', Map Int32 (UTCTime, MServiceKey Peers)
ps') ->
            let (!UTCTime
tn, Map k (UTCTime, b) -> Map k (UTCTime, b)
f) =
                    if UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t UTCTime
t' NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
int
                        then (UTCTime
t
                             ,((UTCTime, b) -> Bool) -> Map k (UTCTime, b) -> Map k (UTCTime, b)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (((UTCTime, b) -> Bool)
 -> Map k (UTCTime, b) -> Map k (UTCTime, b))
-> ((UTCTime, b) -> Bool)
-> Map k (UTCTime, b)
-> Map k (UTCTime, b)
forall a b. (a -> b) -> a -> b
$ \(UTCTime
t'', b
_) -> UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t UTCTime
t'' NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
int
                             )
                        else (UTCTime
t', Map k (UTCTime, b) -> Map k (UTCTime, b)
forall a. a -> a
id)
                !psn :: Map Int32 (UTCTime, MServiceKey Peers)
psn = Map Int32 (UTCTime, MServiceKey Peers)
-> Map Int32 (UTCTime, MServiceKey Peers)
forall {k} {b}. Map k (UTCTime, b) -> Map k (UTCTime, b)
f (Map Int32 (UTCTime, MServiceKey Peers)
 -> Map Int32 (UTCTime, MServiceKey Peers))
-> Map Int32 (UTCTime, MServiceKey Peers)
-> Map Int32 (UTCTime, MServiceKey Peers)
forall a b. (a -> b) -> a -> b
$ (Maybe (UTCTime, MServiceKey Peers)
 -> Maybe (UTCTime, MServiceKey Peers))
-> Int32
-> Map Int32 (UTCTime, MServiceKey Peers)
-> Map Int32 (UTCTime, MServiceKey Peers)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter
                           (\Maybe (UTCTime, MServiceKey Peers)
old ->
                               let !new' :: MServiceKey Peers
new' = if Maybe (UTCTime, MServiceKey Peers) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (UTCTime, MServiceKey Peers)
old
                                               then ServiceKey -> MUpstream Peers -> MServiceKey Peers
forall k a. k -> a -> Map k a
ML.singleton ServiceKey
skey MUpstream Peers
ps
                                               else ServiceKey
-> MUpstream Peers -> MServiceKey Peers -> MServiceKey Peers
forall k a. Ord k => k -> a -> Map k a -> Map k a
ML.insert ServiceKey
skey MUpstream Peers
ps (MServiceKey Peers -> MServiceKey Peers)
-> MServiceKey Peers -> MServiceKey Peers
forall a b. (a -> b) -> a -> b
$
                                                   (UTCTime, MServiceKey Peers) -> MServiceKey Peers
forall a b. (a, b) -> b
snd ((UTCTime, MServiceKey Peers) -> MServiceKey Peers)
-> (UTCTime, MServiceKey Peers) -> MServiceKey Peers
forall a b. (a -> b) -> a -> b
$ Maybe (UTCTime, MServiceKey Peers) -> (UTCTime, MServiceKey Peers)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (UTCTime, MServiceKey Peers)
old
                               in (UTCTime, MServiceKey Peers) -> Maybe (UTCTime, MServiceKey Peers)
forall a. a -> Maybe a
Just (UTCTime
t, MServiceKey Peers
new')
                           ) Int32
pid Map Int32 (UTCTime, MServiceKey Peers)
ps'
            in (UTCTime
tn, Map Int32 (UTCTime, MServiceKey Peers)
psn)

receiveStats :: L.ByteString -> ByteString -> IO L.ByteString
receiveStats :: ByteString -> ByteString -> IO ByteString
receiveStats ByteString
v ByteString
sint = do
    let !int :: NominalDiffTime
int = TimeInterval -> NominalDiffTime
toNominalDiffTime (TimeInterval -> NominalDiffTime)
-> TimeInterval -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ TimeInterval -> [Char] -> TimeInterval
forall a. Read a => a -> [Char] -> a
readDef (Int -> TimeInterval
Min Int
5) ([Char] -> TimeInterval) -> [Char] -> TimeInterval
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
C8.unpack ByteString
sint
    ByteString -> NominalDiffTime -> IO ()
updateStats ByteString
v NominalDiffTime
int
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"done"
ngxExportAsyncOnReqBody 'receiveStats

sendStats' :: IO (Map Int32 (UTCTime, MServiceKey FlatPeers))
sendStats' :: IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
sendStats' = ((UTCTime, MServiceKey Peers)
 -> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> Map Int32 (UTCTime, MServiceKey Peers)
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((MServiceKey Peers -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, MServiceKey Peers)
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
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 ((MServiceKey Peers -> Map ServiceKey (Map ServiceKey FlatPeers))
 -> (UTCTime, MServiceKey Peers)
 -> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> (MServiceKey Peers -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, MServiceKey Peers)
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
forall a b. (a -> b) -> a -> b
$ (MUpstream Peers -> Map ServiceKey FlatPeers)
-> MServiceKey Peers -> Map ServiceKey (Map ServiceKey FlatPeers)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((MUpstream Peers -> Map ServiceKey FlatPeers)
 -> MServiceKey Peers -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (MUpstream Peers -> Map ServiceKey FlatPeers)
-> MServiceKey Peers
-> Map ServiceKey (Map ServiceKey FlatPeers)
forall a b. (a -> b) -> a -> b
$ (Peers -> FlatPeers) -> MUpstream Peers -> Map ServiceKey FlatPeers
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Peers -> FlatPeers)
 -> MUpstream Peers -> Map ServiceKey FlatPeers)
-> (Peers -> FlatPeers)
-> MUpstream Peers
-> Map ServiceKey FlatPeers
forall a b. (a -> b) -> a -> b
$ ((ServiceKey, ServiceKey) -> ServiceKey) -> Peers -> FlatPeers
forall a b. (a -> b) -> [a] -> [b]
map (ServiceKey, ServiceKey) -> ServiceKey
forall a b. (a, b) -> a
fst) (Map Int32 (UTCTime, MServiceKey Peers)
 -> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
    -> Map Int32 (UTCTime, MServiceKey Peers))
-> (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
-> Map Int32 (UTCTime, MServiceKey Peers)
forall a b. (a, b) -> b
snd ((UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
 -> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> IO (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
-> IO
     (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
-> IO (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
forall a. IORef a -> IO a
readIORef IORef (UTCTime, Map Int32 (UTCTime, MServiceKey Peers))
stats

sendStats :: ByteString -> IO ContentHandlerResult
sendStats :: ByteString -> IO ContentHandlerResult
sendStats = IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult
forall a b. a -> b -> a
const (IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult)
-> IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult
forall a b. (a -> b) -> a -> b
$
    (, ByteString
"text/plain", Int
200, []) (ByteString -> ContentHandlerResult)
-> (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
    -> ByteString)
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> ContentHandlerResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> ByteString
forall a. ToJSON a => a -> ByteString
encode
    (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> ByteString)
-> (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
    -> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Map ServiceKey (Map ServiceKey FlatPeers)
 -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
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 ((Map ServiceKey (Map ServiceKey FlatPeers)
  -> Map ServiceKey (Map ServiceKey FlatPeers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> (Map ServiceKey (Map ServiceKey FlatPeers)
    -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
forall a b. (a -> b) -> a -> b
$ (Map ServiceKey FlatPeers -> Bool)
-> Map ServiceKey (Map ServiceKey FlatPeers)
-> Map ServiceKey (Map ServiceKey FlatPeers)
forall a k. (a -> Bool) -> Map k a -> Map k a
ML.filter ((Map ServiceKey FlatPeers -> Bool)
 -> Map ServiceKey (Map ServiceKey FlatPeers)
 -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (Map ServiceKey FlatPeers -> Bool)
-> Map ServiceKey (Map ServiceKey FlatPeers)
-> Map ServiceKey (Map ServiceKey FlatPeers)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool)
-> (Map ServiceKey FlatPeers -> Bool)
-> Map ServiceKey FlatPeers
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ServiceKey FlatPeers -> Bool
forall a. Map ServiceKey a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
    (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> ContentHandlerResult)
-> IO
     (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> IO ContentHandlerResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
sendStats'
ngxExportAsyncHandler 'sendStats

sendMergedStats' :: IO (MServiceKey AnnotatedFlatPeers)
sendMergedStats' :: IO (MServiceKey AnnotatedFlatPeers)
sendMergedStats' = Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> MServiceKey AnnotatedFlatPeers
forall {k}.
Map k (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> MServiceKey AnnotatedFlatPeers
merge (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> MServiceKey AnnotatedFlatPeers)
-> IO
     (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> IO (MServiceKey AnnotatedFlatPeers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
sendStats'
    where merge :: Map k (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> MServiceKey AnnotatedFlatPeers
merge = (MServiceKey AnnotatedFlatPeers
 -> MServiceKey AnnotatedFlatPeers
 -> MServiceKey AnnotatedFlatPeers)
-> MServiceKey AnnotatedFlatPeers
-> Map k (MServiceKey AnnotatedFlatPeers)
-> MServiceKey AnnotatedFlatPeers
forall a b k. (a -> b -> a) -> a -> Map k b -> a
M.foldl ((Map ServiceKey AnnotatedFlatPeers
 -> Map ServiceKey AnnotatedFlatPeers
 -> Map ServiceKey AnnotatedFlatPeers)
-> MServiceKey AnnotatedFlatPeers
-> MServiceKey AnnotatedFlatPeers
-> MServiceKey AnnotatedFlatPeers
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
ML.unionWith ((Map ServiceKey AnnotatedFlatPeers
  -> Map ServiceKey AnnotatedFlatPeers
  -> Map ServiceKey AnnotatedFlatPeers)
 -> MServiceKey AnnotatedFlatPeers
 -> MServiceKey AnnotatedFlatPeers
 -> MServiceKey AnnotatedFlatPeers)
-> (Map ServiceKey AnnotatedFlatPeers
    -> Map ServiceKey AnnotatedFlatPeers
    -> Map ServiceKey AnnotatedFlatPeers)
-> MServiceKey AnnotatedFlatPeers
-> MServiceKey AnnotatedFlatPeers
-> MServiceKey AnnotatedFlatPeers
forall a b. (a -> b) -> a -> b
$ (AnnotatedFlatPeers -> AnnotatedFlatPeers -> AnnotatedFlatPeers)
-> Map ServiceKey AnnotatedFlatPeers
-> Map ServiceKey AnnotatedFlatPeers
-> Map ServiceKey AnnotatedFlatPeers
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith AnnotatedFlatPeers -> AnnotatedFlatPeers -> AnnotatedFlatPeers
pickLatest) MServiceKey AnnotatedFlatPeers
forall k a. Map k a
ML.empty
                  (Map k (MServiceKey AnnotatedFlatPeers)
 -> MServiceKey AnnotatedFlatPeers)
-> (Map k (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
    -> Map k (MServiceKey AnnotatedFlatPeers))
-> Map k (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> MServiceKey AnnotatedFlatPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> MServiceKey AnnotatedFlatPeers)
-> Map k (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> Map k (MServiceKey AnnotatedFlatPeers)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\(UTCTime
t, Map ServiceKey (Map ServiceKey FlatPeers)
s) -> (Map ServiceKey FlatPeers -> Map ServiceKey AnnotatedFlatPeers)
-> Map ServiceKey (Map ServiceKey FlatPeers)
-> MServiceKey AnnotatedFlatPeers
forall a b k. (a -> b) -> Map k a -> Map k b
ML.map ((FlatPeers -> AnnotatedFlatPeers)
-> Map ServiceKey FlatPeers -> Map ServiceKey AnnotatedFlatPeers
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((FlatPeers -> AnnotatedFlatPeers)
 -> Map ServiceKey FlatPeers -> Map ServiceKey AnnotatedFlatPeers)
-> (FlatPeers -> AnnotatedFlatPeers)
-> Map ServiceKey FlatPeers
-> Map ServiceKey AnnotatedFlatPeers
forall a b. (a -> b) -> a -> b
$ (ServiceKey -> (UTCTime, ServiceKey))
-> FlatPeers -> AnnotatedFlatPeers
forall a b. (a -> b) -> [a] -> [b]
map (UTCTime
t,)) Map ServiceKey (Map ServiceKey FlatPeers)
s)
          pickLatest :: AnnotatedFlatPeers -> AnnotatedFlatPeers -> AnnotatedFlatPeers
pickLatest = (((AnnotatedFlatPeers -> (UTCTime, ServiceKey))
-> [AnnotatedFlatPeers] -> AnnotatedFlatPeers
forall a b. (a -> b) -> [a] -> [b]
map (((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Ordering)
-> AnnotatedFlatPeers -> (UTCTime, ServiceKey)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Ordering)
 -> AnnotatedFlatPeers -> (UTCTime, ServiceKey))
-> ((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Ordering)
-> AnnotatedFlatPeers
-> (UTCTime, ServiceKey)
forall a b. (a -> b) -> a -> b
$ ((UTCTime, ServiceKey) -> UTCTime)
-> (UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (UTCTime, ServiceKey) -> UTCTime
forall a b. (a, b) -> a
fst)
                        ([AnnotatedFlatPeers] -> AnnotatedFlatPeers)
-> (AnnotatedFlatPeers -> [AnnotatedFlatPeers])
-> AnnotatedFlatPeers
-> AnnotatedFlatPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Bool)
-> AnnotatedFlatPeers -> [AnnotatedFlatPeers]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (ServiceKey -> ServiceKey -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ServiceKey -> ServiceKey -> Bool)
-> ((UTCTime, ServiceKey) -> ServiceKey)
-> (UTCTime, ServiceKey)
-> (UTCTime, ServiceKey)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (UTCTime, ServiceKey) -> ServiceKey
forall a b. (a, b) -> b
snd)
                        ) (AnnotatedFlatPeers -> AnnotatedFlatPeers)
-> (AnnotatedFlatPeers -> AnnotatedFlatPeers)
-> AnnotatedFlatPeers
-> AnnotatedFlatPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       ) ((AnnotatedFlatPeers -> AnnotatedFlatPeers)
 -> AnnotatedFlatPeers -> AnnotatedFlatPeers)
-> (AnnotatedFlatPeers -> AnnotatedFlatPeers -> AnnotatedFlatPeers)
-> AnnotatedFlatPeers
-> AnnotatedFlatPeers
-> AnnotatedFlatPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, ServiceKey) -> AnnotatedFlatPeers -> AnnotatedFlatPeers)
-> AnnotatedFlatPeers -> AnnotatedFlatPeers -> AnnotatedFlatPeers
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Ordering)
-> (UTCTime, ServiceKey)
-> AnnotatedFlatPeers
-> AnnotatedFlatPeers
forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
insertBy (ServiceKey -> ServiceKey -> Ordering
forall {a}. Eq a => a -> a -> Ordering
groupEqual (ServiceKey -> ServiceKey -> Ordering)
-> ((UTCTime, ServiceKey) -> ServiceKey)
-> (UTCTime, ServiceKey)
-> (UTCTime, ServiceKey)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (UTCTime, ServiceKey) -> ServiceKey
forall a b. (a, b) -> b
snd))
          groupEqual :: a -> a -> Ordering
groupEqual a
a a
b | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = Ordering
EQ
                         | Bool
otherwise = Ordering
GT

sendMergedStats :: ByteString -> IO ContentHandlerResult
sendMergedStats :: ByteString -> IO ContentHandlerResult
sendMergedStats = IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult
forall a b. a -> b -> a
const (IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult)
-> IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult
forall a b. (a -> b) -> a -> b
$
    (, ByteString
"text/plain", Int
200, []) (ByteString -> ContentHandlerResult)
-> (MServiceKey AnnotatedFlatPeers -> ByteString)
-> MServiceKey AnnotatedFlatPeers
-> ContentHandlerResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MServiceKey AnnotatedFlatPeers -> ByteString
forall a. ToJSON a => a -> ByteString
encode
    (MServiceKey AnnotatedFlatPeers -> ContentHandlerResult)
-> IO (MServiceKey AnnotatedFlatPeers) -> IO ContentHandlerResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MServiceKey AnnotatedFlatPeers)
sendMergedStats'
ngxExportAsyncHandler 'sendMergedStats


#ifdef SNAP_STATS_SERVER

ssConfig :: Int -> Config Snap a
ssConfig :: forall a. Int -> Config Snap a
ssConfig Int
p = Int -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. Int -> Config m a -> Config m a
setPort Int
p
           (Config Snap a -> Config Snap a) -> Config Snap a -> Config Snap a
forall a b. (a -> b) -> a -> b
$ ByteString -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. ByteString -> Config m a -> Config m a
setBind ByteString
"127.0.0.1"
           (Config Snap a -> Config Snap a) -> Config Snap a -> Config Snap a
forall a b. (a -> b) -> a -> b
$ ConfigLog -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
setAccessLog ConfigLog
ConfigNoLog
           (Config Snap a -> Config Snap a) -> Config Snap a -> Config Snap a
forall a b. (a -> b) -> a -> b
$ ConfigLog -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. ConfigLog -> Config m a -> Config m a
setErrorLog ConfigLog
ConfigNoLog
           (Config Snap a -> Config Snap a) -> Config Snap a -> Config Snap a
forall a b. (a -> b) -> a -> b
$ Bool -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. Bool -> Config m a -> Config m a
setVerbose Bool
False Config Snap a
forall a. Monoid a => a
mempty

ssHandler :: NominalDiffTime -> Snap ()
ssHandler :: NominalDiffTime -> Snap ()
ssHandler NominalDiffTime
int = [(ByteString, Snap ())] -> Snap ()
forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route [(ByteString
"report", Method -> Snap () -> Snap ()
forall (m :: * -> *) a. MonadSnap m => Method -> m a -> m a
Snap.Core.method Method
POST (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Snap ()
receiveStatsSnap NominalDiffTime
int)
                      ,(ByteString
"stat", Method -> Snap () -> Snap ()
forall (m :: * -> *) a. MonadSnap m => Method -> m a -> m a
Snap.Core.method Method
GET Snap ()
sendStatsSnap)
                      ,(ByteString
"stat/merge", Method -> Snap () -> Snap ()
forall (m :: * -> *) a. MonadSnap m => Method -> m a -> m a
Snap.Core.method Method
GET Snap ()
sendMergedStatsSnap)
                      ]

receiveStatsSnap :: NominalDiffTime -> Snap ()
receiveStatsSnap :: NominalDiffTime -> Snap ()
receiveStatsSnap NominalDiffTime
int =
    [Char] -> Snap () -> Snap ()
handleStatsExceptions [Char]
"Exception while receiving stats" (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ do
        !ByteString
s <- Word64 -> Snap ByteString
forall (m :: * -> *). MonadSnap m => Word64 -> m ByteString
readRequestBody Word64
65536
        IO () -> Snap ()
forall a. IO a -> Snap a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Snap ()) -> IO () -> Snap ()
forall a b. (a -> b) -> a -> b
$ ByteString -> NominalDiffTime -> IO ()
updateStats ByteString
s NominalDiffTime
int
        Response -> Snap ()
forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith Response
emptyResponse

sendStatsSnap :: Snap ()
sendStatsSnap :: Snap ()
sendStatsSnap =
    [Char] -> Snap () -> Snap ()
handleStatsExceptions [Char]
"Exception while sending stats" (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ do
        Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
s <- IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> Snap
     (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
forall a. IO a -> Snap a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
sendStats'
        (Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Response -> Response
setContentType ByteString
"application/json"
        ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS (ByteString -> Snap ()) -> ByteString -> Snap ()
forall a b. (a -> b) -> a -> b
$ Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> ByteString
forall a. ToJSON a => a -> ByteString
encode (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> ByteString)
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> ByteString
forall a b. (a -> b) -> a -> b
$ ((UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Map ServiceKey (Map ServiceKey FlatPeers)
 -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
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 ((Map ServiceKey (Map ServiceKey FlatPeers)
  -> Map ServiceKey (Map ServiceKey FlatPeers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers)))
-> (Map ServiceKey (Map ServiceKey FlatPeers)
    -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
-> (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
forall a b. (a -> b) -> a -> b
$ (Map ServiceKey FlatPeers -> Bool)
-> Map ServiceKey (Map ServiceKey FlatPeers)
-> Map ServiceKey (Map ServiceKey FlatPeers)
forall a k. (a -> Bool) -> Map k a -> Map k a
ML.filter ((Map ServiceKey FlatPeers -> Bool)
 -> Map ServiceKey (Map ServiceKey FlatPeers)
 -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (Map ServiceKey FlatPeers -> Bool)
-> Map ServiceKey (Map ServiceKey FlatPeers)
-> Map ServiceKey (Map ServiceKey FlatPeers)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool)
-> (Map ServiceKey FlatPeers -> Bool)
-> Map ServiceKey FlatPeers
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ServiceKey FlatPeers -> Bool
forall a. Map ServiceKey a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey FlatPeers))
s

sendMergedStatsSnap :: Snap ()
sendMergedStatsSnap :: Snap ()
sendMergedStatsSnap =
    [Char] -> Snap () -> Snap ()
handleStatsExceptions [Char]
"Exception while sending stats" (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ do
        MServiceKey AnnotatedFlatPeers
s <- IO (MServiceKey AnnotatedFlatPeers)
-> Snap (MServiceKey AnnotatedFlatPeers)
forall a. IO a -> Snap a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MServiceKey AnnotatedFlatPeers)
sendMergedStats'
        (Response -> Response) -> Snap ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> Snap ())
-> (Response -> Response) -> Snap ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Response -> Response
setContentType ByteString
"application/json"
        ByteString -> Snap ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeLBS (ByteString -> Snap ()) -> ByteString -> Snap ()
forall a b. (a -> b) -> a -> b
$ MServiceKey AnnotatedFlatPeers -> ByteString
forall a. ToJSON a => a -> ByteString
encode MServiceKey AnnotatedFlatPeers
s

handleStatsExceptions :: String -> Snap () -> Snap ()
handleStatsExceptions :: [Char] -> Snap () -> Snap ()
handleStatsExceptions [Char]
cmsg = (SomeException -> Snap ()) -> Snap () -> Snap ()
forall (m :: * -> *) a.
MonadBaseControl IO m =>
(SomeException -> m a) -> m a -> m a
handleAny ((SomeException -> Snap ()) -> Snap () -> Snap ())
-> (SomeException -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ \SomeException
e ->
    Int -> [Char] -> Snap ()
forall {m :: * -> *}. MonadSnap m => Int -> [Char] -> m ()
writeErrorResponse Int
500 ([Char] -> Snap ()) -> [Char] -> Snap ()
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show (SomeException
e :: SomeException)
    where writeErrorResponse :: Int -> [Char] -> m ()
writeErrorResponse Int
c [Char]
msg = do
              (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> Response -> Response
setResponseStatus Int
c (ByteString -> Response -> Response)
-> ByteString -> Response -> Response
forall a b. (a -> b) -> a -> b
$ ServiceKey -> ByteString
T.encodeUtf8 (ServiceKey -> ByteString) -> ServiceKey -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ServiceKey
T.pack [Char]
cmsg
              ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ServiceKey -> ByteString
T.encodeUtf8 (ServiceKey -> ByteString) -> ServiceKey -> ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ServiceKey
T.pack [Char]
msg

statsServer :: ByteString -> Bool -> IO L.ByteString
statsServer :: ByteString -> Bool -> IO ByteString
statsServer ByteString
cf Bool
fstRun = do
    if Bool
fstRun
        then do
            StatsServerConf
cf' <- IO StatsServerConf
-> (StatsServerConf -> IO StatsServerConf)
-> Maybe StatsServerConf
-> IO StatsServerConf
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> IO StatsServerConf
forall a. [Char] -> IO a
terminateWorkerProcess
                             [Char]
"Unreadable stats server configuration!"
                         ) StatsServerConf -> IO StatsServerConf
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe StatsServerConf -> IO StatsServerConf)
-> Maybe StatsServerConf -> IO StatsServerConf
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe StatsServerConf
forall a. Read a => [Char] -> Maybe a
readMay ([Char] -> Maybe StatsServerConf)
-> [Char] -> Maybe StatsServerConf
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
C8.unpack ByteString
cf
            let !int :: NominalDiffTime
int = TimeInterval -> NominalDiffTime
toNominalDiffTime (TimeInterval -> NominalDiffTime)
-> TimeInterval -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ StatsServerConf -> TimeInterval
ssPurgeInterval StatsServerConf
cf'
            Config Snap Any -> Snap () -> IO ()
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> Snap () -> IO ()
simpleHttpServe (Int -> Config Snap Any
forall a. Int -> Config Snap a
ssConfig (Int -> Config Snap Any) -> Int -> Config Snap Any
forall a b. (a -> b) -> a -> b
$ StatsServerConf -> Int
ssPort StatsServerConf
cf') (Snap () -> IO ()) -> Snap () -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Snap ()
ssHandler NominalDiffTime
int
        else Int -> IO ()
threadDelaySec Int
5
    ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
ngxExportServiceIOYY 'statsServer

#endif


reportPeers :: ByteString -> IO ContentHandlerResult
reportPeers :: ByteString -> IO ContentHandlerResult
reportPeers = IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult
forall a b. a -> b -> a
const (IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult)
-> IO ContentHandlerResult -> ByteString -> IO ContentHandlerResult
forall a b. (a -> b) -> a -> b
$ do
    ((MUpstream NamedPeers -> Map ServiceKey FlatPeers)
-> MServiceKey NamedPeers
-> Map ServiceKey (Map ServiceKey FlatPeers)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((MUpstream NamedPeers -> Map ServiceKey FlatPeers)
 -> MServiceKey NamedPeers
 -> Map ServiceKey (Map ServiceKey FlatPeers))
-> (MUpstream NamedPeers -> Map ServiceKey FlatPeers)
-> MServiceKey NamedPeers
-> Map ServiceKey (Map ServiceKey FlatPeers)
forall a b. (a -> b) -> a -> b
$ (Peers -> FlatPeers) -> MUpstream Peers -> Map ServiceKey FlatPeers
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (((ServiceKey, ServiceKey) -> ServiceKey) -> Peers -> FlatPeers
forall a b. (a -> b) -> [a] -> [b]
map (ServiceKey, ServiceKey) -> ServiceKey
forall a b. (a, b) -> a
fst) (MUpstream Peers -> Map ServiceKey FlatPeers)
-> (MUpstream NamedPeers -> MUpstream Peers)
-> MUpstream NamedPeers
-> Map ServiceKey FlatPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Peers -> Bool) -> MUpstream Peers -> MUpstream Peers
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool) -> (Peers -> Bool) -> Peers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peers -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (MUpstream Peers -> MUpstream Peers)
-> (MUpstream NamedPeers -> MUpstream Peers)
-> MUpstream NamedPeers
-> MUpstream Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedPeers -> Peers) -> MUpstream NamedPeers -> MUpstream Peers
forall a b k. (a -> b) -> Map k a -> Map k b
M.map NamedPeers -> Peers
forall a b. (a, b) -> b
snd -> Map ServiceKey (Map ServiceKey FlatPeers)
peers') <-
        IORef (MServiceKey NamedPeers) -> IO (MServiceKey NamedPeers)
forall a. IORef a -> IO a
readIORef IORef (MServiceKey NamedPeers)
peers
    ContentHandlerResult -> IO ContentHandlerResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ServiceKey (Map ServiceKey FlatPeers) -> ByteString
forall a. ToJSON a => a -> ByteString
encode Map ServiceKey (Map ServiceKey FlatPeers)
peers', ByteString
"application/json", Int
200, [])
ngxExportAsyncHandler 'reportPeers