{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Instana.SDK.Internal.AgentConnection.ConnectLoop
Description : Establishes a connection to the agent.
-}
module Instana.SDK.Internal.AgentConnection.ConnectLoop
    ( initConnectLoop
    ) where


import qualified Control.Concurrent                                   as Concurrent
import qualified Control.Concurrent.STM                               as STM
import           Control.Exception                                    (SomeException,
                                                                       catch)
import           Control.Monad                                        (forever)
import           Data.Maybe                                           (isNothing)
import           Data.Text                                            (Text)
import qualified Data.Text                                            as T
import qualified Data.Text.IO                                         as TextIO
import qualified System.Environment                                   as Environment
import           System.Log.Logger                                    (debugM,
                                                                       infoM,
                                                                       warningM)
import qualified System.Posix.Process                                 as PosixProcess

import qualified Instana.SDK.Internal.AgentConnection.AgentHostLookup as AgentHostLookup
import           Instana.SDK.Internal.AgentConnection.ProcessInfo     (ProcessInfo (ProcessInfo))
import qualified Instana.SDK.Internal.AgentConnection.ProcessInfo     as ProcessInfo
import           Instana.SDK.Internal.AgentConnection.SchedFile       (parsePidFromSchedFile)
import           Instana.SDK.Internal.Context                         (ConnectionState (..),
                                                                       InternalContext)
import qualified Instana.SDK.Internal.Context                         as InternalContext
import           Instana.SDK.Internal.Logging                         (instanaLogger)


{-| Kick of a thread that loops endlessly and checks once in a while if the
agent connection is still up. If not, a connection attempt will be initiated.
The first attempt is made immediately when calling this.
-}
initConnectLoop :: InternalContext -> IO ()
initConnectLoop :: InternalContext -> IO ()
initConnectLoop context :: InternalContext
context = do
  ProcessID
pid <- IO ProcessID
PosixProcess.getProcessID
  String
progName <- IO String
Environment.getProgName
  String
execPath <- IO String
Environment.getExecutablePath
  [String]
args <- IO [String]
Environment.getArgs
  let
    pidStr :: String
pidStr = ProcessID -> String
forall a. Show a => a -> String
show ProcessID
pid
  Maybe Text
cpuSetFileContent <- String -> IO (Maybe Text)
getCpuSetFileContent String
pidStr
  Maybe String
parentNsPid <- String -> IO (Maybe String)
getPidFromParentNamespace String
pidStr
  let
    processInfo :: ProcessInfo
processInfo =
      ProcessInfo :: String
-> String
-> String
-> [String]
-> Maybe Text
-> Maybe String
-> ProcessInfo
ProcessInfo
        { pidString :: String
ProcessInfo.pidString         = String
pidStr
        , programName :: String
ProcessInfo.programName       = String
progName
        , executablePath :: String
ProcessInfo.executablePath    = String
execPath
        , arguments :: [String]
ProcessInfo.arguments         = [String]
args
        , cpuSetFileContent :: Maybe Text
ProcessInfo.cpuSetFileContent = Maybe Text
cpuSetFileContent
        , parentNsPid :: Maybe String
ProcessInfo.parentNsPid       = Maybe String
parentNsPid
        }
  if Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
parentNsPid then
    String -> String -> IO ()
warningM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Could not parse PID from sched file. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
             "Discovery might not work if this process is running inside a " String -> String -> String
forall a. [a] -> [a] -> [a]
++
             "container."
  else
    if (String -> Maybe String
forall a. a -> Maybe a
Just String
pidStr) Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
parentNsPid then
      String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        "PID in sched file matches process PID. Probably not running inside " String -> String -> String
forall a. [a] -> [a] -> [a]
++
        "a PID namespace"
    else do
      let
        Just parentPid :: String
parentPid = Maybe String
parentNsPid
      String -> String -> IO ()
infoM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Changing PID from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pidStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ " to " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
parentPid String -> String -> String
forall a. [a] -> [a] -> [a]
++
            " due to successful identification of PID in parent namespace."
  String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "discovered process info " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProcessInfo -> String
forall a. Show a => a -> String
show ProcessInfo
processInfo

  -- connection loop works as follows:
  -- - try to connect to an an agent at either the agent host/port received via
  -- configuration, environment variables, default (127.0.0.1:42699) or default
  -- gateway
  -- - establishAgentConnection tries to connect to the agent by issuing
  --   a POST to /com.instana.plugin.haskell.discovery
  -- - establishAgentConnection only ever terminates if it has been successful,
  --   then we have switched to announced state.
  -- - after that, establishAgentConnection is called every 5 seconds,
  -- - if the connection is still up, establishAgentConnection does nothing and
  --   returns immediately,
  -- - should the connection have been lost, the cycle starts again, that is,
  --   establishAgentConnection will retry the POST forever and only terminate
  --   after success.
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    InternalContext -> ProcessInfo -> IO ()
establishAgentConnectionSafe InternalContext
context ProcessInfo
processInfo
    Int -> IO ()
Concurrent.threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ 5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1000


establishAgentConnectionSafe ::
  InternalContext
  -> ProcessInfo
  -> IO ()
establishAgentConnectionSafe :: InternalContext -> ProcessInfo -> IO ()
establishAgentConnectionSafe context :: InternalContext
context processInfo :: ProcessInfo
processInfo =
  IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
    (InternalContext -> ProcessInfo -> IO ()
establishAgentConnection InternalContext
context ProcessInfo
processInfo)
    -- exceptions in establishAgentConnection must not kill the loop, so we just
    -- catch everything
    (\e :: SomeException
e -> 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))


establishAgentConnection ::
  InternalContext
  -> ProcessInfo
  -> IO ()
establishAgentConnection :: InternalContext -> ProcessInfo -> IO ()
establishAgentConnection context :: InternalContext
context processInfo :: ProcessInfo
processInfo = do
  ConnectionState
currentState <- 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 (InternalContext -> TVar ConnectionState
InternalContext.connectionState InternalContext
context)

  -- debugM instanaLogger $
  --   "Checking agent connection, current state is " ++ show currentState

  -- Do nothing if a connection attempt is already in progress or connection has
  -- already been established.
  if ConnectionState
currentState ConnectionState -> ConnectionState -> Bool
forall a. Eq a => a -> a -> Bool
/= ConnectionState
Unconnected
    then
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else do
      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
AgentHostLookup
      String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        "Agent connection is not up, attempting (re)connect"
      -- Initial status: Unconnected
      -- step 1: do agent host looup (retry forever until an agent has
      --         been found)
      -- New status: Unannounced
      -- step 2: announce request (retry 3 times with 200 ms delay)
      -- New status: Announced
      -- step 3: check whether agent is ready to accept data (retry 10 times
      --         with 10 second delay)
      -- New status: Connected
      -- If anything fails in between, go back to "Unconnected"
      InternalContext -> ProcessInfo -> IO ()
AgentHostLookup.lookupAgentHost InternalContext
context ProcessInfo
processInfo


getCpuSetFileContent :: String -> IO (Maybe Text)
getCpuSetFileContent :: String -> IO (Maybe Text)
getCpuSetFileContent pidStr :: String
pidStr = do
  let
    cpuSetPath :: String
cpuSetPath = "/proc/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pidStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/cpuset"
  IO (Maybe Text)
-> (SomeException -> IO (Maybe Text)) -> IO (Maybe Text)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
    ( do
      Text
content <- String -> IO Text
TextIO.readFile String
cpuSetPath
      -- paranoid check - if the cpusets file for whatever reason is really big,
      -- we don't want to send it to the agent at all.
      if Text -> Int
T.length Text
content Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2000 then
        Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
      else
        Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
content
    )
    (\(SomeException
_ :: SomeException) -> do
      String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Can't read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cpuSetPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", process " String -> String -> String
forall a. [a] -> [a] -> [a]
++
           "is probably not running in a container."
      Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
    )


getPidFromParentNamespace :: String -> IO (Maybe String)
getPidFromParentNamespace :: String -> IO (Maybe String)
getPidFromParentNamespace pidStr :: String
pidStr = do
  let
    schedFilePath :: String
schedFilePath = "/proc/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pidStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/sched"
  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
schedFileContent <- String -> IO String
readFile String
schedFilePath
        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
parsePidFromSchedFile String
schedFileContent
    )
    (\(SomeException
_ :: SomeException) -> do
      String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Can't read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
schedFilePath String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
      Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    )