{-# options_haddock prune #-}

-- |Description: Http Interpreters, Internal
module Polysemy.Http.Interpreter.Native where

import qualified Data.CaseInsensitive as CaseInsensitive
import Data.CaseInsensitive (foldedCase)
import Exon (exon)
import qualified Log as Log
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client (BodyReader, brRead, brReadSome, httpLbs, responseClose, responseOpen)
import Network.HTTP.Client.Internal (CookieJar (CJ))
import Polysemy.Internal.Tactics (liftT)

import Polysemy.Http.Data.Header (Header (Header), unHeaderName, unHeaderValue)
import qualified Polysemy.Http.Data.HttpError as HttpError
import Polysemy.Http.Data.HttpError (HttpError)
import Polysemy.Http.Data.Request (
  Body (Body),
  Host (Host),
  Path (Path),
  Request (Request),
  Tls (Tls),
  methodUpper,
  unPort,
  unQueryKey,
  unQueryValue,
  )
import Polysemy.Http.Data.Response (Response (Response))
import qualified Polysemy.Http.Effect.Http as Http
import Polysemy.Http.Effect.Http (Http)
import qualified Polysemy.Http.Effect.Manager as Manager
import Polysemy.Http.Effect.Manager (Manager)
import Polysemy.Http.Interpreter.Manager (interpretManager)

-- |Converts a 'Request' to a native 'N.Request'.
nativeRequest :: Request -> HTTP.Request
nativeRequest :: Request -> Request
nativeRequest (Request Method
method (Host Text
host) Maybe Port
portOverride (Tls Bool
tls) (Path Text
path) [(HeaderName, HeaderValue)]
headers (CJ [Cookie]
cookies) [(QueryKey, Maybe QueryValue)]
query (Body ByteString
body)) =
  [(ByteString, Maybe ByteString)] -> Request -> Request
HTTP.setQueryString [(ByteString, Maybe ByteString)]
queryParams Request
HTTP.defaultRequest {
    host :: ByteString
HTTP.host = forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
host,
    port :: Int
HTTP.port = Int
port,
    secure :: Bool
HTTP.secure = Bool
tls,
    method :: ByteString
HTTP.method = forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Method -> Text
methodUpper Method
method),
    requestHeaders :: RequestHeaders
HTTP.requestHeaders = RequestHeaders
encodedHeaders,
    path :: ByteString
HTTP.path = forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
path,
    requestBody :: RequestBody
HTTP.requestBody = ByteString -> RequestBody
HTTP.RequestBodyBS ByteString
body,
    cookieJar :: Maybe CookieJar
HTTP.cookieJar = [Cookie] -> CookieJar
CJ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Cookie]
cookies
  }
  where
    queryParams :: [(ByteString, Maybe ByteString)]
queryParams =
      forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.unQueryKey)) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.unQueryValue))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(QueryKey, Maybe QueryValue)]
query
    port :: Int
port =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if Bool
tls then Int
443 else Int
80) (.unPort) Maybe Port
portOverride
    encodedHeaders :: RequestHeaders
encodedHeaders =
      forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall s. FoldCase s => s -> CI s
CaseInsensitive.mk forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.unHeaderName)) (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.unHeaderValue)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(HeaderName, HeaderValue)]
headers

convertResponse :: HTTP.Response b -> Response b
convertResponse :: forall b. Response b -> Response b
convertResponse Response b
response =
  forall b. Status -> b -> [Header] -> CookieJar -> Response b
Response (forall body. Response body -> Status
HTTP.responseStatus Response b
response) (forall body. Response body -> body
HTTP.responseBody Response b
response) [Header]
headers (forall body. Response body -> CookieJar
HTTP.responseCookieJar Response b
response)
  where
    headers :: [Header]
headers =
      forall {b} {b}.
(ConvertUtf8 String b, ConvertUtf8 String b) =>
(CI b, b) -> Header
header forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall body. Response body -> RequestHeaders
HTTP.responseHeaders Response b
response
    header :: (CI b, b) -> Header
header (forall s. CI s -> s
foldedCase -> forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 -> String
name, forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 -> String
value) =
      HeaderName -> HeaderValue -> Header
Header (forall a. IsString a => String -> a
fromString String
name) (forall a. IsString a => String -> a
fromString String
value)

internalError ::
  Member (Embed IO) r =>
  IO a ->
  Sem r (Either HttpError a)
internalError :: forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either HttpError a)
internalError =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> HttpError
HttpError.Internal) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny

executeRequest ::
  Member (Embed IO) r =>
  HTTP.Manager ->
  Request ->
  Sem r (Either HttpError (Response LByteString))
executeRequest :: forall (r :: EffectRow).
Member (Embed IO) r =>
Manager
-> Request -> Sem r (Either HttpError (Response ByteString))
executeRequest Manager
manager Request
request =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b. Response b -> Response b
convertResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either HttpError a)
internalError (Request -> Manager -> IO (Response ByteString)
httpLbs (Request -> Request
nativeRequest Request
request) Manager
manager)

withResponse ::
  Members [Embed IO, Log, Resource, Manager] r =>
  Request ->
  (Response BodyReader -> Sem r a) ->
  Sem r (Either HttpError a)
withResponse :: forall (r :: EffectRow) a.
Members '[Embed IO, Log, Resource, Manager] r =>
Request
-> (Response BodyReader -> Sem r a) -> Sem r (Either HttpError a)
withResponse Request
request Response BodyReader -> Sem r a
f =
  forall (r :: EffectRow) a c b.
Member Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket Sem r (Either HttpError (Response BodyReader))
acquire forall {r :: EffectRow} {a} {a}.
(Member (Embed IO) r, Member Log r) =>
Either a (Response a) -> Sem r ()
release Either HttpError (Response BodyReader)
-> Sem r (Either HttpError a)
use
  where
    acquire :: Sem r (Either HttpError (Response BodyReader))
acquire = do
      Manager
manager <- forall (r :: EffectRow). Member Manager r => Sem r Manager
Manager.get
      forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either HttpError a)
internalError (Request -> Manager -> IO (Response BodyReader)
responseOpen (Request -> Request
nativeRequest Request
request) Manager
manager)
    release :: Either a (Response a) -> Sem r ()
release (Right Response a
response) =
      forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny (forall a. Response a -> IO ()
responseClose Response a
response) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {r :: EffectRow}. Member Log r => Text -> Sem r ()
closeFailed forall (f :: * -> *) a. Applicative f => a -> f a
pure
    release (Left a
_) =
      forall (f :: * -> *). Applicative f => f ()
unit
    use :: Either HttpError (Response BodyReader)
-> Sem r (Either HttpError a)
use (Right Response BodyReader
response) = do
      forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response BodyReader -> Sem r a
f (forall b. Response b -> Response b
convertResponse Response BodyReader
response)
    use (Left HttpError
err) =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left HttpError
err)
    closeFailed :: Text -> Sem r ()
closeFailed Text
err =
      forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.error [exon|closing response failed: #{err}|]
{-# inline withResponse #-}

distribEither ::
  Functor f =>
  Either err (f a) ->
  Sem (WithTactics e f m r) (f (Either err a))
distribEither :: forall (f :: * -> *) err a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
Either err (f a) -> Sem (WithTactics e f m r) (f (Either err a))
distribEither = \case
  Right f a
fa ->
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
fa)
  Left err
err -> do
    f ()
s <- forall (f :: * -> *) (m :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *).
Sem (WithTactics e f m r) (f ())
getInitialStateT
    pure (forall a b. a -> Either a b
Left err
err forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
{-# inline distribEither #-}

readChunk :: Int -> BodyReader -> IO ByteString
readChunk :: Int -> BodyReader -> BodyReader
readChunk Int
chunkSize BodyReader
body =
  forall l s. LazyStrict l s => l -> s
toStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BodyReader -> Int -> IO ByteString
brReadSome BodyReader
body Int
chunkSize

-- |Same as 'interpretHttpNative', but the interpretation of 'Manager' is left to the user.
interpretHttpNativeWith ::
  Members [Embed IO, Log, Resource, Manager] r =>
  InterpreterFor (Http BodyReader) r
interpretHttpNativeWith :: forall (r :: EffectRow).
Members '[Embed IO, Log, Resource, Manager] r =>
InterpreterFor (Http BodyReader) r
interpretHttpNativeWith =
  forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Http.Response Request
request Response BodyReader -> Sem rInitial a1
f -> do
      forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|http request: #{show request}|]
      forall (f :: * -> *) err a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
Either err (f a) -> Sem (WithTactics e f m r) (f (Either err a))
distribEither forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (r :: EffectRow) a.
Members '[Embed IO, Log, Resource, Manager] r =>
Request
-> (Response BodyReader -> Sem r a) -> Sem r (Either HttpError a)
withResponse Request
request ((\ Sem rInitial a1
x -> forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (r :: EffectRow).
m a -> Tactical e m r a
runTSimple Sem rInitial a1
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response BodyReader -> Sem rInitial a1
f)
    Http.Request Request
request -> do
      forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|http request: #{show request}|]
      Manager
manager <- forall (r :: EffectRow). Member Manager r => Sem r Manager
Manager.get
      forall (m :: * -> *) (f :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT do
        Either HttpError (Response ByteString)
response <- forall (r :: EffectRow).
Member (Embed IO) r =>
Manager
-> Request -> Sem r (Either HttpError (Response ByteString))
executeRequest Manager
manager Request
request
        Either HttpError (Response ByteString)
response forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [exon|http response: #{show response}|]
    Http.ConsumeChunk Maybe Int
chunkSize BodyReader
body ->
      forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: EffectRow).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> HttpError
HttpError.ChunkFailed forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (r :: EffectRow) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny (forall b a. b -> (a -> b) -> Maybe a -> b
maybe BodyReader -> BodyReader
brRead Int -> BodyReader -> BodyReader
readChunk Maybe Int
chunkSize BodyReader
body)
{-# inline interpretHttpNativeWith #-}

-- |Interpret @'Http' 'BodyReader'@ using the native "Network.HTTP.Client" implementation.
-- 'BodyReader' is an alias for @'IO' 'ByteString'@; it is how http-client represents chunks.
-- This uses the default interpreter for 'Manager'.
interpretHttpNative ::
  Members [Embed IO, Log, Resource] r =>
  InterpreterFor (Http BodyReader) r
interpretHttpNative :: forall (r :: EffectRow).
Members '[Embed IO, Log, Resource] r =>
InterpreterFor (Http BodyReader) r
interpretHttpNative =
  forall (r :: EffectRow).
Member (Embed IO) r =>
InterpreterFor Manager r
interpretManager forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: EffectRow).
Members '[Embed IO, Log, Resource, Manager] r =>
InterpreterFor (Http BodyReader) r
interpretHttpNativeWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# inline interpretHttpNative #-}