HttpHelper.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Instana.SDK.IntegrationTest.HttpHelper
  ( agentStubHost
  , agentStubPort
  , agentStubUrl
  , appUrl
  , defaultHeaders
  , doAgentStubRequest
  , doAppRequest
  , parseResponse
  , requestAgentStubAndParse
  , requestAppAndParse
  , retryRequest
  , retryRequestRecovering
  ) where


import           Control.Monad.Catch              (Handler)
import qualified Control.Retry                    as Retry
import qualified Data.Aeson                       as Aeson
import           Data.ByteString                  (ByteString)
import qualified Data.ByteString.Lazy             as LBS
import qualified Network.HTTP.Client              as HTTP
import           Network.HTTP.Types.Header        (Header, HeaderName)
import           Network.HTTP.Types.Method        (Method)

import           Instana.SDK.IntegrationTest.Util (putStrFlush)


-- 100 milliseconds
retryDelay :: Int
retryDelay = 100 * 1000


-- 5 seconds
maxRetryDelay :: Int
maxRetryDelay = 5 * 1000 * 1000


agentStubHost :: String
agentStubHost = "127.0.0.1"


agentStubPort :: Int
agentStubPort = 1302


agentStubBaseUrl :: String
agentStubBaseUrl =
  "http://" ++ agentStubHost ++ ":" ++ (show agentStubPort) ++ "/"


agentStubUrl :: String -> String
agentStubUrl path =
  agentStubBaseUrl ++ path


appHost :: String
appHost = "127.0.0.1"


appPort :: Int
appPort = 1207


appBaseUrl :: String
appBaseUrl =
  "http://" ++ appHost ++ ":" ++ (show appPort) ++ "/"


appUrl :: String -> String
appUrl path =
  appBaseUrl ++ path


defaultHeaders :: [(HeaderName, ByteString)]
defaultHeaders =
  [ ("Accept", "application/json")
  , ("Content-Type", "application/json; charset=UTF-8")
  ]


requestAgentStubAndParse ::
  Aeson.FromJSON a =>
  String
  -> ByteString
  -> IO (Either String a)
requestAgentStubAndParse path method =
  requestAndParse path method [] agentStubUrl


requestAppAndParse ::
  Aeson.FromJSON a =>
  String
  -> ByteString
  -> [Header]
  -> IO (Either String a)
requestAppAndParse path method headers =
  requestAndParse path method headers appUrl


doAgentStubRequest ::
  String
  -> Method
  -> IO (HTTP.Response LBS.ByteString)
doAgentStubRequest path method =
  doRequest path method [] agentStubUrl


doAppRequest ::
  String
  -> Method
  -> [Header]
  -> IO (HTTP.Response LBS.ByteString)
doAppRequest path method headers =
  doRequest path method headers appUrl


requestAndParse ::
  Aeson.FromJSON a =>
  String
  -> Method
  -> [Header]
  -> (String -> String)
  -> IO (Either String a)
requestAndParse path method headers urlCreator = do
  response <- doRequest path method headers urlCreator
  parseResponse response


doRequest ::
  String
  -> Method
  -> [Header]
  -> (String -> String)
  -> IO (HTTP.Response LBS.ByteString)
doRequest path method headers urlCreator = do
  httpManager <- HTTP.newManager $
    HTTP.defaultManagerSettings { HTTP.managerConnCount = 5 }
  let
    url = urlCreator path
  defaultRequestSettings <- HTTP.parseUrlThrow url
  let
    request = defaultRequestSettings
       { HTTP.method = method
       , HTTP.requestHeaders = defaultHeaders ++ headers
       }
  HTTP.httpLbs request httpManager


parseResponse ::
  Aeson.FromJSON a
  => HTTP.Response LBS.ByteString
  -> IO (Either String a)
parseResponse response = do
  let
    body = HTTP.responseBody response
    parsed = Aeson.decode body
    result =
      case parsed of
        Just p  -> Right p
        Nothing -> Left "Could not parse response."
  return result


retryRequestRecovering ::
  IO (HTTP.Response LBS.ByteString)
  -> IO (HTTP.Response LBS.ByteString)
retryRequestRecovering request =
  let
    retryPolicy :: Retry.RetryPolicyM IO =
      Retry.limitRetriesByCumulativeDelay maxRetryDelay $
        Retry.constantDelay retryDelay
    reportHttpError :: Bool -> HTTP.HttpException -> Retry.RetryStatus -> IO ()
    reportHttpError _ _ _ = putStrFlush "."
    retryOnAnyHttpError :: HTTP.HttpException -> IO Bool
    retryOnAnyHttpError _ = return True
    retryOnAnyStatus :: Retry.RetryStatus -> Handler IO Bool
    retryOnAnyStatus = Retry.logRetries retryOnAnyHttpError reportHttpError

  in
    Retry.recovering
       retryPolicy
       [retryOnAnyStatus]
       (const request)


retryRequest ::
  forall a.
  Show a =>
  (a -> Bool)
  -> IO (Either String a)
  -> IO (Either String a)
retryRequest retryUntil executeRequestAndParseResponse = do
  let
    retryPolicy :: Retry.RetryPolicyM IO =
      Retry.limitRetriesByCumulativeDelay maxRetryDelay $
        Retry.constantDelay retryDelay
    retryCheck :: Retry.RetryStatus -> Either String a -> IO Bool
    retryCheck _ decodedResponse = do
      putStrFlush "."
      case decodedResponse of
        Left _ ->
          return True
        Right value ->
          return $ not $ retryUntil value
  lastResponse <- Retry.retrying
     retryPolicy
     retryCheck
     (const executeRequestAndParseResponse)
  case lastResponse of
    Left _ ->
      return lastResponse
    Right lastValue ->
      if retryUntil lastValue
      then
        return lastResponse
      else
        return $
          Left $
            "HTTP request was successful, but the expected value " ++
            "has not been obtained. The last response was: " ++
            show lastValue