{-# 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

-- | Interpret an @Http@ effect
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

-- | Telegraph state
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)