glirc-2.4: src/Client/State.hs
{-# Language TemplateHaskell, BangPatterns, OverloadedStrings #-}
{-|
Module : Client.State
Description : Primary client state type and update operations
Copyright : (c) Eric Mertens, 2016
License : ISC
Maintainer : emertens@gmail.com
This module provides the core logic of the IRC client. The client
state tracks everything about the client.
-}
module Client.State
(
-- * Client state type
NetworkName
, ClientState(..)
, clientWindows
, clientTextBox
, clientConnections
, clientWidth
, clientHeight
, clientEvents
, clientVty
, clientFocus
, clientConnectionContext
, clientConfig
, clientScroll
, clientDetailView
, clientSubfocus
, clientNextConnectionId
, clientNetworkMap
, clientIgnores
, clientConnection
, clientBell
, initialClientState
-- * Client operations
, clientMatcher
, consumeInput
, currentCompletionList
, ircIgnorable
, clientInput
, abortNetwork
, addConnection
, removeNetwork
, clientTick
, applyMessageToClientState
-- * Add messages to buffers
, recordChannelMessage
, recordNetworkMessage
, recordIrcMessage
-- * Focus information
, ClientFocus(..)
, ClientSubfocus(..)
, focusNetwork
, changeFocus
, changeSubfocus
, advanceFocus
, retreatFocus
, windowNames
) where
import Client.ChannelState
import Client.Configuration
import Client.ConnectionState
import qualified Client.EditBox as Edit
import Client.Image.Message
import Client.Message
import Client.NetworkConnection
import Client.ServerSettings
import Client.Window
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Lens
import Data.Foldable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.ICU as ICU
import Data.Time
import Graphics.Vty
import Irc.Codes
import Irc.Identifier
import Irc.Message
import Irc.RawIrcMsg
import Irc.UserInfo
import LensUtils
import Network.Connection
-- | Textual name of a network connection
type NetworkName = Text
-- | Currently focused window
data ClientFocus
= Unfocused -- ^ No network
| NetworkFocus !NetworkName -- ^ Network
| ChannelFocus !NetworkName !Identifier -- ^ Channel on network
deriving Eq
-- | Subfocus for a channel view
data ClientSubfocus
= FocusMessages -- ^ Show chat messages
| FocusInfo -- ^ Show channel metadata
| FocusUsers -- ^ Show user list
| FocusMasks !Char -- ^ Show mask list for given mode
deriving Eq
-- | Unfocused first, followed by focuses sorted by network.
-- Within the same network the network focus comes first and
-- then the channels are ordered by channel identifier
instance Ord ClientFocus where
compare Unfocused Unfocused = EQ
compare (NetworkFocus x) (NetworkFocus y ) = compare x y
compare (ChannelFocus x1 x2) (ChannelFocus y1 y2) = compare x1 y1 <> compare x2 y2
compare Unfocused _ = LT
compare _ Unfocused = GT
compare (NetworkFocus x ) (ChannelFocus y _) = compare x y <> LT
compare (ChannelFocus x _) (NetworkFocus y ) = compare x y <> GT
-- | All state information for the IRC client
data ClientState = ClientState
{ _clientWindows :: !(Map ClientFocus Window) -- ^ client message buffers
, _clientFocus :: !ClientFocus -- ^ currently focused buffer
, _clientSubfocus :: !ClientSubfocus -- ^ sec
, _clientConnections :: !(IntMap ConnectionState) -- ^ state of active connections
, _clientNextConnectionId :: !Int
, _clientConnectionContext :: !ConnectionContext -- ^ network connection context
, _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue
, _clientNetworkMap :: !(HashMap NetworkName NetworkId)
-- ^ network name to connection ID
, _clientVty :: !Vty -- ^ VTY handle
, _clientTextBox :: !Edit.EditBox -- ^ primary text box
, _clientWidth :: !Int -- ^ current terminal width
, _clientHeight :: !Int -- ^ current terminal height
, _clientConfig :: !Configuration -- ^ client configuration
, _clientScroll :: !Int -- ^ buffer scroll lines
, _clientDetailView :: !Bool -- ^ use detailed rendering mode
, _clientBell :: !Bool -- ^ sound a bell next draw
, _clientIgnores :: !(HashSet Identifier) -- ^ ignored nicknames
}
makeLenses ''ClientState
-- | 'Traversal' for finding the 'ConnectionState' associated with a given network
-- if that connection is currently active.
clientConnection :: Applicative f => NetworkName -> LensLike' f ClientState ConnectionState
clientConnection network f st =
case view (clientNetworkMap . at network) st of
Nothing -> pure st
Just i -> clientConnections (ix i f) st
-- | Full content of the edit box
clientInput :: ClientState -> String
clientInput = view (clientTextBox . Edit.content)
-- | Return the network associated with the current focus
focusNetwork :: ClientFocus -> Maybe NetworkName
focusNetwork Unfocused = Nothing
focusNetwork (NetworkFocus network) = Just network
focusNetwork (ChannelFocus network _) = Just network
-- | Construct an initial 'ClientState' using default values.
initialClientState :: Configuration -> Vty -> IO ClientState
initialClientState cfg vty =
do (width,height) <- displayBounds (outputIface vty)
cxt <- initConnectionContext
events <- atomically newTQueue
return ClientState
{ _clientWindows = _Empty # ()
, _clientTextBox = Edit.empty
, _clientConnections = IntMap.empty
, _clientWidth = width
, _clientHeight = height
, _clientVty = vty
, _clientEvents = events
, _clientFocus = Unfocused
, _clientConnectionContext = cxt
, _clientConfig = cfg
, _clientScroll = 0
, _clientDetailView = False
, _clientSubfocus = FocusMessages
, _clientNextConnectionId = 0
, _clientNetworkMap = HashMap.empty
, _clientIgnores = HashSet.empty
, _clientBell = False
}
-- | Forcefully terminate the connection currently associated
-- with a given network name.
abortNetwork :: NetworkName -> ClientState -> IO ClientState
abortNetwork network st =
case preview (clientConnection network) st of
Nothing -> return st
Just cs -> do abortConnection (view csSocket cs)
return $ set (clientNetworkMap . at network) Nothing st
-- | Add a message to the window associated with a given channel
recordChannelMessage ::
NetworkName ->
Identifier {- ^ channel -} ->
ClientMessage -> ClientState -> ClientState
recordChannelMessage network channel msg st =
over (clientWindows . at focus)
(\w -> Just $! addToWindow importance wl (fromMaybe emptyWindow w))
st
where
focus = ChannelFocus network channel'
wl = toWindowLine rendParams msg
myNicks = toListOf (clientConnection network . csNick) st
rendParams = MessageRendererParams
{ rendStatusMsg = statusModes
, rendUserSigils = computeMsgLineSigils network channel' msg st
, rendNicks = channelUserList network channel' st
, rendMyNicks = myNicks
}
-- on failure returns mempty/""
possibleStatusModes = view (clientConnection network . csStatusMsg) st
(statusModes, channel') = splitStatusMsgModes possibleStatusModes channel
importance = msgImportance msg st
-- | Compute the importance of a message to be used when computing
-- change notifications in the client.
msgImportance :: ClientMessage -> ClientState -> WindowLineImportance
msgImportance msg st =
let network = view msgNetwork msg
me = preview (clientConnection network . csNick) st
isMe x = Just x == me
checkTxt txt = case me of
Just me' | me' `elem` (mkId <$> nickSplit txt) -> WLImportant
_ -> WLNormal
in
case view msgBody msg of
ExitBody -> WLImportant
ErrorBody _ -> WLImportant
IrcBody irc
| squelchIrcMsg irc -> WLBoring
| isJust (ircIgnorable irc st) -> WLBoring
| otherwise ->
case irc of
Privmsg _ tgt txt
| isMe tgt -> WLImportant
| otherwise -> checkTxt txt
Notice _ tgt txt
| isMe tgt -> WLImportant
| otherwise -> checkTxt txt
Ctcp _ _ _ _ -> WLNormal
Part who _ _ | isMe (userNick who) -> WLImportant
| otherwise -> WLBoring
Kick _ _ kicked _ | isMe kicked -> WLImportant
| otherwise -> WLNormal
Error{} -> WLImportant
Reply cmd _ ->
case replyCodeType (replyCodeInfo cmd) of
ErrorReply -> WLImportant
_ -> WLNormal
_ -> WLBoring
-- | Predicate for messages that should be ignored based on the
-- configurable ignore list
ircIgnorable :: IrcMsg -> ClientState -> Maybe Identifier
ircIgnorable msg st =
case msg of
Privmsg who _ _ -> checkUser who
Notice who _ _ -> checkUser who
-- privmsg ctcp commands are already metadata
Ctcp who _ "ACTION" _ -> checkUser who
-- notice ctcp responses are not already metadata
CtcpNotice who _ _ _ -> checkUser who
_ -> Nothing
where
ignores = view clientIgnores st
checkUser !who
| HashSet.member (userNick who) ignores = Just (userNick who)
| otherwise = Nothing
-- | Record a message in the windows corresponding to the given target
recordIrcMessage ::
NetworkName -> MessageTarget -> ClientMessage -> ClientState -> ClientState
recordIrcMessage network target msg st =
case target of
TargetHidden -> st
TargetNetwork -> recordNetworkMessage msg st
TargetWindow chan -> recordChannelMessage network chan msg st
TargetUser user ->
foldl' (\st' chan -> overStrict
(clientWindows . ix (ChannelFocus network chan))
(addToWindow WLBoring wl) st')
st chans
where
wl = toWindowLine' msg
chans = user
: case preview (clientConnection network . csChannels) st of
Nothing -> []
Just m -> [chan | (chan, cs) <- HashMap.toList m
, HashMap.member user (view chanUsers cs) ]
-- | Extract the status mode sigils from a message target.
splitStatusMsgModes ::
[Char] {- ^ possible modes -} ->
Identifier {- ^ target -} ->
([Char], Identifier) {- ^ actual modes, actual target -}
splitStatusMsgModes possible ident = (Text.unpack modes, mkId ident')
where
(modes, ident') = Text.span (`elem` possible) (idText ident)
-- | Compute the sigils of the user who sent a message.
computeMsgLineSigils ::
NetworkName ->
Identifier {- ^ channel -} ->
ClientMessage ->
ClientState ->
[Char] {- ^ sigils -}
computeMsgLineSigils network channel msg st =
case msgActor =<< preview (msgBody . _IrcBody) msg of
Just user -> computeUserSigils network channel (userNick user) st
Nothing -> []
-- | Compute sigils for a user on a channel
computeUserSigils ::
NetworkName ->
Identifier {- ^ channel -} ->
Identifier {- ^ user -} ->
ClientState ->
[Char] {- ^ sigils -}
computeUserSigils network channel user =
view $ clientConnection network
. csChannels . ix channel
. chanUsers . ix user
-- | Record a message on a network window
recordNetworkMessage :: ClientMessage -> ClientState -> ClientState
recordNetworkMessage msg st =
over (clientWindows . at (NetworkFocus network))
(\w -> Just $! addToWindow (msgImportance msg st) wl (fromMaybe emptyWindow w))
st
where
network = view msgNetwork msg
wl = toWindowLine' msg
toWindowLine :: MessageRendererParams -> ClientMessage -> WindowLine
toWindowLine params msg = WindowLine
{ _wlBody = view msgBody msg
, _wlText = views msgBody msgText msg
, _wlImage = force $ msgImage (view msgTime msg) params (view msgBody msg)
, _wlFullImage = force $ detailedMsgImage (view msgTime msg) params (view msgBody msg)
}
toWindowLine' :: ClientMessage -> WindowLine
toWindowLine' = toWindowLine defaultRenderParams
clientTick :: ClientState -> ClientState
clientTick = set clientBell False . markSeen
markSeen :: ClientState -> ClientState
markSeen st =
case view clientSubfocus st of
FocusMessages -> overStrict (clientWindows . ix (view clientFocus st)) windowSeen st
_ -> st
consumeInput :: ClientState -> ClientState
consumeInput = over clientTextBox Edit.success
advanceFocus :: ClientState -> ClientState
advanceFocus st
| view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st
| otherwise =
case Map.split oldFocus windows of
(l,r)
| Just ((k,_),_) <- Map.minViewWithKey r -> success k
| Just ((k,_),_) <- Map.minViewWithKey l -> success k
| otherwise -> st
where
success x = set clientScroll 0
$ set clientFocus x st
oldFocus = view clientFocus st
windows = view clientWindows st
retreatFocus :: ClientState -> ClientState
retreatFocus st
| view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st
| otherwise =
case Map.split oldFocus windows of
(l,r)
| Just ((k,_),_) <- Map.maxViewWithKey l -> success k
| Just ((k,_),_) <- Map.maxViewWithKey r -> success k
| otherwise -> st
where
success x = set clientScroll 0
$ set clientFocus x st
oldFocus = view clientFocus st
windows = view clientWindows st
-- | Returns the current network's channels and current channel's users.
currentCompletionList :: ClientState -> [Identifier]
currentCompletionList st =
case view clientFocus st of
NetworkFocus network ->
networkChannelList network st
ChannelFocus network chan ->
networkChannelList network st
++ channelUserList network chan st
_ -> []
networkChannelList :: NetworkName -> ClientState -> [Identifier]
networkChannelList network =
views (clientConnection network . csChannels) HashMap.keys
channelUserList :: NetworkName -> Identifier -> ClientState -> [Identifier]
channelUserList network channel =
views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys
changeFocus :: ClientFocus -> ClientState -> ClientState
changeFocus focus
= set clientScroll 0
. set clientFocus focus
. set clientSubfocus FocusMessages
changeSubfocus :: ClientSubfocus -> ClientState -> ClientState
changeSubfocus focus
= set clientScroll 0
. set clientSubfocus focus
windowNames :: [Char]
windowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP"
clientMatcher :: ClientState -> Text -> Bool
clientMatcher st =
case break (==' ') (clientInput st) of
("/grep" ,_:reStr) -> go [] reStr
("/grepi",_:reStr) -> go [ICU.CaseInsensitive] reStr
_ -> const True
where
go opts reStr
| not (null reStr)
, Right r <- ICU.regex' opts (Text.pack reStr) = isJust . ICU.find r
| otherwise = const True
-- | Remove a network connection and unlink it from the network map.
-- This operation assumes that the networkconnection exists and should
-- only be applied once per connection.
removeNetwork :: NetworkId -> ClientState -> (ConnectionState, ClientState)
removeNetwork networkId st =
case (clientConnections . at networkId <<.~ Nothing) st of
(Nothing, _ ) -> error "removeNetwork: network not found"
(Just cs, st1) ->
-- Only remove the network mapping if it hasn't already been replace
-- with a new one. This can happen during reconnect in particular.
let network = view csNetwork cs in
case view (clientNetworkMap . at network) st of
Just i | i == networkId ->
(cs, set (clientNetworkMap . at network) Nothing st1)
_ -> (cs,st1)
addConnection :: Text -> ClientState -> IO ClientState
addConnection network st =
do let host = Text.unpack network
defSettings = (view (clientConfig . configDefaults) st)
{ _ssHostName = host }
settings = fromMaybe defSettings
(view (clientConfig . configServers . at host) st)
let (i,st') = st & clientNextConnectionId <+~ 1
c <- createConnection
i
(view clientConnectionContext st')
settings
(view clientEvents st')
let cs = newConnectionState i network settings c
traverse_ (sendMsg cs) (initialMessages cs)
return $ set (clientNetworkMap . at network) (Just i)
$ set (clientConnections . at i) (Just cs) st'
applyMessageToClientState ::
ZonedTime {- ^ message received -} ->
IrcMsg {- ^ message recieved -} ->
NetworkId {- ^ messge network -} ->
ConnectionState {- ^ network connection state -} ->
ClientState ->
([RawIrcMsg], ClientState) {- ^ response , updated state -}
applyMessageToClientState time irc networkId cs st =
cs' `seq` (reply, st')
where
(reply, cs') = applyMessage time irc cs
network = view csNetwork cs
st' = applyWindowRenames network irc
$ set (clientConnections . ix networkId) cs' st
-- | When a nick change happens and there is an open query window for that nick
-- and there isn't an open query window for the new nick, rename the window.
applyWindowRenames :: NetworkName -> IrcMsg -> ClientState -> ClientState
applyWindowRenames network (Nick old new) st
| hasWindow old'
, not (hasWindow new) = over clientFocus moveFocus
$ over clientWindows moveWindow st
| otherwise = st
where
old' = userNick old
mkFocus = ChannelFocus network
hasWindow who = has (clientWindows . ix (mkFocus who)) st
moveWindow :: Map ClientFocus Window -> Map ClientFocus Window
moveWindow wins =
let (win,wins') = (at (mkFocus old') <<.~ Nothing) wins
in set (at (mkFocus new)) win wins'
moveFocus x
| x == mkFocus old' = mkFocus new
| otherwise = x
applyWindowRenames _ _ st = st