{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Effectful.HTTP.Client.Internal
  ( -- * Exceptions,
    NetworkStatusE (..),
    NetworkReadBodyE (..),
    NetworkDecodeUtf8E (..),
    NetworkDecodeJsonE (..),

    -- * Readers
    readResponse,

    -- ** Decoders
    decodeJson,
    decodeUtf8,

    -- * Misc
    getStatusCode,
    mapThrowLeft,
  )
where

import Control.Exception (Exception, SomeException, displayException)
import Control.Exception.Utils (throwM, trySync)
import Control.Monad (when)
import Data.Aeson (FromJSON)
import Data.Aeson qualified as Asn
import Data.Bifunctor (Bifunctor (first))
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text.Encoding qualified as TEnc
import Data.Text.Encoding.Error (UnicodeException)
import Effectful (Eff)
import Effectful.Dispatch.Static (HasCallStack)
import Network.HTTP.Client (Response)
import Network.HTTP.Client qualified as HttpClient
import Network.HTTP.Types.Status (Status)
import Network.HTTP.Types.Status qualified as Status

-- | Helper for reading a response, checking for status 200 and exceptions
-- thrown by the consumer.
--
-- @since 0.1
readResponse ::
  (HasCallStack) =>
  -- | String url.
  String ->
  -- | Response.
  Response br ->
  -- | Consumer.
  (br -> Eff es a) ->
  Eff es a
readResponse :: forall br (es :: [Effect]) a.
HasCallStack =>
String -> Response br -> (br -> Eff es a) -> Eff es a
readResponse String
url Response br
res br -> Eff es a
consumer = do
  let bodyReader :: br
bodyReader = Response br -> br
forall body. Response body -> body
HttpClient.responseBody Response br
res
      status :: Status
status = Response br -> Status
forall body. Response body -> Status
HttpClient.responseStatus Response br
res
      statusCode :: Int
statusCode = Response br -> Int
forall body. Response body -> Int
getStatusCode Response br
res

  Bool -> Eff es () -> Eff es ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
statusCode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
200) (Eff es () -> Eff es ()) -> Eff es () -> Eff es ()
forall a b. (a -> b) -> a -> b
$
    NetworkStatusE -> Eff es ()
forall e a. (HasCallStack, Exception e) => e -> Eff es a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (NetworkStatusE -> Eff es ()) -> NetworkStatusE -> Eff es ()
forall a b. (a -> b) -> a -> b
$
      String -> Status -> NetworkStatusE
MkNetworkStatusE String
url Status
status

  (SomeException -> NetworkReadBodyE)
-> Either SomeException a -> Eff es a
forall e2 e1 a (es :: [Effect]).
(Exception e2, HasCallStack) =>
(e1 -> e2) -> Either e1 a -> Eff es a
mapThrowLeft
    (String -> SomeException -> NetworkReadBodyE
MkNetworkReadBodyE String
url)
    (Either SomeException a -> Eff es a)
-> Eff es (Either SomeException a) -> Eff es a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Eff es a -> Eff es (Either SomeException a)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
trySync (br -> Eff es a
consumer br
bodyReader)

decodeJson ::
  ( FromJSON a,
    HasCallStack
  ) =>
  [ByteString] ->
  Eff es a
decodeJson :: forall a (es :: [Effect]).
(FromJSON a, HasCallStack) =>
[ByteString] -> Eff es a
decodeJson [ByteString]
bodyBs = do
  (String -> NetworkDecodeJsonE) -> Either String a -> Eff es a
forall e2 e1 a (es :: [Effect]).
(Exception e2, HasCallStack) =>
(e1 -> e2) -> Either e1 a -> Eff es a
mapThrowLeft
    (ByteString -> String -> NetworkDecodeJsonE
MkNetworkDecodeJsonE ByteString
bs)
    (ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Asn.eitherDecodeStrict ByteString
bs)
  where
    bs :: ByteString
bs = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
bodyBs

decodeUtf8 ::
  (HasCallStack) =>
  [ByteString] ->
  Eff es Text
decodeUtf8 :: forall (es :: [Effect]).
HasCallStack =>
[ByteString] -> Eff es Text
decodeUtf8 [ByteString]
bodyBs = do
  (UnicodeException -> NetworkDecodeUtf8E)
-> Either UnicodeException Text -> Eff es Text
forall e2 e1 a (es :: [Effect]).
(Exception e2, HasCallStack) =>
(e1 -> e2) -> Either e1 a -> Eff es a
mapThrowLeft
    (ByteString -> UnicodeException -> NetworkDecodeUtf8E
MkNetworkDecodeUtf8E ByteString
bs)
    (Either UnicodeException Text -> Eff es Text)
-> Either UnicodeException Text -> Eff es Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
TEnc.decodeUtf8' ByteString
bs
  where
    bs :: ByteString
bs = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
bodyBs

data NetworkStatusE = MkNetworkStatusE String Status
  deriving stock (Int -> NetworkStatusE -> ShowS
[NetworkStatusE] -> ShowS
NetworkStatusE -> String
(Int -> NetworkStatusE -> ShowS)
-> (NetworkStatusE -> String)
-> ([NetworkStatusE] -> ShowS)
-> Show NetworkStatusE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkStatusE -> ShowS
showsPrec :: Int -> NetworkStatusE -> ShowS
$cshow :: NetworkStatusE -> String
show :: NetworkStatusE -> String
$cshowList :: [NetworkStatusE] -> ShowS
showList :: [NetworkStatusE] -> ShowS
Show)

instance Exception NetworkStatusE where
  displayException :: NetworkStatusE -> String
displayException (MkNetworkStatusE String
url Status
status) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"Received ",
        Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Status -> Int
Status.statusCode Status
status,
        String
" for url '",
        String
url,
        String
"': ",
        Status -> String
statusMessage Status
status
      ]

data NetworkReadBodyE = MkNetworkReadBodyE String SomeException
  deriving stock (Int -> NetworkReadBodyE -> ShowS
[NetworkReadBodyE] -> ShowS
NetworkReadBodyE -> String
(Int -> NetworkReadBodyE -> ShowS)
-> (NetworkReadBodyE -> String)
-> ([NetworkReadBodyE] -> ShowS)
-> Show NetworkReadBodyE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkReadBodyE -> ShowS
showsPrec :: Int -> NetworkReadBodyE -> ShowS
$cshow :: NetworkReadBodyE -> String
show :: NetworkReadBodyE -> String
$cshowList :: [NetworkReadBodyE] -> ShowS
showList :: [NetworkReadBodyE] -> ShowS
Show)

instance Exception NetworkReadBodyE where
  displayException :: NetworkReadBodyE -> String
displayException (MkNetworkReadBodyE String
url SomeException
ex) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"Exception reading body for url '",
        String
url,
        String
"':\n\n",
        SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex
      ]

data NetworkDecodeUtf8E = MkNetworkDecodeUtf8E ByteString UnicodeException
  deriving stock (Int -> NetworkDecodeUtf8E -> ShowS
[NetworkDecodeUtf8E] -> ShowS
NetworkDecodeUtf8E -> String
(Int -> NetworkDecodeUtf8E -> ShowS)
-> (NetworkDecodeUtf8E -> String)
-> ([NetworkDecodeUtf8E] -> ShowS)
-> Show NetworkDecodeUtf8E
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkDecodeUtf8E -> ShowS
showsPrec :: Int -> NetworkDecodeUtf8E -> ShowS
$cshow :: NetworkDecodeUtf8E -> String
show :: NetworkDecodeUtf8E -> String
$cshowList :: [NetworkDecodeUtf8E] -> ShowS
showList :: [NetworkDecodeUtf8E] -> ShowS
Show)

instance Exception NetworkDecodeUtf8E where
  displayException :: NetworkDecodeUtf8E -> String
displayException (MkNetworkDecodeUtf8E ByteString
bs UnicodeException
err) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"Could not decode UTF-8: ",
        UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
err,
        String
". Bytes: ",
        ByteString -> String
forall a. Show a => a -> String
show ByteString
bs
      ]

data NetworkDecodeJsonE = MkNetworkDecodeJsonE ByteString String
  deriving stock (Int -> NetworkDecodeJsonE -> ShowS
[NetworkDecodeJsonE] -> ShowS
NetworkDecodeJsonE -> String
(Int -> NetworkDecodeJsonE -> ShowS)
-> (NetworkDecodeJsonE -> String)
-> ([NetworkDecodeJsonE] -> ShowS)
-> Show NetworkDecodeJsonE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkDecodeJsonE -> ShowS
showsPrec :: Int -> NetworkDecodeJsonE -> ShowS
$cshow :: NetworkDecodeJsonE -> String
show :: NetworkDecodeJsonE -> String
$cshowList :: [NetworkDecodeJsonE] -> ShowS
showList :: [NetworkDecodeJsonE] -> ShowS
Show)

instance Exception NetworkDecodeJsonE where
  displayException :: NetworkDecodeJsonE -> String
displayException (MkNetworkDecodeJsonE ByteString
jsonBs String
err) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"Could not decode JSON: ",
        String
err,
        String
". Bytes: ",
        ByteString -> String
forall a. Show a => a -> String
show ByteString
jsonBs
      ]

statusMessage :: Status -> String
statusMessage :: Status -> String
statusMessage Status
s =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
"Status message: ",
      ByteString -> String
forall a. Show a => a -> String
show (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Status -> ByteString
Status.statusMessage Status
s
    ]

getStatusCode :: Response body -> Int
getStatusCode :: forall body. Response body -> Int
getStatusCode = Status -> Int
Status.statusCode (Status -> Int)
-> (Response body -> Status) -> Response body -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response body -> Status
forall body. Response body -> Status
HttpClient.responseStatus

mapThrowLeft :: (Exception e2, HasCallStack) => (e1 -> e2) -> Either e1 a -> Eff es a
mapThrowLeft :: forall e2 e1 a (es :: [Effect]).
(Exception e2, HasCallStack) =>
(e1 -> e2) -> Either e1 a -> Eff es a
mapThrowLeft e1 -> e2
f = Either e2 a -> Eff es a
forall e a (es :: [Effect]).
(Exception e, HasCallStack) =>
Either e a -> Eff es a
throwLeft (Either e2 a -> Eff es a)
-> (Either e1 a -> Either e2 a) -> Either e1 a -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e1 -> e2) -> Either e1 a -> Either e2 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 e1 -> e2
f

throwLeft :: (Exception e, HasCallStack) => Either e a -> Eff es a
throwLeft :: forall e a (es :: [Effect]).
(Exception e, HasCallStack) =>
Either e a -> Eff es a
throwLeft (Right a
x) = a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
throwLeft (Left e
e) = e -> Eff es a
forall e a. (HasCallStack, Exception e) => e -> Eff es a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM e
e