{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Effect.Exh where
import Conduit
import Control.Concurrent
( MVar,
newMVar,
putMVar,
readMVar,
takeMVar,
)
import Control.Effect
import Control.Effect.Bracket
import Control.Effect.Error
import Control.Effect.Reader
import Control.Monad
import Control.Monad.Trans.Cont
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Network.HTTP.Client hiding (Cookie)
import Network.HTTP.Client.MultipartFormData
data Http :: Effect where
FormRequest :: String -> Http m Request
GenBoundary :: Http m ByteString
RespOpen :: Request -> Http m (Response BodyReader)
RespClose :: Response a -> Http m ()
formRequest :: Effs '[Http, Error HttpException] m => String -> m Request
formRequest :: String -> m Request
formRequest = Http m Request -> m Request
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (Http m Request -> m Request)
-> (String -> Http m Request) -> String -> m Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Http m Request
forall (m :: Type -> Type). String -> Http m Request
FormRequest
{-# INLINE formRequest #-}
genBoundary :: Eff Http m => m ByteString
genBoundary :: m ByteString
genBoundary = Http m ByteString -> m ByteString
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send Http m ByteString
forall (m :: Type -> Type). Http m ByteString
GenBoundary
{-# INLINE genBoundary #-}
respOpen :: Effs '[Http, Error HttpException] m => Request -> m (Response BodyReader)
respOpen :: Request -> m (Response BodyReader)
respOpen = Http m (Response BodyReader) -> m (Response BodyReader)
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (Http m (Response BodyReader) -> m (Response BodyReader))
-> (Request -> Http m (Response BodyReader))
-> Request
-> m (Response BodyReader)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Http m (Response BodyReader)
forall (m :: Type -> Type). Request -> Http m (Response BodyReader)
RespOpen
{-# INLINE respOpen #-}
respClose :: Eff Http m => Response a -> m ()
respClose :: Response a -> m ()
respClose = Http m () -> m ()
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (Http m () -> m ())
-> (Response a -> Http m ()) -> Response a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response a -> Http m ()
forall a (m :: Type -> Type). Response a -> Http m ()
RespClose
{-# INLINE respClose #-}
data HttpH
instance (Effs '[Embed IO, Reader Manager] m) => Handler HttpH Http m where
effHandler :: Http (Effly z) x -> Effly z x
effHandler (FormRequest String
s) = forall (m :: Type -> Type) a. Eff (Embed IO) m => IO a -> m a
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed @IO (IO Request -> Effly z Request) -> IO Request -> Effly z Request
forall a b. (a -> b) -> a -> b
$ String -> IO Request
forall (m :: Type -> Type). MonadThrow m => String -> m Request
parseRequest String
s
effHandler Http (Effly z) x
GenBoundary = BodyReader -> Effly z ByteString
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed BodyReader
webkitBoundary
effHandler (RespOpen Request
req) = Effly z Manager
forall i (m :: Type -> Type). Eff (Ask i) m => m i
ask Effly z Manager
-> (Manager -> Effly z (Response BodyReader))
-> Effly z (Response BodyReader)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Response BodyReader) -> Effly z (Response BodyReader)
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO (Response BodyReader) -> Effly z (Response BodyReader))
-> (Manager -> IO (Response BodyReader))
-> Manager
-> Effly z (Response BodyReader)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Manager -> IO (Response BodyReader)
responseOpen Request
req
effHandler (RespClose Response a
resp) = IO () -> Effly z ()
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO () -> Effly z ()) -> IO () -> Effly z ()
forall a b. (a -> b) -> a -> b
$ Response a -> IO ()
forall a. Response a -> IO ()
responseClose Response a
resp
{-# INLINEABLE effHandler #-}
type HttpToIOC = InterpretC HttpH Http
httpToIO :: (Effs '[Embed IO, Reader Manager] m, Threaders '[ReaderThreads] m p) => HttpToIOC m a -> m a
httpToIO :: HttpToIOC m a -> m a
httpToIO = HttpToIOC m a -> m a
forall h (e :: Effect) (m :: Type -> Type) a.
Handler h e m =>
InterpretC h e m a -> m a
interpretViaHandler
{-# INLINE httpToIO #-}
data Cookie :: Effect where
TakeCookie :: Cookie m CookieJar
ReadCookie :: Cookie m CookieJar
PutCookie :: CookieJar -> Cookie m ()
takeCookie :: Eff Cookie m => m CookieJar
takeCookie :: m CookieJar
takeCookie = Cookie m CookieJar -> m CookieJar
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send Cookie m CookieJar
forall (m :: Type -> Type). Cookie m CookieJar
TakeCookie
{-# INLINE takeCookie #-}
readCookie :: Eff Cookie m => m CookieJar
readCookie :: m CookieJar
readCookie = Cookie m CookieJar -> m CookieJar
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send Cookie m CookieJar
forall (m :: Type -> Type). Cookie m CookieJar
ReadCookie
{-# INLINE readCookie #-}
putCookie :: Eff Cookie m => CookieJar -> m ()
putCookie :: CookieJar -> m ()
putCookie = Cookie m () -> m ()
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (Cookie m () -> m ())
-> (CookieJar -> Cookie m ()) -> CookieJar -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieJar -> Cookie m ()
forall (m :: Type -> Type). CookieJar -> Cookie m ()
PutCookie
{-# INLINE putCookie #-}
data CookieH
instance Effs '[Reader (MVar CookieJar), Embed IO] m => Handler CookieH Cookie m where
effHandler :: Cookie (Effly z) x -> Effly z x
effHandler Cookie (Effly z) x
TakeCookie = Effly z (MVar x)
forall i (m :: Type -> Type). Eff (Ask i) m => m i
ask Effly z (MVar x) -> (MVar x -> Effly z x) -> Effly z x
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO x -> Effly z x
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO x -> Effly z x) -> (MVar x -> IO x) -> MVar x -> Effly z x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar x -> IO x
forall a. MVar a -> IO a
takeMVar
effHandler Cookie (Effly z) x
ReadCookie = Effly z (MVar x)
forall i (m :: Type -> Type). Eff (Ask i) m => m i
ask Effly z (MVar x) -> (MVar x -> Effly z x) -> Effly z x
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO x -> Effly z x
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO x -> Effly z x) -> (MVar x -> IO x) -> MVar x -> Effly z x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar x -> IO x
forall a. MVar a -> IO a
readMVar
effHandler (PutCookie CookieJar
c) = do
MVar CookieJar
ref <- Effly z (MVar CookieJar)
forall i (m :: Type -> Type). Eff (Ask i) m => m i
ask
IO () -> Effly z ()
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO () -> Effly z ()) -> IO () -> Effly z ()
forall a b. (a -> b) -> a -> b
$ MVar CookieJar -> CookieJar -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar CookieJar
ref CookieJar
c
{-# INLINEABLE effHandler #-}
type CookieToReaderC = InterpretC CookieH Cookie
type CookieToIOC = CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)]
cookieToIO :: (Eff (Embed IO) m, Threaders '[ReaderThreads] m p) => CookieToIOC m a -> m a
cookieToIO :: CookieToIOC m a -> m a
cookieToIO CookieToIOC m a
m = do
MVar CookieJar
ref <- IO (MVar CookieJar) -> m (MVar CookieJar)
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO (MVar CookieJar) -> m (MVar CookieJar))
-> IO (MVar CookieJar) -> m (MVar CookieJar)
forall a b. (a -> b) -> a -> b
$ CookieJar -> IO (MVar CookieJar)
forall a. a -> IO (MVar a)
newMVar CookieJar
forall a. Monoid a => a
mempty
MVar CookieJar -> ReaderC (MVar CookieJar) m a -> m a
forall i (m :: Type -> Type) a (p :: [Effect]).
(Carrier m, Threaders '[ReaderThreads] m p) =>
i -> ReaderC i m a -> m a
runReader MVar CookieJar
ref (ReaderC (MVar CookieJar) m a -> m a)
-> ReaderC (MVar CookieJar) m a -> m a
forall a b. (a -> b) -> a -> b
$
InterpretC CookieH Cookie (ReaderC (MVar CookieJar) m) a
-> ReaderC (MVar CookieJar) m a
forall h (e :: Effect) (m :: Type -> Type) a.
Handler h e m =>
InterpretC h e m a -> m a
interpretViaHandler (InterpretC CookieH Cookie (ReaderC (MVar CookieJar) m) a
-> ReaderC (MVar CookieJar) m a)
-> InterpretC CookieH Cookie (ReaderC (MVar CookieJar) m) a
-> ReaderC (MVar CookieJar) m a
forall a b. (a -> b) -> a -> b
$
CookieToIOC m a
-> CompositionBaseM
'[CookieToReaderC, ReaderC (MVar CookieJar)] m a
forall (ts :: [Effect]) (m :: Type -> Type) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition CookieToIOC m a
m
{-# INLINE cookieToIO #-}
data ConduitIO :: Effect where
RunConduitIO :: ConduitT () Void IO a -> ConduitIO m a
runConduitIO :: Eff ConduitIO m => ConduitT () Void IO a -> m a
runConduitIO :: ConduitT () Void IO a -> m a
runConduitIO = ConduitIO m a -> m a
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (ConduitIO m a -> m a)
-> (ConduitT () Void IO a -> ConduitIO m a)
-> ConduitT () Void IO a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConduitT () Void IO a -> ConduitIO m a
forall a (m :: Type -> Type).
ConduitT () Void IO a -> ConduitIO m a
RunConduitIO
{-# INLINE runConduitIO #-}
data ConduitIOH
instance Eff (Embed IO) m => Handler ConduitIOH ConduitIO m where
effHandler :: ConduitIO (Effly z) x -> Effly z x
effHandler (RunConduitIO ConduitT () Void IO x
c) = IO x -> Effly z x
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO x -> Effly z x) -> IO x -> Effly z x
forall a b. (a -> b) -> a -> b
$ ConduitT () Void IO x -> IO x
forall (m :: Type -> Type) r.
Monad m =>
ConduitT () Void m r -> m r
runConduit ConduitT () Void IO x
c
{-# INLINEABLE effHandler #-}
type ConduitIOToIOC = InterpretC ConduitIOH ConduitIO
conduitIOToIO :: Eff (Embed IO) m => ConduitIOToIOC m a -> m a
conduitIOToIO :: ConduitIOToIOC m a -> m a
conduitIOToIO = ConduitIOToIOC m a -> m a
forall h (e :: Effect) (m :: Type -> Type) a.
Handler h e m =>
InterpretC h e m a -> m a
interpretViaHandler
{-# INLINE conduitIOToIO #-}
type ExhC = CompositionC '[HttpToIOC, ConduitIOToIOC, CookieToIOC]
exhToIO :: (Effs '[Embed IO, Reader Manager] m, Threaders '[ReaderThreads] m p) => ExhC m a -> m a
exhToIO :: ExhC m a -> m a
exhToIO ExhC m a
m =
CookieToIOC m a -> m a
forall (m :: Type -> Type) (p :: [Effect]) a.
(Eff (Embed IO) m, Threaders '[ReaderThreads] m p) =>
CookieToIOC m a -> m a
cookieToIO (CookieToIOC m a -> m a) -> CookieToIOC m a -> m a
forall a b. (a -> b) -> a -> b
$
ConduitIOToIOC
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m) a
-> CookieToIOC m a
forall (m :: Type -> Type) a.
Eff (Embed IO) m =>
ConduitIOToIOC m a -> m a
conduitIOToIO (ConduitIOToIOC
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m) a
-> CookieToIOC m a)
-> ConduitIOToIOC
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m) a
-> CookieToIOC m a
forall a b. (a -> b) -> a -> b
$
HttpToIOC
(InterpretC
ConduitIOH
ConduitIO
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m))
a
-> ConduitIOToIOC
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m) a
forall (m :: Type -> Type) (p :: [Effect]) a.
(Effs '[Embed IO, Reader Manager] m,
Threaders '[ReaderThreads] m p) =>
HttpToIOC m a -> m a
httpToIO (HttpToIOC
(InterpretC
ConduitIOH
ConduitIO
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m))
a
-> ConduitIOToIOC
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m) a)
-> HttpToIOC
(InterpretC
ConduitIOH
ConduitIO
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m))
a
-> ConduitIOToIOC
(CompositionC '[CookieToReaderC, ReaderC (MVar CookieJar)] m) a
forall a b. (a -> b) -> a -> b
$
ExhC m a
-> CompositionBaseM '[HttpToIOC, ConduitIOToIOC, CookieToIOC] m a
forall (ts :: [Effect]) (m :: Type -> Type) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition ExhC m a
m
{-# INLINE exhToIO #-}
attachFormData :: Eff Http m => [PartM m] -> Request -> m Request
attachFormData :: [PartM m] -> Request -> m Request
attachFormData [PartM m]
parts Request
req = do
ByteString
boundary <- m ByteString
forall (m :: Type -> Type). Eff Http m => m ByteString
genBoundary
ByteString -> [PartM m] -> Request -> m Request
forall (m :: Type -> Type).
Applicative m =>
ByteString -> [PartM m] -> Request -> m Request
formDataBodyWithBoundary ByteString
boundary [PartM m]
parts Request
req
bodyReaderSource :: BodyReader -> ConduitT i ByteString IO ()
bodyReaderSource :: BodyReader -> ConduitT i ByteString IO ()
bodyReaderSource BodyReader
br = ConduitT i ByteString IO ()
loop
where
loop :: ConduitT i ByteString IO ()
loop = do
ByteString
bs <- BodyReader -> ConduitT i ByteString IO ByteString
forall (t :: Effect) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift BodyReader
br
Bool -> ConduitT i ByteString IO () -> ConduitT i ByteString IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
bs) (ConduitT i ByteString IO () -> ConduitT i ByteString IO ())
-> ConduitT i ByteString IO () -> ConduitT i ByteString IO ()
forall a b. (a -> b) -> a -> b
$ do
ByteString -> ConduitT i ByteString IO ()
forall (m :: Type -> Type) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
ConduitT i ByteString IO ()
loop
resetCookie :: Eff Cookie m => m ()
resetCookie :: m ()
resetCookie = m CookieJar
forall (m :: Type -> Type). Eff Cookie m => m CookieJar
takeCookie m CookieJar -> m () -> m ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> CookieJar -> m ()
forall (m :: Type -> Type). Eff Cookie m => CookieJar -> m ()
putCookie CookieJar
forall a. Monoid a => a
mempty
{-# INLINEABLE resetCookie #-}
modifyJar ::
Effs '[Http, Cookie, Error HttpException, Bracket] m =>
Request ->
m ()
modifyJar :: Request -> m ()
modifyJar Request
req =
m CookieJar -> (CookieJar -> m ()) -> (CookieJar -> m ()) -> m ()
forall (m :: Type -> Type) a c b.
Eff Bracket m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracketOnError
m CookieJar
forall (m :: Type -> Type). Eff Cookie m => m CookieJar
takeCookie
CookieJar -> m ()
forall (m :: Type -> Type). Eff Cookie m => CookieJar -> m ()
putCookie
((CookieJar -> m ()) -> m ()) -> (CookieJar -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \CookieJar
jar -> do
let req' :: Request
req' = Request
req {cookieJar :: Maybe CookieJar
cookieJar = CookieJar -> Maybe CookieJar
forall a. a -> Maybe a
Just CookieJar
jar}
m (Response BodyReader)
-> (Response BodyReader -> m ())
-> (Response BodyReader -> m ())
-> m ()
forall (m :: Type -> Type) a c b.
Eff Bracket m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
(Request -> m (Response BodyReader)
forall (m :: Type -> Type).
Effs '[Http, Error HttpException] m =>
Request -> m (Response BodyReader)
respOpen Request
req')
Response BodyReader -> m ()
forall (m :: Type -> Type) a. Eff Http m => Response a -> m ()
respClose
(CookieJar -> m ()
forall (m :: Type -> Type). Eff Cookie m => CookieJar -> m ()
putCookie (CookieJar -> m ())
-> (Response BodyReader -> CookieJar)
-> Response BodyReader
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response BodyReader -> CookieJar
forall body. Response body -> CookieJar
responseCookieJar)
{-# INLINEABLE modifyJar #-}
openWithJar ::
Effs '[Http, Cookie, Error HttpException] m => Request -> m (Response (ConduitT i ByteString IO ()))
openWithJar :: Request -> m (Response (ConduitT i ByteString IO ()))
openWithJar Request
req = do
CookieJar
jar <- m CookieJar
forall (m :: Type -> Type). Eff Cookie m => m CookieJar
readCookie
Response BodyReader
resp <- Request -> m (Response BodyReader)
forall (m :: Type -> Type).
Effs '[Http, Error HttpException] m =>
Request -> m (Response BodyReader)
respOpen (Request
req {cookieJar :: Maybe CookieJar
cookieJar = CookieJar -> Maybe CookieJar
forall a. a -> Maybe a
Just CookieJar
jar})
Response (ConduitT i ByteString IO ())
-> m (Response (ConduitT i ByteString IO ()))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Response (ConduitT i ByteString IO ())
-> m (Response (ConduitT i ByteString IO ())))
-> Response (ConduitT i ByteString IO ())
-> m (Response (ConduitT i ByteString IO ()))
forall a b. (a -> b) -> a -> b
$ (BodyReader -> ConduitT i ByteString IO ())
-> Response BodyReader -> Response (ConduitT i ByteString IO ())
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap BodyReader -> ConduitT i ByteString IO ()
forall i. BodyReader -> ConduitT i ByteString IO ()
bodyReaderSource Response BodyReader
resp
withSource ::
Effs '[Http, Cookie, Error HttpException, Bracket] m =>
Request ->
ContT r m (Response (ConduitT i ByteString IO ()))
withSource :: Request -> ContT r m (Response (ConduitT i ByteString IO ()))
withSource Request
req = ((Response (ConduitT i ByteString IO ()) -> m r) -> m r)
-> ContT r m (Response (ConduitT i ByteString IO ()))
forall k (r :: k) (m :: k -> Type) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((Response (ConduitT i ByteString IO ()) -> m r) -> m r)
-> ContT r m (Response (ConduitT i ByteString IO ())))
-> ((Response (ConduitT i ByteString IO ()) -> m r) -> m r)
-> ContT r m (Response (ConduitT i ByteString IO ()))
forall a b. (a -> b) -> a -> b
$ \Response (ConduitT i ByteString IO ()) -> m r
k -> do
CookieJar
jar <- m CookieJar
forall (m :: Type -> Type). Eff Cookie m => m CookieJar
readCookie
m (Response BodyReader)
-> (Response BodyReader -> m ())
-> (Response BodyReader -> m r)
-> m r
forall (m :: Type -> Type) a c b.
Eff Bracket m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
(Request -> m (Response BodyReader)
forall (m :: Type -> Type).
Effs '[Http, Error HttpException] m =>
Request -> m (Response BodyReader)
respOpen (Request
req {cookieJar :: Maybe CookieJar
cookieJar = CookieJar -> Maybe CookieJar
forall a. a -> Maybe a
Just CookieJar
jar}))
Response BodyReader -> m ()
forall (m :: Type -> Type) a. Eff Http m => Response a -> m ()
respClose
(Response (ConduitT i ByteString IO ()) -> m r
k (Response (ConduitT i ByteString IO ()) -> m r)
-> (Response BodyReader -> Response (ConduitT i ByteString IO ()))
-> Response BodyReader
-> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BodyReader -> ConduitT i ByteString IO ())
-> Response BodyReader -> Response (ConduitT i ByteString IO ())
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap BodyReader -> ConduitT i ByteString IO ()
forall i. BodyReader -> ConduitT i ByteString IO ()
bodyReaderSource)
{-# INLINEABLE withSource #-}