{-# LANGUAGE OverloadedStrings #-}
module Instana.SDK.Internal.AgentConnection.AgentReady
( waitUntilAgentIsReadyToAcceptData
) where
import qualified Control.Concurrent.STM as STM
import Control.Exception (SomeException,
catch)
import Data.ByteString.Lazy (ByteString)
import qualified Network.HTTP.Client as HTTP
import System.Log.Logger (debugM,
infoM,
warningM)
import Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse (AnnounceResponse)
import qualified Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse as AnnounceResponse
import Instana.SDK.Internal.AgentConnection.Json.Util (emptyResponseDecoder)
import Instana.SDK.Internal.AgentConnection.Paths (haskellEntityDataPathPrefix)
import Instana.SDK.Internal.AgentConnection.ProcessInfo (ProcessInfo)
import Instana.SDK.Internal.Context (ConnectionState (..),
InternalContext)
import qualified Instana.SDK.Internal.Context as InternalContext
import Instana.SDK.Internal.Logging (instanaLogger)
import qualified Instana.SDK.Internal.Metrics.Collector as MetricsCollector
import qualified Instana.SDK.Internal.Retry as Retry
import qualified Instana.SDK.Internal.URL as URL
waitUntilAgentIsReadyToAcceptData ::
InternalContext
-> String
-> ProcessInfo
-> AnnounceResponse
-> IO ()
waitUntilAgentIsReadyToAcceptData :: InternalContext
-> String -> ProcessInfo -> AnnounceResponse -> IO ()
waitUntilAgentIsReadyToAcceptData
context :: InternalContext
context
originalPidStr :: String
originalPidStr
processInfo :: ProcessInfo
processInfo
announceResponse :: AnnounceResponse
announceResponse = do
String -> String -> IO ()
debugM String
instanaLogger "Waiting until the agent is ready to accept data."
ConnectionState
connectionState <-
STM ConnectionState -> IO ConnectionState
forall a. STM a -> IO a
STM.atomically (STM ConnectionState -> IO ConnectionState)
-> STM ConnectionState -> IO ConnectionState
forall a b. (a -> b) -> a -> b
$ TVar ConnectionState -> STM ConnectionState
forall a. TVar a -> STM a
STM.readTVar (TVar ConnectionState -> STM ConnectionState)
-> TVar ConnectionState -> STM ConnectionState
forall a b. (a -> b) -> a -> b
$ InternalContext -> TVar ConnectionState
InternalContext.connectionState InternalContext
context
case ConnectionState
connectionState of
Announced hostAndPort :: (String, Int)
hostAndPort ->
InternalContext
-> (String, Int)
-> String
-> ProcessInfo
-> AnnounceResponse
-> IO ()
waitForAgent
InternalContext
context
(String, Int)
hostAndPort
String
originalPidStr
ProcessInfo
processInfo
AnnounceResponse
announceResponse
_ -> do
String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Reached illegal state in agent ready, announce did not " String -> String -> String
forall a. [a] -> [a] -> [a]
++
"yield a host and port. Connection state is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConnectionState -> String
forall a. Show a => a -> String
show ConnectionState
connectionState String -> String -> String
forall a. [a] -> [a] -> [a]
++
". Will retry later."
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ConnectionState -> ConnectionState -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar
(InternalContext -> TVar ConnectionState
InternalContext.connectionState InternalContext
context)
ConnectionState
Unconnected
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
waitForAgent ::
InternalContext
-> (String, Int)
-> String
-> ProcessInfo
-> AnnounceResponse
-> IO ()
waitForAgent :: InternalContext
-> (String, Int)
-> String
-> ProcessInfo
-> AnnounceResponse
-> IO ()
waitForAgent
context :: InternalContext
context
(host :: String
host, port :: Int
port)
originalPidStr :: String
originalPidStr
processInfo :: ProcessInfo
processInfo
announceResponse :: AnnounceResponse
announceResponse = do
let
translatedPidStr :: String
translatedPidStr = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ AnnounceResponse -> Int
AnnounceResponse.pid AnnounceResponse
announceResponse
pidTranslationStr :: String
pidTranslationStr =
if String
translatedPidStr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
originalPidStr
then String
translatedPidStr
else "(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
originalPidStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ " => " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
translatedPidStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
acceptDataUrl :: URL
acceptDataUrl =
String -> Int -> String -> URL
URL.mkHttp String
host Int
port (String
haskellEntityDataPathPrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
translatedPidStr)
Request
agentReadyRequestBase <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ URL -> String
forall a. Show a => a -> String
show URL
acceptDataUrl
let
acceptDataRequest :: Request
acceptDataRequest = Request
agentReadyRequestBase
{ method :: Method
HTTP.method = "HEAD"
, requestHeaders :: RequestHeaders
HTTP.requestHeaders =
[ ("Accept", "application/json")
, ("Content-Type", "application/json; charset=UTF-8'")
]
}
manager :: Manager
manager = InternalContext -> Manager
InternalContext.httpManager InternalContext
context
acceptDataRequestAction :: IO (HTTP.Response ByteString)
acceptDataRequestAction :: IO (Response ByteString)
acceptDataRequestAction = Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
acceptDataRequest Manager
manager
Bool
success <-
IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(RetryPolicyM IO
-> (Response ByteString -> IO Bool)
-> IO (Response ByteString)
-> IO Bool
forall a.
RetryPolicyM IO
-> (Response ByteString -> IO a)
-> IO (Response ByteString)
-> IO a
Retry.retryRequest
RetryPolicyM IO
Retry.acceptDataRetryPolicy
Response ByteString -> IO Bool
emptyResponseDecoder
IO (Response ByteString)
acceptDataRequestAction
)
(\e :: SomeException
e -> do
String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
)
if Bool
success
then do
Store
metricsStore <-
String -> ProcessInfo -> Int -> IO Store
MetricsCollector.registerMetrics
String
translatedPidStr
ProcessInfo
processInfo
(InternalContext -> Int
InternalContext.sdkStartTime InternalContext
context)
let
state :: ConnectionState
state =
(String, Int) -> AnnounceResponse -> Store -> ConnectionState
InternalContext.mkAgentReadyState
(String
host, Int
port)
AnnounceResponse
announceResponse
Store
metricsStore
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
TVar ConnectionState -> ConnectionState -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar (InternalContext -> TVar ConnectionState
InternalContext.connectionState InternalContext
context) ConnectionState
state
String -> String -> IO ()
infoM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Agent connection established for process " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pidTranslationStr
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Could not establish agent connection for process " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
pidTranslationStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (waiting for agent ready state failed), will " String -> String -> String
forall a. [a] -> [a] -> [a]
++
"retry later."
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ConnectionState -> ConnectionState -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar
(InternalContext -> TVar ConnectionState
InternalContext.connectionState InternalContext
context)
ConnectionState
Unconnected