{-# 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
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
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
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
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
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
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 ()
startSpellCheckerThread :: Aspell
-> BChan MHEvent
-> MessageInterfaceTarget
-> Int
-> 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
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)
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
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
[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
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
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
Maybe (Maybe (MH ()))
Nothing -> forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan MHEvent
RateLimitSettingsMissing
Just Maybe (MH ())
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Just MH ()
action) -> forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MH () -> MHEvent
RespEvent MH ()
action)
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
Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
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
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)"
]