{-# options_haddock prune #-}
-- |Description: Pure Http Interpreters, Internal
module Polysemy.Http.Interpreter.Pure where

import Network.HTTP.Client.Internal (CookieJar (CJ))
import Polysemy (interpretH)
import Polysemy.Internal.Tactics (bindT, bindTSimple)

import Polysemy.Http.Data.Response (Response (Response))
import qualified Polysemy.Http.Effect.Http as Http
import Polysemy.Http.Effect.Http (Http)

takeResponse ::
  Member (State [Response LByteString]) r =>
  [Response LByteString] ->
  Sem r (Response LByteString)
takeResponse :: [Response LByteString] -> Sem r (Response LByteString)
takeResponse (Response LByteString
response : [Response LByteString]
rest) =
  Response LByteString
response Response LByteString -> Sem r () -> Sem r (Response LByteString)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Response LByteString] -> Sem r ()
forall s (r :: [Effect]).
MemberWithError (State s) r =>
s -> Sem r ()
put [Response LByteString]
rest
takeResponse [] =
  Response LByteString -> Sem r (Response LByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status
-> LByteString -> [Header] -> CookieJar -> Response LByteString
forall b. Status -> b -> [Header] -> CookieJar -> Response b
Response (Int -> Status
forall a. Enum a => Int -> a
toEnum Int
502) LByteString
"test responses exhausted" [] ([Cookie] -> CookieJar
CJ [Cookie]
forall a. Monoid a => a
mempty))

takeChunk ::
  Member (State [ByteString]) r =>
  [ByteString] ->
  Sem r ByteString
takeChunk :: [ByteString] -> Sem r ByteString
takeChunk (ByteString
chunk : [ByteString]
rest) =
  ByteString
chunk ByteString -> Sem r () -> Sem r ByteString
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [ByteString] -> Sem r ()
forall s (r :: [Effect]).
MemberWithError (State s) r =>
s -> Sem r ()
put [ByteString]
rest
takeChunk [] =
  ByteString -> Sem r ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""

interpretHttpPureWithState ::
  Members [State [ByteString], State [Response LByteString], Embed IO] r =>
  InterpreterFor (Http LByteString) r
interpretHttpPureWithState :: InterpreterFor (Http LByteString) r
interpretHttpPureWithState =
  (forall (rInitial :: [Effect]) x.
 Http LByteString (Sem rInitial) x
 -> Tactical (Http LByteString) (Sem rInitial) r x)
-> Sem (Http LByteString : r) a -> Sem r a
forall (e :: Effect) (r :: [Effect]) a.
(forall (rInitial :: [Effect]) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Http.Response _ f -> do
      f (Response LByteString)
res <- Sem r (Response LByteString)
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Response LByteString))
forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Sem r (Response LByteString)
 -> Sem
      (WithTactics (Http LByteString) f (Sem rInitial) r)
      (f (Response LByteString)))
-> ([Response LByteString] -> Sem r (Response LByteString))
-> [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Response LByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Response LByteString] -> Sem r (Response LByteString)
forall (r :: [Effect]).
Member (State [Response LByteString]) r =>
[Response LByteString] -> Sem r (Response LByteString)
takeResponse ([Response LByteString]
 -> Sem
      (WithTactics (Http LByteString) f (Sem rInitial) r)
      (f (Response LByteString)))
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Response LByteString))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem r [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     [Response LByteString]
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise Sem r [Response LByteString]
forall s (r :: [Effect]). MemberWithError (State s) r => Sem r s
get
      (a -> Either HttpError a) -> f a -> f (Either HttpError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either HttpError a
forall a b. b -> Either a b
Right (f a -> f (Either HttpError a))
-> Sem (WithTactics (Http LByteString) f (Sem rInitial) r) (f a)
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Either HttpError a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Response LByteString -> Sem rInitial a)
-> f (Response LByteString)
-> Sem (WithTactics (Http LByteString) f (Sem rInitial) r) (f a)
forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a
       b.
(a -> m b) -> f a -> Sem (WithTactics e f m r) (f b)
bindTSimple Response LByteString -> Sem rInitial a
f f (Response LByteString)
res
    Http.Request _ ->
      Sem r (Either HttpError (Response LByteString))
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Either HttpError (Response LByteString)))
forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Sem r (Either HttpError (Response LByteString))
 -> Sem
      (WithTactics (Http LByteString) f (Sem rInitial) r)
      (f (Either HttpError (Response LByteString))))
-> ([Response LByteString]
    -> Sem r (Either HttpError (Response LByteString)))
-> [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Either HttpError (Response LByteString)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response LByteString -> Either HttpError (Response LByteString))
-> Sem r (Response LByteString)
-> Sem r (Either HttpError (Response LByteString))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response LByteString -> Either HttpError (Response LByteString)
forall a b. b -> Either a b
Right (Sem r (Response LByteString)
 -> Sem r (Either HttpError (Response LByteString)))
-> ([Response LByteString] -> Sem r (Response LByteString))
-> [Response LByteString]
-> Sem r (Either HttpError (Response LByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Response LByteString] -> Sem r (Response LByteString)
forall (r :: [Effect]).
Member (State [Response LByteString]) r =>
[Response LByteString] -> Sem r (Response LByteString)
takeResponse ([Response LByteString]
 -> Sem
      (WithTactics (Http LByteString) f (Sem rInitial) r)
      (f (Either HttpError (Response LByteString))))
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Either HttpError (Response LByteString)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem r [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     [Response LByteString]
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise Sem r [Response LByteString]
forall s (r :: [Effect]). MemberWithError (State s) r => Sem r s
get
    Http.Stream _ handler -> do
      f (Response LByteString) -> Sem (Http LByteString : r) (f a)
handle <- (Response LByteString -> Sem rInitial a)
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Response LByteString) -> Sem (Http LByteString : r) (f a))
forall a (m :: * -> *) b (e :: Effect) (f :: * -> *)
       (r :: [Effect]).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT Response LByteString -> Sem rInitial a
handler
      f (Response LByteString)
res <- Sem r (Response LByteString)
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Response LByteString))
forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Sem r (Response LByteString)
 -> Sem
      (WithTactics (Http LByteString) f (Sem rInitial) r)
      (f (Response LByteString)))
-> ([Response LByteString] -> Sem r (Response LByteString))
-> [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Response LByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Response LByteString] -> Sem r (Response LByteString)
forall (r :: [Effect]).
Member (State [Response LByteString]) r =>
[Response LByteString] -> Sem r (Response LByteString)
takeResponse ([Response LByteString]
 -> Sem
      (WithTactics (Http LByteString) f (Sem rInitial) r)
      (f (Response LByteString)))
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Response LByteString))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem r [Response LByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     [Response LByteString]
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise Sem r [Response LByteString]
forall s (r :: [Effect]). MemberWithError (State s) r => Sem r s
get
      (a -> Either HttpError a) -> f a -> f (Either HttpError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either HttpError a
forall a b. b -> Either a b
Right (f a -> f (Either HttpError a))
-> Sem (WithTactics (Http LByteString) f (Sem rInitial) r) (f a)
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Either HttpError a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r (f a)
-> Sem (WithTactics (Http LByteString) f (Sem rInitial) r) (f a)
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise (Sem (Http LByteString : r) (f a) -> Sem r (f a)
forall (r :: [Effect]).
Members
  '[State [ByteString], State [Response LByteString], Embed IO] r =>
InterpreterFor (Http LByteString) r
interpretHttpPureWithState (f (Response LByteString) -> Sem (Http LByteString : r) (f a)
handle f (Response LByteString)
res))
    Http.ConsumeChunk _ ->
      Sem r (Either HttpError ByteString)
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Either HttpError ByteString))
forall (m :: * -> *) (f :: * -> *) (r :: [Effect]) (e :: Effect) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Sem r (Either HttpError ByteString)
 -> Sem
      (WithTactics (Http LByteString) f (Sem rInitial) r)
      (f (Either HttpError ByteString)))
-> ([ByteString] -> Sem r (Either HttpError ByteString))
-> [ByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Either HttpError ByteString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either HttpError ByteString)
-> Sem r ByteString -> Sem r (Either HttpError ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either HttpError ByteString
forall a b. b -> Either a b
Right (Sem r ByteString -> Sem r (Either HttpError ByteString))
-> ([ByteString] -> Sem r ByteString)
-> [ByteString]
-> Sem r (Either HttpError ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Sem r ByteString
forall (r :: [Effect]).
Member (State [ByteString]) r =>
[ByteString] -> Sem r ByteString
takeChunk ([ByteString]
 -> Sem
      (WithTactics (Http LByteString) f (Sem rInitial) r)
      (f (Either HttpError ByteString)))
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r) [ByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r)
     (f (Either HttpError ByteString))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sem r [ByteString]
-> Sem
     (WithTactics (Http LByteString) f (Sem rInitial) r) [ByteString]
forall (e :: Effect) (r :: [Effect]) a. Sem r a -> Sem (e : r) a
raise Sem r [ByteString]
forall s (r :: [Effect]). MemberWithError (State s) r => Sem r s
get
{-# inline interpretHttpPureWithState #-}

-- |In-Memory interpreter for 'Http'.
interpretHttpPure ::
  Member (Embed IO) r =>
  -- |When a request is made, one response is popped of the list and returned.
  --   If the list is exhausted, a 502 response is returned.
  [Response LByteString] ->
  -- |Chunks used for streaming responses.
  [ByteString] ->
  InterpretersFor [Http LByteString, State [Response LByteString], State [ByteString]] r
interpretHttpPure :: [Response LByteString]
-> [ByteString]
-> InterpretersFor
     '[Http LByteString, State [Response LByteString],
       State [ByteString]]
     r
interpretHttpPure [Response LByteString]
responses [ByteString]
chunks =
  [ByteString] -> Sem (State [ByteString] : r) a -> Sem r a
forall s (r :: [Effect]) a. s -> Sem (State s : r) a -> Sem r a
evalState [ByteString]
chunks (Sem (State [ByteString] : r) a -> Sem r a)
-> (Sem
      (Http LByteString
         : State [Response LByteString] : State [ByteString] : r)
      a
    -> Sem (State [ByteString] : r) a)
-> Sem
     (Http LByteString
        : State [Response LByteString] : State [ByteString] : r)
     a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [Response LByteString]
-> Sem (State [Response LByteString] : State [ByteString] : r) a
-> Sem (State [ByteString] : r) a
forall s (r :: [Effect]) a. s -> Sem (State s : r) a -> Sem r a
evalState [Response LByteString]
responses (Sem (State [Response LByteString] : State [ByteString] : r) a
 -> Sem (State [ByteString] : r) a)
-> (Sem
      (Http LByteString
         : State [Response LByteString] : State [ByteString] : r)
      a
    -> Sem (State [Response LByteString] : State [ByteString] : r) a)
-> Sem
     (Http LByteString
        : State [Response LByteString] : State [ByteString] : r)
     a
-> Sem (State [ByteString] : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem
  (Http LByteString
     : State [Response LByteString] : State [ByteString] : r)
  a
-> Sem (State [Response LByteString] : State [ByteString] : r) a
forall (r :: [Effect]).
Members
  '[State [ByteString], State [Response LByteString], Embed IO] r =>
InterpreterFor (Http LByteString) r
interpretHttpPureWithState
{-# inline interpretHttpPure #-}