{-# 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 [UserId] -> Bool
forall a. [a] -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ 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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 = 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 b. Integral b => NominalDiffTime -> b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ do
UTCTime
now <- IO UTCTime -> MH UTCTime
forall a. IO a -> MH a
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 MessageInterface n i
-> (MessageInterface n i -> MessageInterface n i)
-> MessageInterface n i
forall a b. a -> (a -> b) -> b
& (EditState n -> Identity (EditState n))
-> MessageInterface n i -> Identity (MessageInterface n i)
forall n i (f :: * -> *).
Functor f =>
(EditState n -> f (EditState n))
-> MessageInterface n i -> f (MessageInterface n i)
miEditor((EditState n -> Identity (EditState n))
-> MessageInterface n i -> Identity (MessageInterface n i))
-> ((TypingUsers -> Identity TypingUsers)
-> EditState n -> Identity (EditState n))
-> (TypingUsers -> Identity TypingUsers)
-> MessageInterface n i
-> Identity (MessageInterface n i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EphemeralEditState -> Identity EphemeralEditState)
-> EditState n -> Identity (EditState n)
forall n (f :: * -> *).
Functor f =>
(EphemeralEditState -> f EphemeralEditState)
-> EditState n -> f (EditState n)
esEphemeral((EphemeralEditState -> Identity EphemeralEditState)
-> EditState n -> Identity (EditState n))
-> ((TypingUsers -> Identity TypingUsers)
-> EphemeralEditState -> Identity EphemeralEditState)
-> (TypingUsers -> Identity TypingUsers)
-> EditState n
-> Identity (EditState n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(TypingUsers -> Identity TypingUsers)
-> EphemeralEditState -> Identity EphemeralEditState
Lens' EphemeralEditState TypingUsers
eesTypingUsers ((TypingUsers -> Identity TypingUsers)
-> MessageInterface n i -> Identity (MessageInterface n i))
-> (TypingUsers -> TypingUsers)
-> MessageInterface n i
-> MessageInterface n i
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)
-> ((MessageInterface Name ()
-> Identity (MessageInterface Name ()))
-> ClientChannels -> Identity ClientChannels)
-> (MessageInterface Name ()
-> Identity (MessageInterface Name ()))
-> 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)
-> ((MessageInterface Name ()
-> Identity (MessageInterface Name ()))
-> HashMap ChannelId ClientChannel
-> Identity (HashMap ChannelId ClientChannel))
-> (MessageInterface Name ()
-> Identity (MessageInterface Name ()))
-> ClientChannels
-> Identity ClientChannels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
(HashMap ChannelId ClientChannel)
(HashMap ChannelId ClientChannel)
ClientChannel
ClientChannel
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped ASetter
(HashMap ChannelId ClientChannel)
(HashMap ChannelId ClientChannel)
ClientChannel
ClientChannel
-> ((MessageInterface Name ()
-> Identity (MessageInterface Name ()))
-> ClientChannel -> Identity ClientChannel)
-> (MessageInterface Name ()
-> Identity (MessageInterface Name ()))
-> HashMap ChannelId ClientChannel
-> Identity (HashMap ChannelId ClientChannel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MessageInterface Name () -> Identity (MessageInterface Name ()))
-> ClientChannel -> Identity ClientChannel
Lens' ClientChannel (MessageInterface Name ())
ccMessageInterface ((MessageInterface Name () -> Identity (MessageInterface Name ()))
-> ChatState -> Identity ChatState)
-> (MessageInterface Name () -> MessageInterface Name ()) -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= MessageInterface Name () -> MessageInterface Name ()
forall {n} {i}. MessageInterface n i -> MessageInterface n i
expireUsers
(HashMap TeamId TeamState -> Identity (HashMap TeamId TeamState))
-> ChatState -> Identity ChatState
Lens' ChatState (HashMap TeamId TeamState)
csTeams ((HashMap TeamId TeamState -> Identity (HashMap TeamId TeamState))
-> ChatState -> Identity ChatState)
-> ((ThreadInterface -> Identity ThreadInterface)
-> HashMap TeamId TeamState -> Identity (HashMap TeamId TeamState))
-> (ThreadInterface -> Identity ThreadInterface)
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
(HashMap TeamId TeamState)
(HashMap TeamId TeamState)
TeamState
TeamState
forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped ASetter
(HashMap TeamId TeamState)
(HashMap TeamId TeamState)
TeamState
TeamState
-> ((ThreadInterface -> Identity ThreadInterface)
-> TeamState -> Identity TeamState)
-> (ThreadInterface -> Identity ThreadInterface)
-> HashMap TeamId TeamState
-> Identity (HashMap TeamId TeamState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> TeamState -> Identity TeamState
Lens' TeamState (Maybe ThreadInterface)
tsThreadInterface ((Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> TeamState -> Identity TeamState)
-> ((ThreadInterface -> Identity ThreadInterface)
-> Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> (ThreadInterface -> Identity ThreadInterface)
-> TeamState
-> Identity TeamState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ThreadInterface -> Identity ThreadInterface)
-> Maybe ThreadInterface -> Identity (Maybe ThreadInterface)
forall a a' (f :: * -> *).
Applicative f =>
(a -> f a') -> Maybe a -> f (Maybe a')
_Just ((ThreadInterface -> Identity ThreadInterface)
-> ChatState -> Identity ChatState)
-> (ThreadInterface -> ThreadInterface) -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ThreadInterface -> ThreadInterface
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 <-
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
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ MHError -> MH ()
mhError (MHError -> MH ()) -> MHError -> MH ()
forall a b. (a -> b) -> a -> b
$ 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
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MH ()) -> IO (Maybe (MH ())))
-> Maybe (MH ()) -> IO (Maybe (MH ()))
forall a b. (a -> b) -> a -> b
$ MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ 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 ChatState () -> MH ()
forall a. EventM Name ChatState a -> MH a
mh EventM Name ChatState ()
forall n s. Ord n => EventM n s ()
invalidateCache
TimeZoneSeries -> IO TimeZoneSeries
forall a. a -> IO a
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
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 a. a -> IO a
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 a. a -> IO a
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 ()
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 <- 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
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)
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
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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
[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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 b a. (b -> a -> b) -> b -> [a] -> b
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 ChatState () -> MH ()
forall a. EventM Name ChatState a -> MH a
mh EventM Name ChatState ()
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 = 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
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 a. a -> STM a
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
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
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
Maybe (Maybe (MH ()))
Nothing -> BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan MHEvent
RateLimitSettingsMissing
Just Maybe (MH ())
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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)
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 -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
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
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)"
]