module Web.Dependencies.Sparrow.Client.Types where
import Web.Dependencies.Sparrow.Types (WSIncoming, WithTopic, Topic)
import Data.Aeson (Value)
import Control.Monad.Reader (ReaderT (..), MonadReader (..))
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Writer (MonadWriter)
import Control.Monad.State (MonadState)
import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, Exception)
import Control.Concurrent.STM (STM, atomically)
import Control.Concurrent.STM.TMapMVar (TMapMVar)
import qualified Control.Concurrent.STM.TMapMVar as TMapMVar
import GHC.Generics (Generic)
type RegisteredTopicSubscriptions m =
TMapMVar Topic
( Value -> m ()
, m ()
)
registerSubscription :: Env m -> Topic -> (Value -> m ()) -> m () -> STM ()
registerSubscription Env{envSubscriptions} topic onDeltaOut onReject =
TMapMVar.insert envSubscriptions topic (onDeltaOut,onReject)
removeSubscription :: Env m -> Topic -> STM ()
removeSubscription Env{envSubscriptions} =
TMapMVar.delete envSubscriptions
callReject :: MonadIO m => Env m -> Topic -> m ()
callReject Env{envSubscriptions} topic = do
(_,onReject) <- liftIO $ atomically $ TMapMVar.lookup envSubscriptions topic
onReject
callOnReceive :: MonadIO m => Env m -> Topic -> Value -> m ()
callOnReceive Env{envSubscriptions} topic v = do
(onReceive,_) <- liftIO $ atomically $ TMapMVar.observe envSubscriptions topic
onReceive v
newtype SparrowClientT m a = SparrowClientT
{ runSparrowClientT :: ReaderT (Env m) m a
} deriving (Functor, Applicative, Monad, MonadIO, MonadWriter w, MonadState s, MonadCatch, MonadThrow, MonadMask)
instance MonadReader r m => MonadReader r (SparrowClientT m) where
ask = lift ask
local f (SparrowClientT (ReaderT x)) = SparrowClientT $ ReaderT $ \r -> local f (x r)
instance MonadTrans SparrowClientT where
lift = SparrowClientT . lift
data Env m = Env
{ envSendDelta :: WSIncoming (WithTopic Value) -> m ()
, envSendInit :: Topic -> Value -> m (Maybe Value)
, envSubscriptions :: !(RegisteredTopicSubscriptions m)
}
ask' :: Applicative m => SparrowClientT m (Env m)
ask' = SparrowClientT (ReaderT pure)
data SparrowClientException
= InitOutFailed
| InitOutDecodingError String
| DeltaOutDecodingError String
| InitOutHTTPError
| UnexpectedAddedTopic Topic
| UnexpectedRemovedTopic Topic
| NetworkingDecodingError String
deriving (Show, Generic)
instance Exception SparrowClientException