webdriver-precore-0.2.0.0: test/HTTP/HttpClient.hs

module HTTP.HttpClient
  ( callWebDriver,
    mkRequest,
    -- share with deprecated runner
    fullCommandPath,
    responseStatusText,
    callWebDriver'
  )
where

import Const (ReqRequestParams (..))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (Value, object)
import Data.Foldable qualified as F
import Data.Text as T (Text)
import Data.Text.Encoding (decodeUtf8Lenient)
import IOUtils (DemoActions (..))
import Network.HTTP.Req
  ( DELETE (DELETE),
    GET (GET),
    HttpConfig (httpConfigCheckResponse),
    JsonResponse,
    NoReqBody (NoReqBody),
    POST (POST),
    Req,
    ReqBodyJson (ReqBodyJson),
    Scheme (..),
    Url,
    defaultHttpConfig,
    jsonResponse,
    req,
    responseBody,
    responseStatusCode,
    responseStatusMessage,
    runReq,
    (/:),
  )
import Network.HTTP.Req qualified as R
import WebDriverPreCore.HTTP.Protocol (Command (..))
import Utils (UrlPath (..))
import Prelude hiding (log)
import WebDriverPreCore.HTTP.HttpResponse (HttpResponse (..))


-- ############# Http Interaction #############

mkRequest :: forall r. Url 'Http -> Int -> Command r -> ReqRequestParams
mkRequest driverUrl port cmd =
  case cmd of
    Get {} -> MkRequestParams url GET NoReqBody port
    Post {body} -> MkRequestParams url POST (ReqBodyJson body) port
    PostEmpty {} -> MkRequestParams url POST (ReqBodyJson $ object []) port
    Delete {} -> MkRequestParams url DELETE NoReqBody port
  where
    url = fullCommandPath driverUrl cmd.path.segments

fullCommandPath :: Url 'Http -> [Text] -> Url 'Http
fullCommandPath basePath = F.foldl' (/:) basePath

-- call webdriver returning the body of the response as a JSON Value
callWebDriver' :: DemoActions -> ReqRequestParams -> IO Value
callWebDriver' MkDemoActions {logShow = logShow', logJSON = logJSON'} MkRequestParams {url, method, body, port = prt} =
  runReq defaultHttpConfig {httpConfigCheckResponse = \_ _ _ -> Nothing} $ do
    logShow "URL" url
    r <- req method url body jsonResponse $ R.port prt

    let body' = responseBody r :: Value

    logShow "Status Code" $ responseStatusCode r
    logShow "Status Message" $ responseStatusText r
    logJSON "Response Body" body'

    pure body'
  where
    logShow :: (Show a) => Text -> a -> Req ()
    logShow msg = liftIO . logShow' msg
    logJSON msg = liftIO . logJSON' msg

-- call webdriver returning the full HttpResponse (kept for now to support deprecated runner)
callWebDriver :: DemoActions -> ReqRequestParams -> IO HttpResponse
callWebDriver MkDemoActions {logShow = logShow', logJSON = logJSON'} MkRequestParams {url, method, body, port = prt} =
  runReq defaultHttpConfig {httpConfigCheckResponse = \_ _ _ -> Nothing} $ do
    logShow "URL" url
    r <- req method url body jsonResponse $ R.port prt

    let body' = responseBody r :: Value
        fr =
          MkHttpResponse
            { statusCode = responseStatusCode r,
              statusMessage = responseStatusText r,
              body = body'
            }

    logShow "Status Code" fr.statusCode
    logShow "Status Message" fr.statusMessage
    logJSON "Response Body" fr.body
    logShow "Framework Response Object" fr

    pure fr
  where
    logShow :: (Show a) => Text -> a -> Req ()
    logShow msg = liftIO . logShow' msg
    logJSON msg = liftIO . logJSON' msg

-- ############# Utils #############

responseStatusText :: JsonResponse Value -> Text
responseStatusText = decodeUtf8Lenient . responseStatusMessage