glirc (empty) → 2.0
raw patch · 36 files changed
+7043/−0 lines, 36 filesdep +arraydep +asyncdep +attoparsecbuild-type:Customsetup-changed
Dependencies added: array, async, attoparsec, base, bytestring, config-value, connection, containers, data-default-class, directory, filepath, hashable, lens, network, profunctors, split, stm, text, text-icu, time, tls, transformers, unordered-containers, vty, x509, x509-store, x509-system
Files
- ChangeLog.md +5/−0
- LICENSE +13/−0
- README.md +174/−0
- Setup.hs +40/−0
- glirc.cabal +86/−0
- src/Client/ChannelState.hs +115/−0
- src/Client/CommandArguments.hs +95/−0
- src/Client/Commands.hs +535/−0
- src/Client/Configuration.hs +152/−0
- src/Client/Connect.hs +113/−0
- src/Client/ConnectionState.hs +703/−0
- src/Client/EditBox.hs +233/−0
- src/Client/EventLoop.hs +349/−0
- src/Client/IdentifierColors.hs +39/−0
- src/Client/Image.hs +288/−0
- src/Client/Image/MaskList.hs +64/−0
- src/Client/Image/Message.hs +299/−0
- src/Client/Image/UserList.hs +82/−0
- src/Client/Message.hs +53/−0
- src/Client/MircFormatting.hs +150/−0
- src/Client/NetworkConnection.hs +156/−0
- src/Client/ServerSettings.hs +103/−0
- src/Client/State.hs +429/−0
- src/Client/Window.hs +89/−0
- src/Client/WordCompletion.hs +100/−0
- src/Config/FromConfig.hs +148/−0
- src/Irc/Codes.hs +1337/−0
- src/Irc/Commands.hs +169/−0
- src/Irc/Identifier.hs +77/−0
- src/Irc/Message.hs +244/−0
- src/Irc/Modes.hs +122/−0
- src/Irc/RateLimit.hs +77/−0
- src/Irc/RawIrcMsg.hs +255/−0
- src/Irc/UserInfo.hs +58/−0
- src/LensUtils.hs +42/−0
- src/Main.hs +49/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for glirc2++## 2.0++* First version of glirc rewrite
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright (c) 2016 Eric Mertens++Permission to use, copy, modify, and/or distribute this software for any purpose+with or without fee is hereby granted, provided that the above copyright notice+and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF+THIS SOFTWARE.
+ README.md view
@@ -0,0 +1,174 @@+My IRC client+=============++[](http://travis-ci.org/glguy/irc-core)++++Client Features+===============++* Subsequent joins and parts fold into one line and do not scroll chat messages off the screen+* Ignore support that folds ignored messages into the joins and parts. Toggle it off to see previously hidden messages+* Detailed view to see all the messages in a channel in full detail with hostmask and timestamp (F2)+* Nick tab completion+* New message notification+* View ban, quiet, invex, and exception lists+* WYSIWYG mIRC formatting input+* Chanserv integration+* Each user's nick is assigned a consistent color, when a user's nick is rendered in a chat message it uses that same color.+* Support for /STATUSMSG/ messages (messages only voice or op users can see)+* Run commands upon connection+* Ban lists don't obstruct chat messages+* Ban list and user list are searchable++TLS+===++`glirc` has TLS support via the Haskell `tls` package. Note that Freenode (and other networks) will allow you to authenticate to NickServ via a client certificate.++I use the `x509-store` for decoding certificates and private key files. This library seems to support PEM formatted files and does not seem to support encrypted private key files. If the key and certificate are both contained in the certificate file the private key command line argument is unnecessary.++Startup+=======++```+glirc [FLAGS] INITIAL_NETWORKS...+ -c PATH --config=PATH Configuration file path+ -h --help Show help+ -v --version Show version+```++Environment variables+```+USER=<default nickname and username>+IRCPASSWORD=<your irc password>+```++Configuration file+=================++A configuration file can currently be used to provide some default values instead of+using command line arguments. If any value is missing the default will be used.++Learn more about this file format at [config-value](http://hackage.haskell.org/package/config-value)++```+-- Defaults used when not specified on command line+defaults:+ port: 6667+ nick: "yournick"+ username: "yourusername"+ realname: "Your real name"+ password: "IRC server password"+ tls: yes -- or: no+ tls-client-cert: "/path/to/cert.pem"+ tls-client-key: "/path/to/cert.key"++-- Override the defaults when connecting to specific servers+servers:+ * hostname: "chat.freenode.net"+ sasl-username: "someuser"+ sasl-password: "somepass"+ socks-host: "socks5.example.com"+ socks-port: 8080 -- defaults to 1080++ * hostname: "example.com"+ port: 7000+ connect-cmds:+ * "JOIN #favoritechannel,#otherchannel"+ * "PRIVMSG mybot :another command"++ -- Specify additional certificates beyond the system CAs+ server-certificates:+ * "/path/to/extra/certificate.pem"++```++Configuration sections:+--------++* `defaults` - These settings are used for all connections+* `servers` - These settings are used to override defaults when the hostname matches++Settings+--------++* `hostname` - text - hostname used to connect and to specify the server+* `port` - number - port number, defaults to 6667 without TLS and 6697 with TLS+* `nick` - text - nickname+* `username` - text - username+* `realname` - text - realname / GECOS+* `password` - text - server password+* `tls` - yes/no - use TLS to connect+* `tls-insecure` - yes/no - disable certificate validation+* `tls-client-cert` - text - path to TLS client certificate+* `tls-client-key` - text - path to TLS client key+* `connect-cmds` - list of text - raw IRC commands to send upon connection+* `socks-host` - text - hostname of SOCKS proxy to connect through+* `socks-port` - number - port number of SOCKS proxy to connect through+* `server-certificates` - list of text - list of CA certificates to use when validating certificates+* `chanserv-channels` - list of text - list of channels with chanserv op permission+++Commands+========++* `/exit` - Terminate the client+* `/quit` - Gracefully terminate connection to the current server+* `/disconnect` - Forcefully terminate connection to the current server+* `/connect <hostname>` - Connect to the given hostname+* `/reconnect` - Reconnect to the current server+* `/focus <server>` - Change focus to server window+* `/focus <server> <channel>` - Change focus to channel window+* `/clear` - <Clear contents of current window+* `/ignore <nick>` - Toggle ignore of a user+* `/quote <raw command>` - Send a raw IRC command to the server+* `/join <channel>` - Join a channel+* `/mode <mode> <params>` - Change modes on the current channel+* `/msg <target> <msg>` - Send a message on the current server to target+* `/nick <nick>` - Change nickname+* `/who <query>` - Perform WHO query (use detailed view to see output)+* `/whois <nick>` - Perform WHOIS query+* `/whowas <nick>` - Perform WHOWAS query+* `/invite <nick>` - Invite a user to the current channel+* `/topic <topic>` - Change the topic+* `/kick <nick>` - Kick a user+* `/kickban <nick>` - Kick and ban a user+* `/remove` - Gracefully kick a user+* `/me` - Send action message to channel+* `/part` - Part from current channel+* `/users` - Show channel user list+* `/masks <mode>` - Show channel bans(b), quiets(q), exempts(e), or invex(I)++Filters++* `/grep` - Filter chat messages using a regular expression+* `/grepi` - Filter chat messages using a case-insensitive regular expression on the message++Keyboard Shortcuts+==================++* `^N` next channel+* `^P` previous channel+* `M-#` jump to window - 1234567890qwertyuiop+* `M-A` jump to activity+* `^A` beginning of line+* `^E` end of line+* `^K` delete to end+* `^U` delete to beginning+* `^D` delete at cursor+* `^W` delete word+* `^Y` paste from yank buffer+* `M-F` forward word+* `M-B` backward word+* `TAB` nickname completion+* `F2` toggle detailed view+* `Page Up` scroll up+* `Page Down` scroll down+* `^B` bold+* `^C` color+* `^V` reverse video+* `^_` underline+* `^]` italic+* `^O` reset formatting
+ Setup.hs view
@@ -0,0 +1,40 @@+{-|+Module : Main+Description : Custom setup script+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This is a default setup script except that it checks that all+transitive dependencies of this package use free licenses.++-}++module Main (main) where++import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex+import Distribution.InstalledPackageInfo+import Control.Monad++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { postConf = \args flags pkg lbi ->+ do validateLicenses lbi+ postConf simpleUserHooks args flags pkg lbi+ }++validateLicenses :: LocalBuildInfo -> IO ()+validateLicenses lbi =+ do let p pkg = license pkg `notElem` freeLicenses+ badPkgs = filter p+ $ allPackages+ $ installedPkgs lbi++ unless (null badPkgs) $+ do mapM_ print badPkgs+ fail "BAD LICENSE"++freeLicenses :: [License]+freeLicenses = [ BSD2, BSD3, ISC, MIT ]
+ glirc.cabal view
@@ -0,0 +1,86 @@+name: glirc+version: 2.0+synopsis: Console IRC client+description: Console IRC client+license: ISC+license-file: LICENSE+author: Eric Mertens+maintainer: emertens@gmail.com+copyright: 2016 Eric Mertens+category: Network+build-type: Custom+extra-source-files: ChangeLog.md README.md+cabal-version: >=1.10+tested-with: GHC==8.0.1++source-repository head+ type: git+ location: git://github.com/glguy/irc-core.git+ branch: v2++executable glirc2+ main-is: Main.hs+ other-modules: Client.ChannelState+ Client.CommandArguments+ Client.Commands+ Client.Configuration+ Client.Connect+ Client.ConnectionState+ Client.EditBox+ Client.EventLoop+ Client.IdentifierColors+ Client.Image+ Client.Image.MaskList+ Client.Image.Message+ Client.Image.UserList+ Client.Message+ Client.MircFormatting+ Client.NetworkConnection+ Client.ServerSettings+ Client.State+ Client.Window+ Client.WordCompletion+ Config.FromConfig+ Irc.Codes+ Irc.Commands+ Irc.Identifier+ Irc.Message+ Irc.Modes+ Irc.RateLimit+ Irc.RawIrcMsg+ Irc.UserInfo+ LensUtils+ Paths_glirc++ -- other-extensions:+ build-depends: base >=4.9 && <4.10,+ async >=2.1 && < 2.2,+ connection >=0.2.5 && <0.3,+ text >=1.2.2 && <1.3,+ text-icu >=0.7 && <0.8,+ config-value >=0.4 && <0.5,+ bytestring >=0.10.8 && <0.11,+ time >=1.6 && <1.7,+ attoparsec >=0.13 && <0.14,+ array >=0.5 && <0.6,+ vty >=5.7 && <5.8,+ lens >=4.14 && <4.15,+ containers >=0.5.7 && <0.6,+ unordered-containers >=0.2.7 && <0.3,+ hashable >=1.2.4 && <1.3,+ network >=2.6.2 && <2.7,+ tls >=1.3.8 && <1.4,+ split >=0.2 && <0.3,+ profunctors >=5.2 && <5.3,+ x509-system >=1.6.3 && <1.7,+ x509-store >=1.6.1 && <1.7,+ x509 >=1.6.3 && <1.7,+ transformers >=0.5.2 && <0.6,+ data-default-class >=0.1.2 && <0.2,+ stm >=2.4 && <2.5,+ directory >=1.2.6 && <1.3,+ filepath >=1.4.1 && <1.5++ ghc-options: -threaded -rtsopts+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Client/ChannelState.hs view
@@ -0,0 +1,115 @@+{-# 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 type+ ChannelState+ , chanTopic+ , chanTopicProvenance+ , chanUsers+ , chanModes+ , chanLists+ , chanList+ , chanCreation+ , chanQueuedModeration++ -- * 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++data ChannelState = ChannelState+ { _chanTopic :: !Text+ -- ^ topic text+ , _chanTopicProvenance :: !(Maybe TopicProvenance)+ -- ^ author and timestamp for topic+ , _chanUsers :: !(HashMap Identifier String)+ -- ^ user list and sigils+ , _chanModes :: !(Map Char Text)+ -- ^ channel settings and parameters+ , _chanLists :: !(Map Char (HashMap Text (Text, UTCTime)))+ -- ^ 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++makeLenses ''ChannelState+makeLenses ''TopicProvenance++-- | Construct an empty 'ChannelState'+newChannel :: ChannelState+newChannel = ChannelState+ { _chanTopic = Text.empty+ , _chanTopicProvenance = Nothing+ , _chanUsers = HashMap.empty+ , _chanModes = Map.empty+ , _chanLists = Map.empty+ , _chanCreation = Nothing+ , _chanQueuedModeration = []+ }++-- | 'Lens' into a mask list for a given mode.+chanList ::+ Functor f =>+ Char {- ^ mode -} ->+ LensLike' f ChannelState (HashMap Text (Text, UTCTime))+chanList mode = chanLists . at mode . non' _Empty++-- | 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/CommandArguments.hs view
@@ -0,0 +1,95 @@+{-# Language TemplateHaskell #-}+{-|+Module : Client.CommandArguments+Description : Processing of command-line arguments+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module process command-line arguments provided when+launching the client.++-}+module Client.CommandArguments+ (+ -- * Command-line argument type+ CommandArguments(..)+ , cmdArgConfigFile+ , cmdArgInitialNetworks++ -- * Argument loader+ , getCommandArguments+ ) where++import Client.State+import Control.Lens+import Data.Foldable+import qualified Data.Text as Text+import Data.Version+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO+import Paths_glirc (version)++-- | Command-line arguments+data CommandArguments = CommandArguments+ { _cmdArgConfigFile :: Maybe FilePath -- ^ configuration file path+ , _cmdArgInitialNetworks :: [NetworkName] -- ^ initial networks+ , _cmdArgShowHelp :: Bool -- ^ show help message+ , _cmdArgShowVersion :: Bool -- ^ show version message+ }++makeLenses ''CommandArguments++-- | Default values for arguments+defaultCommandArguments :: CommandArguments+defaultCommandArguments = CommandArguments+ { _cmdArgConfigFile = Nothing+ , _cmdArgInitialNetworks = []+ , _cmdArgShowHelp = False+ , _cmdArgShowVersion = False+ }++-- | Option descriptions+options :: [OptDescr (CommandArguments -> CommandArguments)]+options =+ [ Option "c" ["config"] (ReqArg (set cmdArgConfigFile . Just) "PATH")+ "Configuration file path"+ , Option "h" ["help"] (NoArg (set cmdArgShowHelp True))+ "Show help"+ , Option "v" ["version"] (NoArg (set cmdArgShowVersion True))+ "Show version"+ ]++-- | Load command line arguments. This action will terminate early+-- in the case of the version flag, help flag, or an error.+getCommandArguments :: IO CommandArguments+getCommandArguments =+ do args <- getArgs+ case getOpt Permute options args of+ (flags, networks, [])+ | view cmdArgShowHelp cmdArgs -> putStr helpTxt >> exitSuccess+ | view cmdArgShowVersion cmdArgs -> putStr versionTxt >> exitSuccess+ | otherwise -> return cmdArgs+ where+ cmdArgs = assembleCommandArguments flags networks+ (_, _, errors) ->+ do traverse_ (hPutStr stderr) errors+ hPutStrLn stderr "Run 'glirc2 --help' to see a list of available command line options."+ exitFailure++assembleCommandArguments :: [CommandArguments -> CommandArguments] -> [String] -> CommandArguments+assembleCommandArguments flags networks =+ let flagArgs = foldl' (\acc f -> f acc) defaultCommandArguments flags+ in flagArgs { _cmdArgInitialNetworks = Text.pack <$> networks }++helpTxt :: String+helpTxt = usageInfo "glirc2 [FLAGS] INITIAL_NETWORKS..." options++versionTxt :: String+versionTxt = unlines+ [ "glirc-" ++ showVersion version+ , "Copyright 2016 Eric Mertens"+ ]+
+ src/Client/Commands.hs view
@@ -0,0 +1,535 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Client.Commands+Description : Implementation of slash commands+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module renders the lines used in the channel mask list. A mask list+can show channel bans, quiets, invites, and exceptions.+-}++module Client.Commands+ ( CommandResult(..)+ , executeCommand+ , nickTabCompletion+ ) where++import Client.ConnectionState+import Client.Message+import Client.ServerSettings+import Client.ChannelState+import Client.State+import Client.Window+import Client.WordCompletion+import Control.Lens+import Control.Monad+import Data.Char+import Data.List.Split+import Data.Foldable+import Data.HashSet (HashSet)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Monoid ((<>))+import Data.Time+import Irc.Commands+import Irc.Identifier+import Irc.RawIrcMsg+import Irc.Message+import Irc.UserInfo+import Irc.Modes+import LensUtils+import qualified Client.EditBox as Edit++-- | Possible results of running a command+data CommandResult+ = CommandContinue ClientState -- ^ Continue running client with updated state+ | CommandQuit -- ^ Client should close++type ClientCommand = ClientState -> String -> IO CommandResult+type NetworkCommand = NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+type ChannelCommand = NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult++-- | Pair of implementations for executing a command and tab completing one.+-- The tab-completion logic is extended with a bool+-- indicating that tab completion should be reversed+data Command+ = ClientCommand ClientCommand (Bool -> ClientCommand)+ | NetworkCommand NetworkCommand (Bool -> NetworkCommand)+ | ChannelCommand ChannelCommand (Bool -> ChannelCommand)+++commandContinue :: Monad m => ClientState -> m CommandResult+commandContinue = return . CommandContinue++splitWord :: String -> (String, String)+splitWord str = (w, drop 1 rest)+ where+ (w, rest) = break isSpace str++nextWord :: String -> Maybe (String, String)+nextWord str =+ case splitWord (dropWhile isSpace str) of+ (a,b) | null a -> Nothing+ | otherwise -> Just (a,b)++-- | Parse and execute the given command. When the first argument is Nothing+-- the command is executed, otherwise the first argument is the cursor+-- position for tab-completion+executeCommand :: Maybe Bool -> String -> ClientState -> IO CommandResult++executeCommand (Just isReversed) _ st+ | Just st' <- commandNameCompletion isReversed st = commandContinue st'++executeCommand tabCompleteReversed str st =+ let (cmd, rest) = splitWord str+ cmdTxt = Text.toLower (Text.pack cmd) in+ case HashMap.lookup cmdTxt commands of++ Just (ClientCommand exec tab) ->+ maybe exec tab tabCompleteReversed+ st rest++ Just (NetworkCommand exec tab)+ | Just network <- views clientFocus focusNetwork st+ , Just cs <- preview (clientConnection network) st ->+ maybe exec tab tabCompleteReversed+ network cs st rest++ Just (ChannelCommand exec tab)+ | ChannelFocus network channelId <- view clientFocus st+ , Just cs <- preview (clientConnection network) st+ , isChannelIdentifier cs channelId ->+ maybe exec tab tabCompleteReversed+ network cs channelId st rest++ _ -> case tabCompleteReversed of+ Nothing -> commandContinue st+ Just isReversed -> commandContinue (nickTabCompletion isReversed st)++commands :: HashMap Text Command+commands = HashMap.fromList+ [ ("connect" , ClientCommand cmdConnect noClientTab)+ , ("exit" , ClientCommand cmdExit noClientTab)+ , ("focus" , ClientCommand cmdFocus simpleClientTab)+ , ("clear" , ClientCommand cmdClear noClientTab)+ , ("reconnect" , ClientCommand cmdReconnect noClientTab)+ , ("ignore" , ClientCommand cmdIgnore simpleClientTab)++ , ("quote" , NetworkCommand cmdQuote simpleNetworkTab)+ , ("join" , NetworkCommand cmdJoin simpleNetworkTab)+ , ("mode" , NetworkCommand cmdMode simpleNetworkTab)+ , ("msg" , NetworkCommand cmdMsg simpleNetworkTab)+ , ("nick" , NetworkCommand cmdNick simpleNetworkTab)+ , ("quit" , NetworkCommand cmdQuit simpleNetworkTab)+ , ("disconnect", NetworkCommand cmdDisconnect noNetworkTab)+ , ("who" , NetworkCommand cmdWho simpleNetworkTab)+ , ("whois" , NetworkCommand cmdWhois simpleNetworkTab)+ , ("whowas" , NetworkCommand cmdWhowas simpleNetworkTab)++ , ("invite" , ChannelCommand cmdInvite simpleChannelTab)+ , ("topic" , ChannelCommand cmdTopic tabTopic )+ , ("kick" , ChannelCommand cmdKick simpleChannelTab)+ , ("kickban" , ChannelCommand cmdKickBan simpleChannelTab)+ , ("remove" , ChannelCommand cmdRemove simpleChannelTab)+ , ("me" , ChannelCommand cmdMe simpleChannelTab)+ , ("part" , ChannelCommand cmdPart simpleChannelTab)++ , ("users" , ChannelCommand cmdUsers noChannelTab)+ , ("masks" , ChannelCommand cmdMasks noChannelTab)+ ]++noClientTab :: Bool -> ClientCommand+noClientTab _ st _ = commandContinue st++noNetworkTab :: Bool -> NetworkCommand+noNetworkTab _ _ _ st _ = commandContinue st++noChannelTab :: Bool -> ChannelCommand+noChannelTab _ _ _ _ st _ = commandContinue st++simpleClientTab :: Bool -> ClientCommand+simpleClientTab isReversed st _ =+ commandContinue (nickTabCompletion isReversed st)++simpleNetworkTab :: Bool -> NetworkCommand+simpleNetworkTab isReversed _ _ st _ =+ commandContinue (nickTabCompletion isReversed st)++simpleChannelTab :: Bool -> ChannelCommand+simpleChannelTab isReversed _ _ _ st _ =+ commandContinue (nickTabCompletion isReversed st)++cmdExit :: ClientState -> String -> IO CommandResult+cmdExit _ _ = return CommandQuit++-- | When used on a channel that the user is currently+-- joined to this command will clear the messages but+-- preserve the window. When used on a window that the+-- user is not joined to this command will delete the window.+cmdClear :: ClientState -> String -> IO CommandResult+cmdClear st _+ = commandContinue+ $ windowEffect+ $ consumeInput st+ where+ windowEffect+ | isActive = clearWindow+ | otherwise = deleteWindow++ deleteWindow = advanceFocus . setWindow Nothing+ clearWindow = setWindow (Just emptyWindow)++ setWindow = set (clientWindows . at (view clientFocus st))++ isActive =+ case view clientFocus st of+ Unfocused -> False+ NetworkFocus network ->+ has (clientConnection network) st+ ChannelFocus network channel ->+ has ( clientConnection network+ . csChannels . ix channel) st+++cmdQuote :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdQuote _ cs st rest =+ case parseRawIrcMsg (Text.pack rest) of+ Nothing -> commandContinue st+ Just raw ->+ do sendMsg cs raw+ commandContinue (consumeInput st)++-- | Implementation of @/me@+cmdMe :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdMe network cs channelId st rest =+ do now <- getZonedTime+ let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A")+ myNick = UserInfo (view csNick cs) Nothing Nothing+ entry = ClientMessage+ { _msgTime = now+ , _msgNetwork = network+ , _msgBody = IrcBody (Action myNick channelId (Text.pack rest))+ }+ sendMsg cs (ircPrivmsg channelId actionTxt)+ commandContinue+ $ recordChannelMessage network channelId entry+ $ consumeInput st++-- | Implementation of @/msg@+cmdMsg :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdMsg network cs st rest =+ case nextWord rest of+ Nothing -> commandContinue st+ Just (targetsStr, msgStr) ->+ do now <- getZonedTime+ let targetsTxt = Text.pack targetsStr+ targetTxts = Text.split (==',') targetsTxt+ targetIds = mkId <$> targetTxts+ msgTxt = Text.pack msgStr+ myNick = UserInfo (view csNick cs) Nothing Nothing+ entries = [ (targetId,+ ClientMessage+ { _msgTime = now+ , _msgNetwork = network+ , _msgBody = IrcBody (Privmsg myNick targetId msgTxt)+ })+ | targetId <- targetIds ]++ sendMsg cs (ircPrivmsg (mkId targetsTxt) msgTxt)++ let st' = foldl' (\acc (targetId, entry) ->+ recordChannelMessage network targetId entry acc)+ st+ entries++ commandContinue (consumeInput st')++cmdConnect :: ClientState -> String -> IO CommandResult+cmdConnect st rest =+ case words rest of+ [networkStr] ->+ do -- abort any existing connection before connecting+ let network = Text.pack networkStr+ st' <- addConnection network =<< abortNetwork network st+ commandContinue+ $ changeFocus (NetworkFocus network)+ $ consumeInput st'++ _ -> commandContinue st++cmdFocus :: ClientState -> String -> IO CommandResult+cmdFocus st rest =+ case words rest of+ [network] ->+ let focus = NetworkFocus (Text.pack network) in+ commandContinue+ $ changeFocus focus+ $ consumeInput st++ [network,channel] ->+ let focus = ChannelFocus (Text.pack network) (mkId (Text.pack channel)) in+ commandContinue+ $ changeFocus focus+ $ consumeInput st++ _ -> commandContinue st++cmdWhois :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdWhois _ cs st rest =+ do sendMsg cs (ircWhois (Text.pack <$> words rest))+ commandContinue (consumeInput st)++cmdWho :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdWho _ cs st rest =+ do sendMsg cs (ircWho (Text.pack <$> words rest))+ commandContinue (consumeInput st)++cmdWhowas :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdWhowas _ cs st rest =+ do sendMsg cs (ircWhowas (Text.pack <$> words rest))+ commandContinue (consumeInput st)++cmdMode :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdMode _ cs st rest = modeCommand (Text.pack <$> words rest) cs st++cmdNick :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdNick _ cs st rest =+ case words rest of+ [nick] ->+ do sendMsg cs (ircNick (mkId (Text.pack nick)))+ commandContinue (consumeInput st)+ _ -> commandContinue st++cmdPart :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdPart _ cs channelId st rest =+ do let msg = dropWhile isSpace rest+ sendMsg cs (ircPart channelId (Text.pack msg))+ commandContinue (consumeInput st)++cmdInvite :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdInvite _ cs channelId st rest =+ case words rest of+ [nick] ->+ do let freeTarget = has (csChannels . ix channelId . chanModes . ix 'g') cs+ cmd = ircInvite (Text.pack nick) channelId+ cs' <- if freeTarget+ then cs <$ sendMsg cs cmd+ else sendModeration channelId [cmd] cs+ commandContinueUpdateCS cs' st++ _ -> commandContinue st++commandContinueUpdateCS :: ConnectionState -> ClientState -> IO CommandResult+commandContinueUpdateCS cs st =+ let networkId = view csNetworkId cs in+ commandContinue+ $ setStrict (clientConnections . ix networkId) cs+ $ consumeInput st++cmdTopic :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdTopic _ cs channelId st rest =+ do let cmd =+ case dropWhile isSpace rest of+ "" -> ircTopic channelId ""+ topic | useChanServ channelId cs ->+ ircPrivmsg (mkId "ChanServ")+ ("TOPIC " <> idText channelId <> Text.pack (' ' : topic))+ | otherwise -> ircTopic channelId (Text.pack topic)+ sendMsg cs cmd+ commandContinue (consumeInput st)++tabTopic :: Bool -> NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+tabTopic _ _ cs channelId st rest++ | all isSpace rest+ , Just topic <- preview (csChannels . ix channelId . chanTopic) cs =+ do let textBox = Edit.end+ . set Edit.content ("/topic " ++ Text.unpack topic)+ commandContinue (over clientTextBox textBox st)++ | otherwise = commandContinue st++cmdUsers :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdUsers _ _ _ st _ = commandContinue+ $ changeSubfocus FocusUsers+ $ consumeInput st++cmdMasks :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdMasks _ cs _ st rest =+ case words rest of+ [[mode]] | mode `elem` view (csModeTypes . modesLists) cs ->+ commandContinue $ changeSubfocus (FocusMasks mode)+ $ consumeInput st+ _ -> commandContinue st++cmdKick :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdKick _ cs channelId st rest =+ case nextWord rest of+ Nothing -> commandContinue st+ Just (who,reason) ->+ do let msg = Text.pack (dropWhile isSpace reason)+ cmd = ircKick channelId (Text.pack who) msg+ cs' <- sendModeration channelId [cmd] cs+ commandContinueUpdateCS cs' st++cmdKickBan :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdKickBan _ cs channelId st rest =+ case nextWord rest of+ Nothing -> commandContinue st+ Just (whoStr,reason) ->+ do let msg = Text.pack (dropWhile isSpace reason)++ whoTxt = Text.pack whoStr++ mask = renderUserInfo (computeBanUserInfo (mkId whoTxt) cs)+ cmds = [ ircMode channelId ["b", mask]+ , ircKick channelId whoTxt msg+ ]+ cs' <- sendModeration channelId cmds cs+ commandContinueUpdateCS cs' st++computeBanUserInfo :: Identifier -> ConnectionState -> UserInfo+computeBanUserInfo who cs =+ case view (csUser who . _2) cs of+ Nothing -> UserInfo who (Just "*") (Just "*")+ Just host -> UserInfo (mkId "*") (Just "*") (Just host)++cmdRemove :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdRemove _ cs channelId st rest =+ case nextWord rest of+ Nothing -> commandContinue st+ Just (who,reason) ->+ do let msg = Text.pack (dropWhile isSpace reason)+ cmd = ircRemove channelId (Text.pack who) msg+ cs' <- sendModeration channelId [cmd] cs+ commandContinueUpdateCS cs' st++cmdJoin :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdJoin network cs st rest =+ let ws = words rest+ doJoin channelStr keyStr =+ do let channelId = mkId (Text.pack (takeWhile (/=',') channelStr))+ sendMsg cs (ircJoin (Text.pack channelStr) (Text.pack <$> keyStr))+ commandContinue+ $ changeFocus (ChannelFocus network channelId)+ $ consumeInput st+ in case ws of+ [channel] -> doJoin channel Nothing+ [channel,key] -> doJoin channel (Just key)+ _ -> commandContinue st+++cmdQuit :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdQuit _ cs st rest =+ do let msg = Text.pack (dropWhile isSpace rest)+ sendMsg cs (ircQuit msg)+ commandContinue (consumeInput st)++cmdDisconnect :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdDisconnect network _ st _ =+ do st' <- abortNetwork network st+ commandContinue (consumeInput st')++-- | Reconnect to the currently focused network. It's possible+-- that we're not currently connected to a network, so+-- this is implemented as a client command.+cmdReconnect :: ClientState -> String -> IO CommandResult+cmdReconnect st _+ | Just network <- views clientFocus focusNetwork st =++ do st' <- addConnection network =<< abortNetwork network st+ commandContinue+ $ changeFocus (NetworkFocus network)+ $ consumeInput st'++ | otherwise = commandContinue st++cmdIgnore :: ClientState -> String -> IO CommandResult+cmdIgnore st rest =+ case mkId . Text.pack <$> words rest of+ [] -> commandContinue st+ xs -> commandContinue+ $ over clientIgnores updateIgnores+ $ consumeInput st+ where+ updateIgnores :: HashSet Identifier -> HashSet Identifier+ updateIgnores s = foldl' updateIgnore s xs+ updateIgnore s x = over (contains x) not s++modeCommand :: [Text] -> ConnectionState -> ClientState -> IO CommandResult+modeCommand modes cs st =+ case view clientFocus st of++ NetworkFocus _ ->+ do sendMsg cs (ircMode (view csNick cs) modes)+ commandContinue (consumeInput st)++ ChannelFocus _ chan ->+ case modes of+ [] -> success False [[]]+ flags:params ->+ case splitModes (view csModeTypes cs) flags params of+ Nothing -> commandContinue st+ Just parsedModes ->+ success needOp (unsplitModes <$> chunksOf (view csModeCount cs) parsedModes')+ where+ parsedModes'+ | useChanServ chan cs = filter (not . isOpMe) parsedModes+ | otherwise = parsedModes++ needOp = not (all isPublicChannelMode parsedModes)+ where+ isOpMe (True, 'o', param) = mkId param == view csNick cs+ isOpMe _ = False++ success needOp argss =+ do let cmds = ircMode chan <$> argss+ cs' <- if needOp+ then sendModeration chan cmds cs+ else cs <$ traverse_ (sendMsg cs) cmds+ commandContinueUpdateCS cs' st++ _ -> commandContinue st++-- | Predicate for mode commands that can be performed without ops+isPublicChannelMode :: (Bool, Char, Text) -> Bool+isPublicChannelMode (True, 'b', param) = Text.null param -- query ban list+isPublicChannelMode (True, 'q', param) = Text.null param -- query quiet list+isPublicChannelMode _ = False++commandNameCompletion :: Bool -> ClientState -> Maybe ClientState+commandNameCompletion isReversed st =+ do guard (cursorPos == n)+ clientTextBox (wordComplete id isReversed possibilities) st+ where+ n = length leadingPart+ leadingPart = takeWhile (not . isSpace) (clientInput st)+ cursorPos = view (clientTextBox . Edit.pos) st+ possibilities = mkId . Text.cons '/' <$> HashMap.keys commands++-- | Complete the nickname at the current cursor position using the+-- userlist for the currently focused channel (if any)+nickTabCompletion :: Bool {- ^ reversed -} -> ClientState -> ClientState+nickTabCompletion isReversed st+ = fromMaybe st+ $ clientTextBox (wordComplete (++": ") isReversed completions) st+ where+ completions = currentUserList st++sendModeration :: Identifier -> [RawIrcMsg] -> ConnectionState -> IO ConnectionState+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 channel cs =+ channel `elem` view (csSettings . ssChanservChannels) cs &&+ not (iHaveOp channel cs)
+ src/Client/Configuration.hs view
@@ -0,0 +1,152 @@+{-# Language OverloadedStrings #-}+{-# Language TemplateHaskell #-}+{-# Language BangPatterns #-}+{-# Language RecordWildCards #-}++{-|+Module : Client.Configuration+Description : Client configuration format and operations+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module defines the top-level configuration information for the client.+-}++module Client.Configuration+ (+ -- * Configuration type+ Configuration(..)+ , configDefaults+ , configServers++ -- * Loading configuration+ , loadConfiguration+ ) where++import Client.ServerSettings+import Control.Applicative+import Control.Exception+import Config+import Config.FromConfig+import Control.Lens hiding (List)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Traversable+import Irc.Identifier (Identifier, mkId)+import Network.Socket (HostName)+import System.Directory+import System.FilePath++-- | Top-level client configuration information. When connecting to a+-- server configuration from '_configServers' is used where possible,+-- otherwise '_configDefaults' is used.+data Configuration = Configuration+ { _configDefaults :: ServerSettings -- ^ Default connection settings+ , _configServers :: HashMap HostName ServerSettings -- ^ Host-specific settings+ }+ deriving Show++makeLenses ''Configuration++data ConfigurationFailure+ = ConfigurationParseFailed String+ | ConfigurationMalformed Text+ deriving Show++instance Exception ConfigurationFailure++getConfigPath :: IO FilePath+getConfigPath =+ do dir <- getAppUserDataDirectory "glirc"+ return (dir </> "config")++-- | Load the configuration file defaulting to @~/.glirc/config@.+-- This action can throw 'IOError' and 'ConfigurationFailure'+-- exceptions.+loadConfiguration ::+ Maybe FilePath {- ^ path to configuration file -} ->+ IO Configuration+loadConfiguration mbPath =+ do path <- maybe getConfigPath return mbPath+ file <- Text.readFile path+ def <- loadDefaultServerSettings+ case parse file of+ Left parseError -> throwIO (ConfigurationParseFailed parseError)+ Right rawcfg ->+ case runConfigParser (parseConfiguration def rawcfg) of+ Left loadError -> throwIO (ConfigurationMalformed loadError)+ Right cfg -> return cfg+++parseConfiguration :: ServerSettings -> Value -> ConfigParser Configuration+parseConfiguration def = parseSections $++ do _configDefaults <- fromMaybe def+ <$> sectionOptWith (parseServerSettings def) "defaults"++ _configServers <- fromMaybe HashMap.empty+ <$> sectionOptWith (parseServers _configDefaults) "servers"++ return Configuration{..}++parseServers :: ServerSettings -> Value -> ConfigParser (HashMap HostName ServerSettings)+parseServers def (List xs) =+ do ys <- traverse (parseServerSettings def) xs+ return (HashMap.fromList [(view ssHostName ss, ss) | ss <- ys])+parseServers _ _ = failure "expected list"++sectionOptString :: Text -> SectionParser (Maybe String)+sectionOptString key = fmap Text.unpack <$> sectionOpt key++sectionOptStrings :: Text -> SectionParser (Maybe [String])+sectionOptStrings key = fmap (fmap Text.unpack) <$> sectionOpt key++sectionOptNum :: Num a => Text -> SectionParser (Maybe a)+sectionOptNum key = fmap fromInteger <$> sectionOpt key++sectionOptIdentifiers :: Text -> SectionParser (Maybe [Identifier])+sectionOptIdentifiers key = fmap (fmap mkId) <$> sectionOpt key++parseServerSettings :: ServerSettings -> Value -> ConfigParser ServerSettings+parseServerSettings !def =+ parseSections $+ do _ssNick <- fieldReq ssNick "nick"+ _ssUser <- fieldReq ssUser "username"+ _ssReal <- fieldReq ssReal "realname"+ _ssUserInfo <- fieldReq ssUserInfo "userinfo"+ _ssPassword <- field ssPassword "password"+ _ssSaslUsername <- field ssSaslUsername "sasl-username"+ _ssSaslPassword <- field ssSaslPassword "sasl-password"+ _ssHostName <- fieldReq' ssHostName (sectionOptString "hostname")+ _ssPort <- field' ssPort (sectionOptNum "port")+ _ssTls <- fieldReq' ssTls (boolean "tls")+ _ssTlsInsecure <- fieldReq' ssTlsInsecure (boolean "tls-insecure")+ _ssTlsClientCert <- field' ssTlsClientCert (sectionOptString "tls-client-cert")+ _ssTlsClientKey <- field' ssTlsClientKey (sectionOptString "tls-client-key")+ _ssConnectCmds <- fieldReq ssConnectCmds "connect-cmds"+ _ssSocksHost <- field' ssSocksHost (sectionOptString "socks-host")+ _ssSocksPort <- fieldReq' ssSocksPort (sectionOptNum "socks-port")+ _ssServerCerts <- fieldReq' ssServerCerts (sectionOptStrings "server-certificates")+ _ssChanservChannels <- fieldReq' ssChanservChannels (sectionOptIdentifiers "chanserv-channels")+ return ServerSettings{..}+ where+ field l key = field' l (sectionOpt key)+ fieldReq l key = fieldReq' l (sectionOpt key)++ fieldReq' l p = fromMaybe (view l def) <$> p++ field' l p = (<|> view l def) <$> p++boolean :: Text -> SectionParser (Maybe Bool)+boolean key =+ do mb <- sectionOpt key+ for mb $ \a ->+ case atomName a of+ "yes" -> return True+ "no" -> return False+ _ -> liftConfigParser (failure "expected yes or no")
+ src/Client/Connect.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Client.Connect+Description : Interface to the connection package+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module is responsible for creating 'Connection' values+for a particular server as specified by a 'ServerSettings'.+This involves setting up certificate stores an mapping+network settings from the client configuration into the+network connection library.+-}++module Client.Connect (withConnection) where++import Control.Lens+import Control.Exception (bracket)+import Data.Default.Class (def)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.X509 (CertificateChain(..))+import Data.X509.CertificateStore (CertificateStore, makeCertificateStore)+import Data.X509.File (readSignedObject, readKeyFile)+import Network.Connection+import Network.Socket (PortNumber)+import Network.TLS+import Network.TLS.Extra (ciphersuite_all)+import System.X509 (getSystemCertificateStore)++import Client.ServerSettings++buildConnectionParams :: ServerSettings -> IO ConnectionParams+buildConnectionParams args =+ do useSecure <- if view ssTls args+ then fmap Just (buildTlsSettings args)+ else return Nothing++ let proxySettings = view ssSocksHost args <&> \host ->+ SockSettingsSimple+ host+ (view ssSocksPort args)++ return ConnectionParams+ { connectionHostname = view ssHostName args+ , connectionPort = ircPort args+ , connectionUseSecure = useSecure+ , connectionUseSocks = proxySettings+ }++ircPort :: ServerSettings -> PortNumber+ircPort args =+ case view ssPort args of+ Just p -> fromIntegral p+ Nothing | view ssTls args -> 6697+ | otherwise -> 6667++buildCertificateStore :: ServerSettings -> IO CertificateStore+buildCertificateStore args =+ do systemStore <- getSystemCertificateStore+ userCerts <- traverse readSignedObject (view ssServerCerts args)+ let userStore = makeCertificateStore (concat userCerts)+ return (userStore <> systemStore)++buildTlsSettings :: ServerSettings -> IO TLSSettings+buildTlsSettings args =+ do store <- buildCertificateStore args++ let noValidation =+ ValidationCache+ (\_ _ _ -> return ValidationCachePass)+ (\_ _ _ -> return ())++ return $ TLSSettings ClientParams+ { clientWantSessionResume = Nothing+ , clientUseMaxFragmentLength = Nothing+ , clientServerIdentification =+ error "buildTlsSettings: field initialized by connectTo"+ , clientUseServerNameIndication = True+ , clientShared = def+ { sharedCAStore = store+ , sharedValidationCache =+ if view ssTlsInsecure args then noValidation else def+ }+ , clientHooks = def+ { onCertificateRequest = \_ -> loadClientCredentials args }+ , clientSupported = def+ { supportedCiphers = ciphersuite_all }+ , clientDebug = def+ }++loadClientCredentials :: ServerSettings -> IO (Maybe (CertificateChain, PrivKey))+loadClientCredentials args =+ case view ssTlsClientCert args of+ Nothing -> return Nothing+ Just certPath ->+ do cert <- readSignedObject certPath+ keys <- readKeyFile (fromMaybe certPath (view ssTlsClientKey args))+ case keys of+ [key] -> return (Just (CertificateChain cert, key))+ [] -> fail "No private keys found"+ _ -> fail "Too many private keys found"++connect :: ConnectionContext -> ServerSettings -> IO Connection+connect connectionContext args = do+ connectionParams <- buildConnectionParams args+ connectTo connectionContext connectionParams++-- | Create a new 'Connection' which will be closed when the continuation finishes.+withConnection :: ConnectionContext -> ServerSettings -> (Connection -> IO a) -> IO a+withConnection cxt settings = bracket (connect cxt settings) connectionClose
+ src/Client/ConnectionState.hs view
@@ -0,0 +1,703 @@+{-# 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 type+ ConnectionState+ , csNick+ , csChannels+ , csSocket+ , csModeTypes+ , csChannelTypes+ , csTransaction+ , csModes+ , csStatusMsg+ , csSettings+ , csUserInfo+ , csUsers+ , csUser+ , csModeCount+ , csNetworkId+ , csNetwork+ , csNextPingTime+ , csPingStatus++ , newConnectionState++ -- * Connection predicates+ , isChannelIdentifier+ , iHaveOp++ -- * Messages interactions+ , sendMsg+ , initialMessages+ , applyMessage+ , squelchIrcMsg++ -- * Timer information+ , PingStatus(..)+ , TimedAction(..)+ , nextTimedAction+ ) where++import Client.ChannelState+import Client.NetworkConnection+import Client.ServerSettings+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++data ConnectionState = ConnectionState+ { _csNetworkId :: NetworkId+ , _csChannels :: !(HashMap Identifier ChannelState)+ , _csSocket :: !NetworkConnection+ , _csModeTypes :: !ModeTypes+ , _csChannelTypes :: ![Char]+ , _csTransaction :: !Transaction+ , _csModes :: ![Char]+ , _csStatusMsg :: ![Char]+ , _csSettings :: !ServerSettings+ , _csUserInfo :: !UserInfo+ , _csUsers :: !(HashMap Identifier (Maybe Text, Maybe Text))+ , _csModeCount :: !Int+ , _csNetwork :: !Text+ , _csNextPingTime :: !(Maybe UTCTime)+ , _csPingStatus :: !PingStatus+ }+ deriving Show++data PingStatus+ = PingSent !UTCTime+ | PingLatency !Double -- seconds+ | PingNever+ deriving Show++data Transaction+ = NoTransaction+ | NamesTransaction [Text]+ | BanTransaction [(Text,(Text,UTCTime))]+ | 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)) Nothing Nothing+ , _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+ }++++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 code args -> noReply (doRpl code msgWhen args cs)+ Cap cmd params -> doCap cmd params 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 cs = (reply, update cs)+ where+ reply = mapMaybe parseRawIrcMsg (view (csSettings . ssConnectCmds) cs)++ update+ = 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 :: Int -> ZonedTime -> [Text] -> ConnectionState -> ConnectionState+doRpl cmd msgWhen args =+ case cmd of++ 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_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:_ | Just when <- parseTimeParam whenTxt ->+ over csTransaction $ \t ->+ let !xs = view _BanTransaction t+ in BanTransaction ((mask,(who,when)):xs)+ _ -> id++ RPL_ENDOFBANLIST ->+ case args of+ _me:tgt:_ -> \cs ->+ set csTransaction NoTransaction+ $ setStrict (csChannels . ix (mkId tgt) . chanList 'b')+ (HashMap.fromList (view (csTransaction . _BanTransaction) cs))+ cs+ _ -> id++ RPL_QUIETLIST ->+ case args of+ _me:_tgt:_q:mask:who:whenTxt:_ | Just when <- parseTimeParam whenTxt ->+ over csTransaction $ \t ->+ let !xs = view _BanTransaction t+ in BanTransaction ((mask,(who,when)):xs)+ _ -> id++ RPL_ENDOFQUIETLIST ->+ case args of+ _me:tgt:_ -> \cs ->+ set csTransaction NoTransaction+ $ setStrict (csChannels . ix (mkId tgt) . chanList 'q')+ (HashMap.fromList (view (csTransaction . _BanTransaction) cs))+ cs+ _ -> id++ RPL_INVITELIST ->+ case args of+ _me:_tgt:mask:who:whenTxt:_ | Just when <- parseTimeParam whenTxt ->+ over csTransaction $ \t ->+ let !xs = view _BanTransaction t+ in BanTransaction ((mask,(who,when)):xs)+ _ -> id++ RPL_ENDOFINVITELIST ->+ case args of+ _me:tgt:_ -> \cs ->+ set csTransaction NoTransaction+ $ setStrict (csChannels . ix (mkId tgt) . chanList 'I')+ (HashMap.fromList (view (csTransaction . _BanTransaction) cs))+ cs+ _ -> id++ RPL_EXCEPTLIST ->+ case args of+ _me:_tgt:mask:who:whenTxt:_ | Just when <- parseTimeParam whenTxt ->+ over csTransaction $ \t ->+ let !xs = view _BanTransaction t+ in BanTransaction ((mask,(who,when)):xs)+ _ -> id++ RPL_ENDOFEXCEPTLIST ->+ case args of+ _me:tgt:_ -> \cs ->+ set csTransaction NoTransaction+ $ setStrict (csChannels . ix (mkId tgt) . chanList 'e')+ (HashMap.fromList (view (csTransaction . _BanTransaction) cs))+ cs+ _ -> id++ RPL_WHOREPLY ->+ case args of+ _me:_tgt:uname:host:_server:nick:_ ->+ over csTransaction $ \t ->+ let !xs = view _WhoTransaction t+ in WhoTransaction (UserInfo (mkId nick) (Just uname) (Just host) : xs)+ _ -> id++ RPL_ENDOFWHO -> massRegistration++ RPL_CHANNELMODEIS ->+ case args of+ _me:chan:modes:params ->+ snd -- channel mode reply shouldn't trigger messages+ . doMode msgWhen (UserInfo (mkId "*") Nothing Nothing) chanId modes params+ . set (csChannels . ix chanId . chanModes) Map.empty+ where chanId = mkId chan+ _ -> id+ _ -> id+++-- | These replies are interpreted by the client and should only be shown+-- in the detailed view. Any reply interpreted by 'doRpl' should be+-- listed here.+squelchReply :: Int -> Bool+squelchReply rpl =+ case rpl of+ RPL_NAMREPLY -> True+ RPL_ENDOFNAMES -> True+ RPL_BANLIST -> True+ RPL_ENDOFBANLIST -> True+ RPL_INVITELIST -> True+ RPL_ENDOFINVITELIST -> 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_NOTOPIC -> 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 (renderUserInfo who, zonedTimeToUTC when)+ | otherwise = Nothing+ in setStrict (chanList 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 -> foldl applyOne modes changes+ where+ applyOne modes (True, mode, _)+ | mode `elem` modes = modes+ | otherwise = mode:modes+ applyOne modes (False, mode, _) = delete mode modes++supportedCaps :: [Text]+supportedCaps = ["multi-prefix", "znc.in/server-time-iso"]++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 caps++ (CapAck,_) -> ([ircCapEnd], cs)+ (CapNak,_) -> ([ircCapEnd], cs)++ _ -> noReply 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 Text, Maybe Text)+csUser i = csUsers . at i . non (Nothing,Nothing)++recordUser :: UserInfo -> ConnectionState -> ConnectionState+recordUser !user = set (csUsers . at (userNick user))+ (Just (userName user, userHost user))++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++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 !info+ | HashSet.member (userNick info) channelUsers =+ HashMap.insert (userNick info) (userName info, userHost info) users+ | otherwise = users++data TimedAction+ = TimedDisconnect+ | TimedSendPing+ deriving (Eq, Ord, Show)++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
+ src/Client/EditBox.hs view
@@ -0,0 +1,233 @@+{-# 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+ ( EditBox+ , content+ , pos+ , tabSeed+ , delete+ , backspace+ , home+ , end+ , killHome+ , killEnd+ , killWord+ , paste+ , left+ , right+ , leftWord+ , rightWord+ , insert+ , insertString+ , empty+ , earlier+ , later+ , success+ ) where++import Control.Lens+import Data.Char++data EditBox = EditBox+ { _content :: !String+ , _pos :: !Int+ , _history :: ![String]+ , _historyPos :: !Int+ , _yankBuffer :: !(String)+ , _tabSeed :: !(Maybe String)+ }+ deriving (Read, Show)++makeLenses ''EditBox++-- | Default 'EditBox value+empty :: EditBox+empty = EditBox+ { _content = ""+ , _pos = 0+ , _history = []+ , _historyPos = -1+ , _yankBuffer = ""+ , _tabSeed = Nothing+ }++-- | 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 contents and cursor and updates the+-- history.+success :: EditBox -> EditBox+success e+ = over history (cons (view content e))+ $ set content ""+ $ set tabSeed Nothing+ $ set historyPos (-1)+ $ set pos 0 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 x+ $ set pos (length 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 ""+ $ set pos 0+ $ set historyPos (-1) e+ | otherwise =+ do x <- preview (history . ix (i-1)) e+ return $ set content x+ $ set pos (length x)+ $ set historyPos (i-1) e+ where+ i = view historyPos e++-- Remove a character without the associated checks+-- internal helper for backspace and delete+removeImpl :: EditBox -> EditBox+removeImpl e+ = set content (a++drop 1 b)+ $ set tabSeed Nothing+ $ over pos (min (views content length e - 1)) e+ where+ (a,b) = splitAt (view pos e) (view content e)++-- | Delete the character after the cursor.+delete :: EditBox -> EditBox+delete e+ | view pos e < views content length e = removeImpl e+ | otherwise = e++-- | Delete the character before the cursor.+backspace :: EditBox -> EditBox+backspace e+ | view pos e > 0 = removeImpl (left e)+ | otherwise = e++-- | Jump the cursor to the beginning of the input.+home :: EditBox -> EditBox+home+ = set tabSeed Nothing+ . set pos 0++-- | Jump the cursor to the end of the input.+end :: EditBox -> EditBox+end e+ = set tabSeed Nothing+ $ set pos (views content length e) e++-- | Delete all text from the cursor to the end and store it in+-- the yank buffer.+killEnd :: EditBox -> EditBox+killEnd e+ = set content keep+ $ updateYankBuffer kill e+ where+ (keep,kill) = splitAt (view pos e) (view content e)++-- | Delete all text from the cursor to the beginning and store it in+-- the yank buffer.+killHome :: EditBox -> EditBox+killHome e+ = set content keep+ $ set pos 0+ $ set tabSeed Nothing+ $ updateYankBuffer kill e+ where+ (kill,keep) = splitAt (view pos e) (view content e)++-- | Insert the yank buffer at the cursor.+paste :: EditBox -> EditBox+paste e = 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.+killWord :: Bool {- ^ yank -} -> EditBox -> EditBox+killWord yank e+ = set pos (length l')+ $ sometimesUpdateYank+ $ set content (l'++r) e+ where+ (l,r) = splitAt (view pos e) (view content e)+ (sp,l1) = span isSpace (reverse l)+ (wd,l2) = break isSpace l1+ l' = reverse l2+ yanked = reverse (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+ . insertString [c]++-- | Insert a string at the cursor and advance the cursor.+insertString :: String -> EditBox -> EditBox+insertString str e+ = over pos (+length str)+ $ set content (a ++ str ++ b) e+ where+ (a,b) = splitAt (view pos e) (view content e)++-- | Move the cursor left.+left :: EditBox -> EditBox+left = over pos (max 0 . subtract 1)++-- | Move the cursor right.+right :: EditBox -> EditBox+right e = over pos (min (views content length e) . (+1)) e++-- | Move the cursor left to the previous word boundary.+leftWord :: EditBox -> EditBox+leftWord e =+ case search of+ [] -> set pos 0 e+ (i,_):_ -> set pos (i+1) e+ where+ search = dropWhile (isAlphaNum . snd)+ $ dropWhile (not . isAlphaNum . snd)+ $ reverse+ $ take (view pos e)+ $ zip [0..]+ $ view content e++-- | Move the cursor right to the next word boundary.+rightWord :: EditBox -> EditBox+rightWord e =+ case search of+ [] -> set pos (views content length e) e+ (i,_):_ -> set pos i e+ where+ search = dropWhile (isAlphaNum . snd)+ $ dropWhile (not . isAlphaNum . snd)+ $ drop (view pos e)+ $ zip [0..]+ $ view content e
+ src/Client/EventLoop.hs view
@@ -0,0 +1,349 @@+{-# Language OverloadedStrings #-}++{-|+Module : Client.EventLoop+Description : Event loop for IRC client+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module is responsible for dispatching user-input, network, and timer+events to the correct module. It renders the user interface once per event.+-}++module Client.EventLoop+ ( eventLoop+ ) where++import Client.Commands+import Client.ConnectionState+import qualified Client.EditBox as Edit+import Client.Image+import Client.Message+import Client.NetworkConnection+import Client.State+import Client.Window+import Control.Concurrent.STM+import Control.Exception+import Control.Lens+import Control.Monad+import Data.ByteString (ByteString)+import Data.Foldable+import qualified Data.IntMap as IntMap+import Data.List+import qualified Data.Map as Map+import Data.Maybe+import Data.Ord+import qualified Data.Text as Text+import Data.Time+import Graphics.Vty+import Irc.Identifier+import Irc.Message+import Irc.RawIrcMsg+import Irc.UserInfo+++-- | Sum of the three possible event types the event loop handles+data ClientEvent+ = VtyEvent Event -- ^ Key presses and resizing+ | NetworkEvent NetworkEvent -- ^ Incoming network events+ | TimerEvent NetworkId TimedAction -- ^ Timed action and the applicable network+++-- | Block waiting for the next 'ClientEvent'. This function will compute+-- an appropriate timeout based on the current connections.+getEvent :: ClientState -> IO ClientEvent+getEvent st =+ do timer <- prepareTimer+ atomically $+ asum [ timer+ , VtyEvent <$> readTChan vtyEventChannel+ , NetworkEvent <$> readTQueue (view clientEvents st)+ ]+ where+ vtyEventChannel = _eventChannel (inputIface (view clientVty st))++ possibleTimedEvents =+ [ (networkId, runAt, action)+ | (networkId, cs) <- views clientConnections IntMap.toList st+ , Just (runAt, action) <- [nextTimedAction cs]+ ]++ earliestEvent+ | null possibleTimedEvents = Nothing+ | otherwise = Just (minimumBy (comparing (\(_,runAt,_) -> runAt)) possibleTimedEvents)++ prepareTimer =+ case earliestEvent of+ Nothing -> return retry+ Just (networkId,runAt,action) ->+ do now <- getCurrentTime+ let microsecs = truncate (1000000 * diffUTCTime runAt now)+ var <- registerDelay (max 0 microsecs)+ return $ do ready <- readTVar var+ unless ready retry+ return (TimerEvent networkId action)++-- | Apply this function to an initial 'ClientState' to launch the client.+eventLoop :: ClientState -> IO ()+eventLoop st0 =+ do st1 <- clientTick st0+ let vty = view clientVty st+ (pic, st) = clientPicture st1++ update vty pic++ event <- getEvent st+ case event of+ TimerEvent networkId action -> doTimerEvent networkId action st+ VtyEvent vtyEvent -> doVtyEvent vtyEvent st+ NetworkEvent networkEvent ->+ case networkEvent of+ NetworkLine network time line -> doNetworkLine network time line st+ NetworkError network time ex -> doNetworkError network time ex st+ NetworkClose network time -> doNetworkClose network time st++-- | Respond to a network connection closing normally.+doNetworkClose ::+ NetworkId {- ^ finished network -} ->+ ZonedTime {- ^ current time -} ->+ ClientState -> IO ()+doNetworkClose networkId time st =+ let (cs,st') = removeNetwork networkId st+ msg = ClientMessage+ { _msgTime = time+ , _msgNetwork = view csNetwork cs+ , _msgBody = ExitBody+ }+ in eventLoop $ recordNetworkMessage msg st'+++-- | Respond to a network connection closing abnormally.+doNetworkError ::+ NetworkId {- ^ failed network -} ->+ ZonedTime {- ^ current time -} ->+ SomeException {- ^ termination reason -} ->+ ClientState -> IO ()+doNetworkError networkId time ex st =+ let (cs,st') = removeNetwork networkId st+ msg = ClientMessage+ { _msgTime = time+ , _msgNetwork = view csNetwork cs+ , _msgBody = ErrorBody (show ex)+ }+ in eventLoop $ recordNetworkMessage msg st'++-- | Respond to an IRC protocol line. This will parse the message, updated the+-- relevant connection state and update the UI buffers.+doNetworkLine ::+ NetworkId {- ^ Network ID of message -} ->+ ZonedTime {- ^ current time -} ->+ ByteString {- ^ Raw IRC message without newlines -} ->+ ClientState -> IO ()+doNetworkLine networkId time line st =+ case view (clientConnections . at networkId) st of+ Nothing -> error "doNetworkLine: Network missing"+ Just cs ->+ let network = view csNetwork cs in+ case parseRawIrcMsg (asUtf8 line) of+ Nothing ->+ do let msg = ClientMessage+ { _msgTime = time+ , _msgNetwork = network+ , _msgBody = ErrorBody ("Malformed message: " ++ show line)+ }+ eventLoop (recordNetworkMessage msg st)++ Just raw ->+ do let irc = cookIrcMsg raw+ time' = case view msgServerTime raw of+ Nothing -> time+ Just stime -> utcToZonedTime (zonedTimeZone time) stime+ msg = ClientMessage+ { _msgTime = time'+ , _msgNetwork = network+ , _msgBody = IrcBody irc+ }+ myNick = view csNick cs+ target = msgTarget myNick irc++ -- record messages *before* applying the changes+ let (msgs, st')+ = traverseOf+ (clientConnection network)+ (applyMessage time irc)+ $ recordIrcMessage network target msg+ $ st++ traverse_ (sendMsg cs) msgs+ eventLoop st'++-- | Respond to a VTY event.+doVtyEvent :: Event -> ClientState -> IO ()+doVtyEvent vtyEvent st =+ case vtyEvent of+ EvKey k modifier -> doKey k modifier st+ EvResize{} -> -- ignore event parameters due to raw TChan use+ do let vty = view clientVty st+ refresh vty+ (w,h) <- displayBounds (outputIface vty)+ eventLoop $ set clientWidth w+ $ set clientHeight h st+ _ -> eventLoop st++-- | Map keyboard inputs to actions in the client+doKey :: Key -> [Modifier] -> ClientState -> IO ()+doKey key modifier st =+ let changeInput f = eventLoop (over clientTextBox f st) in+ case modifier of+ [MCtrl] ->+ case key of+ KChar 'd' -> changeInput Edit.delete+ KChar 'a' -> changeInput Edit.home+ KChar 'e' -> changeInput Edit.end+ KChar 'u' -> changeInput Edit.killHome+ KChar 'k' -> changeInput Edit.killEnd+ KChar 'y' -> changeInput Edit.paste+ KChar 'w' -> changeInput (Edit.killWord True)+ KChar 'b' -> changeInput (Edit.insert '\^B')+ KChar 'c' -> changeInput (Edit.insert '\^C')+ KChar ']' -> changeInput (Edit.insert '\^]')+ KChar '_' -> changeInput (Edit.insert '\^_')+ KChar 'o' -> changeInput (Edit.insert '\^O')+ KChar 'v' -> changeInput (Edit.insert '\^V')+ KChar 'p' -> eventLoop (retreatFocus st)+ KChar 'n' -> eventLoop (advanceFocus st)+ KChar 'l' -> refresh (view clientVty st) >> eventLoop st+ _ -> eventLoop st++ [MMeta] ->+ case key of+ KChar 'b' -> changeInput Edit.leftWord+ KChar 'f' -> changeInput Edit.rightWord+ KChar 'a' -> eventLoop (jumpToActivity st)+ KChar c | Just i <- elemIndex c windowNames ->+ eventLoop (jumpFocus i st)+ _ -> eventLoop st++ [] -> -- no modifier+ case key of+ KBS -> changeInput Edit.backspace+ KDel -> changeInput Edit.delete+ KLeft -> changeInput Edit.left+ KRight -> changeInput Edit.right+ KHome -> changeInput Edit.home+ KEnd -> changeInput Edit.end+ KUp -> changeInput $ \ed -> fromMaybe ed $ Edit.earlier ed+ KDown -> changeInput $ \ed -> fromMaybe ed $ Edit.later ed+ KEnter -> execute st+ KPageUp -> eventLoop (pageUp st)+ KPageDown -> eventLoop (pageDown st)+ KBackTab -> tabCompletion True st+ KChar '\t' -> tabCompletion False st+ KChar c -> changeInput (Edit.insert c)+ KFun 2 -> eventLoop (over clientDetailView not st)+ _ -> eventLoop st++ _ -> eventLoop st -- unsupported modifier++-- | Scroll the current buffer to show older messages+pageUp :: ClientState -> ClientState+pageUp st = over clientScroll (+ scrollAmount st) st++-- | Scroll the current buffer to show newer messages+pageDown :: ClientState -> ClientState+pageDown st = over clientScroll (max 0 . subtract (scrollAmount st)) st++-- | Compute the number of lines in a page at the current window size+scrollAmount :: ClientState -> Int+scrollAmount st = max 1 (view clientHeight st - 2)++-- | Jump the focus of the client to a buffer that has unread activity.+-- Some events like errors or chat messages mentioning keywords are+-- considered important and will be jumped to first.+jumpToActivity :: ClientState -> ClientState+jumpToActivity st =+ case mplus highPriority lowPriority of+ Just (focus,_) -> changeFocus focus st+ Nothing -> st+ where+ windowList = views clientWindows Map.toList st+ highPriority = find (view winMention . snd) windowList+ lowPriority = find (\x -> view winUnread (snd x) > 0) windowList++-- | Jump the focus directly to a window based on its zero-based index.+jumpFocus ::+ Int {- ^ zero-based window index -} ->+ ClientState -> ClientState+jumpFocus i st+ | 0 <= i, i < Map.size windows = changeFocus focus st+ | otherwise = st+ where+ windows = view clientWindows st+ (focus,_) = Map.elemAt i windows++-- | Respond to the TAB key being pressed. This can dispatch to a command+-- specific completion mode when relevant. Otherwise this will complete+-- input based on the users of the channel related to the current buffer.+tabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO ()+tabCompletion isReversed st =+ case clientInput st of+ '/':command -> do res <- executeCommand (Just isReversed) command st+ case res of+ CommandQuit -> return ()+ CommandContinue st' -> eventLoop st'+ _ -> eventLoop (nickTabCompletion isReversed st)++-- | Interpret whatever text is in the textbox. Leading @/@ indicates a+-- command. Otherwise if a channel or user query is focused a chat message+-- will be sent.+execute :: ClientState -> IO ()+execute st =+ case clientInput st of+ [] -> eventLoop st+ '/':command -> do res <- executeCommand Nothing command st+ case res of+ CommandQuit -> return ()+ CommandContinue st' -> eventLoop st'+ msg -> executeChat msg st++-- | Treat the current text input as a chat message and send it.+executeChat :: String -> ClientState -> IO ()+executeChat msg st =+ case view clientFocus st of+ ChannelFocus network channel+ | Just cs <- preview (clientConnection network) st ->+ do now <- getZonedTime+ let msgTxt = Text.pack msg+ ircMsg = rawIrcMsg "PRIVMSG" [idText channel, msgTxt]+ myNick = UserInfo (view csNick cs) Nothing Nothing+ entry = ClientMessage+ { _msgTime = now+ , _msgNetwork = network+ , _msgBody = IrcBody (Privmsg myNick channel msgTxt)+ }+ sendMsg cs ircMsg+ eventLoop $ recordChannelMessage network channel entry+ $ consumeInput st++ _ -> eventLoop st++-- | Respond to a timer event.+doTimerEvent ::+ NetworkId {- ^ Network related to event -} ->+ TimedAction {- ^ Action to perform -} ->+ ClientState -> IO ()+doTimerEvent networkId action st =+ do st' <- forOf (clientConnections . ix networkId) st $ \cs ->+ case action of+ TimedDisconnect ->+ do abortConnection (view csSocket cs)+ return $! set csNextPingTime Nothing cs++ TimedSendPing ->+ do now <- getCurrentTime+ let cs' = set csNextPingTime (Just $! addUTCTime 60 now)+ $ set csPingStatus (PingSent now) cs+ sendMsg cs' (rawIrcMsg "PING" ["ping"])+ return cs'+ eventLoop st'
+ src/Client/IdentifierColors.hs view
@@ -0,0 +1,39 @@+{-|+Module : Client.IdentifierColors+Description : Mapping from identifiers to console colors+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides the color mapping for nick highlighting.++-}++module Client.IdentifierColors (identifierColor) where++import Graphics.Vty.Image+import Irc.Identifier+import Data.Array+import qualified Data.ByteString as B++-- | Compute a color from the denotation of an identifier.+-- This color will be consistent for different capitalizations+-- and will be consistent across program executions.+identifierColor :: Identifier -> Color+identifierColor ident = nickColorPalette ! i+ where+ hash = hashIdentity ident+ (0,hi) = bounds nickColorPalette+ n = hi+1+ i = hash`mod`n++hashIdentity :: Identifier -> Int+hashIdentity ident =+ let h1 = B.foldl' (\acc b -> fromIntegral b + 33 * acc) 0 (idDenote ident)+ in h1 + (h1 `quot` 32)++nickColorPalette :: Array Int Color+nickColorPalette = listArray (0, length xs - 1) xs+ where+ xs = [cyan, magenta, green, yellow, blue,+ brightCyan, brightMagenta, brightGreen, brightBlue]
+ src/Client/Image.hs view
@@ -0,0 +1,288 @@+{-# Language BangPatterns #-}+{-|+Module : Client.Image+Description : UI renderer+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides the renderer for the client's UI.++-}+module Client.Image (clientPicture) where++import Client.ChannelState+import Client.ConnectionState+import qualified Client.EditBox as Edit+import Client.Image.MaskList+import Client.Image.Message+import Client.Image.UserList+import Client.Message+import Client.MircFormatting+import Client.State+import Client.Window+import Control.Lens+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as Text+import Graphics.Vty (Picture(..), Cursor(..), picForImage)+import Graphics.Vty.Image+import Irc.Identifier (Identifier, idText)+import Numeric++-- | Generate a 'Picture' for the current client state. The resulting+-- client state is updated for render specific information like scrolling.+clientPicture :: ClientState -> (Picture, ClientState)+clientPicture st = (pic, st')+ where+ (img, st') = clientImage st+ pic0 = picForImage img+ pic = pic0 { picCursor = cursor }+ cursor = Cursor (min (view clientWidth st - 1)+ (view (clientTextBox . Edit.pos) st+1))+ (view clientHeight st - 1)++clientImage :: ClientState -> (Image, ClientState)+clientImage st = (img, st')+ where+ (mp, st') = messagePane st+ img = vertCat+ [ mp+ , horizDividerImage st'+ , textboxImage st'+ ]++messagePaneImages :: ClientState -> [Image]+messagePaneImages !st =+ case (view clientFocus st, view clientSubfocus st) of+ (ChannelFocus network channel, FocusUsers)+ | view clientDetailView st -> userInfoImages network channel st+ | otherwise -> userListImages network channel st+ (ChannelFocus network channel, FocusMasks mode) ->+ maskListImages mode network channel st++ -- subfocuses only make sense for channels+ _ -> chatMessageImages st++chatMessageImages :: ClientState -> [Image]+chatMessageImages st = windowLineProcessor focusedMessages+ where+ matcher = clientMatcher st++ focusedMessages+ = filter (views wlText matcher)+ $ view (clientWindows . ix (view clientFocus st) . winMessages) st++ windowLineProcessor+ | view clientDetailView st = map (view wlFullImage)+ | otherwise = windowLinesToImages st . filter (not . isNoisy)++ isNoisy msg =+ case view wlBody msg of+ IrcBody irc -> squelchIrcMsg irc+ _ -> False++messagePane :: ClientState -> (Image, ClientState)+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++ overscroll = vh - imageHeight vimg++ st' = over clientScroll (max 0 . subtract overscroll) st++ assemble acc _ | imageHeight acc >= vh = cropTop vh acc+ assemble acc [] = acc+ 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++windowLinesToImages :: ClientState -> [WindowLine] -> [Image]+windowLinesToImages st wwls =+ case wwls of+ [] -> []+ wl:wls+ | Just (img,ident) <- metadataWindowLine st wl -> windowLinesToImagesMd st img ident wls+ | otherwise -> view wlImage wl : windowLinesToImages st wls++windowLinesToImagesMd :: ClientState -> Image -> Maybe Identifier -> [WindowLine] -> [Image]+windowLinesToImagesMd st acc who wwls =+ case wwls of+ wl:wls+ | Just (img,ident) <- metadataWindowLine st wl ->+ if isJust ident && who == ident+ then windowLinesToImagesMd st (acc <|> img) who wls+ else windowLinesToImagesMd st (finish <|> char defAttr ' ' <|> img) ident wls+ _ -> finish : windowLinesToImages st wwls+ where+ finish = acc <|> maybe emptyImage quietIdentifier who+++metadataWindowLine :: ClientState -> WindowLine -> Maybe (Image, Maybe Identifier)+metadataWindowLine st wl =+ case view wlBody wl of+ IrcBody irc+ | Just who <- ircIgnorable irc st -> Just (ignoreImage, Just who)+ | otherwise -> metadataImg irc+ _ -> Nothing++lineWrap :: Int -> Image -> Image+lineWrap w img+ | imageWidth img > w = cropRight w img <-> lineWrap w (cropLeft (imageWidth img - w) img)+ | otherwise = img+++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+ , 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 (withForeColor defAttr red) "scroll"+ , string defAttr ")"+ ]++activityImage :: ClientState -> Image+activityImage st+ | null indicators = emptyImage+ | otherwise = string defAttr "─[" <|>+ horizCat indicators <|>+ string defAttr "]"+ where+ windows = views clientWindows Map.elems st+ winNames = windowNames ++ repeat '?'+ indicators = aux (zip winNames windows)+ aux [] = []+ aux ((i,w):ws)+ | view winUnread w == 0 = aux ws+ | otherwise = char (withForeColor defAttr color) i : aux ws+ where+ color | view winMention w = red+ | otherwise = green+++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+ nickPart network mbChan =+ case preview (clientConnection network) st of+ Nothing -> emptyImage+ Just cs -> string (withForeColor defAttr cyan) 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 (withForeColor defAttr cyan) windowName+ , char defAttr ':'+ , renderedFocus+ ]++ focus = view clientFocus st+ windowName =+ case Map.lookupIndex focus (view clientWindows st) of+ Nothing -> '?'+ Just i -> (windowNames ++ repeat '?') !! i++ subfocusName =+ case view clientSubfocus st of+ FocusMessages -> Nothing+ FocusUsers -> Just $ string (withForeColor defAttr green) "users"+ FocusMasks m -> Just $ horizCat+ [ string (withForeColor defAttr green) "masks"+ , char defAttr ':'+ , char (withForeColor defAttr green) m+ ]++ renderedSubfocus =+ foldMap (\name -> horizCat+ [ string defAttr "─("+ , name+ , char defAttr ')'+ ]) subfocusName++ renderedFocus =+ case focus of+ Unfocused ->+ char (withForeColor defAttr red) '*'+ NetworkFocus network ->+ text' (withForeColor defAttr green) network+ ChannelFocus network channel ->+ text' (withForeColor defAttr green) network <|>+ char defAttr ':' <|>+ text' (withForeColor defAttr green) (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++textboxImage :: ClientState -> Image+textboxImage st+ = applyCrop+ $ beginning <|> content <|> ending+ where+ pos = view (clientTextBox . Edit.pos) st+ width = view clientWidth st+ content = parseIrcTextExplicit (Text.pack (view (clientTextBox . Edit.content) st))+ applyCrop+ | 1+pos < width = cropRight width+ | otherwise = cropLeft width . cropRight (pos+2)++ beginning = char (withForeColor defAttr brightBlack) '^'+ ending = char (withForeColor defAttr brightBlack) '$'++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 (withForeColor defAttr yellow) (showFFloat (Just 2) delta "s")+ , string defAttr ")"+ ]+ | otherwise = emptyImage
+ src/Client/Image/MaskList.hs view
@@ -0,0 +1,64 @@+{-|+Module : Client.Image.MaskList+Description : Line renderers for channel mask list view+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module renders the lines used in the channel mask list. A mask list+can show channel bans, quiets, invites, and exceptions.+-}+module Client.Image.MaskList+ ( maskListImages+ ) where++import Client.ChannelState+import Client.ConnectionState+import Client.State+import Control.Lens+import qualified Data.HashMap.Strict as HashMap+import Data.List+import Data.Ord+import Data.Time+import Graphics.Vty.Image+import Irc.Identifier++-- | Render the lines used in a channel mask list+maskListImages ::+ Char {- ^ Mask mode -} ->+ NetworkName {- ^ Focused network -} ->+ Identifier {- ^ Focused channel -} ->+ ClientState -> [Image]+maskListImages mode network channel st+ | null entryList = [string (withForeColor defAttr red) "No masks"]+ | otherwise = images+ where+ matcher = clientMatcher st++ matcher' (x,(y,_)) = matcher x || matcher y++ entryList = sortBy (flip (comparing (snd . snd)))+ $ filter matcher'+ $ HashMap.toList entries++ entries = view ( clientConnection network+ . csChannels . ix channel+ . chanList mode+ ) st++ renderWhen = formatTime defaultTimeLocale " %F %T"++ (masks, whoWhens) = unzip entryList+ maskImages = text' defAttr <$> masks+ maskColumnWidth = maximum (imageWidth <$> maskImages) + 1+ paddedMaskImages = resizeWidth maskColumnWidth <$> maskImages+ width = max 1 (view clientWidth st)++ images = [ cropLine $ mask <|>+ text' defAttr who <|>+ string defAttr (renderWhen when)+ | (mask, (who, when)) <- zip paddedMaskImages whoWhens ]++ cropLine img+ | imageWidth img > width = cropRight width img+ | otherwise = img
+ src/Client/Image/Message.hs view
@@ -0,0 +1,299 @@+{-|+Module : Client.Image.Message+Description : Renderer for message lines+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides image renderers for messages.++-}+module Client.Image.Message+ ( MessageRendererParams(..)+ , RenderMode(..)+ , defaultRenderParams+ , msgImage+ , detailedMsgImage+ , metadataImg+ , ignoreImage+ , quietIdentifier+ , coloredUserInfo+ , coloredIdentifier+ ) where++import Client.IdentifierColors+import Client.Message+import Client.MircFormatting+import Control.Lens+import Data.Time+import Graphics.Vty.Image+import Irc.Identifier+import Irc.Message+import Irc.RawIrcMsg+import Irc.UserInfo+import qualified Data.HashSet as HashSet+import Data.List+import qualified Data.Text as Text+import Data.Text (Text)+import Data.Char++-- | Parameters used when rendering messages+data MessageRendererParams = MessageRendererParams+ { rendStatusMsg :: [Char] -- ^ restricted message sigils+ , rendUserSigils :: [Char] -- ^ sender sigils+ , rendNicks :: [Identifier] -- ^ nicknames to highlight+ }++-- | Default 'MessageRenderParams' with no sigils or nicknames specified+defaultRenderParams :: MessageRendererParams+defaultRenderParams = MessageRendererParams+ { rendStatusMsg = ""+ , rendUserSigils = ""+ , rendNicks = []+ }++-- | Construct a message given the time the message was received and its+-- render parameters.+msgImage ::+ ZonedTime {- ^ time of message -} ->+ MessageRendererParams -> MessageBody -> Image+msgImage when params body = horizCat+ [ timeImage when+ , statusMsgImage (rendStatusMsg params)+ , bodyImage NormalRender (rendUserSigils params) (rendNicks params) body+ ]++-- | Construct a message given the time the message was received and its+-- render parameters using a detailed view.+detailedMsgImage :: ZonedTime -> MessageRendererParams -> MessageBody -> Image+detailedMsgImage when params body = horizCat+ [ datetimeImage when+ , statusMsgImage (rendStatusMsg params)+ , bodyImage DetailedRender (rendUserSigils params) (rendNicks params) body+ ]++-- | Render the sigils for a restricted message.+statusMsgImage :: [Char] {- ^ sigils -} -> Image+statusMsgImage modes+ | null modes = emptyImage+ | otherwise = string defAttr "(" <|>+ string statusMsgColor modes <|>+ string defAttr ") "+ where+ statusMsgColor = withForeColor defAttr red++-- | Render a 'MessageBody' given the sender's sigils and the nicknames to+-- highlight.+bodyImage ::+ RenderMode ->+ [Char] {- ^ sigils -} ->+ [Identifier] {- ^ nicknames to highlight -} ->+ MessageBody -> Image+bodyImage rm modes nicks body =+ case body of+ IrcBody irc -> ircLineImage rm modes nicks irc+ ErrorBody ex -> string defAttr ("Exception: " ++ show ex)+ ExitBody -> string defAttr "Thread finished"++-- | Render a 'ZonedTime' as time using quiet attributes+--+-- @+-- 23:15+-- @+timeImage :: ZonedTime -> Image+timeImage+ = string (withForeColor defAttr brightBlack)+ . formatTime defaultTimeLocale "%R "++-- | Render a 'ZonedTime' as full date and time user quiet attributes+--+-- @+-- 2016-07-24 23:15:10+-- @+datetimeImage :: ZonedTime -> Image+datetimeImage+ = string (withForeColor defAttr brightBlack)+ . formatTime defaultTimeLocale "%F %T "++-- | Level of detail to use when rendering+data RenderMode+ = NormalRender -- ^ only render nicknames+ | DetailedRender -- ^ render full user info++-- | The attribute to be used for "quiet" content+quietAttr :: Attr+quietAttr = withForeColor defAttr brightBlack++-- | Render a chat message given a rendering mode, the sigils of the user+-- who sent the message, and a list of nicknames to highlight.+ircLineImage ::+ RenderMode ->+ [Char] {- ^ sigils (e.g. \@+) -} ->+ [Identifier] {- ^ nicknames to highlight -} ->+ IrcMsg -> Image+ircLineImage rm sigils nicks body =+ let detail img =+ case rm of+ NormalRender -> emptyImage+ DetailedRender -> img+ in+ case body of+ Nick old new ->+ detail (string quietAttr "nick ") <|>+ string (withForeColor defAttr cyan) sigils <|>+ coloredUserInfo rm old <|>+ string defAttr " became " <|>+ coloredIdentifier new++ Join nick _chan ->+ string quietAttr "join " <|>+ coloredUserInfo rm nick++ Part nick _chan mbreason ->+ string quietAttr "part " <|>+ coloredUserInfo rm nick <|>+ foldMap (\reason -> string quietAttr " (" <|>+ parseIrcText reason <|>+ string quietAttr ")") mbreason++ Quit nick mbreason ->+ string quietAttr "quit " <|>+ coloredUserInfo rm nick <|>+ foldMap (\reason -> string quietAttr " (" <|>+ parseIrcText reason <|>+ string quietAttr ")") mbreason++ Kick kicker _channel kickee reason ->+ detail (string quietAttr "kick ") <|>+ string (withForeColor defAttr cyan) sigils <|>+ coloredUserInfo rm kicker <|>+ string defAttr " kicked " <|>+ coloredIdentifier kickee <|>+ string defAttr ": " <|>+ parseIrcText reason++ Topic src _dst txt ->+ coloredUserInfo rm src <|>+ string defAttr " changed topic to " <|>+ parseIrcText txt++ Notice src _dst txt ->+ detail (string quietAttr "note ") <|>+ string (withForeColor defAttr cyan) sigils <|>+ coloredUserInfo rm src <|>+ string (withForeColor defAttr red) ": " <|>+ parseIrcTextWithNicks nicks txt++ Privmsg src _dst txt ->+ detail (string quietAttr "chat ") <|>+ string (withForeColor defAttr cyan) sigils <|>+ coloredUserInfo rm src <|>+ string defAttr ": " <|>+ parseIrcTextWithNicks nicks txt++ Action src _dst txt ->+ detail (string quietAttr "chat ") <|>+ string (withForeColor defAttr blue) "* " <|>+ string (withForeColor defAttr cyan) sigils <|>+ coloredUserInfo rm src <|>+ string defAttr " " <|>+ parseIrcTextWithNicks nicks txt++ Ping params ->+ string defAttr "PING" <|>+ horizCat [char (withForeColor defAttr blue) '·' <|>+ parseIrcText p | p <- params]++ Pong params ->+ string defAttr "PONG" <|>+ horizCat [char (withForeColor defAttr blue) '·' <|>+ parseIrcText p | p <- params]++ Error reason ->+ string (withForeColor defAttr red) "ERROR " <|>+ parseIrcText reason++ Reply code params ->+ string defAttr (show code) <|>+ horizCat [char (withForeColor defAttr blue) '·' <|>+ parseIrcText p | p <- params]++ UnknownMsg irc ->+ maybe emptyImage (\ui -> coloredUserInfo rm ui <|> char defAttr ' ')+ (view msgPrefix irc) <|>+ text' defAttr (view msgCommand irc) <|>+ horizCat [char (withForeColor defAttr blue) '·' <|>+ parseIrcText p | p <- view msgParams irc]++ Cap cmd args ->+ string defAttr (show cmd) <|>+ horizCat [char (withForeColor defAttr blue) '·' <|>+ text' defAttr a | a <- args]++ Mode nick _chan params ->+ detail (string quietAttr "mode ") <|>+ string (withForeColor defAttr cyan) sigils <|>+ coloredUserInfo rm nick <|>+ string defAttr " set mode: " <|>+ horizCat (intersperse (char (withForeColor defAttr blue) '·')+ (text' defAttr <$> params))++-- | Render a nickname in its hash-based color.+coloredIdentifier :: Identifier -> Image+coloredIdentifier ident =+ text' (withForeColor defAttr (identifierColor ident)) (idText ident)++-- | Render an a full user. In normal mode only the nickname will be rendered.+-- If detailed mode the full user info including the username and hostname parts+-- will be rendered. The nickname will be colored.+coloredUserInfo :: RenderMode -> UserInfo -> Image+coloredUserInfo NormalRender ui = coloredIdentifier (userNick ui)+coloredUserInfo DetailedRender ui = horizCat+ [ coloredIdentifier (userNick ui)+ , foldMap (\user -> char defAttr '!' <|> text' quietAttr user) (userName ui)+ , foldMap (\host -> char defAttr '@' <|> text' quietAttr host) (userHost ui)+ ]++-- | Render an identifier without using colors. This is useful for metadata.+quietIdentifier :: Identifier -> Image+quietIdentifier ident =+ text' (withForeColor defAttr brightBlack) (idText ident)++-- | Parse message text to construct an image. If the text has formatting+-- control characters in it then the text will be rendered according to+-- the formatting codes. Otherwise the nicknames in the message are+-- highlighted.+parseIrcTextWithNicks :: [Identifier] -> Text -> Image+parseIrcTextWithNicks nicks txt+ | Text.any isControl txt = parseIrcText txt+ | otherwise = highlightNicks nicks txt++-- | Given a list of nicknames and a chat message, this will generate+-- an image where all of the occurrences of those nicknames are colored.+highlightNicks :: [Identifier] -> Text -> Image+highlightNicks nicks txt = horizCat (highlight1 <$> txtParts)+ where+ nickSet = HashSet.fromList nicks+ txtParts = nickSplit txt+ highlight1 part+ | HashSet.member partId nickSet = coloredIdentifier partId+ | otherwise = text' defAttr part+ where+ partId = mkId part++-- | Returns image and identifier to be used when collapsing metadata+-- messages.+metadataImg :: IrcMsg -> Maybe (Image, Maybe Identifier)+metadataImg msg =+ case msg of+ Quit who _ -> Just (char (withForeColor defAttr red ) 'x', Just (userNick who))+ Part who _ _ -> Just (char (withForeColor defAttr red ) '-', Just (userNick who))+ Join who _ -> Just (char (withForeColor defAttr green) '+', Just (userNick who))+ Nick old new -> Just (quietIdentifier (userNick old) <|>+ char (withForeColor defAttr yellow) '-' <|>+ quietIdentifier new, Nothing)+ _ -> Nothing++-- | Image used when treating ignored chat messages as metadata+ignoreImage :: Image+ignoreImage = char (withForeColor defAttr yellow) 'I'
+ src/Client/Image/UserList.hs view
@@ -0,0 +1,82 @@+{-|+Module : Client.Image.UserList+Description : Line renderers for channel user list view+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module renders the lines used in the channel user list.+-}+module Client.Image.UserList where++import Client.ChannelState+import Client.ConnectionState+import Client.Image.Message+import Client.State+import Control.Lens+import qualified Data.HashMap.Strict as HashMap+import Data.List+import Data.Ord+import qualified Data.Text as Text+import Graphics.Vty.Image+import Irc.Identifier+import Irc.UserInfo++-- | Render the lines used in a simple user list window.+userListImages ::+ NetworkName {- ^ Focused network name -} ->+ Identifier {- ^ Focused channel name -} ->+ ClientState -> [Image]+userListImages network channel st =+ [horizCat (intersperse gap (map renderUser usersList))]+ where+ matcher = clientMatcher st++ renderUser (ident, sigils) =+ string (withForeColor defAttr cyan) sigils <|>+ coloredIdentifier ident++ gap = char defAttr ' '++ matcher' (ident,sigils) = matcher (Text.pack sigils `Text.append` idText ident)++ usersList = sortBy (comparing fst)+ $ filter matcher'+ $ HashMap.toList usersHashMap++ usersHashMap =+ view ( clientConnection network+ . csChannels . ix channel+ . chanUsers ) st++-- | Render lines for detailed channel user list which shows full user info.+userInfoImages ::+ NetworkName {- ^ Focused network name -} ->+ Identifier {- ^ Focused channel name -} ->+ ClientState -> [Image]+userInfoImages network channel st = renderEntry <$> usersList+ where+ matcher = clientMatcher st++ renderEntry (info, sigils) =+ string (withForeColor defAttr cyan) sigils <|>+ coloredUserInfo DetailedRender info++ matcher' (info,sigils) =+ matcher (Text.pack sigils `Text.append` renderUserInfo info)++ userInfos = view (clientConnection network . csUsers) st++ toInfo nick =+ case view (at nick . non (Nothing,Nothing)) userInfos of+ (n,h) -> UserInfo nick n h++ usersList = sortBy (flip (comparing (userNick . fst)))+ $ filter matcher'+ $ map (over _1 toInfo)+ $ HashMap.toList usersHashMap++ usersHashMap =+ view ( clientConnection network+ . csChannels . ix channel+ . chanUsers ) st
+ src/Client/Message.hs view
@@ -0,0 +1,53 @@+{-# Language TemplateHaskell #-}+{-|+Module : Client.Message+Description : Messages to be added to buffers+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides the type used to track messages just before they+are added to a window.++-}+module Client.Message+ (+ -- * Client message type+ ClientMessage(..)+ , msgNetwork+ , msgBody+ , msgTime++ -- * Message body type+ , MessageBody(..)+ , _IrcBody+ , _ErrorBody+ , _ExitBody++ -- * Client message operations+ , msgText+ ) where++import Control.Lens+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (ZonedTime)+import Irc.Message++data MessageBody = IrcBody !IrcMsg | ErrorBody !String | ExitBody++makePrisms ''MessageBody++data ClientMessage = ClientMessage+ { _msgNetwork :: !Text+ , _msgBody :: !MessageBody+ , _msgTime :: !ZonedTime+ }++makeLenses ''ClientMessage++-- | Compute a searchable text representation of the message+msgText :: MessageBody -> Text+msgText (IrcBody irc) = ircMsgText irc+msgText (ErrorBody str) = Text.pack str+msgText ExitBody = Text.empty
+ src/Client/MircFormatting.hs view
@@ -0,0 +1,150 @@+{-# Language TemplateHaskell #-}++{-|+Module : Client.MircFormatting+Description : Parser for mIRC's text formatting encoding+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module parses mIRC encoded text and generates VTY images.++-}+module Client.MircFormatting+ ( parseIrcText+ , parseIrcTextExplicit+ ) where++import Graphics.Vty hiding ((<|>))+import qualified Graphics.Vty as Vty+import Data.Attoparsec.Text as Parse+import Data.Char+import Data.Text (Text)+import Control.Applicative ((<|>))+import Control.Lens++data FormatState = FormatState+ { _fmtFore :: Maybe Color+ , _fmtBack :: Maybe Color+ , _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse :: !Bool+ }++makeLenses '' FormatState++formatAttr :: FormatState -> Attr+formatAttr fmt+ = doStyle (view fmtBold fmt) bold+ $ doStyle (view fmtUnderline fmt) underline+ $ doStyle (view fmtReverse fmt) reverseVideo+ $ doColor withForeColor (view fmtFore fmt)+ $ doColor withBackColor (view fmtBack fmt)+ $ defAttr++ where+ doStyle False _ attr = attr+ doStyle True style attr = withStyle attr style++ doColor _ Nothing attr = attr+ doColor with (Just x) attr = with attr x++defaultFormatState :: FormatState+defaultFormatState = FormatState Nothing Nothing False False False False++-- | Parse mIRC encoded format characters and hide the control characters.+parseIrcText :: Text -> Image+parseIrcText = parseIrcText' False++-- | Parse mIRC encoded format characters and render the control characters+-- explicitly. This view is useful when inputting control characters to make+-- it clear where they are in the text.+parseIrcTextExplicit :: Text -> Image+parseIrcTextExplicit = parseIrcText' True++parseIrcText' :: Bool -> Text -> Image+parseIrcText' explicit = either (Vty.string defAttr) id+ . parseOnly (pIrcLine explicit defaultFormatState)++data Segment = TextSegment Text | ControlSegment Char++pSegment :: Parser Segment+pSegment = TextSegment <$> takeWhile1 (not . isControl)+ <|> ControlSegment <$> satisfy isControl++pIrcLine :: Bool -> FormatState -> Parser Image+pIrcLine explicit fmt =+ do seg <- option Nothing (Just <$> pSegment)+ case seg of+ Nothing -> return emptyImage+ Just (TextSegment txt) ->+ do rest <- pIrcLine explicit fmt+ return (text' (formatAttr fmt) txt Vty.<|> rest)+ Just (ControlSegment '\^C') ->+ do (numberText, colorNumbers) <- match pColorNumbers+ rest <- pIrcLine explicit (applyColors colorNumbers fmt)+ return $ if explicit+ then Vty.char controlAttr 'C'+ Vty.<|> text' defAttr numberText+ Vty.<|> rest+ else rest+ Just (ControlSegment c)+ | explicit -> do rest <- next+ return (Vty.char controlAttr (controlName c) Vty.<|> rest)+ | otherwise -> next+ where+ next = pIrcLine explicit $ applyControlEffect c fmt++pColorNumbers :: Parser (Maybe Int, Maybe Int)+pColorNumbers = option (Nothing,Nothing) $+ do n <- pNumber+ m <- optional (Parse.char ',' *> pNumber)+ return (Just n,m)++ where+ pNumber = do d1 <- digit+ ds <- option [] (return <$> digit)+ return $! read (d1:ds)++optional :: Parser a -> Parser (Maybe a)+optional p = option Nothing (Just <$> p)++applyColors :: (Maybe Int, Maybe Int) -> FormatState -> FormatState+applyColors (fore, back) = aux fmtFore fore . aux fmtBack back+ where+ aux _ Nothing = id+ aux l (Just x) = set l (mircColor x)++mircColor :: Int -> Maybe Color+mircColor 0 = Just (white ) -- white+mircColor 1 = Just (black ) -- black+mircColor 2 = Just (blue ) -- blue+mircColor 3 = Just (green ) -- green+mircColor 4 = Just (red ) -- red+mircColor 5 = Just (rgbColor' 127 0 0 ) -- brown+mircColor 6 = Just (rgbColor' 156 0 156 ) -- purple+mircColor 7 = Just (rgbColor' 252 127 0 ) -- yellow+mircColor 8 = Just (yellow ) -- yellow+mircColor 9 = Just (brightGreen ) -- green+mircColor 10 = Just (cyan ) -- brightBlue+mircColor 11 = Just (brightCyan ) -- brightCyan+mircColor 12 = Just (brightBlue ) -- brightBlue+mircColor 13 = Just (rgbColor' 255 0 255 ) -- brightRed+mircColor 14 = Just (rgbColor' 127 127 127) -- brightBlack+mircColor 15 = Just (rgbColor' 210 210 210) -- brightWhite+mircColor _ = Nothing++rgbColor' :: Int -> Int -> Int -> Color+rgbColor' = rgbColor -- fix the type to Int++applyControlEffect :: Char -> FormatState -> FormatState+applyControlEffect '\^B' = over fmtBold not+applyControlEffect '\^O' = const defaultFormatState+applyControlEffect '\^V' = over fmtReverse not+applyControlEffect '\^]' = over fmtItalic not+applyControlEffect '\^_' = over fmtUnderline not+applyControlEffect _ = id++controlAttr :: Attr+controlAttr = defAttr `withStyle` reverseVideo++controlName :: Char -> Char+controlName c = chr (ord '@' + ord c)
+ src/Client/NetworkConnection.hs view
@@ -0,0 +1,156 @@+{-# Options_GHC -Wno-unused-do-bind #-}++{-|+Module : Client.NetworkConnection+Description : Event-based network IO+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module creates network connections and thread to manage those connections.+Events on these connections will be written to a given event queue, and+outgoing messages are recieved on an incoming event queue.++These network connections are rate limited for outgoing messages per the+rate limiting algorithm given in the IRC RFC.++Incoming network event messages are assumed to be framed by newlines.++When a network connection terminates normally its final messages will be+'NetworkClose'. When it terminates abnormally its final message will be+'NetworkError'.++-}++module Client.NetworkConnection+ ( NetworkConnection+ , NetworkId+ , NetworkEvent(..)+ , createConnection+ , abortConnection+ , send+ ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.Async+import Control.Exception+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Time+import Network.Connection++import Irc.RateLimit+import Client.Connect+import Client.ServerSettings++-- | Identifier used to match connection events to connections.+type NetworkId = Int++-- | Handle for a network connection+data NetworkConnection = NetworkConnection+ { connOutQueue :: !(TQueue ByteString)+ , connAsync :: !(Async ())+ }++-- | The sum of incoming events from a network connection. All events+-- are annotated with a network ID matching that given when the connection+-- was created as well as the time at which the message was recieved.+data NetworkEvent+ = NetworkLine !NetworkId !ZonedTime !ByteString+ -- ^ Event for a new recieved line (newline removed)+ | NetworkError !NetworkId !ZonedTime !SomeException+ -- ^ Final message indicating the network connection failed+ | NetworkClose !NetworkId !ZonedTime+ -- ^ Final message indicating the network connection finished++instance Show NetworkConnection where+ showsPrec p _ = showParen (p > 10)+ $ showString "NetworkConnection _"++-- | Schedule a message to be transmitted on the network connection.+-- These messages are sent unmodified. The message should contain a+-- newline terminator.+send :: NetworkConnection -> ByteString -> IO ()+send c msg = atomically (writeTQueue (connOutQueue c) msg)++-- | Force the given connection to terminate.+abortConnection :: NetworkConnection -> IO ()+abortConnection = cancel . connAsync++-- | Initiate a new network connection according to the given 'ServerSettings'.+-- All events on this connection will be added to the given queue. The resulting+-- 'NetworkConnection' value can be used for sending outgoing messages and for+-- early termination of the connection.+createConnection ::+ NetworkId {- ^ Identifier to be used on incoming events -} ->+ ConnectionContext ->+ ServerSettings ->+ TQueue NetworkEvent {- Queue for incoming events -} ->+ IO NetworkConnection+createConnection network cxt settings inQueue =+ do outQueue <- atomically newTQueue++ supervisor <- async (startConnection network cxt settings inQueue outQueue)++ -- Having this reporting thread separate from the supervisor ensures+ -- that canceling the supervisor with abortConnection doesn't interfere+ -- with carefully reporting the outcome+ forkIO $ do outcome <- waitCatch supervisor+ case outcome of+ Right{} -> recordNormalExit+ Left e -> recordFailure e++ return NetworkConnection+ { connOutQueue = outQueue+ , connAsync = supervisor+ }+ where+ recordFailure :: SomeException -> IO ()+ recordFailure ex =+ do now <- getZonedTime+ atomically (writeTQueue inQueue (NetworkError network now ex))++ recordNormalExit :: IO ()+ recordNormalExit =+ do now <- getZonedTime+ atomically (writeTQueue inQueue (NetworkClose network now))+++startConnection ::+ NetworkId ->+ ConnectionContext ->+ ServerSettings ->+ TQueue NetworkEvent ->+ TQueue ByteString ->+ IO ()+startConnection network cxt settings onInput outQueue =+ do rate <- newRateLimitDefault+ withConnection cxt settings $ \h ->+ withAsync (sendLoop h outQueue rate) $ \sender ->+ withAsync (receiveLoop network h onInput) $ \receiver ->+ do res <- waitEitherCatch sender receiver+ case res of+ Left Right{} -> fail "PANIC: sendLoop returned"+ Right Right{} -> return ()+ Left (Left e) -> throwIO e+ Right (Left e) -> throwIO e++sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO ()+sendLoop h outQueue rate =+ forever $+ do msg <- atomically (readTQueue outQueue)+ tickRateLimit rate+ connectionPut h msg++ircMaxMessageLength :: Int+ircMaxMessageLength = 512++receiveLoop :: NetworkId -> Connection -> TQueue NetworkEvent -> IO ()+receiveLoop network h inQueue =+ do msg <- connectionGetLine ircMaxMessageLength h+ unless (B.null msg) $+ do now <- getZonedTime+ atomically (writeTQueue inQueue (NetworkLine network now (B.init msg)))+ receiveLoop network h inQueue
+ src/Client/ServerSettings.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell #-}++{-|+Module : Client.ServerSettings+Description : Settings for an individual IRC connection+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module defines the settings used for an individual IRC connection.+These are static settings that are not expected change over the lifetime+of a connection.+-}++module Client.ServerSettings+ (+ -- * Server settings type+ ServerSettings(..)+ , ssNick+ , ssUser+ , ssReal+ , ssUserInfo+ , ssPassword+ , ssSaslUsername+ , ssSaslPassword+ , ssHostName+ , ssPort+ , ssTls+ , ssTlsInsecure+ , ssTlsClientCert+ , ssTlsClientKey+ , ssConnectCmds+ , ssSocksHost+ , ssSocksPort+ , ssServerCerts+ , ssChanservChannels++ -- * Load function+ , loadDefaultServerSettings++ ) where++import Control.Lens+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Irc.Identifier (Identifier)+import System.Environment+import qualified Data.Text as Text++import Network.Socket (HostName, PortNumber)++data ServerSettings = ServerSettings+ { _ssNick :: !Text -- ^ connection nickname+ , _ssUser :: !Text -- ^ connection username+ , _ssReal :: !Text -- ^ connection realname / GECOS+ , _ssUserInfo :: !Text -- ^ CTCP userinfo+ , _ssPassword :: !(Maybe Text) -- ^ server password+ , _ssSaslUsername :: !(Maybe Text) -- ^ SASL username+ , _ssSaslPassword :: !(Maybe Text) -- ^ SASL password+ , _ssHostName :: !HostName -- ^ server hostname+ , _ssPort :: !(Maybe PortNumber) -- ^ server port+ , _ssTls :: !Bool -- ^ use TLS to connect+ , _ssTlsInsecure :: !Bool -- ^ disable certificate checking+ , _ssTlsClientCert :: !(Maybe FilePath) -- ^ path to client TLS certificate+ , _ssTlsClientKey :: !(Maybe FilePath) -- ^ path to client TLS key+ , _ssConnectCmds :: ![Text] -- ^ raw IRC messages to transmit upon successful connection+ , _ssSocksHost :: !(Maybe HostName) -- ^ hostname of SOCKS proxy+ , _ssSocksPort :: !PortNumber -- ^ port of SOCKS proxy+ , _ssServerCerts :: ![FilePath] -- ^ additional CA certificates for validating server+ , _ssChanservChannels :: ![Identifier] -- ^ Channels with chanserv permissions+ }+ deriving Show++makeLenses ''ServerSettings++-- | Load the defaults for server settings based on the environment+-- variables.+--+-- @USER@, @IRCPASSSWORD@, and @SASLPASSWORD@ are used.+loadDefaultServerSettings :: IO ServerSettings+loadDefaultServerSettings =+ do env <- getEnvironment+ let username = Text.pack (fromMaybe "guest" (lookup "USER" env))+ return ServerSettings+ { _ssNick = username+ , _ssUser = username+ , _ssReal = username+ , _ssUserInfo = username+ , _ssPassword = Text.pack <$> lookup "IRCPASSWORD" env+ , _ssSaslUsername = Nothing+ , _ssSaslPassword = Text.pack <$> lookup "SASLPASSWORD" env+ , _ssHostName = ""+ , _ssPort = Nothing+ , _ssTls = False+ , _ssTlsInsecure = False+ , _ssTlsClientCert = Nothing+ , _ssTlsClientKey = Nothing+ , _ssConnectCmds = []+ , _ssSocksHost = Nothing+ , _ssSocksPort = 1080+ , _ssServerCerts = []+ , _ssChanservChannels = []+ }
+ src/Client/State.hs view
@@ -0,0 +1,429 @@+{-# Language TemplateHaskell, BangPatterns #-}+{-|+Module : Client.State+Description : Primary client state type and update operations+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides the core logic of the IRC client. The client+state tracks everything about the client.++-}+module Client.State+ (+ -- * Client state type+ NetworkName+ , ClientState(..)+ , clientWindows+ , clientTextBox+ , clientConnections+ , clientWidth+ , clientHeight+ , clientEvents+ , clientVty+ , clientFocus+ , clientConnectionContext+ , clientConfig+ , clientScroll+ , clientDetailView+ , clientSubfocus+ , clientNextConnectionId+ , clientNetworkMap+ , clientIgnores+ , clientConnection+ , initialClientState++ -- * Client operations+ , clientMatcher+ , consumeInput+ , currentUserList+ , ircIgnorable+ , clientInput+ , abortNetwork+ , addConnection+ , removeNetwork+ , clientTick++ -- * Add messages to buffers+ , recordChannelMessage+ , recordNetworkMessage+ , recordIrcMessage++ -- * Focus information+ , ClientFocus(..)+ , ClientSubfocus(..)+ , focusNetwork+ , changeFocus+ , changeSubfocus+ , advanceFocus+ , retreatFocus+ , windowNames++ ) where++import Client.ChannelState+import Client.Configuration+import Client.ConnectionState+import Client.Image.Message+import Client.Message+import Client.NetworkConnection+import Client.ServerSettings+import Client.Window+import Control.Concurrent.STM+import Control.Lens+import Data.Foldable+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Maybe+import Data.Map (Map)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.ICU as ICU+import Data.Time+import Graphics.Vty+import Irc.Identifier+import Irc.Message+import Irc.UserInfo+import Irc.Codes+import LensUtils+import Network.Connection+import qualified Client.EditBox as Edit+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.Map as Map++type NetworkName = Text++data ClientFocus+ = Unfocused+ | NetworkFocus !NetworkName+ | ChannelFocus !NetworkName !Identifier+ deriving Eq++data ClientSubfocus+ = FocusMessages+ | FocusUsers+ | FocusMasks !Char+ deriving Eq++-- | Unfocused first, followed by focuses sorted by network.+-- Within the same network the network focus comes first and+-- then the channels are ordered by channel identifier+instance Ord ClientFocus where+ compare Unfocused Unfocused = EQ+ compare (NetworkFocus x) (NetworkFocus y ) = compare x y+ compare (ChannelFocus x1 x2) (ChannelFocus y1 y2) = compare x1 y1 <> compare x2 y2++ compare Unfocused _ = LT+ compare _ Unfocused = GT++ compare (NetworkFocus x ) (ChannelFocus y _) = compare x y <> LT+ compare (ChannelFocus x _) (NetworkFocus y ) = compare x y <> GT++-- | All state information for the IRC client+data ClientState = ClientState+ { _clientWindows :: !(Map ClientFocus Window) -- ^ client message buffers+ , _clientFocus :: !ClientFocus -- ^ currently focused buffer+ , _clientSubfocus :: !ClientSubfocus -- ^ sec++ , _clientConnections :: !(IntMap ConnectionState) -- ^ state of active connections+ , _clientNextConnectionId :: !Int+ , _clientConnectionContext :: !ConnectionContext -- ^ network connection context+ , _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue+ , _clientNetworkMap :: !(HashMap NetworkName NetworkId)+ -- ^ network name to connection ID++ , _clientVty :: !Vty -- ^ VTY handle+ , _clientTextBox :: !Edit.EditBox -- ^ primary text box+ , _clientWidth :: !Int -- ^ current terminal width+ , _clientHeight :: !Int -- ^ current terminal height+ , _clientConfig :: !Configuration -- ^ client configuration+ , _clientScroll :: !Int -- ^ buffer scroll lines+ , _clientDetailView :: !Bool -- ^ use detailed rendering mode++ , _clientIgnores :: !(HashSet Identifier) -- ^ ignored nicknames+ }++makeLenses ''ClientState++clientConnection :: Applicative f => NetworkName -> LensLike' f ClientState ConnectionState+clientConnection network f st =+ case view (clientNetworkMap . at network) st of+ Nothing -> pure st+ Just i -> clientConnections (ix i f) st++clientInput :: ClientState -> String+clientInput = view (clientTextBox . Edit.content)++focusNetwork :: ClientFocus -> Maybe NetworkName+focusNetwork Unfocused = Nothing+focusNetwork (NetworkFocus network) = Just network+focusNetwork (ChannelFocus network _) = Just network++initialClientState :: Configuration -> Vty -> IO ClientState+initialClientState cfg vty =+ do (width,height) <- displayBounds (outputIface vty)+ cxt <- initConnectionContext+ events <- atomically newTQueue+ return ClientState+ { _clientWindows = _Empty # ()+ , _clientTextBox = Edit.empty+ , _clientConnections = IntMap.empty+ , _clientWidth = width+ , _clientHeight = height+ , _clientVty = vty+ , _clientEvents = events+ , _clientFocus = Unfocused+ , _clientConnectionContext = cxt+ , _clientConfig = cfg+ , _clientScroll = 0+ , _clientDetailView = False+ , _clientSubfocus = FocusMessages+ , _clientNextConnectionId = 0+ , _clientNetworkMap = HashMap.empty+ , _clientIgnores = HashSet.empty+ }++abortNetwork :: NetworkName -> ClientState -> IO ClientState+abortNetwork network st =+ case preview (clientConnection network) st of+ Nothing -> return st+ Just cs -> do abortConnection (view csSocket cs)+ return $ set (clientNetworkMap . at network) Nothing st++recordChannelMessage :: NetworkName -> Identifier -> ClientMessage -> ClientState -> ClientState+recordChannelMessage network channel msg st =+ over (clientWindows . at focus) (\w -> Just $! addToWindow importance wl (fromMaybe emptyWindow w)) st+ where+ focus = ChannelFocus network channel'+ wl = toWindowLine rendParams msg+ rendParams = MessageRendererParams+ { rendStatusMsg = statusModes+ , rendUserSigils = computeMsgLineModes network channel' msg st+ , rendNicks = channelUserList network channel' st+ }++ -- on failure returns mempty/""+ possibleStatusModes = view (clientConnection network . csStatusMsg) st+ (statusModes, channel') = splitStatusMsgModes possibleStatusModes channel+ importance = msgImportance msg st++msgImportance :: ClientMessage -> ClientState -> WindowLineImportance+msgImportance msg st =+ let network = view msgNetwork msg+ me = preview (clientConnection network . csNick) st+ isMe x = Just x == me+ checkTxt txt = case me of+ Just me' | me' `elem` (mkId <$> nickSplit txt) -> WLImportant+ _ -> WLNormal+ in+ case view msgBody msg of+ ExitBody -> WLImportant+ ErrorBody _ -> WLImportant+ IrcBody irc+ | squelchIrcMsg irc -> WLBoring+ | isJust (ircIgnorable irc st) -> WLBoring+ | otherwise ->+ case irc of+ Privmsg _ tgt txt+ | isMe tgt -> WLImportant+ | otherwise -> checkTxt txt+ Notice _ tgt txt+ | isMe tgt -> WLImportant+ | otherwise -> checkTxt txt+ Action _ _ txt -> checkTxt txt+ Part who _ _ | isMe (userNick who) -> WLImportant+ | otherwise -> WLBoring+ Kick _ _ kicked _ | isMe kicked -> WLImportant+ | otherwise -> WLNormal+ Error{} -> WLImportant+ Reply cmd _ ->+ case replyType cmd of+ ErrorReply -> WLImportant+ _ -> WLNormal+ _ -> WLBoring+++-- | Predicate for messages that should be ignored based on the+-- configurable ignore list+ircIgnorable :: IrcMsg -> ClientState -> Maybe Identifier+ircIgnorable msg st =+ case msg of+ Privmsg who _ _ -> checkUser who+ Notice who _ _ -> checkUser who+ _ -> Nothing+ where+ ignores = view clientIgnores st+ checkUser !who+ | HashSet.member (userNick who) ignores = Just (userNick who)+ | otherwise = Nothing+++recordIrcMessage :: NetworkName -> MessageTarget -> ClientMessage -> ClientState -> ClientState+recordIrcMessage network target msg st =+ case target of+ TargetHidden -> st+ TargetNetwork -> recordNetworkMessage msg st+ TargetWindow chan -> recordChannelMessage network chan msg st+ TargetUser user -> foldl' (\st' chan -> overStrict+ (clientWindows . ix (ChannelFocus network chan))+ (addToWindow WLBoring wl) st')+ st chans+ where+ wl = toWindowLine' msg+ chans =+ case preview (clientConnection network . csChannels) st of+ Nothing -> []+ Just m -> [chan | (chan, cs) <- HashMap.toList m, HashMap.member user (view chanUsers cs) ]++splitStatusMsgModes :: [Char] -> Identifier -> ([Char], Identifier)+splitStatusMsgModes possible ident = (Text.unpack modes, mkId ident')+ where+ (modes, ident') = Text.span (`elem` possible) (idText ident)++computeMsgLineModes :: NetworkName -> Identifier -> ClientMessage -> ClientState -> [Char]+computeMsgLineModes network channel msg st =+ case msgActor =<< preview (msgBody . _IrcBody) msg of+ Just user -> computeLineModes network channel (userNick user) st+ Nothing -> []++computeLineModes :: NetworkName -> Identifier -> Identifier -> ClientState -> [Char]+computeLineModes network channel user =+ view $ clientConnection network+ . csChannels . ix channel+ . chanUsers . ix user++recordNetworkMessage :: ClientMessage -> ClientState -> ClientState+recordNetworkMessage msg st =+ over (clientWindows . at (NetworkFocus network))+ (\w -> Just $! addToWindow (msgImportance msg st) wl (fromMaybe emptyWindow w))+ st+ where+ network = view msgNetwork msg+ wl = toWindowLine' msg++toWindowLine :: MessageRendererParams -> ClientMessage -> WindowLine+toWindowLine params msg = WindowLine+ { _wlBody = view msgBody msg+ , _wlText = views msgBody msgText msg+ , _wlImage = msgImage (view msgTime msg) params (view msgBody msg)+ , _wlFullImage = detailedMsgImage (view msgTime msg) params (view msgBody msg)+ }++toWindowLine' :: ClientMessage -> WindowLine+toWindowLine' = toWindowLine defaultRenderParams++clientTick :: ClientState -> IO ClientState+clientTick st =+ return $! over (clientWindows . ix (view clientFocus st)) windowSeen st++consumeInput :: ClientState -> ClientState+consumeInput = over clientTextBox Edit.success++advanceFocus :: ClientState -> ClientState+advanceFocus st+ | view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st+ | otherwise =+ case Map.split oldFocus windows of+ (l,r)+ | Just ((k,_),_) <- Map.minViewWithKey r -> success k+ | Just ((k,_),_) <- Map.minViewWithKey l -> success k+ | otherwise -> st+ where+ success x = set clientScroll 0+ $ set clientFocus x st+ oldFocus = view clientFocus st+ windows = view clientWindows st++retreatFocus :: ClientState -> ClientState+retreatFocus st+ | view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st+ | otherwise =+ case Map.split oldFocus windows of+ (l,r)+ | Just ((k,_),_) <- Map.maxViewWithKey l -> success k+ | Just ((k,_),_) <- Map.maxViewWithKey r -> success k+ | otherwise -> st+ where+ success x = set clientScroll 0+ $ set clientFocus x st+ oldFocus = view clientFocus st+ windows = view clientWindows st++currentUserList :: ClientState -> [Identifier]+currentUserList st =+ case view clientFocus st of+ ChannelFocus network chan -> channelUserList network chan st+ _ -> []++channelUserList :: NetworkName -> Identifier -> ClientState -> [Identifier]+channelUserList network channel =+ views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys++changeFocus :: ClientFocus -> ClientState -> ClientState+changeFocus focus+ = set clientScroll 0+ . set clientFocus focus+ . set clientSubfocus FocusMessages++changeSubfocus :: ClientSubfocus -> ClientState -> ClientState+changeSubfocus focus+ = set clientScroll 0+ . set clientSubfocus focus++windowNames :: [Char]+windowNames = "1234567890qwertyuiop"++clientMatcher :: ClientState -> Text -> Bool+clientMatcher st =+ case break (==' ') (clientInput st) of+ ("/grep" ,_:reStr) -> go [] reStr+ ("/grepi",_:reStr) -> go [ICU.CaseInsensitive] reStr+ _ -> const True+ where+ go opts reStr+ | not (null reStr)+ , Right r <- ICU.regex' opts (Text.pack reStr) = isJust . ICU.find r+ | otherwise = const True++-- | Remove a network connection and unlink it from the network map.+-- This operation assumes that the networkconnection exists and should+-- only be applied once per connection.+removeNetwork :: NetworkId -> ClientState -> (ConnectionState, ClientState)+removeNetwork networkId st =+ case (clientConnections . at networkId <<.~ Nothing) st of+ (Nothing, _ ) -> error "removeNetwork: network not found"+ (Just cs, st1) ->+ -- Only remove the network mapping if it hasn't already been replace+ -- with a new one. This can happen during reconnect in particular.+ let network = view csNetwork cs in+ case view (clientNetworkMap . at network) st of+ Just i | i == networkId ->+ (cs, set (clientNetworkMap . at network) Nothing st1)+ _ -> (cs,st1)++addConnection :: Text -> ClientState -> IO ClientState+addConnection network st =+ do let host = Text.unpack network+ defSettings = (view (clientConfig . configDefaults) st)+ { _ssHostName = host }+ settings = fromMaybe defSettings+ (view (clientConfig . configServers . at host) st)++ let (i,st') = st & clientNextConnectionId <+~ 1+ c <- createConnection+ i+ (view clientConnectionContext st')+ settings+ (view clientEvents st')++ let cs = newConnectionState i network settings c+ traverse_ (sendMsg cs) (initialMessages cs)++ return $ set (clientNetworkMap . at network) (Just i)+ $ set (clientConnections . at i) (Just cs) st'+
+ src/Client/Window.hs view
@@ -0,0 +1,89 @@+{-# Language 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 :: !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/WordCompletion.hs view
@@ -0,0 +1,100 @@+{-|+Module : Client.WordCompletion+Description : Tab-completion logic+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides the tab-completion logic used for nicknames and channels.++-}+module Client.WordCompletion+ ( wordComplete+ ) where++import Irc.Identifier+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.ByteString as B+import qualified Data.Set as Set+import Data.Char+import Data.Function+import Data.List+import Control.Lens+import Client.EditBox as Edit+import Control.Monad++-- | Perform word completion on a text box.+--+-- The leading update operation is applied to the result of tab-completion+-- when tab completing from the beginning of the text box. This is useful+-- when auto-completing a nick and including a trailing colon.+--+-- The @reversed@ parameter indicates that tab-completion should return the+-- previous entry.+wordComplete ::+ (String -> String) {- ^ leading update operation -} ->+ Bool {- ^ reversed -} ->+ [Identifier] {- ^ possible completions -} ->+ Edit.EditBox -> Maybe Edit.EditBox+wordComplete leadingCase isReversed vals box =+ do let current = currentWord box+ guard (not (null current))+ let cur = mkId (Text.pack current)+ case view Edit.tabSeed box of+ Just patternStr+ | idPrefix pat cur ->++ do next <- tabSearch isReversed pat cur vals+ Just $ replaceWith leadingCase (idString next) box+ where+ pat = mkId (Text.pack patternStr)++ _ ->+ do next <- tabSearch isReversed cur cur vals+ Just $ set tabSeed (Just current)+ $ replaceWith leadingCase (idString next) box++replaceWith :: (String -> String) -> String -> Edit.EditBox -> Edit.EditBox+replaceWith leadingCase str box =+ let box1 = Edit.killWord False box+ str1 | view Edit.pos box1 == 0 = leadingCase str+ | otherwise = str+ in Edit.insertString str1 box1++idPrefix :: Identifier -> Identifier -> Bool+idPrefix = B.isPrefixOf `on` idDenote++idString :: Identifier -> String+idString = Text.unpack . idText++currentWord :: Edit.EditBox -> String+currentWord box+ = reverse+ $ takeWhile (not . isSpace)+ $ dropWhile (\x -> x==' ' || x==':')+ $ reverse+ $ take (view Edit.pos box) (view Edit.content box)++class Prefix a where isPrefix :: a -> a -> Bool+instance Prefix Identifier where isPrefix = idPrefix+instance Prefix Text where isPrefix = Text.isPrefixOf+instance Eq a => Prefix [a] where isPrefix = isPrefixOf++tabSearch :: (Ord a, Prefix a) => Bool -> a -> a -> [a] -> Maybe a+tabSearch isReversed pat cur vals+ | Just next <- advanceFun cur valSet+ , isPrefix pat next+ = Just next++ | isReversed = find (isPrefix pat) (reverse (Set.toList valSet))++ | otherwise = do x <- Set.lookupGE pat valSet+ guard (isPrefix pat x)+ Just x+ where+ valSet = Set.fromList vals++ advanceFun | isReversed = Set.lookupLT+ | otherwise = Set.lookupGT+
+ src/Config/FromConfig.hs view
@@ -0,0 +1,148 @@+{-# Language GeneralizedNewtypeDeriving #-}+{-# Language OverloadedStrings #-}++{-|+Module : Config.FromConfig+Description : Parser for unstructure configuration file format+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides tools for producing structured configuration+information out of configuration values.++-}+module Config.FromConfig+ ( -- * Configuration parsing+ ConfigParser+ , decodeConfig+ , runConfigParser+ , failure+ , FromConfig(parseConfig)++ -- * Section parsing+ , SectionParser+ , parseSections+ , sectionReq+ , sectionOpt+ , sectionOptWith+ , liftConfigParser+ ) where++import Config+import Control.Lens hiding (List)+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as Text++-- | Configuration parser tracking current location and for propagating+-- error information.+newtype ConfigParser a = ConfigParser (ReaderT [Text] (Either Text) a)+ deriving (Functor, Applicative, Monad)++-- | Run a top-level parser to either get the parsed value or an error message.+runConfigParser :: ConfigParser a -> Either Text a+runConfigParser (ConfigParser p) = runReaderT p []++-- | A parser that always fails with the given error message.+failure :: Text {- ^ error message -} -> ConfigParser a+failure msg = ConfigParser $+ do loc <- ask+ let msg' = Text.concat [Text.intercalate "." (reverse loc), ": ", msg]+ lift (Left msg')++-- | Embed a parser into an extended location. This is used when+-- parsing inside a section.+extendLoc :: Text -> ConfigParser a -> ConfigParser a+extendLoc loc (ConfigParser p) = ConfigParser (local (loc:) p)++------------------------------------------------------------------------++-- | Parse a 'Value' according to the method in the 'FromConfig'+decodeConfig :: FromConfig a => Value -> Either Text a+decodeConfig = runConfigParser . parseConfig++-- | Class for types that have a well-known way to parse them.+class FromConfig a where+ -- | Parse a value+ parseConfig :: Value -> ConfigParser a++-- | Matches 'Text' values.+instance FromConfig Text where+ parseConfig (Text x) = return x+ parseConfig _ = failure "expected text"++-- | Matches 'Number' values ignoring the base+instance FromConfig Integer where+ parseConfig (Number _ n) = return n+ parseConfig _ = failure "expected number"++-- | Matches 'Atom' values+instance FromConfig Atom where+ parseConfig (Atom a) = return a+ parseConfig _ = failure "expected atom"++-- | Matches 'List' values, extends the error location with a zero-based+-- index+instance FromConfig a => FromConfig [a] where+ parseConfig (List xs) = ifor xs $ \i x ->+ extendLoc (Text.pack (show (i+1)))+ (parseConfig x)+ parseConfig _ = failure "expected list"++------------------------------------------------------------------------++-- | Parser for consuming key-value pairs of sections.+newtype SectionParser a =+ SectionParser (StateT (HashMap Text Value) ConfigParser a)+ deriving (Functor, Applicative, Monad)++-- | Lift a 'ConfigParser' into a 'SectionParser' leaving the current+-- section information unmodified.+liftConfigParser :: ConfigParser a -> SectionParser a+liftConfigParser = SectionParser . lift++-- | Run a 'SectionParser' given particular 'Value'. This will only+-- succeed when the value is a 'Sections' and the section parser consumes all+-- of the sections from that value.+parseSections :: SectionParser a -> Value -> ConfigParser a+parseSections (SectionParser p) (Sections xs) =+ do (res, xs') <- runStateT p (toHashMap xs)+ let unused = HashMap.keys xs'+ unless (null unused)+ (failure ("unknown keys: " <> Text.intercalate ", " unused))+ return res+parseSections _ _ = failure "expected sections"++-- |+-- @+-- sectionOpt = sectionOptWith parseConfig+-- @+sectionOpt :: FromConfig a => Text -> SectionParser (Maybe a)+sectionOpt = sectionOptWith parseConfig++-- | Parses the value stored at the given section with the given parser.+-- Nothing is returned if the section is missing.+-- Just is returned if the parse succeeds+-- Error is raised if the section is present but the parse fails+sectionOptWith :: (Value -> ConfigParser a) -> Text -> SectionParser (Maybe a)+sectionOptWith p key = SectionParser $+ do mb <- at key <<.= Nothing+ lift (traverse (extendLoc key . p) mb)++-- | Parse the value at the given section or fail.+sectionReq :: FromConfig a => Text -> SectionParser a+sectionReq key =+ do mb <- sectionOpt key+ liftConfigParser $ case mb of+ Nothing -> failure ("section required: " <> key)+ Just x -> return x++toHashMap :: [Section] -> HashMap Text Value+toHashMap xs = HashMap.fromList [ (k,v) | Section k v <- xs ] -- todo: handle duplicate sections
+ src/Irc/Codes.hs view
@@ -0,0 +1,1337 @@+{-# Language PatternSynonyms #-}++{-|+Module : Irc.Codes+Description : Helpers for interpreting IRC reply codes+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module defines support for working with IRC's numeric reply+codes. Pattern synonyms are provided for each of the possible IRC reply codes.++Reply code information was extracted from https://www.alien.net.au/irc/irc2numerics.html++-}++module Irc.Codes where++-- | Categories for reply codes+data ReplyType+ = ClientServerReply -- ^ 0-99 Messages between client and server+ | CommandReply -- ^ 200-399 Responses to commands+ | ErrorReply -- ^ 200-399 Errors+ | CustomReply -- ^ Uncategorized++-- | Categorize replies according to the ranges provided in RFC 2812+replyType :: Int {- reply code -} -> ReplyType+replyType x+ | 000 <= x, x < 100 = ClientServerReply+ | 200 <= x, x < 400 = CommandReply+ | 400 <= x, x < 600 = ErrorReply+ | otherwise = CustomReply++pattern RPL_WELCOME :: Int+pattern RPL_WELCOME = 001++pattern RPL_YOURHOST :: Int+pattern RPL_YOURHOST = 002++pattern RPL_CREATED :: Int+pattern RPL_CREATED = 003++pattern RPL_MYINFO :: Int+pattern RPL_MYINFO = 004++pattern RPL_ISUPPORT :: Int+pattern RPL_ISUPPORT = 005++pattern RPL_SNOMASK :: Int+pattern RPL_SNOMASK = 008++pattern RPL_STATMEMTOT :: Int+pattern RPL_STATMEMTOT = 009++pattern RPL_BOUNCE :: Int+pattern RPL_BOUNCE = 010++pattern RPL_STATMEM :: Int+pattern RPL_STATMEM = 010++pattern RPL_YOURCOOKIE :: Int+pattern RPL_YOURCOOKIE = 014++pattern RPL_YOURID :: Int+pattern RPL_YOURID = 042++pattern RPL_SAVENICK :: Int+pattern RPL_SAVENICK = 043++pattern RPL_ATTEMPTINGJUNC :: Int+pattern RPL_ATTEMPTINGJUNC = 050++pattern RPL_ATTEMPTINGREROUTE :: Int+pattern RPL_ATTEMPTINGREROUTE = 051++pattern RPL_TRACELINK :: Int+pattern RPL_TRACELINK = 200++pattern RPL_TRACECONNECTING :: Int+pattern RPL_TRACECONNECTING = 201++pattern RPL_TRACEHANDSHAKE :: Int+pattern RPL_TRACEHANDSHAKE = 202++pattern RPL_TRACEUNKNOWN :: Int+pattern RPL_TRACEUNKNOWN = 203++pattern RPL_TRACEOPERATOR :: Int+pattern RPL_TRACEOPERATOR = 204++pattern RPL_TRACEUSER :: Int+pattern RPL_TRACEUSER = 205++pattern RPL_TRACESERVER :: Int+pattern RPL_TRACESERVER = 206++pattern RPL_TRACESERVICE :: Int+pattern RPL_TRACESERVICE = 207++pattern RPL_TRACENEWTYPE :: Int+pattern RPL_TRACENEWTYPE = 208++pattern RPL_TRACECLASS :: Int+pattern RPL_TRACECLASS = 209++pattern RPL_TRACERECONNECT :: Int+pattern RPL_TRACERECONNECT = 210++pattern RPL_STATS :: Int+pattern RPL_STATS = 210++pattern RPL_STATSLINKINFO :: Int+pattern RPL_STATSLINKINFO = 211++pattern RPL_STATSCOMMANDS :: Int+pattern RPL_STATSCOMMANDS = 212++pattern RPL_STATSCLINE :: Int+pattern RPL_STATSCLINE = 213++pattern RPL_STATSILINE :: Int+pattern RPL_STATSILINE = 215++pattern RPL_STATSKLINE :: Int+pattern RPL_STATSKLINE = 216++pattern RPL_STATSYLINE :: Int+pattern RPL_STATSYLINE = 218++pattern RPL_ENDOFSTATS :: Int+pattern RPL_ENDOFSTATS = 219++pattern RPL_UMODEIS :: Int+pattern RPL_UMODEIS = 221++pattern RPL_SQLINE_NICK :: Int+pattern RPL_SQLINE_NICK = 222++pattern RPL_STATSDLINE :: Int+pattern RPL_STATSDLINE = 225++pattern RPL_STATSZLINE :: Int+pattern RPL_STATSZLINE = 225++pattern RPL_STATSCOUNT :: Int+pattern RPL_STATSCOUNT = 226++pattern RPL_SERVICEINFO :: Int+pattern RPL_SERVICEINFO = 231++pattern RPL_ENDOFSERVICES :: Int+pattern RPL_ENDOFSERVICES = 232++pattern RPL_SERVICE :: Int+pattern RPL_SERVICE = 233++pattern RPL_SERVLIST :: Int+pattern RPL_SERVLIST = 234++pattern RPL_SERVLISTEND :: Int+pattern RPL_SERVLISTEND = 235++pattern RPL_STATSVERBOSE :: Int+pattern RPL_STATSVERBOSE = 236++pattern RPL_STATSIAUTH :: Int+pattern RPL_STATSIAUTH = 239++pattern RPL_STATSLLINE :: Int+pattern RPL_STATSLLINE = 241++pattern RPL_STATSUPTIME :: Int+pattern RPL_STATSUPTIME = 242++pattern RPL_STATSOLINE :: Int+pattern RPL_STATSOLINE = 243++pattern RPL_STATSHLINE :: Int+pattern RPL_STATSHLINE = 244++pattern RPL_STATSSLINE :: Int+pattern RPL_STATSSLINE = 245++pattern RPL_STATSPING :: Int+pattern RPL_STATSPING = 246++pattern RPL_STATSDEFINE :: Int+pattern RPL_STATSDEFINE = 248++pattern RPL_STATSDEBUG :: Int+pattern RPL_STATSDEBUG = 249++pattern RPL_STATSCONN :: Int+pattern RPL_STATSCONN = 250++pattern RPL_LUSERCLIENT :: Int+pattern RPL_LUSERCLIENT = 251++pattern RPL_LUSEROP :: Int+pattern RPL_LUSEROP = 252++pattern RPL_LUSERUNKNOWN :: Int+pattern RPL_LUSERUNKNOWN = 253++pattern RPL_LUSERCHANNELS :: Int+pattern RPL_LUSERCHANNELS = 254++pattern RPL_LUSERME :: Int+pattern RPL_LUSERME = 255++pattern RPL_ADMINME :: Int+pattern RPL_ADMINME = 256++pattern RPL_ADMINLOC1 :: Int+pattern RPL_ADMINLOC1 = 257++pattern RPL_ADMINLOC2 :: Int+pattern RPL_ADMINLOC2 = 258++pattern RPL_ADMINEMAIL :: Int+pattern RPL_ADMINEMAIL = 259++pattern RPL_TRACELOG :: Int+pattern RPL_TRACELOG = 261++pattern RPL_TRACEPING :: Int+pattern RPL_TRACEPING = 262++pattern RPL_TRACEEND :: Int+pattern RPL_TRACEEND = 262++pattern RPL_TRYAGAIN :: Int+pattern RPL_TRYAGAIN = 263++pattern RPL_LOCALUSERS :: Int+pattern RPL_LOCALUSERS = 265++pattern RPL_GLOBALUSERS :: Int+pattern RPL_GLOBALUSERS = 266++pattern RPL_START_NETSTAT :: Int+pattern RPL_START_NETSTAT = 267++pattern RPL_NETSTAT :: Int+pattern RPL_NETSTAT = 268++pattern RPL_END_NETSTAT :: Int+pattern RPL_END_NETSTAT = 269++pattern RPL_PRIVS :: Int+pattern RPL_PRIVS = 270++pattern RPL_SILELIST :: Int+pattern RPL_SILELIST = 271++pattern RPL_ENDOFSILELIST :: Int+pattern RPL_ENDOFSILELIST = 272++pattern RPL_NOTIFY :: Int+pattern RPL_NOTIFY = 273++pattern RPL_ENDNOTIFY :: Int+pattern RPL_ENDNOTIFY = 274++pattern RPL_STATSDELTA :: Int+pattern RPL_STATSDELTA = 274++pattern RPL_VCHANEXIST :: Int+pattern RPL_VCHANEXIST = 276++pattern RPL_VCHANLIST :: Int+pattern RPL_VCHANLIST = 277++pattern RPL_VCHANHELP :: Int+pattern RPL_VCHANHELP = 278++pattern RPL_GLIST :: Int+pattern RPL_GLIST = 280++pattern RPL_ENDOFGLIST :: Int+pattern RPL_ENDOFGLIST = 281++pattern RPL_ACCEPTLIST :: Int+pattern RPL_ACCEPTLIST = 281++pattern RPL_ENDOFACCEPT :: Int+pattern RPL_ENDOFACCEPT = 282++pattern RPL_JUPELIST :: Int+pattern RPL_JUPELIST = 282++pattern RPL_ENDOFJUPELIST :: Int+pattern RPL_ENDOFJUPELIST = 283++pattern RPL_FEATURE :: Int+pattern RPL_FEATURE = 284++pattern RPL_GLIST_HASH :: Int+pattern RPL_GLIST_HASH = 285++pattern RPL_CHANINFO_HANDLE :: Int+pattern RPL_CHANINFO_HANDLE = 285++pattern RPL_NEWHOSTIS :: Int+pattern RPL_NEWHOSTIS = 285++pattern RPL_CHANINFO_USERS :: Int+pattern RPL_CHANINFO_USERS = 286++pattern RPL_CHKHEAD :: Int+pattern RPL_CHKHEAD = 286++pattern RPL_CHANINFO_CHOPS :: Int+pattern RPL_CHANINFO_CHOPS = 287++pattern RPL_CHANUSER :: Int+pattern RPL_CHANUSER = 287++pattern RPL_CHANINFO_VOICES :: Int+pattern RPL_CHANINFO_VOICES = 288++pattern RPL_PATCHHEAD :: Int+pattern RPL_PATCHHEAD = 288++pattern RPL_CHANINFO_AWAY :: Int+pattern RPL_CHANINFO_AWAY = 289++pattern RPL_PATCHCON :: Int+pattern RPL_PATCHCON = 289++pattern RPL_CHANINFO_OPERS :: Int+pattern RPL_CHANINFO_OPERS = 290++pattern RPL_HELPHDR :: Int+pattern RPL_HELPHDR = 290++pattern RPL_DATASTR :: Int+pattern RPL_DATASTR = 290++pattern RPL_CHANINFO_BANNED :: Int+pattern RPL_CHANINFO_BANNED = 291++pattern RPL_HELPOP :: Int+pattern RPL_HELPOP = 291++pattern RPL_ENDOFCHECK :: Int+pattern RPL_ENDOFCHECK = 291++pattern RPL_CHANINFO_BANS :: Int+pattern RPL_CHANINFO_BANS = 292++pattern RPL_HELPTLR :: Int+pattern RPL_HELPTLR = 292++pattern RPL_CHANINFO_INVITE :: Int+pattern RPL_CHANINFO_INVITE = 293++pattern RPL_HELPHLP :: Int+pattern RPL_HELPHLP = 293++pattern RPL_CHANINFO_INVITES :: Int+pattern RPL_CHANINFO_INVITES = 294++pattern RPL_HELPFWD :: Int+pattern RPL_HELPFWD = 294++pattern RPL_CHANINFO_KICK :: Int+pattern RPL_CHANINFO_KICK = 295++pattern RPL_HELPIGN :: Int+pattern RPL_HELPIGN = 295++pattern RPL_CHANINFO_KICKS :: Int+pattern RPL_CHANINFO_KICKS = 296++pattern RPL_END_CHANINFO :: Int+pattern RPL_END_CHANINFO = 299++pattern RPL_NONE :: Int+pattern RPL_NONE = 300++pattern RPL_AWAY :: Int+pattern RPL_AWAY = 301++pattern RPL_USERHOST :: Int+pattern RPL_USERHOST = 302++pattern RPL_ISON :: Int+pattern RPL_ISON = 303++pattern RPL_TEXT :: Int+pattern RPL_TEXT = 304++pattern RPL_UNAWAY :: Int+pattern RPL_UNAWAY = 305++pattern RPL_NOWAWAY :: Int+pattern RPL_NOWAWAY = 306++pattern RPL_WHOISREGNICK :: Int+pattern RPL_WHOISREGNICK = 307++pattern RPL_SUSERHOST :: Int+pattern RPL_SUSERHOST = 307++pattern RPL_NOTIFYACTION :: Int+pattern RPL_NOTIFYACTION = 308++pattern RPL_WHOISADMIN :: Int+pattern RPL_WHOISADMIN = 308++pattern RPL_NICKTRACE :: Int+pattern RPL_NICKTRACE = 309++pattern RPL_WHOISSADMIN :: Int+pattern RPL_WHOISSADMIN = 309++pattern RPL_WHOISHELPER :: Int+pattern RPL_WHOISHELPER = 309++pattern RPL_WHOISSVCMSG :: Int+pattern RPL_WHOISSVCMSG = 310++pattern RPL_WHOISHELPOP :: Int+pattern RPL_WHOISHELPOP = 310++pattern RPL_WHOISSERVICE :: Int+pattern RPL_WHOISSERVICE = 310++pattern RPL_WHOISUSER :: Int+pattern RPL_WHOISUSER = 311++pattern RPL_WHOISSERVER :: Int+pattern RPL_WHOISSERVER = 312++pattern RPL_WHOISOPERATOR :: Int+pattern RPL_WHOISOPERATOR = 313++pattern RPL_WHOWASUSER :: Int+pattern RPL_WHOWASUSER = 314++pattern RPL_ENDOFWHO :: Int+pattern RPL_ENDOFWHO = 315++pattern RPL_WHOISCHANOP :: Int+pattern RPL_WHOISCHANOP = 316++pattern RPL_WHOISIDLE :: Int+pattern RPL_WHOISIDLE = 317++pattern RPL_ENDOFWHOIS :: Int+pattern RPL_ENDOFWHOIS = 318++pattern RPL_WHOISCHANNELS :: Int+pattern RPL_WHOISCHANNELS = 319++pattern RPL_WHOISVIRT :: Int+pattern RPL_WHOISVIRT = 320++pattern RPL_WHOIS_HIDDEN :: Int+pattern RPL_WHOIS_HIDDEN = 320++pattern RPL_WHOISSPECIAL :: Int+pattern RPL_WHOISSPECIAL = 320++pattern RPL_LISTSTART :: Int+pattern RPL_LISTSTART = 321++pattern RPL_LIST :: Int+pattern RPL_LIST = 322++pattern RPL_LISTEND :: Int+pattern RPL_LISTEND = 323++pattern RPL_CHANNELMODEIS :: Int+pattern RPL_CHANNELMODEIS = 324++pattern RPL_UNIQOPIS :: Int+pattern RPL_UNIQOPIS = 325++pattern RPL_CHANNELPASSIS :: Int+pattern RPL_CHANNELPASSIS = 325++pattern RPL_NOCHANPASS :: Int+pattern RPL_NOCHANPASS = 326++pattern RPL_CHPASSUNKNOWN :: Int+pattern RPL_CHPASSUNKNOWN = 327++pattern RPL_CHANNEL_URL :: Int+pattern RPL_CHANNEL_URL = 328++pattern RPL_CREATIONTIME :: Int+pattern RPL_CREATIONTIME = 329++pattern RPL_WHOWAS_TIME :: Int+pattern RPL_WHOWAS_TIME = 330++pattern RPL_WHOISACCOUNT :: Int+pattern RPL_WHOISACCOUNT = 330++pattern RPL_NOTOPIC :: Int+pattern RPL_NOTOPIC = 331++pattern RPL_TOPIC :: Int+pattern RPL_TOPIC = 332++pattern RPL_TOPICWHOTIME :: Int+pattern RPL_TOPICWHOTIME = 333++pattern RPL_LISTUSAGE :: Int+pattern RPL_LISTUSAGE = 334++pattern RPL_COMMANDSYNTAX :: Int+pattern RPL_COMMANDSYNTAX = 334++pattern RPL_LISTSYNTAX :: Int+pattern RPL_LISTSYNTAX = 334++pattern RPL_CHANPASSOK :: Int+pattern RPL_CHANPASSOK = 338++pattern RPL_WHOISACTUALLY :: Int+pattern RPL_WHOISACTUALLY = 338++pattern RPL_BADCHANPASS :: Int+pattern RPL_BADCHANPASS = 339++pattern RPL_INVITING :: Int+pattern RPL_INVITING = 341++pattern RPL_SUMMONING :: Int+pattern RPL_SUMMONING = 342++pattern RPL_INVITED :: Int+pattern RPL_INVITED = 345++pattern RPL_INVITELIST :: Int+pattern RPL_INVITELIST = 346++pattern RPL_ENDOFINVITELIST :: Int+pattern RPL_ENDOFINVITELIST = 347++pattern RPL_EXCEPTLIST :: Int+pattern RPL_EXCEPTLIST = 348++pattern RPL_ENDOFEXCEPTLIST :: Int+pattern RPL_ENDOFEXCEPTLIST = 349++pattern RPL_VERSION :: Int+pattern RPL_VERSION = 351++pattern RPL_WHOREPLY :: Int+pattern RPL_WHOREPLY = 352++pattern RPL_NAMREPLY :: Int+pattern RPL_NAMREPLY = 353++pattern RPL_WHOSPCRPL :: Int+pattern RPL_WHOSPCRPL = 354++pattern RPL_NAMREPLY_ :: Int+pattern RPL_NAMREPLY_ = 355++pattern RPL_KILLDONE :: Int+pattern RPL_KILLDONE = 361++pattern RPL_CLOSING :: Int+pattern RPL_CLOSING = 362++pattern RPL_CLOSEEND :: Int+pattern RPL_CLOSEEND = 363++pattern RPL_LINKS :: Int+pattern RPL_LINKS = 364++pattern RPL_ENDOFLINKS :: Int+pattern RPL_ENDOFLINKS = 365++pattern RPL_ENDOFNAMES :: Int+pattern RPL_ENDOFNAMES = 366++pattern RPL_BANLIST :: Int+pattern RPL_BANLIST = 367++pattern RPL_ENDOFBANLIST :: Int+pattern RPL_ENDOFBANLIST = 368++pattern RPL_ENDOFWHOWAS :: Int+pattern RPL_ENDOFWHOWAS = 369++pattern RPL_INFO :: Int+pattern RPL_INFO = 371++pattern RPL_MOTD :: Int+pattern RPL_MOTD = 372++pattern RPL_INFOSTART :: Int+pattern RPL_INFOSTART = 373++pattern RPL_ENDOFINFO :: Int+pattern RPL_ENDOFINFO = 374++pattern RPL_MOTDSTART :: Int+pattern RPL_MOTDSTART = 375++pattern RPL_ENDOFMOTD :: Int+pattern RPL_ENDOFMOTD = 376++pattern RPL_KICKEXPIRED :: Int+pattern RPL_KICKEXPIRED = 377++pattern RPL_SPAM :: Int+pattern RPL_SPAM = 377++pattern RPL_BANEXPIRED :: Int+pattern RPL_BANEXPIRED = 378++pattern RPL_WHOISHOST :: Int+pattern RPL_WHOISHOST = 378++pattern RPL_KICKLINKED :: Int+pattern RPL_KICKLINKED = 379++pattern RPL_BANLINKED :: Int+pattern RPL_BANLINKED = 380++pattern RPL_YOURHELPER :: Int+pattern RPL_YOURHELPER = 380++pattern RPL_YOUREOPER :: Int+pattern RPL_YOUREOPER = 381++pattern RPL_REHASHING :: Int+pattern RPL_REHASHING = 382++pattern RPL_YOURESERVICE :: Int+pattern RPL_YOURESERVICE = 383++pattern RPL_MYPORTIS :: Int+pattern RPL_MYPORTIS = 384++pattern RPL_NOTOPERANYMORE :: Int+pattern RPL_NOTOPERANYMORE = 385++pattern RPL_QLIST :: Int+pattern RPL_QLIST = 386++pattern RPL_IRCOPS :: Int+pattern RPL_IRCOPS = 386++pattern RPL_ENDOFQLIST :: Int+pattern RPL_ENDOFQLIST = 387++pattern RPL_ENDOFIRCOPS :: Int+pattern RPL_ENDOFIRCOPS = 387++pattern RPL_TIME :: Int+pattern RPL_TIME = 391++pattern RPL_USERSSTART :: Int+pattern RPL_USERSSTART = 392++pattern RPL_USERS :: Int+pattern RPL_USERS = 393++pattern RPL_ENDOFUSERS :: Int+pattern RPL_ENDOFUSERS = 394++pattern RPL_NOUSERS :: Int+pattern RPL_NOUSERS = 395++pattern RPL_HOSTHIDDEN :: Int+pattern RPL_HOSTHIDDEN = 396++pattern ERR_UNKNOWNERROR :: Int+pattern ERR_UNKNOWNERROR = 400++pattern ERR_NOSUCHNICK :: Int+pattern ERR_NOSUCHNICK = 401++pattern ERR_NOSUCHSERVER :: Int+pattern ERR_NOSUCHSERVER = 402++pattern ERR_NOSUCHCHANNEL :: Int+pattern ERR_NOSUCHCHANNEL = 403++pattern ERR_CANNOTSENDTOCHAN :: Int+pattern ERR_CANNOTSENDTOCHAN = 404++pattern ERR_TOOMANYCHANNELS :: Int+pattern ERR_TOOMANYCHANNELS = 405++pattern ERR_WASNOSUCHNICK :: Int+pattern ERR_WASNOSUCHNICK = 406++pattern ERR_TOOMANYTARGETS :: Int+pattern ERR_TOOMANYTARGETS = 407++pattern ERR_NOSUCHSERVICE :: Int+pattern ERR_NOSUCHSERVICE = 408++pattern ERR_NOCOLORSONCHAN :: Int+pattern ERR_NOCOLORSONCHAN = 408++pattern ERR_NOORIGIN :: Int+pattern ERR_NOORIGIN = 409++pattern ERR_NORECIPIENT :: Int+pattern ERR_NORECIPIENT = 411++pattern ERR_NOTEXTTOSEND :: Int+pattern ERR_NOTEXTTOSEND = 412++pattern ERR_NOTOPLEVEL :: Int+pattern ERR_NOTOPLEVEL = 413++pattern ERR_WILDTOPLEVEL :: Int+pattern ERR_WILDTOPLEVEL = 414++pattern ERR_BADMASK :: Int+pattern ERR_BADMASK = 415++pattern ERR_TOOMANYMATCHES :: Int+pattern ERR_TOOMANYMATCHES = 416++pattern ERR_QUERYTOOLONG :: Int+pattern ERR_QUERYTOOLONG = 416++pattern ERR_LENGTHTRUNCATED :: Int+pattern ERR_LENGTHTRUNCATED = 419++pattern ERR_UNKNOWNCOMMAND :: Int+pattern ERR_UNKNOWNCOMMAND = 421++pattern ERR_NOMOTD :: Int+pattern ERR_NOMOTD = 422++pattern ERR_NOADMININFO :: Int+pattern ERR_NOADMININFO = 423++pattern ERR_FILEERROR :: Int+pattern ERR_FILEERROR = 424++pattern ERR_NOOPERMOTD :: Int+pattern ERR_NOOPERMOTD = 425++pattern ERR_TOOMANYAWAY :: Int+pattern ERR_TOOMANYAWAY = 429++pattern ERR_EVENTNICKCHANGE :: Int+pattern ERR_EVENTNICKCHANGE = 430++pattern ERR_NONICKNAMEGIVEN :: Int+pattern ERR_NONICKNAMEGIVEN = 431++pattern ERR_ERRONEUSNICKNAME :: Int+pattern ERR_ERRONEUSNICKNAME = 432++pattern ERR_NICKNAMEINUSE :: Int+pattern ERR_NICKNAMEINUSE = 433++pattern ERR_SERVICENAMEINUSE :: Int+pattern ERR_SERVICENAMEINUSE = 434++pattern ERR_NORULES :: Int+pattern ERR_NORULES = 434++pattern ERR_SERVICECONFUSED :: Int+pattern ERR_SERVICECONFUSED = 435++pattern ERR_BANONCHAN :: Int+pattern ERR_BANONCHAN = 435++pattern ERR_NICKCOLLISION :: Int+pattern ERR_NICKCOLLISION = 436++pattern ERR_UNAVAILRESOURCE :: Int+pattern ERR_UNAVAILRESOURCE = 437++pattern ERR_BANNICKCHANGE :: Int+pattern ERR_BANNICKCHANGE = 437++pattern ERR_NICKTOOFAST :: Int+pattern ERR_NICKTOOFAST = 438++pattern ERR_DEAD :: Int+pattern ERR_DEAD = 438++pattern ERR_TARGETTOOFAST :: Int+pattern ERR_TARGETTOOFAST = 439++pattern ERR_SERVICESDOWN :: Int+pattern ERR_SERVICESDOWN = 440++pattern ERR_USERNOTINCHANNEL :: Int+pattern ERR_USERNOTINCHANNEL = 441++pattern ERR_NOTONCHANNEL :: Int+pattern ERR_NOTONCHANNEL = 442++pattern ERR_USERONCHANNEL :: Int+pattern ERR_USERONCHANNEL = 443++pattern ERR_NOLOGIN :: Int+pattern ERR_NOLOGIN = 444++pattern ERR_SUMMONDISABLED :: Int+pattern ERR_SUMMONDISABLED = 445++pattern ERR_USERSDISABLED :: Int+pattern ERR_USERSDISABLED = 446++pattern ERR_NONICKCHANGE :: Int+pattern ERR_NONICKCHANGE = 447++pattern ERR_NOTIMPLEMENTED :: Int+pattern ERR_NOTIMPLEMENTED = 449++pattern ERR_NOTREGISTERED :: Int+pattern ERR_NOTREGISTERED = 451++pattern ERR_IDCOLLISION :: Int+pattern ERR_IDCOLLISION = 452++pattern ERR_NICKLOST :: Int+pattern ERR_NICKLOST = 453++pattern ERR_HOSTILENAME :: Int+pattern ERR_HOSTILENAME = 455++pattern ERR_ACCEPTFULL :: Int+pattern ERR_ACCEPTFULL = 456++pattern ERR_ACCEPTEXIST :: Int+pattern ERR_ACCEPTEXIST = 457++pattern ERR_ACCEPTNOT :: Int+pattern ERR_ACCEPTNOT = 458++pattern ERR_NOHIDING :: Int+pattern ERR_NOHIDING = 459++pattern ERR_NOTFORHALFOPS :: Int+pattern ERR_NOTFORHALFOPS = 460++pattern ERR_NEEDMOREPARAMS :: Int+pattern ERR_NEEDMOREPARAMS = 461++pattern ERR_ALREADYREGISTERED :: Int+pattern ERR_ALREADYREGISTERED = 462++pattern ERR_NOPERMFORHOST :: Int+pattern ERR_NOPERMFORHOST = 463++pattern ERR_PASSWDMISMATCH :: Int+pattern ERR_PASSWDMISMATCH = 464++pattern ERR_YOUREBANNEDCREEP :: Int+pattern ERR_YOUREBANNEDCREEP = 465++pattern ERR_YOUWILLBEBANNED :: Int+pattern ERR_YOUWILLBEBANNED = 466++pattern ERR_KEYSET :: Int+pattern ERR_KEYSET = 467++pattern ERR_INVALIDUSERNAME :: Int+pattern ERR_INVALIDUSERNAME = 468++pattern ERR_ONLYSERVERSCANCHANGE :: Int+pattern ERR_ONLYSERVERSCANCHANGE = 468++pattern ERR_LINKSET :: Int+pattern ERR_LINKSET = 469++pattern ERR_LINKCHANNEL :: Int+pattern ERR_LINKCHANNEL = 470++pattern ERR_KICKEDFROMCHAN :: Int+pattern ERR_KICKEDFROMCHAN = 470++pattern ERR_CHANNELISFULL :: Int+pattern ERR_CHANNELISFULL = 471++pattern ERR_UNKNOWNMODE :: Int+pattern ERR_UNKNOWNMODE = 472++pattern ERR_INVITEONLYCHAN :: Int+pattern ERR_INVITEONLYCHAN = 473++pattern ERR_BANNEDFROMCHAN :: Int+pattern ERR_BANNEDFROMCHAN = 474++pattern ERR_BADCHANNELKEY :: Int+pattern ERR_BADCHANNELKEY = 475++pattern ERR_BADCHANMASK :: Int+pattern ERR_BADCHANMASK = 476++pattern ERR_NOCHANMODES :: Int+pattern ERR_NOCHANMODES = 477++pattern ERR_NEEDREGGEDNICK :: Int+pattern ERR_NEEDREGGEDNICK = 477++pattern ERR_BANLISTFULL :: Int+pattern ERR_BANLISTFULL = 478++pattern ERR_BADCHANNAME :: Int+pattern ERR_BADCHANNAME = 479++pattern ERR_LINKFAIL :: Int+pattern ERR_LINKFAIL = 479++pattern ERR_NOULINE :: Int+pattern ERR_NOULINE = 480++pattern ERR_CANNOTKNOCK :: Int+pattern ERR_CANNOTKNOCK = 480++pattern ERR_NOPRIVILEGES :: Int+pattern ERR_NOPRIVILEGES = 481++pattern ERR_CHANOPRIVSNEEDED :: Int+pattern ERR_CHANOPRIVSNEEDED = 482++pattern ERR_CANTKILLSERVER :: Int+pattern ERR_CANTKILLSERVER = 483++pattern ERR_RESTRICTED :: Int+pattern ERR_RESTRICTED = 484++pattern ERR_ISCHANSERVICE :: Int+pattern ERR_ISCHANSERVICE = 484++pattern ERR_DESYNC :: Int+pattern ERR_DESYNC = 484++pattern ERR_ATTACKDENY :: Int+pattern ERR_ATTACKDENY = 484++pattern ERR_UNIQOPRIVSNEEDED :: Int+pattern ERR_UNIQOPRIVSNEEDED = 485++pattern ERR_KILLDENY :: Int+pattern ERR_KILLDENY = 485++pattern ERR_CANTKICKADMIN :: Int+pattern ERR_CANTKICKADMIN = 485++pattern ERR_ISREALSERVICE :: Int+pattern ERR_ISREALSERVICE = 485++pattern ERR_NONONREG :: Int+pattern ERR_NONONREG = 486++pattern ERR_HTMDISABLED :: Int+pattern ERR_HTMDISABLED = 486++pattern ERR_ACCOUNTONLY :: Int+pattern ERR_ACCOUNTONLY = 486++pattern ERR_CHANTOORECENT :: Int+pattern ERR_CHANTOORECENT = 487++pattern ERR_MSGSERVICES :: Int+pattern ERR_MSGSERVICES = 487++pattern ERR_TSLESSCHAN :: Int+pattern ERR_TSLESSCHAN = 488++pattern ERR_VOICENEEDED :: Int+pattern ERR_VOICENEEDED = 489++pattern ERR_SECUREONLYCHAN :: Int+pattern ERR_SECUREONLYCHAN = 489++pattern ERR_NOOPERHOST :: Int+pattern ERR_NOOPERHOST = 491++pattern ERR_NOSERVICEHOST :: Int+pattern ERR_NOSERVICEHOST = 492++pattern ERR_NOFEATURE :: Int+pattern ERR_NOFEATURE = 493++pattern ERR_BADFEATURE :: Int+pattern ERR_BADFEATURE = 494++pattern ERR_BADLOGTYPE :: Int+pattern ERR_BADLOGTYPE = 495++pattern ERR_BADLOGSYS :: Int+pattern ERR_BADLOGSYS = 496++pattern ERR_BADLOGVALUE :: Int+pattern ERR_BADLOGVALUE = 497++pattern ERR_ISOPERLCHAN :: Int+pattern ERR_ISOPERLCHAN = 498++pattern ERR_CHANOWNPRIVNEEDED :: Int+pattern ERR_CHANOWNPRIVNEEDED = 499++pattern ERR_UMODEUNKNOWNFLAG :: Int+pattern ERR_UMODEUNKNOWNFLAG = 501++pattern ERR_USERSDONTMATCH :: Int+pattern ERR_USERSDONTMATCH = 502++pattern ERR_GHOSTEDCLIENT :: Int+pattern ERR_GHOSTEDCLIENT = 503++pattern ERR_VWORLDWARN :: Int+pattern ERR_VWORLDWARN = 503++pattern ERR_USERNOTONSERV :: Int+pattern ERR_USERNOTONSERV = 504++pattern ERR_SILELISTFULL :: Int+pattern ERR_SILELISTFULL = 511++pattern ERR_TOOMANYWATCH :: Int+pattern ERR_TOOMANYWATCH = 512++pattern ERR_BADPING :: Int+pattern ERR_BADPING = 513++pattern ERR_INVALID_ERROR :: Int+pattern ERR_INVALID_ERROR = 514++pattern ERR_TOOMANYDCC :: Int+pattern ERR_TOOMANYDCC = 514++pattern ERR_BADEXPIRE :: Int+pattern ERR_BADEXPIRE = 515++pattern ERR_DONTCHEAT :: Int+pattern ERR_DONTCHEAT = 516++pattern ERR_DISABLED :: Int+pattern ERR_DISABLED = 517++pattern ERR_NOINVITE :: Int+pattern ERR_NOINVITE = 518++pattern ERR_LONGMASK :: Int+pattern ERR_LONGMASK = 518++pattern ERR_ADMONLY :: Int+pattern ERR_ADMONLY = 519++pattern ERR_TOOMANYUSERS :: Int+pattern ERR_TOOMANYUSERS = 519++pattern ERR_OPERONLY :: Int+pattern ERR_OPERONLY = 520++pattern ERR_MASKTOOWIDE :: Int+pattern ERR_MASKTOOWIDE = 520++pattern ERR_WHOTRUNC :: Int+pattern ERR_WHOTRUNC = 520++pattern ERR_LISTSYNTAX :: Int+pattern ERR_LISTSYNTAX = 521++pattern ERR_WHOSYNTAX :: Int+pattern ERR_WHOSYNTAX = 522++pattern ERR_WHOLIMEXCEED :: Int+pattern ERR_WHOLIMEXCEED = 523++pattern ERR_QUARANTINED :: Int+pattern ERR_QUARANTINED = 524++pattern ERR_OPERSPVERIFY :: Int+pattern ERR_OPERSPVERIFY = 524++pattern ERR_REMOTEPFX :: Int+pattern ERR_REMOTEPFX = 525++pattern ERR_PFXUNROUTABLE :: Int+pattern ERR_PFXUNROUTABLE = 526++pattern ERR_BADHOSTMASK :: Int+pattern ERR_BADHOSTMASK = 550++pattern ERR_HOSTUNAVAIL :: Int+pattern ERR_HOSTUNAVAIL = 551++pattern ERR_USINGSLINE :: Int+pattern ERR_USINGSLINE = 552++pattern ERR_STATSSLINE :: Int+pattern ERR_STATSSLINE = 553++pattern RPL_LOGON :: Int+pattern RPL_LOGON = 600++pattern RPL_LOGOFF :: Int+pattern RPL_LOGOFF = 601++pattern RPL_WATCHOFF :: Int+pattern RPL_WATCHOFF = 602++pattern RPL_WATCHSTAT :: Int+pattern RPL_WATCHSTAT = 603++pattern RPL_NOWON :: Int+pattern RPL_NOWON = 604++pattern RPL_NOWOFF :: Int+pattern RPL_NOWOFF = 605++pattern RPL_WATCHLIST :: Int+pattern RPL_WATCHLIST = 606++pattern RPL_ENDOFWATCHLIST :: Int+pattern RPL_ENDOFWATCHLIST = 607++pattern RPL_WATCHCLEAR :: Int+pattern RPL_WATCHCLEAR = 608++pattern RPL_ISOPER :: Int+pattern RPL_ISOPER = 610++pattern RPL_ISLOCOP :: Int+pattern RPL_ISLOCOP = 611++pattern RPL_ISNOTOPER :: Int+pattern RPL_ISNOTOPER = 612++pattern RPL_ENDOFISOPER :: Int+pattern RPL_ENDOFISOPER = 613++pattern RPL_DCCSTATUS :: Int+pattern RPL_DCCSTATUS = 617++pattern RPL_DCCLIST :: Int+pattern RPL_DCCLIST = 618++pattern RPL_ENDOFDCCLIST :: Int+pattern RPL_ENDOFDCCLIST = 619++pattern RPL_WHOWASHOST :: Int+pattern RPL_WHOWASHOST = 619++pattern RPL_DCCINFO :: Int+pattern RPL_DCCINFO = 620++pattern RPL_RULES :: Int+pattern RPL_RULES = 621++pattern RPL_ENDOFO :: Int+pattern RPL_ENDOFO = 626++pattern RPL_SETTINGS :: Int+pattern RPL_SETTINGS = 630++pattern RPL_ENDOFSETTINGS :: Int+pattern RPL_ENDOFSETTINGS = 631++pattern RPL_DUMPING :: Int+pattern RPL_DUMPING = 640++pattern RPL_DUMPRPL :: Int+pattern RPL_DUMPRPL = 641++pattern RPL_EODUMP :: Int+pattern RPL_EODUMP = 642++pattern RPL_TRACEROUTE_HOP :: Int+pattern RPL_TRACEROUTE_HOP = 660++pattern RPL_TRACEROUTE_START :: Int+pattern RPL_TRACEROUTE_START = 661++pattern RPL_MODECHANGEWARN :: Int+pattern RPL_MODECHANGEWARN = 662++pattern RPL_CHANREDIR :: Int+pattern RPL_CHANREDIR = 663++pattern RPL_SERVMODEIS :: Int+pattern RPL_SERVMODEIS = 664++pattern RPL_OTHERUMODEIS :: Int+pattern RPL_OTHERUMODEIS = 665++pattern RPL_ENDOF_GENERIC :: Int+pattern RPL_ENDOF_GENERIC = 666++pattern RPL_WHOWASDETAILS :: Int+pattern RPL_WHOWASDETAILS = 670++pattern RPL_WHOISSECURE :: Int+pattern RPL_WHOISSECURE = 671++pattern RPL_UNKNOWNMODES :: Int+pattern RPL_UNKNOWNMODES = 672++pattern RPL_CANNOTSETMODES :: Int+pattern RPL_CANNOTSETMODES = 673++pattern RPL_LUSERSTAFF :: Int+pattern RPL_LUSERSTAFF = 678++pattern RPL_TIMEONSERVERIS :: Int+pattern RPL_TIMEONSERVERIS = 679++pattern RPL_NETWORKS :: Int+pattern RPL_NETWORKS = 682++pattern RPL_YOURLANGUAGEIS :: Int+pattern RPL_YOURLANGUAGEIS = 687++pattern RPL_LANGUAGE :: Int+pattern RPL_LANGUAGE = 688++pattern RPL_WHOISSTAFF :: Int+pattern RPL_WHOISSTAFF = 689++pattern RPL_WHOISLANGUAGE :: Int+pattern RPL_WHOISLANGUAGE = 690++pattern RPL_ENDOFMODLIST :: Int+pattern RPL_ENDOFMODLIST = 703++pattern RPL_HELPSTART :: Int+pattern RPL_HELPSTART = 704++pattern RPL_HELPTXT :: Int+pattern RPL_HELPTXT = 705++pattern RPL_ENDOFHELP :: Int+pattern RPL_ENDOFHELP = 706++pattern RPL_ETRACEFULL :: Int+pattern RPL_ETRACEFULL = 708++pattern RPL_ETRACE :: Int+pattern RPL_ETRACE = 709++pattern RPL_KNOCK :: Int+pattern RPL_KNOCK = 710++pattern RPL_KNOCKDLVR :: Int+pattern RPL_KNOCKDLVR = 711++pattern ERR_TOOMANYKNOCK :: Int+pattern ERR_TOOMANYKNOCK = 712++pattern ERR_CHANOPEN :: Int+pattern ERR_CHANOPEN = 713++pattern ERR_KNOCKONCHAN :: Int+pattern ERR_KNOCKONCHAN = 714++pattern ERR_KNOCKDISABLED :: Int+pattern ERR_KNOCKDISABLED = 715++pattern RPL_TARGUMODEG :: Int+pattern RPL_TARGUMODEG = 716++pattern RPL_TARGNOTIFY :: Int+pattern RPL_TARGNOTIFY = 717++pattern RPL_UMODEGMSG :: Int+pattern RPL_UMODEGMSG = 718++pattern RPL_ENDOFOMOTD :: Int+pattern RPL_ENDOFOMOTD = 722++pattern ERR_NOPRIVS :: Int+pattern ERR_NOPRIVS = 723++pattern RPL_TESTMARK :: Int+pattern RPL_TESTMARK = 724++pattern RPL_TESTLINE :: Int+pattern RPL_TESTLINE = 725++pattern RPL_NOTESTLINE :: Int+pattern RPL_NOTESTLINE = 726++pattern RPL_QUIETLIST :: Int+pattern RPL_QUIETLIST = 728++pattern RPL_ENDOFQUIETLIST :: Int+pattern RPL_ENDOFQUIETLIST = 729++pattern RPL_XINFO :: Int+pattern RPL_XINFO = 771++pattern RPL_XINFOSTART :: Int+pattern RPL_XINFOSTART = 773++pattern RPL_XINFOEND :: Int+pattern RPL_XINFOEND = 774++pattern ERR_CANNOTDOCOMMAND :: Int+pattern ERR_CANNOTDOCOMMAND = 972++pattern ERR_CANNOTCHANGEUMODE :: Int+pattern ERR_CANNOTCHANGEUMODE = 973++pattern ERR_CANNOTCHANGECHANMODE :: Int+pattern ERR_CANNOTCHANGECHANMODE = 974++pattern ERR_CANNOTCHANGESERVERMODE :: Int+pattern ERR_CANNOTCHANGESERVERMODE = 975++pattern ERR_CANNOTSENDTONICK :: Int+pattern ERR_CANNOTSENDTONICK = 976++pattern ERR_UNKNOWNSERVERMODE :: Int+pattern ERR_UNKNOWNSERVERMODE = 977++pattern ERR_SERVERMODELOCK :: Int+pattern ERR_SERVERMODELOCK = 979++pattern ERR_BADCHARENCODING :: Int+pattern ERR_BADCHARENCODING = 980++pattern ERR_TOOMANYLANGUAGES :: Int+pattern ERR_TOOMANYLANGUAGES = 981++pattern ERR_NOLANGUAGE :: Int+pattern ERR_NOLANGUAGE = 982++pattern ERR_TEXTTOOSHORT :: Int+pattern ERR_TEXTTOOSHORT = 983++pattern ERR_NUMERIC_ERR :: Int+pattern ERR_NUMERIC_ERR = 999
+ src/Irc/Commands.hs view
@@ -0,0 +1,169 @@+{-# Language OverloadedStrings #-}+{-|+Module : Irc.Commands+Description : Smart constructors for 'RawIrcMsg'+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides smart constructors for IRC commands.+-}+module Irc.Commands+ ( ircCapEnd+ , ircCapLs+ , ircCapReq+ , ircInvite+ , ircJoin+ , ircKick+ , ircMode+ , ircNick+ , ircPart+ , ircPass+ , ircPong+ , ircPrivmsg+ , ircQuit+ , ircRemove+ , ircTopic+ , ircUser+ , ircWho+ , ircWhois+ , ircWhowas+ ) where++import Irc.RawIrcMsg+import Irc.Identifier+import Data.Text (Text)+import qualified Data.Text as Text++-- | PRIVMSG command+ircPrivmsg ::+ Identifier {- ^ target -} ->+ Text {- ^ message -} ->+ RawIrcMsg+ircPrivmsg who msg = rawIrcMsg "PRIVMSG" [idText who, msg]++-- | MODE command+ircMode ::+ Identifier {- ^ target -} ->+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircMode tgt params = rawIrcMsg "MODE" (idText tgt : params)++-- | WHOIS command+ircWhois ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircWhois = rawIrcMsg "WHOIS"++-- | WHO command+ircWho ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircWho = rawIrcMsg "WHO"++-- | WHOWAS command+ircWhowas ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircWhowas = rawIrcMsg "WHOWAS"++-- | NICK command+ircNick ::+ Identifier {- ^ nickname -} ->+ RawIrcMsg+ircNick nick = rawIrcMsg "NICK" [idText nick]++-- | PART command+ircPart ::+ Identifier {- ^ channel -} ->+ Text {- ^ message -} ->+ RawIrcMsg+ircPart chan msg+ | Text.null msg = rawIrcMsg "PART" [idText chan]+ | otherwise = rawIrcMsg "PART" [idText chan, msg]++-- | JOIN command+ircJoin ::+ Text {- ^ channel -} ->+ Maybe Text {- ^ key -} ->+ RawIrcMsg+ircJoin chan (Just key) = rawIrcMsg "JOIN" [chan, key]+ircJoin chan Nothing = rawIrcMsg "JOIN" [chan]++-- | INVITE command+ircInvite ::+ Text {- ^ nickname -} ->+ Identifier {- ^ channel -} ->+ RawIrcMsg+ircInvite nick channel = rawIrcMsg "INVITE" [nick, idText channel]++-- | TOPIC command+ircTopic ::+ Identifier {- ^ channel -} ->+ Text {- ^ topic -} ->+ RawIrcMsg+ircTopic chan msg+ | Text.null msg = rawIrcMsg "TOPIC" [idText chan]+ | otherwise = rawIrcMsg "TOPIC" [idText chan, msg]++-- | KICK command+ircKick ::+ Identifier {- ^ channel -} ->+ Text {- ^ nickname -} ->+ Text {- ^ message -} ->+ RawIrcMsg+ircKick chan who msg+ | Text.null msg = rawIrcMsg "KICK" [idText chan, who]+ | otherwise = rawIrcMsg "KICK" [idText chan, who, msg]++-- | REMOVE command+ircRemove ::+ Identifier {- ^ channel -} ->+ Text {- ^ nickname -} ->+ Text {- ^ message -} ->+ RawIrcMsg+ircRemove chan who msg+ | Text.null msg = rawIrcMsg "REMOVE" [idText chan, who]+ | otherwise = rawIrcMsg "REMOVE" [idText chan, who, msg]++-- | QUIT command+ircQuit :: Text {- ^ quit message -} -> RawIrcMsg+ircQuit msg+ | Text.null msg = rawIrcMsg "QUIT" []+ | otherwise = rawIrcMsg "QUIT" [msg]++-- | PASS command+ircPass :: Text {- ^ password -} -> RawIrcMsg+ircPass pass = rawIrcMsg "PASS" [pass]++-- | PONG command+ircPong ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircPong = rawIrcMsg "PONG"++ircUser ::+ Text {- ^ username -} ->+ Bool {- ^ set +w -} ->+ Bool {- ^ set +i -} ->+ Text {- ^ realname -} -> RawIrcMsg+ircUser user set_w set_i real = rawIrcMsg "USER" [user, modeTxt, "*", real]+ where+ modeTxt = Text.pack (show mode)+ mode :: Int+ mode = (if set_w then 4 else 0) -- bit 2+ + (if set_i then 8 else 0) -- bit 3++-- | CAP REQ command+ircCapReq ::+ [Text] {- ^ capabilities -} ->+ RawIrcMsg+ircCapReq caps = rawIrcMsg "CAP" ["REQ", Text.unwords caps]++-- | CAP END command+ircCapEnd :: RawIrcMsg+ircCapEnd = rawIrcMsg "CAP" ["END"]++-- | CAP LS command+ircCapLs :: RawIrcMsg+ircCapLs = rawIrcMsg "CAP" ["LS"]
+ src/Irc/Identifier.hs view
@@ -0,0 +1,77 @@+{-|+Module : Irc.Identifier+Description : Type and operations for nicknames and channel names+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module defines support for working with IRC's numeric reply+codes. Pattern synonyms are provided for each of the possible IRC reply codes.++Reply code information was extracted from https://www.alien.net.au/irc/irc2numerics.html++-}+module Irc.Identifier+ ( Identifier+ , idDenote+ , mkId+ , idText+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import Data.Function+import Data.Hashable (Hashable (hashWithSalt))+import Data.Text (Text)+import qualified Data.Text.Encoding as Text++-- | Identifier representing channels and nicknames+data Identifier = Identifier Text ByteString+ deriving (Read, Show)++-- | Equality on normalized identifier+instance Eq Identifier where+ (==) = (==) `on` idDenote++-- | Comparison on normalized identifier+instance Ord Identifier where+ compare = compare `on` idDenote++-- | Hash on normalized identifier+instance Hashable Identifier where+ hashWithSalt s = hashWithSalt s . idDenote++-- | Construct an 'Identifier' from a 'ByteString'+mkId :: Text -> Identifier+mkId x = Identifier x (ircFoldCase (Text.encodeUtf8 x))++-- | Returns the original 'Text' of an 'Identifier'+idText :: Identifier -> Text+idText (Identifier x _) = x++-- | Returns the case-normalized 'ByteString' of an 'Identifier'+-- which is suitable for comparison or hashing.+idDenote :: Identifier -> ByteString+idDenote (Identifier _ x) = x++-- | Capitalize a string according to RFC 2812+-- Latin letters are capitalized and {|}~ are mapped to [\]^+ircFoldCase :: ByteString -> ByteString+ircFoldCase = B.map (B.index casemap . fromIntegral)++casemap :: ByteString+casemap = B8.pack+ "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\+ \\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\+ \ !\"#$%&'()*+,-./0123456789:;<=>?\+ \@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_\+ \`ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^\x7f\+ \\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\+ \\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\+ \\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\+ \\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\+ \\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\+ \\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\+ \\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\+ \\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"
+ src/Irc/Message.hs view
@@ -0,0 +1,244 @@+{-# Language OverloadedStrings #-}++{-|+Module : Irc.Message+Description : High-level representation of IRC messages+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module defines high-level IRC commands. Commands are interpreted+and their arguments are extracted into the appropriate types.++-}++module Irc.Message+ (+ -- * High-level messages+ IrcMsg(..)+ , CapCmd(..)+ , cookIrcMsg++ -- * Properties of messages+ , MessageTarget(..)+ , ircMsgText+ , msgTarget+ , msgActor++ -- * Helper functions+ , nickSplit+ , computeMaxMessageLength+ ) where++import Control.Lens+import Data.Function+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Read as Text+import Irc.Identifier+import Irc.RawIrcMsg+import Irc.UserInfo++data IrcMsg+ = UnknownMsg RawIrcMsg+ | Reply Int [Text]+ | Nick UserInfo Identifier+ | Join UserInfo Identifier+ | Part UserInfo Identifier (Maybe Text)+ | Quit UserInfo (Maybe Text)+ | Kick UserInfo Identifier Identifier Text -- ^ kicker channel kickee comment+ | Topic UserInfo Identifier Text -- ^ user channel topic+ | Privmsg UserInfo Identifier Text -- ^ source target txt+ | Action UserInfo Identifier Text -- ^ source target txt+ | Notice UserInfo Identifier Text -- ^ source target txt+ | Mode UserInfo Identifier [Text] -- ^ source target txt+ | Cap CapCmd [Text]+ | Ping [Text]+ | Pong [Text]+ | Error Text+ deriving Show++data CapCmd+ = CapLs+ | CapList+ | CapReq+ | CapAck+ | CapNak+ deriving (Show, Eq, Ord)++cookCapCmd :: Text -> Maybe CapCmd+cookCapCmd "LS" = Just CapLs+cookCapCmd "LIST" = Just CapList+cookCapCmd "REQ" = Just CapReq+cookCapCmd "ACK" = Just CapAck+cookCapCmd "NAK" = Just CapNak+cookCapCmd _ = Nothing++-- | Interpret a low-level 'RawIrcMsg' as a high-level 'IrcMsg'.+-- Messages that can't be understood are wrapped in 'UnknownMsg'.+cookIrcMsg :: RawIrcMsg -> IrcMsg+cookIrcMsg msg =+ case view msgCommand msg of+ cmd | Right (n,"") <- decimal cmd ->+ Reply n (view msgParams msg)+ "CAP" | _target:cmdTxt:rest <- view msgParams msg+ , Just cmd <- cookCapCmd cmdTxt ->+ Cap cmd rest++ "PING" -> Ping (view msgParams msg)+ "PONG" -> Pong (view msgParams msg)++ "PRIVMSG" | Just user <- view msgPrefix msg+ , [chan,txt] <- view msgParams msg ->++ case Text.stripSuffix "\^A" =<< Text.stripPrefix "\^AACTION " txt of+ Just action -> Action user (mkId chan) action+ Nothing -> Privmsg user (mkId chan) txt++ "NOTICE" | Just user <- view msgPrefix msg+ , [chan,txt] <- view msgParams msg ->+ Notice user (mkId chan) txt++ "JOIN" | Just user <- view msgPrefix msg+ , chan:_ <- view msgParams msg ->++ Join user (mkId chan)++ "QUIT" | Just user <- view msgPrefix msg+ , reasons <- view msgParams msg ->+ Quit user (listToMaybe reasons)++ "PART" | Just user <- view msgPrefix msg+ , chan:reasons <- view msgParams msg ->+ Part user (mkId chan) (listToMaybe reasons)++ "NICK" | Just user <- view msgPrefix msg+ , newNick:_ <- view msgParams msg ->+ Nick user (mkId newNick)++ "KICK" | Just user <- view msgPrefix msg+ , [chan,nick,reason] <- view msgParams msg ->+ Kick user (mkId chan) (mkId nick) reason++ "TOPIC" | Just user <- view msgPrefix msg+ , [chan,topic] <- view msgParams msg ->+ Topic user (mkId chan) topic++ "MODE" | Just user <- view msgPrefix msg+ , target:modes <- view msgParams msg ->+ Mode user (mkId target) modes++ "ERROR" | [reason] <- view msgParams msg ->+ Error reason++ _ -> UnknownMsg msg++-- | Targets used to direct a message to a window for display+data MessageTarget+ = TargetUser !Identifier -- ^ Metadata update for a user+ | TargetWindow !Identifier -- ^ Directed message to channel or from user+ | TargetNetwork -- ^ Network-level message+ | TargetHidden -- ^ Completely hidden message++-- | Target information for the window that could be appropriate to+-- display this message in.+msgTarget :: Identifier -> IrcMsg -> MessageTarget+msgTarget me msg =+ case msg of+ UnknownMsg{} -> TargetNetwork+ Nick user _ -> TargetUser (userNick user)+ Mode _ tgt _ | tgt == me -> TargetNetwork+ | otherwise -> TargetWindow tgt+ Join _ chan -> TargetWindow chan+ Part _ chan _ -> TargetWindow chan+ Quit user _ -> TargetUser (userNick user)+ Kick _ chan _ _ -> TargetWindow chan+ Topic _ chan _ -> TargetWindow chan+ Privmsg src tgt _ | tgt == me -> TargetWindow (userNick src)+ | otherwise -> TargetWindow tgt+ Action src tgt _ | tgt == me -> TargetWindow (userNick src)+ | otherwise -> TargetWindow tgt+ Notice src tgt _ | tgt == me -> TargetWindow (userNick src)+ | otherwise -> TargetWindow tgt+ Ping{} -> TargetHidden+ Pong{} -> TargetHidden+ Error{} -> TargetNetwork+ Cap{} -> TargetNetwork+ Reply {} -> TargetNetwork++-- | 'UserInfo' of the user responsible for a message.+msgActor :: IrcMsg -> Maybe UserInfo+msgActor msg =+ case msg of+ UnknownMsg{} -> Nothing+ Reply{} -> Nothing+ Nick x _ -> Just x+ Join x _ -> Just x+ Part x _ _ -> Just x+ Quit x _ -> Just x+ Kick x _ _ _ -> Just x+ Topic x _ _ -> Just x+ Privmsg x _ _ -> Just x+ Action x _ _ -> Just x+ Notice x _ _ -> Just x+ Mode x _ _ -> Just x+ Ping{} -> Nothing+ Pong{} -> Nothing+ Error{} -> Nothing+ Cap{} -> Nothing++-- | Text representation of an IRC message to be used for matching with+-- regular expressions.+ircMsgText :: IrcMsg -> Text+ircMsgText msg =+ case msg of+ UnknownMsg raw -> Text.unwords (view msgCommand raw : view msgParams raw)+ Reply n xs -> Text.unwords (Text.pack (show n) : xs)+ Nick x y -> Text.unwords [renderUserInfo x, idText y]+ Join x _ -> renderUserInfo x+ Part x _ mb -> Text.unwords (renderUserInfo x : maybeToList mb)+ Quit x mb -> Text.unwords (renderUserInfo x : maybeToList mb)+ Kick x _ z r -> Text.unwords [renderUserInfo x, idText z, r]+ Topic x _ t -> Text.unwords [renderUserInfo x, t]+ Privmsg x _ t -> Text.unwords [renderUserInfo x, t]+ Action x _ t -> Text.unwords [renderUserInfo x, t]+ Notice x _ t -> Text.unwords [renderUserInfo x, t]+ Mode x _ xs -> Text.unwords (renderUserInfo x:"set mode":xs)+ Ping xs -> Text.unwords xs+ Pong xs -> Text.unwords xs+ Cap _ xs -> Text.unwords xs+ Error t -> t++-- nickname = ( letter / special ) *8( letter / digit / special / "-" )+-- letter = %x41-5A / %x61-7A ; A-Z / a-z+-- digit = %x30-39 ; 0-9+-- special = %x5B-60 / %x7B-7D+isNickChar :: Char -> Bool+isNickChar x = '0' <= x && x <= '9'+ || 'A' <= x && x <= '}'+ || '-' == x++-- | Split a nick into text parts group by whether or not those parts are valid+-- nickname characters.+nickSplit :: Text -> [Text]+nickSplit = Text.groupBy ((==) `on` isNickChar)++-- | Maximum length computation for the message part for+-- privmsg and notice. Note that the need for the limit is because+-- the server will limit the length of the message sent out to each+-- client, not just the length of the messages it will recieve.+--+-- Note that the length is on the *encoded message* which is UTF-8+-- The calculation isn't using UTF-8 on the userinfo part because+-- I'm assuming that the channel name and userinfo are all ASCII+--+-- @+-- :my!user@info PRIVMSG #channel :messagebody\r\n+-- @+computeMaxMessageLength :: UserInfo -> Text -> Int+computeMaxMessageLength myUserInfo target+ = 512 -- max IRC command+ - Text.length (renderUserInfo myUserInfo)+ - length (": PRIVMSG :\r\n"::String)+ - Text.length target
+ src/Irc/Modes.hs view
@@ -0,0 +1,122 @@+{-# Language TemplateHaskell #-}+{-# Language BangPatterns #-}++{-|+Module : Irc.Modes+Description : Operations for interpreting mode changes+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides support for interpreting the modes changed by+a MODE command.++-}+module Irc.Modes+ (+ -- * Interpretation of modes+ ModeTypes(..)+ , modesLists+ , modesAlwaysArg+ , modesSetArg+ , modesNeverArg+ , modesPrefixModes+ , defaultModeTypes+ , defaultUmodeTypes++ -- * Operations for working with MODE command parameters+ , splitModes+ , unsplitModes+ ) where++import Control.Lens+import Data.Text (Text)+import qualified Data.Text as Text++-- | Settings that describe how to interpret channel modes+data ModeTypes = ModeTypes+ { _modesLists :: ![Char] -- ^ modes for channel lists (e.g. ban)+ , _modesAlwaysArg :: ![Char] -- ^ modes that always have an argument+ , _modesSetArg :: ![Char] -- ^ modes that have an argument when set+ , _modesNeverArg :: ![Char] -- ^ modes that never have arguments+ , _modesPrefixModes :: ![(Char,Char)] -- ^ modes requiring a nickname argument (mode,sigil)+ }+ deriving Show++makeLenses ''ModeTypes++-- | The channel modes used by Freenode+defaultModeTypes :: ModeTypes+defaultModeTypes = ModeTypes+ { _modesLists = "eIbq"+ , _modesAlwaysArg = "k"+ , _modesSetArg = "flj"+ , _modesNeverArg = "CFLMPQScgimnprstz"+ , _modesPrefixModes = [('o','@'),('v','+')]+ }++-- | The default UMODE used by Freenode+defaultUmodeTypes :: ModeTypes+defaultUmodeTypes = ModeTypes+ { _modesLists = ""+ , _modesAlwaysArg = ""+ , _modesSetArg = "s"+ , _modesNeverArg = ""+ , _modesPrefixModes = []+ }++-- | Split up a mode change command and arguments into individual changes+-- given a configuration.+splitModes ::+ ModeTypes {- ^ mode interpretation -} ->+ Text {- ^ modes -} ->+ [Text] {- ^ arguments -} ->+ Maybe [(Bool,Char,Text)] {- ^ (set, mode, parameter) -}+splitModes !icm = computeMode True . Text.unpack+ where+ computeMode ::+ Bool {- current polarity -} ->+ [Char] {- remaining modes -} ->+ [Text] {- remaining arguments -} ->+ Maybe [(Bool,Char,Text)]+ computeMode polarity modes args =++ case modes of+ [] | null args -> Just []+ | otherwise -> Nothing++ '+':ms -> computeMode True ms args+ '-':ms -> computeMode False ms args++ m:ms+ | m `elem` view modesAlwaysArg icm+ || polarity && m `elem` view modesSetArg icm+ || m `elem` map fst (view modesPrefixModes icm)+ || m `elem` view modesLists icm ->+ let (arg,args') =+ case args of+ [] -> (Text.empty,[])+ x:xs -> (x,xs)+ in cons (polarity,m,arg) <$> computeMode polarity ms args'++ | not polarity && m `elem` view modesSetArg icm+ || m `elem` view modesNeverArg icm ->+ do res <- computeMode polarity ms args+ return ((polarity,m,Text.empty) : res)++ | otherwise -> Nothing++-- | Construct the arguments to a MODE command corresponding to the given+-- mode changes.+unsplitModes ::+ [(Bool,Char,Text)] {- ^ (set,mode,parameter) -} ->+ [Text]+unsplitModes modes+ = Text.pack (foldr combineModeChars (const "") modes True)+ : args+ where+ args = [arg | (_,_,arg) <- modes, not (Text.null arg)]+ combineModeChars (q,m,_) rest p+ | p == q = m : rest p+ | q = '+' : m : rest True+ | otherwise = '-' : m : rest False
+ src/Irc/RateLimit.hs view
@@ -0,0 +1,77 @@+{-|+Module : Irc.RateLimit+Description : Rate limit operations for IRC+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module implements a simple rate limiter based on the IRC RFC+to be used to keep an IRC client from getting disconnected for+flooding. It allows one event per duration with a given threshold.++This algorithm keeps track of the time at which the client may+start sending messages. Each message sent advances that time into+the future by the @penalty@. The client is allowed to transmit+up to @threshold@ seconds ahead of this time.++-}+module Irc.RateLimit+ ( RateLimit+ , newRateLimit+ , newRateLimitDefault+ , tickRateLimit+ ) where++import Control.Concurrent+import Control.Monad+import Data.Time++-- | The 'RateLimit' keeps track of rate limit settings as well+-- as the current state of the limit.+data RateLimit = RateLimit+ { rateStamp :: !(MVar UTCTime) -- ^ Time that client can send+ , rateThreshold :: !Int -- ^ seconds+ , ratePenalty :: !Int -- ^ seconds+ }++-- | Construct a new rate limit with the RFC 2813 specified+-- 2 second penalty and 10 second threshold+newRateLimitDefault :: IO RateLimit+newRateLimitDefault = newRateLimit 2 12++-- | Construct a new rate limit with the given penalty and threshold.+newRateLimit ::+ Int {- ^ penalty -} ->+ Int {- ^ threshold -} ->+ IO RateLimit+newRateLimit penalty threshold =+ do unless (penalty > 0)+ (fail "newRateLimit: Penalty too small")++ unless (threshold > 0)+ (fail "newRateLimit: Threshold too small")++ now <- getCurrentTime+ ref <- newMVar now++ return RateLimit+ { rateStamp = ref+ , rateThreshold = threshold+ , ratePenalty = penalty+ }++-- | Account for an event in the context of a 'RateLimit'. This command+-- will block and delay as required to satisfy the current rate. Once+-- it returns it is safe to proceed with the rate limited action.+tickRateLimit :: RateLimit -> IO ()+tickRateLimit r = modifyMVar_ (rateStamp r) $ \stamp ->+ do now <- getCurrentTime+ let stamp' = fromIntegral (ratePenalty r) `addUTCTime` max stamp now+ diff = diffUTCTime stamp' now+ excess = diff - fromIntegral (rateThreshold r)++ when (excess > 0)+ (threadDelay+ (ceiling (1000000 * realToFrac excess :: Rational)))++ return stamp'
+ src/Irc/RawIrcMsg.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# Language TemplateHaskell #-}++{-|+Module : Irc.RawIrcMsg+Description : Low-level representation of IRC messages+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides a parser and printer for the low-level IRC+message format. It handles splitting up IRC commands into the+prefix, command, and arguments.++-}+module Irc.RawIrcMsg+ (+ -- * Low-level IRC messages+ RawIrcMsg(..)+ , rawIrcMsg+ , msgServerTime+ , msgPrefix+ , msgCommand+ , msgParams++ -- * Text format for IRC messages+ , parseRawIrcMsg+ , renderRawIrcMsg++ -- * Permissive text decoder+ , asUtf8+ ) where++import Control.Applicative+import Control.Monad (when)+import Control.Lens+import Data.Array+import Data.Attoparsec.Text as P+import Data.ByteString (ByteString)+import Data.ByteString.Builder (Builder)+import Data.Functor+import Data.Monoid+import Data.Text (Text)+import Data.Time (UTCTime, parseTimeM, defaultTimeLocale)+import Data.Word (Word8)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as Builder+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import Irc.UserInfo++-- | 'RawIrcMsg' breaks down the IRC protocol into its most basic parts.+-- The "trailing" parameter indicated in the IRC protocol with a leading+-- colon will appear as the last parameter in the parameter list.+--+-- Note that RFC 2812 specifies a maximum of 15 parameters.+--+-- @:prefix COMMAND param0 param1 param2 .. paramN@+data RawIrcMsg = RawIrcMsg+ { _msgServerTime :: Maybe UTCTime -- ^ Time from znc.in/server-time-iso extension+ , _msgPrefix :: Maybe UserInfo -- ^ Optional sender of message+ , _msgCommand :: Text -- ^ command+ , _msgParams :: [Text] -- ^ command parameters+ }+ deriving (Read, Show)++makeLenses ''RawIrcMsg++-- | Attempt to split an IRC protocol message without its trailing newline+-- information into a structured message.+parseRawIrcMsg :: Text -> Maybe RawIrcMsg+parseRawIrcMsg x =+ case parseOnly rawIrcMsgParser x of+ Left{} -> Nothing+ Right r -> Just r++-- | RFC 2812 specifies that there can only be up to+-- 14 "middle" parameters, after that the fifteenth is+-- the final parameter and the trailing : is optional!+maxMiddleParams :: Int+maxMiddleParams = 14++-- Excerpt from https://tools.ietf.org/html/rfc2812#section-2.3.1++-- message = [ ":" prefix SPACE ] command [ params ] crlf+-- prefix = servername / ( nickname [ [ "!" user ] "@" host ] )+-- command = 1*letter / 3digit+-- params = *14( SPACE middle ) [ SPACE ":" trailing ]+-- =/ 14( SPACE middle ) [ SPACE [ ":" ] trailing ]++-- nospcrlfcl = %x01-09 / %x0B-0C / %x0E-1F / %x21-39 / %x3B-FF+-- ; any octet except NUL, CR, LF, " " and ":"+-- middle = nospcrlfcl *( ":" / nospcrlfcl )+-- trailing = *( ":" / " " / nospcrlfcl )++-- SPACE = %x20 ; space character+-- crlf = %x0D %x0A ; "carriage return" "linefeed"++-- | Parse a whole IRC message assuming that the trailing+-- newlines have already been removed. This parser will+-- parse valid messages correctly but will also accept some+-- invalid messages. Presumably the server isn't sending+-- invalid messages!+rawIrcMsgParser :: Parser RawIrcMsg+rawIrcMsgParser =+ do time <- guarded (string "@time=") timeParser+ prefix <- guarded (char ':') prefixParser+ cmd <- simpleTokenParser+ params <- paramsParser maxMiddleParams+ return RawIrcMsg+ { _msgServerTime = time+ , _msgPrefix = prefix+ , _msgCommand = cmd+ , _msgParams = params+ }++-- | Parse the list of parameters in a raw message. The RFC+-- allows for up to 15 parameters.+paramsParser :: Int -> Parser [Text]+paramsParser n =+ do _ <- skipMany (char ' ') -- Freenode requires this exception+ endOfInput $> [] <|> more+ where+ more+ | n == 0 =+ do _ <- optional (char ':')+ finalParam++ | otherwise =+ do mbColon <- optional (char ':')+ case mbColon of+ Just{} -> finalParam+ Nothing -> middleParam++ finalParam =+ do x <- takeText+ let !x' = Text.copy x+ return [x']++ middleParam =+ do x <- P.takeWhile (/= ' ')+ when (Text.null x) (fail "Empty middle parameter")+ let !x' = Text.copy x+ xs <- paramsParser (n-1)+ return (x':xs)++-- | Parse the server-time message prefix:+-- @time=2015-03-04T22:29:04.064Z+timeParser :: Parser UTCTime+timeParser =+ do timeBytes <- simpleTokenParser+ _ <- char ' '+ case parseIrcTime (Text.unpack timeBytes) of+ Nothing -> fail "Bad server-time format"+ Just t -> return t++parseIrcTime :: String -> Maybe UTCTime+parseIrcTime = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z"++prefixParser :: Parser UserInfo+prefixParser =+ do tok <- simpleTokenParser+ _ <- char ' '+ return (parseUserInfo tok)++-- | Take the bytes up to the next space delimiter+simpleTokenParser :: Parser Text+simpleTokenParser =+ do xs <- P.takeWhile (/= ' ')+ when (Text.null xs) (fail "Empty token")+ return $! Text.copy xs++-- | Take the bytes up to the next space delimiter.+-- If the first character of this token is a ':'+-- then take the whole remaining bytestring++++-- | Serialize a structured IRC protocol message back into its wire+-- format. This command adds the required trailing newline.+renderRawIrcMsg :: RawIrcMsg -> ByteString+renderRawIrcMsg m = L.toStrict $ Builder.toLazyByteString $+ maybe mempty renderPrefix (view msgPrefix m)+ <> Text.encodeUtf8Builder (view msgCommand m)+ <> buildParams (view msgParams m)+ <> Builder.char8 '\r'+ <> Builder.char8 '\n'++-- | Construct a new 'RawIrcMsg' without a time or prefix.+rawIrcMsg ::+ Text {- ^ command -} ->+ [Text] {- ^ parameters -} -> RawIrcMsg+rawIrcMsg = RawIrcMsg Nothing Nothing++renderPrefix :: UserInfo -> Builder+renderPrefix u = Builder.char8 ':'+ <> Text.encodeUtf8Builder (renderUserInfo u)+ <> Builder.char8 ' '++-- | Build concatenate a list of parameters into a single, space-+-- delimited bytestring. Use a colon for the last parameter if it contains+-- a colon or a space.+buildParams :: [Text] -> Builder+buildParams [x]+ | " " `Text.isInfixOf` x || ":" `Text.isPrefixOf` x+ = Builder.char8 ' ' <> Builder.char8 ':' <> Text.encodeUtf8Builder x+buildParams (x:xs)+ = Builder.char8 ' ' <> Text.encodeUtf8Builder x <> buildParams xs+buildParams [] = mempty++-- | When the first parser succeeds require the second parser to succeed.+-- Otherwise return Nothing+guarded :: Parser a -> Parser b -> Parser (Maybe b)+guarded pa pb =+ do mb <- optional pa+ case mb of+ Nothing -> return Nothing+ Just{} -> fmap Just pb+++-- | Try to decode a message as UTF-8. If that fails interpret it as Windows CP1252+-- This helps deal with clients like XChat that get clever and otherwise misconfigured+-- clients.+asUtf8 :: ByteString -> Text+asUtf8 x = case Text.decodeUtf8' x of+ Right txt -> txt+ Left{} -> decodeCP1252 x++decodeCP1252 :: ByteString -> Text+decodeCP1252 = Text.pack . map (cp1252!) . B.unpack++-- This character encoding is a superset of ISO 8859-1 in terms of printable+-- characters, but differs from the IANA's ISO-8859-1 by using displayable+-- characters rather than control characters in the 80 to 9F (hex) range.+cp1252 :: Array Word8 Char+cp1252 = listArray (0,255)+ ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK','\a','\b','\t','\n','\v','\f','\r','\SO','\SI',+ '\DLE','\DC1','\DC2','\DC3','\DC4','\NAK','\SYN','\ETB','\CAN','\EM','\SUB','\ESC','\FS','\GS','\RS','\US',+ ' ','!','\"','#','$','%','&','\'','(',')','*','+',',','-','.','/',+ '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',+ '@','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',+ 'P','Q','R','S','T','U','V','W','X','Y','Z','[','\\',']','^','_',+ '`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',+ 'p','q','r','s','t','u','v','w','x','y','z','{','|','}','~','\DEL',+ '\8364','\129','\8218','\402','\8222','\8230','\8224','\8225','\710','\8240','\352','\8249','\338','\141','\381','\143',+ '\144','\8216','\8217','\8220','\8221','\8226','\8211','\8212','\732','\8482','\353','\8250','\339','\157','\382','\376',+ '\160','\161','\162','\163','\164','\165','\166','\167','\168','\169','\170','\171','\172','\173','\174','\175',+ '\176','\177','\178','\179','\180','\181','\182','\183','\184','\185','\186','\187','\188','\189','\190','\191',+ '\192','\193','\194','\195','\196','\197','\198','\199','\200','\201','\202','\203','\204','\205','\206','\207',+ '\208','\209','\210','\211','\212','\213','\214','\215','\216','\217','\218','\219','\220','\221','\222','\223',+ '\224','\225','\226','\227','\228','\229','\230','\231','\232','\233','\234','\235','\236','\237','\238','\239',+ '\240','\241','\242','\243','\244','\245','\246','\247','\248','\249','\250','\251','\252','\253','\254','\255']
+ src/Irc/UserInfo.hs view
@@ -0,0 +1,58 @@+{-# Language OverloadedStrings #-}++{-|+Module : Irc.UserInfo+Description : User hostmasks+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++Information identifying users on IRC. This information includes+a nickname and optionally a username and hostname.++-}++module Irc.UserInfo+ ( UserInfo(..)+ , renderUserInfo+ , parseUserInfo+ , uiNick+ ) where++import Data.Text (Text)+import qualified Data.Text as Text+import Irc.Identifier+import Data.Monoid ((<>))+import Control.Lens++-- | 'UserInfo' packages a nickname along with the username and hsotname+-- if they are known in the current context.+data UserInfo = UserInfo+ { userNick :: !Identifier -- ^ nickname+ , userName :: !(Maybe Text) -- ^ username+ , userHost :: !(Maybe Text) -- ^ hostname+ }+ deriving (Read, Show)++-- | 'Lens' into 'userNick' field.+uiNick :: Lens' UserInfo Identifier+uiNick f ui@UserInfo{userNick = n} = (\n' -> ui{userNick = n'}) <$> f n++-- | Render 'UserInfo' as @nick!username\@hostname@+renderUserInfo :: UserInfo -> Text+renderUserInfo u = idText (userNick u)+ <> maybe "" ("!" <>) (userName u)+ <> maybe "" ("@" <>) (userHost u)++-- | Split up a hostmask into a nickname, username, and hostname.+-- The username and hostname might not be defined but are delimited by+-- a @!@ and @\@@ respectively.+parseUserInfo :: Text -> UserInfo+parseUserInfo x = UserInfo+ { userNick = mkId nick+ , userName = if Text.null user then Nothing else Just $! Text.drop 1 user+ , userHost = if Text.null host then Nothing else Just $! Text.drop 1 host+ }+ where+ (nickuser,host) = Text.break (=='@') x+ (nick,user) = Text.break (=='!') nickuser
+ src/LensUtils.hs view
@@ -0,0 +1,42 @@+{-|+Module : LensUtils+Description : Lens utility functions+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++This module provides functions that are useful with lenses.++-}+module LensUtils+ ( Id'+ , overStrict+ , setStrict+ ) where++import Control.Lens+import Control.Applicative+import Data.Profunctor.Unsafe++newtype Id' a = Id' { runId' :: a }++-- | Strict function composition+instance Functor Id' where+ fmap = liftA++-- | Strict function application+instance Applicative Id' where+ pure = Id'+ Id' f <*> Id' x = Id' (f $! x)++-- | Modify the target of a 'Setter' with a function. The result+-- is strict in the results of applying the function. Strict version+-- of 'over'+overStrict :: LensLike Id' s t a b -> (a -> b) -> s -> t+overStrict l f = runId' #. l (Id' #. f)+{-# INLINE overStrict #-}++-- | Set a value strictly in the set value. Strict version of 'set'.+setStrict :: ASetter s t a b -> b -> s -> t+setStrict l x = set l $! x+{-# INLINE setStrict #-}
+ src/Main.hs view
@@ -0,0 +1,49 @@+{-|+Module : Main+Description : Entry-point of executable+Copyright : (c) Eric Mertens, 2016+License : ISC+Maintainer : emertens@gmail.com++Entry point into glirc2. This module sets up VTY and launches the client.+-}++module Main where++import Control.Concurrent+import Control.Exception+import Control.Lens+import Control.Monad+import Data.Default.Class+import Graphics.Vty++import Client.EventLoop+import Client.Configuration+import Client.CommandArguments+import Client.State++-- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty'+-- once the continuation finishes.+withVty :: (Vty -> IO a) -> IO a+withVty = bracket (mkVty def) shutdown++-- | Main action for IRC client+main :: IO ()+main =+ do args <- getCommandArguments+ cfg <- loadConfiguration (view cmdArgConfigFile args)+ withVty $ \vty ->+ runInUnboundThread $+ do st <- initialClientState cfg vty+ st' <- addInitialNetworks (view cmdArgInitialNetworks args) st+ eventLoop st'++-- | Create connections for all the networks on the command line.+-- Set the client focus to the first network listed.+addInitialNetworks :: [NetworkName] -> ClientState -> IO ClientState+addInitialNetworks networks st =+ case networks of+ [] -> return st+ network:_ ->+ do st' <- foldM (flip addConnection) st networks+ return (set clientFocus (NetworkFocus network) st')