{-# 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
context
originalPidStr
processInfo
announceResponse = do
debugM instanaLogger "Waiting until the agent is ready to accept data."
connectionState <-
STM.atomically $ STM.readTVar $ InternalContext.connectionState context
case connectionState of
Announced hostAndPort ->
waitForAgent
context
hostAndPort
originalPidStr
processInfo
announceResponse
_ -> do
warningM instanaLogger $
"Reached illegal state in agent ready, announce did not " ++
"yield a host and port. Connection state is " ++ show connectionState ++
". Will retry later."
STM.atomically $ STM.writeTVar
(InternalContext.connectionState context)
Unconnected
return ()
waitForAgent ::
InternalContext
-> (String, Int)
-> String
-> ProcessInfo
-> AnnounceResponse
-> IO ()
waitForAgent
context
(host, port)
originalPidStr
processInfo
announceResponse = do
let
translatedPidStr = show $ AnnounceResponse.pid announceResponse
pidTranslationStr =
if translatedPidStr == originalPidStr
then translatedPidStr
else "(" ++ originalPidStr ++ " => " ++ translatedPidStr ++ ")"
acceptDataUrl =
URL.mkHttp host port (haskellEntityDataPathPrefix ++ translatedPidStr)
agentReadyRequestBase <- HTTP.parseUrlThrow $ show acceptDataUrl
let
acceptDataRequest = agentReadyRequestBase
{ HTTP.method = "HEAD"
, HTTP.requestHeaders =
[ ("Accept", "application/json")
, ("Content-Type", "application/json; charset=UTF-8'")
]
}
manager = InternalContext.httpManager context
acceptDataRequestAction :: IO (HTTP.Response ByteString)
acceptDataRequestAction = HTTP.httpLbs acceptDataRequest manager
success <-
catch
(Retry.retryRequest
Retry.acceptDataRetryPolicy
emptyResponseDecoder
acceptDataRequestAction
)
(\e -> do
warningM instanaLogger $ show (e :: SomeException)
return False
)
if success
then do
metricsStore <-
MetricsCollector.registerMetrics
translatedPidStr
processInfo
(InternalContext.sdkStartTime context)
let
state =
InternalContext.mkAgentReadyState
(host, port)
announceResponse
metricsStore
STM.atomically $
STM.writeTVar (InternalContext.connectionState context) state
infoM instanaLogger $
"🎉 agent connection established for process " ++ pidTranslationStr ++
" 🎉"
return ()
else do
warningM instanaLogger $
"Could not establish agent connection for process " ++
pidTranslationStr ++ " (waiting for agent ready state failed), will " ++
"retry later."
STM.atomically $ STM.writeTVar
(InternalContext.connectionState context)
Unconnected