glirc 2.9 → 2.10

raw patch · 24 files changed

+1912/−1780 lines, 24 files

Files

ChangeLog.md +5/−0
glirc.cabal +14/−12
src/Client/CApi/Exports.hs +3/−3
src/Client/ChannelState.hs +0/−125
src/Client/Commands.hs +17/−18
src/Client/Commands/WordCompletion.hs +13/−13
src/Client/ConnectionState.hs +0/−789
src/Client/EditBox.hs +0/−399
src/Client/EventLoop.hs +11/−8
src/Client/Focus.hs +0/−77
src/Client/Image.hs +121/−213
src/Client/Image/ChannelInfo.hs +4/−4
src/Client/Image/MaskList.hs +2/−2
src/Client/Image/StatusLine.hs +187/−0
src/Client/Image/UserList.hs +4/−4
src/Client/State.hs +21/−21
src/Client/State/Channel.hs +125/−0
src/Client/State/EditBox.hs +240/−0
src/Client/State/EditBox/Content.hs +187/−0
src/Client/State/Focus.hs +77/−0
src/Client/State/Network.hs +789/−0
src/Client/State/Window.hs +91/−0
src/Client/Window.hs +0/−91
src/Main.hs +1/−1

ChangeLog.md view

@@ -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

glirc.cabal view

@@ -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

src/Client/CApi/Exports.hs view

@@ -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

− src/Client/ChannelState.hs

@@ -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

src/Client/Commands.hs view

@@ -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)

src/Client/Commands/WordCompletion.hs view

@@ -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

− src/Client/ConnectionState.hs

@@ -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

− src/Client/EditBox.hs

@@ -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])

src/Client/EventLoop.hs view

@@ -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

− src/Client/Focus.hs

@@ -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

src/Client/Image.hs view

@@ -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

src/Client/Image/ChannelInfo.hs view

@@ -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

src/Client/Image/MaskList.hs view

@@ -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

+ src/Client/Image/StatusLine.hs view

@@ -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 ')'

src/Client/Image/UserList.hs view

@@ -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

src/Client/State.hs view

@@ -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

+ src/Client/State/Channel.hs view

@@ -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

+ src/Client/State/EditBox.hs view

@@ -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])

+ src/Client/State/EditBox/Content.hs view

@@ -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

+ src/Client/State/Focus.hs view

@@ -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

+ src/Client/State/Network.hs view

@@ -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

+ src/Client/State/Window.hs view

@@ -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

− src/Client/Window.hs

@@ -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

src/Main.hs view

@@ -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.