{-# Language BangPatterns, OverloadedStrings, NondecreasingIndentation #-}
module Client.EventLoop
( eventLoop
, updateTerminalSize
) where
import qualified Client.Authentication.Ecdsa as Ecdsa
import Client.CApi (popTimer)
import Client.Commands
import Client.Commands.Interpolation
import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames)
import Client.Configuration.ServerSettings
import Client.Configuration.Sts
import Client.EventLoop.Actions
import Client.EventLoop.Errors (exceptionToLines)
import Client.Hook
import Client.Hooks
import Client.Image
import Client.Image.Layout (scrollAmount)
import Client.Log
import Client.Message
import Client.Network.Async
import Client.Network.Connect (ircPort)
import Client.State
import qualified Client.State.EditBox as Edit
import Client.State.Extensions
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.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 qualified Data.Text.Read 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
| ExtTimerEvent Int
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 (runAt,event) ->
do now <- getCurrentTime
let microsecs = truncate (1000000 * diffUTCTime runAt now)
var <- registerDelay (max 0 microsecs)
return $ do ready <- readTVar var
unless ready retry
return event
earliestEvent :: ClientState -> Maybe (UTCTime, ClientEvent)
earliestEvent st = earliest2 networkEvent extensionEvent
where
earliest2 (Just (time1, action1)) (Just (time2, action2))
| time1 < time2 = Just (time1, action1)
| otherwise = Just (time2, action2)
earliest2 x y = mplus x y
mkEventN (network, (time, action)) = (time, TimerEvent network action)
networkEvent =
minimumByOf
(clientConnections . (ifolded <. folding nextTimedAction) . withIndex . to mkEventN)
(comparing fst)
st
mkEventE (i, (time,_,_,_,_)) = (time, ExtTimerEvent i)
extensionEvent =
minimumByOf
(clientExtensions . esActive . (ifolded <. folding popTimer) . withIndex . to mkEventE)
(comparing fst)
st
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
ExtTimerEvent i -> eventLoop vty =<< clientExtTimer i st'
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 Nothing (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) <- clientNotifyExtensions network raw 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
Cap (CapLs _ caps)
| Just stsVal <- join (lookup "sts" caps) -> processSts stsVal cs st
Cap (CapNew caps)
| Just stsVal <- join (lookup "sts" caps) -> processSts stsVal cs st
_ -> return st
processSts ::
Text ->
NetworkState ->
ClientState ->
IO ClientState
processSts txt cs st =
case view (csSettings . ssTls) cs of
_ | views (csSettings . ssSts) not cs -> return st
UseInsecure | Just port <- mbPort -> upgradeConnection port
UseTls | Just duration <- mbDuration -> setStsPolicy duration
UseInsecureTls | Just duration <- mbDuration -> setStsPolicy duration
_ -> return st
where
entries = splitEntry <$> Text.splitOn "," txt
mbPort = readInt =<< lookup "port" entries
mbDuration = readInt =<< lookup "duration" entries
splitEntry e =
case Text.break ('=' ==) e of
(a, b) -> (a, Text.drop 1 b)
upgradeConnection port =
do abortConnection StsUpgrade (view csSocket cs)
addConnection 0 (view csLastReceived cs) (Just port) (view csNetwork cs) st
setStsPolicy duration =
do now <- getCurrentTime
let host = Text.pack (view (csSettings . ssHostName) cs)
port = fromIntegral (ircPort (view csSettings cs))
policy = StsPolicy
{ _stsExpiration = addUTCTime (fromIntegral duration) now
, _stsPort = port }
st' = st & clientStsPolicy . at host ?~ policy
savePolicyFile (view clientStsPolicy st')
return st'
readInt :: Text -> Maybe Int
readInt x =
case Text.decimal x of
Right (n, t) | Text.null t -> Just n
_ -> Nothing
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 ->
let cfg = view clientConfig st
keymap = view configKeyMap cfg
winnames = view configWindowNames cfg
winmods = view configJumpModifier cfg
action = keyToAction keymap winmods winnames modifier k
in doAction vty action 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)
doAction ::
Vty ->
Action ->
ClientState ->
IO (Maybe ClientState)
doAction vty action st =
let continue !out
| action == ActJumpToActivity =
let upd Nothing = Just $! view clientFocus st
upd x = x
in return $! Just $! over clientActivityReturn upd out
| otherwise = return (Just out)
changeEditor f = continue (over clientTextBox f st)
changeContent f = changeEditor
$ over Edit.content f
. set Edit.lastOperation Edit.OtherOperation
mbChangeEditor f =
case traverseOf clientTextBox f st of
Nothing -> continue $! set clientBell True st
Just st' -> continue st'
in
case action of
ActHome -> changeEditor Edit.home
ActEnd -> changeEditor Edit.end
ActLeft -> changeContent Edit.left
ActRight -> changeContent Edit.right
ActBackWord -> changeContent Edit.leftWord
ActForwardWord -> changeContent Edit.rightWord
ActKillHome -> changeEditor Edit.killHome
ActKillEnd -> changeEditor Edit.killEnd
ActKillWordBack -> changeEditor (Edit.killWordBackward True)
ActKillWordForward -> changeEditor (Edit.killWordForward True)
ActYank -> changeEditor Edit.yank
ActToggle -> changeContent Edit.toggle
ActDelete -> changeContent Edit.delete
ActBackspace -> changeContent Edit.backspace
ActBold -> changeEditor (Edit.insert '\^B')
ActColor -> changeEditor (Edit.insert '\^C')
ActItalic -> changeEditor (Edit.insert '\^]')
ActUnderline -> changeEditor (Edit.insert '\^_')
ActClearFormat -> changeEditor (Edit.insert '\^O')
ActReverseVideo -> changeEditor (Edit.insert '\^V')
ActDigraph -> mbChangeEditor Edit.insertDigraph
ActInsertEnter -> changeEditor (Edit.insert '\^J')
ActJump i -> continue (jumpFocus i st)
ActJumpToActivity -> continue (jumpToActivity st)
ActJumpPrevious -> continue (returnFocus st)
ActRetreatFocus -> continue (retreatFocus st)
ActAdvanceFocus -> continue (advanceFocus st)
ActAdvanceNetwork -> continue (advanceNetworkFocus st)
ActReset -> continue (changeSubfocus FocusMessages st)
ActOlderLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed
ActNewerLine -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed
ActScrollUp -> continue (scrollClient ( scrollAmount st) st)
ActScrollDown -> continue (scrollClient (-scrollAmount st) st)
ActTabCompleteBack -> doCommandResult False =<< tabCompletion True st
ActTabComplete -> doCommandResult False =<< tabCompletion False st
ActInsert c -> changeEditor (Edit.insert c)
ActEnter -> doCommandResult True =<< executeInput st
ActRefresh -> refresh vty >> continue st
ActCommand cmd -> do resp <- executeUserCommand Nothing (Text.unpack cmd) st
case resp of
CommandSuccess st1 -> continue st1
CommandFailure st1 -> continue st1
CommandQuit _ -> return Nothing
ActIgnored -> 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)
clientShutdown :: ClientState -> IO ()
clientShutdown st = () <$ clientStopExtensions 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)