{-# Language BangPatterns, OverloadedStrings, NondecreasingIndentation #-}
module Client.EventLoop
( eventLoop
, updateTerminalSize
) where
import qualified Client.Authentication.Ecdsa as Ecdsa
import Client.CApi
import Client.Commands
import Client.Commands.Interpolation
import Client.Configuration.ServerSettings
import Client.EventLoop.Errors (exceptionToLines)
import Client.Hook
import Client.Hooks
import Client.Image
import Client.Log
import Client.Message
import Client.Network.Async
import Client.State
import qualified Client.State.EditBox as Edit
import Client.State.Focus
import Client.State.Network
import Control.Concurrent.STM
import Control.Exception
import Control.Lens
import Control.Monad
import Data.ByteString (ByteString)
import Data.Foldable
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as Text
import Data.Time
import GHC.IO.Exception (IOErrorType(..), ioe_type)
import Graphics.Vty
import Irc.Codes
import Irc.Commands
import Irc.Message
import Irc.RawIrcMsg
import LensUtils
import Hookup
data ClientEvent
= VtyEvent Event
| NetworkEvent NetworkEvent
| TimerEvent NetworkId TimedAction
getEvent ::
Vty ->
ClientState ->
IO ClientEvent
getEvent vty st =
do timer <- prepareTimer
atomically $
asum [ timer
, VtyEvent <$> readTChan vtyEventChannel
, NetworkEvent <$> readTQueue (view clientEvents st)
]
where
vtyEventChannel = _eventChannel (inputIface vty)
prepareTimer =
case earliestEvent st of
Nothing -> return retry
Just (networkId,(runAt,action)) ->
do now <- getCurrentTime
let microsecs = truncate (1000000 * diffUTCTime runAt now)
var <- registerDelay (max 0 microsecs)
return $ do ready <- readTVar var
unless ready retry
return (TimerEvent networkId action)
earliestEvent :: ClientState -> Maybe (NetworkId, (UTCTime, TimedAction))
earliestEvent =
minimumByOf
(clientConnections . (ifolded <. folding nextTimedAction) . withIndex)
(comparing (fst . snd))
eventLoop :: Vty -> ClientState -> IO ()
eventLoop vty st =
do when (view clientBell st) (beep vty)
processLogEntries st
let (pic, st') = clientPicture (clientTick st)
update vty pic
event <- getEvent vty st'
case event of
TimerEvent networkId action -> eventLoop vty =<< doTimerEvent networkId action st'
VtyEvent vtyEvent -> traverse_ (eventLoop vty) =<< doVtyEvent vty vtyEvent st'
NetworkEvent networkEvent ->
eventLoop vty =<<
case networkEvent of
NetworkLine net time line -> doNetworkLine net time line st'
NetworkError net time ex -> doNetworkError net time ex st'
NetworkOpen net time -> doNetworkOpen net time st'
NetworkClose net time -> doNetworkClose net time st'
beep :: Vty -> IO ()
beep = ringTerminalBell . outputIface
processLogEntries :: ClientState -> IO ()
processLogEntries =
traverse_ writeLogLine . reverse . view clientLogQueue
doNetworkOpen ::
NetworkId ->
ZonedTime ->
ClientState ->
IO ClientState
doNetworkOpen networkId time st =
case view (clientConnections . at networkId) st of
Nothing -> error "doNetworkOpen: Network missing"
Just cs ->
do let msg = ClientMessage
{ _msgTime = time
, _msgNetwork = view csNetwork cs
, _msgBody = NormalBody "connection opened"
}
return $! recordNetworkMessage msg
$ overStrict (clientConnections . ix networkId . csLastReceived)
(\old -> old `seq` Just $! zonedTimeToUTC time)
st
doNetworkClose ::
NetworkId ->
ZonedTime ->
ClientState ->
IO ClientState
doNetworkClose networkId time st =
do let (cs,st') = removeNetwork networkId st
msg = ClientMessage
{ _msgTime = time
, _msgNetwork = view csNetwork cs
, _msgBody = NormalBody "connection closed"
}
return (recordNetworkMessage msg st')
doNetworkError ::
NetworkId ->
ZonedTime ->
SomeException ->
ClientState ->
IO ClientState
doNetworkError networkId time ex st =
do let (cs,st1) = removeNetwork networkId st
st2 = foldl' (\acc msg -> recordError time cs (Text.pack msg) acc) st1
$ exceptionToLines ex
reconnectLogic ex cs st2
reconnectLogic ::
SomeException ->
NetworkState ->
ClientState ->
IO ClientState
reconnectLogic ex cs st
| shouldReconnect =
do (attempts, mbDisconnectTime) <- computeRetryInfo
addConnection attempts mbDisconnectTime (view csNetwork cs) st
| otherwise = return st
where
computeRetryInfo =
case view csPingStatus cs of
PingConnecting n tm -> pure (n+1, tm)
_ | Just tm <- view csLastReceived cs -> pure (1, Just tm)
| otherwise -> do now <- getCurrentTime
pure (1, Just now)
reconnectAttempts = view (csSettings . ssReconnectAttempts) cs
shouldReconnect =
case view csPingStatus cs of
PingConnecting n _ | n == 0 || n > reconnectAttempts -> False
_ | Just ConnectionFailure{} <- fromException ex -> True
| Just HostnameResolutionFailure{} <- fromException ex -> True
| Just PingTimeout <- fromException ex -> True
| Just ResourceVanished <- ioe_type <$> fromException ex -> True
| Just NoSuchThing <- ioe_type <$> fromException ex -> True
| otherwise -> False
doNetworkLine ::
NetworkId ->
ZonedTime ->
ByteString ->
ClientState ->
IO ClientState
doNetworkLine networkId time line st =
case view (clientConnections . at networkId) st of
Nothing -> error "doNetworkLine: Network missing"
Just cs ->
let network = view csNetwork cs in
case parseRawIrcMsg (asUtf8 line) of
Nothing ->
do let msg = Text.pack ("Malformed message: " ++ show line)
return $! recordError time cs msg st
Just raw ->
do (st1,passed) <- clientPark st $ \ptr ->
notifyExtensions ptr network raw
(view (clientExtensions . esActive) st)
if not passed then return st1 else do
let time' = computeEffectiveTime time (view msgTags raw)
(stateHook, viewHook)
= over both applyMessageHooks
$ partition (view messageHookStateful)
$ lookups
(view csMessageHooks cs)
messageHooks
case stateHook (cookIrcMsg raw) of
Nothing -> return st1
Just irc ->
do
let st2 =
case viewHook irc of
Nothing -> st1
Just irc' -> recordIrcMessage network target msg st1
where
myNick = view csNick cs
target = msgTarget myNick irc
msg = ClientMessage
{ _msgTime = time'
, _msgNetwork = network
, _msgBody = IrcBody irc'
}
let (replies, st3) = applyMessageToClientState time irc networkId cs st2
traverse_ (sendMsg cs) replies
clientResponse time' irc cs st3
clientResponse :: ZonedTime -> IrcMsg -> NetworkState -> ClientState -> IO ClientState
clientResponse now irc cs st =
case irc of
Reply RPL_WELCOME _ ->
do let focus = NetworkFocus (view csNetwork cs)
st' <- foldM (processConnectCmd now cs)
(set clientFocus focus st)
(view (csSettings . ssConnectCmds) cs)
return $! set clientFocus (view clientFocus st) st'
Authenticate challenge
| AS_EcdsaWaitChallenge <- view csAuthenticationState cs ->
processSaslEcdsa now challenge cs st
_ -> return st
processSaslEcdsa ::
ZonedTime ->
Text ->
NetworkState ->
ClientState ->
IO ClientState
processSaslEcdsa now challenge cs st =
case view ssSaslEcdsaFile ss of
Nothing ->
do sendMsg cs ircCapEnd
return $! recordError now cs "panic: ecdsatool malformed output" st
Just path ->
do res <- Ecdsa.computeResponse path challenge
case res of
Left e ->
do sendMsg cs ircCapEnd
return $! recordError now cs (Text.pack e) st
Right resp ->
do sendMsg cs (ircAuthenticate resp)
return $! set asLens AS_None st
where
ss = view csSettings cs
asLens = clientConnections . ix (view csNetworkId cs) . csAuthenticationState
processConnectCmd ::
ZonedTime ->
NetworkState ->
ClientState ->
[ExpansionChunk] ->
IO ClientState
processConnectCmd now cs st0 cmdTxt =
do dc <- forM disco $ \t ->
Text.pack . formatTime defaultTimeLocale "%H:%M:%S"
<$> utcToLocalZonedTime t
let failureCase e = recordError now cs ("Bad connect-cmd: " <> e)
case resolveMacroExpansions (commandExpansion dc st0) (const Nothing) cmdTxt of
Nothing -> return $! failureCase "Unable to expand connect command" st0
Just cmdTxt' ->
do res <- executeUserCommand dc (Text.unpack cmdTxt') st0
return $! case res of
CommandFailure st -> failureCase cmdTxt' st
CommandSuccess st -> st
CommandQuit st -> st
where
disco = case view csPingStatus cs of
PingConnecting _ tm -> tm
_ -> Nothing
recordError ::
ZonedTime ->
NetworkState ->
Text ->
ClientState ->
ClientState
recordError now cs msg =
recordNetworkMessage ClientMessage
{ _msgTime = now
, _msgNetwork = view csNetwork cs
, _msgBody = ErrorBody msg
}
computeEffectiveTime :: ZonedTime -> [TagEntry] -> ZonedTime
computeEffectiveTime time tags = fromMaybe time zncTime
where
isTimeTag (TagEntry key _) = key == "time"
zncTime =
do TagEntry _ txt <- find isTimeTag tags
tagTime <- parseZncTime (Text.unpack txt)
return (utcToZonedTime (zonedTimeZone time) tagTime)
parseZncTime :: String -> Maybe UTCTime
parseZncTime = parseTimeM True defaultTimeLocale
$ iso8601DateFormat (Just "%T%Q%Z")
lookups :: Ixed m => [Index m] -> m -> [IxValue m]
lookups ks m = mapMaybe (\k -> preview (ix k) m) ks
updateTerminalSize :: Vty -> ClientState -> IO ClientState
updateTerminalSize vty st =
do (w,h) <- displayBounds (outputIface vty)
return $! set clientWidth w
$ set clientHeight h st
doVtyEvent ::
Vty ->
Event ->
ClientState ->
IO (Maybe ClientState)
doVtyEvent vty vtyEvent st =
case vtyEvent of
EvKey k modifier -> doKey vty k modifier st
EvResize{} -> Just <$> updateTerminalSize vty st
EvPaste utf8 ->
do let str = Text.unpack (Text.decodeUtf8With Text.lenientDecode utf8)
return $! Just $! over clientTextBox (Edit.insertPaste str) st
_ -> return (Just st)
doKey ::
Vty ->
Key ->
[Modifier] ->
ClientState ->
IO (Maybe ClientState)
doKey vty key modifier st =
let continue !out
| modifier == [MMeta] && key == KChar 'a' = return (Just out)
| otherwise = return $! Just $! set clientActivityReturn (view clientFocus out) out
changeEditor f = continue (over clientTextBox f st)
changeContent f = changeEditor
$ over Edit.content f
. set Edit.lastOperation Edit.OtherOperation
mbChangeEditor f =
case clientTextBox f st of
Nothing -> continue $! set clientBell True st
Just st' -> continue st'
in
case modifier of
[MCtrl] ->
case key of
KChar 'd' -> changeContent Edit.delete
KChar 'a' -> changeEditor Edit.home
KChar 'e' -> changeEditor Edit.end
KChar 'u' -> changeEditor Edit.killHome
KChar 'k' -> changeEditor Edit.killEnd
KChar 'y' -> changeEditor Edit.yank
KChar 't' -> changeContent Edit.toggle
KChar 'w' -> changeEditor (Edit.killWordBackward True)
KChar 'b' -> changeEditor (Edit.insert '\^B')
KChar 'c' -> changeEditor (Edit.insert '\^C')
KChar ']' -> changeEditor (Edit.insert '\^]')
KChar '_' -> changeEditor (Edit.insert '\^_')
KChar 'o' -> changeEditor (Edit.insert '\^O')
KChar 'v' -> changeEditor (Edit.insert '\^V')
KChar 'p' -> continue (retreatFocus st)
KChar 'n' -> continue (advanceFocus st)
KChar 'x' -> continue (advanceNetworkFocus st)
KChar 'l' -> do refresh vty
continue st
_ -> continue st
[MMeta] ->
case key of
KChar c | let names = clientWindowNames st
, Just i <- elemIndex c names ->
continue (jumpFocus i st)
KEnter -> changeEditor (Edit.insert '\^J')
KBS -> changeEditor (Edit.killWordBackward True)
KChar 'd' -> changeEditor (Edit.killWordForward True)
KChar 'b' -> changeContent Edit.leftWord
KChar 'f' -> changeContent Edit.rightWord
KLeft -> changeContent Edit.leftWord
KRight -> changeContent Edit.rightWord
KChar 'a' -> continue (jumpToActivity st)
KChar 's' -> continue (returnFocus st)
KChar 'k' -> mbChangeEditor Edit.insertDigraph
_ -> continue st
[] ->
case key of
KEsc -> continue (changeSubfocus FocusMessages st)
KBS -> changeContent Edit.backspace
KDel -> changeContent Edit.delete
KLeft -> changeContent Edit.left
KRight -> changeContent Edit.right
KHome -> changeEditor Edit.home
KEnd -> changeEditor Edit.end
KUp -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed
KDown -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed
KPageUp -> continue (scrollClient ( scrollAmount st) st)
KPageDown -> continue (scrollClient (-scrollAmount st) st)
KEnter -> doCommandResult True =<< executeInput st
KBackTab -> doCommandResult False =<< tabCompletion True st
KChar '\t' -> doCommandResult False =<< tabCompletion False st
KChar c -> changeEditor (Edit.insert c)
KFun 2 -> continue (over clientDetailView not st)
KFun 3 -> continue (over clientActivityBar not st)
KFun 4 -> continue (over clientShowMetadata not st)
_ -> continue st
_ -> continue st
doCommandResult ::
Bool ->
CommandResult ->
IO (Maybe ClientState)
doCommandResult clearOnSuccess res =
let continue !st = return (Just st) in
case res of
CommandQuit st -> Nothing <$ clientShutdown st
CommandSuccess st -> continue (if clearOnSuccess then consumeInput st else st)
CommandFailure st -> continue (set clientBell True st)
executeInput ::
ClientState ->
IO CommandResult
executeInput st = execute (clientFirstLine st) st
doTimerEvent ::
NetworkId ->
TimedAction ->
ClientState ->
IO ClientState
doTimerEvent networkId action =
traverseOf
(clientConnections . ix networkId)
(applyTimedAction action)