{-# Language BangPatterns, OverloadedStrings, NondecreasingIndentation, PatternSynonyms #-}

{-|
Module      : Client.EventLoop
Description : Event loop for IRC client
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module is responsible for dispatching user-input, network, and timer
events to the correct module. It renders the user interface once per event.
-}

module Client.EventLoop
  ( eventLoop
  , updateTerminalSize
  , ClientEvent(..)
  ) where

import Client.CApi (ThreadEntry, popTimer)
import Client.Commands (CommandResult(..), execute, executeUserCommand, tabCompletion)
import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames, configDigraphs, configNotifications)
import Client.Configuration.Notifications (notifyCmd)
import Client.Configuration.ServerSettings ( ssReconnectAttempts )
import Client.EventLoop.Actions (keyToAction, Action(..))
import Client.EventLoop.Errors (exceptionToLines)
import Client.EventLoop.Network (clientResponse)
import Client.Hook (applyMessageHooks, messageHookStateful)
import Client.Image (clientPicture)
import Client.Image.Layout (scrollAmount)
import Client.Image.StatusLine (clientTitle)
import Client.Log ( writeLogLine )
import Client.Message
import Client.Network.Async
import Client.State
import Client.State.EditBox qualified as Edit
import Client.State.Extensions
import Client.State.Focus (Subfocus(FocusMessages))
import Client.State.Network
import Control.Concurrent.STM
import Control.Exception (SomeException, Exception(fromException), catch)
import Control.Lens
import Control.Monad (when, MonadPlus(mplus), foldM, unless, void)
import Data.ByteString (ByteString)
import Data.Char (isSpace)
import Data.Foldable (Foldable(foldl'), find, asum, traverse_)
import Data.HashMap.Strict qualified as HashMap
import Data.List (partition)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Encoding.Error qualified as Text
import Data.Time
import Data.Time.Format.ISO8601 (formatParseM, iso8601Format)
import Data.Traversable (for)
import GHC.IO.Exception (IOErrorType(..), ioe_type)
import Graphics.Vty
import Hookup (ConnectionFailure(..))
import Irc.Codes (pattern RPL_STARTTLS)
import Irc.Message (IrcMsg(Reply, Notice), cookIrcMsg, msgTarget)
import Irc.RawIrcMsg (RawIrcMsg, TagEntry(..), asUtf8, msgTags, parseRawIrcMsg)
import LensUtils (setStrict)
import System.Process.Typed (startProcess, setStdin, setStdout, setStderr, nullStream)


-- | Sum of the five possible event types the event loop handles
data ClientEvent
  = VtyEvent InternalEvent -- ^ Key presses and resizing
  | NetworkEvents (NonEmpty (Text, NetworkEvent)) -- ^ Incoming network events
  | TimerEvent Text TimedAction      -- ^ Timed action and the applicable network
  | ExtTimerEvent Int                     -- ^ extension ID
  | ThreadEvent Int ThreadEntry


-- | Block waiting for the next 'ClientEvent'. This function will compute
-- an appropriate timeout based on the current connections.
getEvent ::
  Vty         {- ^ vty handle   -} ->
  ClientState {- ^ client state -} ->
  IO ClientEvent
getEvent :: Vty -> ClientState -> IO ClientEvent
getEvent Vty
vty ClientState
st =
  do STM ClientEvent
timer <- IO (STM ClientEvent)
prepareTimer
     forall a. STM a -> IO a
atomically (forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [STM ClientEvent
timer, STM ClientEvent
vtyEvent, STM ClientEvent
networkEvents, STM ClientEvent
threadJoin])
  where
    vtyEvent :: STM ClientEvent
vtyEvent = InternalEvent -> ClientEvent
VtyEvent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM a
readTChan (Input -> TChan InternalEvent
eventChannel (Vty -> Input
inputIface Vty
vty))

    networkEvents :: STM ClientEvent
networkEvents =
      do [[(Text, NetworkEvent)]]
xs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall k v. HashMap k v -> [(k, v)]
HashMap.toList (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState (HashMap Text NetworkState)
clientConnections ClientState
st)) forall a b. (a -> b) -> a -> b
$ \(Text
network, NetworkState
conn) ->
           do [NetworkEvent]
ys <- NetworkConnection -> STM [NetworkEvent]
recv (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState NetworkConnection
csSocket NetworkState
conn)
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map ((,) Text
network) [NetworkEvent]
ys)
         case forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, NetworkEvent)]]
xs) of
           Just NonEmpty (Text, NetworkEvent)
events1 -> forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty (Text, NetworkEvent) -> ClientEvent
NetworkEvents NonEmpty (Text, NetworkEvent)
events1)
           Maybe (NonEmpty (Text, NetworkEvent))
Nothing      -> forall a. STM a
retry

    prepareTimer :: IO (STM ClientEvent)
prepareTimer =
      case ClientState -> Maybe (UTCTime, ClientEvent)
earliestEvent ClientState
st of
        Maybe (UTCTime, ClientEvent)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. STM a
retry
        Just (UTCTime
runAt,ClientEvent
event) ->
          do UTCTime
now <- IO UTCTime
getCurrentTime
             let microsecs :: Int
microsecs = forall a b. (RealFrac a, Integral b) => a -> b
truncate (NominalDiffTime
1000000 forall a. Num a => a -> a -> a
* UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
runAt UTCTime
now)
             TVar Bool
var <- Int -> IO (TVar Bool)
registerDelay (forall a. Ord a => a -> a -> a
max Int
0 Int
microsecs)
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do Bool
ready <- forall a. TVar a -> STM a
readTVar TVar Bool
var
                         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ready forall a. STM a
retry
                         forall (m :: * -> *) a. Monad m => a -> m a
return ClientEvent
event

    threadJoin :: STM ClientEvent
threadJoin =
      do (Int
i,ThreadEntry
r) <- forall a. TQueue a -> STM a
readTQueue (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState (TQueue (Int, ThreadEntry))
clientThreadJoins ClientState
st)
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ThreadEntry -> ClientEvent
ThreadEvent Int
i ThreadEntry
r)

-- | Compute the earliest scheduled timed action for the client
earliestEvent :: ClientState -> Maybe (UTCTime, ClientEvent)
earliestEvent :: ClientState -> Maybe (UTCTime, ClientEvent)
earliestEvent ClientState
st = forall {a} {b}.
Ord a =>
Maybe (a, b) -> Maybe (a, b) -> Maybe (a, b)
earliest2 Maybe (UTCTime, ClientEvent)
networkEvent Maybe (UTCTime, ClientEvent)
extensionEvent
  where
    earliest2 :: Maybe (a, b) -> Maybe (a, b) -> Maybe (a, b)
earliest2 (Just (a
time1, b
action1)) (Just (a
time2, b
action2))
      | a
time1 forall a. Ord a => a -> a -> Bool
< a
time2 = forall a. a -> Maybe a
Just (a
time1, b
action1)
      | Bool
otherwise     = forall a. a -> Maybe a
Just (a
time2, b
action2)
    earliest2 Maybe (a, b)
x Maybe (a, b)
y = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe (a, b)
x Maybe (a, b)
y

    mkEventN :: (Text, (a, TimedAction)) -> (a, ClientEvent)
mkEventN (Text
network, (a
time, TimedAction
action)) = (a
time, Text -> TimedAction -> ClientEvent
TimerEvent Text
network TimedAction
action)
    networkEvent :: Maybe (UTCTime, ClientEvent)
networkEvent =
      forall a s.
Getting (Endo (Endo (Maybe a))) s a
-> (a -> a -> Ordering) -> s -> Maybe a
minimumByOf
        (Lens' ClientState (HashMap Text NetworkState)
clientConnections forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall i (f :: * -> *) a.
FoldableWithIndex i f =>
IndexedFold i (f a) a
ifolded forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding NetworkState -> Maybe (UTCTime, TimedAction)
nextTimedAction) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i (p :: * -> * -> *) (f :: * -> *) s j t.
(Indexable i p, Functor f) =>
p (i, s) (f (j, t)) -> Indexed i s (f t)
withIndex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall {a}. (Text, (a, TimedAction)) -> (a, ClientEvent)
mkEventN)
        (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)
        ClientState
st

    mkEventE :: (Int, (a, b, c, d, e)) -> (a, ClientEvent)
mkEventE (Int
i, (a
time,b
_,c
_,d
_,e
_)) = (a
time, Int -> ClientEvent
ExtTimerEvent Int
i)
    extensionEvent :: Maybe (UTCTime, ClientEvent)
extensionEvent =
      forall a s.
Getting (Endo (Endo (Maybe a))) s a
-> (a -> a -> Ordering) -> s -> Maybe a
minimumByOf
        (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall i (f :: * -> *) a.
FoldableWithIndex i f =>
IndexedFold i (f a) a
ifolded forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding ActiveExtension
-> Maybe
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
popTimer) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i (p :: * -> * -> *) (f :: * -> *) s j t.
(Indexable i p, Functor f) =>
p (i, s) (f (j, t)) -> Indexed i s (f t)
withIndex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall {a} {b} {c} {d} {e}.
(Int, (a, b, c, d, e)) -> (a, ClientEvent)
mkEventE)
        (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)
        ClientState
st

-- | Apply this function to an initial 'ClientState' to launch the client.
eventLoop :: Vty -> ClientState -> IO ()
eventLoop :: Vty -> ClientState -> IO ()
eventLoop Vty
vty ClientState
st =
  do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Bool
clientBell ClientState
st) (Vty -> IO ()
beep Vty
vty)
     ClientState -> IO ()
processNotifications ClientState
st
     ClientState -> IO ()
processLogEntries ClientState
st

     let (Picture
pic, ClientState
st') = ClientState -> (Picture, ClientState)
clientPicture (ClientState -> ClientState
clientTick ClientState
st)
     Vty -> Picture -> IO ()
update Vty
vty Picture
pic
     Vty -> String -> IO ()
setWindowTitle Vty
vty (ClientState -> String
clientTitle ClientState
st)

     ClientEvent
event <- Vty -> ClientState -> IO ClientEvent
getEvent Vty
vty ClientState
st'
     case ClientEvent
event of
       ExtTimerEvent Int
i ->
         Vty -> ClientState -> IO ()
eventLoop Vty
vty forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> ClientState -> IO ClientState
clientExtTimer Int
i ClientState
st'
       ThreadEvent Int
i ThreadEntry
result ->
         Vty -> ClientState -> IO ()
eventLoop Vty
vty forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> ThreadEntry -> ClientState -> IO ClientState
clientThreadJoin Int
i ThreadEntry
result ClientState
st'
       TimerEvent Text
networkId TimedAction
action ->
         Vty -> ClientState -> IO ()
eventLoop Vty
vty forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> TimedAction -> ClientState -> IO ClientState
doTimerEvent Text
networkId TimedAction
action ClientState
st'
       VtyEvent (InputEvent Event
vtyEvent) ->
         forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Vty -> ClientState -> IO ()
eventLoop Vty
vty) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Vty -> Event -> ClientState -> IO (Maybe ClientState)
doVtyEvent Vty
vty Event
vtyEvent ClientState
st'
       VtyEvent InternalEvent
ResumeAfterInterrupt ->
         Vty -> ClientState -> IO ()
eventLoop Vty
vty forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Vty -> ClientState -> IO ClientState
updateTerminalSize Vty
vty ClientState
st
       NetworkEvents NonEmpty (Text, NetworkEvent)
networkEvents ->
         Vty -> ClientState -> IO ()
eventLoop Vty
vty forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ClientState -> (Text, NetworkEvent) -> IO ClientState
doNetworkEvent ClientState
st' NonEmpty (Text, NetworkEvent)
networkEvents

-- | Apply a single network event to the client state.
doNetworkEvent :: ClientState -> (Text, NetworkEvent) -> IO ClientState
doNetworkEvent :: ClientState -> (Text, NetworkEvent) -> IO ClientState
doNetworkEvent ClientState
st (Text
net, NetworkEvent
networkEvent) =
  case NetworkEvent
networkEvent of
    NetworkLine  ZonedTime
time ByteString
line -> Text -> ZonedTime -> ByteString -> ClientState -> IO ClientState
doNetworkLine  Text
net ZonedTime
time ByteString
line ClientState
st
    NetworkError ZonedTime
time SomeException
ex   -> Text -> ZonedTime -> SomeException -> ClientState -> IO ClientState
doNetworkError Text
net ZonedTime
time SomeException
ex ClientState
st
    NetworkOpen  ZonedTime
time      -> Text -> ZonedTime -> ClientState -> IO ClientState
doNetworkOpen  Text
net ZonedTime
time ClientState
st
    NetworkTLS   [Text]
txts      -> Text -> [Text] -> ClientState -> IO ClientState
doNetworkTLS   Text
net [Text]
txts ClientState
st
    NetworkClose ZonedTime
time      -> Text -> ZonedTime -> ClientState -> IO ClientState
doNetworkClose Text
net ZonedTime
time ClientState
st

-- | Sound the terminal bell assuming that the @BEL@ control code
-- is supported.
beep :: Vty -> IO ()
beep :: Vty -> IO ()
beep = Output -> IO ()
ringTerminalBell forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vty -> Output
outputIface

processLogEntries :: ClientState -> IO ()
processLogEntries :: ClientState -> IO ()
processLogEntries =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ LogLine -> IO ()
writeLogLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState [LogLine]
clientLogQueue

processNotifications :: ClientState -> IO ()
processNotifications :: ClientState -> IO ()
processNotifications ClientState
st =
  case NotifyWith -> Maybe ((Text, Text) -> ProcessConfig () () ())
notifyCmd (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState Configuration
clientConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Configuration NotifyWith
configNotifications) ClientState
st) of
    Just (Text, Text) -> ProcessConfig () () ()
cmd | Bool -> Bool
not (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Bool
clientUiFocused ClientState
st) -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall {p} {stdin0} {stdout0} {stderr0}.
(p -> ProcessConfig stdin0 stdout0 stderr0) -> p -> IO ()
spawn (Text, Text) -> ProcessConfig () () ()
cmd) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState [(Text, Text)]
clientNotifications ClientState
st)
    Maybe ((Text, Text) -> ProcessConfig () () ())
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    -- TODO: May be a nicer way to handle notification failure than just silently squashing the exception
    handleException :: SomeException -> IO ()
    handleException :: SomeException -> IO ()
handleException SomeException
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    spawn :: (p -> ProcessConfig stdin0 stdout0 stderr0) -> p -> IO ()
spawn p -> ProcessConfig stdin0 stdout0 stderr0
cmd p
pair = do
      let procCfg :: ProcessConfig () () ()
procCfg = forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream forall a b. (a -> b) -> a -> b
$ p -> ProcessConfig stdin0 stdout0 stderr0
cmd p
pair
      -- Maybe find a nicer way to get an error out of here.
      forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr
-> m (Process stdin stdout stderr)
startProcess ProcessConfig () () ()
procCfg)) SomeException -> IO ()
handleException

-- | Respond to a network connection successfully connecting.
doNetworkOpen ::
  Text        {- ^ network name -} ->
  ZonedTime   {- ^ event time   -} ->
  ClientState {- ^ client state -} ->
  IO ClientState
doNetworkOpen :: Text -> ZonedTime -> ClientState -> IO ClientState
doNetworkOpen Text
networkId ZonedTime
time ClientState
st =
  case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState (HashMap Text NetworkState)
clientConnections forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
networkId) ClientState
st of
    Maybe NetworkState
Nothing -> forall a. HasCallStack => String -> a
error String
"doNetworkOpen: Network missing"
    Just NetworkState
cs ->
      do let msg :: ClientMessage
msg = ClientMessage
                     { _msgTime :: ZonedTime
_msgTime    = ZonedTime
time
                     , _msgNetwork :: Text
_msgNetwork = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs
                     , _msgBody :: MessageBody
_msgBody    = Text -> MessageBody
NormalBody Text
"connection opened"
                     }
         let cs' :: NetworkState
cs' = NetworkState
cs forall a b. a -> (a -> b) -> b
& Lens' NetworkState (Maybe UTCTime)
csLastReceived forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
time)
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ClientMessage -> ClientState -> ClientState
recordNetworkMessage ClientMessage
msg
                 forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
setStrict (Lens' ClientState (HashMap Text NetworkState)
clientConnections forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
networkId) NetworkState
cs' ClientState
st

-- | Update the TLS certificates for a connection
doNetworkTLS ::
  Text   {- ^ network name      -} ->
  [Text] {- ^ certificate lines -} ->
  ClientState ->
  IO ClientState
doNetworkTLS :: Text -> [Text] -> ClientState -> IO ClientState
doNetworkTLS Text
network [Text]
cert ClientState
st =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' ClientState (HashMap Text NetworkState)
clientConnections forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
network) NetworkState -> NetworkState
upd ClientState
st
  where
    upd :: NetworkState -> NetworkState
upd = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState [Text]
csCertificate [Text]
cert
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState PingStatus
csPingStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' PingStatus (Int, Maybe UTCTime, ConnectRestriction)
_PingConnecting forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
_3) ConnectRestriction
NoRestriction

-- | Respond to a network connection closing normally.
doNetworkClose ::
  Text        {- ^ network name -} ->
  ZonedTime   {- ^ event time   -} ->
  ClientState {- ^ client state -} ->
  IO ClientState
doNetworkClose :: Text -> ZonedTime -> ClientState -> IO ClientState
doNetworkClose Text
networkId ZonedTime
time ClientState
st =
  do let (NetworkState
cs,ClientState
st1) = Text -> ClientState -> (NetworkState, ClientState)
removeNetwork Text
networkId ClientState
st
         msg :: ClientMessage
msg = ClientMessage
                 { _msgTime :: ZonedTime
_msgTime    = ZonedTime
time
                 , _msgNetwork :: Text
_msgNetwork = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs
                 , _msgBody :: MessageBody
_msgBody    = Text -> MessageBody
NormalBody Text
"connection closed"
                 }
     forall (m :: * -> *) a. Monad m => a -> m a
return (ClientMessage -> ClientState -> ClientState
recordNetworkMessage ClientMessage
msg ClientState
st1)


-- | Respond to a network connection closing abnormally.
doNetworkError ::
  Text          {- ^ failed network     -} ->
  ZonedTime     {- ^ current time       -} ->
  SomeException {- ^ termination reason -} ->
  ClientState   {- ^ client state       -} ->
  IO ClientState
doNetworkError :: Text -> ZonedTime -> SomeException -> ClientState -> IO ClientState
doNetworkError Text
networkId ZonedTime
time SomeException
ex ClientState
st =
  do let (NetworkState
cs,ClientState
st1) = Text -> ClientState -> (NetworkState, ClientState)
removeNetwork Text
networkId ClientState
st
         st2 :: ClientState
st2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ClientState
acc String
msg -> ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
time (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs) (String -> Text
Text.pack String
msg) ClientState
acc) ClientState
st1
             forall a b. (a -> b) -> a -> b
$ SomeException -> NonEmpty String
exceptionToLines SomeException
ex
     SomeException -> NetworkState -> ClientState -> IO ClientState
reconnectLogicOnFailure SomeException
ex NetworkState
cs ClientState
st2

reconnectLogicOnFailure ::
  SomeException {- ^ thread failure reason -} ->
  NetworkState  {- ^ failed network        -} ->
  ClientState   {- ^ client state          -} ->
  IO ClientState
reconnectLogicOnFailure :: SomeException -> NetworkState -> ClientState -> IO ClientState
reconnectLogicOnFailure SomeException
ex NetworkState
cs ClientState
st

  | Bool
shouldReconnect =
      do (Int
attempts, Maybe UTCTime
mbDisconnectTime) <- IO (Int, Maybe UTCTime)
computeRetryInfo
         Int
-> Maybe UTCTime
-> Maybe Int
-> Text
-> ClientState
-> IO ClientState
addConnection Int
attempts Maybe UTCTime
mbDisconnectTime forall a. Maybe a
Nothing (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs) ClientState
st

  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st

  where
    computeRetryInfo :: IO (Int, Maybe UTCTime)
computeRetryInfo =
      case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs of
        PingConnecting Int
n Maybe UTCTime
tm ConnectRestriction
_                 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
nforall a. Num a => a -> a -> a
+Int
1, Maybe UTCTime
tm)
        PingStatus
_ | Just UTCTime
tm <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState (Maybe UTCTime)
csLastReceived NetworkState
cs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, forall a. a -> Maybe a
Just UTCTime
tm)
          | Bool
otherwise                         -> do UTCTime
now <- IO UTCTime
getCurrentTime
                                                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, forall a. a -> Maybe a
Just UTCTime
now)

    reconnectAttempts :: Int
reconnectAttempts = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState ServerSettings
csSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ServerSettings Int
ssReconnectAttempts) NetworkState
cs

    shouldReconnect :: Bool
shouldReconnect =
      case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs of
        PingConnecting Int
n Maybe UTCTime
_ ConnectRestriction
_ | Int
n forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
n forall a. Ord a => a -> a -> Bool
> Int
reconnectAttempts        -> Bool
False
        PingStatus
_ | Just ConnectionFailure{}         <-      forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Just HostnameResolutionFailure{} <-      forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Just TerminationReason
PingTimeout         <-              forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Just IOErrorType
ResourceVanished    <- IOException -> IOErrorType
ioe_type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Just IOErrorType
NoSuchThing         <- IOException -> IOErrorType
ioe_type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Bool
otherwise                                                 -> Bool
False


-- | Respond to an IRC protocol line. This will parse the message, updated the
-- relevant connection state and update the UI buffers.
doNetworkLine ::
  Text        {- ^ Network name                     -} ->
  ZonedTime   {- ^ current time                     -} ->
  ByteString  {- ^ Raw IRC message without newlines -} ->
  ClientState {- ^ client state                     -} ->
  IO ClientState
doNetworkLine :: Text -> ZonedTime -> ByteString -> ClientState -> IO ClientState
doNetworkLine Text
networkId ZonedTime
time ByteString
line ClientState
st =
  case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState (HashMap Text NetworkState)
clientConnections forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
networkId) ClientState
st of
    Maybe NetworkState
Nothing -> forall a. HasCallStack => String -> a
error String
"doNetworkLine: Network missing"
    Just NetworkState
cs ->
      let network :: Text
network = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs in
      case Text -> Maybe RawIrcMsg
parseRawIrcMsg (ByteString -> Text
asUtf8 ByteString
line) of
        Maybe RawIrcMsg
_ | PingConnecting Int
_ Maybe UTCTime
_ ConnectRestriction
WaitTLSRestriction <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs ->
          ClientState
st forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TerminationReason -> NetworkConnection -> IO ()
abortConnection TerminationReason
StartTLSFailed (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState NetworkConnection
csSocket NetworkState
cs)

        Just RawIrcMsg
raw
          | PingConnecting Int
_ Maybe UTCTime
_ ConnectRestriction
StartTLSRestriction <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs ->
          Text -> NetworkState -> ClientState -> RawIrcMsg -> IO ClientState
startTLSLine Text
networkId NetworkState
cs ClientState
st RawIrcMsg
raw

        Maybe RawIrcMsg
Nothing ->
          do let msg :: Text
msg = String -> Text
Text.pack (String
"Malformed message: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
line)
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
time Text
network Text
msg ClientState
st

        Just RawIrcMsg
raw ->
          do (ClientState
st1,Bool
passed) <- Text -> RawIrcMsg -> ClientState -> IO (ClientState, Bool)
clientNotifyExtensions Text
network RawIrcMsg
raw ClientState
st

             if Bool -> Bool
not Bool
passed then forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st1 else do

             let time' :: ZonedTime
time' = ZonedTime -> [TagEntry] -> ZonedTime
computeEffectiveTime ZonedTime
time (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags RawIrcMsg
raw)

                 (IrcMsg -> Maybe IrcMsg
stateHook, IrcMsg -> Maybe IrcMsg
viewHook)
                      = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both [MessageHook] -> IrcMsg -> Maybe IrcMsg
applyMessageHooks
                      forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' MessageHook Bool
messageHookStateful)
                      forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState [MessageHook]
csMessageHooks NetworkState
cs

             case IrcMsg -> Maybe IrcMsg
stateHook (RawIrcMsg -> IrcMsg
cookIrcMsg RawIrcMsg
raw) of
               Maybe IrcMsg
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st1 -- Message ignored
               Just IrcMsg
irc ->
                 do -- state with message recorded
                    -- record messages *before* applying state changes
                    -- so that quits, nick-changes, etc (TargetUser) will dispatch to
                    -- the correct window
                    let st2 :: ClientState
st2 =
                          case IrcMsg -> Maybe IrcMsg
viewHook IrcMsg
irc of
                            Maybe IrcMsg
Nothing -> ClientState
st1 -- Message hidden
                            Just IrcMsg
irc'
                              | IrcMsg -> Bool
hideMessage IrcMsg
irc' -> ClientState
st1
                              | Bool
otherwise -> Text
-> MessageTarget -> ClientMessage -> ClientState -> ClientState
recordIrcMessage Text
network MessageTarget
target ClientMessage
msg ClientState
st1
                              where
                                myNick :: Identifier
myNick = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Identifier
csNick NetworkState
cs
                                target :: MessageTarget
target = Identifier -> IrcMsg -> MessageTarget
msgTarget Identifier
myNick IrcMsg
irc
                                msg :: ClientMessage
msg = ClientMessage
                                      { _msgTime :: ZonedTime
_msgTime    = ZonedTime
time'
                                      , _msgNetwork :: Text
_msgNetwork = Text
network
                                      , _msgBody :: MessageBody
_msgBody    = IrcMsg -> MessageBody
IrcBody IrcMsg
irc'
                                      }

                    let ([RawIrcMsg]
replies, ClientState
st3) =
                          ZonedTime
-> IrcMsg
-> Text
-> NetworkState
-> ClientState
-> ([RawIrcMsg], ClientState)
applyMessageToClientState ZonedTime
time IrcMsg
irc Text
networkId NetworkState
cs ClientState
st2

                    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs) [RawIrcMsg]
replies
                    ZonedTime
-> IrcMsg -> NetworkState -> ClientState -> IO ClientState
clientResponse ZonedTime
time' IrcMsg
irc NetworkState
cs ClientState
st3

-- Highly restricted message handler for messages sent before STARTTLS
-- has completed.
startTLSLine :: Text -> NetworkState -> ClientState -> RawIrcMsg -> IO ClientState
startTLSLine :: Text -> NetworkState -> ClientState -> RawIrcMsg -> IO ClientState
startTLSLine Text
network NetworkState
cs ClientState
st RawIrcMsg
raw =
  do ZonedTime
now <- IO ZonedTime
getZonedTime
     let irc :: IrcMsg
irc = RawIrcMsg -> IrcMsg
cookIrcMsg RawIrcMsg
raw
         myNick :: Identifier
myNick = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Identifier
csNick NetworkState
cs
         target :: MessageTarget
target = Identifier -> IrcMsg -> MessageTarget
msgTarget Identifier
myNick IrcMsg
irc
         msg :: ClientMessage
msg = ClientMessage
             { _msgTime :: ZonedTime
_msgTime    = ZonedTime
now
             , _msgNetwork :: Text
_msgNetwork = Text
network
             , _msgBody :: MessageBody
_msgBody    = IrcMsg -> MessageBody
IrcBody IrcMsg
irc
             }
         st1 :: ClientState
st1 = Text
-> MessageTarget -> ClientMessage -> ClientState -> ClientState
recordIrcMessage Text
network MessageTarget
target ClientMessage
msg ClientState
st

     case IrcMsg
irc of
       Notice{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientState
st1
       Reply Text
_ ReplyCode
RPL_STARTTLS [Text]
_ ->
         do NetworkConnection -> IO ()
upgrade (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState NetworkConnection
csSocket NetworkState
cs)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall s t a b. ASetter s t a b -> b -> s -> t
set ( Lens' ClientState (HashMap Text NetworkState)
clientConnections forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
network forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' NetworkState PingStatus
csPingStatus
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' PingStatus (Int, Maybe UTCTime, ConnectRestriction)
_PingConnecting forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
_3)
                      ConnectRestriction
WaitTLSRestriction ClientState
st1)
       IrcMsg
_ -> ClientState
st1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TerminationReason -> NetworkConnection -> IO ()
abortConnection TerminationReason
StartTLSFailed (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState NetworkConnection
csSocket NetworkState
cs)

-- | Find the ZNC provided server time
computeEffectiveTime :: ZonedTime -> [TagEntry] -> ZonedTime
computeEffectiveTime :: ZonedTime -> [TagEntry] -> ZonedTime
computeEffectiveTime ZonedTime
time [TagEntry]
tags = forall a. a -> Maybe a -> a
fromMaybe ZonedTime
time Maybe ZonedTime
zncTime
  where
    isTimeTag :: TagEntry -> Bool
isTimeTag (TagEntry Text
key Text
_) = Text
key forall a. Eq a => a -> a -> Bool
== Text
"time"
    zncTime :: Maybe ZonedTime
zncTime =
      do TagEntry Text
_ Text
txt <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find TagEntry -> Bool
isTimeTag [TagEntry]
tags
         UTCTime
tagTime <- String -> Maybe UTCTime
parseZncTime (Text -> String
Text.unpack Text
txt)
         forall (m :: * -> *) a. Monad m => a -> m a
return (TimeZone -> UTCTime -> ZonedTime
utcToZonedTime (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
time) UTCTime
tagTime)

-- | Parses the time format used by ZNC for buffer playback
parseZncTime :: String -> Maybe UTCTime
parseZncTime :: String -> Maybe UTCTime
parseZncTime = forall (m :: * -> *) t. MonadFail m => Format t -> String -> m t
formatParseM forall t. ISO8601 t => Format t
iso8601Format


-- | Update the height and width fields of the client state
updateTerminalSize :: Vty -> ClientState -> IO ClientState
updateTerminalSize :: Vty -> ClientState -> IO ClientState
updateTerminalSize Vty
vty ClientState
st =
  do (Int
w,Int
h) <- Output -> IO (Int, Int)
displayBounds (Vty -> Output
outputIface Vty
vty)
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Int
clientWidth  Int
w
            forall a b. (a -> b) -> a -> b
$  forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Int
clientHeight Int
h ClientState
st

-- | Respond to a VTY event.
doVtyEvent ::
  Vty                    {- ^ vty handle            -} ->
  Event                  {- ^ vty event             -} ->
  ClientState            {- ^ client state          -} ->
  IO (Maybe ClientState) {- ^ nothing when finished -}
doVtyEvent :: Vty -> Event -> ClientState -> IO (Maybe ClientState)
doVtyEvent Vty
vty Event
vtyEvent ClientState
st =
  case Event
vtyEvent of
    EvKey Key
k [Modifier]
modifier ->
      let cfg :: Configuration
cfg      = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Configuration
clientConfig ClientState
st
          keymap :: KeyMap
keymap   = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Configuration KeyMap
configKeyMap       Configuration
cfg
          winnames :: Text
winnames = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Configuration Text
configWindowNames  Configuration
cfg
          winmods :: [Modifier]
winmods  = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Configuration [Modifier]
configJumpModifier Configuration
cfg
          action :: Action
action = KeyMap -> [Modifier] -> Text -> [Modifier] -> Key -> Action
keyToAction KeyMap
keymap [Modifier]
winmods Text
winnames [Modifier]
modifier Key
k
      in Vty -> Action -> ClientState -> IO (Maybe ClientState)
doAction Vty
vty Action
action ClientState
st
    -- ignore event parameters due to raw TChan use
    EvResize{} -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vty -> ClientState -> IO ClientState
updateTerminalSize Vty
vty ClientState
st
    EvPaste ByteString
utf8 ->
       do let str :: String
str = Text -> String
Text.unpack (OnDecodeError -> ByteString -> Text
Text.decodeUtf8With OnDecodeError
Text.lenientDecode ByteString
utf8)
          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
$! forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' ClientState EditBox
clientTextBox (String -> EditBox -> EditBox
Edit.insertPaste String
str) ClientState
st
    Event
EvLostFocus ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Bool
clientUiFocused Bool
False ClientState
st)
    Event
EvGainedFocus ->
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Bool
clientUiFocused Bool
True ClientState
st)
    Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just ClientState
st)


-- | Map keyboard inputs to actions in the client
doAction ::
  Vty         {- ^ vty handle     -} ->
  Action      {- ^ action         -} ->
  ClientState {- ^ client state   -} ->
  IO (Maybe ClientState)
doAction :: Vty -> Action -> ClientState -> IO (Maybe ClientState)
doAction Vty
vty Action
action ClientState
st =

  let continue :: ClientState -> m (Maybe ClientState)
continue !ClientState
out -- detect when chains of M-a are broken
        | Action
action forall a. Eq a => a -> a -> Bool
== Action
ActJumpToActivity =
            let upd :: Maybe Focus -> Maybe Focus
upd Maybe Focus
Nothing = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Focus
clientFocus ClientState
st
                upd Maybe Focus
x       = Maybe Focus
x
            in 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
$! forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' ClientState (Maybe Focus)
clientActivityReturn Maybe Focus -> Maybe Focus
upd ClientState
out
        | Bool
otherwise = 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
$! forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState (Maybe Focus)
clientActivityReturn forall a. Maybe a
Nothing ClientState
out

      changeEditor :: (EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor  EditBox -> EditBox
f = forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' ClientState EditBox
clientTextBox EditBox -> EditBox
f ClientState
st)
      changeContent :: (Content -> Content) -> m (Maybe ClientState)
changeContent Content -> Content
f = forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor
                      forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' EditBox Content
Edit.content Content -> Content
f
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set  Lens' EditBox LastOperation
Edit.lastOperation LastOperation
Edit.OtherOperation

      mbChangeEditor :: (EditBox -> Maybe EditBox) -> m (Maybe ClientState)
mbChangeEditor EditBox -> Maybe EditBox
f =
        case forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf Lens' ClientState EditBox
clientTextBox EditBox -> Maybe EditBox
f ClientState
st of
          Maybe ClientState
Nothing -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue forall a b. (a -> b) -> a -> b
$! forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Bool
clientBell Bool
True ClientState
st
          Just ClientState
st' -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st'
  in
  case Action
action of
    -- movements
    Action
ActHome              -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor EditBox -> EditBox
Edit.home
    Action
ActEnd               -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor EditBox -> EditBox
Edit.end
    Action
ActLeft              -> forall {m :: * -> *}.
Monad m =>
(Content -> Content) -> m (Maybe ClientState)
changeContent Content -> Content
Edit.left
    Action
ActRight             -> forall {m :: * -> *}.
Monad m =>
(Content -> Content) -> m (Maybe ClientState)
changeContent Content -> Content
Edit.right
    Action
ActBackWord          -> forall {m :: * -> *}.
Monad m =>
(Content -> Content) -> m (Maybe ClientState)
changeContent Content -> Content
Edit.leftWord
    Action
ActForwardWord       -> forall {m :: * -> *}.
Monad m =>
(Content -> Content) -> m (Maybe ClientState)
changeContent Content -> Content
Edit.rightWord

    -- edits
    Action
ActKillHome          -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor EditBox -> EditBox
Edit.killHome
    Action
ActKillEnd           -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor EditBox -> EditBox
Edit.killEnd
    Action
ActKillWordBack      -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor ((Char -> Bool) -> Bool -> EditBox -> EditBox
Edit.killWordBackward Char -> Bool
isSpace Bool
True)
    Action
ActKillWordForward   -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor ((Char -> Bool) -> Bool -> EditBox -> EditBox
Edit.killWordForward Char -> Bool
isSpace Bool
True)
    Action
ActYank              -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor EditBox -> EditBox
Edit.yank
    Action
ActToggle            -> forall {m :: * -> *}.
Monad m =>
(Content -> Content) -> m (Maybe ClientState)
changeContent Content -> Content
Edit.toggle
    Action
ActDelete            -> forall {m :: * -> *}.
Monad m =>
(Content -> Content) -> m (Maybe ClientState)
changeContent Content -> Content
Edit.delete
    Action
ActBackspace         -> forall {m :: * -> *}.
Monad m =>
(Content -> Content) -> m (Maybe ClientState)
changeContent Content -> Content
Edit.backspace

    -- special inserts
    Action
ActBold              -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^B')
    Action
ActColor             -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^C')
    Action
ActItalic            -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^]')
    Action
ActStrikethrough     -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^^')
    Action
ActUnderline         -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^_')
    Action
ActClearFormat       -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^O')
    Action
ActReverseVideo      -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^V')
    Action
ActMonospace         -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^Q')
    Action
ActDigraph           -> forall {m :: * -> *}.
Monad m =>
(EditBox -> Maybe EditBox) -> m (Maybe ClientState)
mbChangeEditor (Map Digraph Text -> EditBox -> Maybe EditBox
Edit.insertDigraph (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState Configuration
clientConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Configuration (Map Digraph Text)
configDigraphs) ClientState
st))
    Action
ActInsertEnter       -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
'\^J')

    -- focus jumps
    ActJump Char
i            -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Char -> ClientState -> ClientState
jumpFocus Char
i ClientState
st)
    Action
ActJumpToActivity    -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (ClientState -> ClientState
jumpToActivity ClientState
st)
    Action
ActJumpPrevious      -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (ClientState -> ClientState
returnFocus ClientState
st)
    Action
ActRetreatFocus      -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (ClientState -> ClientState
retreatFocus ClientState
st)
    Action
ActAdvanceFocus      -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (ClientState -> ClientState
advanceFocus ClientState
st)
    Action
ActAdvanceNetwork    -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (ClientState -> ClientState
advanceNetworkFocus ClientState
st)

    Action
ActReset             -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Subfocus -> ClientState -> ClientState
changeSubfocus Subfocus
FocusMessages ClientState
st)
    Action
ActOlderLine         -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor forall a b. (a -> b) -> a -> b
$ \EditBox
ed -> forall a. a -> Maybe a -> a
fromMaybe EditBox
ed forall a b. (a -> b) -> a -> b
$ EditBox -> Maybe EditBox
Edit.earlier EditBox
ed
    Action
ActNewerLine         -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor forall a b. (a -> b) -> a -> b
$ \EditBox
ed -> forall a. a -> Maybe a -> a
fromMaybe EditBox
ed forall a b. (a -> b) -> a -> b
$ EditBox -> Maybe EditBox
Edit.later EditBox
ed
    Action
ActScrollUp          -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Int -> ClientState -> ClientState
scrollClient ( ClientState -> Int
scrollAmount ClientState
st) ClientState
st)
    Action
ActScrollDown        -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Int -> ClientState -> ClientState
scrollClient (-ClientState -> Int
scrollAmount ClientState
st) ClientState
st)
    Action
ActScrollUpSmall     -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Int -> ClientState -> ClientState
scrollClient ( Int
3) ClientState
st)
    Action
ActScrollDownSmall   -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Int -> ClientState -> ClientState
scrollClient (-Int
3) ClientState
st)

    Action
ActTabCompleteBack   -> Bool -> CommandResult -> IO (Maybe ClientState)
doCommandResult Bool
False forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> ClientState -> IO CommandResult
tabCompletion Bool
True  ClientState
st
    Action
ActTabComplete       -> Bool -> CommandResult -> IO (Maybe ClientState)
doCommandResult Bool
False forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> ClientState -> IO CommandResult
tabCompletion Bool
False ClientState
st

    ActInsert Char
c          -> forall {m :: * -> *}.
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
c)
    Action
ActEnter             -> if forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Bool
clientEditLock ClientState
st
                            then forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Bool
clientBell ClientState
st) (Vty -> IO ()
beep Vty
vty) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st
                            else Bool -> CommandResult -> IO (Maybe ClientState)
doCommandResult Bool
True forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ClientState -> IO CommandResult
executeInput ClientState
st
    Action
ActRefresh           -> Vty -> IO ()
refresh Vty
vty forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st
    ActCommand Text
cmd       -> do CommandResult
resp <- Maybe Text -> String -> ClientState -> IO CommandResult
executeUserCommand forall a. Maybe a
Nothing (Text -> String
Text.unpack Text
cmd) ClientState
st
                               case CommandResult
resp of
                                 CommandSuccess ClientState
st1 -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st1
                                 CommandFailure ClientState
st1 -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st1
                                 CommandQuit    ClientState
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    Action
ActIgnored           -> forall {m :: * -> *}.
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st


-- | Process 'CommandResult' and update the 'ClientState' textbox
-- and error state. When quitting return 'Nothing'.
doCommandResult ::
  Bool          {- ^ clear on success -} ->
  CommandResult {- ^ command result   -} ->
  IO (Maybe ClientState)
doCommandResult :: Bool -> CommandResult -> IO (Maybe ClientState)
doCommandResult Bool
clearOnSuccess CommandResult
res =
  let continue :: a -> m (Maybe a)
continue !a
st = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
st) in
  case CommandResult
res of
    CommandQuit    ClientState
st -> forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ClientState -> IO ()
clientShutdown ClientState
st
    CommandSuccess ClientState
st -> forall {m :: * -> *} {a}. Monad m => a -> m (Maybe a)
continue (if Bool
clearOnSuccess then ClientState -> ClientState
consumeInput ClientState
st else ClientState
st)
    CommandFailure ClientState
st -> forall {m :: * -> *} {a}. Monad m => a -> m (Maybe a)
continue (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Bool
clientBell Bool
True ClientState
st)


-- | Actions to be run when exiting the client.
clientShutdown :: ClientState -> IO ()
clientShutdown :: ClientState -> IO ()
clientShutdown ClientState
st = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ClientState -> IO ClientState
clientStopExtensions ClientState
st
 -- other shutdown stuff might be added here later


-- | Execute the the command on the first line of the text box
executeInput ::
  ClientState {- ^ client state -} ->
  IO CommandResult
executeInput :: ClientState -> IO CommandResult
executeInput ClientState
st = String -> ClientState -> IO CommandResult
execute (ClientState -> String
clientFirstLine ClientState
st) ClientState
st


-- | Respond to a timer event.
doTimerEvent ::
  Text        {- ^ Network related to event -} ->
  TimedAction {- ^ Action to perform        -} ->
  ClientState {- ^ client state             -} ->
  IO ClientState
doTimerEvent :: Text -> TimedAction -> ClientState -> IO ClientState
doTimerEvent Text
networkId TimedAction
action =
  forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf
    (forall (f :: * -> *).
Applicative f =>
Text -> LensLike' f ClientState NetworkState
clientConnection Text
networkId)
    (TimedAction -> NetworkState -> IO NetworkState
applyTimedAction TimedAction
action)