{-# LANGUAGE OverloadedStrings #-}
{-|
Module      : Instana.SDK.Internal.AgentConnection.Announce
Description : Handles the announce phase for establishing the connection to the
agent.
-}
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


-- |Starts the announce phase.
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
      )

  -- maybeAnnounceResponse is guaranteed to be Just _ if request succeeded and
  -- response was parsed succesfully, it is only Nothing when an exception
  -- has been catched, which should actually never happen, because we retry
  -- indefinitely.
  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."

    -- transition to next phase of sensor-agent handshake
    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


{-| Decodes the JSON response returned by the announce request.
-}
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)