module Polysemy.Http.Strict where

import Polysemy (interpretH)
import Polysemy.Internal.Tactics (bindT, bindTSimple)

import Polysemy.Http.Data.Header (Header(Header))
import qualified Polysemy.Http.Data.Http as Http
import Polysemy.Http.Data.Http (Http)
import Polysemy.Http.Data.Response (Response(Response))
import Network.HTTP.Client.Internal (CookieJar(CJ))

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
""

streamResponse :: Response LByteString
streamResponse :: Response LByteString
streamResponse =
  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
200) LByteString
"stream response" [
    HeaderName -> HeaderValue -> Header
Header HeaderName
"content-disposition" [qt|filename="file.txt"|],
    HeaderName -> HeaderValue -> Header
Header HeaderName
"content-length" HeaderValue
"5000000"
    ] ([Cookie] -> CookieJar
CJ [Cookie]
forall a. Monoid a => a
mempty)

interpretHttpStrictWithState ::
  Members [State [ByteString], State [Response LByteString], Embed IO] r =>
  InterpreterFor (Http LByteString) r
interpretHttpStrictWithState :: InterpreterFor (Http LByteString) r
interpretHttpStrictWithState =
  (forall x (rInitial :: [Effect]).
 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 x (rInitial :: [Effect]).
 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)
resp <- Response LByteString
-> Tactical
     (Http LByteString) (Sem rInitial) r (Response LByteString)
forall a (e :: Effect) (m :: * -> *) (r :: [Effect]).
a -> Tactical e m r a
pureT Response LByteString
streamResponse
      (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
interpretHttpStrictWithState (f (Response LByteString) -> Sem (Http LByteString : r) (f a)
handle f (Response LByteString)
resp))
    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 interpretHttpStrictWithState #-}

-- |In-Memory interpreter for 'Http'.
interpretHttpStrict ::
  Member (Embed IO) r =>
  -- |When a request is made, one response is popped of the head and returned.
  --   If the list is exhausted, a 502 response is returned.
  [Response LByteString] ->
  -- |Chunks used for streaming responses.
  [ByteString] ->
  InterpreterFor (Http LByteString) r
interpretHttpStrict :: [Response LByteString]
-> [ByteString] -> InterpreterFor (Http LByteString) r
interpretHttpStrict [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 : r) a -> Sem (State [ByteString] : r) a)
-> Sem (Http LByteString : 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 : r) a
    -> Sem (State [Response LByteString] : State [ByteString] : r) a)
-> Sem (Http LByteString : 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
interpretHttpStrictWithState (Sem
   (Http LByteString
      : State [Response LByteString] : State [ByteString] : r)
   a
 -> Sem (State [Response LByteString] : State [ByteString] : r) a)
-> (Sem (Http LByteString : r) a
    -> Sem
         (Http LByteString
            : State [Response LByteString] : State [ByteString] : r)
         a)
-> Sem (Http LByteString : r) a
-> Sem (State [Response LByteString] : State [ByteString] : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Http LByteString : State [ByteString] : r) a
-> Sem
     (Http LByteString
        : State [Response LByteString] : State [ByteString] : r)
     a
forall (e2 :: Effect) (e1 :: Effect) (r :: [Effect]) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder (Sem (Http LByteString : State [ByteString] : r) a
 -> Sem
      (Http LByteString
         : State [Response LByteString] : State [ByteString] : r)
      a)
-> (Sem (Http LByteString : r) a
    -> Sem (Http LByteString : State [ByteString] : r) a)
-> Sem (Http LByteString : r) a
-> Sem
     (Http LByteString
        : State [Response LByteString] : State [ByteString] : r)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Http LByteString : r) a
-> Sem (Http LByteString : State [ByteString] : r) a
forall (e2 :: Effect) (e1 :: Effect) (r :: [Effect]) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# INLINE interpretHttpStrict #-}