{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Effect.Telegraph where
import Control.Concurrent
import Control.Effect
import Control.Effect.Error
import Control.Effect.ErrorIO
import Control.Effect.Reader
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Text (Text)
import GHC.Generics
import Network.HTTP.Client
import qualified Network.HTTP.Client as C
import Network.HTTP.Client.MultipartFormData
data Http :: Effect where
HttpLbs :: Request -> Http m (Response LBS.ByteString)
GenBoundary :: Http m ByteString
data Telegraph :: Effect where
TakeTS :: Telegraph m TS
ReadTS :: Telegraph m TS
PutTS :: TS -> Telegraph m ()
type Telegraph' = Bundle '[Telegraph, Http, Error HttpException]
type Http' = Bundle '[Http, Error HttpException]
data TelegraphH
instance
Effs '[Embed IO, Reader (MVar TS)] m =>
Handler TelegraphH Telegraph m
where
effHandler :: Telegraph (Effly z) x -> Effly z x
effHandler = \case
Telegraph (Effly z) x
TakeTS -> 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
Telegraph (Effly z) x
ReadTS -> 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
PutTS TS
ts -> do
MVar TS
ref <- Effly z (MVar TS)
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 TS -> TS -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar TS
ref TS
ts
type TelegraphC = InterpretC TelegraphH Telegraph
telegraph ::
Effs '[Embed IO, Reader (MVar TS)] m =>
TelegraphC m a ->
m a
telegraph :: TelegraphC m a -> m a
telegraph = TelegraphC 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 telegraph #-}
data HttpH
instance
Effs '[Embed IO, Reader Manager] m =>
Handler HttpH Http m
where
effHandler :: Http (Effly z) x -> Effly z x
effHandler = \case
HttpLbs Request
req -> Effly z Manager
forall i (m :: Type -> Type). Eff (Ask i) m => m i
ask Effly z Manager
-> (Manager -> Effly z (Response ByteString))
-> Effly z (Response ByteString)
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Response ByteString) -> Effly z (Response ByteString)
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO (Response ByteString) -> Effly z (Response ByteString))
-> (Manager -> IO (Response ByteString))
-> Manager
-> Effly z (Response ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Manager -> IO (Response ByteString)
C.httpLbs Request
req
Http (Effly z) x
GenBoundary -> IO ByteString -> Effly z ByteString
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed IO ByteString
webkitBoundary
type HttpC = InterpretC HttpH Http
http ::
Effs '[Embed IO, Reader Manager] m =>
HttpC m a ->
m a
http :: HttpC m a -> m a
http = HttpC 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 http #-}
errorToErrorIOAsExc ::
(Exception e, Effs '[ErrorIO, Embed IO] m) =>
InterpretErrorC e m a ->
m a
errorToErrorIOAsExc :: InterpretErrorC e m a -> m a
errorToErrorIOAsExc InterpretErrorC e m a
main =
EffHandler (Throw e) m -> InterpretReifiedC (Throw e) m a -> m a
forall (e :: Effect) (m :: Type -> Type) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret (\(Throw e) -> e -> Effly z x
forall e (m :: Type -> Type) a.
(Exception e, Eff ErrorIO m) =>
e -> m a
throwIO e
e) (InterpretReifiedC (Throw e) m a -> m a)
-> InterpretReifiedC (Throw e) m a -> m a
forall a b. (a -> b) -> a -> b
$
EffHandler (Catch e) (InterpretC (ViaReifiedH s) (Throw e) m)
-> InterpretReifiedC
(Catch e) (InterpretC (ViaReifiedH s) (Throw e) m) a
-> InterpretC (ViaReifiedH s) (Throw e) m a
forall (e :: Effect) (m :: Type -> Type) a.
(RepresentationalEff e, Carrier m) =>
EffHandler e m -> InterpretReifiedC e m a -> m a
interpret (\(Catch m h) -> Effly z x
m Effly z x -> (e -> Effly z x) -> Effly z x
forall e (m :: Type -> Type) a.
(Exception e, Eff ErrorIO m) =>
m a -> (e -> m a) -> m a
`catchIO` e -> Effly z x
h) (InterpretReifiedC
(Catch e) (InterpretC (ViaReifiedH s) (Throw e) m) a
-> InterpretC (ViaReifiedH s) (Throw e) m a)
-> InterpretReifiedC
(Catch e) (InterpretC (ViaReifiedH s) (Throw e) m) a
-> InterpretC (ViaReifiedH s) (Throw e) m a
forall a b. (a -> b) -> a -> b
$
CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
-> CompositionBaseM
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
forall (ts :: [Effect]) (m :: Type -> Type) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s) (Throw e)]
m
a
InterpretErrorC e m a
main
{-# INLINE errorToErrorIOAsExc #-}
errorToIOAsExc ::
(Exception e, Eff (Embed IO) m, MonadCatch m) =>
ErrorToIOC e m a ->
m a
errorToIOAsExc :: ErrorToIOC e m a -> m a
errorToIOAsExc ErrorToIOC e m a
m =
ErrorIOToIOC m a -> m a
forall (m :: Type -> Type) a.
(Carrier m, MonadCatch m) =>
ErrorIOToIOC m a -> m a
errorIOToIO (ErrorIOToIOC m a -> m a) -> ErrorIOToIOC m a -> m a
forall a b. (a -> b) -> a -> b
$
InterpretErrorC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
-> ErrorIOToIOC m a
forall e (m :: Type -> Type) a.
(Exception e, Effs '[ErrorIO, Embed IO] m) =>
InterpretErrorC e m a -> m a
errorToErrorIOAsExc (InterpretErrorC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
-> ErrorIOToIOC m a)
-> InterpretErrorC
e
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
-> ErrorIOToIOC m a
forall a b. (a -> b) -> a -> b
$
IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
forall (top :: [Effect]) (new :: [Effect]) (m :: Type -> Type) a.
(KnownList top, KnownList new, IntroConsistent top new m) =>
IntroUnderManyC top new m a -> m a
introUnderMany (IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a)
-> IntroUnderManyC
'[Catch e, Throw e]
'[ErrorIO]
(CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m))
a
-> CompositionC
'[InterpretC (ViaReifiedH s) (Catch e),
InterpretC (ViaReifiedH s') (Throw e)]
(CompositionC
'[ReinterpretC
ErrorIOFinalH ErrorIO '[Optional ((->) SomeException)],
InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException))]
m)
a
forall a b. (a -> b) -> a -> b
$
CompositionC
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
-> CompositionBaseM
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
forall (ts :: [Effect]) (m :: Type -> Type) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition CompositionC
'[IntroC '[Catch e, Throw e] '[ErrorIO], InterpretErrorC' s s' e,
ErrorIOToIOC]
m
a
ErrorToIOC e m a
m
{-# INLINE errorToIOAsExc #-}
takeTS :: Eff Telegraph m => m TS
takeTS :: m TS
takeTS = Telegraph m TS -> m TS
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send Telegraph m TS
forall (m :: Type -> Type). Telegraph m TS
TakeTS
readTS :: Eff Telegraph m => m TS
readTS :: m TS
readTS = Telegraph m TS -> m TS
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send Telegraph m TS
forall (m :: Type -> Type). Telegraph m TS
ReadTS
putTS :: Eff Telegraph m => TS -> m ()
putTS :: TS -> m ()
putTS !TS
s = Telegraph m () -> m ()
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (TS -> Telegraph m ()
forall (m :: Type -> Type). TS -> Telegraph m ()
PutTS TS
s)
httpLbs :: Effs '[Http, Error HttpException] m => Request -> m (Response LBS.ByteString)
httpLbs :: Request -> m (Response ByteString)
httpLbs !Request
r = Http m (Response ByteString) -> m (Response ByteString)
forall (e :: Effect) (m :: Type -> Type) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send (Request -> Http m (Response ByteString)
forall (m :: Type -> Type). Request -> Http m (Response ByteString)
HttpLbs Request
r)
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
data TS = TS
{ TS -> Text
accessToken :: Text,
TS -> Text
shortName :: Text,
TS -> Text
authorName :: Text,
TS -> Text
authorUrl :: Text
}
deriving (Int -> TS -> ShowS
[TS] -> ShowS
TS -> String
(Int -> TS -> ShowS)
-> (TS -> String) -> ([TS] -> ShowS) -> Show TS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TS] -> ShowS
$cshowList :: [TS] -> ShowS
show :: TS -> String
$cshow :: TS -> String
showsPrec :: Int -> TS -> ShowS
$cshowsPrec :: Int -> TS -> ShowS
Show, TS -> TS -> Bool
(TS -> TS -> Bool) -> (TS -> TS -> Bool) -> Eq TS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TS -> TS -> Bool
$c/= :: TS -> TS -> Bool
== :: TS -> TS -> Bool
$c== :: TS -> TS -> Bool
Eq, (forall x. TS -> Rep TS x)
-> (forall x. Rep TS x -> TS) -> Generic TS
forall x. Rep TS x -> TS
forall x. TS -> Rep TS x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TS x -> TS
$cfrom :: forall x. TS -> Rep TS x
Generic)