-- | This module provides functionality for running the 'Hreq' Monad as an HTTP client
-- and the necessary required class instances, such as 'RunClient' instance.
--
{-# LANGUAGE TupleSections #-}
module Hreq.Client.Internal.HTTP
  ( -- * Hreq monad
    Hreq (..)
  , RunClient (..)
    -- * Running Hreq
  , runHreq
  , runHreqWithConfig
  , runHttpClient
    -- * Helper functions
  , checkHttpResponse
  , requestToHTTPRequest
  , httpResponsetoResponse
  , catchConnectionError
  ) where

import Prelude ()
import Prelude.Compat

import Control.Concurrent.STM.TVar (TVar, modifyTVar', readTVar, writeTVar)
import Control.Monad.Catch (SomeException (..), catch, throwM)
import Control.Monad.IO.Unlift (MonadUnliftIO (..), wrappedWithRunInIO)
import Control.Monad.Reader (MonadIO (..), MonadReader, MonadTrans, ReaderT (..), ask, asks)
import Control.Monad.STM (STM, atomically)
import Control.Retry (retrying)
import qualified Data.ByteString.Lazy as LBS
import Data.Either (isLeft)
import Data.Foldable (toList)
import Data.Maybe (maybeToList)
import Data.String.Conversions (cs)
import Data.Time.Clock (UTCTime, getCurrentTime)
import GHC.Natural (Natural)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Media (renderHeader)
import Network.HTTP.Types (Header, hAccept, hContentType, renderQuery, statusCode, statusMessage)

import Hreq.Client.Internal.Config (HttpConfig (..), StatusRange (..), createDefConfig)
import Hreq.Core.API (GivesPooper (..))
import Hreq.Core.Client (BaseUrl (..), ClientError (..), Request, RequestBody (..), RequestF (..),
                         Response, ResponseF (..), RunClient (..), Scheme (..))

-- | Monad for running Http client requests
newtype Hreq m a = Hreq { runHreq' :: ReaderT HttpConfig m a }
  deriving (Functor, Applicative, Monad, MonadReader HttpConfig, MonadTrans, MonadIO)

instance MonadUnliftIO m => MonadUnliftIO (Hreq m) where
  withRunInIO = wrappedWithRunInIO Hreq runHreq'

instance RunClient (Hreq IO) where
  runClient = runHttpClient

  throwHttpError = Hreq . throwM

  checkResponse = checkHttpResponse

runHreq :: MonadIO m => BaseUrl -> Hreq m a -> m a
runHreq baseUrl action = do
  config <- liftIO $ createDefConfig baseUrl

  runHreqWithConfig config action

runHreqWithConfig :: HttpConfig -> Hreq m a -> m a
runHreqWithConfig config action = runReaderT (runHreq' action) config

runHttpClient
  :: (MonadReader HttpConfig m, MonadIO m, RunClient m)
  => Request
  -> m Response
runHttpClient req = do
  config <- ask

  let manager = httpManager config
  let baseUrl = httpBaseUrl config
  let mcookieJar = httpCookieJar config
  let retryPolicy = httpRetryPolicy config

  let httpRequest = requestToHTTPRequest baseUrl req

  let requestAction = liftIO $ catchConnectionError
        $ performHttpRequest httpRequest manager mcookieJar

  ehttpResponse <- retrying retryPolicy (const (return . isLeft) ) (const requestAction)

  response <- either throwHttpError (pure . httpResponsetoResponse cs) ehttpResponse

  maybe (pure response) throwHttpError =<< checkResponse req response

checkHttpResponse
  :: (MonadReader HttpConfig m)
  => Request
  -> Response
  -> m (Maybe ClientError)
checkHttpResponse req response = do
  statusRange <- asks httpStatuses
  let code = resStatusCode response
  pure $ if code >= statusLower statusRange && code <= statusUpper statusRange
    then Just $ FailureResponse req response
    else Nothing

-- * Helper functions
performHttpRequest
  :: HTTP.Request
  -> HTTP.Manager
  -> Maybe (TVar HTTP.CookieJar)
  -> IO (HTTP.Response LBS.ByteString)
performHttpRequest request manager mcookieJar = case mcookieJar of
  Nothing -> HTTP.httpLbs request manager
  Just cj -> do
    req' <- cookieJarRequest cj request
    HTTP.withResponseHistory req' manager $ updateWithResponseCookies cj
  where
    cookieJarRequest :: TVar HTTP.CookieJar -> HTTP.Request -> IO HTTP.Request
    cookieJarRequest cj req = do
      now <- getCurrentTime
      atomically $ do
        oldCookieJar <- readTVar cj
        let (newReq, newCookieJar) = HTTP.insertCookiesIntoRequest req oldCookieJar now
        writeTVar cj newCookieJar
        pure newReq

    -- updateWithResponseCookies code is borrowed from @servant-client@
    updateWithResponseCookies
      :: TVar HTTP.CookieJar
      -> HTTP.HistoriedResponse HTTP.BodyReader
      -> IO (HTTP.Response LBS.ByteString)
    updateWithResponseCookies cj responses = do
        now <- getCurrentTime
        bss <- HTTP.brConsume $ HTTP.responseBody fRes
        let fRes'        = fRes { HTTP.responseBody = LBS.fromChunks bss }
            allResponses = HTTP.hrRedirects responses <> [(fReq, fRes')]
        atomically $ mapM_ (updateCookieJar now) allResponses
        return fRes'
      where
          updateCookieJar :: UTCTime -> (HTTP.Request, HTTP.Response LBS.ByteString) -> STM ()
          updateCookieJar now' (req', res') = modifyTVar' cj (fst . HTTP.updateCookieJar res' req' now')

          fReq = HTTP.hrFinalRequest responses
          fRes = HTTP.hrFinalResponse responses

httpResponsetoResponse :: (a -> b) -> HTTP.Response a -> ResponseF b
httpResponsetoResponse f response = Response
 { resStatusCode = statusCode $ HTTP.responseStatus response
 , resStatusMsg = cs $ statusMessage $ HTTP.responseStatus response
 , resHeaders = HTTP.responseHeaders response
 , resBody = f $ HTTP.responseBody response
 , resHttpVersion = HTTP.responseVersion response
 }

requestToHTTPRequest :: BaseUrl -> Request -> HTTP.Request
requestToHTTPRequest burl r = HTTP.defaultRequest
    { HTTP.method = reqMethod r
    , HTTP.host = cs $ baseUrlHost burl
    , HTTP.port = fromIntegral @Natural @Int $ baseUrlPort burl
    , HTTP.path = cs $ baseUrlPath burl <> reqPath r
    , HTTP.queryString = renderQuery True $ toList $ reqQueryString r
    , HTTP.requestHeaders = maybeToList acceptHeader <> maybeToList contentType <> headers
    , HTTP.requestBody = body
    , HTTP.secure = isSecure
    }
  where
    headers :: [ Header ]
    headers = filter ( \(hname, _) -> hname /= hAccept && hname /= hContentType)
            $ toList $ reqHeaders r

    acceptHeader :: Maybe Header
    acceptHeader = (hAccept, ) . renderHeader <$> reqAccept r

    (body, contentType) = case reqBody r of
      Nothing -> (HTTP.RequestBodyBS mempty, Nothing)
      Just (body', ctyp) ->
        let addBody = (, Just (hContentType, renderHeader ctyp))
        in case body' of
          RequestBodyBS bs ->
            addBody $ HTTP.RequestBodyBS bs
          RequestBodyLBS lbs ->
            addBody $ HTTP.RequestBodyLBS lbs
          RequestBodyStream (GivesPooper givesPooper) ->
            addBody $ HTTP.RequestBodyStreamChunked givesPooper

    isSecure :: Bool
    isSecure = case baseUrlScheme burl of
        Http  -> False
        Https -> True

catchConnectionError :: IO a -> IO (Either ClientError a)
catchConnectionError action =
  catch (Right <$> action)
    $ \e -> pure . Left . ConnectionError $ SomeException (e :: HTTP.HttpException)