{-# LANGUAGE CPP, TemplateHaskell, ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings, BangPatterns, ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables, TupleSections, NumDecimals #-}
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
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