HTTP.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Gogol.Internal.HTTP
-- Copyright   : (c) 2015-2022 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
module Gogol.Internal.HTTP where

import Control.Exception (Handler (..), catches, throwIO, toException)
import Control.Lens ((%~), (&))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Resource (MonadResource (..), transResourceT)
import Data.Monoid (Dual (..), Endo (..))
import Data.Text.Encoding qualified as Text
import Data.Text.Lazy qualified as LText
import Data.Text.Lazy.Builder qualified as Build
import GHC.Exts (toList)
import Gogol.Auth (KnownScopes, authorize)
import Gogol.Env (Env (..))
import Gogol.Internal.Logger (logDebug)
import Gogol.Internal.Multipart
import Gogol.Types
import Network.HTTP.Client.Conduit qualified as Client
import Network.HTTP.Conduit
import Network.HTTP.Media (RenderHeader (..))
import Network.HTTP.Types

-- FIXME: "mediaType" param also comes/calculated from the request body?
--
-- Resumable endpoints - Not supported to begin with, need to figure
-- out how to return session id etc.
--   - Assume initially that every service supports multipart upload.
--
-- "resumable" or "multipart" needs to go into the "uploadType" param

unsafeRequest ::
  ( MonadResource m,
    GoogleRequest a,
    KnownScopes scopes
  ) =>
  Env scopes ->
  a ->
  m (Either Error (Rs a))
unsafeRequest Env {..} x =
  liftResourceT (transResourceT (`catches` handlers) go)
  where
    Request {..} = _cliRequest

    ServiceConfig {..} = _cliService

    GClient {..} =
      requestClient x
        & clientService %~ appEndo (getDual _envOverride)

    go = do
      (ct, b) <- getContent _rqBody
      rq <- authorize (request ct b) _envStore _envLogger _envManager

      logDebug _envLogger rq -- debug:ClientRequest
      rs <- http rq _envManager

      logDebug _envLogger rs -- debug:ClientResponse
      statusCheck rs

      r <- _cliResponse (responseBody rs)

      pure $! case r of
        Right y -> Right y
        Left (e, bs) ->
          Left . SerializeError $
            SerializeError'
              { _serializeId = _svcId,
                _serializeHeaders = responseHeaders rs,
                _serializeStatus = responseStatus rs,
                _serializeMessage = e,
                _serializeBody = Just bs
              }

    request ct b =
      Client.defaultRequest
        { Client.host = _svcHost,
          Client.port = _svcPort,
          Client.secure = _svcSecure,
          Client.responseTimeout = timeout,
          Client.method = _cliMethod,
          Client.path = path,
          Client.queryString = renderQuery True (toList _rqQuery),
          Client.requestHeaders = accept (ct (toList _rqHeaders)),
          Client.requestBody = b
        }

    accept
      | Just t <- _cliAccept = ((hAccept, renderHeader t) :)
      | otherwise = id

    path =
      Text.encodeUtf8
        . LText.toStrict
        $ Build.toLazyText (_svcPath <> _rqPath)

    statusCheck rs
      | _cliCheck (responseStatus rs) = pure ()
      | otherwise = do
          b <- sinkLBS (responseBody rs)

          liftIO . throwIO . toException . ServiceError $
            ServiceError'
              { _serviceId = _svcId,
                _serviceStatus = responseStatus rs,
                _serviceHeaders = responseHeaders rs,
                _serviceBody = Just b
              }

    timeout =
      maybe
        Client.responseTimeoutNone
        (Client.responseTimeoutMicro . microseconds)
        _svcTimeout

    handlers =
      [ Handler $ err,
        Handler $ err . TransportError
      ]
      where
        err e = return (Left e)

getContent ::
  (MonadIO m) =>
  [GBody] ->
  m ([Header] -> [Header], RequestBody)
getContent [] = pure (id, mempty)
getContent [GBody t s] = pure (((hContentType, renderHeader t) :), s)
getContent bs = do
  b <- genBoundary
  pure
    ( (multipartHeader b :),
      renderParts b bs
    )