{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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)
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)
InternalContext -> ProcessInfo -> IO ()
Announce.announce InternalContext
context ProcessInfo
processInfo
Left _ -> do
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