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


-- | Try to run a computation, posting an informative error
--   message if it fails with a 'MattermostServerError'.
tryMM :: IO a
      -- ^ The action to try (usually a MM API call)
      -> (a -> IO (Maybe (MH ())))
      -- ^ What to do on success
      -> IO (Maybe (MH ()))
tryMM :: 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 (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 (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 (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

-- * Background Computation

-- $background_computation
--
-- The main context for Matterhorn is the EventM context provided by
-- the 'Brick' library.  This context is normally waiting for user
-- input (or terminal resizing, etc.) which gets turned into an
-- MHEvent and the 'onEvent' event handler is called to process that
-- event, after which the display is redrawn as necessary and brick
-- awaits the next input.
--
-- However, it is often convenient to communicate with the Mattermost
-- server in the background, so that large numbers of
-- synchronously-blocking events (e.g. on startup) or refreshes can
-- occur whenever needed and without negatively impacting the UI
-- updates or responsiveness.  This is handled by a 'forkIO' context
-- that waits on an STM channel for work to do, performs the work, and
-- then sends brick an MHEvent containing the completion or failure
-- information for that work.
--
-- The /doAsyncWith/ family of functions here facilitates that
-- asynchronous functionality.  This is typically used in the
-- following fashion:
--
-- > doSomething :: MH ()
-- > doSomething = do
-- >    got <- something
-- >    doAsyncWith Normal $ do
-- >       r <- mmFetchR ....
-- >       return $ do
-- >          csSomething.here %= processed r
--
-- The second argument is an IO monad operation (because 'forkIO' runs
-- in the IO Monad context), but it returns an MH monad operation.
-- The IO monad has access to the closure of 'doSomething' (e.g. the
-- 'got' value), but it should be aware that the state of the MH monad
-- may have been changed by the time the IO monad runs in the
-- background, so the closure is a snapshot of information at the time
-- the 'doAsyncWith' was called.
--
-- Similarly, the returned MH monad operation is *not* run in the
-- context of the 'forkIO' background, but it is instead passed via an
-- MHEvent back to the main brick thread, where it is executed in an
-- EventM handler's MH monad context.  This operation therefore has
-- access to the combined closure of the pre- 'doAsyncWith' code and
-- the closure of the IO operation.  It is important that the final MH
-- monad operation should *re-obtain* state information from the MH
-- monad instead of using or setting the state obtained prior to the
-- 'doAsyncWith' call.

-- | Priority setting for asynchronous work items. Preempt means that
-- the queued item will be the next work item begun (i.e. it goes to the
-- front of the queue); normal means it will go last in the queue.
data AsyncPriority = Preempt | Normal

-- | Run a computation in the background, ignoring any results from it.
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing)

-- | Run a computation in the background, returning a computation to be
-- called on the 'ChatState' value.
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MH ()) -> IO (Maybe (MH ()))
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 (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

-- | Run a computation in the background, returning a computation to be
-- called on the 'ChatState' value.
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

-- | Performs an asynchronous IO operation. On completion, the final
-- argument a completion function is executed in an MH () context in the
-- main (brick) thread.
doAsyncMM :: AsyncPriority
          -- ^ the priority for this async operation
          -> (Session -> IO a)
          -- ^ the async MM channel-based IO operation
          -> (a -> Maybe (MH ()))
          -- ^ function to process the results in brick event handling
          -- context
          -> MH ()
doAsyncMM :: 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 (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

-- | Helper type for a function to perform an asynchronous MM operation
-- on a channel and then invoke an MH completion event.
type DoAsyncChannelMM a =
    AsyncPriority
    -- ^ the priority for this async operation
    -> ChannelId
    -- ^ The channel
    -> (Session -> ChannelId -> IO a)
    -- ^ the asynchronous Mattermost channel-based IO operation
    -> (ChannelId -> a -> Maybe (MH ()))
    -- ^ function to process the results in brick event handling context
    -> MH ()

-- | Performs an asynchronous IO operation on a specific channel. On
-- completion, the final argument a completion function is executed in
-- an MH () context in the main (brick) thread.
doAsyncChannelMM :: DoAsyncChannelMM a
doAsyncChannelMM :: 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)

-- | Use this convenience function if no operation needs to be
-- performed in the MH state after an async operation completes.
endAsyncNOP :: ChannelId -> a -> Maybe (MH ())
endAsyncNOP :: ChannelId -> a -> Maybe (MH ())
endAsyncNOP ChannelId
_ a
_ = Maybe (MH ())
forall a. Maybe a
Nothing