{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Control.Effect.Telegraph where

import Control.Concurrent
import Control.Effect
import Control.Effect.Error
import Control.Effect.Reader
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Text (Text)
import Network.HTTP.Client
import qualified Network.HTTP.Client as C
import Network.HTTP.Client.MultipartFormData
import Optics.TH

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

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
{-# INLINE 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
{-# INLINE 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)
{-# INLINE putTS #-}

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)
{-# INLINE httpLbs #-}

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

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

makeFieldLabelsWith noPrefixFieldLabels ''TS