{-# LANGUAGE OverloadedStrings #-}
module Instana.SDK.Internal.AgentConnection.Announce
( announce
) where
import qualified Control.Concurrent.STM as STM
import Control.Exception (SomeException,
catch)
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Maybe (isJust)
import qualified Network.HTTP.Client as HTTP
import System.Log.Logger (debugM,
warningM)
import qualified System.Posix.Files as PosixFiles
import Instana.SDK.Internal.AgentConnection.AgentReady as AgentReady
import Instana.SDK.Internal.AgentConnection.Json.AnnounceResponse (AnnounceResponse)
import Instana.SDK.Internal.AgentConnection.Paths
import Instana.SDK.Internal.AgentConnection.ProcessInfo (ProcessInfo)
import qualified Instana.SDK.Internal.AgentConnection.ProcessInfo as 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.Retry as Retry
import qualified Instana.SDK.Internal.URL as URL
announce ::
InternalContext
-> ProcessInfo
-> IO ()
announce context processInfo = do
debugM instanaLogger "Starting to announce process to agent."
connectionState <-
STM.atomically $ STM.readTVar $ InternalContext.connectionState context
case connectionState of
Unannounced hostAndPort ->
announceToAgent context hostAndPort processInfo
_ -> do
warningM instanaLogger $
"Reached illegal state in announce, agent host lookup did not " ++
"yield a host and port. Connection state is " ++ show connectionState ++
". Will retry later."
STM.atomically $ STM.writeTVar
(InternalContext.connectionState context)
Unconnected
return ()
announceToAgent ::
InternalContext
-> (String, Int)
-> ProcessInfo
-> IO ()
announceToAgent context (host, port) processInfo = do
fileDescriptor <-
STM.atomically $ STM.readTVar $ InternalContext.fileDescriptor context
let
manager = InternalContext.httpManager context
discoveryUrl =
URL.mkHttp host port haskellDiscoveryPath
nonContainerPid = ProcessInfo.pidString processInfo
(pidStr, pidFromParentNS) =
case ProcessInfo.parentNsPid processInfo of
Just parentPid ->
(parentPid, parentPid == nonContainerPid)
Nothing ->
(nonContainerPid, False)
maybeFileDescriptorString = show <$> fileDescriptor
maybeInodeLinkPath =
(\fdStr -> "/proc/" ++ nonContainerPid ++ "/fd/" ++ fdStr) <$>
maybeFileDescriptorString
discoveryRequestBase <- HTTP.parseUrlThrow $ show discoveryUrl
inode <-
case maybeInodeLinkPath of
Just inodeLinkPath ->
catch
(do
i <- PosixFiles.readSymbolicLink inodeLinkPath
return $ Just i
)
(\e -> do
debugM instanaLogger $
"Could not obtain inode for process matching from " ++
inodeLinkPath ++ ": " ++ show (e :: SomeException)
return Nothing
)
Nothing ->
return Nothing
let
haskellProcess =
Aeson.object
[ "pid" .= pidStr
, "pidFromParentNS" .= pidFromParentNS
, "progName" .= ProcessInfo.programName processInfo
, "execPath" .= ProcessInfo.executablePath processInfo
, "args" .= ProcessInfo.arguments processInfo
, "fd" .= maybeFileDescriptorString
, "inode" .= inode
]
announceRequest = discoveryRequestBase
{ HTTP.method = "PUT"
, HTTP.requestBody = HTTP.RequestBodyLBS $ Aeson.encode haskellProcess
, HTTP.requestHeaders =
[ ("Accept", "application/json")
, ("Content-Type", "application/json; charset=UTF-8'")
]
}
announceRequestAction = HTTP.httpLbs announceRequest manager
maybeAnnounceResponse <-
catch
(Retry.retryRequest
Retry.announceRetryPolicy
decodeAnnounceResponse
announceRequestAction
)
(\e -> do
warningM instanaLogger $ show (e :: SomeException)
return Nothing
)
if isJust maybeAnnounceResponse
then do
let
Just announceResponse = maybeAnnounceResponse
STM.atomically $
STM.writeTVar (InternalContext.connectionState context) $
Announced (host, port)
debugM instanaLogger $
"Haskell process " ++ pidStr ++
" has been successfully announced to agent at " ++ show (host, port) ++
", now waiting for the agent to be ready to accept data."
AgentReady.waitUntilAgentIsReadyToAcceptData
context
pidStr
processInfo
announceResponse
else do
warningM instanaLogger $
"Could not establish agent connection for process " ++ pidStr ++
" (announce failed), will retry later."
STM.atomically $ STM.writeTVar
(InternalContext.connectionState context)
Unconnected
decodeAnnounceResponse ::
HTTP.Response ByteString
-> IO (Maybe AnnounceResponse)
decodeAnnounceResponse response = do
let
body = HTTP.responseBody response
maybeParsed :: Maybe AnnounceResponse
maybeParsed = Aeson.decode body
case maybeParsed of
Just _ -> do
return maybeParsed
Nothing ->
fail $ "Can't parse announce response" ++ (show body)