{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}

{-|

HTTP(S)-specific wait functions, for waiting on servers.

-}


module Test.Sandwich.Contexts.HttpWaits (
  -- * HTTP waits
  waitUntilStatusCode
  , waitUntilStatusCodeWithTimeout

  -- * Types
  , VerifyCerts(..)
  , WaitConstraints
  ) where

import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Data.Maybe
import Data.String.Interpolate
import GHC.Stack
import Network.Connection (TLSSettings(..))
import Network.HTTP.Conduit
import Network.HTTP.Types.Status (statusCode)
import Network.Stream hiding (Result)
import Relude
import Test.Sandwich
import UnliftIO.Exception
import UnliftIO.Timeout

#ifdef MIN_VERSION_crypton_connection
#if MIN_VERSION_crypton_connection(0,4,0)
import Data.Default (def)
#endif
#endif


timePerRequest :: Int
timePerRequest :: Int
timePerRequest = Int
10_000_000

type WaitConstraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m)

-- | Whether to verify certificates or not when connecting to an HTTPS endpoint.
data VerifyCerts = YesVerify | NoVerify
  deriving (VerifyCerts -> VerifyCerts -> Bool
(VerifyCerts -> VerifyCerts -> Bool)
-> (VerifyCerts -> VerifyCerts -> Bool) -> Eq VerifyCerts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerifyCerts -> VerifyCerts -> Bool
== :: VerifyCerts -> VerifyCerts -> Bool
$c/= :: VerifyCerts -> VerifyCerts -> Bool
/= :: VerifyCerts -> VerifyCerts -> Bool
Eq)

tlsNoVerifySettings :: ManagerSettings
tlsNoVerifySettings :: ManagerSettings
tlsNoVerifySettings = TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
tlsSettings Maybe SockSettings
forall a. Maybe a
Nothing
  where
    tlsSettings :: TLSSettings
tlsSettings = TLSSettingsSimple {
      settingDisableCertificateValidation :: Bool
settingDisableCertificateValidation = Bool
True
      , settingDisableSession :: Bool
settingDisableSession = Bool
False
      , settingUseServerName :: Bool
settingUseServerName = Bool
False
#ifdef MIN_VERSION_crypton_connection
#if MIN_VERSION_crypton_connection(0,4,0)
      , settingClientSupported :: Supported
settingClientSupported = Supported
forall a. Default a => a
def
#endif
#endif
      }

-- | Send HTTP requests to a URL until we get a response with an given code.
waitUntilStatusCode :: (WaitConstraints m) => (Int, Int, Int) -> VerifyCerts -> String -> m ()
waitUntilStatusCode :: forall (m :: * -> *).
WaitConstraints m =>
(Int, Int, Int) -> VerifyCerts -> String -> m ()
waitUntilStatusCode (Int, Int, Int)
code VerifyCerts
verifyCerts String
url = do
  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Beginning waitUntilStatusCode request to #{url}|]
  Request
req <- case String -> Either SomeException Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url of
    Left SomeException
err -> String -> m Request
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Couldn't parse URL: #{url}: #{err}|]
    Right Request
x -> Request -> m Request
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
x
  Manager
man <- IO Manager -> m Manager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager (if VerifyCerts
verifyCerts VerifyCerts -> VerifyCerts -> Bool
forall a. Eq a => a -> a -> Bool
== VerifyCerts
YesVerify then ManagerSettings
tlsManagerSettings else ManagerSettings
tlsNoVerifySettings)
  Int
-> m (Either ConnError (Response ByteString))
-> m (Maybe (Either ConnError (Response ByteString)))
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
timePerRequest (m (Either ConnError (Response ByteString))
-> m (Either ConnError (Response ByteString))
forall {b}. m (Either ConnError b) -> m (Either ConnError b)
handleException (m (Either ConnError (Response ByteString))
 -> m (Either ConnError (Response ByteString)))
-> m (Either ConnError (Response ByteString))
-> m (Either ConnError (Response ByteString))
forall a b. (a -> b) -> a -> b
$ (Response ByteString -> Either ConnError (Response ByteString)
forall a b. b -> Either a b
Right (Response ByteString -> Either ConnError (Response ByteString))
-> m (Response ByteString)
-> m (Either ConnError (Response ByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (Response ByteString)
 -> m (Either ConnError (Response ByteString)))
-> m (Response ByteString)
-> m (Either ConnError (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
req Manager
man) m (Maybe (Either ConnError (Response ByteString)))
-> (Maybe (Either ConnError (Response ByteString)) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Right Response ByteString
resp)
      | Status -> Int
statusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int, Int, Int) -> Int
forall {a}. Num a => (a, a, a) -> a
statusToInt (Int, Int, Int)
code -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise -> do
          Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Unexpected response in waitUntilStatusCode request to #{url}: #{responseStatus resp}. Wanted #{code}. Body is #{responseBody resp}|]
          m ()
retry
    Just (Left ConnError
err) -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Failure in waitUntilStatusCode request to #{url}: #{err}|]
      m ()
retry
    Maybe (Either ConnError (Response ByteString))
Nothing -> do
      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Timeout in waitUntilStatusCode request to #{url} (after #{timePerRequest}us)|]
      m ()
retry
  where
    retry :: m ()
retry = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
1_000_000) m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Int, Int, Int) -> VerifyCerts -> String -> m ()
forall (m :: * -> *).
WaitConstraints m =>
(Int, Int, Int) -> VerifyCerts -> String -> m ()
waitUntilStatusCode (Int, Int, Int)
code VerifyCerts
verifyCerts String
url
    handleException :: m (Either ConnError b) -> m (Either ConnError b)
handleException = (SomeException -> m (Either ConnError b))
-> m (Either ConnError b) -> m (Either ConnError b)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(SomeException
e :: SomeException) -> Either ConnError b -> m (Either ConnError b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConnError b -> m (Either ConnError b))
-> Either ConnError b -> m (Either ConnError b)
forall a b. (a -> b) -> a -> b
$ ConnError -> Either ConnError b
forall a b. a -> Either a b
Left (ConnError -> Either ConnError b)
-> ConnError -> Either ConnError b
forall a b. (a -> b) -> a -> b
$ String -> ConnError
ErrorMisc [i|Exception in waitUntilStatusCode: #{e}|])
    statusToInt :: (a, a, a) -> a
statusToInt (a
x, a
y, a
z) = a
100 a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
10 a -> a -> a
forall a. Num a => a -> a -> a
* a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
z

-- | Same as 'waitUntilStatusCode', but with a customizable timeout in microseconds.
waitUntilStatusCodeWithTimeout :: (WaitConstraints m) => (Int, Int, Int) -> Int -> VerifyCerts -> String -> m ()
waitUntilStatusCodeWithTimeout :: forall (m :: * -> *).
WaitConstraints m =>
(Int, Int, Int) -> Int -> VerifyCerts -> String -> m ()
waitUntilStatusCodeWithTimeout (Int, Int, Int)
code Int
timeInMicroseconds VerifyCerts
verifyCerts String
url = do
  Maybe ()
maybeSuccess <- Int -> m () -> m (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
timeInMicroseconds (m () -> m (Maybe ())) -> m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ (Int, Int, Int) -> VerifyCerts -> String -> m ()
forall (m :: * -> *).
WaitConstraints m =>
(Int, Int, Int) -> VerifyCerts -> String -> m ()
waitUntilStatusCode (Int, Int, Int)
code VerifyCerts
verifyCerts String
url
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe () -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ()
maybeSuccess) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Failed to connect to URL "#{url}" in waitUntilStatusCodeWithTimeout'...|]