module Matterhorn.State.Async
( AsyncPriority(..)
, doAsync
, doAsyncIO
, doAsyncWith
, doAsyncChannelMM
, doAsyncWithIO
, doAsyncMM
, tryMM
, endAsyncNOP
, scheduleMH
)
where
import Prelude ()
import Matterhorn.Prelude
import qualified Control.Concurrent.STM as STM
import Control.Exception ( try )
import Network.Mattermost.Types
import Matterhorn.Types
tryMM :: IO a
-> (a -> IO (Maybe (MH ())))
-> IO (Maybe (MH ()))
tryMM :: forall a. IO a -> (a -> IO (Maybe (MH ()))) -> IO (Maybe (MH ()))
tryMM IO a
act a -> IO (Maybe (MH ()))
onSuccess = do
Either MattermostError a
result <- IO (Either MattermostError a) -> IO (Either MattermostError a)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either MattermostError a) -> IO (Either MattermostError a))
-> IO (Either MattermostError a) -> IO (Either MattermostError a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either MattermostError a)
forall e a. Exception e => IO a -> IO (Either e a)
try IO a
act
case Either MattermostError a
result of
Left MattermostError
e -> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ MHError -> MH ()
mhError (MHError -> MH ()) -> MHError -> MH ()
forall a b. (a -> b) -> a -> b
$ MattermostError -> MHError
ServerError MattermostError
e
Right a
value -> IO (Maybe (MH ())) -> IO (Maybe (MH ()))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (MH ())) -> IO (Maybe (MH ())))
-> IO (Maybe (MH ())) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ a -> IO (Maybe (MH ()))
onSuccess a
value
data AsyncPriority = Preempt | Normal
doAsync :: AsyncPriority -> IO () -> MH ()
doAsync :: AsyncPriority -> IO () -> MH ()
doAsync AsyncPriority
prio IO ()
act = AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
prio (IO ()
act IO () -> IO (Maybe (MH ())) -> IO (Maybe (MH ()))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing)
doAsyncWith :: AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith :: AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
prio IO (Maybe (MH ()))
act = do
let putChan :: TChan a -> a -> STM ()
putChan = case AsyncPriority
prio of
AsyncPriority
Preempt -> TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
STM.unGetTChan
AsyncPriority
Normal -> TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan
RequestChan
queue <- Getting RequestChan ChatState RequestChan -> MH RequestChan
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatResources -> Const RequestChan ChatResources)
-> ChatState -> Const RequestChan ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const RequestChan ChatResources)
-> ChatState -> Const RequestChan ChatState)
-> ((RequestChan -> Const RequestChan RequestChan)
-> ChatResources -> Const RequestChan ChatResources)
-> Getting RequestChan ChatState RequestChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(RequestChan -> Const RequestChan RequestChan)
-> ChatResources -> Const RequestChan ChatResources
Lens' ChatResources RequestChan
crRequestQueue)
IO () -> MH ()
forall a. IO a -> MH a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MH ()) -> IO () -> MH ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ RequestChan -> IO (Maybe (MH ())) -> STM ()
forall a. TChan a -> a -> STM ()
putChan RequestChan
queue IO (Maybe (MH ()))
act
doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO ()
doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO ()
doAsyncIO AsyncPriority
prio ChatState
st IO ()
act =
AsyncPriority -> ChatState -> IO (Maybe (MH ())) -> IO ()
doAsyncWithIO AsyncPriority
prio ChatState
st (IO ()
act IO () -> IO (Maybe (MH ())) -> IO (Maybe (MH ()))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing)
scheduleMH :: ChatResources -> MH () -> IO ()
scheduleMH :: ChatResources -> MH () -> IO ()
scheduleMH ChatResources
r MH ()
act = do
let queue :: RequestChan
queue = ChatResources
rChatResources
-> ((RequestChan -> Const RequestChan RequestChan)
-> ChatResources -> Const RequestChan ChatResources)
-> RequestChan
forall s a. s -> Getting a s a -> a
^.(RequestChan -> Const RequestChan RequestChan)
-> ChatResources -> Const RequestChan ChatResources
Lens' ChatResources RequestChan
crRequestQueue
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ RequestChan -> IO (Maybe (MH ())) -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan RequestChan
queue (IO (Maybe (MH ())) -> STM ()) -> IO (Maybe (MH ())) -> STM ()
forall a b. (a -> b) -> a -> b
$ Maybe (MH ()) -> IO (Maybe (MH ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just MH ()
act
doAsyncWithIO :: AsyncPriority -> ChatState -> IO (Maybe (MH ())) -> IO ()
doAsyncWithIO :: AsyncPriority -> ChatState -> IO (Maybe (MH ())) -> IO ()
doAsyncWithIO AsyncPriority
prio ChatState
st IO (Maybe (MH ()))
act = do
let putChan :: TChan a -> a -> STM ()
putChan = case AsyncPriority
prio of
AsyncPriority
Preempt -> TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
STM.unGetTChan
AsyncPriority
Normal -> TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan
let queue :: RequestChan
queue = ChatState
stChatState
-> Getting RequestChan ChatState RequestChan -> RequestChan
forall s a. s -> Getting a s a -> a
^.(ChatResources -> Const RequestChan ChatResources)
-> ChatState -> Const RequestChan ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const RequestChan ChatResources)
-> ChatState -> Const RequestChan ChatState)
-> ((RequestChan -> Const RequestChan RequestChan)
-> ChatResources -> Const RequestChan ChatResources)
-> Getting RequestChan ChatState RequestChan
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(RequestChan -> Const RequestChan RequestChan)
-> ChatResources -> Const RequestChan ChatResources
Lens' ChatResources RequestChan
crRequestQueue
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ RequestChan -> IO (Maybe (MH ())) -> STM ()
forall a. TChan a -> a -> STM ()
putChan RequestChan
queue IO (Maybe (MH ()))
act
doAsyncMM :: AsyncPriority
-> (Session -> IO a)
-> (a -> Maybe (MH ()))
-> MH ()
doAsyncMM :: forall a.
AsyncPriority -> (Session -> IO a) -> (a -> Maybe (MH ())) -> MH ()
doAsyncMM AsyncPriority
prio Session -> IO a
mmOp a -> Maybe (MH ())
eventHandler = do
Session
session <- MH Session
getSession
AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
prio (IO (Maybe (MH ())) -> MH ()) -> IO (Maybe (MH ())) -> MH ()
forall a b. (a -> b) -> a -> b
$ do
a
r <- Session -> IO a
mmOp Session
session
Maybe (MH ()) -> IO (Maybe (MH ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ a -> Maybe (MH ())
eventHandler a
r
type DoAsyncChannelMM a =
AsyncPriority
-> ChannelId
-> (Session -> ChannelId -> IO a)
-> (ChannelId -> a -> Maybe (MH ()))
-> MH ()
doAsyncChannelMM :: DoAsyncChannelMM a
doAsyncChannelMM :: forall a. DoAsyncChannelMM a
doAsyncChannelMM AsyncPriority
prio ChannelId
cId Session -> ChannelId -> IO a
mmOp ChannelId -> a -> Maybe (MH ())
eventHandler =
AsyncPriority -> (Session -> IO a) -> (a -> Maybe (MH ())) -> MH ()
forall a.
AsyncPriority -> (Session -> IO a) -> (a -> Maybe (MH ())) -> MH ()
doAsyncMM AsyncPriority
prio (\Session
s -> Session -> ChannelId -> IO a
mmOp Session
s ChannelId
cId) (ChannelId -> a -> Maybe (MH ())
eventHandler ChannelId
cId)
endAsyncNOP :: ChannelId -> a -> Maybe (MH ())
endAsyncNOP :: forall a. ChannelId -> a -> Maybe (MH ())
endAsyncNOP ChannelId
_ a
_ = Maybe (MH ())
forall a. Maybe a
Nothing