module Polysemy.Http.Native where

import qualified Data.CaseInsensitive as CaseInsensitive
import Data.CaseInsensitive (foldedCase)
import Network.HTTP.Client (BodyReader, httpLbs, responseClose, responseOpen)
import qualified Network.HTTP.Client as HTTP (Manager)
import Network.HTTP.Simple (
  defaultRequest,
  getResponseBody,
  getResponseHeaders,
  getResponseStatus,
  setRequestBodyLBS,
  setRequestHeaders,
  setRequestHost,
  setRequestMethod,
  setRequestPath,
  setRequestPort,
  setRequestQueryString,
  setRequestSecure,
  )
import qualified Network.HTTP.Simple as N (Request, Response)
import Polysemy (Tactical, interpretH, runT)
import qualified Polysemy.Http.Data.Log as Log
import Polysemy.Http.Data.Log (Log)
import Polysemy.Resource (Resource, bracket)

import Polysemy.Http.Data.Header (Header(Header), unHeaderName, unHeaderValue)
import qualified Polysemy.Http.Data.Http as Http
import Polysemy.Http.Data.Http (Http)
import qualified Polysemy.Http.Data.HttpError as HttpError
import Polysemy.Http.Data.HttpError (HttpError)
import qualified Polysemy.Http.Data.Manager as Manager
import Polysemy.Http.Data.Manager (Manager)
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 Polysemy.Http.Manager (interpretManager)

-- |Converts a 'Request' to a native 'N.Request'.
nativeRequest :: Request -> N.Request
nativeRequest :: Request -> Request
nativeRequest (Request Method
method (Host Text
host) Maybe Port
portOverride (Tls Bool
tls) (Path Text
path) [(HeaderName, HeaderValue)]
headers [(QueryKey, Maybe QueryValue)]
query (Body LByteString
body)) =
  Request -> Request
cons Request
defaultRequest
  where
    cons :: Request -> Request
cons =
      Request -> Request
scheme (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ByteString -> Request -> Request
setRequestMethod (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Method -> Text
methodUpper Method
method) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      RequestHeaders -> Request -> Request
setRequestHeaders RequestHeaders
encodedHeaders (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ByteString -> Request -> Request
setRequestHost (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
host) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> Request -> Request
setRequestPort Int
port (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ByteString -> Request -> Request
setRequestPath (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
path) (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Query -> Request -> Request
setRequestQueryString Query
queryParam (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      LByteString -> Request -> Request
setRequestBodyLBS LByteString
body
    queryParam :: Query
queryParam =
      (QueryKey -> ByteString)
-> (Maybe QueryValue -> Maybe ByteString)
-> (QueryKey, Maybe QueryValue)
-> (ByteString, Maybe ByteString)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString)
-> (QueryKey -> Text) -> QueryKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryKey -> Text
unQueryKey) ((QueryValue -> ByteString) -> Maybe QueryValue -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString)
-> (QueryValue -> Text) -> QueryValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryValue -> Text
unQueryValue)) ((QueryKey, Maybe QueryValue) -> (ByteString, Maybe ByteString))
-> [(QueryKey, Maybe QueryValue)] -> Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(QueryKey, Maybe QueryValue)]
query
    scheme :: Request -> Request
scheme =
      if Bool
tls then Bool -> Request -> Request
setRequestSecure Bool
True else Request -> Request
forall a. a -> a
id
    port :: Int
port =
      Int -> (Port -> Int) -> Maybe Port -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (if Bool
tls then Int
443 else Int
80) Port -> Int
unPort Maybe Port
portOverride
    encodedHeaders :: RequestHeaders
encodedHeaders =
      (HeaderName -> CI ByteString)
-> (HeaderValue -> ByteString)
-> (HeaderName, HeaderValue)
-> (CI ByteString, ByteString)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CaseInsensitive.mk (ByteString -> CI ByteString)
-> (HeaderName -> ByteString) -> HeaderName -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString)
-> (HeaderName -> Text) -> HeaderName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> Text
unHeaderName) (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Text -> ByteString)
-> (HeaderValue -> Text) -> HeaderValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderValue -> Text
unHeaderValue) ((HeaderName, HeaderValue) -> (CI ByteString, ByteString))
-> [(HeaderName, HeaderValue)] -> RequestHeaders
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(HeaderName, HeaderValue)]
headers

convertResponse :: N.Response b -> Response b
convertResponse :: Response b -> Response b
convertResponse Response b
response =
  Status -> b -> [Header] -> Response b
forall b. Status -> b -> [Header] -> Response b
Response (Response b -> Status
forall a. Response a -> Status
getResponseStatus Response b
response) (Response b -> b
forall a. Response a -> a
getResponseBody Response b
response) [Header]
headers
  where
    headers :: [Header]
headers =
      (CI ByteString, ByteString) -> Header
forall b b.
(ConvertUtf8 String b, ConvertUtf8 String b) =>
(CI b, b) -> Header
header ((CI ByteString, ByteString) -> Header)
-> RequestHeaders -> [Header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response b -> RequestHeaders
forall a. Response a -> RequestHeaders
getResponseHeaders Response b
response
    header :: (CI b, b) -> Header
header (CI b -> b
forall s. CI s -> s
foldedCase -> b -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 -> String
name, b -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 -> String
value) =
      HeaderName -> HeaderValue -> Header
Header (String -> HeaderName
forall a. IsString a => String -> a
fromString String
name) (String -> HeaderValue
forall a. IsString a => String -> a
fromString String
value)

internalError ::
  Member (Embed IO) r =>
  IO a ->
  Sem r (Either HttpError a)
internalError :: IO a -> Sem r (Either HttpError a)
internalError =
  (Text -> HttpError) -> IO a -> Sem r (Either HttpError a)
forall (r :: [(* -> *) -> * -> *]) e a.
Member (Embed IO) r =>
(Text -> e) -> IO a -> Sem r (Either e a)
tryHoist Text -> HttpError
HttpError.Internal

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

-- |Default handler for 'Http.Stream'.
-- Uses 'bracket' to acquire and close the connection, calling 'StreamEvent.Acquire' and 'StreamEvent.Release' in the
-- corresponding phases.
httpStream ::
  Members [Embed IO, Log, Resource, Manager] r =>
  Request ->
  (Response BodyReader -> m (Either HttpError a)) ->
  Tactical (Http BodyReader) m r (Either HttpError a)
httpStream :: Request
-> (Response BodyReader -> m (Either HttpError a))
-> Tactical (Http BodyReader) m r (Either HttpError a)
httpStream Request
request Response BodyReader -> m (Either HttpError a)
handler =
  Sem
  (Tactics f m (Http BodyReader : r) : r)
  (Either HttpError (Response BodyReader))
-> (Either HttpError (Response BodyReader)
    -> Sem (Tactics f m (Http BodyReader : r) : r) ())
-> (Either HttpError (Response BodyReader)
    -> Sem
         (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a)))
-> Sem
     (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a))
forall (r :: [(* -> *) -> * -> *]) a c b.
MemberWithError Resource r =>
Sem r a -> (a -> Sem r c) -> (a -> Sem r b) -> Sem r b
bracket Sem
  (Tactics f m (Http BodyReader : r) : r)
  (Either HttpError (Response BodyReader))
acquire Either HttpError (Response BodyReader)
-> Sem (Tactics f m (Http BodyReader : r) : r) ()
forall (r :: [(* -> *) -> * -> *]) a a.
(Find (Embed IO) r, Find Log r, LocateEffect Log r ~ '(),
 LocateEffect (Embed IO) r ~ '()) =>
Either a (Response a) -> Sem r ()
release Either HttpError (Response BodyReader)
-> Sem
     (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a))
use
  where
    acquire :: Sem
  (Tactics f m (Http BodyReader : r) : r)
  (Either HttpError (Response BodyReader))
acquire = do
      Manager
manager <- Sem (Tactics f m (Http BodyReader : r) : r) Manager
forall (r :: [(* -> *) -> * -> *]).
MemberWithError Manager r =>
Sem r Manager
Manager.get
      IO (Response BodyReader)
-> Sem
     (Tactics f m (Http BodyReader : r) : r)
     (Either HttpError (Response BodyReader))
forall (r :: [(* -> *) -> * -> *]) 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) =
      IO () -> Sem r (Either Text ())
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny (Response a -> IO ()
forall a. Response a -> IO ()
responseClose Response a
response) Sem r (Either Text ()) -> (Either Text () -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> Sem r ()) -> Either Text () -> Sem r ()
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
traverseLeft Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]) src.
(Find Log r, Interpolatable 'True src Text,
 LocateEffect Log r ~ '()) =>
src -> Sem r ()
closeFailed
    release (Left a
_) =
      Sem r ()
forall (f :: * -> *). Applicative f => f ()
unit
    use :: Either HttpError (Response BodyReader)
-> Sem
     (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a))
use (Right Response BodyReader
response) = do
      Sem r (f (Either HttpError a))
-> Sem
     (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a))
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r (f (Either HttpError a))
 -> Sem
      (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a)))
-> (Sem (Http BodyReader : r) (f (Either HttpError a))
    -> Sem r (f (Either HttpError a)))
-> Sem (Http BodyReader : r) (f (Either HttpError a))
-> Sem
     (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Http BodyReader : r) (f (Either HttpError a))
-> Sem r (f (Either HttpError a))
forall (r :: [(* -> *) -> * -> *]).
Members '[Embed IO, Log, Resource, Manager] r =>
InterpreterFor (Http BodyReader) r
interpretHttpNativeWith (Sem (Http BodyReader : r) (f (Either HttpError a))
 -> Sem
      (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a)))
-> Sem
     (Tactics f m (Http BodyReader : r) : r)
     (Sem (Http BodyReader : r) (f (Either HttpError a)))
-> Sem
     (Tactics f m (Http BodyReader : r) : r) (f (Either HttpError a))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either HttpError a)
-> Sem
     (Tactics f m (Http BodyReader : r) : r)
     (Sem (Http BodyReader : r) (f (Either HttpError a)))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT (Response BodyReader -> m (Either HttpError a)
handler (Response BodyReader -> Response BodyReader
forall b. Response b -> Response b
convertResponse Response BodyReader
response))
    use (Left HttpError
err) =
      Either HttpError a
-> Tactical (Http BodyReader) m r (Either HttpError a)
forall a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
a -> Tactical e m r a
pureT (HttpError -> Either HttpError a
forall a b. a -> Either a b
Left HttpError
err)
    closeFailed :: src -> Sem r ()
closeFailed src
err =
      Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.error [qt|closing response failed: #{err}|]
{-# INLINE httpStream #-}

-- |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 :: InterpreterFor (Http BodyReader) r
interpretHttpNativeWith =
  (forall x (rInitial :: [(* -> *) -> * -> *]).
 Http BodyReader (Sem rInitial) x
 -> Tactical (Http BodyReader) (Sem rInitial) r x)
-> Sem (Http BodyReader : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH ((forall x (rInitial :: [(* -> *) -> * -> *]).
  Http BodyReader (Sem rInitial) x
  -> Tactical (Http BodyReader) (Sem rInitial) r x)
 -> Sem (Http BodyReader : r) a -> Sem r a)
-> (forall x (rInitial :: [(* -> *) -> * -> *]).
    Http BodyReader (Sem rInitial) x
    -> Tactical (Http BodyReader) (Sem rInitial) r x)
-> Sem (Http BodyReader : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
    Http.Request request -> do
      Text -> Sem (WithTactics (Http BodyReader) f (Sem rInitial) r) ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug (Text -> Sem (WithTactics (Http BodyReader) f (Sem rInitial) r) ())
-> Text
-> Sem (WithTactics (Http BodyReader) f (Sem rInitial) r) ()
forall a b. (a -> b) -> a -> b
$ [qt|http request: #{request}|]
      Manager
manager <- Sem (WithTactics (Http BodyReader) f (Sem rInitial) r) Manager
forall (r :: [(* -> *) -> * -> *]).
MemberWithError Manager r =>
Sem r Manager
Manager.get
      Sem r (Either HttpError (Response LByteString))
-> Sem
     (WithTactics (Http BodyReader) f (Sem rInitial) r)
     (f (Either HttpError (Response LByteString)))
forall (m :: * -> *) (f :: * -> *) (r :: [(* -> *) -> * -> *])
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT do
        Either HttpError (Response LByteString)
response <- Manager
-> Request -> Sem r (Either HttpError (Response LByteString))
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Manager
-> Request -> Sem r (Either HttpError (Response LByteString))
executeRequest Manager
manager Request
request
        Either HttpError (Response LByteString)
response Either HttpError (Response LByteString)
-> Sem r () -> Sem r (Either HttpError (Response LByteString))
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.debug [qt|http response: #{response}|]
    Http.Stream request handler ->
      Request
-> (Response BodyReader -> Sem rInitial (Either HttpError a))
-> Tactical (Http BodyReader) (Sem rInitial) r (Either HttpError a)
forall (r :: [(* -> *) -> * -> *]) (m :: * -> *) a.
Members '[Embed IO, Log, Resource, Manager] r =>
Request
-> (Response BodyReader -> m (Either HttpError a))
-> Tactical (Http BodyReader) m r (Either HttpError a)
httpStream Request
request Response BodyReader -> Sem rInitial (Either HttpError a)
handler
    Http.ConsumeChunk body ->
      Either HttpError ByteString
-> Sem
     (WithTactics (Http BodyReader) f (Sem rInitial) r)
     (f (Either HttpError ByteString))
forall a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
a -> Tactical e m r a
pureT (Either HttpError ByteString
 -> Sem
      (WithTactics (Http BodyReader) f (Sem rInitial) r)
      (f (Either HttpError ByteString)))
-> Sem
     (WithTactics (Http BodyReader) f (Sem rInitial) r)
     (Either HttpError ByteString)
-> Sem
     (WithTactics (Http BodyReader) f (Sem rInitial) r)
     (f (Either HttpError ByteString))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Text -> HttpError)
-> Either Text ByteString -> Either HttpError ByteString
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft Text -> HttpError
HttpError.ChunkFailed (Either Text ByteString -> Either HttpError ByteString)
-> Sem
     (WithTactics (Http BodyReader) f (Sem rInitial) r)
     (Either Text ByteString)
-> Sem
     (WithTactics (Http BodyReader) f (Sem rInitial) r)
     (Either HttpError ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BodyReader
-> Sem
     (WithTactics (Http BodyReader) f (Sem rInitial) r)
     (Either Text ByteString)
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
IO a -> Sem r (Either Text a)
tryAny 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 :: InterpreterFor (Http BodyReader) r
interpretHttpNative =
  Sem (Manager : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
InterpreterFor Manager r
interpretManager (Sem (Manager : r) a -> Sem r a)
-> (Sem (Http BodyReader : r) a -> Sem (Manager : r) a)
-> Sem (Http BodyReader : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Http BodyReader : Manager : r) a -> Sem (Manager : r) a
forall (r :: [(* -> *) -> * -> *]).
Members '[Embed IO, Log, Resource, Manager] r =>
InterpreterFor (Http BodyReader) r
interpretHttpNativeWith (Sem (Http BodyReader : Manager : r) a -> Sem (Manager : r) a)
-> (Sem (Http BodyReader : r) a
    -> Sem (Http BodyReader : Manager : r) a)
-> Sem (Http BodyReader : r) a
-> Sem (Manager : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Http BodyReader : r) a
-> Sem (Http BodyReader : Manager : r) a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# INLINE interpretHttpNative #-}