{-# 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, _Just )
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 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 (forall a. [a] -> Seq a
Seq.fromList [UserId]
uIds) Session
session
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq Status
statuses 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall {b}. IO b
body
  where
      seconds :: Int -> Int
seconds = (forall a. Num a => a -> a -> a
* (Int
1000 forall a. Num a => a -> a -> a
* Int
1000))
      userRefreshInterval :: Int
userRefreshInterval = Int
30
      body :: IO b
body = forall {b}. [UserId] -> IO b
refresh []
      refresh :: [UserId] -> IO b
refresh [UserId]
prev = do
          Maybe [UserId]
result <- forall a. Int -> IO a -> IO (Maybe a)
timeout (Int -> Int
seconds Int
userRefreshInterval)
                            (forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ 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 forall a. Eq a => a -> a -> Bool
/= [UserId]
prev)

          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
update forall a b. (a -> b) -> a -> b
$ do
              forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan RequestChan
requestChan forall a b. (a -> b) -> a -> b
$ do
                  Either SomeException (Maybe (MH ()))
rs <- forall e a. Exception e => IO a -> IO (Either e a)
try 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                      Right Maybe (MH ())
upd -> 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever IO ()
refresh
  where
    seconds :: NominalDiffTime -> NominalDiffTime
seconds = (forall a. Num a => a -> a -> a
* (NominalDiffTime
1000 forall a. Num a => a -> a -> a
* NominalDiffTime
1000))
    refreshIntervalMicros :: Int
refreshIntervalMicros = forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> NominalDiffTime
seconds forall a b. (a -> b) -> a -> b
$ NominalDiffTime
userTypingExpiryInterval forall a. Fractional a => a -> a -> a
/ NominalDiffTime
2
    refresh :: IO ()
refresh = do
      forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan RequestChan
requestChan forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
        UTCTime
now <- 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 :: MessageInterface n i -> MessageInterface n i
expireUsers MessageInterface n i
mi = MessageInterface n i
mi forall a b. a -> (a -> b) -> b
& forall n i. Lens' (MessageInterface n i) (EditState n)
miEditorforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n. Lens' (EditState n) EphemeralEditState
esEphemeralforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' EphemeralEditState TypingUsers
eesTypingUsers forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ UTCTime -> TypingUsers -> TypingUsers
expireTypingUsers UTCTime
expiry

        -- Expire typing user states for each channel
        Lens' ChatState ClientChannels
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ClientChannels (HashMap ChannelId ClientChannel)
chanMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ClientChannel (MessageInterface Name ())
ccMessageInterface forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall {n} {i}. MessageInterface n i -> MessageInterface n i
expireUsers

        -- Expire typing user states for each team's thread interface,
        -- if any
        Lens' ChatState (HashMap TeamId TeamState)
csTeams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TeamState (Maybe ThreadInterface)
tsThreadInterface forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Just forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall {n} {i}. MessageInterface n i -> MessageInterface n i
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 <-
              forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
STM.readTChan TChan ProgramOutput
logChan

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

                  forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan RequestChan
requestChan forall a b. (a -> b) -> a -> b
$ do
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ MHError -> MH ()
mhError 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 (forall a. a -> Maybe a
Just (FilePath
logPath, Handle
logHandle))

    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall {b}. Maybe (FilePath, Handle) -> IO b
logMonitor 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 = (forall a. Num a => a -> a -> a
* (Int -> Int
seconds Int
60))
      seconds :: Int -> Int
seconds = (forall a. Num a => a -> a -> a
* (Int
1000 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
                forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan RequestChan
requestChan forall a b. (a -> b) -> a -> b
$ do
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
                        LogCategory -> Text -> MH ()
mhLog LogCategory
LogGeneral forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ FilePath
"Could not load time zone information: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show SomeException
e
                forall (m :: * -> *) a. Monad m => a -> m a
return TimeZoneSeries
prevTz
            Right TimeZoneSeries
newTz -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TimeZoneSeries
newTz forall a. Eq a => a -> a -> Bool
/= TimeZoneSeries
prevTz) forall a b. (a -> b) -> a -> b
$
                    forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
STM.writeTChan RequestChan
requestChan forall a b. (a -> b) -> a -> b
$ do
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
                            Lens' ChatState TimeZoneSeries
timeZone forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= TimeZoneSeries
newTz
                            forall a. EventM Name ChatState a -> MH a
mh forall n s. Ord n => EventM n s ()
invalidateCache

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

        TimeZoneSeries -> IO b
timezoneMonitor TimeZoneSeries
nextTz

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

spellCheckerTimeout :: Int
spellCheckerTimeout :: Int
spellCheckerTimeout = Int
500 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Bool
True -> do
          let aspellOpts :: [AspellOption]
aspellOpts = forall a. [Maybe a] -> [a]
catMaybes [ Text -> AspellOption
UseDictionary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Config -> Maybe Text
configAspellDictionary Config
config)
                                     ]
          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ 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 <- forall a. STM a -> IO a
STM.atomically forall a. STM (TChan a)
STM.newTChan
  TChan Delay
delayWorkerChan <- forall a. STM a -> IO a
STM.atomically forall a. STM (TChan a)
STM.newTChan
  TVar (Maybe Delay)
delVar <- forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. a -> STM (TVar a)
STM.newTVar forall a. Maybe a
Nothing

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

    Maybe Delay
oldDel <- forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
STM.readTVar TVar (Maybe Delay)
delVar
    Maybe Delay
mNewDel <- case Maybe Delay
oldDel of
        Maybe Delay
Nothing -> forall a. a -> Maybe a
Just 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 -> forall a. a -> Maybe a
Just 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
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

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

  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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Config -> [FilePath]
configSyntaxDirs Config
config) forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
        Either SomeException (Either FilePath SyntaxMap)
result <- forall e a. Exception e => IO a -> IO (Either e a)
try 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Right (Left FilePath
_)          -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Right (Right SyntaxMap
m)         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just SyntaxMap
m

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

    forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan forall a b. (a -> b) -> a -> b
$ MH () -> MHEvent
RespEvent forall a b. (a -> b) -> a -> b
$ do
        Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources SyntaxMap
crSyntaxMap forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= SyntaxMap
finalMap
        forall a. EventM Name ChatState a -> MH a
mh forall n s. Ord n => EventM n s ()
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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO 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 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever 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
            forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan forall a b. (a -> b) -> a -> b
$ Int -> MHEvent
RateLimitExceeded Int
sec

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

    IO (Maybe (MH ()))
req <- forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ 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 <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. (Int -> IO ()) -> IO a -> IO (Maybe a)
rateLimitRetry forall {m :: * -> *}. MonadIO m => Int -> m ()
rateLimitNotify IO (Maybe (MH ()))
req
    case Either SomeException (Maybe (Maybe (MH ())))
res of
      Left SomeException
e -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ SomeException -> Bool
shouldIgnore SomeException
e) forall a b. (a -> b) -> a -> b
$ do
              case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                  Just (RateLimitException
_::RateLimitException) ->
                      forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan MHEvent
RequestDropped
                  Maybe RateLimitException
Nothing -> do
                      let err :: MHError
err = case 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
                      forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan forall a b. (a -> b) -> a -> b
$ InternalEvent -> MHEvent
IEvent 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 -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

              -- The IO action was run successfully and returned a state
              -- transformation.
              Just (Just MH ()
action) -> 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 :: forall a. (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Num a => a -> a -> a
+ Int
1
                    Int -> IO ()
rateLimitNotify Int
adjusted
                    Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
adjusted forall a. Num a => a -> a -> a
* Int
1000000
                    forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act

    (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act) 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 = forall a. Show a => a -> FilePath
show SomeException
e
    in forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall a b. (a -> b) -> a -> b
$ (forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
eStr) 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)"
    ]