-- | Centralized module for making HTTP requests
--
-- These functions:
--
-- - Do not throw exceptions on non-200
-- - May throw for other 'HttpException' cases (e.g. 'ConnectionTimeout')
-- - Capture decoding failures with 'Either' values as the 'Response' body
-- - Handle 429-@Retry-In@ for you (if using an 'IO'-based instance)
module Freckle.App.Http
  ( MonadHttp (..)

    -- * Decoding responses
  , httpJson
  , HttpDecodeError (..)
  , httpDecode

    -- * Pagination
  , httpPaginated
  , sourcePaginated

    -- * Request builders
  , Request
  , parseRequest
  , parseRequest_

    -- * Request modifiers
  , addRequestHeader
  , addAcceptHeader
  , addBearerAuthorizationHeader
  , addToRequestQueryString
  , setRequestBasicAuth
  , setRequestBodyJSON
  , setRequestBodyURLEncoded
  , setRequestCheckStatus
  , setRequestMethod
  , setRequestPath
  , disableRequestDecompress

    -- * Response accessors
  , Response
  , getResponseStatus
  , getResponseBody

    -- ** Unsafe access
  , getResponseBodyUnsafe

    -- * Exceptions
  , HttpException (..)
    -- | Predicates useful for handling 'HttpException's
    --
    -- For example, given a function 'guarded', which returns 'Just' a given value
    -- when a predicate holds for it (otherwise 'Nothing'), you can add
    -- error-handling specific to exceptions caused by 4XX responses:
    --
    -- @
    -- flip 'catchJust' (guard 'httpExceptionIsClientError' *> handle4XXError) $ do
    --   resp <- 'httpJson' $ 'setRequestCheckStatus' $ parseRequest_ "http://..."
    --   body <- 'getResponseBodyUnsafe' resp
    --
    --   -- ...
    -- @
  , httpExceptionIsInformational
  , httpExceptionIsRedirection
  , httpExceptionIsClientError
  , httpExceptionIsServerError

    -- * "Network.HTTP.Types" re-exports
  , Status
  , statusCode
  , statusIsInformational
  , statusIsSuccessful
  , statusIsRedirection
  , statusIsClientError
  , statusIsServerError
  , StdMethod (..)
  ) where

import Prelude

import Conduit (foldC, mapMC, runConduit, (.|))
import Control.Exception.Annotated.UnliftIO (Exception (..), throwWithCallStack)
import Control.Monad.Except (ExceptT)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (ReaderT)
import Control.Monad.State (StateT)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Validate (ValidateT)
import Control.Monad.Writer (WriterT)
import Data.Aeson (FromJSON)
import Data.Aeson qualified as Aeson
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as BSL
import Data.ByteString.Lazy.Char8 qualified as BSL8
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Freckle.App.Http.Paginate
import Freckle.App.Http.Retry
import GHC.Stack (HasCallStack)
import Network.HTTP.Client qualified as HTTP (Request (..))
import Network.HTTP.Conduit (HttpExceptionContent (..))
import Network.HTTP.Simple hiding (httpLbs, httpNoBody, setRequestMethod)
import Network.HTTP.Simple qualified as HTTP
import Network.HTTP.Types (StdMethod (..), renderStdMethod)
import Network.HTTP.Types.Header (hAccept, hAuthorization)
import Network.HTTP.Types.Status
  ( Status
  , statusCode
  , statusIsClientError
  , statusIsInformational
  , statusIsRedirection
  , statusIsServerError
  , statusIsSuccessful
  )

-- | Type-class for making HTTP requests
--
-- Functions of this module require the 'MonadHttp' constraint. This type class
-- allows us to instantiate differently in different contexts, most usefully
-- with stubbed responses in test. (See "Freckle.App.Test.Http".)
--
-- The 'IO' instance does what you would expect, and can be used to either build
-- your own instances:
--
-- @
-- instance MonadIO m => MonadHttp (AppT m) where
--   httpLbs = liftIO . httpLbs
--
-- instance MonadHttp (HandlerFor App) where
--   httpLbs = liftIO . httpLbs
-- @
--
-- Or directly,
--
-- @
-- resp <- liftIO $ httpLbs ...
-- @
class Monad m => MonadHttp m where
  httpLbs :: Request -> m (Response BSL.ByteString)

instance MonadHttp IO where
  httpLbs :: Request -> IO (Response ByteString)
httpLbs = (Request -> IO (Response ByteString))
-> Request -> IO (Response ByteString)
forall (m :: * -> *) body.
MonadIO m =>
(Request -> m (Response body)) -> Request -> m (Response body)
rateLimited Request -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
HTTP.httpLbs

instance MonadHttp m => MonadHttp (MaybeT m) where
  httpLbs :: Request -> MaybeT m (Response ByteString)
httpLbs = m (Response ByteString) -> MaybeT m (Response ByteString)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Response ByteString) -> MaybeT m (Response ByteString))
-> (Request -> m (Response ByteString))
-> Request
-> MaybeT m (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> m (Response ByteString)
forall (m :: * -> *).
MonadHttp m =>
Request -> m (Response ByteString)
httpLbs

instance MonadHttp m => MonadHttp (ReaderT r m) where
  httpLbs :: Request -> ReaderT r m (Response ByteString)
httpLbs = m (Response ByteString) -> ReaderT r m (Response ByteString)
forall (m :: * -> *) a. Monad m => m a -> ReaderT r m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Response ByteString) -> ReaderT r m (Response ByteString))
-> (Request -> m (Response ByteString))
-> Request
-> ReaderT r m (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> m (Response ByteString)
forall (m :: * -> *).
MonadHttp m =>
Request -> m (Response ByteString)
httpLbs

instance (Monoid w, MonadHttp m) => MonadHttp (WriterT w m) where
  httpLbs :: Request -> WriterT w m (Response ByteString)
httpLbs = m (Response ByteString) -> WriterT w m (Response ByteString)
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Response ByteString) -> WriterT w m (Response ByteString))
-> (Request -> m (Response ByteString))
-> Request
-> WriterT w m (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> m (Response ByteString)
forall (m :: * -> *).
MonadHttp m =>
Request -> m (Response ByteString)
httpLbs

instance MonadHttp m => MonadHttp (StateT s m) where
  httpLbs :: Request -> StateT s m (Response ByteString)
httpLbs = m (Response ByteString) -> StateT s m (Response ByteString)
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Response ByteString) -> StateT s m (Response ByteString))
-> (Request -> m (Response ByteString))
-> Request
-> StateT s m (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> m (Response ByteString)
forall (m :: * -> *).
MonadHttp m =>
Request -> m (Response ByteString)
httpLbs

instance MonadHttp m => MonadHttp (ExceptT e m) where
  httpLbs :: Request -> ExceptT e m (Response ByteString)
httpLbs = m (Response ByteString) -> ExceptT e m (Response ByteString)
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Response ByteString) -> ExceptT e m (Response ByteString))
-> (Request -> m (Response ByteString))
-> Request
-> ExceptT e m (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> m (Response ByteString)
forall (m :: * -> *).
MonadHttp m =>
Request -> m (Response ByteString)
httpLbs

instance MonadHttp m => MonadHttp (ValidateT e m) where
  httpLbs :: Request -> ValidateT e m (Response ByteString)
httpLbs = m (Response ByteString) -> ValidateT e m (Response ByteString)
forall (m :: * -> *) a. Monad m => m a -> ValidateT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Response ByteString) -> ValidateT e m (Response ByteString))
-> (Request -> m (Response ByteString))
-> Request
-> ValidateT e m (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> m (Response ByteString)
forall (m :: * -> *).
MonadHttp m =>
Request -> m (Response ByteString)
httpLbs

data HttpDecodeError = HttpDecodeError
  { HttpDecodeError -> ByteString
hdeBody :: BSL.ByteString
  , HttpDecodeError -> NonEmpty String
hdeErrors :: NonEmpty String
  }
  deriving stock (HttpDecodeError -> HttpDecodeError -> Bool
(HttpDecodeError -> HttpDecodeError -> Bool)
-> (HttpDecodeError -> HttpDecodeError -> Bool)
-> Eq HttpDecodeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HttpDecodeError -> HttpDecodeError -> Bool
== :: HttpDecodeError -> HttpDecodeError -> Bool
$c/= :: HttpDecodeError -> HttpDecodeError -> Bool
/= :: HttpDecodeError -> HttpDecodeError -> Bool
Eq, Int -> HttpDecodeError -> ShowS
[HttpDecodeError] -> ShowS
HttpDecodeError -> String
(Int -> HttpDecodeError -> ShowS)
-> (HttpDecodeError -> String)
-> ([HttpDecodeError] -> ShowS)
-> Show HttpDecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HttpDecodeError -> ShowS
showsPrec :: Int -> HttpDecodeError -> ShowS
$cshow :: HttpDecodeError -> String
show :: HttpDecodeError -> String
$cshowList :: [HttpDecodeError] -> ShowS
showList :: [HttpDecodeError] -> ShowS
Show)

instance Exception HttpDecodeError where
  displayException :: HttpDecodeError -> String
displayException HttpDecodeError {NonEmpty String
ByteString
hdeBody :: HttpDecodeError -> ByteString
hdeErrors :: HttpDecodeError -> NonEmpty String
hdeBody :: ByteString
hdeErrors :: NonEmpty String
..} =
    Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [Text
"Error decoding HTTP Response:", Text
"Raw body:", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BSL8.unpack ByteString
hdeBody]
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> NonEmpty String -> [Text]
fromErrors NonEmpty String
hdeErrors
   where
    fromErrors :: NonEmpty String -> [Text]
fromErrors = \case
      String
err NE.:| [] -> [Text
"Error:", String -> Text
T.pack String
err]
      NonEmpty String
errs -> Text
"Errors:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
bullet (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
errs)
    bullet :: a -> a
bullet = (a
" • " <>)

-- | Make a request and parse the body as JSON
--
-- @
-- -- Throws, but only on a complete failure to perform the request
-- resp <- 'httpJson' $ 'parseRequest_' "https://example.com"
--
-- -- Safe access
-- 'getResponseBody' resp :: Either 'HttpDecodeError' a
--
-- -- Unsafe access (throws on Left)
-- 'getResponseBodyUnsafe' resp :: m a
-- @
httpJson
  :: (MonadHttp m, FromJSON a)
  => Request
  -> m (Response (Either HttpDecodeError a))
httpJson :: forall (m :: * -> *) a.
(MonadHttp m, FromJSON a) =>
Request -> m (Response (Either HttpDecodeError a))
httpJson =
  (ByteString -> Either (NonEmpty String) a)
-> Request -> m (Response (Either HttpDecodeError a))
forall (m :: * -> *) a.
MonadHttp m =>
(ByteString -> Either (NonEmpty String) a)
-> Request -> m (Response (Either HttpDecodeError a))
httpDecode ((String -> NonEmpty String)
-> Either String a -> Either (NonEmpty String) a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> NonEmpty String
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> Either (NonEmpty String) a)
-> (ByteString -> Either String a)
-> ByteString
-> Either (NonEmpty String) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode)
    (Request -> m (Response (Either HttpDecodeError a)))
-> (Request -> Request)
-> Request
-> m (Response (Either HttpDecodeError a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
addAcceptHeader ByteString
"application/json"

-- | Make a request and decode the body using the given function
--
-- This be used to request other formats, e.g. CSV.
httpDecode
  :: MonadHttp m
  => (BSL.ByteString -> Either (NonEmpty String) a)
  -> Request
  -> m (Response (Either HttpDecodeError a))
httpDecode :: forall (m :: * -> *) a.
MonadHttp m =>
(ByteString -> Either (NonEmpty String) a)
-> Request -> m (Response (Either HttpDecodeError a))
httpDecode ByteString -> Either (NonEmpty String) a
decode Request
req = do
  Response ByteString
resp <- Request -> m (Response ByteString)
forall (m :: * -> *).
MonadHttp m =>
Request -> m (Response ByteString)
httpLbs Request
req
  let body :: ByteString
body = Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody Response ByteString
resp
  Response (Either HttpDecodeError a)
-> m (Response (Either HttpDecodeError a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response (Either HttpDecodeError a)
 -> m (Response (Either HttpDecodeError a)))
-> Response (Either HttpDecodeError a)
-> m (Response (Either HttpDecodeError a))
forall a b. (a -> b) -> a -> b
$ (NonEmpty String -> HttpDecodeError)
-> Either (NonEmpty String) a -> Either HttpDecodeError a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString -> NonEmpty String -> HttpDecodeError
HttpDecodeError ByteString
body) (Either (NonEmpty String) a -> Either HttpDecodeError a)
-> (ByteString -> Either (NonEmpty String) a)
-> ByteString
-> Either HttpDecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either (NonEmpty String) a
decode (ByteString -> Either HttpDecodeError a)
-> Response ByteString -> Response (Either HttpDecodeError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response ByteString
resp

-- | Request all pages of a paginated endpoint into some 'Monoid'
--
-- For example,
--
-- Interact with a paginated endpoint where each page is a JSON list, combining
-- all the pages into one list (i.e. 'concat') and throw on any decoding errors:
--
-- @
-- 'httpPaginated' 'httpJson' 'getResponseBodyUnsafe' $ 'parseRequest_' "https://..."
-- @
--
-- This uses 'sourcePaginated', and so reads a @Link@ header. To do otherwise,
-- drop down to 'sourcePaginatedBy' directly.
--
-- The second argument is used to extract the data to combine out of the
-- response. This is particularly useful for 'Either' values, like you may get
-- from 'httpJson'. It lives in @m@ to support functions such as
-- 'getResponseBodyUnsafe'.
--
-- Decoding errors can be handled differently by adjusting what 'Monoid' you
-- convert each page's response into:
--
-- @
-- 'httpPaginated' 'httpJson' fromResponseLenient $ 'parseRequest_' "https://..."
--
-- fromResponseLenient
--   :: MonadLogger m
--   => Response (Either e [MyJsonThing])
--   -> m [MyJsonThing]
-- fromResponseLenient r = case getResponseBody r of
--      Left _ -> [] <$ logWarn "..."
--      Right a -> pure a
-- @
--
-- See "Freckle.Http.App.Paginate" to process requested pages in a streaming
-- fashion, or perform pagination based on somethign other than @Link@.
httpPaginated
  :: (MonadHttp m, Monoid b)
  => (Request -> m (Response a))
  -> (Response a -> m b)
  -> Request
  -> m b
httpPaginated :: forall (m :: * -> *) b a.
(MonadHttp m, Monoid b) =>
(Request -> m (Response a))
-> (Response a -> m b) -> Request -> m b
httpPaginated Request -> m (Response a)
runRequest Response a -> m b
getBody Request
req =
  ConduitT () Void m b -> m b
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m b -> m b) -> ConduitT () Void m b -> m b
forall a b. (a -> b) -> a -> b
$ (Request -> m (Response a))
-> Request -> ConduitT () (Response a) m ()
forall (m :: * -> *) body i.
Monad m =>
(Request -> m (Response body))
-> Request -> ConduitT i (Response body) m ()
sourcePaginated Request -> m (Response a)
runRequest Request
req ConduitT () (Response a) m ()
-> ConduitT (Response a) Void m b -> ConduitT () Void m b
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (Response a -> m b) -> ConduitT (Response a) b m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC Response a -> m b
getBody ConduitT (Response a) b m ()
-> ConduitT b Void m b -> ConduitT (Response a) Void m b
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT b Void m b
forall (m :: * -> *) a o. (Monad m, Monoid a) => ConduitT a o m a
foldC

addAcceptHeader :: ByteString -> Request -> Request
addAcceptHeader :: ByteString -> Request -> Request
addAcceptHeader = HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hAccept

addBearerAuthorizationHeader :: ByteString -> Request -> Request
addBearerAuthorizationHeader :: ByteString -> Request -> Request
addBearerAuthorizationHeader = HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hAuthorization (ByteString -> Request -> Request)
-> (ByteString -> ByteString) -> ByteString -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
"Bearer " <>)

setRequestMethod :: StdMethod -> Request -> Request
setRequestMethod :: StdMethod -> Request -> Request
setRequestMethod StdMethod
method Request
req = Request
req {HTTP.method = renderStdMethod method}

disableRequestDecompress :: Request -> Request
disableRequestDecompress :: Request -> Request
disableRequestDecompress Request
req =
  Request
req
    { HTTP.decompress = const False
    }

-- | Read an 'Either' response body, throwing any 'Left' as an exception
--
-- If you plan to use this function, and haven't built your decoding to handle
-- error response bodies too, you'll want to use 'setRequestCheckStatus' so that
-- you see status-code exceptions before 'HttpDecodeError's.
getResponseBodyUnsafe
  :: (MonadIO m, Exception e, HasCallStack)
  => Response (Either e a)
  -> m a
getResponseBodyUnsafe :: forall (m :: * -> *) e a.
(MonadIO m, Exception e, HasCallStack) =>
Response (Either e a) -> m a
getResponseBodyUnsafe = (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m a
forall e (m :: * -> *) a.
(MonadIO m, Exception e, HasCallStack) =>
e -> m a
throwWithCallStack a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m a)
-> (Response (Either e a) -> Either e a)
-> Response (Either e a)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response (Either e a) -> Either e a
forall a. Response a -> a
getResponseBody

httpExceptionIsInformational :: HttpException -> Bool
httpExceptionIsInformational :: HttpException -> Bool
httpExceptionIsInformational = (Status -> Bool) -> HttpException -> Bool
filterStatusException Status -> Bool
statusIsInformational

httpExceptionIsRedirection :: HttpException -> Bool
httpExceptionIsRedirection :: HttpException -> Bool
httpExceptionIsRedirection = (Status -> Bool) -> HttpException -> Bool
filterStatusException Status -> Bool
statusIsRedirection

httpExceptionIsClientError :: HttpException -> Bool
httpExceptionIsClientError :: HttpException -> Bool
httpExceptionIsClientError = (Status -> Bool) -> HttpException -> Bool
filterStatusException Status -> Bool
statusIsClientError

httpExceptionIsServerError :: HttpException -> Bool
httpExceptionIsServerError :: HttpException -> Bool
httpExceptionIsServerError = (Status -> Bool) -> HttpException -> Bool
filterStatusException Status -> Bool
statusIsServerError

filterStatusException :: (Status -> Bool) -> HttpException -> Bool
filterStatusException :: (Status -> Bool) -> HttpException -> Bool
filterStatusException Status -> Bool
predicate = \case
  HttpExceptionRequest Request
_ (StatusCodeException Response ()
resp ByteString
_) ->
    Status -> Bool
predicate (Status -> Bool) -> Status -> Bool
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall a. Response a -> Status
getResponseStatus Response ()
resp
  HttpException
_ -> Bool
False