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

-----------------------------------------------------------------------------
-- |
-- Module      :  NgxExport.Healthcheck
-- Copyright   :  (c) Alexey Radkov 2022
-- 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 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 -> Peers
upstreams     :: [Upstream]
                 , Conf -> TimeInterval
interval      :: TimeInterval
                 , Conf -> TimeInterval
peerTimeout   :: TimeInterval
                 , Conf -> Maybe Endpoint
endpoint      :: Maybe Endpoint
                 , Conf -> Maybe HttpStatus
sendStatsPort :: Maybe Int
                 } deriving ReadPrec [Conf]
ReadPrec Conf
HttpStatus -> ReadS Conf
ReadS [Conf]
(HttpStatus -> ReadS Conf)
-> ReadS [Conf] -> ReadPrec Conf -> ReadPrec [Conf] -> Read Conf
forall a.
(HttpStatus -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: HttpStatus -> ReadS Conf
readsPrec :: HttpStatus -> 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 -> PassRule
epPassRule :: PassRule
                         } deriving ReadPrec [Endpoint]
ReadPrec Endpoint
HttpStatus -> ReadS Endpoint
ReadS [Endpoint]
(HttpStatus -> ReadS Endpoint)
-> ReadS [Endpoint]
-> ReadPrec Endpoint
-> ReadPrec [Endpoint]
-> Read Endpoint
forall a.
(HttpStatus -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: HttpStatus -> ReadS Endpoint
readsPrec :: HttpStatus -> ReadS Endpoint
$creadList :: ReadS [Endpoint]
readList :: ReadS [Endpoint]
$creadPrec :: ReadPrec Endpoint
readPrec :: ReadPrec Endpoint
$creadListPrec :: ReadPrec [Endpoint]
readListPrec :: ReadPrec [Endpoint]
Read

data PassRule = DefaultPassRule
              | PassRuleByHttpStatus [HttpStatus]
              deriving ReadPrec [PassRule]
ReadPrec PassRule
HttpStatus -> ReadS PassRule
ReadS [PassRule]
(HttpStatus -> ReadS PassRule)
-> ReadS [PassRule]
-> ReadPrec PassRule
-> ReadPrec [PassRule]
-> Read PassRule
forall a.
(HttpStatus -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: HttpStatus -> ReadS PassRule
readsPrec :: HttpStatus -> 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 -> HttpStatus
responseHttpStatus :: HttpStatus }

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

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

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

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

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

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

data StatsServerConf = StatsServerConf { StatsServerConf -> HttpStatus
ssPort          :: Int
                                       , StatsServerConf -> TimeInterval
ssPurgeInterval :: TimeInterval
                                       } deriving ReadPrec [StatsServerConf]
ReadPrec StatsServerConf
HttpStatus -> ReadS StatsServerConf
ReadS [StatsServerConf]
(HttpStatus -> ReadS StatsServerConf)
-> ReadS [StatsServerConf]
-> ReadPrec StatsServerConf
-> ReadPrec [StatsServerConf]
-> Read StatsServerConf
forall a.
(HttpStatus -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: HttpStatus -> ReadS StatsServerConf
readsPrec :: HttpStatus -> 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, Map ServiceKey (Map ServiceKey Peers)))
stats = IO
  (IORef
     (UTCTime,
      Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))))
-> IORef
     (UTCTime,
      Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
forall a. IO a -> a
unsafePerformIO (IO
   (IORef
      (UTCTime,
       Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))))
 -> IORef
      (UTCTime,
       Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))))
-> IO
     (IORef
        (UTCTime,
         Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))))
-> IORef
     (UTCTime,
      Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
forall a b. (a -> b) -> a -> b
$ (UTCTime,
 Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> IO
     (IORef
        (UTCTime,
         Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))))
forall a. a -> IO (IORef a)
newIORef (Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day
ModifiedJulianDay Integer
0) DiffTime
0, Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey 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
. HttpStatus -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HttpStatus -> Integer)
-> (TimeInterval -> HttpStatus) -> TimeInterval -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterval -> HttpStatus
toSec

getUrl :: ServiceKey -> Url -> IO HttpStatus
getUrl :: ServiceKey -> [Char] -> IO HttpStatus
getUrl ServiceKey
skey [Char]
url = do
    Maybe Manager
httpManager' <- ServiceKey -> Map ServiceKey Manager -> Maybe Manager
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
skey (Map ServiceKey Manager -> Maybe Manager)
-> IO (Map ServiceKey Manager) -> IO (Maybe Manager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map ServiceKey Manager) -> IO (Map ServiceKey Manager)
forall a. IORef a -> IO a
readIORef IORef (Map ServiceKey Manager)
httpManager
    if Maybe Manager -> Bool
forall a. Maybe a -> Bool
isJust Maybe Manager
httpManager'
        then -- using httpNoBody here makes Nginx backends claim about closed
             -- keepalive connections!
             [Char] -> (Request -> IO (Response ByteString)) -> IO HttpStatus
forall {f :: * -> *} {body}.
MonadThrow f =>
[Char] -> (Request -> f (Response body)) -> f HttpStatus
getResponseStatus [Char]
url ((Request -> IO (Response ByteString)) -> IO HttpStatus)
-> (Request -> IO (Response ByteString)) -> IO HttpStatus
forall a b. (a -> b) -> a -> b
$
                 (Request -> Manager -> IO (Response ByteString))
-> Manager -> Request -> IO (Response ByteString)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ByteString)
httpLbsBrReadWithTimeout (Manager -> Request -> IO (Response ByteString))
-> Manager -> Request -> IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Maybe Manager -> Manager
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Manager
httpManager'
        else IO HttpStatus
forall a. HasCallStack => a
undefined
    where getResponseStatus :: [Char] -> (Request -> f (Response body)) -> f HttpStatus
getResponseStatus [Char]
u =
            (Response body -> HttpStatus) -> f (Response body) -> f HttpStatus
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Status -> HttpStatus
statusCode (Status -> HttpStatus)
-> (Response body -> Status) -> Response body -> HttpStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response body -> Status
forall body. Response body -> Status
responseStatus) (f (Response body) -> f HttpStatus)
-> ((Request -> f (Response body)) -> f (Response body))
-> (Request -> f (Response body))
-> f HttpStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> f Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
u f Request -> (Request -> f (Response body)) -> f (Response body)
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)

query :: ServiceKey -> Url -> Peer -> IO (Peer, HttpStatus)
query :: ServiceKey -> [Char] -> ServiceKey -> IO (ServiceKey, HttpStatus)
query ServiceKey
skey [Char]
url = Kleisli IO ServiceKey (ServiceKey, HttpStatus)
-> ServiceKey -> IO (ServiceKey, HttpStatus)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli (Kleisli IO ServiceKey (ServiceKey, HttpStatus)
 -> ServiceKey -> IO (ServiceKey, HttpStatus))
-> Kleisli IO ServiceKey (ServiceKey, HttpStatus)
-> ServiceKey
-> IO (ServiceKey, HttpStatus)
forall a b. (a -> b) -> a -> b
$ (ServiceKey -> ServiceKey) -> Kleisli IO ServiceKey ServiceKey
forall b c. (b -> c) -> Kleisli IO b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ServiceKey -> ServiceKey
forall a. a -> a
id Kleisli IO ServiceKey ServiceKey
-> Kleisli IO ServiceKey HttpStatus
-> Kleisli IO ServiceKey (ServiceKey, HttpStatus)
forall b c c'.
Kleisli IO b c -> Kleisli IO b c' -> Kleisli IO b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (ServiceKey -> IO HttpStatus) -> Kleisli IO ServiceKey HttpStatus
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (ServiceKey -> [Char] -> IO HttpStatus
getUrl ServiceKey
skey ([Char] -> IO HttpStatus)
-> (ServiceKey -> [Char]) -> ServiceKey -> IO HttpStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServiceKey -> [Char] -> [Char]) -> [Char] -> ServiceKey -> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ServiceKey -> [Char] -> [Char]
mkAddr [Char]
url)
    where mkAddr :: ServiceKey -> [Char] -> [Char]
mkAddr = (([Char]
"http://" [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

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

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

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

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

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

lookupServiceKey :: ServiceKey -> MServiceKey Peers -> MUpstream Peers
lookupServiceKey :: ServiceKey
-> Map ServiceKey (Map ServiceKey Peers) -> Map ServiceKey Peers
lookupServiceKey = (Map ServiceKey Peers
-> Maybe (Map ServiceKey Peers) -> Map ServiceKey Peers
forall a. a -> Maybe a -> a
fromMaybe Map ServiceKey Peers
forall k a. Map k a
M.empty (Maybe (Map ServiceKey Peers) -> Map ServiceKey Peers)
-> (Map ServiceKey (Map ServiceKey Peers)
    -> Maybe (Map ServiceKey Peers))
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Map ServiceKey (Map ServiceKey Peers)
  -> Maybe (Map ServiceKey Peers))
 -> Map ServiceKey (Map ServiceKey Peers) -> Map ServiceKey Peers)
-> (ServiceKey
    -> Map ServiceKey (Map ServiceKey Peers)
    -> Maybe (Map ServiceKey Peers))
-> ServiceKey
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey
-> Map ServiceKey (Map ServiceKey Peers)
-> Maybe (Map ServiceKey Peers)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup

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 Peers -> IO ()
throwWhenPeersUninitialized :: ServiceKey -> Map ServiceKey Peers -> IO ()
throwWhenPeersUninitialized ServiceKey
skey Map ServiceKey Peers
ps = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map ServiceKey Peers -> Bool
forall k a. Map k a -> Bool
M.null Map ServiceKey Peers
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]
"!"

reportStats :: Int -> (Int32, ServiceKey, MUpstream Peers) -> IO ()
reportStats :: HttpStatus -> (Int32, ServiceKey, Map ServiceKey Peers) -> IO ()
reportStats HttpStatus
ssp v :: (Int32, ServiceKey, Map ServiceKey Peers)
v@(Int32
_, ServiceKey
skey, Map ServiceKey Peers
_) = do
    Maybe Manager
httpManager' <- ServiceKey -> Map ServiceKey Manager -> Maybe Manager
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
skey (Map ServiceKey Manager -> Maybe Manager)
-> IO (Map ServiceKey Manager) -> IO (Maybe Manager)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map ServiceKey Manager) -> IO (Map ServiceKey Manager)
forall a. IORef a -> IO a
readIORef IORef (Map ServiceKey Manager)
httpManager
    if Maybe Manager -> Bool
forall a. Maybe a -> Bool
isJust Maybe Manager
httpManager'
        then (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 -> IO (Response ())) -> Manager -> IO (Response ())
forall a b. (a -> b) -> a -> b
$ Maybe Manager -> Manager
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Manager
httpManager'
        else IO ()
forall a. HasCallStack => a
undefined

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
$ TerminateWorkerProcess -> IO ()
forall e a. Exception e => e -> IO a
throwIO (TerminateWorkerProcess -> IO ())
-> TerminateWorkerProcess -> IO ()
forall a b. (a -> b) -> a -> b
$
                      [Char] -> TerminateWorkerProcess
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 :: Peers
us  = Conf -> Peers
upstreams Conf
cf''
        ep :: Maybe Endpoint
ep   = Conf -> Maybe Endpoint
endpoint Conf
cf''
        int :: HttpStatus
int  = TimeInterval -> HttpStatus
toSec (TimeInterval -> HttpStatus) -> TimeInterval -> HttpStatus
forall a b. (a -> b) -> a -> b
$ Conf -> TimeInterval
interval Conf
cf''
        pto :: HttpStatus
pto  = TimeInterval -> HttpStatus
toSec (TimeInterval -> HttpStatus) -> TimeInterval -> HttpStatus
forall a b. (a -> b) -> a -> b
$ Conf -> TimeInterval
peerTimeout Conf
cf''
        !ssp :: Maybe HttpStatus
ssp = Conf -> Maybe HttpStatus
sendStatsPort Conf
cf''
    if Bool
fstRun
        then do
            Map ServiceKey Peers
peers' <- ServiceKey
-> Map ServiceKey (Map ServiceKey Peers) -> Map ServiceKey Peers
lookupServiceKey ServiceKey
skey' (Map ServiceKey (Map ServiceKey Peers) -> Map ServiceKey Peers)
-> IO (Map ServiceKey (Map ServiceKey Peers))
-> IO (Map ServiceKey Peers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map ServiceKey (Map ServiceKey Peers))
-> IO (Map ServiceKey (Map ServiceKey Peers))
forall a. IORef a -> IO a
readIORef IORef (Map ServiceKey (Map ServiceKey Peers))
peers
            let peers'' :: Map ServiceKey Peers
peers'' = (ServiceKey -> Map ServiceKey Peers -> Map ServiceKey Peers)
-> Map ServiceKey Peers -> Peers -> Map ServiceKey Peers
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ServiceKey
 -> Peers -> Map ServiceKey Peers -> Map ServiceKey Peers)
-> Peers
-> ServiceKey
-> Map ServiceKey Peers
-> Map ServiceKey Peers
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Peers -> Peers -> Peers)
-> ServiceKey
-> Peers
-> Map ServiceKey Peers
-> Map ServiceKey Peers
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith ((Peers -> Peers -> Peers)
 -> ServiceKey
 -> Peers
 -> Map ServiceKey Peers
 -> Map ServiceKey Peers)
-> (Peers -> Peers -> Peers)
-> ServiceKey
-> Peers
-> Map ServiceKey Peers
-> Map ServiceKey Peers
forall a b. (a -> b) -> a -> b
$ (Peers -> Peers) -> Peers -> Peers -> Peers
forall a b. a -> b -> a
const Peers -> Peers
forall a. a -> a
id) []) Map ServiceKey Peers
peers' Peers
us
            IORef (Map ServiceKey (Map ServiceKey Peers))
-> (Map ServiceKey (Map ServiceKey Peers)
    -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map ServiceKey (Map ServiceKey Peers))
peers ((Map ServiceKey (Map ServiceKey Peers)
  -> (Map ServiceKey (Map ServiceKey Peers), ()))
 -> IO ())
-> (Map ServiceKey (Map ServiceKey Peers)
    -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) (Map ServiceKey (Map ServiceKey Peers)
 -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> (Map ServiceKey (Map ServiceKey Peers)
    -> Map ServiceKey (Map ServiceKey Peers))
-> Map ServiceKey (Map ServiceKey Peers)
-> (Map ServiceKey (Map ServiceKey Peers), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey
-> Map ServiceKey Peers
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ServiceKey
skey' Map ServiceKey Peers
peers''
            IORef (Map ServiceKey Manager) -> IO (Map ServiceKey Manager)
forall a. IORef a -> IO a
readIORef IORef (Map ServiceKey Manager)
httpManager IO (Map ServiceKey Manager)
-> (Map ServiceKey Manager -> IO ()) -> IO ()
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 -> IO ()) -> Maybe Manager -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IORef (Map ServiceKey Manager)
-> (Map ServiceKey Manager -> (Map ServiceKey Manager, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map ServiceKey Manager)
httpManager ((Map ServiceKey Manager -> (Map ServiceKey Manager, ())) -> IO ())
-> (Map ServiceKey Manager -> (Map ServiceKey Manager, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
                          (, ()) (Map ServiceKey Manager -> (Map ServiceKey Manager, ()))
-> (Map ServiceKey Manager -> Map ServiceKey Manager)
-> Map ServiceKey Manager
-> (Map ServiceKey Manager, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey
-> Manager -> Map ServiceKey Manager -> Map ServiceKey Manager
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ServiceKey
skey'
                                   (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
                                       { managerResponseTimeout =
                                           responseTimeoutMicro $ pto * 1e6
                                       }
                                   )
                      ) (IO Manager -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Manager -> IO ())
-> (Manager -> IO Manager) -> Manager -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Manager -> IO Manager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return) (Maybe Manager -> IO ())
-> (Map ServiceKey Manager -> Maybe Manager)
-> Map ServiceKey Manager
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> Map ServiceKey Manager -> Maybe Manager
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
skey'
            IORef Peers -> (Peers -> (Peers, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Peers
active ((Peers -> (Peers, ())) -> IO ())
-> (Peers -> (Peers, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) (Peers -> (Peers, ())) -> (Peers -> Peers) -> Peers -> (Peers, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServiceKey
skey' ServiceKey -> Peers -> Peers
forall a. a -> [a] -> [a]
:)
        else HttpStatus -> IO ()
threadDelaySec HttpStatus
int
    Map ServiceKey Peers
peers' <- ServiceKey
-> Map ServiceKey (Map ServiceKey Peers) -> Map ServiceKey Peers
lookupServiceKey ServiceKey
skey' (Map ServiceKey (Map ServiceKey Peers) -> Map ServiceKey Peers)
-> IO (Map ServiceKey (Map ServiceKey Peers))
-> IO (Map ServiceKey Peers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map ServiceKey (Map ServiceKey Peers))
-> IO (Map ServiceKey (Map ServiceKey Peers))
forall a. IORef a -> IO a
readIORef IORef (Map ServiceKey (Map ServiceKey Peers))
peers
    ServiceKey -> Map ServiceKey Peers -> IO ()
throwWhenPeersUninitialized ServiceKey
skey' Map ServiceKey Peers
peers'
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe HttpStatus -> Bool
forall a. Maybe a -> Bool
isJust Maybe HttpStatus
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
$ HttpStatus -> (Int32, ServiceKey, Map ServiceKey Peers) -> IO ()
reportStats (Maybe HttpStatus -> HttpStatus
forall a. HasCallStack => Maybe a -> a
fromJust Maybe HttpStatus
ssp)
            (Int32
pid, ServiceKey
skey', (Peers -> Bool) -> Map ServiceKey Peers -> Map ServiceKey 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) Map ServiceKey Peers
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
                url :: [Char]
url  = Endpoint -> [Char]
epUrl Endpoint
ep'
                rule :: PassRule
rule = Endpoint -> PassRule
epPassRule Endpoint
ep'
            ((ServiceKey -> ByteString) -> Peers -> [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'') <-
                Peers -> (ServiceKey -> IO ServiceKey) -> IO Peers
forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
forConcurrently Peers
us ((ServiceKey -> IO ServiceKey) -> IO Peers)
-> (ServiceKey -> IO ServiceKey) -> IO Peers
forall a b. (a -> b) -> a -> b
$ \ServiceKey
u -> do
                    let !ps :: Peers
ps = Maybe Peers -> Peers
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Peers -> Peers) -> Maybe Peers -> Peers
forall a b. (a -> b) -> a -> b
$ ServiceKey -> Map ServiceKey Peers -> Maybe Peers
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
u Map ServiceKey Peers
peers'
                    [(ServiceKey, HttpStatus)]
ps' <- Peers
-> (ServiceKey -> IO (ServiceKey, HttpStatus))
-> IO [(ServiceKey, HttpStatus)]
forall (t :: * -> *) a b.
Traversable t =>
t a -> (a -> IO b) -> IO (t b)
forConcurrently Peers
ps ((ServiceKey -> IO (ServiceKey, HttpStatus))
 -> IO [(ServiceKey, HttpStatus)])
-> (ServiceKey -> IO (ServiceKey, HttpStatus))
-> IO [(ServiceKey, HttpStatus)]
forall a b. (a -> b) -> a -> b
$ \ServiceKey
p ->
                        ServiceKey
-> IO (ServiceKey, HttpStatus) -> IO (ServiceKey, HttpStatus)
catchBadResponse ServiceKey
p (IO (ServiceKey, HttpStatus) -> IO (ServiceKey, HttpStatus))
-> IO (ServiceKey, HttpStatus) -> IO (ServiceKey, HttpStatus)
forall a b. (a -> b) -> a -> b
$ ServiceKey -> [Char] -> ServiceKey -> IO (ServiceKey, HttpStatus)
query ServiceKey
skey' [Char]
url ServiceKey
p
                    let (Peers
psGood, Peers
psBad) = ([(ServiceKey, HttpStatus)] -> Peers)
-> ([(ServiceKey, HttpStatus)], [(ServiceKey, HttpStatus)])
-> (Peers, Peers)
forall (a :: * -> * -> *) b c. Arrow a => a b c -> a (b, b) (c, c)
both (((ServiceKey, HttpStatus) -> ServiceKey)
-> [(ServiceKey, HttpStatus)] -> Peers
forall a b. (a -> b) -> [a] -> [b]
map (ServiceKey, HttpStatus) -> ServiceKey
forall a b. (a, b) -> a
fst) (([(ServiceKey, HttpStatus)], [(ServiceKey, HttpStatus)])
 -> (Peers, Peers))
-> ([(ServiceKey, HttpStatus)], [(ServiceKey, HttpStatus)])
-> (Peers, Peers)
forall a b. (a -> b) -> a -> b
$
                            ((ServiceKey, HttpStatus) -> Bool)
-> [(ServiceKey, HttpStatus)]
-> ([(ServiceKey, HttpStatus)], [(ServiceKey, HttpStatus)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (PassRule -> PassRuleParams -> Bool
byPassRule PassRule
rule
                                      (PassRuleParams -> Bool)
-> ((ServiceKey, HttpStatus) -> PassRuleParams)
-> (ServiceKey, HttpStatus)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\HttpStatus
st -> PassRuleParams
defaultPassRuleParams
                                            { responseHttpStatus = st }
                                        )
                                      (HttpStatus -> PassRuleParams)
-> ((ServiceKey, HttpStatus) -> HttpStatus)
-> (ServiceKey, HttpStatus)
-> PassRuleParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServiceKey, HttpStatus) -> HttpStatus
forall a b. (a, b) -> b
snd
                                      ) [(ServiceKey, HttpStatus)]
ps'
                        ic :: Peers -> ServiceKey
ic = ServiceKey -> Peers -> 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
$ Peers -> ServiceKey
T.concat [ServiceKey
u, ServiceKey
"|", Peers -> ServiceKey
ic Peers
psBad, ServiceKey
"/", Peers -> ServiceKey
ic Peers
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) -> Peers -> [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")) Peers
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)
    | (HttpStatus -> ByteString -> (ByteString, ByteString)
B.splitAt HttpStatus
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'
        Map ServiceKey Peers
peers' <- ServiceKey
-> Map ServiceKey (Map ServiceKey Peers) -> Map ServiceKey Peers
lookupServiceKey ServiceKey
skey' (Map ServiceKey (Map ServiceKey Peers) -> Map ServiceKey Peers)
-> IO (Map ServiceKey (Map ServiceKey Peers))
-> IO (Map ServiceKey Peers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map ServiceKey (Map ServiceKey Peers))
-> IO (Map ServiceKey (Map ServiceKey Peers))
forall a. IORef a -> IO a
readIORef IORef (Map ServiceKey (Map ServiceKey Peers))
peers
        if Bool
a
            then ServiceKey -> Map ServiceKey Peers -> IO ()
throwWhenPeersUninitialized ServiceKey
skey' Map ServiceKey Peers
peers'
            else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Peers -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Peers -> Bool) -> Maybe Peers -> Bool
forall a b. (a -> b) -> a -> b
$ ServiceKey -> Map ServiceKey Peers -> Maybe Peers
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
skey' Map ServiceKey Peers
peers') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                IORef (Map ServiceKey (Map ServiceKey Peers))
-> (Map ServiceKey (Map ServiceKey Peers)
    -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map ServiceKey (Map ServiceKey Peers))
peers ((Map ServiceKey (Map ServiceKey Peers)
  -> (Map ServiceKey (Map ServiceKey Peers), ()))
 -> IO ())
-> (Map ServiceKey (Map ServiceKey Peers)
    -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ (, ()) (Map ServiceKey (Map ServiceKey Peers)
 -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> (Map ServiceKey (Map ServiceKey Peers)
    -> Map ServiceKey (Map ServiceKey Peers))
-> Map ServiceKey (Map ServiceKey Peers)
-> (Map ServiceKey (Map ServiceKey Peers), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey
-> Map ServiceKey Peers
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ServiceKey
skey' Map ServiceKey Peers
forall k a. Map k a
M.empty
        MVector RealWorld (Maybe ServiceKey)
usBad <- HttpStatus
-> Maybe ServiceKey
-> IO (MVector (PrimState IO) (Maybe ServiceKey))
forall (m :: * -> *) a.
PrimMonad m =>
HttpStatus -> a -> m (MVector (PrimState m) a)
MV.replicate ([ByteString] -> HttpStatus
forall a. [a] -> HttpStatus
forall (t :: * -> *) a. Foldable t => t a -> HttpStatus
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 -> HttpStatus
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> HttpStatus
l) <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pl
                                ((ServiceKey -> Bool) -> Peers -> Peers
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) (Peers -> Peers) -> (ByteString -> Peers) -> ByteString -> Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ServiceKey -> Peers
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',')
                                    (ServiceKey -> Peers)
-> (ByteString -> ServiceKey) -> ByteString -> Peers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ServiceKey
T.decodeUtf8 -> Peers
ps'') <-
                                    CStringLen -> IO ByteString
B.unsafePackCStringLen (CString
v, HttpStatus
l)
                                let peers'' :: Peers
peers'' = Peers -> Maybe Peers -> Peers
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe Peers -> Peers) -> Maybe Peers -> Peers
forall a b. (a -> b) -> a -> b
$ ServiceKey -> Map ServiceKey Peers -> Maybe Peers
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ServiceKey
u Map ServiceKey Peers
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 (Map ServiceKey (Map ServiceKey Peers))
-> (Map ServiceKey (Map ServiceKey Peers)
    -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map ServiceKey (Map ServiceKey Peers))
peers ((Map ServiceKey (Map ServiceKey Peers)
  -> (Map ServiceKey (Map ServiceKey Peers), ()))
 -> IO ())
-> (Map ServiceKey (Map ServiceKey Peers)
    -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
                                        (, ()) (Map ServiceKey (Map ServiceKey Peers)
 -> (Map ServiceKey (Map ServiceKey Peers), ()))
-> (Map ServiceKey (Map ServiceKey Peers)
    -> Map ServiceKey (Map ServiceKey Peers))
-> Map ServiceKey (Map ServiceKey Peers)
-> (Map ServiceKey (Map ServiceKey Peers), ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ServiceKey Peers -> Maybe (Map ServiceKey Peers))
-> ServiceKey
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
M.update
                                            (Map ServiceKey Peers -> Maybe (Map ServiceKey Peers)
forall a. a -> Maybe a
Just (Map ServiceKey Peers -> Maybe (Map ServiceKey Peers))
-> (Map ServiceKey Peers -> Map ServiceKey Peers)
-> Map ServiceKey Peers
-> Maybe (Map ServiceKey Peers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServiceKey -> Peers -> Map ServiceKey Peers -> Map ServiceKey Peers
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert ServiceKey
u 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 :: HttpStatus
idx = Maybe HttpStatus -> HttpStatus
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe HttpStatus -> HttpStatus) -> Maybe HttpStatus -> HttpStatus
forall a b. (a -> b) -> a -> b
$
                                        (Maybe ServiceKey -> Bool)
-> Vector (Maybe ServiceKey) -> Maybe HttpStatus
forall a. (a -> Bool) -> Vector a -> Maybe HttpStatus
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)
-> HttpStatus -> Maybe ServiceKey -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> HttpStatus -> a -> m ()
MV.unsafeWrite MVector RealWorld (Maybe ServiceKey)
MVector (PrimState IO) (Maybe ServiceKey)
usBad'' HttpStatus
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 -> Peers -> ServiceKey
T.intercalate ServiceKey
", " (Peers -> ServiceKey) -> Peers -> ServiceKey
forall a b. (a -> b) -> a -> b
$
                (Maybe ServiceKey -> ServiceKey) -> [Maybe ServiceKey] -> Peers
forall a b. (a -> b) -> [a] -> [b]
map Maybe ServiceKey -> ServiceKey
forall a. HasCallStack => Maybe a -> a
fromJust ([Maybe ServiceKey] -> Peers) -> [Maybe ServiceKey] -> Peers
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, Map ServiceKey Peers)
s = ByteString -> Maybe (Int32, ServiceKey, Map ServiceKey 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, Map ServiceKey Peers) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Int32, ServiceKey, Map ServiceKey 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, Map ServiceKey Peers
ps) = Maybe (Int32, ServiceKey, Map ServiceKey Peers)
-> (Int32, ServiceKey, Map ServiceKey Peers)
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Int32, ServiceKey, Map ServiceKey Peers)
s
    !UTCTime
t <- IO UTCTime
getCurrentTime
    IORef
  (UTCTime,
   Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> ((UTCTime,
     Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
    -> ((UTCTime,
         Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))),
        ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef
  (UTCTime,
   Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
stats (((UTCTime,
   Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
  -> ((UTCTime,
       Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))),
      ()))
 -> IO ())
-> ((UTCTime,
     Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
    -> ((UTCTime,
         Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))),
        ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$
        (, ()) ((UTCTime,
  Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
 -> ((UTCTime,
      Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))),
     ()))
-> ((UTCTime,
     Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
    -> (UTCTime,
        Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))))
-> (UTCTime,
    Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> ((UTCTime,
     Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))),
    ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \(UTCTime
t', Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey 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, Map ServiceKey (Map ServiceKey Peers))
psn = Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall {k} {b}. Map k (UTCTime, b) -> Map k (UTCTime, b)
f (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall a b. (a -> b) -> a -> b
$ (Maybe (UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> Maybe (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> Int32
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter
                           (\Maybe (UTCTime, Map ServiceKey (Map ServiceKey Peers))
old ->
                               let !new' :: Map ServiceKey (Map ServiceKey Peers)
new' = if Maybe (UTCTime, Map ServiceKey (Map ServiceKey Peers)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (UTCTime, Map ServiceKey (Map ServiceKey Peers))
old
                                               then ServiceKey
-> Map ServiceKey Peers -> Map ServiceKey (Map ServiceKey Peers)
forall k a. k -> a -> Map k a
ML.singleton ServiceKey
skey Map ServiceKey Peers
ps
                                               else ServiceKey
-> Map ServiceKey Peers
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall k a. Ord k => k -> a -> Map k a -> Map k a
ML.insert ServiceKey
skey Map ServiceKey Peers
ps (Map ServiceKey (Map ServiceKey Peers)
 -> Map ServiceKey (Map ServiceKey Peers))
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall a b. (a -> b) -> a -> b
$
                                                   (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Map ServiceKey (Map ServiceKey Peers)
forall a b. (a, b) -> b
snd ((UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Map ServiceKey (Map ServiceKey Peers)
forall a b. (a -> b) -> a -> b
$ Maybe (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (UTCTime, Map ServiceKey (Map ServiceKey Peers))
old
                               in (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Maybe (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall a. a -> Maybe a
Just (UTCTime
t, Map ServiceKey (Map ServiceKey Peers)
new')
                           ) Int32
pid Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
ps'
            in (UTCTime
tn, Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey 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 (HttpStatus -> TimeInterval
Min HttpStatus
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 Peers))
sendStats' :: IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
sendStats' = (UTCTime,
 Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall a b. (a, b) -> b
snd ((UTCTime,
  Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
 -> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> IO
     (UTCTime,
      Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef
  (UTCTime,
   Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> IO
     (UTCTime,
      Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
forall a. IORef a -> IO a
readIORef IORef
  (UTCTime,
   Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey 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", HttpStatus
200, []) (ByteString -> ContentHandlerResult)
-> (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
    -> ByteString)
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> ContentHandlerResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> ByteString
forall a. ToJSON a => a -> ByteString
encode
    (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> ByteString)
-> (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
    -> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Map ServiceKey (Map ServiceKey Peers)
 -> Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
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 Peers)
  -> Map ServiceKey (Map ServiceKey Peers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> (Map ServiceKey (Map ServiceKey Peers)
    -> Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall a b. (a -> b) -> a -> b
$ (Map ServiceKey Peers -> Bool)
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall a k. (a -> Bool) -> Map k a -> Map k a
ML.filter ((Map ServiceKey Peers -> Bool)
 -> Map ServiceKey (Map ServiceKey Peers)
 -> Map ServiceKey (Map ServiceKey Peers))
-> (Map ServiceKey Peers -> Bool)
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool)
-> (Map ServiceKey Peers -> Bool) -> Map ServiceKey Peers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ServiceKey Peers -> Bool
forall a. Map ServiceKey a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
    (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> ContentHandlerResult)
-> IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> IO ContentHandlerResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
sendStats'
ngxExportAsyncHandler 'sendStats

sendMergedStats' :: IO (MServiceKey AnnotatedPeers)
sendMergedStats' :: IO (MServiceKey AnnotatedPeers)
sendMergedStats' = Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> MServiceKey AnnotatedPeers
forall {k}.
Map k (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> MServiceKey AnnotatedPeers
merge (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> MServiceKey AnnotatedPeers)
-> IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> IO (MServiceKey AnnotatedPeers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
sendStats'
    where merge :: Map k (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> MServiceKey AnnotatedPeers
merge = (MServiceKey AnnotatedPeers
 -> MServiceKey AnnotatedPeers -> MServiceKey AnnotatedPeers)
-> MServiceKey AnnotatedPeers
-> Map k (MServiceKey AnnotatedPeers)
-> MServiceKey AnnotatedPeers
forall a b k. (a -> b -> a) -> a -> Map k b -> a
M.foldl ((Map ServiceKey AnnotatedPeers
 -> Map ServiceKey AnnotatedPeers -> Map ServiceKey AnnotatedPeers)
-> MServiceKey AnnotatedPeers
-> MServiceKey AnnotatedPeers
-> MServiceKey AnnotatedPeers
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
ML.unionWith ((Map ServiceKey AnnotatedPeers
  -> Map ServiceKey AnnotatedPeers -> Map ServiceKey AnnotatedPeers)
 -> MServiceKey AnnotatedPeers
 -> MServiceKey AnnotatedPeers
 -> MServiceKey AnnotatedPeers)
-> (Map ServiceKey AnnotatedPeers
    -> Map ServiceKey AnnotatedPeers -> Map ServiceKey AnnotatedPeers)
-> MServiceKey AnnotatedPeers
-> MServiceKey AnnotatedPeers
-> MServiceKey AnnotatedPeers
forall a b. (a -> b) -> a -> b
$ (AnnotatedPeers -> AnnotatedPeers -> AnnotatedPeers)
-> Map ServiceKey AnnotatedPeers
-> Map ServiceKey AnnotatedPeers
-> Map ServiceKey AnnotatedPeers
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith AnnotatedPeers -> AnnotatedPeers -> AnnotatedPeers
pickLatest) MServiceKey AnnotatedPeers
forall k a. Map k a
ML.empty
                  (Map k (MServiceKey AnnotatedPeers) -> MServiceKey AnnotatedPeers)
-> (Map k (UTCTime, Map ServiceKey (Map ServiceKey Peers))
    -> Map k (MServiceKey AnnotatedPeers))
-> Map k (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> MServiceKey AnnotatedPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> MServiceKey AnnotatedPeers)
-> Map k (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Map k (MServiceKey AnnotatedPeers)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (\(UTCTime
t, Map ServiceKey (Map ServiceKey Peers)
s) -> (Map ServiceKey Peers -> Map ServiceKey AnnotatedPeers)
-> Map ServiceKey (Map ServiceKey Peers)
-> MServiceKey AnnotatedPeers
forall a b k. (a -> b) -> Map k a -> Map k b
ML.map ((Peers -> AnnotatedPeers)
-> Map ServiceKey Peers -> Map ServiceKey AnnotatedPeers
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Peers -> AnnotatedPeers)
 -> Map ServiceKey Peers -> Map ServiceKey AnnotatedPeers)
-> (Peers -> AnnotatedPeers)
-> Map ServiceKey Peers
-> Map ServiceKey AnnotatedPeers
forall a b. (a -> b) -> a -> b
$ (ServiceKey -> (UTCTime, ServiceKey)) -> Peers -> AnnotatedPeers
forall a b. (a -> b) -> [a] -> [b]
map (UTCTime
t,)) Map ServiceKey (Map ServiceKey Peers)
s)
          pickLatest :: AnnotatedPeers -> AnnotatedPeers -> AnnotatedPeers
pickLatest = (((AnnotatedPeers -> (UTCTime, ServiceKey))
-> [AnnotatedPeers] -> AnnotatedPeers
forall a b. (a -> b) -> [a] -> [b]
map (((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Ordering)
-> AnnotatedPeers -> (UTCTime, ServiceKey)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Ordering)
 -> AnnotatedPeers -> (UTCTime, ServiceKey))
-> ((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Ordering)
-> AnnotatedPeers
-> (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)
                        ([AnnotatedPeers] -> AnnotatedPeers)
-> (AnnotatedPeers -> [AnnotatedPeers])
-> AnnotatedPeers
-> AnnotatedPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, ServiceKey) -> (UTCTime, ServiceKey) -> Bool)
-> AnnotatedPeers -> [AnnotatedPeers]
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)
                        ) (AnnotatedPeers -> AnnotatedPeers)
-> (AnnotatedPeers -> AnnotatedPeers)
-> AnnotatedPeers
-> AnnotatedPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       ) ((AnnotatedPeers -> AnnotatedPeers)
 -> AnnotatedPeers -> AnnotatedPeers)
-> (AnnotatedPeers -> AnnotatedPeers -> AnnotatedPeers)
-> AnnotatedPeers
-> AnnotatedPeers
-> AnnotatedPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTCTime, ServiceKey) -> AnnotatedPeers -> AnnotatedPeers)
-> AnnotatedPeers -> AnnotatedPeers -> AnnotatedPeers
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) -> AnnotatedPeers -> AnnotatedPeers
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", HttpStatus
200, []) (ByteString -> ContentHandlerResult)
-> (MServiceKey AnnotatedPeers -> ByteString)
-> MServiceKey AnnotatedPeers
-> ContentHandlerResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MServiceKey AnnotatedPeers -> ByteString
forall a. ToJSON a => a -> ByteString
encode
    (MServiceKey AnnotatedPeers -> ContentHandlerResult)
-> IO (MServiceKey AnnotatedPeers) -> IO ContentHandlerResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MServiceKey AnnotatedPeers)
sendMergedStats'
ngxExportAsyncHandler 'sendMergedStats


#ifdef SNAP_STATS_SERVER

ssConfig :: Int -> Config Snap a
ssConfig :: forall a. HttpStatus -> Config Snap a
ssConfig HttpStatus
p = HttpStatus -> Config Snap a -> Config Snap a
forall (m :: * -> *) a. HttpStatus -> Config m a -> Config m a
setPort HttpStatus
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 Peers))
s <- IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> Snap
     (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
forall a. IO a -> Snap a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
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 Peers))
-> ByteString
forall a. ToJSON a => a -> ByteString
encode (Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> ByteString)
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> ByteString
forall a b. (a -> b) -> a -> b
$ ((UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Map ServiceKey (Map ServiceKey Peers)
 -> Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
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 Peers)
  -> Map ServiceKey (Map ServiceKey Peers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
 -> (UTCTime, Map ServiceKey (Map ServiceKey Peers)))
-> (Map ServiceKey (Map ServiceKey Peers)
    -> Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
-> (UTCTime, Map ServiceKey (Map ServiceKey Peers))
forall a b. (a -> b) -> a -> b
$ (Map ServiceKey Peers -> Bool)
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall a k. (a -> Bool) -> Map k a -> Map k a
ML.filter ((Map ServiceKey Peers -> Bool)
 -> Map ServiceKey (Map ServiceKey Peers)
 -> Map ServiceKey (Map ServiceKey Peers))
-> (Map ServiceKey Peers -> Bool)
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool)
-> (Map ServiceKey Peers -> Bool) -> Map ServiceKey Peers -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map ServiceKey Peers -> Bool
forall a. Map ServiceKey a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) Map Int32 (UTCTime, Map ServiceKey (Map ServiceKey Peers))
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 AnnotatedPeers
s <- IO (MServiceKey AnnotatedPeers)
-> Snap (MServiceKey AnnotatedPeers)
forall a. IO a -> Snap a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MServiceKey AnnotatedPeers)
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 AnnotatedPeers -> ByteString
forall a. ToJSON a => a -> ByteString
encode MServiceKey AnnotatedPeers
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 ->
    HttpStatus -> [Char] -> Snap ()
forall {m :: * -> *}. MonadSnap m => HttpStatus -> [Char] -> m ()
writeErrorResponse HttpStatus
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 :: HttpStatus -> [Char] -> m ()
writeErrorResponse HttpStatus
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
$ HttpStatus -> ByteString -> Response -> Response
setResponseStatus HttpStatus
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 (TerminateWorkerProcess -> IO StatsServerConf
forall e a. Exception e => e -> IO a
throwIO (TerminateWorkerProcess -> IO StatsServerConf)
-> TerminateWorkerProcess -> IO StatsServerConf
forall a b. (a -> b) -> a -> b
$
                             [Char] -> TerminateWorkerProcess
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 (HttpStatus -> Config Snap Any
forall a. HttpStatus -> Config Snap a
ssConfig (HttpStatus -> Config Snap Any) -> HttpStatus -> Config Snap Any
forall a b. (a -> b) -> a -> b
$ StatsServerConf -> HttpStatus
ssPort StatsServerConf
cf') (Snap () -> IO ()) -> Snap () -> IO ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Snap ()
ssHandler NominalDiffTime
int
        else HttpStatus -> IO ()
threadDelaySec HttpStatus
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
    ((Map ServiceKey Peers -> Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Map ServiceKey Peers -> Map ServiceKey Peers)
 -> Map ServiceKey (Map ServiceKey Peers)
 -> Map ServiceKey (Map ServiceKey Peers))
-> (Map ServiceKey Peers -> Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
-> Map ServiceKey (Map ServiceKey Peers)
forall a b. (a -> b) -> a -> b
$ (Peers -> Bool) -> Map ServiceKey Peers -> Map ServiceKey Peers
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Peers -> Bool) -> Map ServiceKey Peers -> Map ServiceKey Peers)
-> (Peers -> Bool) -> Map ServiceKey Peers -> Map ServiceKey Peers
forall a b. (a -> b) -> a -> b
$ 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 -> Map ServiceKey (Map ServiceKey Peers)
peers') <- IORef (Map ServiceKey (Map ServiceKey Peers))
-> IO (Map ServiceKey (Map ServiceKey Peers))
forall a. IORef a -> IO a
readIORef IORef (Map ServiceKey (Map ServiceKey Peers))
peers
    ContentHandlerResult -> IO ContentHandlerResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map ServiceKey (Map ServiceKey Peers) -> ByteString
forall a. ToJSON a => a -> ByteString
encode Map ServiceKey (Map ServiceKey Peers)
peers', ByteString
"application/json", HttpStatus
200, [])
ngxExportAsyncHandler 'reportPeers