-- | Centralized module for making HTTP requests from the backend
--
-- These functions:
--
-- - Do not throw exceptions on non-200
-- - May throw for other 'HttpException' cases (e.g. 'ConnectionTimeout')
-- - Handle 429-@Retry-In@ for you
-- - Capture decoding failures with 'Either' values as the 'Response' body
--
-- == Examples
--
-- Make request, retry on 429s, 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
-- @
--
-- 'httpLbs' can be used to get a raw response (without risk of decoding
-- errors), and 'httpDecode' can be used to supply your own decoding function
-- (e.g. for CSV).
--
-- Interact with a paginated endpoint that uses @Link@, combining all the pages
-- monoidally (e.g. concat) and throwing on any decoding errors.
--
-- @
-- 'httpPaginated' 'httpJson' 'getResponseBodyUnsafe' $ 'parseRequest_' "https://..."
-- @
--
-- 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@.
--
module Freckle.App.Http
  ( httpJson
  , HttpDecodeError(..)
  , httpDecode
  , httpLbs
  , httpNoBody
  , httpPaginated
  , sourcePaginated

  -- * Request builders
  , Request
  , parseRequest
  , parseRequest_

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

  -- * 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:
  --
  -- @
  -- 'handleJust' (guarded '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
  ) where

import Freckle.App.Prelude

import Conduit (foldC, mapMC, runConduit, (.|))
import Data.Aeson (FromJSON)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.List.NonEmpty as NE
import Freckle.App.Http.Paginate
import Freckle.App.Http.Retry
import Network.HTTP.Conduit (HttpExceptionContent(..))
import Network.HTTP.Simple hiding (httpLbs, httpNoBody)
import qualified Network.HTTP.Simple as HTTP
import Network.HTTP.Types.Header (hAccept, hAuthorization)
import Network.HTTP.Types.Status
  ( Status
  , statusCode
  , statusIsClientError
  , statusIsInformational
  , statusIsRedirection
  , statusIsServerError
  , statusIsSuccessful
  )
import UnliftIO.Exception (Exception(..), throwIO)

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

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

-- | Request and decode a response as JSON
httpJson
  :: (MonadIO m, FromJSON a)
  => Request
  -> m (Response (Either HttpDecodeError a))
httpJson :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Request -> m (Response (Either HttpDecodeError a))
httpJson = forall (m :: * -> *) a.
MonadIO m =>
(ByteString -> Either (NonEmpty String) a)
-> Request -> m (Response (Either HttpDecodeError a))
httpDecode (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Request -> Request
addAcceptHeader ByteString
"application/json"

-- | Request and decode a response
httpDecode
  :: MonadIO m
  => (ByteString -> Either (NonEmpty String) a)
  -> Request
  -> m (Response (Either HttpDecodeError a))
httpDecode :: forall (m :: * -> *) a.
MonadIO 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 <- forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLbs Request
req
  let body :: ByteString
body = forall a. Response a -> a
getResponseBody Response ByteString
resp
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString -> NonEmpty String -> HttpDecodeError
HttpDecodeError ByteString
body) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either (NonEmpty String) a
decode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response ByteString
resp

-- | Request a lazy 'ByteString', handling 429 retries
httpLbs :: MonadIO m => Request -> m (Response ByteString)
httpLbs :: forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLbs = forall (m :: * -> *) body.
MonadIO m =>
(Request -> m (Response body)) -> Request -> m (Response body)
rateLimited forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS

-- | Make a Request ignoring the response, but handling 429 retries
httpNoBody :: MonadIO m => Request -> m (Response ())
httpNoBody :: forall (m :: * -> *). MonadIO m => Request -> m (Response ())
httpNoBody = forall (m :: * -> *) body.
MonadIO m =>
(Request -> m (Response body)) -> Request -> m (Response body)
rateLimited forall (m :: * -> *). MonadIO m => Request -> m (Response ())
HTTP.httpNoBody

-- | Request all pages of a paginated endpoint into a big list
--
-- 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'.
--
httpPaginated
  :: (MonadIO m, Monoid b)
  => (Request -> m (Response a))
  -> (Response a -> m b)
  -> Request
  -> m b
httpPaginated :: forall (m :: * -> *) b a.
(MonadIO 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 =
  forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) body i.
MonadIO m =>
(Request -> m (Response body))
-> Request -> ConduitT i (Response body) m ()
sourcePaginated Request -> m (Response a)
runRequest Request
req forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC Response a -> m b
getBody forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a o. (Monad m, Monoid a) => ConduitT a o m a
foldC

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

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

-- | 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) => Response (Either e a) -> m a
getResponseBodyUnsafe :: forall (m :: * -> *) e a.
(MonadIO m, Exception e) =>
Response (Either e a) -> m a
getResponseBodyUnsafe = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ forall a. Response a -> Status
getResponseStatus Response ()
resp
  HttpException
_ -> Bool
False