{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Instana.SDK.Internal.AgentConnection.AgentHostLookup
Description : Handles the agent host lookup phase for establishing the
connection to the agent.
-}
module Instana.SDK.Internal.AgentConnection.AgentHostLookup
    ( lookupAgentHost
    ) where


import qualified Control.Concurrent.STM                           as STM
import           Control.Exception                                (SomeException,
                                                                   catch)
import           Data.ByteString.Char8                            (unpack)
import           Data.Char                                        (isSpace)
import qualified Data.List                                        as List
import qualified Network.HTTP.Client                              as HTTP
import qualified Network.HTTP.Types.Header                        as Header
import           System.Exit                                      (ExitCode (ExitSuccess))
import           System.Log.Logger                                (debugM)
import           System.Process                                   as Process

import qualified Instana.SDK.Internal.AgentConnection.Announce    as Announce
import           Instana.SDK.Internal.AgentConnection.ProcessInfo (ProcessInfo)
import qualified Instana.SDK.Internal.Config                      as InternalConfig
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


type SuccessfullHost = (String, Int)


-- |Starts the agent host lookup phase.
lookupAgentHost ::
  InternalContext
  -> ProcessInfo
  -> IO ()
lookupAgentHost :: InternalContext -> ProcessInfo -> IO ()
lookupAgentHost context :: InternalContext
context processInfo :: ProcessInfo
processInfo = do
  String -> String -> IO ()
debugM String
instanaLogger "Starting agent host lookup."
  Either String SuccessfullHost
result <-
    RetryPolicyM IO
-> IO (Either String SuccessfullHost)
-> IO (Either String SuccessfullHost)
forall a.
Show a =>
RetryPolicyM IO -> IO (Either String a) -> IO (Either String a)
Retry.retryUntilRight
      RetryPolicyM IO
Retry.agentHostLookupRetryPolicy
      (InternalContext -> IO (Either String SuccessfullHost)
tryAll InternalContext
context)
  case Either String SuccessfullHost
result of
    Right successfulHost :: SuccessfullHost
successfulHost -> do
      String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        "Found an agent to connect to: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SuccessfullHost -> String
forall a. Show a => a -> String
show SuccessfullHost
successfulHost String -> String -> String
forall a. [a] -> [a] -> [a]
++
        ", starting sensor-agent handshake."
      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)
          (SuccessfullHost -> ConnectionState
Unannounced SuccessfullHost
successfulHost)

      -- transition to next phase of sensor-agent handshake
      InternalContext -> ProcessInfo -> IO ()
Announce.announce InternalContext
context ProcessInfo
processInfo
    Left _ -> do
      -- Actually, this line should never be reached, as the agent host lookup
      -- is retried indefinitely.
      String -> String -> IO ()
debugM String
instanaLogger "Could not find an agent to connect to."
      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


tryAll :: InternalContext -> IO (Either String SuccessfullHost)
tryAll :: InternalContext -> IO (Either String SuccessfullHost)
tryAll context :: InternalContext
context = do
  Either String SuccessfullHost
resultConfiguredHost <- InternalContext -> IO (Either String SuccessfullHost)
tryConfiguredHost InternalContext
context
  case Either String SuccessfullHost
resultConfiguredHost of
    Right _ ->
      Either String SuccessfullHost -> IO (Either String SuccessfullHost)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String SuccessfullHost
resultConfiguredHost
    Left errc :: String
errc -> do
      String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
errc String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", trying default gateway next."
      Either String SuccessfullHost
resultDefaultGateway <- InternalContext -> IO (Either String SuccessfullHost)
tryDefaultGateway InternalContext
context
      case Either String SuccessfullHost
resultDefaultGateway of
        Right _ ->
          Either String SuccessfullHost -> IO (Either String SuccessfullHost)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String SuccessfullHost
resultDefaultGateway
        Left errdg :: String
errdg -> do
          String -> String -> IO ()
debugM String
instanaLogger String
errdg
          Either String SuccessfullHost -> IO (Either String SuccessfullHost)
forall (m :: * -> *) a. Monad m => a -> m a
return Either String SuccessfullHost
resultDefaultGateway


tryConfiguredHost :: InternalContext -> IO (Either String SuccessfullHost)
tryConfiguredHost :: InternalContext -> IO (Either String SuccessfullHost)
tryConfiguredHost context :: InternalContext
context = do
  let
    config :: FinalConfig
config = InternalContext -> FinalConfig
InternalContext.config InternalContext
context
    host :: String
host = FinalConfig -> String
InternalConfig.agentHost FinalConfig
config
    port :: Int
port = FinalConfig -> Int
InternalConfig.agentPort FinalConfig
config
  InternalContext
-> String -> Int -> IO (Either String SuccessfullHost)
tryHost InternalContext
context String
host Int
port


tryDefaultGateway :: InternalContext -> IO (Either String SuccessfullHost)
tryDefaultGateway :: InternalContext -> IO (Either String SuccessfullHost)
tryDefaultGateway context :: InternalContext
context = do
  let
    config :: FinalConfig
config = InternalContext -> FinalConfig
InternalContext.config InternalContext
context
    port :: Int
port = FinalConfig -> Int
InternalConfig.agentPort FinalConfig
config
  Either String String
defaultGateway <- IO (Either String String)
readDefaultGateway
  case Either String String
defaultGateway of
    Right gatewayHost :: String
gatewayHost ->
      InternalContext
-> String -> Int -> IO (Either String SuccessfullHost)
tryHost InternalContext
context String
gatewayHost Int
port
    Left err :: String
err ->
      Either String SuccessfullHost -> IO (Either String SuccessfullHost)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String SuccessfullHost
 -> IO (Either String SuccessfullHost))
-> Either String SuccessfullHost
-> IO (Either String SuccessfullHost)
forall a b. (a -> b) -> a -> b
$ String -> Either String SuccessfullHost
forall a b. a -> Either a b
Left String
err


tryHost ::
  InternalContext
  -> String
  -> Int
  -> IO (Either String SuccessfullHost)
tryHost :: InternalContext
-> String -> Int -> IO (Either String SuccessfullHost)
tryHost context :: InternalContext
context host :: String
host port :: Int
port = do
  let
    expectedServerHeader :: String
expectedServerHeader = "Instana Agent"
    manager :: Manager
manager = InternalContext -> Manager
InternalContext.httpManager InternalContext
context
    agentRootUrl :: URL
agentRootUrl = String -> Int -> String -> URL
URL.mkHttp String
host Int
port ""
  String -> String -> IO ()
debugM String
instanaLogger (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Trying to reach agent at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URL -> String
forall a. Show a => a -> String
show URL
agentRootUrl
  Request
agentRootRequest <- 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
agentRootUrl
  let
    agentRootAction :: IO (Response ByteString)
agentRootAction = Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
agentRootRequest Manager
manager
  IO (Either String SuccessfullHost)
-> (SomeException -> IO (Either String SuccessfullHost))
-> IO (Either String SuccessfullHost)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
    (do
      Response ByteString
response <- IO (Response ByteString)
agentRootAction
      let
        headers :: ResponseHeaders
headers = Response ByteString -> ResponseHeaders
forall body. Response body -> ResponseHeaders
HTTP.responseHeaders Response ByteString
response
        serverHeaderTuple :: Maybe (HeaderName, ByteString)
serverHeaderTuple = ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\(h :: HeaderName
h, _) -> HeaderName
h HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
Header.hServer) ResponseHeaders
headers
        serverHeaderValue :: Maybe String
serverHeaderValue = (ByteString -> String
unpack (ByteString -> String)
-> ((HeaderName, ByteString) -> ByteString)
-> (HeaderName, ByteString)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd) ((HeaderName, ByteString) -> String)
-> Maybe (HeaderName, ByteString) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HeaderName, ByteString)
serverHeaderTuple
      if Maybe String
serverHeaderValue Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
expectedServerHeader
      then do
        Either String SuccessfullHost -> IO (Either String SuccessfullHost)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String SuccessfullHost
 -> IO (Either String SuccessfullHost))
-> Either String SuccessfullHost
-> IO (Either String SuccessfullHost)
forall a b. (a -> b) -> a -> b
$ SuccessfullHost -> Either String SuccessfullHost
forall a b. b -> Either a b
Right (String
host, Int
port)
      else do
        Either String SuccessfullHost -> IO (Either String SuccessfullHost)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String SuccessfullHost
 -> IO (Either String SuccessfullHost))
-> Either String SuccessfullHost
-> IO (Either String SuccessfullHost)
forall a b. (a -> b) -> a -> b
$ String -> Either String SuccessfullHost
forall a b. a -> Either a b
Left (String -> Either String SuccessfullHost)
-> String -> Either String SuccessfullHost
forall a b. (a -> b) -> a -> b
$
          "Host at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URL -> String
forall a. Show a => a -> String
show URL
agentRootUrl String -> String -> String
forall a. [a] -> [a] -> [a]
++ " did not respond with " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          "expected Server header (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expectedServerHeader String -> String -> String
forall a. [a] -> [a] -> [a]
++
          ") but with: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show Maybe String
serverHeaderValue
    )
    (\e :: SomeException
e -> do
      let
        SomeException
_ = (SomeException
e :: SomeException)
      Either String SuccessfullHost -> IO (Either String SuccessfullHost)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String SuccessfullHost
 -> IO (Either String SuccessfullHost))
-> Either String SuccessfullHost
-> IO (Either String SuccessfullHost)
forall a b. (a -> b) -> a -> b
$ String -> Either String SuccessfullHost
forall a b. a -> Either a b
Left (String -> Either String SuccessfullHost)
-> String -> Either String SuccessfullHost
forall a b. (a -> b) -> a -> b
$
        "Could not reach agent at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ URL -> String
forall a. Show a => a -> String
show URL
agentRootUrl
    )


readDefaultGateway :: IO (Either String String)
readDefaultGateway :: IO (Either String String)
readDefaultGateway = do
  let
    cmd :: String
cmd = "/sbin/ip route | awk '/default/ { print $3 }'"
    stdIn :: String
stdIn = ""
  (exitCode :: ExitCode
exitCode, stdOut :: String
stdOut, stdErr :: String
stdErr) <-
    CreateProcess -> String -> IO (ExitCode, String, String)
Process.readCreateProcessWithExitCode (String -> CreateProcess
Process.shell String
cmd) String
stdIn
  if ExitCode
exitCode ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess Bool -> Bool -> Bool
|| String
stdErr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= ""
  then
    Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ "Failed to retrieve default gateway: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stdErr
  else
    Either String String -> IO (Either String String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String -> String
trim String
stdOut
  where
    trim :: String -> String
trim = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace