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

{-|
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
import           Client.Configuration (configJumpModifier, configKeyMap, configWindowNames, configDigraphs)
import           Client.Configuration.ServerSettings
import           Client.EventLoop.Actions
import           Client.EventLoop.Errors (exceptionToLines)
import           Client.EventLoop.Network (clientResponse)
import           Client.Hook
import           Client.Image
import           Client.Image.Layout (scrollAmount)
import           Client.Image.StatusLine (clientTitle)
import           Client.Log
import           Client.Message
import           Client.Network.Async
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.Char (isSpace)
import           Data.Foldable
import           Data.Traversable
import           Data.List
import           Data.List.NonEmpty (NonEmpty, nonEmpty)
import           Data.Maybe
import           Data.Ord
import           Data.Text (Text)
import qualified Data.HashMap.Strict as HashMap
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           Graphics.Vty.Input.Events
import           Irc.Message
import           Irc.Codes
import           Irc.RawIrcMsg
import           LensUtils
import           Hookup (ConnectionFailure(..))


-- | 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
     STM ClientEvent -> IO ClientEvent
forall a. STM a -> IO a
atomically ([STM ClientEvent] -> STM ClientEvent
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 (InternalEvent -> ClientEvent)
-> STM InternalEvent -> STM ClientEvent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TChan InternalEvent -> STM InternalEvent
forall a. TChan a -> STM a
readTChan (Input -> TChan InternalEvent
_eventChannel (Vty -> Input
inputIface Vty
vty))

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

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

    threadJoin :: STM ClientEvent
threadJoin =
      do (Int
i,ThreadEntry
r) <- TQueue (Int, ThreadEntry) -> STM (Int, ThreadEntry)
forall a. TQueue a -> STM a
readTQueue (Getting
  (TQueue (Int, ThreadEntry)) ClientState (TQueue (Int, ThreadEntry))
-> ClientState -> TQueue (Int, ThreadEntry)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (TQueue (Int, ThreadEntry)) ClientState (TQueue (Int, ThreadEntry))
Lens' ClientState (TQueue (Int, ThreadEntry))
clientThreadJoins ClientState
st)
         ClientEvent -> STM ClientEvent
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 = Maybe (UTCTime, ClientEvent)
-> Maybe (UTCTime, ClientEvent) -> Maybe (UTCTime, ClientEvent)
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 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
time2 = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
time1, b
action1)
      | Bool
otherwise     = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
time2, b
action2)
    earliest2 Maybe (a, b)
x Maybe (a, b)
y = Maybe (a, b) -> Maybe (a, b) -> Maybe (a, b)
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 =
      Getting
  (Endo (Endo (Maybe (UTCTime, ClientEvent))))
  ClientState
  (UTCTime, ClientEvent)
-> ((UTCTime, ClientEvent) -> (UTCTime, ClientEvent) -> Ordering)
-> ClientState
-> Maybe (UTCTime, ClientEvent)
forall a s.
Getting (Endo (Endo (Maybe a))) s a
-> (a -> a -> Ordering) -> s -> Maybe a
minimumByOf
        ((HashMap Text NetworkState
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (HashMap Text NetworkState))
-> ClientState
-> Const (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ClientState
Lens' ClientState (HashMap Text NetworkState)
clientConnections ((HashMap Text NetworkState
  -> Const
       (Endo (Endo (Maybe (UTCTime, ClientEvent))))
       (HashMap Text NetworkState))
 -> ClientState
 -> Const (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ClientState)
-> (((UTCTime, ClientEvent)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, ClientEvent))
    -> HashMap Text NetworkState
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (HashMap Text NetworkState))
-> Getting
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     ClientState
     (UTCTime, ClientEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Indexed
  Text
  NetworkState
  (Const (Endo (Endo (Maybe (UTCTime, ClientEvent)))) NetworkState)
-> HashMap Text NetworkState
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     (HashMap Text NetworkState)
forall i (f :: * -> *) a.
FoldableWithIndex i f =>
IndexedFold i (f a) a
ifolded (Indexed
   Text
   NetworkState
   (Const (Endo (Endo (Maybe (UTCTime, ClientEvent)))) NetworkState)
 -> HashMap Text NetworkState
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (HashMap Text NetworkState))
-> (((UTCTime, TimedAction)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, TimedAction))
    -> NetworkState
    -> Const (Endo (Endo (Maybe (UTCTime, ClientEvent)))) NetworkState)
-> Indexed
     Text
     (UTCTime, TimedAction)
     (Const
        (Endo (Endo (Maybe (UTCTime, ClientEvent))))
        (UTCTime, TimedAction))
-> HashMap Text NetworkState
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     (HashMap Text NetworkState)
forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. (NetworkState -> Maybe (UTCTime, TimedAction))
-> Fold NetworkState (UTCTime, TimedAction)
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding NetworkState -> Maybe (UTCTime, TimedAction)
nextTimedAction) (Indexed
   Text
   (UTCTime, TimedAction)
   (Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (UTCTime, TimedAction))
 -> HashMap Text NetworkState
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (HashMap Text NetworkState))
-> (((UTCTime, ClientEvent)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, ClientEvent))
    -> Indexed
         Text
         (UTCTime, TimedAction)
         (Const
            (Endo (Endo (Maybe (UTCTime, ClientEvent))))
            (UTCTime, TimedAction)))
-> ((UTCTime, ClientEvent)
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, ClientEvent))
-> HashMap Text NetworkState
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     (HashMap Text NetworkState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, (UTCTime, TimedAction))
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (Text, (UTCTime, TimedAction)))
-> Indexed
     Text
     (UTCTime, TimedAction)
     (Const
        (Endo (Endo (Maybe (UTCTime, ClientEvent))))
        (UTCTime, TimedAction))
forall i (p :: * -> * -> *) (f :: * -> *) s j t.
(Indexable i p, Functor f) =>
p (i, s) (f (j, t)) -> Indexed i s (f t)
withIndex (((Text, (UTCTime, TimedAction))
  -> Const
       (Endo (Endo (Maybe (UTCTime, ClientEvent))))
       (Text, (UTCTime, TimedAction)))
 -> Indexed
      Text
      (UTCTime, TimedAction)
      (Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, TimedAction)))
-> (((UTCTime, ClientEvent)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, ClientEvent))
    -> (Text, (UTCTime, TimedAction))
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (Text, (UTCTime, TimedAction)))
-> ((UTCTime, ClientEvent)
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, ClientEvent))
-> Indexed
     Text
     (UTCTime, TimedAction)
     (Const
        (Endo (Endo (Maybe (UTCTime, ClientEvent))))
        (UTCTime, TimedAction))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, (UTCTime, TimedAction)) -> (UTCTime, ClientEvent))
-> ((UTCTime, ClientEvent)
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, ClientEvent))
-> (Text, (UTCTime, TimedAction))
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     (Text, (UTCTime, TimedAction))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Text, (UTCTime, TimedAction)) -> (UTCTime, ClientEvent)
forall a. (Text, (a, TimedAction)) -> (a, ClientEvent)
mkEventN)
        (((UTCTime, ClientEvent) -> UTCTime)
-> (UTCTime, ClientEvent) -> (UTCTime, ClientEvent) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (UTCTime, ClientEvent) -> UTCTime
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 =
      Getting
  (Endo (Endo (Maybe (UTCTime, ClientEvent))))
  ClientState
  (UTCTime, ClientEvent)
-> ((UTCTime, ClientEvent) -> (UTCTime, ClientEvent) -> Ordering)
-> ClientState
-> Maybe (UTCTime, ClientEvent)
forall a s.
Getting (Endo (Endo (Maybe a))) s a
-> (a -> a -> Ordering) -> s -> Maybe a
minimumByOf
        ((ExtensionState
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ExtensionState)
-> ClientState
-> Const (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState
  -> Const
       (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ExtensionState)
 -> ClientState
 -> Const (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ClientState)
-> (((UTCTime, ClientEvent)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, ClientEvent))
    -> ExtensionState
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ExtensionState)
-> Getting
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     ClientState
     (UTCTime, ClientEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (IntMap ActiveExtension))
-> ExtensionState
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension
  -> Const
       (Endo (Endo (Maybe (UTCTime, ClientEvent))))
       (IntMap ActiveExtension))
 -> ExtensionState
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ExtensionState)
-> (((UTCTime, ClientEvent)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, ClientEvent))
    -> IntMap ActiveExtension
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (IntMap ActiveExtension))
-> ((UTCTime, ClientEvent)
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, ClientEvent))
-> ExtensionState
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ExtensionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Indexed
  Int
  ActiveExtension
  (Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ActiveExtension)
-> IntMap ActiveExtension
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     (IntMap ActiveExtension)
forall i (f :: * -> *) a.
FoldableWithIndex i f =>
IndexedFold i (f a) a
ifolded (Indexed
   Int
   ActiveExtension
   (Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ActiveExtension)
 -> IntMap ActiveExtension
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (IntMap ActiveExtension))
-> (((UTCTime, TimerId, FunPtr TimerCallback, Ptr (),
      ActiveExtension)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
    -> ActiveExtension
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent)))) ActiveExtension)
-> Indexed
     Int
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
     (Const
        (Endo (Endo (Maybe (UTCTime, ClientEvent))))
        (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
-> IntMap ActiveExtension
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     (IntMap ActiveExtension)
forall i (p :: * -> * -> *) s t r a b.
Indexable i p =>
(Indexed i s t -> r) -> ((a -> b) -> s -> t) -> p a b -> r
<. (ActiveExtension
 -> Maybe
      (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
-> Fold
     ActiveExtension
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding ActiveExtension
-> Maybe
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
popTimer) (Indexed
   Int
   (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
   (Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
 -> IntMap ActiveExtension
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (IntMap ActiveExtension))
-> (((UTCTime, ClientEvent)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, ClientEvent))
    -> Indexed
         Int
         (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
         (Const
            (Endo (Endo (Maybe (UTCTime, ClientEvent))))
            (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)))
-> ((UTCTime, ClientEvent)
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, ClientEvent))
-> IntMap ActiveExtension
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     (IntMap ActiveExtension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int,
  (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
 -> Const
      (Endo (Endo (Maybe (UTCTime, ClientEvent))))
      (Int,
       (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)))
-> Indexed
     Int
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
     (Const
        (Endo (Endo (Maybe (UTCTime, ClientEvent))))
        (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
forall i (p :: * -> * -> *) (f :: * -> *) s j t.
(Indexable i p, Functor f) =>
p (i, s) (f (j, t)) -> Indexed i s (f t)
withIndex (((Int,
   (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
  -> Const
       (Endo (Endo (Maybe (UTCTime, ClientEvent))))
       (Int,
        (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)))
 -> Indexed
      Int
      (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
      (Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)))
-> (((UTCTime, ClientEvent)
     -> Const
          (Endo (Endo (Maybe (UTCTime, ClientEvent))))
          (UTCTime, ClientEvent))
    -> (Int,
        (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (Int,
          (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)))
-> ((UTCTime, ClientEvent)
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, ClientEvent))
-> Indexed
     Int
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
     (Const
        (Endo (Endo (Maybe (UTCTime, ClientEvent))))
        (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int,
  (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
 -> (UTCTime, ClientEvent))
-> ((UTCTime, ClientEvent)
    -> Const
         (Endo (Endo (Maybe (UTCTime, ClientEvent))))
         (UTCTime, ClientEvent))
-> (Int,
    (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
-> Const
     (Endo (Endo (Maybe (UTCTime, ClientEvent))))
     (Int,
      (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Int,
 (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension))
-> (UTCTime, ClientEvent)
forall a b c d e. (Int, (a, b, c, d, e)) -> (a, ClientEvent)
mkEventE)
        (((UTCTime, ClientEvent) -> UTCTime)
-> (UTCTime, ClientEvent) -> (UTCTime, ClientEvent) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (UTCTime, ClientEvent) -> UTCTime
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 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Bool ClientState Bool -> ClientState -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool ClientState Bool
Lens' ClientState Bool
clientBell ClientState
st) (Vty -> IO ()
beep Vty
vty)
     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 (ClientState -> IO ()) -> IO ClientState -> IO ()
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 (ClientState -> IO ()) -> IO ClientState -> IO ()
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 (ClientState -> IO ()) -> IO ClientState -> IO ()
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) ->
         (ClientState -> IO ()) -> Maybe ClientState -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Vty -> ClientState -> IO ()
eventLoop Vty
vty) (Maybe ClientState -> IO ()) -> IO (Maybe ClientState) -> IO ()
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
ResumeAfterSignal ->
         Vty -> ClientState -> IO ()
eventLoop Vty
vty (ClientState -> IO ()) -> IO ClientState -> IO ()
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 (ClientState -> IO ()) -> IO ClientState -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ClientState -> (Text, NetworkEvent) -> IO ClientState)
-> ClientState -> NonEmpty (Text, NetworkEvent) -> IO ClientState
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 (Output -> IO ()) -> (Vty -> Output) -> Vty -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vty -> Output
outputIface

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

-- | 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 Getting (Maybe NetworkState) ClientState (Maybe NetworkState)
-> ClientState -> Maybe NetworkState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((HashMap Text NetworkState
 -> Const (Maybe NetworkState) (HashMap Text NetworkState))
-> ClientState -> Const (Maybe NetworkState) ClientState
Lens' ClientState (HashMap Text NetworkState)
clientConnections ((HashMap Text NetworkState
  -> Const (Maybe NetworkState) (HashMap Text NetworkState))
 -> ClientState -> Const (Maybe NetworkState) ClientState)
-> ((Maybe NetworkState
     -> Const (Maybe NetworkState) (Maybe NetworkState))
    -> HashMap Text NetworkState
    -> Const (Maybe NetworkState) (HashMap Text NetworkState))
-> Getting (Maybe NetworkState) ClientState (Maybe NetworkState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text NetworkState)
-> Lens'
     (HashMap Text NetworkState)
     (Maybe (IxValue (HashMap Text NetworkState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (HashMap Text NetworkState)
networkId) ClientState
st of
    Maybe NetworkState
Nothing -> String -> IO ClientState
forall a. HasCallStack => String -> a
error String
"doNetworkOpen: Network missing"
    Just NetworkState
cs ->
      do let msg :: ClientMessage
msg = ClientMessage :: Text -> MessageBody -> ZonedTime -> ClientMessage
ClientMessage
                     { _msgTime :: ZonedTime
_msgTime    = ZonedTime
time
                     , _msgNetwork :: Text
_msgNetwork = Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs
                     , _msgBody :: MessageBody
_msgBody    = Text -> MessageBody
NormalBody Text
"connection opened"
                     }
         let cs' :: NetworkState
cs' = NetworkState
cs NetworkState -> (NetworkState -> NetworkState) -> NetworkState
forall a b. a -> (a -> b) -> b
& (Maybe UTCTime -> Identity (Maybe UTCTime))
-> NetworkState -> Identity NetworkState
Lens' NetworkState (Maybe UTCTime)
csLastReceived ((Maybe UTCTime -> Identity (Maybe UTCTime))
 -> NetworkState -> Identity NetworkState)
-> Maybe UTCTime -> NetworkState -> NetworkState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$! ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
time)
         ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ClientMessage -> ClientState -> ClientState
recordNetworkMessage ClientMessage
msg
                 (ClientState -> ClientState) -> ClientState -> ClientState
forall a b. (a -> b) -> a -> b
$ ASetter ClientState ClientState NetworkState NetworkState
-> NetworkState -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
setStrict ((HashMap Text NetworkState -> Identity (HashMap Text NetworkState))
-> ClientState -> Identity ClientState
Lens' ClientState (HashMap Text NetworkState)
clientConnections ((HashMap Text NetworkState
  -> Identity (HashMap Text NetworkState))
 -> ClientState -> Identity ClientState)
-> ((NetworkState -> Identity NetworkState)
    -> HashMap Text NetworkState
    -> Identity (HashMap Text NetworkState))
-> ASetter ClientState ClientState NetworkState NetworkState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text NetworkState)
-> Traversal'
     (HashMap Text NetworkState) (IxValue (HashMap Text NetworkState))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
Index (HashMap Text NetworkState)
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 =
  ClientState -> IO ClientState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ASetter ClientState ClientState NetworkState NetworkState
-> (NetworkState -> NetworkState) -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((HashMap Text NetworkState -> Identity (HashMap Text NetworkState))
-> ClientState -> Identity ClientState
Lens' ClientState (HashMap Text NetworkState)
clientConnections ((HashMap Text NetworkState
  -> Identity (HashMap Text NetworkState))
 -> ClientState -> Identity ClientState)
-> ((NetworkState -> Identity NetworkState)
    -> HashMap Text NetworkState
    -> Identity (HashMap Text NetworkState))
-> ASetter ClientState ClientState NetworkState NetworkState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text NetworkState)
-> Traversal'
     (HashMap Text NetworkState) (IxValue (HashMap Text NetworkState))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
Index (HashMap Text NetworkState)
network) NetworkState -> NetworkState
upd ClientState
st
  where
    upd :: NetworkState -> NetworkState
upd = ASetter NetworkState NetworkState [Text] [Text]
-> [Text] -> NetworkState -> NetworkState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter NetworkState NetworkState [Text] [Text]
Lens' NetworkState [Text]
csCertificate [Text]
cert
        (NetworkState -> NetworkState)
-> (NetworkState -> NetworkState) -> NetworkState -> NetworkState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  NetworkState NetworkState ConnectRestriction ConnectRestriction
-> ConnectRestriction -> NetworkState -> NetworkState
forall s t a b. ASetter s t a b -> b -> s -> t
set ((PingStatus -> Identity PingStatus)
-> NetworkState -> Identity NetworkState
Lens' NetworkState PingStatus
csPingStatus ((PingStatus -> Identity PingStatus)
 -> NetworkState -> Identity NetworkState)
-> ((ConnectRestriction -> Identity ConnectRestriction)
    -> PingStatus -> Identity PingStatus)
-> ASetter
     NetworkState NetworkState ConnectRestriction ConnectRestriction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Maybe UTCTime, ConnectRestriction)
 -> Identity (Int, Maybe UTCTime, ConnectRestriction))
-> PingStatus -> Identity PingStatus
Prism' PingStatus (Int, Maybe UTCTime, ConnectRestriction)
_PingConnecting (((Int, Maybe UTCTime, ConnectRestriction)
  -> Identity (Int, Maybe UTCTime, ConnectRestriction))
 -> PingStatus -> Identity PingStatus)
-> ((ConnectRestriction -> Identity ConnectRestriction)
    -> (Int, Maybe UTCTime, ConnectRestriction)
    -> Identity (Int, Maybe UTCTime, ConnectRestriction))
-> (ConnectRestriction -> Identity ConnectRestriction)
-> PingStatus
-> Identity PingStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConnectRestriction -> Identity ConnectRestriction)
-> (Int, Maybe UTCTime, ConnectRestriction)
-> Identity (Int, Maybe UTCTime, ConnectRestriction)
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 :: Text -> MessageBody -> ZonedTime -> ClientMessage
ClientMessage
                 { _msgTime :: ZonedTime
_msgTime    = ZonedTime
time
                 , _msgNetwork :: Text
_msgNetwork = Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs
                 , _msgBody :: MessageBody
_msgBody    = Text -> MessageBody
NormalBody Text
"connection closed"
                 }
     ClientState -> IO ClientState
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 = (ClientState -> String -> ClientState)
-> ClientState -> NonEmpty String -> ClientState
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 (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs) (String -> Text
Text.pack String
msg) ClientState
acc) ClientState
st1
             (NonEmpty String -> ClientState) -> NonEmpty String -> ClientState
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 Maybe Int
forall a. Maybe a
Nothing (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs) ClientState
st

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

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

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

    shouldReconnect :: Bool
shouldReconnect =
      case Getting PingStatus NetworkState PingStatus
-> NetworkState -> PingStatus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PingStatus NetworkState PingStatus
Lens' NetworkState PingStatus
csPingStatus NetworkState
cs of
        PingConnecting Int
n Maybe UTCTime
_ ConnectRestriction
_ | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
reconnectAttempts        -> Bool
False
        PingStatus
_ | Just ConnectionFailure{}         <-      SomeException -> Maybe ConnectionFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Just HostnameResolutionFailure{} <-      SomeException -> Maybe ConnectionFailure
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Just TerminationReason
PingTimeout         <-              SomeException -> Maybe TerminationReason
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Just IOErrorType
ResourceVanished    <- IOException -> IOErrorType
ioe_type (IOException -> IOErrorType)
-> Maybe IOException -> Maybe IOErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex -> Bool
True
          | Just IOErrorType
NoSuchThing         <- IOException -> IOErrorType
ioe_type (IOException -> IOErrorType)
-> Maybe IOException -> Maybe IOErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> Maybe IOException
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 Getting (Maybe NetworkState) ClientState (Maybe NetworkState)
-> ClientState -> Maybe NetworkState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((HashMap Text NetworkState
 -> Const (Maybe NetworkState) (HashMap Text NetworkState))
-> ClientState -> Const (Maybe NetworkState) ClientState
Lens' ClientState (HashMap Text NetworkState)
clientConnections ((HashMap Text NetworkState
  -> Const (Maybe NetworkState) (HashMap Text NetworkState))
 -> ClientState -> Const (Maybe NetworkState) ClientState)
-> ((Maybe NetworkState
     -> Const (Maybe NetworkState) (Maybe NetworkState))
    -> HashMap Text NetworkState
    -> Const (Maybe NetworkState) (HashMap Text NetworkState))
-> Getting (Maybe NetworkState) ClientState (Maybe NetworkState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text NetworkState)
-> Lens'
     (HashMap Text NetworkState)
     (Maybe (IxValue (HashMap Text NetworkState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (HashMap Text NetworkState)
networkId) ClientState
st of
    Maybe NetworkState
Nothing -> String -> IO ClientState
forall a. HasCallStack => String -> a
error String
"doNetworkLine: Network missing"
    Just NetworkState
cs ->
      let network :: Text
network = Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
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 <- Getting PingStatus NetworkState PingStatus
-> NetworkState -> PingStatus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PingStatus NetworkState PingStatus
Lens' NetworkState PingStatus
csPingStatus NetworkState
cs ->
          ClientState
st ClientState -> IO () -> IO ClientState
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TerminationReason -> NetworkConnection -> IO ()
abortConnection TerminationReason
StartTLSFailed (Getting NetworkConnection NetworkState NetworkConnection
-> NetworkState -> NetworkConnection
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NetworkConnection NetworkState NetworkConnection
Lens' NetworkState NetworkConnection
csSocket NetworkState
cs)

        Just RawIrcMsg
raw
          | PingConnecting Int
_ Maybe UTCTime
_ ConnectRestriction
StartTLSRestriction <- Getting PingStatus NetworkState PingStatus
-> NetworkState -> PingStatus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PingStatus NetworkState PingStatus
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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
line)
             ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
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 ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st1 else do

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

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

             case IrcMsg -> Maybe IrcMsg
stateHook (RawIrcMsg -> IrcMsg
cookIrcMsg RawIrcMsg
raw) of
               Maybe IrcMsg
Nothing  -> ClientState -> IO ClientState
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 = Getting Identifier NetworkState Identifier
-> NetworkState -> Identifier
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Identifier NetworkState Identifier
Lens' NetworkState Identifier
csNick NetworkState
cs
                                target :: MessageTarget
target = Identifier -> IrcMsg -> MessageTarget
msgTarget Identifier
myNick IrcMsg
irc
                                msg :: ClientMessage
msg = ClientMessage :: Text -> MessageBody -> ZonedTime -> ClientMessage
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

                    (RawIrcMsg -> IO ()) -> [RawIrcMsg] -> IO ()
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 = Getting Identifier NetworkState Identifier
-> NetworkState -> Identifier
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Identifier NetworkState Identifier
Lens' NetworkState Identifier
csNick NetworkState
cs
         target :: MessageTarget
target = Identifier -> IrcMsg -> MessageTarget
msgTarget Identifier
myNick IrcMsg
irc
         msg :: ClientMessage
msg = ClientMessage :: Text -> MessageBody -> ZonedTime -> ClientMessage
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{} -> ClientState -> IO ClientState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientState
st1
       Reply Text
_ ReplyCode
RPL_STARTTLS [Text]
_ ->
         do NetworkConnection -> IO ()
upgrade (Getting NetworkConnection NetworkState NetworkConnection
-> NetworkState -> NetworkConnection
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NetworkConnection NetworkState NetworkConnection
Lens' NetworkState NetworkConnection
csSocket NetworkState
cs)
            ClientState -> IO ClientState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ASetter
  ClientState ClientState ConnectRestriction ConnectRestriction
-> ConnectRestriction -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ( (HashMap Text NetworkState -> Identity (HashMap Text NetworkState))
-> ClientState -> Identity ClientState
Lens' ClientState (HashMap Text NetworkState)
clientConnections ((HashMap Text NetworkState
  -> Identity (HashMap Text NetworkState))
 -> ClientState -> Identity ClientState)
-> ((ConnectRestriction -> Identity ConnectRestriction)
    -> HashMap Text NetworkState
    -> Identity (HashMap Text NetworkState))
-> ASetter
     ClientState ClientState ConnectRestriction ConnectRestriction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text NetworkState)
-> Traversal'
     (HashMap Text NetworkState) (IxValue (HashMap Text NetworkState))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
Index (HashMap Text NetworkState)
network ((NetworkState -> Identity NetworkState)
 -> HashMap Text NetworkState
 -> Identity (HashMap Text NetworkState))
-> ASetter
     NetworkState NetworkState ConnectRestriction ConnectRestriction
-> (ConnectRestriction -> Identity ConnectRestriction)
-> HashMap Text NetworkState
-> Identity (HashMap Text NetworkState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PingStatus -> Identity PingStatus)
-> NetworkState -> Identity NetworkState
Lens' NetworkState PingStatus
csPingStatus
                      ((PingStatus -> Identity PingStatus)
 -> NetworkState -> Identity NetworkState)
-> ((ConnectRestriction -> Identity ConnectRestriction)
    -> PingStatus -> Identity PingStatus)
-> ASetter
     NetworkState NetworkState ConnectRestriction ConnectRestriction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Maybe UTCTime, ConnectRestriction)
 -> Identity (Int, Maybe UTCTime, ConnectRestriction))
-> PingStatus -> Identity PingStatus
Prism' PingStatus (Int, Maybe UTCTime, ConnectRestriction)
_PingConnecting (((Int, Maybe UTCTime, ConnectRestriction)
  -> Identity (Int, Maybe UTCTime, ConnectRestriction))
 -> PingStatus -> Identity PingStatus)
-> ((ConnectRestriction -> Identity ConnectRestriction)
    -> (Int, Maybe UTCTime, ConnectRestriction)
    -> Identity (Int, Maybe UTCTime, ConnectRestriction))
-> (ConnectRestriction -> Identity ConnectRestriction)
-> PingStatus
-> Identity PingStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConnectRestriction -> Identity ConnectRestriction)
-> (Int, Maybe UTCTime, ConnectRestriction)
-> Identity (Int, Maybe UTCTime, ConnectRestriction)
forall s t a b. Field3 s t a b => Lens s t a b
_3)
                      ConnectRestriction
WaitTLSRestriction ClientState
st1)
       IrcMsg
_ -> ClientState
st1 ClientState -> IO () -> IO ClientState
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TerminationReason -> NetworkConnection -> IO ()
abortConnection TerminationReason
StartTLSFailed (Getting NetworkConnection NetworkState NetworkConnection
-> NetworkState -> NetworkConnection
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NetworkConnection NetworkState NetworkConnection
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 = ZonedTime -> Maybe ZonedTime -> ZonedTime
forall a. a -> Maybe a -> a
fromMaybe ZonedTime
time Maybe ZonedTime
zncTime
  where
    isTimeTag :: TagEntry -> Bool
isTimeTag (TagEntry Text
key Text
_) = Text
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"time"
    zncTime :: Maybe ZonedTime
zncTime =
      do TagEntry Text
_ Text
txt <- (TagEntry -> Bool) -> [TagEntry] -> Maybe TagEntry
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)
         ZonedTime -> Maybe ZonedTime
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 = Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale
             (String -> String -> Maybe UTCTime)
-> String -> String -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
iso8601DateFormat (String -> Maybe String
forall a. a -> Maybe a
Just String
"%T%Q%Z")


-- | 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)
     ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ASetter ClientState ClientState Int Int
-> Int -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ClientState ClientState Int Int
Lens' ClientState Int
clientWidth  Int
w
            (ClientState -> ClientState) -> ClientState -> ClientState
forall a b. (a -> b) -> a -> b
$  ASetter ClientState ClientState Int Int
-> Int -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ClientState ClientState Int Int
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      = Getting Configuration ClientState Configuration
-> ClientState -> Configuration
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Configuration ClientState Configuration
Lens' ClientState Configuration
clientConfig ClientState
st
          keymap :: KeyMap
keymap   = Getting KeyMap Configuration KeyMap -> Configuration -> KeyMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting KeyMap Configuration KeyMap
Lens' Configuration KeyMap
configKeyMap       Configuration
cfg
          winnames :: Text
winnames = Getting Text Configuration Text -> Configuration -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Configuration Text
Lens' Configuration Text
configWindowNames  Configuration
cfg
          winmods :: [Modifier]
winmods  = Getting [Modifier] Configuration [Modifier]
-> Configuration -> [Modifier]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Modifier] Configuration [Modifier]
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{} -> ClientState -> Maybe ClientState
forall a. a -> Maybe a
Just (ClientState -> Maybe ClientState)
-> IO ClientState -> IO (Maybe ClientState)
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)
          Maybe ClientState -> IO (Maybe ClientState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ClientState -> IO (Maybe ClientState))
-> Maybe ClientState -> IO (Maybe ClientState)
forall a b. (a -> b) -> a -> b
$! ClientState -> Maybe ClientState
forall a. a -> Maybe a
Just (ClientState -> Maybe ClientState)
-> ClientState -> Maybe ClientState
forall a b. (a -> b) -> a -> b
$! ASetter ClientState ClientState EditBox EditBox
-> (EditBox -> EditBox) -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ClientState ClientState EditBox EditBox
Lens' ClientState EditBox
clientTextBox (String -> EditBox -> EditBox
Edit.insertPaste String
str) ClientState
st
    Event
_ -> Maybe ClientState -> IO (Maybe ClientState)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> Maybe ClientState
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 Action -> Action -> Bool
forall a. Eq a => a -> a -> Bool
== Action
ActJumpToActivity =
            let upd :: Maybe Focus -> Maybe Focus
upd Maybe Focus
Nothing = Focus -> Maybe Focus
forall a. a -> Maybe a
Just (Focus -> Maybe Focus) -> Focus -> Maybe Focus
forall a b. (a -> b) -> a -> b
$! Getting Focus ClientState Focus -> ClientState -> Focus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Focus ClientState Focus
Lens' ClientState Focus
clientFocus ClientState
st
                upd Maybe Focus
x       = Maybe Focus
x
            in Maybe ClientState -> m (Maybe ClientState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ClientState -> m (Maybe ClientState))
-> Maybe ClientState -> m (Maybe ClientState)
forall a b. (a -> b) -> a -> b
$! ClientState -> Maybe ClientState
forall a. a -> Maybe a
Just (ClientState -> Maybe ClientState)
-> ClientState -> Maybe ClientState
forall a b. (a -> b) -> a -> b
$! ASetter ClientState ClientState (Maybe Focus) (Maybe Focus)
-> (Maybe Focus -> Maybe Focus) -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ClientState ClientState (Maybe Focus) (Maybe Focus)
Lens' ClientState (Maybe Focus)
clientActivityReturn Maybe Focus -> Maybe Focus
upd ClientState
out
        | Bool
otherwise = Maybe ClientState -> m (Maybe ClientState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ClientState -> m (Maybe ClientState))
-> Maybe ClientState -> m (Maybe ClientState)
forall a b. (a -> b) -> a -> b
$! ClientState -> Maybe ClientState
forall a. a -> Maybe a
Just
                     (ClientState -> Maybe ClientState)
-> ClientState -> Maybe ClientState
forall a b. (a -> b) -> a -> b
$! ASetter ClientState ClientState (Maybe Focus) (Maybe Focus)
-> Maybe Focus -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ClientState ClientState (Maybe Focus) (Maybe Focus)
Lens' ClientState (Maybe Focus)
clientActivityReturn Maybe Focus
forall a. Maybe a
Nothing ClientState
out

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

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

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

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

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

    Action
ActReset             -> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Subfocus -> ClientState -> ClientState
changeSubfocus Subfocus
FocusMessages ClientState
st)
    Action
ActOlderLine         -> (EditBox -> EditBox) -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor ((EditBox -> EditBox) -> IO (Maybe ClientState))
-> (EditBox -> EditBox) -> IO (Maybe ClientState)
forall a b. (a -> b) -> a -> b
$ \EditBox
ed -> EditBox -> Maybe EditBox -> EditBox
forall a. a -> Maybe a -> a
fromMaybe EditBox
ed (Maybe EditBox -> EditBox) -> Maybe EditBox -> EditBox
forall a b. (a -> b) -> a -> b
$ EditBox -> Maybe EditBox
Edit.earlier EditBox
ed
    Action
ActNewerLine         -> (EditBox -> EditBox) -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor ((EditBox -> EditBox) -> IO (Maybe ClientState))
-> (EditBox -> EditBox) -> IO (Maybe ClientState)
forall a b. (a -> b) -> a -> b
$ \EditBox
ed -> EditBox -> Maybe EditBox -> EditBox
forall a. a -> Maybe a -> a
fromMaybe EditBox
ed (Maybe EditBox -> EditBox) -> Maybe EditBox -> EditBox
forall a b. (a -> b) -> a -> b
$ EditBox -> Maybe EditBox
Edit.later EditBox
ed
    Action
ActScrollUp          -> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Int -> ClientState -> ClientState
scrollClient ( ClientState -> Int
scrollAmount ClientState
st) ClientState
st)
    Action
ActScrollDown        -> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Int -> ClientState -> ClientState
scrollClient (-ClientState -> Int
scrollAmount ClientState
st) ClientState
st)
    Action
ActScrollUpSmall     -> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
ClientState -> m (Maybe ClientState)
continue (Int -> ClientState -> ClientState
scrollClient ( Int
3) ClientState
st)
    Action
ActScrollDownSmall   -> ClientState -> IO (Maybe ClientState)
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 (CommandResult -> IO (Maybe ClientState))
-> IO CommandResult -> IO (Maybe ClientState)
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 (CommandResult -> IO (Maybe ClientState))
-> IO CommandResult -> IO (Maybe ClientState)
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          -> (EditBox -> EditBox) -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
(EditBox -> EditBox) -> m (Maybe ClientState)
changeEditor (Char -> EditBox -> EditBox
Edit.insert Char
c)
    Action
ActEnter             -> if Getting Bool ClientState Bool -> ClientState -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool ClientState Bool
Lens' ClientState Bool
clientEditLock ClientState
st
                            then Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Bool ClientState Bool -> ClientState -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool ClientState Bool
Lens' ClientState Bool
clientBell ClientState
st) (Vty -> IO ()
beep Vty
vty) IO () -> IO (Maybe ClientState) -> IO (Maybe ClientState)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st
                            else Bool -> CommandResult -> IO (Maybe ClientState)
doCommandResult Bool
True (CommandResult -> IO (Maybe ClientState))
-> IO CommandResult -> IO (Maybe ClientState)
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 IO () -> IO (Maybe ClientState) -> IO (Maybe ClientState)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st
    ActCommand Text
cmd       -> do CommandResult
resp <- Maybe Text -> String -> ClientState -> IO CommandResult
executeUserCommand Maybe Text
forall a. Maybe a
Nothing (Text -> String
Text.unpack Text
cmd) ClientState
st
                               case CommandResult
resp of
                                 CommandSuccess ClientState
st1 -> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st1
                                 CommandFailure ClientState
st1 -> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *).
Monad m =>
ClientState -> m (Maybe ClientState)
continue ClientState
st1
                                 CommandQuit    ClientState
_   -> Maybe ClientState -> IO (Maybe ClientState)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ClientState
forall a. Maybe a
Nothing

    Action
ActIgnored           -> ClientState -> IO (Maybe ClientState)
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 = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
st) in
  case CommandResult
res of
    CommandQuit    ClientState
st -> Maybe ClientState
forall a. Maybe a
Nothing Maybe ClientState -> IO () -> IO (Maybe ClientState)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ClientState -> IO ()
clientShutdown ClientState
st
    CommandSuccess ClientState
st -> ClientState -> IO (Maybe ClientState)
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 -> ClientState -> IO (Maybe ClientState)
forall (m :: * -> *) a. Monad m => a -> m (Maybe a)
continue (ASetter ClientState ClientState Bool Bool
-> Bool -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ClientState ClientState Bool Bool
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 = () () -> IO ClientState -> IO ()
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 =
  LensLike IO ClientState ClientState NetworkState NetworkState
-> LensLike IO ClientState ClientState NetworkState NetworkState
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf
    (Text
-> LensLike IO ClientState ClientState NetworkState NetworkState
forall (f :: * -> *).
Applicative f =>
Text -> LensLike' f ClientState NetworkState
clientConnection Text
networkId)
    (TimedAction -> NetworkState -> IO NetworkState
applyTimedAction TimedAction
action)