{-# 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 :: InternalContext -> ProcessInfo -> IO ()
announce context :: InternalContext
context processInfo :: ProcessInfo
processInfo = do
String -> String -> IO ()
debugM String
instanaLogger "Starting to announce process to agent."
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
Unannounced hostAndPort :: (String, Int)
hostAndPort ->
InternalContext -> (String, Int) -> ProcessInfo -> IO ()
announceToAgent InternalContext
context (String, Int)
hostAndPort ProcessInfo
processInfo
_ -> do
String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Reached illegal state in announce, agent host lookup 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 ()
announceToAgent ::
InternalContext
-> (String, Int)
-> ProcessInfo
-> IO ()
announceToAgent :: InternalContext -> (String, Int) -> ProcessInfo -> IO ()
announceToAgent context :: InternalContext
context (host :: String
host, port :: Int
port) processInfo :: ProcessInfo
processInfo = do
Maybe CInt
fileDescriptor <-
STM (Maybe CInt) -> IO (Maybe CInt)
forall a. STM a -> IO a
STM.atomically (STM (Maybe CInt) -> IO (Maybe CInt))
-> STM (Maybe CInt) -> IO (Maybe CInt)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe CInt) -> STM (Maybe CInt)
forall a. TVar a -> STM a
STM.readTVar (TVar (Maybe CInt) -> STM (Maybe CInt))
-> TVar (Maybe CInt) -> STM (Maybe CInt)
forall a b. (a -> b) -> a -> b
$ InternalContext -> TVar (Maybe CInt)
InternalContext.fileDescriptor InternalContext
context
let
manager :: Manager
manager = InternalContext -> Manager
InternalContext.httpManager InternalContext
context
discoveryUrl :: URL
discoveryUrl =
String -> Int -> String -> URL
URL.mkHttp String
host Int
port String
haskellDiscoveryPath
nonContainerPid :: String
nonContainerPid = ProcessInfo -> String
ProcessInfo.pidString ProcessInfo
processInfo
(pidStr :: String
pidStr, pidFromParentNS :: Bool
pidFromParentNS) =
case ProcessInfo -> Maybe String
ProcessInfo.parentNsPid ProcessInfo
processInfo of
Just parentPid :: String
parentPid ->
(String
parentPid, String
parentPid String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
nonContainerPid)
Nothing ->
(String
nonContainerPid, Bool
False)
maybeFileDescriptorString :: Maybe String
maybeFileDescriptorString = CInt -> String
forall a. Show a => a -> String
show (CInt -> String) -> Maybe CInt -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CInt
fileDescriptor
maybeInodeLinkPath :: Maybe String
maybeInodeLinkPath =
(\fdStr :: String
fdStr -> "/proc/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nonContainerPid String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/fd/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fdStr) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Maybe String
maybeFileDescriptorString
Request
discoveryRequestBase <- 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
discoveryUrl
Maybe String
inode <-
case Maybe String
maybeInodeLinkPath of
Just inodeLinkPath :: String
inodeLinkPath ->
IO (Maybe String)
-> (SomeException -> IO (Maybe String)) -> IO (Maybe String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(do
String
i <- String -> IO String
PosixFiles.readSymbolicLink String
inodeLinkPath
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
i
)
(\e :: SomeException
e -> do
String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Could not obtain inode for process matching from " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
inodeLinkPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
)
Nothing ->
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
let
haskellProcess :: Value
haskellProcess =
[Pair] -> Value
Aeson.object
[ "pid" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
pidStr
, "pidFromParentNS" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
pidFromParentNS
, "progName" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ProcessInfo -> String
ProcessInfo.programName ProcessInfo
processInfo
, "execPath" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ProcessInfo -> String
ProcessInfo.executablePath ProcessInfo
processInfo
, "args" Text -> [String] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ProcessInfo -> [String]
ProcessInfo.arguments ProcessInfo
processInfo
, "fd" Text -> Maybe String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe String
maybeFileDescriptorString
, "inode" Text -> Maybe String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe String
inode
]
announceRequest :: Request
announceRequest = Request
discoveryRequestBase
{ method :: Method
HTTP.method = "PUT"
, requestBody :: RequestBody
HTTP.requestBody = ByteString -> RequestBody
HTTP.RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
haskellProcess
, requestHeaders :: RequestHeaders
HTTP.requestHeaders =
[ ("Accept", "application/json")
, ("Content-Type", "application/json; charset=UTF-8'")
]
}
announceRequestAction :: IO (Response ByteString)
announceRequestAction = Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
announceRequest Manager
manager
Maybe AnnounceResponse
maybeAnnounceResponse <-
IO (Maybe AnnounceResponse)
-> (SomeException -> IO (Maybe AnnounceResponse))
-> IO (Maybe AnnounceResponse)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(RetryPolicyM IO
-> (Response ByteString -> IO (Maybe AnnounceResponse))
-> IO (Response ByteString)
-> IO (Maybe AnnounceResponse)
forall a.
RetryPolicyM IO
-> (Response ByteString -> IO a)
-> IO (Response ByteString)
-> IO a
Retry.retryRequest
RetryPolicyM IO
Retry.announceRetryPolicy
Response ByteString -> IO (Maybe AnnounceResponse)
decodeAnnounceResponse
IO (Response ByteString)
announceRequestAction
)
(\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)
Maybe AnnounceResponse -> IO (Maybe AnnounceResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AnnounceResponse
forall a. Maybe a
Nothing
)
if Maybe AnnounceResponse -> Bool
forall a. Maybe a -> Bool
isJust Maybe AnnounceResponse
maybeAnnounceResponse
then do
let
Just announceResponse :: AnnounceResponse
announceResponse = Maybe AnnounceResponse
maybeAnnounceResponse
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 -> STM ()) -> ConnectionState -> STM ()
forall a b. (a -> b) -> a -> b
$
(String, Int) -> ConnectionState
Announced (String
host, Int
port)
String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
"Haskell process " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pidStr String -> String -> String
forall a. [a] -> [a] -> [a]
++
" has been successfully announced to agent at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, Int) -> String
forall a. Show a => a -> String
show (String
host, Int
port) String -> String -> String
forall a. [a] -> [a] -> [a]
++
", now waiting for the agent to be ready to accept data."
InternalContext
-> String -> ProcessInfo -> AnnounceResponse -> IO ()
AgentReady.waitUntilAgentIsReadyToAcceptData
InternalContext
context
String
pidStr
ProcessInfo
processInfo
AnnounceResponse
announceResponse
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
pidStr String -> String -> String
forall a. [a] -> [a] -> [a]
++
" (announce failed), 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
decodeAnnounceResponse ::
HTTP.Response ByteString
-> IO (Maybe AnnounceResponse)
decodeAnnounceResponse :: Response ByteString -> IO (Maybe AnnounceResponse)
decodeAnnounceResponse response :: Response ByteString
response = do
let
body :: ByteString
body = Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
response
maybeParsed :: Maybe AnnounceResponse
maybeParsed :: Maybe AnnounceResponse
maybeParsed = ByteString -> Maybe AnnounceResponse
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
body
case Maybe AnnounceResponse
maybeParsed of
Just _ -> do
Maybe AnnounceResponse -> IO (Maybe AnnounceResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AnnounceResponse
maybeParsed
Nothing ->
String -> IO (Maybe AnnounceResponse)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Maybe AnnounceResponse))
-> String -> IO (Maybe AnnounceResponse)
forall a b. (a -> b) -> a -> b
$ "Can't parse announce response" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ByteString -> String
forall a. Show a => a -> String
show ByteString
body)