{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module Matterhorn.State.Setup.Threads
  ( startUserStatusUpdateThread
  , startTypingUsersRefreshThread
  , startSubprocessLoggerThread
  , startTimezoneMonitorThread
  , maybeStartSpellChecker
  , newSpellCheckTimer
  , startAsyncWorkerThread
  , startSyntaxMapLoaderThread
  , module Matterhorn.State.Setup.Threads.Logging
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick.BChan ( BChan )
import           Brick.Main ( invalidateCache )
import           Control.Concurrent ( threadDelay, forkIO )
import qualified Control.Concurrent.STM as STM
import           Control.Concurrent.STM.Delay
import           Control.Exception ( SomeException, try, fromException, catch )
import           Data.List ( isInfixOf )
import qualified Data.Map as M
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import           Data.Time ( getCurrentTime, addUTCTime )
import           Lens.Micro.Platform ( (.=), (%=), (%~), mapped )
import           Skylighting.Loader ( loadSyntaxesFromDir )
import           System.Directory ( getTemporaryDirectory )
import           System.Exit ( ExitCode(ExitSuccess) )
import           System.IO ( hPutStrLn, hFlush )
import           System.IO.Temp ( openTempFile )
import           System.Timeout ( timeout )
import           Text.Aspell ( Aspell, AspellOption(..), startAspell )

import           Network.Mattermost.Exceptions ( RateLimitException
                                               , rateLimitExceptionReset )
import           Network.Mattermost.Endpoints
import           Network.Mattermost.Types

import           Matterhorn.Constants
import           Matterhorn.State.Editing ( requestSpellCheck )
import           Matterhorn.State.Setup.Threads.Logging
import           Matterhorn.TimeUtils ( lookupLocalTimeZone )
import           Matterhorn.Types


updateUserStatuses :: [UserId] -> Session -> IO (Maybe (MH ()))
updateUserStatuses :: [UserId] -> Session -> IO (Maybe (MH ()))
updateUserStatuses [UserId]
uIds Session
session =
    case [UserId] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UserId]
uIds of
        Bool
False -> do
            Seq Status
statuses <- Seq UserId -> Session -> IO (Seq Status)
mmGetUserStatusByIds ([UserId] -> Seq UserId
forall a. [a] -> Seq a
Seq.fromList [UserId]
uIds) 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
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ do
                Seq Status -> (Status -> MH ()) -> MH ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq Status
statuses ((Status -> MH ()) -> MH ()) -> (Status -> MH ()) -> MH ()
forall a b. (a -> b) -> a -> b
$ \Status
s ->
                    UserId -> Text -> MH ()
setUserStatus (Status -> UserId
statusUserId Status
s) (Status -> Text
statusStatus Status
s)
        Bool
True -> Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing

startUserStatusUpdateThread :: STM.TChan [UserId] -> Session -> RequestChan -> IO ()
startUserStatusUpdateThread :: TChan [UserId] -> Session -> RequestChan -> IO ()
startUserStatusUpdateThread TChan [UserId]
zipperChan Session
session RequestChan
requestChan = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
forall b. IO b
body
  where
      seconds :: Int -> Int
seconds = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000))
      userRefreshInterval :: Int
userRefreshInterval = Int
30
      body :: IO b
body = [UserId] -> IO b
forall b. [UserId] -> IO b
refresh []
      refresh :: [UserId] -> IO b
refresh [UserId]
prev = do
          Maybe [UserId]
result <- Int -> IO [UserId] -> IO (Maybe [UserId])
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int -> Int
seconds Int
userRefreshInterval)
                            (STM [UserId] -> IO [UserId]
forall a. STM a -> IO a
STM.atomically (STM [UserId] -> IO [UserId]) -> STM [UserId] -> IO [UserId]
forall a b. (a -> b) -> a -> b
$ TChan [UserId] -> STM [UserId]
forall a. TChan a -> STM a
STM.readTChan TChan [UserId]
zipperChan)
          let ([UserId]
uIds, Bool
update) = case Maybe [UserId]
result of
                  Maybe [UserId]
Nothing -> ([UserId]
prev, Bool
True)
                  Just [UserId]
ids -> ([UserId]
ids, [UserId]
ids [UserId] -> [UserId] -> Bool
forall a. Eq a => a -> a -> Bool
/= [UserId]
prev)

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
update (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              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
requestChan (IO (Maybe (MH ())) -> STM ()) -> IO (Maybe (MH ())) -> STM ()
forall a b. (a -> b) -> a -> b
$ do
                  Either SomeException (Maybe (MH ()))
rs <- IO (Maybe (MH ())) -> IO (Either SomeException (Maybe (MH ())))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Maybe (MH ())) -> IO (Either SomeException (Maybe (MH ()))))
-> IO (Maybe (MH ())) -> IO (Either SomeException (Maybe (MH ())))
forall a b. (a -> b) -> a -> b
$ [UserId] -> Session -> IO (Maybe (MH ()))
updateUserStatuses [UserId]
uIds Session
session
                  case Either SomeException (Maybe (MH ()))
rs of
                      Left (SomeException
_ :: SomeException) -> Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing
                      Right Maybe (MH ())
upd -> Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
upd

          [UserId] -> IO b
refresh [UserId]
uIds

-- This thread refreshes the map of typing users every second, forever,
-- to expire users who have stopped typing. Expiry time is 3 seconds.
startTypingUsersRefreshThread :: RequestChan -> IO ()
startTypingUsersRefreshThread :: RequestChan -> IO ()
startTypingUsersRefreshThread RequestChan
requestChan = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever IO ()
refresh
  where
    seconds :: NominalDiffTime -> NominalDiffTime
seconds = (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* (NominalDiffTime
1000 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000))
    refreshIntervalMicros :: Int
refreshIntervalMicros = NominalDiffTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime -> Int) -> NominalDiffTime -> Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> NominalDiffTime
seconds (NominalDiffTime -> NominalDiffTime)
-> NominalDiffTime -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
userTypingExpiryInterval NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ NominalDiffTime
2
    refresh :: IO ()
refresh = do
      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
requestChan (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 () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
now <- IO UTCTime -> MH UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        let expiry :: UTCTime
expiry = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (- NominalDiffTime
userTypingExpiryInterval) UTCTime
now
            expireUsers :: ClientChannel -> ClientChannel
expireUsers ClientChannel
c = ClientChannel
c ClientChannel -> (ClientChannel -> ClientChannel) -> ClientChannel
forall a b. a -> (a -> b) -> b
& (MessageInterface Name () -> Identity (MessageInterface Name ()))
-> ClientChannel -> Identity ClientChannel
Lens' ClientChannel (MessageInterface Name ())
ccMessageInterface((MessageInterface Name () -> Identity (MessageInterface Name ()))
 -> ClientChannel -> Identity ClientChannel)
-> ((TypingUsers -> Identity TypingUsers)
    -> MessageInterface Name () -> Identity (MessageInterface Name ()))
-> (TypingUsers -> Identity TypingUsers)
-> ClientChannel
-> Identity ClientChannel
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EditState Name -> Identity (EditState Name))
-> MessageInterface Name () -> Identity (MessageInterface Name ())
forall n i. Lens' (MessageInterface n i) (EditState n)
miEditor((EditState Name -> Identity (EditState Name))
 -> MessageInterface Name () -> Identity (MessageInterface Name ()))
-> ((TypingUsers -> Identity TypingUsers)
    -> EditState Name -> Identity (EditState Name))
-> (TypingUsers -> Identity TypingUsers)
-> MessageInterface Name ()
-> Identity (MessageInterface Name ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EphemeralEditState -> Identity EphemeralEditState)
-> EditState Name -> Identity (EditState Name)
forall n. Lens' (EditState n) EphemeralEditState
esEphemeral((EphemeralEditState -> Identity EphemeralEditState)
 -> EditState Name -> Identity (EditState Name))
-> ((TypingUsers -> Identity TypingUsers)
    -> EphemeralEditState -> Identity EphemeralEditState)
-> (TypingUsers -> Identity TypingUsers)
-> EditState Name
-> Identity (EditState Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(TypingUsers -> Identity TypingUsers)
-> EphemeralEditState -> Identity EphemeralEditState
Lens' EphemeralEditState TypingUsers
eesTypingUsers ((TypingUsers -> Identity TypingUsers)
 -> ClientChannel -> Identity ClientChannel)
-> (TypingUsers -> TypingUsers) -> ClientChannel -> ClientChannel
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ UTCTime -> TypingUsers -> TypingUsers
expireTypingUsers UTCTime
expiry
        (ClientChannels -> Identity ClientChannels)
-> ChatState -> Identity ChatState
Lens' ChatState ClientChannels
csChannels ((ClientChannels -> Identity ClientChannels)
 -> ChatState -> Identity ChatState)
-> ((ClientChannel -> Identity ClientChannel)
    -> ClientChannels -> Identity ClientChannels)
-> (ClientChannel -> Identity ClientChannel)
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap ChannelId ClientChannel
 -> Identity (HashMap ChannelId ClientChannel))
-> ClientChannels -> Identity ClientChannels
Lens' ClientChannels (HashMap ChannelId ClientChannel)
chanMap ((HashMap ChannelId ClientChannel
  -> Identity (HashMap ChannelId ClientChannel))
 -> ClientChannels -> Identity ClientChannels)
-> ((ClientChannel -> Identity ClientChannel)
    -> HashMap ChannelId ClientChannel
    -> Identity (HashMap ChannelId ClientChannel))
-> (ClientChannel -> Identity ClientChannel)
-> ClientChannels
-> Identity ClientChannels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientChannel -> Identity ClientChannel)
-> HashMap ChannelId ClientChannel
-> Identity (HashMap ChannelId ClientChannel)
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped ((ClientChannel -> Identity ClientChannel)
 -> ChatState -> Identity ChatState)
-> (ClientChannel -> ClientChannel) -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ClientChannel -> ClientChannel
expireUsers

      Int -> IO ()
threadDelay Int
refreshIntervalMicros

startSubprocessLoggerThread :: STM.TChan ProgramOutput -> RequestChan -> IO ()
startSubprocessLoggerThread :: TChan ProgramOutput -> RequestChan -> IO ()
startSubprocessLoggerThread TChan ProgramOutput
logChan RequestChan
requestChan = do
    let logMonitor :: Maybe (FilePath, Handle) -> IO b
logMonitor Maybe (FilePath, Handle)
mPair = do
          ProgramOutput FilePath
progName [FilePath]
args FilePath
out FilePath
err ExitCode
ec <-
              STM ProgramOutput -> IO ProgramOutput
forall a. STM a -> IO a
STM.atomically (STM ProgramOutput -> IO ProgramOutput)
-> STM ProgramOutput -> IO ProgramOutput
forall a b. (a -> b) -> a -> b
$ TChan ProgramOutput -> STM ProgramOutput
forall a. TChan a -> STM a
STM.readTChan TChan ProgramOutput
logChan

          case ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess of
              -- the "good" case, no output and exit sucess
              Bool
True -> Maybe (FilePath, Handle) -> IO b
logMonitor Maybe (FilePath, Handle)
mPair
              Bool
False -> do
                  (FilePath
logPath, Handle
logHandle) <- case Maybe (FilePath, Handle)
mPair of
                      Just (FilePath, Handle)
p ->
                          (FilePath, Handle) -> IO (FilePath, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath, Handle)
p
                      Maybe (FilePath, Handle)
Nothing -> do
                          FilePath
tmp <- IO FilePath
getTemporaryDirectory
                          FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile FilePath
tmp FilePath
"matterhorn-subprocess.log"

                  Handle -> FilePath -> IO ()
hPutStrLn Handle
logHandle (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                      [FilePath] -> FilePath
unlines [ FilePath
"Program: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
progName
                              , FilePath
"Arguments: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
forall a. Show a => a -> FilePath
show [FilePath]
args
                              , FilePath
"Exit code: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ExitCode -> FilePath
forall a. Show a => a -> FilePath
show ExitCode
ec
                              , FilePath
"Stdout:"
                              , FilePath
out
                              , FilePath
"Stderr:"
                              , FilePath
err
                              ]
                  Handle -> IO ()
hFlush Handle
logHandle

                  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
requestChan (IO (Maybe (MH ())) -> STM ()) -> IO (Maybe (MH ())) -> STM ()
forall a b. (a -> b) -> a -> b
$ do
                      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
$ Text -> Text -> MHError
ProgramExecutionFailed (FilePath -> Text
T.pack FilePath
progName)
                                                                       (FilePath -> Text
T.pack FilePath
logPath)

                  Maybe (FilePath, Handle) -> IO b
logMonitor ((FilePath, Handle) -> Maybe (FilePath, Handle)
forall a. a -> Maybe a
Just (FilePath
logPath, Handle
logHandle))

    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Maybe (FilePath, Handle) -> IO ()
forall b. Maybe (FilePath, Handle) -> IO b
logMonitor Maybe (FilePath, Handle)
forall a. Maybe a
Nothing

startTimezoneMonitorThread :: TimeZoneSeries -> RequestChan -> IO ()
startTimezoneMonitorThread :: TimeZoneSeries -> RequestChan -> IO ()
startTimezoneMonitorThread TimeZoneSeries
tz RequestChan
requestChan = do
  -- Start the timezone monitor thread
  let timezoneMonitorSleepInterval :: Int
timezoneMonitorSleepInterval = Int -> Int
minutes Int
5
      minutes :: Int -> Int
minutes = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int -> Int
seconds Int
60))
      seconds :: Int -> Int
seconds = (Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000))
      timezoneMonitor :: TimeZoneSeries -> IO b
timezoneMonitor TimeZoneSeries
prevTz = do
        Int -> IO ()
threadDelay Int
timezoneMonitorSleepInterval

        Either SomeException TimeZoneSeries
newTzResult <- IO (Either SomeException TimeZoneSeries)
lookupLocalTimeZone
        TimeZoneSeries
nextTz <- case Either SomeException TimeZoneSeries
newTzResult of
            Left SomeException
e -> do
                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
requestChan (IO (Maybe (MH ())) -> STM ()) -> IO (Maybe (MH ())) -> STM ()
forall a b. (a -> b) -> a -> b
$ do
                    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
$ do
                        LogCategory -> Text -> MH ()
mhLog LogCategory
LogGeneral (Text -> MH ()) -> Text -> MH ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"Could not load time zone information: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                TimeZoneSeries -> IO TimeZoneSeries
forall (m :: * -> *) a. Monad m => a -> m a
return TimeZoneSeries
prevTz
            Right TimeZoneSeries
newTz -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TimeZoneSeries
newTz TimeZoneSeries -> TimeZoneSeries -> Bool
forall a. Eq a => a -> a -> Bool
/= TimeZoneSeries
prevTz) (IO () -> IO ()) -> IO () -> IO ()
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 ()
STM.writeTChan RequestChan
requestChan (IO (Maybe (MH ())) -> STM ()) -> IO (Maybe (MH ())) -> STM ()
forall a b. (a -> b) -> a -> b
$ do
                        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
$ do
                            (TimeZoneSeries -> Identity TimeZoneSeries)
-> ChatState -> Identity ChatState
Lens' ChatState TimeZoneSeries
timeZone ((TimeZoneSeries -> Identity TimeZoneSeries)
 -> ChatState -> Identity ChatState)
-> TimeZoneSeries -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= TimeZoneSeries
newTz
                            EventM Name () -> MH ()
forall a. EventM Name a -> MH a
mh EventM Name ()
forall n. Ord n => EventM n ()
invalidateCache

                TimeZoneSeries -> IO TimeZoneSeries
forall (m :: * -> *) a. Monad m => a -> m a
return TimeZoneSeries
newTz

        TimeZoneSeries -> IO b
timezoneMonitor TimeZoneSeries
nextTz

  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (TimeZoneSeries -> IO ()
forall b. TimeZoneSeries -> IO b
timezoneMonitor TimeZoneSeries
tz)

spellCheckerTimeout :: Int
spellCheckerTimeout :: Int
spellCheckerTimeout = Int
500 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000 -- 500k us = 500ms

maybeStartSpellChecker :: Config -> IO (Maybe Aspell)
maybeStartSpellChecker :: Config -> IO (Maybe Aspell)
maybeStartSpellChecker Config
config = do
  case Config -> Bool
configEnableAspell Config
config of
      Bool
False -> Maybe Aspell -> IO (Maybe Aspell)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Aspell
forall a. Maybe a
Nothing
      Bool
True -> do
          let aspellOpts :: [AspellOption]
aspellOpts = [Maybe AspellOption] -> [AspellOption]
forall a. [Maybe a] -> [a]
catMaybes [ Text -> AspellOption
UseDictionary (Text -> AspellOption) -> Maybe Text -> Maybe AspellOption
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Config -> Maybe Text
configAspellDictionary Config
config)
                                     ]
          (FilePath -> Maybe Aspell)
-> (Aspell -> Maybe Aspell)
-> Either FilePath Aspell
-> Maybe Aspell
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Aspell -> FilePath -> Maybe Aspell
forall a b. a -> b -> a
const Maybe Aspell
forall a. Maybe a
Nothing) Aspell -> Maybe Aspell
forall a. a -> Maybe a
Just (Either FilePath Aspell -> Maybe Aspell)
-> IO (Either FilePath Aspell) -> IO (Maybe Aspell)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AspellOption] -> IO (Either FilePath Aspell)
startAspell [AspellOption]
aspellOpts

newSpellCheckTimer :: Aspell -> BChan MHEvent -> MessageInterfaceTarget -> IO (IO ())
newSpellCheckTimer :: Aspell -> BChan MHEvent -> MessageInterfaceTarget -> IO (IO ())
newSpellCheckTimer Aspell
checker BChan MHEvent
eventQueue MessageInterfaceTarget
target = do
    TChan ()
resetSCChan <- Aspell
-> BChan MHEvent -> MessageInterfaceTarget -> Int -> IO (TChan ())
startSpellCheckerThread Aspell
checker BChan MHEvent
eventQueue MessageInterfaceTarget
target Int
spellCheckerTimeout
    IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
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
$ TChan () -> () -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan TChan ()
resetSCChan ()

-- Start the background spell checker delay thread.
--
-- The purpose of this thread is to postpone the spell checker query
-- while the user is actively typing and only wait until they have
-- stopped typing before bothering with a query. This is to avoid spell
-- checker queries when the editor contents are changing rapidly.
-- Avoiding such queries reduces system load and redraw frequency.
--
-- We do this by starting a thread whose job is to wait for the event
-- loop to tell it to schedule a spell check. Spell checks are scheduled
-- by writing to the channel returned by this function. The scheduler
-- thread reads from that channel and then works with another worker
-- thread as follows:
--
-- A wakeup of the main spell checker thread causes it to determine
-- whether the worker thread is already waiting on a timer. When that
-- timer goes off, a spell check will be requested. If there is already
-- an active timer that has not yet expired, the timer's expiration is
-- extended. This is the case where typing is occurring and we want to
-- continue postponing the spell check. If there is not an active timer
-- or the active timer has expired, we create a new timer and send it to
-- the worker thread for waiting.
--
-- The worker thread works by reading a timer from its queue, waiting
-- until the timer expires, and then injecting an event into the main
-- event loop to request a spell check.
startSpellCheckerThread :: Aspell
                        -- ^ The spell checker handle to use
                        -> BChan MHEvent
                        -- ^ The main event loop's event channel.
                        -> MessageInterfaceTarget
                        -- ^ The target of the editor whose contents
                        -- should be spell checked
                        -> Int
                        -- ^ The number of microseconds to wait before
                        -- requesting a spell check.
                        -> IO (STM.TChan ())
startSpellCheckerThread :: Aspell
-> BChan MHEvent -> MessageInterfaceTarget -> Int -> IO (TChan ())
startSpellCheckerThread Aspell
checker BChan MHEvent
eventChan MessageInterfaceTarget
target Int
spellCheckTimeout = do
  TChan ()
delayWakeupChan <- STM (TChan ()) -> IO (TChan ())
forall a. STM a -> IO a
STM.atomically STM (TChan ())
forall a. STM (TChan a)
STM.newTChan
  TChan Delay
delayWorkerChan <- STM (TChan Delay) -> IO (TChan Delay)
forall a. STM a -> IO a
STM.atomically STM (TChan Delay)
forall a. STM (TChan a)
STM.newTChan
  TVar (Maybe Delay)
delVar <- STM (TVar (Maybe Delay)) -> IO (TVar (Maybe Delay))
forall a. STM a -> IO a
STM.atomically (STM (TVar (Maybe Delay)) -> IO (TVar (Maybe Delay)))
-> STM (TVar (Maybe Delay)) -> IO (TVar (Maybe Delay))
forall a b. (a -> b) -> a -> b
$ Maybe Delay -> STM (TVar (Maybe Delay))
forall a. a -> STM (TVar a)
STM.newTVar Maybe Delay
forall a. Maybe a
Nothing

  -- The delay worker actually waits on the delay to expire and then
  -- requests a spell check.
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Delay -> STM ()
waitDelay (Delay -> STM ()) -> STM Delay -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TChan Delay -> STM Delay
forall a. TChan a -> STM a
STM.readTChan TChan Delay
delayWorkerChan
    BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MH () -> MHEvent
RespEvent (MH () -> MHEvent) -> MH () -> MHEvent
forall a b. (a -> b) -> a -> b
$ Aspell -> MessageInterfaceTarget -> MH ()
requestSpellCheck Aspell
checker MessageInterfaceTarget
target)

  -- The delay manager waits for requests to start a delay timer and
  -- signals the worker to begin waiting.
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    () <- STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan () -> STM ()
forall a. TChan a -> STM a
STM.readTChan TChan ()
delayWakeupChan

    Maybe Delay
oldDel <- STM (Maybe Delay) -> IO (Maybe Delay)
forall a. STM a -> IO a
STM.atomically (STM (Maybe Delay) -> IO (Maybe Delay))
-> STM (Maybe Delay) -> IO (Maybe Delay)
forall a b. (a -> b) -> a -> b
$ TVar (Maybe Delay) -> STM (Maybe Delay)
forall a. TVar a -> STM a
STM.readTVar TVar (Maybe Delay)
delVar
    Maybe Delay
mNewDel <- case Maybe Delay
oldDel of
        Maybe Delay
Nothing -> Delay -> Maybe Delay
forall a. a -> Maybe a
Just (Delay -> Maybe Delay) -> IO Delay -> IO (Maybe Delay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Delay
newDelay Int
spellCheckTimeout
        Just Delay
del -> do
            -- It's possible that between this check for expiration and
            -- the updateDelay below, the timer will expire -- at which
            -- point this will mean that we won't extend the timer as
            -- originally desired. But that's alright, because future
            -- keystrokes will trigger another timer anyway.
            Bool
expired <- Delay -> IO Bool
tryWaitDelayIO Delay
del
            case Bool
expired of
                Bool
True -> Delay -> Maybe Delay
forall a. a -> Maybe a
Just (Delay -> Maybe Delay) -> IO Delay -> IO (Maybe Delay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Delay
newDelay Int
spellCheckTimeout
                Bool
False -> do
                    Delay -> Int -> IO ()
updateDelay Delay
del Int
spellCheckTimeout
                    Maybe Delay -> IO (Maybe Delay)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Delay
forall a. Maybe a
Nothing

    case Maybe Delay
mNewDel of
        Maybe Delay
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Delay
newDel -> STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            TVar (Maybe Delay) -> Maybe Delay -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Maybe Delay)
delVar (Maybe Delay -> STM ()) -> Maybe Delay -> STM ()
forall a b. (a -> b) -> a -> b
$ Delay -> Maybe Delay
forall a. a -> Maybe a
Just Delay
newDel
            TChan Delay -> Delay -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan TChan Delay
delayWorkerChan Delay
newDel

  TChan () -> IO (TChan ())
forall (m :: * -> *) a. Monad m => a -> m a
return TChan ()
delayWakeupChan

startSyntaxMapLoaderThread :: Config -> BChan MHEvent -> IO ()
startSyntaxMapLoaderThread :: Config -> BChan MHEvent -> IO ()
startSyntaxMapLoaderThread Config
config BChan MHEvent
eventChan = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    -- Iterate over the configured syntax directories, loading syntax
    -- maps. Ensure that entries loaded in earlier directories in the
    -- sequence take precedence over entries loaded later.
    [Maybe SyntaxMap]
mMaps <- [FilePath]
-> (FilePath -> IO (Maybe SyntaxMap)) -> IO [Maybe SyntaxMap]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Config -> [FilePath]
configSyntaxDirs Config
config) ((FilePath -> IO (Maybe SyntaxMap)) -> IO [Maybe SyntaxMap])
-> (FilePath -> IO (Maybe SyntaxMap)) -> IO [Maybe SyntaxMap]
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        Either SomeException (Either FilePath SyntaxMap)
result <- IO (Either FilePath SyntaxMap)
-> IO (Either SomeException (Either FilePath SyntaxMap))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Either FilePath SyntaxMap)
 -> IO (Either SomeException (Either FilePath SyntaxMap)))
-> IO (Either FilePath SyntaxMap)
-> IO (Either SomeException (Either FilePath SyntaxMap))
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Either FilePath SyntaxMap)
loadSyntaxesFromDir FilePath
dir
        case Either SomeException (Either FilePath SyntaxMap)
result of
            Left (SomeException
_::SomeException) -> Maybe SyntaxMap -> IO (Maybe SyntaxMap)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxMap
forall a. Maybe a
Nothing
            Right (Left FilePath
_)          -> Maybe SyntaxMap -> IO (Maybe SyntaxMap)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SyntaxMap
forall a. Maybe a
Nothing
            Right (Right SyntaxMap
m)         -> Maybe SyntaxMap -> IO (Maybe SyntaxMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SyntaxMap -> IO (Maybe SyntaxMap))
-> Maybe SyntaxMap -> IO (Maybe SyntaxMap)
forall a b. (a -> b) -> a -> b
$ SyntaxMap -> Maybe SyntaxMap
forall a. a -> Maybe a
Just SyntaxMap
m

    let maps :: [SyntaxMap]
maps = [Maybe SyntaxMap] -> [SyntaxMap]
forall a. [Maybe a] -> [a]
catMaybes [Maybe SyntaxMap]
mMaps
        finalMap :: SyntaxMap
finalMap = (SyntaxMap -> SyntaxMap -> SyntaxMap)
-> SyntaxMap -> [SyntaxMap] -> SyntaxMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl SyntaxMap -> SyntaxMap -> SyntaxMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union SyntaxMap
forall a. Monoid a => a
mempty [SyntaxMap]
maps

    BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ MH () -> MHEvent
RespEvent (MH () -> MHEvent) -> MH () -> MHEvent
forall a b. (a -> b) -> a -> b
$ do
        (ChatResources -> Identity ChatResources)
-> ChatState -> Identity ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Identity ChatResources)
 -> ChatState -> Identity ChatState)
-> ((SyntaxMap -> Identity SyntaxMap)
    -> ChatResources -> Identity ChatResources)
-> (SyntaxMap -> Identity SyntaxMap)
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SyntaxMap -> Identity SyntaxMap)
-> ChatResources -> Identity ChatResources
Lens' ChatResources SyntaxMap
crSyntaxMap ((SyntaxMap -> Identity SyntaxMap)
 -> ChatState -> Identity ChatState)
-> SyntaxMap -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= SyntaxMap
finalMap
        EventM Name () -> MH ()
forall a. EventM Name a -> MH a
mh EventM Name ()
forall n. Ord n => EventM n ()
invalidateCache

-------------------------------------------------------------------
-- Async worker thread

startAsyncWorkerThread :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO ()
startAsyncWorkerThread :: Config -> RequestChan -> BChan MHEvent -> IO ()
startAsyncWorkerThread Config
c RequestChan
r BChan MHEvent
e = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Config -> RequestChan -> BChan MHEvent -> IO ()
asyncWorker Config
c RequestChan
r BChan MHEvent
e

asyncWorker :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO ()
asyncWorker :: Config -> RequestChan -> BChan MHEvent -> IO ()
asyncWorker Config
c RequestChan
r BChan MHEvent
e = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> RequestChan -> BChan MHEvent -> IO ()
doAsyncWork Config
c RequestChan
r BChan MHEvent
e

doAsyncWork :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO ()
doAsyncWork :: Config -> RequestChan -> BChan MHEvent -> IO ()
doAsyncWork Config
config RequestChan
requestChan BChan MHEvent
eventChan = do
    let rateLimitNotify :: Int -> m ()
rateLimitNotify Int
sec = do
            BChan MHEvent -> MHEvent -> m ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> m ()) -> MHEvent -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> MHEvent
RateLimitExceeded Int
sec

    IO ()
startWork <- case Config -> BackgroundInfo
configShowBackground Config
config of
        BackgroundInfo
Disabled -> IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        BackgroundInfo
Active -> do Maybe (IO (Maybe (MH ())))
chk <- STM (Maybe (IO (Maybe (MH ())))) -> IO (Maybe (IO (Maybe (MH ()))))
forall a. STM a -> IO a
STM.atomically (STM (Maybe (IO (Maybe (MH ()))))
 -> IO (Maybe (IO (Maybe (MH ())))))
-> STM (Maybe (IO (Maybe (MH ()))))
-> IO (Maybe (IO (Maybe (MH ()))))
forall a b. (a -> b) -> a -> b
$ RequestChan -> STM (Maybe (IO (Maybe (MH ()))))
forall a. TChan a -> STM (Maybe a)
STM.tryPeekTChan RequestChan
requestChan
                     case Maybe (IO (Maybe (MH ())))
chk of
                       Maybe (IO (Maybe (MH ())))
Nothing -> do BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan MHEvent
BGIdle
                                     IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> MHEvent
BGBusy Maybe Int
forall a. Maybe a
Nothing
                       Maybe (IO (Maybe (MH ())))
_ -> IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        BackgroundInfo
ActiveCount -> do
          Int
chk <- STM Int -> IO Int
forall a. STM a -> IO a
STM.atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
            RequestChan
chanCopy <- RequestChan -> STM RequestChan
forall a. TChan a -> STM (TChan a)
STM.cloneTChan RequestChan
requestChan
            let cntMsgs :: STM Int
cntMsgs = do Maybe (IO (Maybe (MH ())))
m <- RequestChan -> STM (Maybe (IO (Maybe (MH ()))))
forall a. TChan a -> STM (Maybe a)
STM.tryReadTChan RequestChan
chanCopy
                             case Maybe (IO (Maybe (MH ())))
m of
                               Maybe (IO (Maybe (MH ())))
Nothing -> Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
                               Just IO (Maybe (MH ()))
_ -> (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> STM Int -> STM Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Int
cntMsgs
            STM Int
cntMsgs
          case Int
chk of
            Int
0 -> do BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan MHEvent
BGIdle
                    IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> MHEvent
BGBusy (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1))
            Int
_ -> do BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> MHEvent
BGBusy (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
chk)
                    IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    IO (Maybe (MH ()))
req <- STM (IO (Maybe (MH ()))) -> IO (IO (Maybe (MH ())))
forall a. STM a -> IO a
STM.atomically (STM (IO (Maybe (MH ()))) -> IO (IO (Maybe (MH ()))))
-> STM (IO (Maybe (MH ()))) -> IO (IO (Maybe (MH ())))
forall a b. (a -> b) -> a -> b
$ RequestChan -> STM (IO (Maybe (MH ())))
forall a. TChan a -> STM a
STM.readTChan RequestChan
requestChan
    IO ()
startWork
    -- Run the IO action with up to one additional attempt if it makes
    -- rate-limited API requests.
    Either SomeException (Maybe (Maybe (MH ())))
res <- IO (Maybe (Maybe (MH ())))
-> IO (Either SomeException (Maybe (Maybe (MH ()))))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Maybe (Maybe (MH ())))
 -> IO (Either SomeException (Maybe (Maybe (MH ())))))
-> IO (Maybe (Maybe (MH ())))
-> IO (Either SomeException (Maybe (Maybe (MH ()))))
forall a b. (a -> b) -> a -> b
$ (Int -> IO ()) -> IO (Maybe (MH ())) -> IO (Maybe (Maybe (MH ())))
forall a. (Int -> IO ()) -> IO a -> IO (Maybe a)
rateLimitRetry Int -> IO ()
forall (m :: * -> *). MonadIO m => Int -> m ()
rateLimitNotify IO (Maybe (MH ()))
req
    case Either SomeException (Maybe (Maybe (MH ())))
res of
      Left SomeException
e -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
shouldIgnore SomeException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              case SomeException -> Maybe RateLimitException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                  Just (RateLimitException
_::RateLimitException) ->
                      BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan MHEvent
RequestDropped
                  Maybe RateLimitException
Nothing -> do
                      let err :: MHError
err = case SomeException -> Maybe MattermostError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                            Maybe MattermostError
Nothing -> SomeException -> MHError
AsyncErrEvent SomeException
e
                            Just MattermostError
mmErr -> MattermostError -> MHError
ServerError MattermostError
mmErr
                      BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ InternalEvent -> MHEvent
IEvent (InternalEvent -> MHEvent) -> InternalEvent -> MHEvent
forall a b. (a -> b) -> a -> b
$ MHError -> InternalEvent
DisplayError MHError
err
      Right Maybe (Maybe (MH ()))
upd ->
          case Maybe (Maybe (MH ()))
upd of
              -- The IO action triggered a rate limit error but could
              -- not be retried due to rate limiting information being
              -- missing.
              Maybe (Maybe (MH ()))
Nothing -> BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan MHEvent
RateLimitSettingsMissing

              -- The IO action was run successfully but returned no
              -- state transformation.
              Just Maybe (MH ())
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

              -- The IO action was run successfully and returned a state
              -- transformation.
              Just (Just MH ()
action) -> BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MH () -> MHEvent
RespEvent MH ()
action)

-- | Run an IO action. If the action raises a RateLimitException, invoke
-- the provided rate limit exception handler with the rate limit window
-- size (time in seconds until rate limit resets). Then block until the
-- rate limit resets and attempt to run the action one more time.
--
-- If the rate limit exception does not contain a rate limit reset
-- interval, return Nothing. Otherwise return IO action's result.
rateLimitRetry :: (Int -> IO ()) -> IO a -> IO (Maybe a)
rateLimitRetry :: (Int -> IO ()) -> IO a -> IO (Maybe a)
rateLimitRetry Int -> IO ()
rateLimitNotify IO a
act = do
    let retry :: RateLimitException -> IO (Maybe a)
retry RateLimitException
e = do
            case RateLimitException -> Maybe Int
rateLimitExceptionReset RateLimitException
e of
                -- The rate limit exception contains no metadata so we
                -- cannot retry the action.
                Maybe Int
Nothing -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

                -- The rate limit exception contains the size of the
                -- rate limit reset interval, so block until that has
                -- passed and retry the action (only) one more time.
                Just Int
sec -> do
                    let adjusted :: Int
adjusted = Int
sec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                    Int -> IO ()
rateLimitNotify Int
adjusted
                    Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
adjusted Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
                    a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act

    (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act) IO (Maybe a)
-> (RateLimitException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` RateLimitException -> IO (Maybe a)
retry

-- Filter for exceptions that we don't want to report to the user,
-- probably because they are not actionable and/or contain no useful
-- information.
--
-- E.g.
-- https://github.com/matterhorn-chat/matterhorn/issues/391
shouldIgnore :: SomeException -> Bool
shouldIgnore :: SomeException -> Bool
shouldIgnore SomeException
e =
    let eStr :: FilePath
eStr = SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
    in [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
eStr) (FilePath -> Bool) -> [FilePath] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
ignoreErrorSubstrings

ignoreErrorSubstrings :: [String]
ignoreErrorSubstrings :: [FilePath]
ignoreErrorSubstrings =
    [ FilePath
"getAddrInfo"
    , FilePath
"Network.Socket.recvBuf"
    , FilePath
"Network.Socket.sendBuf"
    , FilePath
"resource vanished"
    , FilePath
"timeout"
    , FilePath
"partial packet"
    , FilePath
"No route to host"
    , FilePath
"(5,0,3)"
    , FilePath
"(5,0,4)"
    ]