diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for glirc2 +## 2.10 + +* Fixes for multiline editing +* Multiple, sequential kills all fill the same yank buffer + ## 2.9 * Dynamically loadable extensions diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.9 +version: 2.10 synopsis: Console IRC client description: Console IRC client license: ISC @@ -26,36 +26,38 @@ executable glirc2 main-is: Main.hs - other-modules: Client.ChannelState - Client.CommandArguments + other-modules: Client.CommandArguments Client.Commands Client.Commands.Interpolation + Client.CApi + Client.CApi.Exports + Client.CApi.Types Client.Commands.WordCompletion Client.Configuration Client.Configuration.Colors Client.Configuration.ServerSettings - Client.ConnectionState - Client.EditBox Client.EventLoop - Client.CApi.Exports - Client.CApi.Types - Client.CApi - Client.Focus Client.Hook - Client.Hooks Client.Hook.Znc.Buffextras + Client.Hooks Client.Image Client.Image.ChannelInfo Client.Image.MaskList Client.Image.Message Client.Image.MircFormatting Client.Image.Palette + Client.Image.StatusLine Client.Image.UserList Client.Message - Client.Network.Connect Client.Network.Async + Client.Network.Connect Client.State - Client.Window + Client.State.Channel + Client.State.EditBox + Client.State.EditBox.Content + Client.State.Focus + Client.State.Network + Client.State.Window Config.FromConfig LensUtils StrictUnit diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs --- a/src/Client/CApi/Exports.hs +++ b/src/Client/CApi/Exports.hs @@ -21,10 +21,10 @@ ) where import Client.CApi.Types -import Client.State -import Client.ChannelState -import Client.ConnectionState import Client.Message +import Client.State +import Client.State.Channel +import Client.State.Network import Control.Concurrent.MVar import Control.Exception import Control.Lens diff --git a/src/Client/ChannelState.hs b/src/Client/ChannelState.hs deleted file mode 100644 --- a/src/Client/ChannelState.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# Language TemplateHaskell #-} - -{-| -Module : Client.ChannelState -Description : IRC channel session state -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module is responsible for tracking the state of an individual IRC -channel while the client is connected to it. When the client joins a -channel a new channel session is created and when the client leaves -a channel is it destroyed. --} - -module Client.ChannelState - ( - -- * Channel state - ChannelState(..) - , chanTopic - , chanTopicProvenance - , chanUrl - , chanUsers - , chanModes - , chanLists - , chanCreation - , chanQueuedModeration - - -- * Mask list entries - , MaskListEntry(..) - , maskListSetter - , maskListTime - - -- * Topic information - , TopicProvenance(..) - , topicAuthor - , topicTime - - -- * Channel manipulation - , newChannel - , setTopic - , joinChannel - , partChannel - , nickChange - ) where - -import Control.Lens -import Data.HashMap.Strict -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Time -import Irc.Identifier -import Irc.RawIrcMsg (RawIrcMsg) -import Irc.UserInfo - --- | Dynamic information about the state of an IRC channel -data ChannelState = ChannelState - { _chanTopic :: !Text - -- ^ topic text - , _chanTopicProvenance :: !(Maybe TopicProvenance) - -- ^ author and timestamp for topic - , _chanUrl :: !(Maybe Text) - -- ^ channel URL - , _chanUsers :: !(HashMap Identifier String) - -- ^ user list and sigils - , _chanModes :: !(Map Char Text) - -- ^ channel settings and parameters - , _chanLists :: !(Map Char (HashMap Text MaskListEntry)) - -- ^ mode, mask, setter, set time - , _chanCreation :: !(Maybe UTCTime) -- ^ creation time of channel - , _chanQueuedModeration :: ![RawIrcMsg] -- ^ delayed op messages - } - deriving Show - -data TopicProvenance = TopicProvenance - { _topicAuthor :: !UserInfo - , _topicTime :: !UTCTime - } - deriving Show - -data MaskListEntry = MaskListEntry - { _maskListSetter :: {-# UNPACK #-} !Text - , _maskListTime :: {-# UNPACK #-} !UTCTime - } - deriving Show - -makeLenses ''ChannelState -makeLenses ''TopicProvenance -makeLenses ''MaskListEntry - --- | Construct an empty 'ChannelState' -newChannel :: ChannelState -newChannel = ChannelState - { _chanTopic = Text.empty - , _chanUrl = Nothing - , _chanTopicProvenance = Nothing - , _chanUsers = HashMap.empty - , _chanModes = Map.empty - , _chanLists = Map.empty - , _chanCreation = Nothing - , _chanQueuedModeration = [] - } - - --- | Add a user to the user list -joinChannel :: Identifier -> ChannelState -> ChannelState -joinChannel nick = set (chanUsers . at nick) (Just "") - --- | Remove a user from the user list -partChannel :: Identifier -> ChannelState -> ChannelState -partChannel nick = set (chanUsers . at nick) Nothing - --- | Rename a user in the user list -nickChange :: Identifier -> Identifier -> ChannelState -> ChannelState -nickChange fromNick toNick cs = - set (chanUsers . at toNick) modes cs' - where - (modes, cs') = cs & chanUsers . at fromNick <<.~ Nothing - --- | Set the channel topic -setTopic :: Text -> ChannelState -> ChannelState -setTopic = set chanTopic diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -19,17 +19,17 @@ ) where import Client.CApi -import Client.ChannelState -import Client.Configuration.ServerSettings import Client.Commands.Interpolation import Client.Commands.WordCompletion import Client.Configuration -import Client.ConnectionState -import qualified Client.EditBox as Edit -import Client.Focus +import Client.Configuration.ServerSettings import Client.Message import Client.State -import Client.Window +import Client.State.Channel +import qualified Client.State.EditBox as Edit +import Client.State.Focus +import Client.State.Network +import Client.State.Window import Control.Lens import Control.Monad import Data.Char @@ -68,7 +68,7 @@ -- | Type of commands that require an active network to be focused type NetworkCommand = Text {- ^ focused network -} -> - ConnectionState {- ^ focused connection state -} -> + NetworkState {- ^ focused connection state -} -> ClientState -> String {- ^ command arguments -} -> IO CommandResult @@ -76,7 +76,7 @@ -- | Type of commands that require an active channel to be focused type ChannelCommand = Text {- ^ focused network -} -> - ConnectionState {- ^ focused connection state -} -> + NetworkState {- ^ focused connection state -} -> Identifier {- ^ focused channel -} -> ClientState -> String {- ^ command arguments -} -> @@ -406,7 +406,7 @@ (UserInfo -> Identifier -> IrcMsg) -> Text {- ^ target -} -> Text {- ^ network -} -> - ConnectionState -> + NetworkState -> ClientState -> IO CommandResult chatCommand con targetsTxt network cs st = @@ -596,7 +596,7 @@ _ -> commandFailure st -commandSuccessUpdateCS :: ConnectionState -> ClientState -> IO CommandResult +commandSuccessUpdateCS :: NetworkState -> ClientState -> IO CommandResult commandSuccessUpdateCS cs st = let networkId = view csNetworkId cs in commandSuccess @@ -621,8 +621,7 @@ | all isSpace rest , Just topic <- preview (csChannels . ix channelId . chanTopic) cs = - do let textBox = Edit.end - . set Edit.line (Edit.endLine $ "/topic " ++ Text.unpack topic) + do let textBox = set Edit.line (Edit.endLine $ "/topic " ++ Text.unpack topic) commandSuccess (over clientTextBox textBox st) | otherwise = commandFailure st @@ -668,7 +667,7 @@ cs' <- sendModeration channelId cmds cs commandSuccessUpdateCS cs' st -computeBanUserInfo :: Identifier -> ConnectionState -> UserInfo +computeBanUserInfo :: Identifier -> NetworkState -> UserInfo computeBanUserInfo who cs = case view (csUser who) cs of Nothing -> UserInfo who "*" "*" @@ -767,7 +766,7 @@ modeCommand :: [Text] {- mode parameters -} -> - ConnectionState -> + NetworkState -> ClientState -> IO CommandResult modeCommand modes cs st = @@ -853,7 +852,7 @@ Bool {- ^ mode polarity -} -> Char {- ^ mode -} -> Identifier {- ^ channel -} -> - ConnectionState -> + NetworkState -> ClientState -> ([Identifier],[Identifier]) {- ^ (hint, complete) -} computeModeCompletion pol mode channel cs st @@ -907,15 +906,15 @@ sendModeration :: Identifier {- ^ channel -} -> [RawIrcMsg] {- ^ commands -} -> - ConnectionState {- ^ network state -} -> - IO ConnectionState + NetworkState {- ^ network state -} -> + IO NetworkState sendModeration channel cmds cs | useChanServ channel cs = do sendMsg cs (ircPrivmsg (mkId "ChanServ") ("OP " <> idText channel)) return $ csChannels . ix channel . chanQueuedModeration <>~ cmds $ cs | otherwise = cs <$ traverse_ (sendMsg cs) cmds -useChanServ :: Identifier -> ConnectionState -> Bool +useChanServ :: Identifier -> NetworkState -> Bool useChanServ channel cs = channel `elem` view (csSettings . ssChanservChannels) cs && not (iHaveOp channel cs) diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs --- a/src/Client/Commands/WordCompletion.hs +++ b/src/Client/Commands/WordCompletion.hs @@ -12,16 +12,16 @@ ( wordComplete ) where -import Irc.Identifier -import Control.Applicative -import Data.Text (Text) -import qualified Data.Text as Text +import qualified Client.State.EditBox as Edit +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Char +import Data.List import qualified Data.Set as Set -import Data.Char -import Data.List -import Control.Lens -import qualified Client.EditBox as Edit -import Control.Monad +import qualified Data.Text as Text +import Data.Text (Text) +import Irc.Identifier -- | Perform word completion on a text box. -- @@ -43,8 +43,8 @@ do let current = currentWord box guard (not (null current)) let cur = mkId (Text.pack current) - case view Edit.tabSeed box of - Just patternStr + case view Edit.lastOperation box of + Edit.TabOperation patternStr | idPrefix pat cur -> do next <- tabSearch isReversed pat cur vals @@ -55,7 +55,7 @@ _ -> do next <- find (idPrefix cur) hint <|> tabSearch isReversed cur cur vals - Just $ set Edit.tabSeed (Just current) + Just $ set Edit.lastOperation (Edit.TabOperation current) $ replaceWith leadingCase (idString next) box replaceWith :: (String -> String) -> String -> Edit.EditBox -> Edit.EditBox @@ -75,7 +75,7 @@ $ dropWhile (\x -> x==' ' || x==':') $ reverse $ take n txt - where Edit.Line n txt = view (Edit.content . Edit.current) box + where Edit.Line n txt = view Edit.line box class Prefix a where isPrefix :: a -> a -> Bool instance Prefix Identifier where isPrefix = idPrefix diff --git a/src/Client/ConnectionState.hs b/src/Client/ConnectionState.hs deleted file mode 100644 --- a/src/Client/ConnectionState.hs +++ /dev/null @@ -1,789 +0,0 @@ -{-# Language TemplateHaskell, OverloadedStrings, BangPatterns #-} - -{-| -Module : Client.ConnectionState -Description : IRC connection session state -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module is responsible for tracking the state of an individual IRC -connection while the client is connected to it. This state includes -user information, server settings, channel membership, and more. - -This module is more complicated than many of the other modules in the -client because it is responsible for interpreting each IRC message from -the server and updating the connection state accordingly. --} - -module Client.ConnectionState - ( - -- * Connection state - ConnectionState(..) - , newConnectionState - - , csNick - , csChannels - , csSocket - , csModeTypes - , csChannelTypes - , csTransaction - , csModes - , csStatusMsg - , csSettings - , csUserInfo - , csUsers - , csUser - , csModeCount - , csNetworkId - , csNetwork - , csNextPingTime - , csPingStatus - , csMessageHooks - - -- * User information - , UserAndHost(..) - - -- * Cross-message state - , Transaction(..) - - -- * Connection predicates - , isChannelIdentifier - , iHaveOp - - -- * Messages interactions - , sendMsg - , initialMessages - , applyMessage - , squelchIrcMsg - - -- * Timer information - , PingStatus(..) - , TimedAction(..) - , nextTimedAction - , applyTimedAction - ) where - -import Client.ChannelState -import Client.Configuration.ServerSettings -import Client.Network.Async -import Control.Lens -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet -import qualified Data.ByteString as B -import qualified Data.Map.Strict as Map -import Data.Bits -import Data.Foldable -import Data.List -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Read as Text -import Data.Time -import Data.Time.Clock.POSIX -import Irc.Codes -import Irc.Commands -import Irc.Identifier -import Irc.Message -import Irc.Modes -import Irc.RawIrcMsg -import Irc.UserInfo -import LensUtils - --- | State tracked for each IRC connection -data ConnectionState = ConnectionState - { _csNetworkId :: !NetworkId -- ^ network connection identifier - , _csChannels :: !(HashMap Identifier ChannelState) -- ^ joined channels - , _csSocket :: !NetworkConnection -- ^ network socket - , _csModeTypes :: !ModeTypes -- ^ channel mode meanings - , _csChannelTypes :: ![Char] -- ^ channel identifier prefixes - , _csTransaction :: !Transaction -- ^ state for multi-message sequences - , _csModes :: ![Char] -- ^ modes for the connected user - , _csStatusMsg :: ![Char] -- ^ modes that prefix statusmsg channel names - , _csSettings :: !ServerSettings -- ^ settings used for this connection - , _csUserInfo :: !UserInfo -- ^ usermask used by the server for this connection - , _csUsers :: !(HashMap Identifier UserAndHost) -- ^ user and hostname for other nicks - , _csModeCount :: !Int -- ^ maximum mode changes per MODE command - , _csNetwork :: !Text -- ^ name of network connection - , _csNextPingTime :: !(Maybe UTCTime) -- ^ time for next ping event - , _csPingStatus :: !PingStatus -- ^ state of ping timer - , _csMessageHooks :: ![Text] -- ^ names of message hooks to apply to this connection - } - deriving Show - --- | Pair of username and hostname. Empty strings represent missing information. -data UserAndHost = - UserAndHost {-# UNPACK #-} !Text {-# UNPACK #-} !Text - -- ^ username hostname - deriving Show - --- | Status of the ping timer -data PingStatus - = PingSent !UTCTime -- ^ ping sent waiting for pong - | PingLatency !Double -- ^ latency in seconds for last ping - | PingNever -- ^ no ping sent - deriving Show - -data Transaction - = NoTransaction - | NamesTransaction [Text] - | BanTransaction [(Text,MaskListEntry)] - | WhoTransaction [UserInfo] - deriving Show - -makeLenses ''ConnectionState -makePrisms ''Transaction - -csNick :: Lens' ConnectionState Identifier -csNick = csUserInfo . uiNick - -sendMsg :: ConnectionState -> RawIrcMsg -> IO () -sendMsg cs msg = - case (view msgCommand msg, view msgParams msg) of - ("PRIVMSG", [tgt,txt]) -> multiline "PRIVMSG" tgt txt - ("NOTICE", [tgt,txt]) -> multiline "NOTICE" tgt txt - _ -> transmit msg - where - transmit = send (view csSocket cs) . renderRawIrcMsg - - multiline cmd tgt txt = - for_ txtChunks $ \txtChunk -> - transmit $ rawIrcMsg cmd [tgt, txtChunk] - where - txtChunks = utf8ChunksOf maxContentLen txt - maxContentLen = computeMaxMessageLength (view csUserInfo cs) tgt - --- This is an approximation for splitting the text. It doesn't --- understand combining characters. A correct implementation --- probably needs to use icu, but its going to take some work --- to use that library to do this. -utf8ChunksOf :: Int -> Text -> [Text] -utf8ChunksOf n txt - | B.length enc <= n = [txt] -- fast/common case - | otherwise = search 0 0 txt info - where - isBeginning b = b .&. 0xc0 /= 0x80 - - enc = Text.encodeUtf8 txt - - beginnings = B.findIndices isBeginning enc - - info = zip3 [0..] -- charIndex - beginnings - (drop 1 beginnings ++ [B.length enc]) - - search startByte startChar currentTxt xs = - case dropWhile (\(_,_,byteLen) -> byteLen-startByte <= n) xs of - [] -> [currentTxt] - (charIx,byteIx,_):xs' -> - case Text.splitAt (charIx - startChar) currentTxt of - (a,b) -> a : search byteIx charIx b xs' - -newConnectionState :: - NetworkId -> - Text -> - ServerSettings -> - NetworkConnection -> - ConnectionState -newConnectionState networkId network settings sock = ConnectionState - { _csNetworkId = networkId - , _csUserInfo = UserInfo (mkId (view ssNick settings)) "" "" - , _csChannels = HashMap.empty - , _csSocket = sock - , _csChannelTypes = "#&" - , _csModeTypes = defaultModeTypes - , _csTransaction = NoTransaction - , _csModes = "" - , _csStatusMsg = "" - , _csSettings = settings - , _csModeCount = 3 - , _csUsers = HashMap.empty - , _csNetwork = network - , _csPingStatus = PingNever - , _csNextPingTime = Nothing - , _csMessageHooks = view ssMessageHooks settings - } - - - -noReply :: ConnectionState -> ([RawIrcMsg], ConnectionState) -noReply x = ([], x) - -overChannel :: Identifier -> (ChannelState -> ChannelState) -> ConnectionState -> ConnectionState -overChannel chan = overStrict (csChannels . ix chan) - -overChannels :: (ChannelState -> ChannelState) -> ConnectionState -> ConnectionState -overChannels = overStrict (csChannels . traverse) - -applyMessage :: ZonedTime -> IrcMsg -> ConnectionState -> ([RawIrcMsg], ConnectionState) -applyMessage msgWhen msg cs = - case msg of - Ping args -> ([ircPong args], cs) - Pong _ -> noReply $ doPong msgWhen cs - Join user chan -> - noReply - $ recordUser user - $ overChannel chan (joinChannel (userNick user)) - $ createOnJoin user chan cs - - Quit user _reason -> - noReply - $ forgetUser (userNick user) - $ overChannels (partChannel (userNick user)) cs - - Part user chan _mbreason -> - noReply - $ forgetUser' (userNick user) -- possibly forget - $ if userNick user == view csNick cs - then set (csChannels . at chan) Nothing cs - else overChannel chan (partChannel (userNick user)) cs - - Nick oldNick newNick -> - noReply - $ renameUser (userNick oldNick) newNick - $ updateMyNick (userNick oldNick) newNick - $ overChannels (nickChange (userNick oldNick) newNick) cs - - Kick _kicker chan nick _reason -> - noReply - $ forgetUser' nick - $ overChannel chan (partChannel nick) cs - Reply RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs - Reply RPL_SASLSUCCESS _ -> ([ircCapEnd], cs) - Reply RPL_SASLFAIL _ -> ([ircCapEnd], cs) - Reply code args -> noReply (doRpl code msgWhen args cs) - Cap cmd params -> doCap cmd params cs - Authenticate param -> doAuthenticate param cs - Mode who target (modes:params) -> doMode msgWhen who target modes params cs - Topic user chan topic -> noReply (doTopic msgWhen user chan topic cs) - _ -> noReply cs - --- | 001 'RPL_WELCOME' is the first message received when transitioning --- from the initial handshake to a connected state. At this point we know --- what nickname the server is using for our connection, and we can start --- scheduling PINGs. -doWelcome :: - ZonedTime {- ^ message received -} -> - Identifier {- ^ my nickname -} -> - ConnectionState -> ([RawIrcMsg], ConnectionState) -doWelcome msgWhen me - = noReply - . set csNick me - . set csNextPingTime (Just $! addUTCTime 30 (zonedTimeToUTC msgWhen)) - -doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> ConnectionState -> ConnectionState -doTopic when user chan topic = - overChannel chan (setTopic topic . set chanTopicProvenance (Just $! prov)) - where - prov = TopicProvenance - { _topicAuthor = user - , _topicTime = zonedTimeToUTC when - } - -parseTimeParam :: Text -> Maybe UTCTime -parseTimeParam txt = - case Text.decimal txt of - Right (i, rest) | Text.null rest -> - Just $! posixSecondsToUTCTime (fromInteger i) - _ -> Nothing - -doRpl :: ReplyCode -> ZonedTime -> [Text] -> ConnectionState -> ConnectionState -doRpl cmd msgWhen args = - case cmd of - RPL_UMODEIS -> - case args of - _me:modes:params - | Just xs <- splitModes defaultUmodeTypes modes params -> - doMyModes xs - . set csModes "" -- reset modes - _ -> id - - RPL_NOTOPIC -> - case args of - _me:chan:_ -> overChannel - (mkId chan) - (setTopic "" . set chanTopicProvenance Nothing) - _ -> id - - RPL_TOPIC -> - case args of - _me:chan:topic:_ -> overChannel (mkId chan) (setTopic topic) - _ -> id - - RPL_TOPICWHOTIME -> - case args of - _me:chan:who:whenTxt:_ | Just when <- parseTimeParam whenTxt -> - let !prov = TopicProvenance - { _topicAuthor = parseUserInfo who - , _topicTime = when - } - in overChannel (mkId chan) (set chanTopicProvenance (Just prov)) - _ -> id - - RPL_CREATIONTIME -> - case args of - _me:chan:whenTxt:_ | Just when <- parseTimeParam whenTxt -> - overChannel (mkId chan) (set chanCreation (Just when)) - _ -> id - - RPL_CHANNEL_URL -> - case args of - _me:chan:urlTxt:_ -> - overChannel (mkId chan) (set chanUrl (Just urlTxt)) - _ -> id - - RPL_ISUPPORT -> isupport args - - RPL_NAMREPLY -> - case args of - _me:_sym:_tgt:x:_ -> - over csTransaction - (\t -> let xs = view _NamesTransaction t - in xs `seq` NamesTransaction (x:xs)) - _ -> id - - RPL_ENDOFNAMES -> - case args of - _me:tgt:_ -> loadNamesList (mkId tgt) - _ -> id - - RPL_BANLIST -> - case args of - _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt - _ -> id - - RPL_ENDOFBANLIST -> - case args of - _me:tgt:_ -> saveList 'b' tgt - _ -> id - - RPL_QUIETLIST -> - case args of - _me:_tgt:_q:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt - _ -> id - - RPL_ENDOFQUIETLIST -> - case args of - _me:tgt:_ -> saveList 'q' tgt - _ -> id - - RPL_INVEXLIST -> - case args of - _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt - _ -> id - - RPL_ENDOFINVEXLIST -> - case args of - _me:tgt:_ -> saveList 'I' tgt - _ -> id - - RPL_EXCEPTLIST -> - case args of - _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt - _ -> id - - RPL_ENDOFEXCEPTLIST -> - case args of - _me:tgt:_ -> saveList 'e' tgt - _ -> id - - RPL_WHOREPLY -> - case args of - _me:_tgt:uname:host:_server:nick:_ -> - over csTransaction $ \t -> - let !x = UserInfo (mkId nick) uname host - !xs = view _WhoTransaction t - in WhoTransaction (x : xs) - _ -> id - - RPL_ENDOFWHO -> massRegistration - - RPL_CHANNELMODEIS -> - case args of - _me:chan:modes:params -> - snd -- channel mode reply shouldn't trigger messages - . doMode msgWhen who chanId modes params - . set (csChannels . ix chanId . chanModes) Map.empty - where chanId = mkId chan - !who = UserInfo (mkId "*") "" "" - _ -> id - _ -> id - - --- | Add an entry to a mode list transaction -recordListEntry :: - Text {- ^ mask -} -> - Text {- ^ set by -} -> - Text {- ^ set time -} -> - ConnectionState -> ConnectionState -recordListEntry mask who whenTxt = - case parseTimeParam whenTxt of - Nothing -> id - Just when -> - over csTransaction $ \t -> - let !x = MaskListEntry - { _maskListSetter = who - , _maskListTime = when - } - !xs = view _BanTransaction t - in BanTransaction ((mask,x):xs) - - --- | Save a completed ban, quiet, invex, or exempt list into the channel --- state. -saveList :: - Char {- ^ mode -} -> - Text {- ^ channel -} -> - ConnectionState -> ConnectionState -saveList mode tgt cs - = set csTransaction NoTransaction - $ setStrict - (csChannels . ix (mkId tgt) . chanLists . at mode) - (Just $! newList) - cs - where - newList = HashMap.fromList (view (csTransaction . _BanTransaction) cs) - - --- | These replies are interpreted by the client and should only be shown --- in the detailed view. -squelchReply :: ReplyCode -> Bool -squelchReply rpl = - case rpl of - RPL_NAMREPLY -> True - RPL_ENDOFNAMES -> True - RPL_BANLIST -> True - RPL_ENDOFBANLIST -> True - RPL_INVEXLIST -> True - RPL_ENDOFINVEXLIST -> True - RPL_EXCEPTLIST -> True - RPL_ENDOFEXCEPTLIST -> True - RPL_QUIETLIST -> True - RPL_ENDOFQUIETLIST -> True - RPL_CHANNELMODEIS -> True - RPL_TOPIC -> True - RPL_TOPICWHOTIME -> True - RPL_CREATIONTIME -> True - RPL_CHANNEL_URL -> True - RPL_NOTOPIC -> True - RPL_UMODEIS -> True - RPL_WHOREPLY -> True - RPL_ENDOFWHO -> True - _ -> False - --- | Return 'True' for messages that should be hidden outside of --- full detail view. These messages are interpreted by the client --- so the user shouldn't need to see them directly to get the --- relevant information. -squelchIrcMsg :: IrcMsg -> Bool -squelchIrcMsg (Reply rpl _) = squelchReply rpl -squelchIrcMsg _ = False - -doMode :: - ZonedTime {- ^ time of message -} -> - UserInfo {- ^ sender -} -> - Identifier {- ^ channel -} -> - Text {- ^ mode flags -} -> - [Text] {- ^ mode parameters -} -> - ConnectionState -> ([RawIrcMsg], ConnectionState) -doMode when who target modes args cs - | view csNick cs == target - , Just xs <- splitModes defaultUmodeTypes modes args = - noReply (doMyModes xs cs) - - | isChannelIdentifier cs target - , Just xs <- splitModes (view csModeTypes cs) modes args = - let cs' = doChannelModes when who target xs cs - - finish | iHaveOp target cs' = popQueue - | otherwise = noReply - - in finish cs' - where - popQueue :: ConnectionState -> ([RawIrcMsg], ConnectionState) - popQueue = csChannels . ix target . chanQueuedModeration <<.~ [] - -doMode _ _ _ _ _ cs = noReply cs -- ignore bad mode command - --- | Predicate to test if the connection has op in a given channel. -iHaveOp :: Identifier -> ConnectionState -> Bool -iHaveOp channel cs = - elemOf (csChannels . ix channel . chanUsers . ix me . folded) '@' cs - where - me = view csNick cs - - -doChannelModes :: ZonedTime -> UserInfo -> Identifier -> [(Bool, Char, Text)] -> ConnectionState -> ConnectionState -doChannelModes when who chan changes cs = overChannel chan applyChannelModes cs - where - modeTypes = view csModeTypes cs - sigilMap = view modesPrefixModes modeTypes - listModes = view modesLists modeTypes - - applyChannelModes c = foldl' applyChannelMode c changes - - applyChannelMode c (polarity, mode, arg) - - | Just sigil <- lookup mode sigilMap = - overStrict (chanUsers . ix (mkId arg)) - (setPrefixMode polarity sigil) - c - - | mode `elem` listModes = - let entry | polarity = Just $! MaskListEntry - { _maskListSetter = renderUserInfo who - , _maskListTime = zonedTimeToUTC when - } - | otherwise = Nothing - in setStrict (chanLists . ix mode . at arg) entry c - - | polarity = set (chanModes . at mode) (Just arg) c - | otherwise = set (chanModes . at mode) Nothing c - - setPrefixMode polarity sigil sigils - | not polarity = delete sigil sigils - | sigil `elem` sigils = sigils - | otherwise = filter (`elem` sigils') (map snd sigilMap) - where - sigils' = sigil : sigils - - -doMyModes :: [(Bool, Char, Text)] -> ConnectionState -> ConnectionState -doMyModes changes = over csModes $ \modes -> sort (foldl' applyOne modes changes) - where - applyOne modes (True, mode, _) - | mode `elem` modes = modes - | otherwise = mode:modes - applyOne modes (False, mode, _) = delete mode modes - -supportedCaps :: ConnectionState -> [Text] -supportedCaps cs = - sasl ++ ["multi-prefix", "znc.in/batch", "znc.in/playback", - "znc.in/server-time-iso", "znc.in/self-message"] - where - ss = view csSettings cs - sasl = ["sasl" | isJust (view ssSaslUsername ss) - , isJust (view ssSaslPassword ss) ] - -doAuthenticate :: Text -> ConnectionState -> ([RawIrcMsg], ConnectionState) -doAuthenticate "+" cs - | Just user <- view ssSaslUsername ss - , Just pass <- view ssSaslPassword ss - = ([ircAuthenticate (encodePlainAuthentication user pass)], cs) - where - ss = view csSettings cs - -doAuthenticate _ cs = ([ircCapEnd], cs) - -doCap :: CapCmd -> [Text] -> ConnectionState -> ([RawIrcMsg], ConnectionState) -doCap cmd args cs = - case (cmd,args) of - (CapLs,[capsTxt]) - | null reqCaps -> ([ircCapEnd], cs) - | otherwise -> ([ircCapReq reqCaps], cs) - where - caps = Text.words capsTxt - reqCaps = intersect (supportedCaps cs) caps - - (CapAck,[capsTxt]) - | "sasl" `elem` caps -> - ([ircAuthenticate plainAuthenticationMode], cs) - where - caps = Text.words capsTxt - - _ -> ([ircCapEnd], cs) - - -initialMessages :: ConnectionState -> [RawIrcMsg] -initialMessages cs - = [ ircCapLs ] - ++ [ ircPass pass | Just pass <- [view ssPassword ss]] - ++ [ ircUser (view ssUser ss) False True (view ssReal ss) - , ircNick (view csNick cs) - ] - where - ss = view csSettings cs - -loadNamesList :: Identifier -> ConnectionState -> ConnectionState -loadNamesList chan cs - = set csTransaction NoTransaction - $ setStrict (csChannels . ix chan . chanUsers) newChanUsers - $ cs - where - newChanUsers = HashMap.fromList (splitEntry "" <$> entries) - - sigils = toListOf (csModeTypes . modesPrefixModes . folded . _2) cs - - splitEntry modes str - | Text.head str `elem` sigils = splitEntry (Text.head str : modes) - (Text.tail str) - | otherwise = (mkId str, reverse modes) - - entries = - concatMap Text.words (view (csTransaction . _NamesTransaction) cs) - - -createOnJoin :: UserInfo -> Identifier -> ConnectionState -> ConnectionState -createOnJoin who chan cs - | userNick who == view csNick cs = - set csUserInfo who -- great time to learn our userinfo - $ set (csChannels . at chan) (Just newChannel) cs - | otherwise = cs - -updateMyNick :: Identifier -> Identifier -> ConnectionState -> ConnectionState -updateMyNick oldNick newNick cs - | oldNick == view csNick cs = set csNick newNick cs - | otherwise = cs - --- ISUPPORT is defined by --- https://tools.ietf.org/html/draft-brocklesby-irc-isupport-03#section-3.14 -isupport :: - [Text] {- ^ ["key=value"] -} -> - ConnectionState -> - ConnectionState -isupport [] conn = conn -isupport params conn = foldl' (flip isupport1) conn - $ map parseISupport - $ init params - where - isupport1 ("CHANTYPES",types) = set csChannelTypes (Text.unpack types) - isupport1 ("CHANMODES",modes) = updateChanModes modes - isupport1 ("PREFIX" ,modes) = updateChanPrefix modes - isupport1 ("STATUSMSG",prefix) = set csStatusMsg (Text.unpack prefix) - isupport1 ("MODES",nstr) | Right (n,"") <- Text.decimal nstr = - set csModeCount n - isupport1 _ = id - -parseISupport :: Text -> (Text,Text) -parseISupport str = - case Text.break (=='=') str of - (key,val) -> (key, Text.drop 1 val) - -updateChanModes :: - Text {- lists,always,set,never -} -> - ConnectionState -> - ConnectionState -updateChanModes modes - = over csModeTypes - $ set modesLists listModes - . set modesAlwaysArg alwaysModes - . set modesSetArg setModes - . set modesNeverArg neverModes - -- Note: doesn't set modesPrefixModes - where - next = over _2 (drop 1) . break (==',') - (listModes ,modes1) = next (Text.unpack modes) - (alwaysModes,modes2) = next modes1 - (setModes ,modes3) = next modes2 - (neverModes ,_) = next modes3 - -updateChanPrefix :: - Text {- e.g. "(ov)@+" -} -> - ConnectionState -> - ConnectionState -updateChanPrefix txt = - case parsePrefixes txt of - Just prefixes -> set (csModeTypes . modesPrefixModes) prefixes - Nothing -> id - -parsePrefixes :: Text -> Maybe [(Char,Char)] -parsePrefixes txt = - case uncurry Text.zip (Text.break (==')') txt) of - ('(',')'):rest -> Just rest - _ -> Nothing - -isChannelIdentifier :: ConnectionState -> Identifier -> Bool -isChannelIdentifier cs ident = - case Text.uncons (idText ident) of - Just (p, _) -> p `elem` view csChannelTypes cs - _ -> False - ------------------------------------------------------------------------- --- Helpers for managing the user list ------------------------------------------------------------------------- - -csUser :: Functor f => Identifier -> LensLike' f ConnectionState (Maybe UserAndHost) -csUser i = csUsers . at i - -recordUser :: UserInfo -> ConnectionState -> ConnectionState -recordUser (UserInfo nick user host) - | Text.null user || Text.null host = id - | otherwise = set (csUsers . at nick) - (Just (UserAndHost user host)) - -forgetUser :: Identifier -> ConnectionState -> ConnectionState -forgetUser nick = set (csUsers . at nick) Nothing - -renameUser :: Identifier -> Identifier -> ConnectionState -> ConnectionState -renameUser old new cs = set (csUsers . at new) entry cs' - where - (entry,cs') = cs & csUsers . at old <<.~ Nothing - -forgetUser' :: Identifier -> ConnectionState -> ConnectionState -forgetUser' nick cs - | keep = cs - | otherwise = forgetUser nick cs - where - keep = has (csChannels . folded . chanUsers . ix nick) cs - --- | Process a list of WHO replies -massRegistration :: ConnectionState -> ConnectionState -massRegistration cs - = set csTransaction NoTransaction - $ over csUsers updateUsers cs - where - infos = view (csTransaction . _WhoTransaction) cs - - channelUsers = - HashSet.fromList (views (csChannels . folded . chanUsers) HashMap.keys cs) - - updateUsers users = foldl' updateUser users infos - - updateUser users (UserInfo nick user host) - | not (Text.null user) - , not (Text.null host) - , HashSet.member nick channelUsers = - HashMap.insert nick (UserAndHost user host) users - | otherwise = users - --- | Timer-based events -data TimedAction - = TimedDisconnect -- ^ terminate the connection due to timeout - | TimedSendPing -- ^ transmit a ping to the server - deriving (Eq, Ord, Show) - --- | Compute the earliest timed action for a connection, if any -nextTimedAction :: ConnectionState -> Maybe (UTCTime, TimedAction) -nextTimedAction cs = - do runAt <- view csNextPingTime cs - return (runAt, action) - where - action = - case view csPingStatus cs of - PingSent{} -> TimedDisconnect - PingLatency{} -> TimedSendPing - PingNever -> TimedSendPing - -doPong :: ZonedTime -> ConnectionState -> ConnectionState -doPong when cs = set csPingStatus (PingLatency delta) cs - where - delta = - case view csPingStatus cs of - PingSent sent -> realToFrac (diffUTCTime (zonedTimeToUTC when) sent) - _ -> 0 - --- | Apply the given 'TimedAction' to a connection state. -applyTimedAction :: TimedAction -> ConnectionState -> IO ConnectionState -applyTimedAction action cs = - case action of - TimedDisconnect -> - do abortConnection (view csSocket cs) - return $! set csNextPingTime Nothing cs - - TimedSendPing -> - do now <- getCurrentTime - sendMsg cs (ircPing ["ping"]) - return $! set csNextPingTime (Just $! addUTCTime 60 now) - $ set csPingStatus (PingSent now) cs diff --git a/src/Client/EditBox.hs b/src/Client/EditBox.hs deleted file mode 100644 --- a/src/Client/EditBox.hs +++ /dev/null @@ -1,399 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module : Client.EditBox -Description : Console-mode text box -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module provides support for the text operations important for -providing a text input in the IRC client. It tracks user input -history, tab completion history, and provides many update operations -which are mapped to the keyboard in "Client.EventLoop". - --} - -module Client.EditBox - ( Line(Line) - , endLine - , HasLine(..) - , Content - , above - , current - , below - , singleLine - , firstLine - , EditBox - , content - , tabSeed - , delete - , backspace - , home - , end - , killHome - , killEnd - , killWordBackward - , killWordForward - , paste - , left - , right - , leftWord - , rightWord - , insert - , insertString - , empty - , earlier - , later - , success - ) where - -import Control.Lens hiding (below) -import Data.Char - -data Line = Line - { _pos :: !Int - , _text :: !String - } - deriving (Read, Show) - -makeClassy ''Line - -emptyLine :: Line -emptyLine = Line 0 "" - -endLine :: String -> Line -endLine s = Line (length s) s - --- | Zipper-ish view of the multi-line content of an 'EditBox'. --- Lines 'above' the 'current' are stored in reverse order. -data Content = Content - { _above :: ![String] - , _current :: !Line - , _below :: ![String] - } - deriving (Read, Show) - -makeLenses ''Content - -instance HasLine Content where - line = current - --- | Default 'Content' value -noContent :: Content -noContent = Content [] emptyLine [] - --- | Single line 'Content'. -singleLine :: Line -> Content -singleLine l = Content [] l [] - --- | Shifts the first line off of the 'Content', yielding the --- text of the line and the rest of the content. -shift :: Content -> (String, Content) -shift (Content [] l []) = (view text l, noContent) -shift (Content a@(_:_) l b) = (last a, Content (init a) l b) -shift (Content [] l (b:bs)) = (view text l, Content [] (endLine b) bs) - -firstLine :: Content -> String -firstLine (Content a c _) = head (reverse a ++ [_text c]) - -jumpLeft :: Content -> Content -jumpLeft c - | view pos c == 0 - , a:as <- view above c - = over below (cons $ view text c) - . set text a - . set above as - $ c - | otherwise = set pos 0 c - -jumpRight :: Content -> Content -jumpRight c - | view pos c == len - , b:bs <- view below c - = over above (cons $ view text c) - . set text b - . set pos len - . set below bs - $ c - | otherwise = set pos len c - where len = views text length c - --- Move the cursor left, across lines if necessary. -left :: Content -> Content -left c - | n > 0 - = over (current.pos) (subtract 1) c - - | n == 0 - , a:as <- view above c - = over below (cons s) - . set above as - . set current (endLine a) - $ c - - | otherwise = c - where Line n s = view current c - --- Move the cursor right, across lines if necessary. -right :: Content -> Content -right c - | n < length s - = over (current.pos) (+1) c - - | n == length s - , b:bs <- view below c - = over above (cons s) - . set below bs - . set current (Line 0 b) - $ c - - | otherwise = c - where Line n s = view current c - --- | Move the cursor left to the previous word boundary. -leftWord :: Content -> Content -leftWord c - | n == 0 - = case view above c of - [] -> c - (a:as) -> leftWord - . set current (endLine a) - . over below (cons txt) - . set above as - $ c - | otherwise - = case search of - [] -> set (current.pos) 0 c - (i,_):_ -> set (current.pos) (i+1) c - where - Line n txt = view current c - search = dropWhile (isAlphaNum . snd) - $ dropWhile (not . isAlphaNum . snd) - $ reverse - $ take n - $ zip [0..] - $ txt - --- | Move the cursor right to the next word boundary. -rightWord :: Content -> Content -rightWord c - | n == length txt - = case view below c of - [] -> c - (b:bs) -> rightWord - . set current (endLine b) - . over above (cons txt) - . set below bs - $ c - | otherwise - = case search of - [] -> set (current.pos) (length txt) c - (i,_):_ -> set (current.pos) i c - where - Line n txt = view current c - search = dropWhile (isAlphaNum . snd) - $ dropWhile (not . isAlphaNum . snd) - $ drop n - $ zip [0..] - $ txt - --- | Delete the character before the cursor. -backspace :: Content -> Content -backspace c - | n == 0 - = case view above c of - [] -> c - a:as -> set above as - . set current (Line (length a) (a ++ s)) - $ c - - | (preS, postS) <- splitAt (n-1) s - = set current (Line (n-1) (preS ++ drop 1 postS)) c - where - Line n s = view current c - --- | Delete the character after/under the cursor. -delete :: Content -> Content -delete c - | n == length s - = case view below c of - [] -> c - b:bs -> set below bs - . set current (Line n (s ++ b)) - $ c - - | (preS, postS) <- splitAt n s - = set current (Line n (preS ++ drop 1 postS)) c - where - Line n s = view current c - -insertString :: String -> Content -> Content -insertString ins c = case push (view above c) (preS ++ l) ls of - (newAbove, newCurrent) -> set above newAbove . set current newCurrent $ c - where - l:ls = lines (ins ++ "\n") - Line n txt = view current c - (preS, postS) = splitAt n txt - - push stk x [] = (stk, Line (length x) (x ++ postS)) - push stk x (y:ys) = push (x:stk) y ys - -data EditBox = EditBox - { _content :: !Content - , _history :: ![String] - , _historyPos :: !Int - , _yankBuffer :: !(String) - , _tabSeed :: !(Maybe String) - } - deriving (Read, Show) - -makeLenses ''EditBox - --- | Default 'EditBox' value -empty :: EditBox -empty = EditBox - { _content = noContent - , _history = [] - , _historyPos = -1 - , _yankBuffer = "" - , _tabSeed = Nothing - } - -instance HasLine EditBox where - line = content . line - --- | Sets the given string to the yank buffer unless the string is empty. -updateYankBuffer :: String -> EditBox -> EditBox -updateYankBuffer str - | null str = id - | otherwise = set yankBuffer str - --- | Indicate that the contents of the text box were successfully used --- by the program. This clears the first line of the contents and updates --- the history. -success :: EditBox -> EditBox -success e - = over history (cons sent) - $ set content c - $ set tabSeed Nothing - $ set historyPos (-1) - $ e - where - (sent, c) = shift $ view content e - --- | Update the editbox to reflect the earlier element in the history. -earlier :: EditBox -> Maybe EditBox -earlier e = - do let i = view historyPos e + 1 - x <- preview (history . ix i) e - return $ set content (singleLine . endLine $ x) - $ set historyPos i e - --- | Update the editbox to reflect the later element in the history. -later :: EditBox -> Maybe EditBox -later e - | i < 0 = Nothing - | i == 0 = Just - $ set content noContent - $ set historyPos (-1) e - | otherwise = - do x <- preview (history . ix (i-1)) e - return $ set content (singleLine . endLine $ x) - $ set historyPos (i-1) e - where - i = view historyPos e - --- | Jump the cursor to the beginning of the input. -home :: EditBox -> EditBox -home - = set tabSeed Nothing - . over content jumpLeft - --- | Jump the cursor to the end of the input. -end :: EditBox -> EditBox -end - = set tabSeed Nothing - . over content jumpRight - --- | Delete all text from the cursor to the end and store it in --- the yank buffer. -killEnd :: EditBox -> EditBox -killEnd e - | null kill - = case view (content.below) e of - [] -> e - b:bs -> set (content.below) bs - $ updateYankBuffer b e - | otherwise - = set (content.current) (endLine keep) - $ updateYankBuffer kill e - where - Line n txt = view (content.current) e - (keep,kill) = splitAt n txt - --- | Delete all text from the cursor to the beginning and store it in --- the yank buffer. -killHome :: EditBox -> EditBox -killHome e - | null kill - = case view (content.above) e of - [] -> e - a:as -> set (content.above) as - . set tabSeed Nothing - $ updateYankBuffer a e - - | otherwise - = set (content.current) (Line 0 keep) - $ set tabSeed Nothing - $ updateYankBuffer kill e - where - Line n txt = view (content.current) e - (kill,keep) = splitAt n txt - --- | Insert the yank buffer at the cursor. -paste :: EditBox -> EditBox -paste e = over content (insertString (view yankBuffer e)) e - --- | Kill the content from the cursor back to the previous word boundary. --- When @yank@ is set the yank buffer will be updated. -killWordBackward :: Bool {- ^ yank -} -> EditBox -> EditBox -killWordBackward yank e - = sometimesUpdateYank - $ set (content.current) (Line (length l') (l'++r)) - $ e - where - Line n txt = view (content.current) e - (l,r) = splitAt n txt - (sp,l1) = span isSpace (reverse l) - (wd,l2) = break isSpace l1 - l' = reverse l2 - yanked = reverse (sp++wd) - - sometimesUpdateYank - | yank = updateYankBuffer yanked - | otherwise = id - --- | Kill the content from the curser forward to the next word boundary. --- When @yank@ is set the yank buffer will be updated -killWordForward :: Bool {- ^ yank -} -> EditBox -> EditBox -killWordForward yank e - = sometimesUpdateYank - $ set (content.current) (Line (length l) (l++r2)) - $ e - where - Line n txt = view (content.current) e - (l,r) = splitAt n txt - (sp,r1) = span isSpace r - (wd,r2) = break isSpace r1 - yanked = sp++wd - - sometimesUpdateYank - | yank = updateYankBuffer yanked - | otherwise = id - --- | Insert a character at the cursor and advance the cursor. -insert :: Char -> EditBox -> EditBox -insert c - = set tabSeed Nothing - . over content (insertString [c]) diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -19,14 +19,14 @@ import Client.Commands import Client.Configuration import Client.Configuration.ServerSettings -import Client.ConnectionState -import qualified Client.EditBox as Edit import Client.Hook import Client.Hooks import Client.Image import Client.Message import Client.Network.Async import Client.State +import qualified Client.State.EditBox as Edit +import Client.State.Network import Control.Concurrent.STM import Control.Exception import Control.Lens @@ -205,8 +205,8 @@ -- | Client-level responses to specific IRC messages. -- This is in contrast to the connection state tracking logic in --- "Client.ConnectionState" -clientResponse :: ZonedTime -> IrcMsg -> ConnectionState -> ClientState -> IO ClientState +-- "Client.NetworkState " +clientResponse :: ZonedTime -> IrcMsg -> NetworkState -> ClientState -> IO ClientState clientResponse now irc cs st = case irc of Reply RPL_WELCOME _ -> @@ -218,7 +218,7 @@ processConnectCmd :: ZonedTime {- ^ now -} -> - ConnectionState {- ^ current network -} -> + NetworkState {- ^ current network -} -> ClientState -> Text {- ^ command -} -> IO ClientState @@ -232,7 +232,7 @@ reportConnectCmdError :: ZonedTime {- ^ now -} -> - ConnectionState {- ^ current network -} -> + NetworkState {- ^ current network -} -> Text {- ^ bad command -} -> ClientState -> ClientState @@ -285,8 +285,11 @@ -- | Map keyboard inputs to actions in the client doKey :: Key -> [Modifier] -> ClientState -> IO () doKey key modifier st = - let changeEditor f = eventLoop (over clientTextBox f st) - changeContent f = eventLoop (over (clientTextBox . Edit.content) f st) in + let changeEditor f = eventLoop (over clientTextBox f st) + changeContent f = changeEditor + $ over Edit.content f + . set Edit.lastOperation Edit.OtherOperation + in case modifier of [MCtrl] -> case key of diff --git a/src/Client/Focus.hs b/src/Client/Focus.hs deleted file mode 100644 --- a/src/Client/Focus.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module : Client.Focus -Description : Types for representing the current window being displayed -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -The client has a primary message window whose contents are determined -by a 'ClientFocus'. In order to provide different views of channels -the 'ClientSubfocus' breaks down channel focus into different subviews. --} - -module Client.Focus - ( -- * Types - ClientFocus(..) - , ClientSubfocus(..) - - -- * Focus operations - , focusNetwork - - -- * Focus Prisms - , _ChannelFocus - , _NetworkFocus - , _Unfocused - - -- * Subfocus Prisms - , _FocusMessages - , _FocusInfo - , _FocusUsers - , _FocusMasks - ) where - -import Control.Lens -import Data.Monoid ((<>)) -import Data.Text (Text) -import Irc.Identifier - --- | Currently focused window -data ClientFocus - = Unfocused -- ^ No network - | NetworkFocus !Text -- ^ Network - | ChannelFocus !Text !Identifier -- ^ Network Channel/Nick - deriving (Eq,Show) - -makePrisms ''ClientFocus - --- | 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,Show) - -makePrisms ''ClientSubfocus - --- | 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 - --- | Return the network associated with the current focus -focusNetwork :: ClientFocus -> Maybe Text {- ^ network -} -focusNetwork Unfocused = Nothing -focusNetwork (NetworkFocus network) = Just network -focusNetwork (ChannelFocus network _) = Just network diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -11,29 +11,27 @@ -} module Client.Image (clientPicture) where -import Client.ChannelState import Client.Configuration -import Client.ConnectionState -import qualified Client.EditBox as Edit -import Client.Focus import Client.Image.ChannelInfo import Client.Image.MaskList import Client.Image.Message import Client.Image.MircFormatting import Client.Image.Palette +import Client.Image.StatusLine import Client.Image.UserList import Client.Message import Client.State -import Client.Window +import qualified Client.State.EditBox as Edit +import Client.State.Focus +import Client.State.Network +import Client.State.Window import Control.Lens -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Text (Text) +import Data.Char +import Data.List import qualified Data.Text as Text -import Graphics.Vty (Picture(..), Cursor(..), picForImage) +import Graphics.Vty (Background(..), Picture(..), Cursor(..)) import Graphics.Vty.Image -import Irc.Identifier (Identifier, idText) -import Numeric +import Irc.Identifier (Identifier) -- | Generate a 'Picture' for the current client state. The resulting -- client state is updated for render specific information like scrolling. @@ -41,19 +39,22 @@ clientPicture st = (pic, st') where (pos, img, st') = clientImage st - pic0 = picForImage img - pic = pic0 { picCursor = cursor } - cursor = Cursor (min (view clientWidth st - 1) (pos+1)) - (view clientHeight st - 1) + pic = Picture + { picCursor = Cursor pos (view clientHeight st - 1) + , picBackground = ClearBackground + , picLayers = [img] + } -clientImage :: ClientState -> (Int, Image, ClientState) +clientImage :: + ClientState -> + (Int, Image, ClientState) -- ^ text box cursor position, image, updated state clientImage st = (pos, img, st') where (mp, st') = messagePane st (pos, tbImg) = textboxImage st' img = vertCat [ mp - , horizDividerImage st' + , statusLineImage st' , tbImg ] @@ -93,9 +94,9 @@ messagePane st = (img, st') where images = messagePaneImages st - vimg = assemble emptyImage images - vimg1 = cropBottom h vimg - img = pad 0 (h - imageHeight vimg1) 0 0 vimg1 + vimg = assemble emptyImage images + vimg1 = cropBottom h vimg + img = pad 0 (h - imageHeight vimg1) 0 0 vimg1 overscroll = vh - imageHeight vimg @@ -106,39 +107,77 @@ assemble acc (x:xs) = assemble (lineWrap w x <-> acc) xs scroll = view clientScroll st - vh = h + scroll - h = view clientHeight st - 2 - w = view clientWidth st + vh = h + scroll + h = view clientHeight st - 2 + w = view clientWidth st windowLinesToImages :: ClientState -> [WindowLine] -> [Image] windowLinesToImages st wwls = - case windowLinesToImagesMd st wwls of - Just (img, _, wls) -> img : windowLinesToImages st wls - Nothing -> - case wwls of - [] -> [] - wl:wls -> view wlImage wl : windowLinesToImages st wls + case gatherMetadataLines st wwls of + ([], []) -> [] + ([], w:ws) -> view wlImage w : windowLinesToImages st ws + ((img,who,mbnext):mds, wls) -> + startMetadata img mbnext who mds palette + : windowLinesToImages st wls + where + palette = view (clientConfig . configPalette) st -windowLinesToImagesMd :: - ClientState -> [WindowLine] -> Maybe (Image, Identifier, [WindowLine]) -windowLinesToImagesMd st wwls = - do w:wls <- Just wwls - (img, ident, mbnext) <- metadataWindowLine st w - let palette = view (clientConfig . configPalette) st +------------------------------------------------------------------------ - (acc1, wls2) = - case windowLinesToImagesMd st wls of - Nothing -> (quietIdentifier palette ident <|> img, wls) - Just (acc, prevident, wls') -> (acc <|> transition <|> img, wls') - where - transition - | ident == prevident = emptyImage - | otherwise = char defAttr ' ' <|> quietIdentifier palette ident +type MetadataState = + Identifier {- ^ current nick -} -> + [(Image,Identifier,Maybe Identifier)] {- ^ metadata -} -> + Palette {- ^ palette -} -> + Image - let transition2 = foldMap (quietIdentifier palette) mbnext - Just (acc1 <|> transition2, fromMaybe ident mbnext, wls2) +startMetadata :: + Image {- ^ metadata image -} -> + Maybe Identifier {- ^ possible nick transition -} -> + MetadataState +startMetadata img mbnext who mds palette = + quietIdentifier palette who + <|> img + <|> transitionMetadata mbnext who mds palette -metadataWindowLine :: ClientState -> WindowLine -> Maybe (Image, Identifier, Maybe Identifier) +transitionMetadata :: + Maybe Identifier {- ^ possible nick transition -} -> + MetadataState +transitionMetadata mbwho who mds palette = + case mbwho of + Nothing -> continueMetadata who mds palette + Just who' -> quietIdentifier palette who' + <|> continueMetadata who' mds palette + +continueMetadata :: MetadataState +continueMetadata _ [] _ = emptyImage +continueMetadata who1 ((img, who2, mbwho3):mds) palette + | who1 == who2 = img + <|> transitionMetadata mbwho3 who2 mds palette + | otherwise = char defAttr ' ' + <|> startMetadata img mbwho3 who2 mds palette + +------------------------------------------------------------------------ + +gatherMetadataLines :: + ClientState -> + [WindowLine] -> + ( [(Image, Identifier, Maybe Identifier)] , [ WindowLine ] ) + -- ^ metadata entries are reversed +gatherMetadataLines st = go [] + where + go acc (w:ws) + | Just (img,who,mbnext) <- metadataWindowLine st w = + go ((img,who,mbnext) : acc) ws + + go acc ws = (acc,ws) + + +-- | Classify window lines for metadata coalesence +metadataWindowLine :: + ClientState -> + WindowLine -> + Maybe (Image, Identifier, Maybe Identifier) + {- ^ Image, incoming identifier, outgoing identifier if changed -} metadataWindowLine st wl = case view wlBody wl of IrcBody irc @@ -154,187 +193,56 @@ -- where the formatting will continue past the end of chat messages -horizDividerImage :: ClientState -> Image -horizDividerImage st - = content <|> charFill defAttr '─' fillSize 1 - where - fillSize = max 0 (view clientWidth st - imageWidth content) - content = horizCat - [ myNickImage st - , focusImage st - , activityImage st - , detailImage st - , scrollImage st - , latencyImage st - ] - -parens :: Attr -> Image -> Image -parens attr i = char attr '(' <|> i <|> char attr ')' - -scrollImage :: ClientState -> Image -scrollImage st - | 0 == view clientScroll st = emptyImage - | otherwise = horizCat - [ string defAttr "─(" - , string attr "scroll" - , string defAttr ")" - ] - where - attr = view (clientConfig . configPalette . palLabel) st - -detailImage :: ClientState -> Image -detailImage st - | view clientDetailView st = horizCat - [ string defAttr "─(" - , string attr "detail" - , string defAttr ")" - ] - | otherwise = emptyImage - where - attr = view (clientConfig . configPalette . palLabel) st - -activityImage :: ClientState -> Image -activityImage st - | null indicators = emptyImage - | otherwise = string defAttr "─[" <|> - horizCat indicators <|> - string defAttr "]" - where - windows = views clientWindows Map.elems st - windowNames = view (clientConfig . configWindowNames) st - winNames = Text.unpack windowNames ++ repeat '?' - indicators = aux (zip winNames windows) - aux [] = [] - aux ((i,w):ws) - | view winUnread w == 0 = aux ws - | otherwise = char attr i : aux ws - where - pal = view (clientConfig . configPalette) st - attr | view winMention w = view palMention pal - | otherwise = view palActivity pal - - -myNickImage :: ClientState -> Image -myNickImage st = - case view clientFocus st of - NetworkFocus network -> nickPart network Nothing - ChannelFocus network chan -> nickPart network (Just chan) - Unfocused -> emptyImage - where - pal = view (clientConfig . configPalette) st - nickPart network mbChan = - case preview (clientConnection network) st of - Nothing -> emptyImage - Just cs -> string (view palSigil pal) myChanModes - <|> text' defAttr (idText nick) - <|> parens defAttr (string defAttr ('+' : view csModes cs)) - <|> char defAttr '─' - where - nick = view csNick cs - myChanModes = - case mbChan of - Nothing -> [] - Just chan -> view (csChannels . ix chan . chanUsers . ix nick) cs - - -focusImage :: ClientState -> Image -focusImage st = parens defAttr majorImage <|> renderedSubfocus +textboxImage :: ClientState -> (Int, Image) +textboxImage st + = (pos, croppedImage) where - majorImage = horizCat - [ char (view palWindowName pal) windowName - , char defAttr ':' - , renderedFocus - ] - - pal = view (clientConfig . configPalette) st - focus = view clientFocus st - windowNames = view (clientConfig . configWindowNames) st - - windowName = - case Map.lookupIndex focus (view clientWindows st) of - Just i | i < Text.length windowNames -> Text.index windowNames i - _ -> '?' - - subfocusName = - case view clientSubfocus st of - FocusMessages -> Nothing - FocusInfo -> Just $ string (view palLabel pal) "info" - FocusUsers -> Just $ string (view palLabel pal) "users" - FocusMasks m -> Just $ horizCat - [ string (view palLabel pal) "masks" - , char defAttr ':' - , char (view palLabel pal) m - ] + width = view clientWidth st + (txt, content) = + views (clientTextBox . Edit.content) renderContent st - renderedSubfocus = - foldMap (\name -> horizCat - [ string defAttr "─(" - , name - , char defAttr ')' - ]) subfocusName + pos = computeCharWidth (width-1) txt - renderedFocus = - case focus of - Unfocused -> - char (view palError pal) '*' - NetworkFocus network -> - text' (view palLabel pal) network - ChannelFocus network channel -> - text' (view palLabel pal) network <|> - char defAttr ':' <|> - text' (view palLabel pal) (idText channel) <|> - channelModesImage network channel st + lineImage = beginning <|> content <|> ending -channelModesImage :: Text -> Identifier -> ClientState -> Image -channelModesImage network channel st = - case preview (clientConnection network . csChannels . ix channel . chanModes) st of - Just modeMap | not (null modeMap) -> - string defAttr (" +" ++ modes) <|> - horizCat [ char defAttr ' ' <|> text' defAttr arg | arg <- args, not (Text.null arg) ] - where (modes,args) = unzip (Map.toList modeMap) - _ -> emptyImage + leftOfCurWidth = safeWcswidth txt -textboxImage :: ClientState -> (Int, Image) -textboxImage st - = (pos, applyCrop $ beginning <|> content <|> ending) - where - width = view clientWidth st - (pos, content) = views (clientTextBox . Edit.content) renderContent st - applyCrop - | 1+pos < width = cropRight width - | otherwise = cropLeft width . cropRight (pos+2) + croppedImage + | leftOfCurWidth < width = lineImage + | otherwise = cropLeft width (cropRight (leftOfCurWidth+1) lineImage) attr = view (clientConfig . configPalette . palTextBox) st beginning = char attr '^' ending = char attr '$' -renderContent :: Edit.Content -> (Int, Image) -renderContent c = (imgPos, wholeImg) +renderContent :: Edit.Content -> (String, Image) +renderContent c = (txt, wholeImg) where - as = view Edit.above c - bs = view Edit.below c - cur = view Edit.current c + as = reverse (view Edit.above c) + bs = view Edit.below c + cur = view Edit.line c - imgPos = view Edit.pos cur + length as + sum (map length as) + leftCur = take (view Edit.pos cur) (view Edit.text cur) renderLine l = parseIrcTextExplicit $ Text.pack l - curImg = views Edit.text renderLine cur - rightImg = foldl (\i b -> i <|> renderLine ('\n':b)) curImg bs - wholeImg = foldl (\i a -> renderLine (a ++ "\n") <|> i) rightImg as + inputLines = as ++ view Edit.text cur : bs -latencyImage :: ClientState -> Image -latencyImage st - | Just network <- views clientFocus focusNetwork st - , Just cs <- preview (clientConnection network) st = - case view csPingStatus cs of - PingNever -> emptyImage - PingSent {} -> emptyImage - PingLatency delta -> horizCat - [ string defAttr "─(" - , string (view palLatency pal) (showFFloat (Just 2) delta "s") - , string defAttr ")" - ] - | otherwise = emptyImage + -- ["one","two"] "three" --> "^two one three" + txt = '^' : foldl (\acc x -> x++' ':acc) leftCur as + + wholeImg = horizCat + $ intersperse (renderLine "\n") + $ map renderLine inputLines + +computeCharWidth :: Int -> String -> Int +computeCharWidth = go 0 where - pal = view (clientConfig . configPalette) st + go !acc _ [] = acc + go acc 0 _ = acc + go acc w (x:xs) + | z > w = acc + w -- didn't fit, will be filled in + | otherwise = go (acc+1) (w-z) xs + where + z | isControl x = 1 + | otherwise = safeWcwidth x diff --git a/src/Client/Image/ChannelInfo.hs b/src/Client/Image/ChannelInfo.hs --- a/src/Client/Image/ChannelInfo.hs +++ b/src/Client/Image/ChannelInfo.hs @@ -16,13 +16,13 @@ ( channelInfoImages ) where -import Client.ChannelState import Client.Configuration -import Client.ConnectionState -import Client.Image.Palette import Client.Image.Message import Client.Image.MircFormatting +import Client.Image.Palette import Client.State +import Client.State.Channel +import Client.State.Network import Control.Lens import Data.Text (Text) import Data.Time @@ -44,7 +44,7 @@ where pal = view (clientConfig . configPalette) st -channelInfoImages' :: Palette -> ChannelState -> ConnectionState -> [Image] +channelInfoImages' :: Palette -> ChannelState -> NetworkState -> [Image] channelInfoImages' pal !channel !cs = topicLine : provenanceLines diff --git a/src/Client/Image/MaskList.hs b/src/Client/Image/MaskList.hs --- a/src/Client/Image/MaskList.hs +++ b/src/Client/Image/MaskList.hs @@ -13,11 +13,11 @@ ( maskListImages ) where -import Client.ChannelState import Client.Configuration -import Client.ConnectionState import Client.Image.Palette import Client.State +import Client.State.Channel +import Client.State.Network import Control.Lens import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/StatusLine.hs @@ -0,0 +1,187 @@ +{-| +Module : Client.Image.StatusLine +Description : Renderer for status line +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides image renderers used to construct +the status image that sits between text input and the message +window. + +-} +module Client.Image.StatusLine + ( statusLineImage + ) where + +import Client.Configuration +import Client.Image.Palette +import Client.State +import Client.State.Channel +import Client.State.Focus +import Client.State.Network +import Client.State.Window +import Control.Lens +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Graphics.Vty.Image +import Irc.Identifier (Identifier, idText) +import Numeric + +statusLineImage :: ClientState -> Image +statusLineImage st + = content <|> charFill defAttr '─' fillSize 1 + where + fillSize = max 0 (view clientWidth st - imageWidth content) + content = horizCat + [ myNickImage st + , focusImage st + , activityImage st + , detailImage st + , scrollImage st + , latencyImage st + ] + + +scrollImage :: ClientState -> Image +scrollImage st + | 0 == view clientScroll st = emptyImage + | otherwise = horizCat + [ string defAttr "─(" + , string attr "scroll" + , string defAttr ")" + ] + where + attr = view (clientConfig . configPalette . palLabel) st + +latencyImage :: ClientState -> Image +latencyImage st + | Just network <- views clientFocus focusNetwork st + , Just cs <- preview (clientConnection network) st = + case view csPingStatus cs of + PingNever -> emptyImage + PingSent {} -> emptyImage + PingLatency delta -> horizCat + [ string defAttr "─(" + , string (view palLatency pal) (showFFloat (Just 2) delta "s") + , string defAttr ")" + ] + | otherwise = emptyImage + where + pal = view (clientConfig . configPalette) st + +detailImage :: ClientState -> Image +detailImage st + | view clientDetailView st = horizCat + [ string defAttr "─(" + , string attr "detail" + , string defAttr ")" + ] + | otherwise = emptyImage + where + attr = view (clientConfig . configPalette . palLabel) st + +activityImage :: ClientState -> Image +activityImage st + | null indicators = emptyImage + | otherwise = string defAttr "─[" <|> + horizCat indicators <|> + string defAttr "]" + where + windows = views clientWindows Map.elems st + windowNames = view (clientConfig . configWindowNames) st + winNames = Text.unpack windowNames ++ repeat '?' + indicators = aux (zip winNames windows) + aux [] = [] + aux ((i,w):ws) + | view winUnread w == 0 = aux ws + | otherwise = char attr i : aux ws + where + pal = view (clientConfig . configPalette) st + attr | view winMention w = view palMention pal + | otherwise = view palActivity pal + + +myNickImage :: ClientState -> Image +myNickImage st = + case view clientFocus st of + NetworkFocus network -> nickPart network Nothing + ChannelFocus network chan -> nickPart network (Just chan) + Unfocused -> emptyImage + where + pal = view (clientConfig . configPalette) st + nickPart network mbChan = + case preview (clientConnection network) st of + Nothing -> emptyImage + Just cs -> string (view palSigil pal) myChanModes + <|> text' defAttr (idText nick) + <|> parens defAttr (string defAttr ('+' : view csModes cs)) + <|> char defAttr '─' + where + nick = view csNick cs + myChanModes = + case mbChan of + Nothing -> [] + Just chan -> view (csChannels . ix chan . chanUsers . ix nick) cs + + +focusImage :: ClientState -> Image +focusImage st = parens defAttr majorImage <|> renderedSubfocus + where + majorImage = horizCat + [ char (view palWindowName pal) windowName + , char defAttr ':' + , renderedFocus + ] + + pal = view (clientConfig . configPalette) st + focus = view clientFocus st + windowNames = view (clientConfig . configWindowNames) st + + windowName = + case Map.lookupIndex focus (view clientWindows st) of + Just i | i < Text.length windowNames -> Text.index windowNames i + _ -> '?' + + subfocusName = + case view clientSubfocus st of + FocusMessages -> Nothing + FocusInfo -> Just $ string (view palLabel pal) "info" + FocusUsers -> Just $ string (view palLabel pal) "users" + FocusMasks m -> Just $ horizCat + [ string (view palLabel pal) "masks" + , char defAttr ':' + , char (view palLabel pal) m + ] + + renderedSubfocus = + foldMap (\name -> horizCat + [ string defAttr "─(" + , name + , char defAttr ')' + ]) subfocusName + + renderedFocus = + case focus of + Unfocused -> + char (view palError pal) '*' + NetworkFocus network -> + text' (view palLabel pal) network + ChannelFocus network channel -> + text' (view palLabel pal) network <|> + char defAttr ':' <|> + text' (view palLabel pal) (idText channel) <|> + channelModesImage network channel st + +channelModesImage :: Text -> Identifier -> ClientState -> Image +channelModesImage network channel st = + case preview (clientConnection network . csChannels . ix channel . chanModes) st of + Just modeMap | not (null modeMap) -> + string defAttr (" +" ++ modes) <|> + horizCat [ char defAttr ' ' <|> text' defAttr arg | arg <- args, not (Text.null arg) ] + where (modes,args) = unzip (Map.toList modeMap) + _ -> emptyImage + +parens :: Attr -> Image -> Image +parens attr i = char attr '(' <|> i <|> char attr ')' diff --git a/src/Client/Image/UserList.hs b/src/Client/Image/UserList.hs --- a/src/Client/Image/UserList.hs +++ b/src/Client/Image/UserList.hs @@ -10,12 +10,12 @@ -} module Client.Image.UserList where -import Client.ChannelState import Client.Configuration -import Client.ConnectionState import Client.Image.Message import Client.Image.Palette import Client.State +import Client.State.Channel +import Client.State.Network import Control.Lens import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map @@ -40,7 +40,7 @@ where pal = view (clientConfig . configPalette) st -userListImages' :: ConnectionState -> Identifier -> ClientState -> [Image] +userListImages' :: NetworkState -> Identifier -> ClientState -> [Image] userListImages' cs channel st = [countImage, horizCat (intersperse gap (map renderUser usersList))] where @@ -90,7 +90,7 @@ where pal = view (clientConfig . configPalette) st -userInfoImages' :: ConnectionState -> Identifier -> ClientState -> [Image] +userInfoImages' :: NetworkState -> Identifier -> ClientState -> [Image] userInfoImages' cs channel st = renderEntry <$> usersList where matcher = clientMatcher st diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -70,16 +70,16 @@ ) where import Client.CApi -import Client.ChannelState import Client.Configuration import Client.Configuration.ServerSettings -import Client.ConnectionState -import qualified Client.EditBox as Edit -import Client.Focus import Client.Image.Message import Client.Message import Client.Network.Async -import Client.Window +import Client.State.Channel +import qualified Client.State.EditBox as Edit +import Client.State.Focus +import Client.State.Network +import Client.State.Window import Control.Concurrent.STM import Control.DeepSeq import Control.Exception @@ -112,11 +112,11 @@ -- | 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 + { _clientWindows :: !(Map Focus Window) -- ^ client message buffers + , _clientFocus :: !Focus -- ^ currently focused buffer + , _clientSubfocus :: !Subfocus -- ^ sec - , _clientConnections :: !(IntMap ConnectionState) -- ^ state of active connections + , _clientConnections :: !(IntMap NetworkState) -- ^ state of active connections , _clientNextConnectionId :: !Int , _clientConnectionContext :: !ConnectionContext -- ^ network connection context , _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue @@ -138,20 +138,20 @@ makeLenses ''ClientState --- | 'Traversal' for finding the 'ConnectionState' associated with a given network +-- | 'Traversal' for finding the 'NetworkState' associated with a given network -- if that connection is currently active. clientConnection :: Applicative f => Text {- ^ network -} -> - LensLike' f ClientState ConnectionState + LensLike' f ClientState NetworkState 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 +-- | The full top-most line that would be executed clientFirstLine :: ClientState -> String -clientFirstLine = views (clientTextBox . Edit.content) Edit.firstLine +clientFirstLine = fst . Edit.shift . view (clientTextBox . Edit.content) -- | The line under the cursor in the edit box. clientLine :: ClientState -> (Int, String) {- ^ line number, line content -} @@ -168,7 +168,7 @@ , _clientNetworkMap = _Empty # () , _clientIgnores = _Empty # () , _clientConnections = _Empty # () - , _clientTextBox = Edit.empty + , _clientTextBox = Edit.defaultEditBox , _clientWidth = width , _clientHeight = height , _clientVty = vty @@ -355,7 +355,7 @@ -- | Record window line at the given focus creating the window if necessary recordWindowLine :: - ClientFocus -> + Focus -> WindowLineImportance -> WindowLine -> ClientState -> ClientState @@ -439,7 +439,7 @@ -- | 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 -> ClientState -> (NetworkState, ClientState) removeNetwork networkId st = case (clientConnections . at networkId <<.~ Nothing) st of (Nothing, _ ) -> error "removeNetwork: network not found" @@ -469,7 +469,7 @@ settings (view clientEvents st') - let cs = newConnectionState i network settings c + let cs = newNetworkState i network settings c traverse_ (sendMsg cs) (initialMessages cs) return $ set (clientNetworkMap . at network) (Just i) @@ -479,7 +479,7 @@ ZonedTime {- ^ timestamp -} -> IrcMsg {- ^ message recieved -} -> NetworkId {- ^ message network -} -> - ConnectionState {- ^ network connection state -} -> + NetworkState {- ^ network connection state -} -> ClientState -> ([RawIrcMsg], ClientState) {- ^ response , updated state -} applyMessageToClientState time irc networkId cs st = @@ -508,7 +508,7 @@ hasWindow who = has (clientWindows . ix (mkFocus who)) st - moveWindow :: Map ClientFocus Window -> Map ClientFocus Window + moveWindow :: Map Focus Window -> Map Focus Window moveWindow wins = let (win,wins') = (at (mkFocus old') <<.~ Nothing) wins in set (at (mkFocus new)) win wins' @@ -600,13 +600,13 @@ windows = view clientWindows st (focus,_) = Map.elemAt i windows -changeFocus :: ClientFocus -> ClientState -> ClientState +changeFocus :: Focus -> ClientState -> ClientState changeFocus focus = set clientScroll 0 . set clientFocus focus . set clientSubfocus FocusMessages -changeSubfocus :: ClientSubfocus -> ClientState -> ClientState +changeSubfocus :: Subfocus -> ClientState -> ClientState changeSubfocus focus = set clientScroll 0 . set clientSubfocus focus diff --git a/src/Client/State/Channel.hs b/src/Client/State/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/Channel.hs @@ -0,0 +1,125 @@ +{-# Language TemplateHaskell #-} + +{-| +Module : Client.State.Channel +Description : IRC channel session state +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module is responsible for tracking the state of an individual IRC +channel while the client is connected to it. When the client joins a +channel a new channel session is created and when the client leaves +a channel is it destroyed. +-} + +module Client.State.Channel + ( + -- * Channel state + ChannelState(..) + , chanTopic + , chanTopicProvenance + , chanUrl + , chanUsers + , chanModes + , chanLists + , chanCreation + , chanQueuedModeration + + -- * Mask list entries + , MaskListEntry(..) + , maskListSetter + , maskListTime + + -- * Topic information + , TopicProvenance(..) + , topicAuthor + , topicTime + + -- * Channel manipulation + , newChannel + , setTopic + , joinChannel + , partChannel + , nickChange + ) where + +import Control.Lens +import Data.HashMap.Strict +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time +import Irc.Identifier +import Irc.RawIrcMsg (RawIrcMsg) +import Irc.UserInfo + +-- | Dynamic information about the state of an IRC channel +data ChannelState = ChannelState + { _chanTopic :: !Text + -- ^ topic text + , _chanTopicProvenance :: !(Maybe TopicProvenance) + -- ^ author and timestamp for topic + , _chanUrl :: !(Maybe Text) + -- ^ channel URL + , _chanUsers :: !(HashMap Identifier String) + -- ^ user list and sigils + , _chanModes :: !(Map Char Text) + -- ^ channel settings and parameters + , _chanLists :: !(Map Char (HashMap Text MaskListEntry)) + -- ^ mode, mask, setter, set time + , _chanCreation :: !(Maybe UTCTime) -- ^ creation time of channel + , _chanQueuedModeration :: ![RawIrcMsg] -- ^ delayed op messages + } + deriving Show + +data TopicProvenance = TopicProvenance + { _topicAuthor :: !UserInfo + , _topicTime :: !UTCTime + } + deriving Show + +data MaskListEntry = MaskListEntry + { _maskListSetter :: {-# UNPACK #-} !Text + , _maskListTime :: {-# UNPACK #-} !UTCTime + } + deriving Show + +makeLenses ''ChannelState +makeLenses ''TopicProvenance +makeLenses ''MaskListEntry + +-- | Construct an empty 'ChannelState' +newChannel :: ChannelState +newChannel = ChannelState + { _chanTopic = Text.empty + , _chanUrl = Nothing + , _chanTopicProvenance = Nothing + , _chanUsers = HashMap.empty + , _chanModes = Map.empty + , _chanLists = Map.empty + , _chanCreation = Nothing + , _chanQueuedModeration = [] + } + + +-- | Add a user to the user list +joinChannel :: Identifier -> ChannelState -> ChannelState +joinChannel nick = set (chanUsers . at nick) (Just "") + +-- | Remove a user from the user list +partChannel :: Identifier -> ChannelState -> ChannelState +partChannel nick = set (chanUsers . at nick) Nothing + +-- | Rename a user in the user list +nickChange :: Identifier -> Identifier -> ChannelState -> ChannelState +nickChange fromNick toNick cs = + set (chanUsers . at toNick) modes cs' + where + (modes, cs') = cs & chanUsers . at fromNick <<.~ Nothing + +-- | Set the channel topic +setTopic :: Text -> ChannelState -> ChannelState +setTopic = set chanTopic diff --git a/src/Client/State/EditBox.hs b/src/Client/State/EditBox.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/EditBox.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Client.State.EditBox +Description : Console-mode text box +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides support for the text operations important for +providing a text input in the IRC client. It tracks user input +history, tab completion history, and provides many update operations +which are mapped to the keyboard in "Client.EventLoop". + +-} + +module Client.State.EditBox + ( -- * Edit box type + EditBox + , defaultEditBox + , content + , lastOperation + + -- * Line type + , Line(Line) + , singleLine + , endLine + , HasLine(..) + + -- * Content type + , Content + , shift + , above + , below + + -- * Operations + , delete + , backspace + , home + , end + , killHome + , killEnd + , killWordBackward + , killWordForward + , paste + , left + , right + , leftWord + , rightWord + , insert + , insertString + , earlier + , later + , success + + -- * Last operation + , LastOperation(..) + + ) where + +import Client.State.EditBox.Content +import Control.Lens hiding (below) +import Data.Char + + +data EditBox = EditBox + { _content :: !Content + , _history :: ![String] + , _historyPos :: !Int + , _yankBuffer :: String + , _lastOperation :: !LastOperation + } + deriving (Read, Show) + +data LastOperation + = TabOperation String + | KillOperation + | OtherOperation + deriving (Read, Show) + +makeLenses ''EditBox + +-- | Default 'EditBox' value +defaultEditBox :: EditBox +defaultEditBox = EditBox + { _content = noContent + , _history = [] + , _historyPos = -1 + , _yankBuffer = "" + , _lastOperation = OtherOperation + } + +instance HasLine EditBox where + line = content . line + +data KillDirection = KillForward | KillBackward + +-- | Sets the given string to the yank buffer unless the string is empty. +updateYankBuffer :: KillDirection -> String -> EditBox -> EditBox +updateYankBuffer dir str e = + case view lastOperation e of + _ | null str -> set lastOperation OtherOperation e -- failed kill interrupts kill sequence + KillOperation -> + case dir of + KillForward -> over yankBuffer (++ str) e + KillBackward -> over yankBuffer (str ++) e + _ -> set yankBuffer str + $ set lastOperation KillOperation e + +-- | Indicate that the contents of the text box were successfully used +-- by the program. This clears the first line of the contents and updates +-- the history. +success :: EditBox -> EditBox +success e + = over history (cons sent) + $ set content c + $ set lastOperation OtherOperation + $ set historyPos (-1) + $ e + where + (sent, c) = shift $ view content e + +-- | Update the editbox to reflect the earlier element in the history. +earlier :: EditBox -> Maybe EditBox +earlier e = + do let i = view historyPos e + 1 + x <- preview (history . ix i) e + return $ set content (singleLine (endLine x)) + $ set lastOperation OtherOperation + $ set historyPos i e + +-- | Update the editbox to reflect the later element in the history. +later :: EditBox -> Maybe EditBox +later e + | i < 0 = Nothing + | i == 0 = Just + $ set content noContent + $ set lastOperation OtherOperation + $ set historyPos (-1) e + | otherwise = + do x <- preview (history . ix (i-1)) e + return $ set content (singleLine (endLine x)) + $ set lastOperation OtherOperation + $ set historyPos (i-1) e + where + i = view historyPos e + +-- | Jump the cursor to the beginning of the input. +home :: EditBox -> EditBox +home + = set lastOperation OtherOperation + . over content jumpLeft + +-- | Jump the cursor to the end of the input. +end :: EditBox -> EditBox +end + = set lastOperation OtherOperation + . over content jumpRight + +-- | Delete all text from the cursor to the end and store it in +-- the yank buffer. +killEnd :: EditBox -> EditBox +killEnd e + | null kill + = case view (content . below) e of + [] -> e + b:bs -> set (content . below) bs + $ updateYankBuffer KillForward b e -- add newline? + | otherwise + = set line (endLine keep) + $ updateYankBuffer KillForward kill e + where + Line n txt = view line e + (keep,kill) = splitAt n txt + +-- | Delete all text from the cursor to the beginning and store it in +-- the yank buffer. +killHome :: EditBox -> EditBox +killHome e + | null kill + = case view (content.above) e of + [] -> e + a:as -> set (content.above) as + $ updateYankBuffer KillBackward a e + + | otherwise + = set line (Line 0 keep) + $ updateYankBuffer KillBackward kill e + where + Line n txt = view line e + (kill,keep) = splitAt n txt + +-- | Insert the yank buffer at the cursor. +paste :: EditBox -> EditBox +paste e + = over content (insertString (view yankBuffer e)) + $ set lastOperation OtherOperation e + +-- | Kill the content from the cursor back to the previous word boundary. +-- When @yank@ is set the yank buffer will be updated. +killWordBackward :: Bool {- ^ yank -} -> EditBox -> EditBox +killWordBackward yank e + = sometimesUpdateYank + $ set line (Line (length l') (l'++r)) + $ e + where + Line n txt = view line e + (l,r) = splitAt n txt + (sp,l1) = span isSpace (reverse l) + (wd,l2) = break isSpace l1 + l' = reverse l2 + yanked = reverse (sp++wd) + + sometimesUpdateYank + | yank = updateYankBuffer KillBackward yanked + | otherwise = id -- don't update operation + +-- | Kill the content from the curser forward to the next word boundary. +-- When @yank@ is set the yank buffer will be updated +killWordForward :: Bool {- ^ yank -} -> EditBox -> EditBox +killWordForward yank e + = sometimesUpdateYank + $ set line (Line (length l) (l++r2)) + $ e + where + Line n txt = view line e + (l,r) = splitAt n txt + (sp,r1) = span isSpace r + (wd,r2) = break isSpace r1 + yanked = sp++wd + + sometimesUpdateYank + | yank = updateYankBuffer KillForward yanked + | otherwise = id -- don't update operation + +-- | Insert a character at the cursor and advance the cursor. +insert :: Char -> EditBox -> EditBox +insert c + = set lastOperation OtherOperation + . over content (insertString [c]) diff --git a/src/Client/State/EditBox/Content.hs b/src/Client/State/EditBox/Content.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/EditBox/Content.hs @@ -0,0 +1,187 @@ +{-# Language TemplateHaskell #-} +{-| +Module : Client.State.EditBox.Content +Description : Multiline text container with cursor +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +-} +module Client.State.EditBox.Content where + +import Control.Lens hiding (below) +import Data.Char + +data Line = Line + { _pos :: !Int + , _text :: !String + } + deriving (Read, Show) + +makeClassy ''Line + +emptyLine :: Line +emptyLine = Line 0 "" + +beginLine :: String -> Line +beginLine = Line 0 + +endLine :: String -> Line +endLine s = Line (length s) s + +-- | Zipper-ish view of the multi-line content of an 'EditBox'. +-- Lines '_above' the '_currentLine' are stored in reverse order. +data Content = Content + { _above :: ![String] + , _currentLine :: !Line + , _below :: ![String] + } + deriving (Read, Show) + +makeLenses ''Content + +instance HasLine Content where + line = currentLine + +-- | Default 'Content' value +noContent :: Content +noContent = Content [] emptyLine [] + +-- | Single line 'Content'. +singleLine :: Line -> Content +singleLine l = Content [] l [] + +-- | Shifts the first line off of the 'Content', yielding the +-- text of the line and the rest of the content. +shift :: Content -> (String, Content) +shift (Content [] l []) = (view text l, noContent) +shift (Content a@(_:_) l b) = (last a, Content (init a) l b) +shift (Content [] l (b:bs)) = (view text l, Content [] (beginLine b) bs) + +jumpLeft :: Content -> Content +jumpLeft c + | view pos c == 0 = maybe c begin1 (backwardLine c) + | otherwise = begin1 c + where + begin1 = set pos 0 + +jumpRight :: Content -> Content +jumpRight c + | view pos c == len = maybe c end1 (forwardLine c) + | otherwise = set pos len c + + where + len = views text length c + end1 l = set pos (views text length l) l + + +-- Move the cursor left, across lines if necessary. +left :: Content -> Content +left c = + case compare (view pos c) 0 of + GT -> (pos -~ 1) c + EQ | Just c' <- backwardLine c -> c' + _ -> c + +-- Move the cursor right, across lines if necessary. +right :: Content -> Content +right c = + let Line n s = view line c in + case compare n (length s) of + LT -> (pos +~ 1) c + EQ | Just c' <- forwardLine c -> c' + _ -> c + +-- | Move the cursor left to the previous word boundary. +leftWord :: Content -> Content +leftWord c + | n == 0 + = maybe c leftWord (backwardLine c) + | otherwise + = case search of + [] -> set pos 0 c + (i,_):_ -> set pos (i+1) c + where + Line n txt = view line c + search = dropWhile (isAlphaNum . snd) + $ dropWhile (not . isAlphaNum . snd) + $ reverse + $ take n + $ zip [0..] + $ txt + +-- | Move the cursor right to the next word boundary. +rightWord :: Content -> Content +rightWord c + | n == length txt + = case forwardLine c of + Nothing -> c + Just c' -> rightWord c' + | otherwise + = case search of + [] -> set pos (length txt) c + (i,_):_ -> set pos i c + where + Line n txt = view line c + search = dropWhile (isAlphaNum . snd) + $ dropWhile (not . isAlphaNum . snd) + $ drop n + $ zip [0..] txt + +-- | Delete the character before the cursor. +backspace :: Content -> Content +backspace c + | n == 0 + = case view above c of + [] -> c + a:as -> set above as + . set line (Line (length a) (a ++ s)) + $ c + + | (preS, postS) <- splitAt (n-1) s + = set line (Line (n-1) (preS ++ drop 1 postS)) c + where + Line n s = view line c + +-- | Delete the character after/under the cursor. +delete :: Content -> Content +delete c = + let Line n s = view line c in + case splitAt n s of + (preS, _:postS) -> set text (preS ++ postS) c + _ -> case view below c of + [] -> c + b:bs -> set below bs + . set text (s ++ b) + $ c + +insertString :: String -> Content -> Content +insertString ins c = + case push (view above c) (preS ++ l) ls of + (newAbove, newLine) -> set above newAbove + $ set line newLine c + where + l:ls = lines (ins ++ "\n") + Line n txt = view line c + (preS, postS) = splitAt n txt + + push stk x [] = (stk, Line (length x) (x ++ postS)) + push stk x (y:ys) = push (x:stk) y ys + +forwardLine :: Content -> Maybe Content +forwardLine c = + case view below c of + [] -> Nothing + b:bs -> Just + $! over above (view text c :) + $ set below bs + $ set line (beginLine b) c + +backwardLine :: Content -> Maybe Content +backwardLine c = + case view above c of + [] -> Nothing + a:as -> Just + $! over below (view text c :) + $ set above as + $ set line (endLine a) c diff --git a/src/Client/State/Focus.hs b/src/Client/State/Focus.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/Focus.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Client.State.Focus +Description : Types for representing the current window being displayed +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +The client has a primary message window whose contents are determined +by a 'Focus'. In order to provide different views of channels +the 'Subfocus' breaks down channel focus into different subviews. +-} + +module Client.State.Focus + ( -- * Types + Focus(..) + , Subfocus(..) + + -- * Focus operations + , focusNetwork + + -- * Focus Prisms + , _ChannelFocus + , _NetworkFocus + , _Unfocused + + -- * Subfocus Prisms + , _FocusMessages + , _FocusInfo + , _FocusUsers + , _FocusMasks + ) where + +import Control.Lens +import Data.Monoid ((<>)) +import Data.Text (Text) +import Irc.Identifier + +-- | Currently focused window +data Focus + = Unfocused -- ^ No network + | NetworkFocus !Text -- ^ Network + | ChannelFocus !Text !Identifier -- ^ Network Channel/Nick + deriving (Eq,Show) + +makePrisms ''Focus + +-- | Subfocus for a channel view +data Subfocus + = FocusMessages -- ^ Show chat messages + | FocusInfo -- ^ Show channel metadata + | FocusUsers -- ^ Show user list + | FocusMasks !Char -- ^ Show mask list for given mode + deriving (Eq,Show) + +makePrisms ''Subfocus + +-- | 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 Focus 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 + +-- | Return the network associated with the current focus +focusNetwork :: Focus -> Maybe Text {- ^ network -} +focusNetwork Unfocused = Nothing +focusNetwork (NetworkFocus network) = Just network +focusNetwork (ChannelFocus network _) = Just network diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/Network.hs @@ -0,0 +1,789 @@ +{-# Language TemplateHaskell, OverloadedStrings, BangPatterns #-} + +{-| +Module : Client.State.Network +Description : IRC network session state +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module is responsible for tracking the state of an individual IRC +connection while the client is connected to it. This state includes +user information, server settings, channel membership, and more. + +This module is more complicated than many of the other modules in the +client because it is responsible for interpreting each IRC message from +the server and updating the connection state accordingly. +-} + +module Client.State.Network + ( + -- * Connection state + NetworkState(..) + , newNetworkState + + , csNick + , csChannels + , csSocket + , csModeTypes + , csChannelTypes + , csTransaction + , csModes + , csStatusMsg + , csSettings + , csUserInfo + , csUsers + , csUser + , csModeCount + , csNetworkId + , csNetwork + , csNextPingTime + , csPingStatus + , csMessageHooks + + -- * User information + , UserAndHost(..) + + -- * Cross-message state + , Transaction(..) + + -- * Connection predicates + , isChannelIdentifier + , iHaveOp + + -- * Messages interactions + , sendMsg + , initialMessages + , applyMessage + , squelchIrcMsg + + -- * Timer information + , PingStatus(..) + , TimedAction(..) + , nextTimedAction + , applyTimedAction + ) where + +import Client.Configuration.ServerSettings +import Client.Network.Async +import Client.State.Channel +import Control.Lens +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet as HashSet +import qualified Data.ByteString as B +import qualified Data.Map.Strict as Map +import Data.Bits +import Data.Foldable +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Read as Text +import Data.Time +import Data.Time.Clock.POSIX +import Irc.Codes +import Irc.Commands +import Irc.Identifier +import Irc.Message +import Irc.Modes +import Irc.RawIrcMsg +import Irc.UserInfo +import LensUtils + +-- | State tracked for each IRC connection +data NetworkState = NetworkState + { _csNetworkId :: !NetworkId -- ^ network connection identifier + , _csChannels :: !(HashMap Identifier ChannelState) -- ^ joined channels + , _csSocket :: !NetworkConnection -- ^ network socket + , _csModeTypes :: !ModeTypes -- ^ channel mode meanings + , _csChannelTypes :: ![Char] -- ^ channel identifier prefixes + , _csTransaction :: !Transaction -- ^ state for multi-message sequences + , _csModes :: ![Char] -- ^ modes for the connected user + , _csStatusMsg :: ![Char] -- ^ modes that prefix statusmsg channel names + , _csSettings :: !ServerSettings -- ^ settings used for this connection + , _csUserInfo :: !UserInfo -- ^ usermask used by the server for this connection + , _csUsers :: !(HashMap Identifier UserAndHost) -- ^ user and hostname for other nicks + , _csModeCount :: !Int -- ^ maximum mode changes per MODE command + , _csNetwork :: !Text -- ^ name of network connection + , _csNextPingTime :: !(Maybe UTCTime) -- ^ time for next ping event + , _csPingStatus :: !PingStatus -- ^ state of ping timer + , _csMessageHooks :: ![Text] -- ^ names of message hooks to apply to this connection + } + deriving Show + +-- | Pair of username and hostname. Empty strings represent missing information. +data UserAndHost = + UserAndHost {-# UNPACK #-} !Text {-# UNPACK #-} !Text + -- ^ username hostname + deriving Show + +-- | Status of the ping timer +data PingStatus + = PingSent !UTCTime -- ^ ping sent waiting for pong + | PingLatency !Double -- ^ latency in seconds for last ping + | PingNever -- ^ no ping sent + deriving Show + +data Transaction + = NoTransaction + | NamesTransaction [Text] + | BanTransaction [(Text,MaskListEntry)] + | WhoTransaction [UserInfo] + deriving Show + +makeLenses ''NetworkState +makePrisms ''Transaction + +csNick :: Lens' NetworkState Identifier +csNick = csUserInfo . uiNick + +sendMsg :: NetworkState -> RawIrcMsg -> IO () +sendMsg cs msg = + case (view msgCommand msg, view msgParams msg) of + ("PRIVMSG", [tgt,txt]) -> multiline "PRIVMSG" tgt txt + ("NOTICE", [tgt,txt]) -> multiline "NOTICE" tgt txt + _ -> transmit msg + where + transmit = send (view csSocket cs) . renderRawIrcMsg + + multiline cmd tgt txt = + for_ txtChunks $ \txtChunk -> + transmit $ rawIrcMsg cmd [tgt, txtChunk] + where + txtChunks = utf8ChunksOf maxContentLen txt + maxContentLen = computeMaxMessageLength (view csUserInfo cs) tgt + +-- This is an approximation for splitting the text. It doesn't +-- understand combining characters. A correct implementation +-- probably needs to use icu, but its going to take some work +-- to use that library to do this. +utf8ChunksOf :: Int -> Text -> [Text] +utf8ChunksOf n txt + | B.length enc <= n = [txt] -- fast/common case + | otherwise = search 0 0 txt info + where + isBeginning b = b .&. 0xc0 /= 0x80 + + enc = Text.encodeUtf8 txt + + beginnings = B.findIndices isBeginning enc + + info = zip3 [0..] -- charIndex + beginnings + (drop 1 beginnings ++ [B.length enc]) + + search startByte startChar currentTxt xs = + case dropWhile (\(_,_,byteLen) -> byteLen-startByte <= n) xs of + [] -> [currentTxt] + (charIx,byteIx,_):xs' -> + case Text.splitAt (charIx - startChar) currentTxt of + (a,b) -> a : search byteIx charIx b xs' + +newNetworkState :: + NetworkId -> + Text -> + ServerSettings -> + NetworkConnection -> + NetworkState +newNetworkState networkId network settings sock = NetworkState + { _csNetworkId = networkId + , _csUserInfo = UserInfo (mkId (view ssNick settings)) "" "" + , _csChannels = HashMap.empty + , _csSocket = sock + , _csChannelTypes = "#&" + , _csModeTypes = defaultModeTypes + , _csTransaction = NoTransaction + , _csModes = "" + , _csStatusMsg = "" + , _csSettings = settings + , _csModeCount = 3 + , _csUsers = HashMap.empty + , _csNetwork = network + , _csPingStatus = PingNever + , _csNextPingTime = Nothing + , _csMessageHooks = view ssMessageHooks settings + } + + + +noReply :: NetworkState -> ([RawIrcMsg], NetworkState) +noReply x = ([], x) + +overChannel :: Identifier -> (ChannelState -> ChannelState) -> NetworkState -> NetworkState +overChannel chan = overStrict (csChannels . ix chan) + +overChannels :: (ChannelState -> ChannelState) -> NetworkState -> NetworkState +overChannels = overStrict (csChannels . traverse) + +applyMessage :: ZonedTime -> IrcMsg -> NetworkState -> ([RawIrcMsg], NetworkState) +applyMessage msgWhen msg cs = + case msg of + Ping args -> ([ircPong args], cs) + Pong _ -> noReply $ doPong msgWhen cs + Join user chan -> + noReply + $ recordUser user + $ overChannel chan (joinChannel (userNick user)) + $ createOnJoin user chan cs + + Quit user _reason -> + noReply + $ forgetUser (userNick user) + $ overChannels (partChannel (userNick user)) cs + + Part user chan _mbreason -> + noReply + $ forgetUser' (userNick user) -- possibly forget + $ if userNick user == view csNick cs + then set (csChannels . at chan) Nothing cs + else overChannel chan (partChannel (userNick user)) cs + + Nick oldNick newNick -> + noReply + $ renameUser (userNick oldNick) newNick + $ updateMyNick (userNick oldNick) newNick + $ overChannels (nickChange (userNick oldNick) newNick) cs + + Kick _kicker chan nick _reason -> + noReply + $ forgetUser' nick + $ overChannel chan (partChannel nick) cs + Reply RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs + Reply RPL_SASLSUCCESS _ -> ([ircCapEnd], cs) + Reply RPL_SASLFAIL _ -> ([ircCapEnd], cs) + Reply code args -> noReply (doRpl code msgWhen args cs) + Cap cmd params -> doCap cmd params cs + Authenticate param -> doAuthenticate param cs + Mode who target (modes:params) -> doMode msgWhen who target modes params cs + Topic user chan topic -> noReply (doTopic msgWhen user chan topic cs) + _ -> noReply cs + +-- | 001 'RPL_WELCOME' is the first message received when transitioning +-- from the initial handshake to a connected state. At this point we know +-- what nickname the server is using for our connection, and we can start +-- scheduling PINGs. +doWelcome :: + ZonedTime {- ^ message received -} -> + Identifier {- ^ my nickname -} -> + NetworkState -> ([RawIrcMsg], NetworkState) +doWelcome msgWhen me + = noReply + . set csNick me + . set csNextPingTime (Just $! addUTCTime 30 (zonedTimeToUTC msgWhen)) + +doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState +doTopic when user chan topic = + overChannel chan (setTopic topic . set chanTopicProvenance (Just $! prov)) + where + prov = TopicProvenance + { _topicAuthor = user + , _topicTime = zonedTimeToUTC when + } + +parseTimeParam :: Text -> Maybe UTCTime +parseTimeParam txt = + case Text.decimal txt of + Right (i, rest) | Text.null rest -> + Just $! posixSecondsToUTCTime (fromInteger i) + _ -> Nothing + +doRpl :: ReplyCode -> ZonedTime -> [Text] -> NetworkState -> NetworkState +doRpl cmd msgWhen args = + case cmd of + RPL_UMODEIS -> + case args of + _me:modes:params + | Just xs <- splitModes defaultUmodeTypes modes params -> + doMyModes xs + . set csModes "" -- reset modes + _ -> id + + RPL_NOTOPIC -> + case args of + _me:chan:_ -> overChannel + (mkId chan) + (setTopic "" . set chanTopicProvenance Nothing) + _ -> id + + RPL_TOPIC -> + case args of + _me:chan:topic:_ -> overChannel (mkId chan) (setTopic topic) + _ -> id + + RPL_TOPICWHOTIME -> + case args of + _me:chan:who:whenTxt:_ | Just when <- parseTimeParam whenTxt -> + let !prov = TopicProvenance + { _topicAuthor = parseUserInfo who + , _topicTime = when + } + in overChannel (mkId chan) (set chanTopicProvenance (Just prov)) + _ -> id + + RPL_CREATIONTIME -> + case args of + _me:chan:whenTxt:_ | Just when <- parseTimeParam whenTxt -> + overChannel (mkId chan) (set chanCreation (Just when)) + _ -> id + + RPL_CHANNEL_URL -> + case args of + _me:chan:urlTxt:_ -> + overChannel (mkId chan) (set chanUrl (Just urlTxt)) + _ -> id + + RPL_ISUPPORT -> isupport args + + RPL_NAMREPLY -> + case args of + _me:_sym:_tgt:x:_ -> + over csTransaction + (\t -> let xs = view _NamesTransaction t + in xs `seq` NamesTransaction (x:xs)) + _ -> id + + RPL_ENDOFNAMES -> + case args of + _me:tgt:_ -> loadNamesList (mkId tgt) + _ -> id + + RPL_BANLIST -> + case args of + _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt + _ -> id + + RPL_ENDOFBANLIST -> + case args of + _me:tgt:_ -> saveList 'b' tgt + _ -> id + + RPL_QUIETLIST -> + case args of + _me:_tgt:_q:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt + _ -> id + + RPL_ENDOFQUIETLIST -> + case args of + _me:tgt:_ -> saveList 'q' tgt + _ -> id + + RPL_INVEXLIST -> + case args of + _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt + _ -> id + + RPL_ENDOFINVEXLIST -> + case args of + _me:tgt:_ -> saveList 'I' tgt + _ -> id + + RPL_EXCEPTLIST -> + case args of + _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt + _ -> id + + RPL_ENDOFEXCEPTLIST -> + case args of + _me:tgt:_ -> saveList 'e' tgt + _ -> id + + RPL_WHOREPLY -> + case args of + _me:_tgt:uname:host:_server:nick:_ -> + over csTransaction $ \t -> + let !x = UserInfo (mkId nick) uname host + !xs = view _WhoTransaction t + in WhoTransaction (x : xs) + _ -> id + + RPL_ENDOFWHO -> massRegistration + + RPL_CHANNELMODEIS -> + case args of + _me:chan:modes:params -> + snd -- channel mode reply shouldn't trigger messages + . doMode msgWhen who chanId modes params + . set (csChannels . ix chanId . chanModes) Map.empty + where chanId = mkId chan + !who = UserInfo (mkId "*") "" "" + _ -> id + _ -> id + + +-- | Add an entry to a mode list transaction +recordListEntry :: + Text {- ^ mask -} -> + Text {- ^ set by -} -> + Text {- ^ set time -} -> + NetworkState -> NetworkState +recordListEntry mask who whenTxt = + case parseTimeParam whenTxt of + Nothing -> id + Just when -> + over csTransaction $ \t -> + let !x = MaskListEntry + { _maskListSetter = who + , _maskListTime = when + } + !xs = view _BanTransaction t + in BanTransaction ((mask,x):xs) + + +-- | Save a completed ban, quiet, invex, or exempt list into the channel +-- state. +saveList :: + Char {- ^ mode -} -> + Text {- ^ channel -} -> + NetworkState -> NetworkState +saveList mode tgt cs + = set csTransaction NoTransaction + $ setStrict + (csChannels . ix (mkId tgt) . chanLists . at mode) + (Just $! newList) + cs + where + newList = HashMap.fromList (view (csTransaction . _BanTransaction) cs) + + +-- | These replies are interpreted by the client and should only be shown +-- in the detailed view. +squelchReply :: ReplyCode -> Bool +squelchReply rpl = + case rpl of + RPL_NAMREPLY -> True + RPL_ENDOFNAMES -> True + RPL_BANLIST -> True + RPL_ENDOFBANLIST -> True + RPL_INVEXLIST -> True + RPL_ENDOFINVEXLIST -> True + RPL_EXCEPTLIST -> True + RPL_ENDOFEXCEPTLIST -> True + RPL_QUIETLIST -> True + RPL_ENDOFQUIETLIST -> True + RPL_CHANNELMODEIS -> True + RPL_TOPIC -> True + RPL_TOPICWHOTIME -> True + RPL_CREATIONTIME -> True + RPL_CHANNEL_URL -> True + RPL_NOTOPIC -> True + RPL_UMODEIS -> True + RPL_WHOREPLY -> True + RPL_ENDOFWHO -> True + _ -> False + +-- | Return 'True' for messages that should be hidden outside of +-- full detail view. These messages are interpreted by the client +-- so the user shouldn't need to see them directly to get the +-- relevant information. +squelchIrcMsg :: IrcMsg -> Bool +squelchIrcMsg (Reply rpl _) = squelchReply rpl +squelchIrcMsg _ = False + +doMode :: + ZonedTime {- ^ time of message -} -> + UserInfo {- ^ sender -} -> + Identifier {- ^ channel -} -> + Text {- ^ mode flags -} -> + [Text] {- ^ mode parameters -} -> + NetworkState -> ([RawIrcMsg], NetworkState) +doMode when who target modes args cs + | view csNick cs == target + , Just xs <- splitModes defaultUmodeTypes modes args = + noReply (doMyModes xs cs) + + | isChannelIdentifier cs target + , Just xs <- splitModes (view csModeTypes cs) modes args = + let cs' = doChannelModes when who target xs cs + + finish | iHaveOp target cs' = popQueue + | otherwise = noReply + + in finish cs' + where + popQueue :: NetworkState -> ([RawIrcMsg], NetworkState) + popQueue = csChannels . ix target . chanQueuedModeration <<.~ [] + +doMode _ _ _ _ _ cs = noReply cs -- ignore bad mode command + +-- | Predicate to test if the connection has op in a given channel. +iHaveOp :: Identifier -> NetworkState -> Bool +iHaveOp channel cs = + elemOf (csChannels . ix channel . chanUsers . ix me . folded) '@' cs + where + me = view csNick cs + + +doChannelModes :: ZonedTime -> UserInfo -> Identifier -> [(Bool, Char, Text)] -> NetworkState -> NetworkState +doChannelModes when who chan changes cs = overChannel chan applyChannelModes cs + where + modeTypes = view csModeTypes cs + sigilMap = view modesPrefixModes modeTypes + listModes = view modesLists modeTypes + + applyChannelModes c = foldl' applyChannelMode c changes + + applyChannelMode c (polarity, mode, arg) + + | Just sigil <- lookup mode sigilMap = + overStrict (chanUsers . ix (mkId arg)) + (setPrefixMode polarity sigil) + c + + | mode `elem` listModes = + let entry | polarity = Just $! MaskListEntry + { _maskListSetter = renderUserInfo who + , _maskListTime = zonedTimeToUTC when + } + | otherwise = Nothing + in setStrict (chanLists . ix mode . at arg) entry c + + | polarity = set (chanModes . at mode) (Just arg) c + | otherwise = set (chanModes . at mode) Nothing c + + setPrefixMode polarity sigil sigils + | not polarity = delete sigil sigils + | sigil `elem` sigils = sigils + | otherwise = filter (`elem` sigils') (map snd sigilMap) + where + sigils' = sigil : sigils + + +doMyModes :: [(Bool, Char, Text)] -> NetworkState -> NetworkState +doMyModes changes = over csModes $ \modes -> sort (foldl' applyOne modes changes) + where + applyOne modes (True, mode, _) + | mode `elem` modes = modes + | otherwise = mode:modes + applyOne modes (False, mode, _) = delete mode modes + +supportedCaps :: NetworkState -> [Text] +supportedCaps cs = + sasl ++ ["multi-prefix", "znc.in/batch", "znc.in/playback", + "znc.in/server-time-iso", "znc.in/self-message"] + where + ss = view csSettings cs + sasl = ["sasl" | isJust (view ssSaslUsername ss) + , isJust (view ssSaslPassword ss) ] + +doAuthenticate :: Text -> NetworkState -> ([RawIrcMsg], NetworkState) +doAuthenticate "+" cs + | Just user <- view ssSaslUsername ss + , Just pass <- view ssSaslPassword ss + = ([ircAuthenticate (encodePlainAuthentication user pass)], cs) + where + ss = view csSettings cs + +doAuthenticate _ cs = ([ircCapEnd], cs) + +doCap :: CapCmd -> [Text] -> NetworkState -> ([RawIrcMsg], NetworkState) +doCap cmd args cs = + case (cmd,args) of + (CapLs,[capsTxt]) + | null reqCaps -> ([ircCapEnd], cs) + | otherwise -> ([ircCapReq reqCaps], cs) + where + caps = Text.words capsTxt + reqCaps = intersect (supportedCaps cs) caps + + (CapAck,[capsTxt]) + | "sasl" `elem` caps -> + ([ircAuthenticate plainAuthenticationMode], cs) + where + caps = Text.words capsTxt + + _ -> ([ircCapEnd], cs) + + +initialMessages :: NetworkState -> [RawIrcMsg] +initialMessages cs + = [ ircCapLs ] + ++ [ ircPass pass | Just pass <- [view ssPassword ss]] + ++ [ ircUser (view ssUser ss) False True (view ssReal ss) + , ircNick (view csNick cs) + ] + where + ss = view csSettings cs + +loadNamesList :: Identifier -> NetworkState -> NetworkState +loadNamesList chan cs + = set csTransaction NoTransaction + $ setStrict (csChannels . ix chan . chanUsers) newChanUsers + $ cs + where + newChanUsers = HashMap.fromList (splitEntry "" <$> entries) + + sigils = toListOf (csModeTypes . modesPrefixModes . folded . _2) cs + + splitEntry modes str + | Text.head str `elem` sigils = splitEntry (Text.head str : modes) + (Text.tail str) + | otherwise = (mkId str, reverse modes) + + entries = + concatMap Text.words (view (csTransaction . _NamesTransaction) cs) + + +createOnJoin :: UserInfo -> Identifier -> NetworkState -> NetworkState +createOnJoin who chan cs + | userNick who == view csNick cs = + set csUserInfo who -- great time to learn our userinfo + $ set (csChannels . at chan) (Just newChannel) cs + | otherwise = cs + +updateMyNick :: Identifier -> Identifier -> NetworkState -> NetworkState +updateMyNick oldNick newNick cs + | oldNick == view csNick cs = set csNick newNick cs + | otherwise = cs + +-- ISUPPORT is defined by +-- https://tools.ietf.org/html/draft-brocklesby-irc-isupport-03#section-3.14 +isupport :: + [Text] {- ^ ["key=value"] -} -> + NetworkState -> + NetworkState +isupport [] conn = conn +isupport params conn = foldl' (flip isupport1) conn + $ map parseISupport + $ init params + where + isupport1 ("CHANTYPES",types) = set csChannelTypes (Text.unpack types) + isupport1 ("CHANMODES",modes) = updateChanModes modes + isupport1 ("PREFIX" ,modes) = updateChanPrefix modes + isupport1 ("STATUSMSG",prefix) = set csStatusMsg (Text.unpack prefix) + isupport1 ("MODES",nstr) | Right (n,"") <- Text.decimal nstr = + set csModeCount n + isupport1 _ = id + +parseISupport :: Text -> (Text,Text) +parseISupport str = + case Text.break (=='=') str of + (key,val) -> (key, Text.drop 1 val) + +updateChanModes :: + Text {- lists,always,set,never -} -> + NetworkState -> + NetworkState +updateChanModes modes + = over csModeTypes + $ set modesLists listModes + . set modesAlwaysArg alwaysModes + . set modesSetArg setModes + . set modesNeverArg neverModes + -- Note: doesn't set modesPrefixModes + where + next = over _2 (drop 1) . break (==',') + (listModes ,modes1) = next (Text.unpack modes) + (alwaysModes,modes2) = next modes1 + (setModes ,modes3) = next modes2 + (neverModes ,_) = next modes3 + +updateChanPrefix :: + Text {- e.g. "(ov)@+" -} -> + NetworkState -> + NetworkState +updateChanPrefix txt = + case parsePrefixes txt of + Just prefixes -> set (csModeTypes . modesPrefixModes) prefixes + Nothing -> id + +parsePrefixes :: Text -> Maybe [(Char,Char)] +parsePrefixes txt = + case uncurry Text.zip (Text.break (==')') txt) of + ('(',')'):rest -> Just rest + _ -> Nothing + +isChannelIdentifier :: NetworkState -> Identifier -> Bool +isChannelIdentifier cs ident = + case Text.uncons (idText ident) of + Just (p, _) -> p `elem` view csChannelTypes cs + _ -> False + +------------------------------------------------------------------------ +-- Helpers for managing the user list +------------------------------------------------------------------------ + +csUser :: Functor f => Identifier -> LensLike' f NetworkState (Maybe UserAndHost) +csUser i = csUsers . at i + +recordUser :: UserInfo -> NetworkState -> NetworkState +recordUser (UserInfo nick user host) + | Text.null user || Text.null host = id + | otherwise = set (csUsers . at nick) + (Just (UserAndHost user host)) + +forgetUser :: Identifier -> NetworkState -> NetworkState +forgetUser nick = set (csUsers . at nick) Nothing + +renameUser :: Identifier -> Identifier -> NetworkState -> NetworkState +renameUser old new cs = set (csUsers . at new) entry cs' + where + (entry,cs') = cs & csUsers . at old <<.~ Nothing + +forgetUser' :: Identifier -> NetworkState -> NetworkState +forgetUser' nick cs + | keep = cs + | otherwise = forgetUser nick cs + where + keep = has (csChannels . folded . chanUsers . ix nick) cs + +-- | Process a list of WHO replies +massRegistration :: NetworkState -> NetworkState +massRegistration cs + = set csTransaction NoTransaction + $ over csUsers updateUsers cs + where + infos = view (csTransaction . _WhoTransaction) cs + + channelUsers = + HashSet.fromList (views (csChannels . folded . chanUsers) HashMap.keys cs) + + updateUsers users = foldl' updateUser users infos + + updateUser users (UserInfo nick user host) + | not (Text.null user) + , not (Text.null host) + , HashSet.member nick channelUsers = + HashMap.insert nick (UserAndHost user host) users + | otherwise = users + +-- | Timer-based events +data TimedAction + = TimedDisconnect -- ^ terminate the connection due to timeout + | TimedSendPing -- ^ transmit a ping to the server + deriving (Eq, Ord, Show) + +-- | Compute the earliest timed action for a connection, if any +nextTimedAction :: NetworkState -> Maybe (UTCTime, TimedAction) +nextTimedAction cs = + do runAt <- view csNextPingTime cs + return (runAt, action) + where + action = + case view csPingStatus cs of + PingSent{} -> TimedDisconnect + PingLatency{} -> TimedSendPing + PingNever -> TimedSendPing + +doPong :: ZonedTime -> NetworkState -> NetworkState +doPong when cs = set csPingStatus (PingLatency delta) cs + where + delta = + case view csPingStatus cs of + PingSent sent -> realToFrac (diffUTCTime (zonedTimeToUTC when) sent) + _ -> 0 + +-- | Apply the given 'TimedAction' to a connection state. +applyTimedAction :: TimedAction -> NetworkState -> IO NetworkState +applyTimedAction action cs = + case action of + TimedDisconnect -> + do abortConnection (view csSocket cs) + return $! set csNextPingTime Nothing cs + + TimedSendPing -> + do now <- getCurrentTime + sendMsg cs (ircPing ["ping"]) + return $! set csNextPingTime (Just $! addUTCTime 60 now) + $ set csPingStatus (PingSent now) cs diff --git a/src/Client/State/Window.hs b/src/Client/State/Window.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/Window.hs @@ -0,0 +1,91 @@ +{-# Language BangPatterns, TemplateHaskell #-} + +{-| +Module : Client.State.Window +Description : Types and operations for managing message buffers. +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module defines types and operations used to store messages for display +in the client's buffers. +-} + +module Client.State.Window + ( + -- * Windows + Window(..) + , winMessages + , winUnread + , winMention + + -- * Window lines + , WindowLine(..) + , wlBody + , wlText + , wlImage + , wlFullImage + + -- * Window line importance + , WindowLineImportance(..) + + -- * Window operations + , emptyWindow + , addToWindow + , windowSeen + ) where + +import Client.Message +import Control.Lens +import Data.Text (Text) +import Graphics.Vty.Image (Image) + +-- | A single message to be displayed in a window +data WindowLine = WindowLine + { _wlBody :: !MessageBody -- ^ Original Haskell value + , _wlText :: {-# UNPACK #-} !Text -- ^ Searchable text form + , _wlImage :: !Image -- ^ Normal rendered image + , _wlFullImage :: !Image -- ^ Detailed rendered image + } + +-- | A 'Window' tracks all of the messages and metadata for a particular +-- message buffer. +data Window = Window + { _winMessages :: ![WindowLine] -- ^ Messages to display, newest first + , _winUnread :: !Int -- ^ Messages added since buffer was visible + , _winMention :: !Bool -- ^ Indicates an important event is unread + } + +-- | Flag for the important of a message being added to a window +data WindowLineImportance + = WLBoring -- ^ Don't update unread count + | WLNormal -- ^ Increment unread count + | WLImportant -- ^ Increment unread count and set important flag + deriving (Eq, Show) + +makeLenses ''Window +makeLenses ''WindowLine + +-- | A window with no messages +emptyWindow :: Window +emptyWindow = Window + { _winMessages = [] + , _winUnread = 0 + , _winMention = False + } + +-- | Adds a given line to a window as the newest message. Window's +-- unread count will be updated according to the given importance. +addToWindow :: WindowLineImportance -> WindowLine -> Window -> Window +addToWindow importance !msg !win = Window + { _winMessages = msg : _winMessages win + , _winUnread = _winUnread win + + (if importance == WLBoring then 0 else 1) + , _winMention = _winMention win + || importance == WLImportant + } + +-- | Update the window clearing the unread count and important flag. +windowSeen :: Window -> Window +windowSeen = set winUnread 0 + . set winMention False diff --git a/src/Client/Window.hs b/src/Client/Window.hs deleted file mode 100644 --- a/src/Client/Window.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# Language BangPatterns, TemplateHaskell #-} - -{-| -Module : Client.Window -Description : Types and operations for managing message buffers. -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module defines types and operations used to store messages for display -in the client's buffers. --} - -module Client.Window - ( - -- * Windows - Window(..) - , winMessages - , winUnread - , winMention - - -- * Window lines - , WindowLine(..) - , wlBody - , wlText - , wlImage - , wlFullImage - - -- * Window line importance - , WindowLineImportance(..) - - -- * Window operations - , emptyWindow - , addToWindow - , windowSeen - ) where - -import Client.Message -import Control.Lens -import Data.Text (Text) -import Graphics.Vty.Image (Image) - --- | A single message to be displayed in a window -data WindowLine = WindowLine - { _wlBody :: !MessageBody -- ^ Original Haskell value - , _wlText :: {-# UNPACK #-} !Text -- ^ Searchable text form - , _wlImage :: !Image -- ^ Normal rendered image - , _wlFullImage :: !Image -- ^ Detailed rendered image - } - --- | A 'Window' tracks all of the messages and metadata for a particular --- message buffer. -data Window = Window - { _winMessages :: ![WindowLine] -- ^ Messages to display, newest first - , _winUnread :: !Int -- ^ Messages added since buffer was visible - , _winMention :: !Bool -- ^ Indicates an important event is unread - } - --- | Flag for the important of a message being added to a window -data WindowLineImportance - = WLBoring -- ^ Don't update unread count - | WLNormal -- ^ Increment unread count - | WLImportant -- ^ Increment unread count and set important flag - deriving (Eq, Show) - -makeLenses ''Window -makeLenses ''WindowLine - --- | A window with no messages -emptyWindow :: Window -emptyWindow = Window - { _winMessages = [] - , _winUnread = 0 - , _winMention = False - } - --- | Adds a given line to a window as the newest message. Window's --- unread count will be updated according to the given importance. -addToWindow :: WindowLineImportance -> WindowLine -> Window -> Window -addToWindow importance !msg !win = Window - { _winMessages = msg : _winMessages win - , _winUnread = _winUnread win - + (if importance == WLBoring then 0 else 1) - , _winMention = _winMention win - || importance == WLImportant - } - --- | Update the window clearing the unread count and important flag. -windowSeen :: Window -> Window -windowSeen = set winUnread 0 - . set winMention False diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -24,8 +24,8 @@ import Client.CommandArguments import Client.Configuration import Client.EventLoop -import Client.Focus import Client.State +import Client.State.Focus -- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' -- once the continuation finishes.