irc-core-1.1.3/0000755000000000000000000000000012622517457011420 5ustar0000000000000000irc-core-1.1.3/CHANGELOG.md0000644000000000000000000000143412622517457013233 0ustar00000000000000001.1.3 ------- * Support for running commands upon connection * Support for SOCKS5 proxy * Merge view of all channels (F5) 1.1.2 ------- * Support multiple nicknames in `/filter` * Periodically ping to determine ping-times and keep connection alive. * Added ping time field to IrcConnection datatype. * Add `/ping` command 1.1.1.1 ------- * Better error handling * Added a stack.yaml 1.1.1 ----- * Add `/grep` filter command 1.1.0.1 ------- * Fix setting default nick in configuration file * Dependency version constraint bumps 1.1 --- * Better support for Freenode's trailing spaces * More compact metadata representation * Ignored messages no longer count toward unread number * Updated version bounds on lens and attoparsec * Channel info has user count 1.0 --- * Initial hackage release irc-core-1.1.3/irc-core.cabal0000644000000000000000000001436712622517457014122 0ustar0000000000000000name: irc-core version: 1.1.3 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues license: BSD3 license-file: LICENSE author: Eric Mertens maintainer: Eric Mertens copyright: 2015 Eric Mertens category: Network build-type: Simple cabal-version: >=1.10 synopsis: An IRC client library and text client tested-with: GHC == 7.8.4, GHC == 7.10.2 description: This package provides an IRC connection library as well as a console-based IRC client that uses the library. . /Library module breakdown/ . * "Irc.Cmd" - Functions for generating IRC protocol message for client-to-server . * "Irc.Core" - Functions for parsing low-level IRC messages into mid-level IRC messages . * "Irc.Core.Prisms" - Prisms for all of the mid-level IRC message constructors . * "Irc.Format" - Functions for parsing and rendering low-level IRC protocol messages . * "Irc.Message" - High-level IRC event messages for client interpretation . * "Irc.Model" - Functions for interpreting mid-level IRC messages to generate high-level event messages and to maintain a consistent view of the connection . * "Irc.RateLimit" - Functions to assist with rate-limiting outgoing client messages . * "Irc.Time" - Internal compatibility module for time-1.4 and time-1.5 interop . /Library module breakdown/ . * "Main" - Main client module . * "ClientState" - Types and operations representing the full state of the client . * "CommandArgs" - Types and functions for interpreting the initial client configuration . * "CommandParser" - Types and functions for parsing and pretty printing IRC commands . * "Connection" - Types and functions for establishing a plain and TLS connections . * "CtcpHandler" - Event handler for CTCP messages . * "EditBox" - Types and functions for managing the input box along the bottom of the client . * "HaskelHighlighter" - Haskell syntax highlighting support . * "ImageUtils" - Functions to support the various view construction . * "Moderation" - Implementation of various IRC channel moderation automation . * "ServerSettings" - Types for defining connection parameters for an IRC server . * "Views.BanList" - Functions to generate the ban list view . * "Views.Channel" - Functions to generate message list views . * "Views.ChannelInfo" - Functions to generate metadata views for channels . See the associated README file for help using the client. extra-source-files: README.md CHANGELOG.md -- Use time-1.5 and drop old-locale flag time15 default: True library exposed-modules: Irc.Core Irc.Core.Prisms Irc.Cmd Irc.Message Irc.Model Irc.Format Irc.RateLimit other-modules: Irc.Time -- Note: GHC 7.8.4 fixes a bug that can cause IRC.Core -- to use an absurd amount of RAM when compiling. -- The base >= 4.7.0.2 is to protect people from finding -- this out the hard way. build-depends: base >= 4.7.0.2 && < 4.9, array >= 0.5 && < 0.6, attoparsec >= 0.12.1.2 && < 0.14, bytestring >= 0.10 && < 0.11, base64-bytestring>= 1.0.0.1 && < 1.1, containers >= 0.5 && < 0.6, free >= 4.11 && < 4.13, lens >= 4.7 && < 4.14, text >= 1.2.0.4 && < 1.3, transformers >= 0.2 && < 0.5, regex-tdfa >= 1.2 && < 1.3 if flag(time15) build-depends: time >= 1.5 && < 1.6 else build-depends: time >= 1.4.2 && < 1.5, old-locale >= 1.0.0.6 && < 1.1 hs-source-dirs: src default-language: Haskell2010 executable glirc main-is: Main.hs other-modules: ClientState CommandArgs CommandParser Connection ConnectCmds CtcpHandler EditBox HaskellHighlighter ImageUtils Moderation ServerSettings Views.BanList Views.Channel Views.ChannelInfo Paths_irc_core hs-source-dirs: driver ghc-options: -threaded build-depends: irc-core, connection >= 0.2.4 && < 0.3, tls >= 1.2.16 && < 1.4, data-default-class >= 0.0.1 && < 0.1, x509 >= 1.5.0.1 && < 1.7, x509-system >= 1.5.0 && < 1.7, x509-store >= 1.5.0 && < 1.7, x509-validation >= 1.5.1 && < 1.7, array >= 0.5 && < 0.6, base >= 4.7 && < 4.9, bytestring >= 0.10.4.0 && < 0.11, containers >= 0.5 && < 0.6, config-value >= 0.4 && < 0.5, deepseq >= 1.3.0.2 && < 1.5, directory >= 1.2.1.0 && < 1.3, filepath >= 1.3.0.2 && < 1.5, lens >= 4.7 && < 4.14, network >= 2.6.0.2 && < 2.7, old-locale >= 1.0.0.6 && < 1.1, split >= 0.2.2 && < 0.3, stm >= 2.4.4 && < 2.5, text >= 1.2.0.4 && < 1.3, time >= 1.4.2 && < 1.6, vty >= 5.2.7 && < 5.5, haskell-lexer >= 1.0 && < 1.1, transformers >= 0.2 && < 0.5, regex-tdfa >= 1.2 && < 1.3 default-language: Haskell2010 source-repository head type: git location: git://github.com/glguy/irc-core.git irc-core-1.1.3/LICENSE0000644000000000000000000000276212622517457012434 0ustar0000000000000000Copyright (c) 2015, Eric Mertens All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Eric Mertens nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. irc-core-1.1.3/README.md0000644000000000000000000001760712622517457012712 0ustar0000000000000000My IRC client ============= [![Build Status](https://secure.travis-ci.org/glguy/irc-core.svg)](http://travis-ci.org/glguy/irc-core) ![](https://raw.githubusercontent.com/wiki/glguy/irc-core/images/screenshot.png) Library ======= This package is split into a generic IRC modeling library and a VTY-base text client using that library. 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 * SASL authentication * New message notification * Customizable mention filter (looks for your nick plus extra search terms) * View ban, quiet, invex, and exception lists * Support for rendering/inputing colors and formatting * Haskell source code highlighting (/hs) * Write your modifications in Haskell! * Chanserv automation (automatically requests op from chanserv for privileged commands), automatically deop after 5 minutes of not performing privileged commands. * Command syntax highlighting with hints. * 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 * Togglable support for merged view of all joined channels (F5). * Run commands upon connection TLS === I've added TLS support. You can enable it with the `-t` flag. Note that Freenode (and other networks) will allow you to authenticate to NickServ via a client certificate. This is configurable via `--tls-client-cert`. 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. [Identifying with CERTFP](https://freenode.net/certfp/) Startup ======= ``` glirc SERVER -c FILENAME --config=FILENAME Configuration file path (default ~/.glirc/config) -p PORT --port=PORT IRC Server Port -n NICK --nick=NICK Nickname -u USER --user=USER Username -r REAL --real=REAL Real Name --sasl-user=USER SASL username -d FILE --debug=FILE Debug log filename -i USERINFO --userinfo=USERINFO CTCP USERINFO Response -t --tls Enable TLS --tls-client-cert=PATH Path to PEM encoded client certificate --tls-client-key=PATH Path to PEM encoded client key --tls-insecure Disable server certificate verification -h --help Show help Environment variables IRCPASSWORD= SASLPASSWORD= ``` 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) ``` -- Optional file to dump raw server messages debug-file: "debug.txt" -- Defaults used when not specified on command line defaults: port: 6667 nick: "yournick" username: "yourusername" realname: "Your real name" password: "IRC server password" sasl-username: "sasl_username" sasl-password: "sasl_password" userinfo: "user info string" 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" ``` Commands ======== * `/exit` - *Exit!* * `/akb ` - Auto-kickban: Request ops from chanserv if needed, ban by accountname if known, hostname otherwise, kick with message * `/bans` - Show known bans for current channel. Note: Request bans list with `/quote mode +b` * `/channel ` - switch to a user message window * `/channelinfo` - Show information for the current channel * `/ctcp ` - Send CTCP command to current window * `/clear` - Clear all messages for the current channel * `/help ` - Request help from the server * `/hs ` - Send syntax highlighted source code as a message to the current channel * `/ignore ` - Toggle ignoring a user by nickname. * `/join ` - join a new channel (optional key argument) * `/kick ` - Kick a user from the current channel * `/masks ` - Show the bans (b), quiets (q), invex (I), or ban exemptions (e) for a channel. The list must be requested as above. * `/me ` - send an action to the current channel * `/mode ` - Set modes on the current channel * `/msg ` - send a private message * `/nick ` - Change your nickname * `/notice ` - send a notice message * `/op ` - Op nicks in the channel, self when no nicks given * `/deop ` - Deop nicks in the channel, self when no nicks given * `/voice ` - Voice nicks in the channel, self when no nicks given * `/devoice ` - Devoice nicks in the channel, self when no nicks given * `/part ` - part the current channel with the given message * `/query ` - switch to a user message window * `/quote ` - send a client command verbatim * `/remove ` - Force a user to part from the current channel * `/server` - switch to the server message window * `/topic ` - Change the topic for the current channel * `/umode ` - Set modes on yourself * `/window ` - Jump to a window by index * `/whois ` - Query the server for information about a user * `/whowas ` - Query the server for information about a user who recently disconnected. * `/stats ` - Request server stat information, try `/help stats` on Freenode first. * `/admin` - Request some basic admin contact information * `/away ` - Toggle current away status * `/time` - Request server time * `/oper` - Enter your OPER credentials * `/accept` - Add user to the "accept list", try `/help accept` on Freenode * `/unaccept` - Remove a user from the "accept list" * `/acceptlist` - List users on accept lists * `/knock` - Request an /invite/ to a restricted channel * `/invite ` - Invite the given user to the current channel * `/reconnect` - Reconnect to the current server * `/ping` - Send ping to upload current roundtrip time * `/ping ` - Send manually specified ping message Filters * `/filter` - Filter chat messages by space-delimited set of nicknames * `/grep` - Filter chat messages using a regular expression on the message Keyboard Shortcuts ================== * `ESC` quit * `^N` next channel * `^P` previous channel * `M-#` jump to window * `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 * `F3` toggle timestamps * `F4` toggle compressed metadata * `F5` toggle all channel view * `Page Up` scroll up * `Page Down` scroll down * `^B` bold * `^C` color * `^V` reverse video * `^_` underline * `^]` italic * `^O` reset formatting irc-core-1.1.3/Setup.hs0000644000000000000000000000005612622517457013055 0ustar0000000000000000import Distribution.Simple main = defaultMain irc-core-1.1.3/driver/0000755000000000000000000000000012622517457012713 5ustar0000000000000000irc-core-1.1.3/driver/ClientState.hs0000644000000000000000000002403012622517457015465 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} module ClientState where import Control.Concurrent (ThreadId) import Control.Concurrent.STM (TChan, atomically, writeTChan) import Control.DeepSeq (force) import Control.Lens import Control.Monad (foldM, guard, when) import Data.ByteString (ByteString) import Data.Char (isControl) import Data.Foldable (for_) import Data.Functor.Compose import Data.IORef import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Monoid import Data.Set (Set) import Data.Text (Text) import Data.Time (TimeZone, UTCTime) import Graphics.Vty.Image import System.IO (Handle) import qualified Config import qualified Data.ByteString as B import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Text #if !MIN_VERSION_base(4,8,0) import Data.Functor ((<$)) #endif import Irc.Core import Irc.Format import Irc.Message import Irc.Model import Connection import EditBox (EditBox) import qualified EditBox as Edit import ImageUtils (cleanText, nameHighlighter) data ClientConnection = ClientConnection { _ccServerSettings :: ServerSettings , _ccConnection :: IrcConnection , _ccSendChan :: Maybe (IORef Bool, TChan ByteString) , _ccRecvThread :: Maybe ThreadId , _ccSendThread :: Maybe ThreadId } data ClientState = ClientState -- stuff that will need to be split out for mutiple -- servers { _clientServer0 :: ClientConnection , _clientRecvChan :: TChan (UTCTime, MsgFromServer) , _clientErrors :: Maybe Handle , _clientFocus :: Focus , _clientDetailView :: !Bool , _clientTimeView :: !Bool , _clientMetaView :: !Bool , _clientFullView :: !Bool , _clientEditBox :: EditBox , _clientTabPattern :: Maybe String , _clientScrollPos :: Int , _clientHeight :: Int , _clientWidth :: Int , _clientIgnores :: !(Set Identifier) -- Todo: support mask matching , _clientHighlights :: !(Set ByteString) , _clientMessages :: !(Map Identifier MessageList) , _clientNickColors :: [Color] , _clientAutomation :: [EventHandler] , _clientTimers :: Map UTCTime [TimerEvent] , _clientTimeZone :: TimeZone , _clientConfig :: Config.Value } -- TODO: split this record into logical pieces data TimerEvent = DropOperator Identifier | TransmitPing deriving (Read, Show, Eq) data MessageList = MessageList { _mlNewMessages :: !Int , _mlMentioned :: !Bool , _mlMessages :: [(IrcMessage,Image)] } defaultMessageList :: MessageList defaultMessageList = MessageList { _mlNewMessages = 0 , _mlMentioned = False , _mlMessages = [] } data Focus = ChannelFocus Identifier | ChannelInfoFocus Identifier | MaskListFocus Char Identifier deriving (Eq, Ord, Read, Show) data EventHandler = EventHandler { _evName :: String , _evOnEvent :: Identifier -> IrcMessage -> ClientState -> IO ClientState } makeLenses ''ClientState makeLenses ''MessageList makeLenses ''EventHandler makePrisms ''Focus makePrisms ''TimerEvent makeLenses ''ClientConnection resetCurrentChannelMessages :: ClientState -> ClientState resetCurrentChannelMessages st = over (clientMessages . ix (focusedName st)) ( set mlNewMessages 0 . set mlMentioned False ) st -- Return the message part of a message which counts -- toward unread message count. isRelevant :: IrcMessageType -> Maybe Text isRelevant (PrivMsgType msg) = Just msg isRelevant (NoticeMsgType msg) = Just msg isRelevant (ActionMsgType msg) = Just msg isRelevant (ErrorMsgType msg) = Just msg isRelevant _ = Nothing clientInput :: ClientState -> String clientInput = view (clientEditBox . Edit.content) clearInput :: ClientState -> ClientState clearInput = clearTabPattern . over clientEditBox Edit.success -- | Advance the focus element forward. See 'incrementFocus' for -- details. nextFocus :: ClientState -> ClientState nextFocus = incrementFocus nextInSorted -- | Advance the focus element backward. See 'incrementFocus' for -- details. prevFocus :: ClientState -> ClientState prevFocus = incrementFocus prevInSorted -- | Jump to a zero-based index in the set of focus targets. jumpFocus :: Int -> ClientState -> ClientState jumpFocus i = incrementFocus $ \current targets -> if 0 <= i && i < Set.size targets then Set.elemAt i targets else current -- | Find a channel to jump to that is either marked for mention -- or which has new messages jumpActivity :: ClientState -> ClientState jumpActivity st = case active of [] -> st name:_ -> clearTabPattern $ set clientScrollPos 0 $ set clientFocus (ChannelFocus name) st where active = [ name | (name,messages) <- views clientMessages Map.toList st , view mlMentioned messages ] ++ [ name | (name,messages) <- views clientMessages Map.toList st , view mlNewMessages messages > 0 ] -- | 'incrementFocus' allows moving forward and backward through -- a sorted list of channel names and query windows. Information -- windows like mask lists and info lists will always transition -- back to the associated message view before moving forward -- and backward. The server message window is placed at the -- beginning of this rotation. In the case of overflow the focus -- wraps around to the other side of the list. incrementFocus :: (Identifier -> Set Identifier -> Identifier) -> ClientState -> ClientState incrementFocus f st = clearTabPattern $ set clientScrollPos 0 $ set clientFocus focus' st where focus' = case view clientFocus st of ChannelInfoFocus c -> ChannelFocus c MaskListFocus _ c -> ChannelFocus c ChannelFocus c -> ChannelFocus (f c focuses) focuses = Map.keysSet (fullMessageLists st) clearTabPattern :: ClientState -> ClientState clearTabPattern = set clientTabPattern Nothing clientSend :: ByteString -> ClientState -> IO () clientSend x st = for_ (view (clientServer0.ccSendChan) st) $ \(connectedRef,chan) -> do connected <- readIORef connectedRef when connected (atomically (writeTChan chan x)) focusedName :: ClientState -> Identifier focusedName st = case view clientFocus st of ChannelInfoFocus c -> c MaskListFocus _ c -> c ChannelFocus c -> c focusedChan :: ClientState -> Maybe Identifier focusedChan st = case view clientFocus st of ChannelInfoFocus c -> Just c MaskListFocus _ c -> Just c ChannelFocus c | isChannelName c (view (clientServer0.ccConnection) st) -> Just c | otherwise -> Nothing addMessage :: Identifier -> IrcMessage -> ClientState -> ClientState addMessage target message st | view (clientServer0 . ccConnection . connNick) st == target = over (clientMessages . at (views mesgSender userNick message)) (Just . aux . fromMaybe defaultMessageList) st | otherwise = over (clientMessages . at target) (Just . aux . fromMaybe defaultMessageList) st where conn = view (clientServer0 . ccConnection) st isIgnored nick = view (clientIgnores . contains nick) st aux = case views mesgType isRelevant message of Nothing -> over mlMessages (cons (message,error "unused colored message")) Just txt -> updateMessageCount . over mlMessages (cons (message,coloredImage)) where updateMessageCount | isIgnored (views mesgSender userNick message) = id | otherwise = over mlNewMessages (+1) . over mlMentioned (|| mention txt || private) !coloredImage | Text.any isControl txt = cleanText txt | otherwise = force -- avoid holding on to old channel lists $ nameHighlighter (Text.encodeUtf8 txt) (views (connChannels . ix target . chanUsers) Map.keysSet conn) (view connNick conn) (view clientNickColors st) nickTxt = idDenote (view connNick conn) highlights = set (contains nickTxt) True $ view clientHighlights st mention txt = or [ B.isInfixOf term (ircFoldCase (Text.encodeUtf8 txt)) | term <- Set.toList highlights ] private = isNickName target conn && not (view mesgMe message) fullMessageLists :: ClientState -> Map Identifier MessageList fullMessageLists st = view clientMessages st <> views (clientServer0 . ccConnection . connChannels) (defaultMessageList <$) st <> Map.singleton "" defaultMessageList runEventHandlers :: Identifier -> IrcMessage -> ClientState -> IO ClientState runEventHandlers tgt msg st0 = foldM aux st1 hs where st1 = set clientAutomation [] st0 hs = view clientAutomation st0 aux st h = view evOnEvent h tgt msg st nextInSorted :: Ord a => a -> Set a -> a nextInSorted x ys = case Set.lookupGT x ys of Just y -> y Nothing -> case Set.minView ys of Just (y,_) -> y Nothing -> x prevInSorted :: Ord a => a -> Set a -> a prevInSorted x ys = case Set.lookupLT x ys of Just y -> y Nothing -> case Set.maxView ys of Just (y,_) -> y Nothing -> x nextTimerEvent :: UTCTime -> ClientState -> Maybe (TimerEvent, ClientState) nextTimerEvent now = alaf Compose clientTimers aux where aux :: Map UTCTime [TimerEvent] -> Maybe (TimerEvent, Map UTCTime [TimerEvent]) aux timers = do ((trigger,events), timers1) <- Map.minViewWithKey timers guard (trigger <= now) case events of [] -> error "nextTimerEvent: empty entry!" [e] -> return (e, timers1) e:es -> return (e, Map.insert trigger es timers1) filterTimerEvents :: (TimerEvent -> Bool) -> ClientState -> ClientState filterTimerEvents p = over clientTimers (Map.mapMaybe aux) where aux xs | null xs' = Nothing | otherwise = Just xs' where xs' = filter p xs addTimerEvent :: UTCTime -> TimerEvent -> ClientState -> ClientState addTimerEvent trigger e = over clientTimers (Map.insertWith (++) trigger [e]) irc-core-1.1.3/driver/CommandArgs.hs0000644000000000000000000002154512622517457015451 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module CommandArgs where import Config import Config.Lens import Control.Applicative import Control.Exception import Control.Monad (when, unless) import Data.Foldable (traverse_) import Data.Maybe import Data.List (foldl') import Data.Text (Text) import Data.Text.Lens (unpacked) import Data.Version (showVersion) import Network.Socket (PortNumber) import System.Console.GetOpt import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO import System.IO.Error import Control.Lens import qualified Data.Text as Text import qualified Data.Text.IO as Text import ServerSettings import Paths_irc_core defaultSocksPort :: PortNumber defaultSocksPort = 1080 defaultConfigPath :: IO FilePath defaultConfigPath = do dir <- getAppUserDataDirectory "glirc" return (dir "config") data CommandArgs = CommandArgs { _cmdArgNick :: Maybe String , _cmdArgServer :: String , _cmdArgPort :: Maybe Int , _cmdArgHelp :: Bool , _cmdArgVersion :: Bool , _cmdArgReal :: Maybe String , _cmdArgUser :: Maybe String , _cmdArgSaslUser :: Maybe String , _cmdArgDebug :: Maybe FilePath , _cmdArgUserInfo :: Maybe String , _cmdArgTls :: Bool , _cmdArgTlsClientCert :: Maybe FilePath , _cmdArgTlsClientKey :: Maybe FilePath , _cmdArgTlsInsecure :: Bool , _cmdArgConfigFile :: Maybe FilePath , _cmdArgConfigValue:: Value } makeLenses ''CommandArgs emptyCommandArgs :: CommandArgs emptyCommandArgs = CommandArgs { _cmdArgServer = "" , _cmdArgReal = Nothing , _cmdArgUser = Nothing , _cmdArgNick = Nothing , _cmdArgUserInfo = Nothing , _cmdArgSaslUser = Nothing , _cmdArgPort = Nothing , _cmdArgHelp = False , _cmdArgVersion = False , _cmdArgDebug = Nothing , _cmdArgTls = False , _cmdArgTlsClientCert = Nothing , _cmdArgTlsClientKey = Nothing , _cmdArgTlsInsecure = False , _cmdArgConfigFile = Nothing , _cmdArgConfigValue = Sections [] } getCommandArgs :: IO CommandArgs getCommandArgs = do args <- getArgs let (flags, servers, errors) = getOpt Permute optDescrs args r = foldl' (\acc f -> f acc) emptyCommandArgs flags when (view cmdArgHelp r) help when (view cmdArgVersion r) emitVersion unless (null errors) $ do traverse_ (hPutStrLn stderr) errors exitFailure server <- case servers of [server] -> return server [] -> do hPutStrLn stderr "Expected server name argument (try --help)" exitFailure _ -> do hPutStrLn stderr "Too many server name arguments (try --help)" exitFailure v <- loadConfigValue (view cmdArgConfigFile r) return $ set cmdArgServer server $ set cmdArgConfigValue v $ r help :: IO a help = do prog <- getProgName let txt = prog ++ " SERVER" hPutStr stderr (usageInfo txt optDescrs) exitFailure emitVersion :: IO a emitVersion = do putStrLn ("glirc " ++ showVersion version) exitSuccess optDescrs :: [OptDescr (CommandArgs -> CommandArgs)] optDescrs = [ Option "c" [ "config"] (ReqArg (set cmdArgConfigFile . Just) "FILENAME") "Configuration file path (default ~/.glirc/config)" , Option "p" [ "port"] (ReqArg (set cmdArgPort . Just . read) "PORT") "IRC Server Port" , Option "n" [ "nick"] (ReqArg (set cmdArgNick . Just) "NICK") "Nickname" , Option "u" [ "user"] (ReqArg (set cmdArgUser . Just) "USER") "Username" , Option "r" [ "real"] (ReqArg (set cmdArgReal . Just) "REAL") "Real Name" , Option "" ["sasl-user"] (ReqArg (set cmdArgSaslUser . Just) "USER") "SASL username" , Option "d" [ "debug"] (ReqArg (set cmdArgDebug . Just) "FILE") "Debug log filename" , Option "i" [ "userinfo"] (ReqArg (set cmdArgUserInfo . Just) "USERINFO") "CTCP USERINFO Response" , Option "t" [ "tls"] (NoArg (set cmdArgTls True)) "Enable TLS" , Option "" [ "tls-client-cert"] (ReqArg (set cmdArgTlsClientCert . Just) "PATH") "Path to PEM encoded client certificate" , Option "" [ "tls-client-key"] (ReqArg (set cmdArgTlsClientKey . Just) "PATH") "Path to PEM encoded client key" , Option "" [ "tls-insecure"] (NoArg (set cmdArgTlsInsecure True)) "Disable server certificate verification" , Option "v" [ "version"] (NoArg (set cmdArgVersion True)) "Show version" , Option "h" [ "help"] (NoArg (set cmdArgHelp True)) "Show help" ] initialServerSettings :: CommandArgs -> IO ServerSettings initialServerSettings !args = do env <- getEnvironment let username = fromMaybe "" (lookup "USER" env) password = lookup "IRCPASSWORD" env saslpassword = lookup "SASLPASSWORD" env nick = fromMaybe username (view cmdArgNick args <|> defaultStr hostTxt "nick" args) hostTxt = Text.pack (view cmdArgServer args) return ServerSettings { _ssNick = nick , _ssUser = fromMaybe username $ view cmdArgUser args <|> defaultStr hostTxt "username" args , _ssReal = fromMaybe username $ view cmdArgReal args <|> defaultStr hostTxt "realname" args , _ssUserInfo = fromMaybe username $ view cmdArgUserInfo args <|> defaultStr hostTxt "userinfo" args , _ssPassword = password <|> defaultStr hostTxt "password" args , _ssSaslCredential = (saslpassword <|> defaultStr hostTxt "sasl-password" args) <&> \p -> (fromMaybe nick (view cmdArgSaslUser args <|> defaultStr hostTxt "sasl-username" args), p) , _ssHostName = view cmdArgServer args , _ssPort = fromIntegral <$> view cmdArgPort args <|> fromIntegral <$> defaultNum hostTxt "port" args , _ssTls = view cmdArgTls args || fromMaybe False (defaultBool hostTxt "tls" args) , _ssTlsInsecure = view cmdArgTlsInsecure args , _ssTlsClientCert = view cmdArgTlsClientCert args <|> defaultStr hostTxt "tls-client-cert" args , _ssTlsClientKey = view cmdArgTlsClientKey args <|> defaultStr hostTxt "tls-client-key" args , _ssConnectCmds = toListOf (cmdArgConfigValue . configPath hostTxt "connect-cmds" . values . text) args , _ssSocksProxy = do h <- defaultStr hostTxt "socks-host" args let p = maybe defaultSocksPort fromIntegral $ defaultNum hostTxt "socks-port" args return (h,p) } loadConfigValue :: Maybe FilePath -> IO Value loadConfigValue mbFp = case mbFp of Just fp -> process fp Nothing -> do fp <- defaultConfigPath process fp `catch` \e -> if isDoesNotExistError e then return emptyConfig else throwIO e where emptyConfig = Sections [] process fp = do raw <- Text.readFile fp case parse raw of Right v -> return v Left errMsg -> do hPutStrLn stderr "Configuration error" hPutStrLn stderr (fp ++ ":" ++ errMsg) exitFailure -- | Apply a function to the 'Bool' contained inside the given -- 'Value' when it is a @Bool@. bool :: Applicative f => (Bool -> f Bool) -> Value -> f Value bool = atom . _Bool -- | Map 'True' to @"yes"@ and 'False' to @"no"@ _Bool :: Prism' Atom Bool _Bool = prism' (\b -> if b then "yes" else "no") (\a -> case a of "yes" -> Just True "no" -> Just False _ -> Nothing) ------------------------------------------------------------------------ -- Look up settings for a given server from the config ------------------------------------------------------------------------ hostnameMatch :: Text -> Value -> Bool hostnameMatch = elemOf (key "hostname" . text) configPath :: (Applicative f, Contravariant f) => Text -> Text -> LensLike' f Value Value configPath hostname name = failing (key "servers" . values . filtered (hostnameMatch hostname) . key name) (key "defaults" . key name) defaultStr :: Text -> Text -> CommandArgs -> Maybe String defaultStr hostname i = preview (cmdArgConfigValue . configPath hostname i . text . unpacked) defaultBool :: Text -> Text -> CommandArgs -> Maybe Bool defaultBool hostname i = preview (cmdArgConfigValue . configPath hostname i . bool) defaultNum :: Text -> Text -> CommandArgs -> Maybe Integer defaultNum hostname i = preview (cmdArgConfigValue . configPath hostname i . number) irc-core-1.1.3/driver/CommandParser.hs0000644000000000000000000001220012622517457015775 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module CommandParser ( Parser , runParser , pChannel , pNick , pRemaining , pRemainingNoSp , pRemainingNoSpLimit , pToken , pValidToken , pTarget , pChar , pSatisfy , pHaskell , pAnyChar , pNumber , commandsParser , many' ) where import Data.Char import Data.List (find) import Text.Read (readMaybe) import Control.Monad import Control.Lens import Control.Applicative import Graphics.Vty.Image hiding ((<|>)) import qualified Graphics.Vty.Image as Vty import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import ClientState import Irc.Model import Irc.Format import HaskellHighlighter import ImageUtils newtype Parser a = Parser (String -> (String, Image, Maybe a)) deriving (Functor) runParser :: Parser a -> String -> (Image, Maybe a) runParser (Parser p) s | all isSpace rest = (img Vty.<|> stringWithControls defAttr rest, res) | otherwise = (img Vty.<|> stringWithControls (withForeColor defAttr red) rest, Nothing) where (rest,img,res) = p s instance Applicative Parser where pure x = Parser (\s -> (s,emptyImage,Just x)) Parser f <*> Parser x = Parser (\s -> case f s of (s1,i1,r1) -> case x s1 of (s2,i2,r2) -> (s2,i1 Vty.<|> i2,r1<*>r2)) instance Alternative Parser where empty = Parser (\s -> (s,emptyImage,Nothing)) Parser x <|> Parser y = Parser $ \s -> case (x s,y s) of (rx@(_,_,Just{}),_) -> rx (_,ry@(_,_,Just{})) -> ry (rx,_) -> rx pAnyChar :: Parser Char pAnyChar = pValidToken "character" $ \t -> case t of [x] -> Just x _ -> Nothing pValidToken :: String -> (String -> Maybe a) -> Parser a pValidToken name validate = Parser $ \s -> let (w,s1) = span (==' ') s (t,s2) = break (==' ') s1 img c = stringWithControls (withForeColor defAttr c) (w ++ t) in if null t then ("", char defAttr ' ' Vty.<|> stringWithControls (withStyle defAttr reverseVideo) name Vty.<|> stringWithControls defAttr (drop (length name + 1) w) , Nothing) else case validate t of Just x -> (s2, img green, Just x) Nothing -> (s2, img red, Nothing) pToken :: String -> Parser String pToken name = pValidToken name Just pRemaining :: Parser String pRemaining = Parser (\s -> ("", stringWithControls defAttr s, Just s)) pRemainingNoSp :: Parser String pRemainingNoSp = fmap (dropWhile isSpace) pRemaining pRemainingNoSpLimit :: Int -> Parser String pRemainingNoSpLimit len = Parser (\s -> let (w,s') = span (==' ') s (a,b) = splitAt len (dropWhile isSpace s') in if null b then ("", stringWithControls defAttr (w++a), Just a) else ("", stringWithControls defAttr (w++a) Vty.<|> stringWithControls (withForeColor defAttr red) b, Nothing)) pChannel :: ClientState -> Parser Identifier pChannel st = pValidToken "channel" $ \chan -> do let ident = asIdentifier chan guard (isChannelName ident (view (clientServer0 . ccConnection) st)) return ident pTarget :: Parser Identifier pTarget = pValidToken "target" (Just . asIdentifier) pNick :: ClientState -> Parser Identifier pNick st = pValidToken "nick" $ \nick -> do let ident = asIdentifier nick guard (isNickName ident (view (clientServer0 . ccConnection) st)) return ident asIdentifier :: String -> Identifier asIdentifier = mkId . Text.encodeUtf8 . Text.pack pChar :: Char -> Parser Char pChar c = pSatisfy [c] (== c) pSatisfy :: String -> (Char -> Bool) -> Parser Char pSatisfy name f = Parser (\s -> case s of c1:s1 | f c1 -> (s1, char defAttr c1, Just c1) | otherwise -> (s1, emptyImage, Nothing) [] -> (s, string (withStyle defAttr reverseVideo) (' ':name), Nothing)) pHaskell :: Parser String pHaskell = Parser (\s -> ("", cleanText (Text.pack (highlightHaskell s)), Just (drop 1 (highlightHaskell s)))) commandsParser :: String -> [(String, [String], Parser a)] -> (Image, Maybe a) commandsParser input cmds = case find matchCommand cmds of Just p -> over _1 (\img -> char defAttr '/' Vty.<|> stringWithControls (withForeColor defAttr yellow) cmd Vty.<|> img) (runParser (view _3 p) rest) Nothing -> ( char defAttr '/' Vty.<|> stringWithControls (withForeColor defAttr red) (drop 1 input) , Nothing) where (cmd,rest) = break (==' ') (drop 1 input) matchCommand (c,cs,_) = cmd `elem` c:cs -- | Many parser that works in this infinite model -- NOTE: MUST BE END OF PARSER! many' :: Parser a -> Parser [a] many' p = [] <$ pEnd <|> liftA2 (:) p (many' p) pEnd :: Parser () pEnd = Parser (\s -> if all isSpace s then ("", string defAttr s, Just ()) else (s , emptyImage , Nothing)) pNumber :: Parser Int pNumber = pValidToken "number" readMaybe irc-core-1.1.3/driver/ConnectCmds.hs0000644000000000000000000000160412622517457015450 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module ConnectCmds (connectCmds) where import Control.Lens import Data.Foldable (for_) import Data.Text.Encoding import Data.Monoid ((<>)) import Irc.Message import Irc.Format import ClientState import ServerSettings connectCmds :: EventHandler connectCmds = EventHandler { _evName = "connect commands" , _evOnEvent = handler } handler :: Identifier -> IrcMessage -> ClientState -> IO ClientState handler ident mesg st | ident == "" , views mesgSender userNick mesg == "Welcome" = do let cmds = view (clientServer0 . ccServerSettings . ssConnectCmds) st for_ cmds $ \cmd -> clientSend (encodeUtf8 cmd<>"\r\n") st return st | otherwise = return (reschedule st) -- Reschedule the autojoin handler for the next message reschedule :: ClientState -> ClientState reschedule = over clientAutomation (cons connectCmds) irc-core-1.1.3/driver/Connection.hs0000644000000000000000000001050412622517457015346 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This module is responsible for creating 'Connection' values -- for a particular server as specified by its 'ServerSettings' module Connection ( -- * Settings ServerSettings(..) , ssHostName , ssPort , ssTls , ssTlsClientCert , ssTlsClientKey -- * Operations , connect , getRawIrcLine ) where import Control.Lens import Data.ByteString (ByteString) import Data.Default.Class (def) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text.Lens (unpacked) 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_strong) import System.X509 (getSystemCertificateStore) import qualified Config import qualified Config.Lens as Config import qualified Data.ByteString.Char8 as B8 import ServerSettings -- | This behaves like 'connectionGetLine' but it strips off the @'\r'@ -- IRC calls for 512 byte packets I rounded off to 1024. getRawIrcLine :: Connection -> IO ByteString getRawIrcLine h = do b <- connectionGetLine 1024 h return (if B8.null b then b else B8.init b) -- empty lines will still fail, just later and nicely buildConnectionParams :: Config.Value -> ServerSettings -> IO ConnectionParams buildConnectionParams config args = do useSecure <- if view ssTls args then fmap Just (buildTlsSettings config args) else return Nothing let proxySettings = fmap (uncurry SockSettingsSimple) (view ssSocksProxy 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 :: Config.Value -> IO CertificateStore buildCertificateStore config = do systemStore <- getSystemCertificateStore userCerts <- traverse readSignedObject (configExtraCertificates config) let userStore = makeCertificateStore (concat userCerts) return (userStore <> systemStore) configExtraCertificates :: Config.Value -> [FilePath] configExtraCertificates = toListOf $ Config.key "server-certificates" . Config.list . folded . Config.text . unpacked buildTlsSettings :: Config.Value -> ServerSettings -> IO TLSSettings buildTlsSettings config args = do store <- buildCertificateStore config let portString = B8.pack (show (view ssPort args)) paramsClient = defaultParamsClient (view ssHostName args) portString validationCache | view ssTlsInsecure args = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ()) | otherwise = exceptionValidationCache [] return $ TLSSettings paramsClient { clientSupported = def { supportedCiphers = ciphersuite_strong } , clientHooks = def { onCertificateRequest = \_ -> loadClientCredentials args } , clientShared = def { sharedCAStore = store , sharedValidationCache = validationCache } } 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 :: Config.Value -> ServerSettings -> IO Connection connect config args = do connectionContext <- initConnectionContext connectionParams <- buildConnectionParams config args connectTo connectionContext connectionParams irc-core-1.1.3/driver/CtcpHandler.hs0000644000000000000000000000500112622517457015432 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module CtcpHandler (ctcpHandler) where import Control.Lens import Control.Monad import Data.ByteString (ByteString) import Data.Monoid import Data.Time (formatTime, getZonedTime) import Data.Version (showVersion) import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as Text import qualified Data.Text.Encoding as Text #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif import ClientState import ServerSettings import Irc.Format import Irc.Message import Irc.Cmd import Paths_irc_core (version) versionString :: ByteString versionString = "glirc " <> B8.pack (showVersion version) sourceString :: ByteString sourceString = "https://github.com/glguy/irc-core" ctcpHandler :: EventHandler ctcpHandler = EventHandler { _evName = "CTCP replies" , _evOnEvent = \_ msg st -> do let sender = views mesgSender userNick msg forOf_ (mesgType . _CtcpReqMsgType) msg $ \(command,params) -> -- Don't send responses to ignored users unless (view (clientIgnores . contains sender) st) $ case command of "CLIENTINFO" -> clientSend (ctcpResponseCmd sender "CLIENTINFO" "ACTION CLIENTINFO FINGER PING SOURCE TIME USERINFO VERSION") st "VERSION" -> clientSend (ctcpResponseCmd sender "VERSION" versionString) st "USERINFO" -> clientSend (ctcpResponseCmd sender "USERINFO" (views (clientServer0 . ccServerSettings . ssUserInfo) (Text.encodeUtf8 . Text.pack) st)) st "PING" -> clientSend (ctcpResponseCmd sender "PING" params) st "SOURCE" -> clientSend (ctcpResponseCmd sender "SOURCE" sourceString) st "FINGER" -> clientSend (ctcpResponseCmd sender "FINGER" "Username and idle time unavailable") st "TIME" -> do now <- getZonedTime let resp = formatTime defaultTimeLocale "%a %d %b %Y %T %Z" now clientSend (ctcpResponseCmd sender "TIME" (B8.pack resp)) st _ -> return () -- reschedule handler return (over clientAutomation (cons ctcpHandler) st) } irc-core-1.1.3/driver/EditBox.hs0000644000000000000000000000757012622517457014616 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module EditBox ( EditBox , content , pos , 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 } deriving (Read, Show) makeLenses ''EditBox empty :: EditBox empty = EditBox { _content = "" , _pos = 0 , _history = [] , _historyPos = -1 , _yankBuffer = "" } updateYankBuffer :: String -> EditBox -> EditBox updateYankBuffer str | null str = id | otherwise = set yankBuffer str success :: EditBox -> EditBox success e = over history (cons (view content e)) $ set content "" $ set historyPos (-1) $ set pos 0 e 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 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) $ over pos (min (views content length e - 1)) e where (a,b) = splitAt (view pos e) (view content e) delete :: EditBox -> EditBox delete e | view pos e < views content length e = removeImpl e | otherwise = e backspace :: EditBox -> EditBox backspace e | view pos e > 0 = removeImpl (left e) | otherwise = e home :: EditBox -> EditBox home e = set pos 0 e end :: EditBox -> EditBox end e = set pos (views content length e) e killEnd :: EditBox -> EditBox killEnd e = set content keep $ updateYankBuffer kill e where (keep,kill) = splitAt (view pos e) (view content e) killHome :: EditBox -> EditBox killHome e = set content keep $ set pos 0 $ updateYankBuffer kill e where (kill,keep) = splitAt (view pos e) (view content e) paste :: EditBox -> EditBox paste e = insertString (view yankBuffer e) e 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 :: Char -> EditBox -> EditBox insert c = insertString [c] 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) left :: EditBox -> EditBox left e = over pos (max 0 . subtract 1) e right :: EditBox -> EditBox right e = over pos (min (views content length e) . (+1)) e 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 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 irc-core-1.1.3/driver/HaskellHighlighter.hs0000644000000000000000000000433212622517457017013 0ustar0000000000000000module HaskellHighlighter (highlightHaskell) where import Language.Haskell.Lexer highlightHaskell :: String -> String highlightHaskell src = init (colorize (lexerPass0 (src++"\n"))) -- the lexer requires this newline for single-line comments to work colorize :: [PosToken] -> String colorize [] = "" colorize ((_,(_,"`")):(Varid,(_,str)):(_,(_,"`")):rest) = orange ("`" ++ str ++ "`") ++ colorize rest colorize ((tok, (_,str)):rest) = aux str ++ colorize rest where aux = case tok of Varid -> id Conid -> id Varsym -> orange Consym -> orange Reservedid -> case str of "case" -> orange "of" -> orange "do" -> orange "if" -> orange "then" -> orange "else" -> orange "let" -> orange "in" -> orange "import" -> pink "infixl" -> pink "infixr" -> pink "infix" -> pink "_" -> id _ -> green Reservedop -> orange Specialid -> id IntLit -> red FloatLit -> red CharLit -> red StringLit -> red Qvarid -> id Qconid -> id Qvarsym -> orange Qconsym -> orange Special -> id Whitespace -> id NestedCommentStart -> comment NestedComment -> comment LiterateComment -> comment Commentstart -> comment Comment -> comment ErrorToken -> id GotEOF -> id ModuleName -> id ModuleAlias -> id Layout -> id Indent _ -> id Open _ -> id TheRest -> id comment :: String -> String comment = cyan green, orange, red, cyan, pink :: String -> String green x = "\03\&03" ++ x ++ "\03\02\02" red x = "\03\&04" ++ x ++ "\03\02\02" orange x = "\03\&07" ++ x ++ "\03\02\02" cyan x = "\03\&11" ++ x ++ "\03\02\02" pink x = "\03\&13" ++ x ++ "\03\02\02" irc-core-1.1.3/driver/ImageUtils.hs0000644000000000000000000001666012622517457015323 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module ImageUtils where import Control.Lens import Control.Monad (guard) import Data.Array import Data.ByteString (ByteString) import Data.Char (isControl, isAlphaNum) import Data.Set (Set) import Data.Text (Text) import Graphics.Vty.Image import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.Set as Set import qualified Data.Text as Text import Irc.Format data Formatting = Formatting { _fmtFore :: Maybe Color , _fmtBack :: Maybe Color , _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse :: !Bool } makeLenses ''Formatting lineWrap :: Int -> Image -> [Image] lineWrap width img | w <= width = [img <|> char defAttr ' '] -- vty forgets to turn off formatting | otherwise = cropRight width img : lineWrap width (cropLeft (w-width) img) where w = imageWidth img cleanText :: Text -> Image cleanText = ircFormattedText renderFullUsermask :: UserInfo -> Image renderFullUsermask u = utf8Bytestring' (withForeColor defAttr yellow) (idBytes (userNick u)) <|> userpart <|> hostpart where userpart = case userName u of Just x -> string defAttr "!" <|> utf8Bytestring' (withForeColor defAttr green) x Nothing -> emptyImage hostpart = case userHost u of Just x -> string defAttr "@" <|> utf8Bytestring' (withForeColor defAttr red) x Nothing -> emptyImage ircFormattedText :: Text -> Image ircFormattedText = ircFormattedText' defaultFormatting ircFormattedText' :: Formatting -> Text -> Image ircFormattedText' fmt t = text' (formattingAttr fmt) a <|> rest where (a,b) = Text.break isControl t rest = case Text.uncons b of Nothing -> emptyImage Just ('\x02',xs) -> ircFormattedText' (over fmtBold not fmt) xs Just ('\x0F',xs) -> ircFormattedText' defaultFormatting xs Just ('\x16',xs) -> ircFormattedText' (over fmtReverse not fmt) xs Just ('\x1D',xs) -> ircFormattedText' (over fmtItalic not fmt) xs Just ('\x1F',xs) -> ircFormattedText' (over fmtUnderline not fmt) xs Just ('\x03',xs) | Just (fore,xs1) <- colorNumber xs -> case Text.uncons xs1 of Just (',',xs2) | Just (back,xs3) <- colorNumber xs2 -> ircFormattedText' (set fmtFore (Just fore) (set fmtBack (Just back) fmt)) xs3 _ -> ircFormattedText' (set fmtFore (Just fore) (set fmtBack Nothing fmt)) xs1 | otherwise -> ircFormattedText' (set fmtFore Nothing (set fmtBack Nothing fmt)) xs Just (_,xs) -> ircFormattedText' fmt xs colorNumber :: Text -> Maybe (Color, Text) colorNumber t = do (c1,c2,t1) <- splitNumber t case (c1,c2) of ('0','0') -> Just (white , t1) -- white ('0','1') -> Just (black , t1) -- black ('0','2') -> Just (blue , t1) -- blue ('0','3') -> Just (green , t1) -- green ('0','4') -> Just (red , t1) -- red ('0','5') -> Just (rgbColor' 127 0 0 , t1) -- brown ('0','6') -> Just (rgbColor' 156 0 156 , t1) -- purple ('0','7') -> Just (rgbColor' 252 127 0 , t1) -- yellow ('0','8') -> Just (yellow , t1) -- yellow ('0','9') -> Just (brightGreen , t1) -- green ('1','0') -> Just (cyan , t1) -- brightBlue ('1','1') -> Just (brightCyan , t1) -- brightCyan ('1','2') -> Just (brightBlue , t1) -- brightBlue ('1','3') -> Just (rgbColor' 255 0 255 , t1) -- brightRed ('1','4') -> Just (rgbColor' 127 127 127, t1) -- brightBlack ('1','5') -> Just (rgbColor' 210 210 210, t1) -- brightWhite _ -> Nothing -- Take up to two digits off the front of a text. If there is only -- a single digit pretend like the first digit was a 0 splitNumber :: Text -> Maybe (Char,Char,Text) splitNumber t = do let isNumber x = '0' <= x && x <= '9' (c1,t1) <- Text.uncons t guard (isNumber c1) case Text.uncons t1 of Just (c2,t2) | isNumber c2 -> Just (c1,c2,t2) _ -> Just ('0',c1,t1) rgbColor' :: Int -> Int -> Int -> Color rgbColor' = rgbColor -- fix the type to Int defaultFormatting :: Formatting defaultFormatting = Formatting { _fmtFore = Nothing , _fmtBack = Nothing , _fmtBold = False , _fmtItalic = False , _fmtUnderline = False , _fmtReverse = False } formattingAttr :: Formatting -> Attr formattingAttr fmt = addForeColor $ addBackColor $ flag (view fmtBold fmt) bold $ flag (view fmtUnderline fmt) underline $ flag (view fmtReverse fmt) reverseVideo -- no italic support $ defAttr where addForeColor x = case view fmtFore fmt of Nothing -> x Just c -> withForeColor x c addBackColor x = case view fmtBack fmt of Nothing -> x Just c -> withBackColor x c flag True s x = withStyle x s flag False _ x = x identImg :: Attr -> Identifier -> Image identImg attr = utf8Bytestring' attr . idBytes -- | Render a string and replace the control characters with -- reversed video of the associated control key. stringWithControls :: Attr -> String -> Image stringWithControls _ [] = emptyImage stringWithControls attr xs = case break isControl xs of (a,[]) -> string attr a (a,b:bs) -> string attr a <|> char (withStyle attr reverseVideo) (controls ! fromEnum b) <|> stringWithControls attr bs where controls = listArray (0,0x1f) ('@':['A'..'Z']++"[\\]^_") nameHighlighter :: ByteString -> Set Identifier -> Identifier -> [Color] -> Image nameHighlighter msg users me colors = aux 0 0 where lowmsg = ircFoldCase msg n = B8.length lowmsg ncolors = length colors aux lo hi | hi == n = utf8Bytestring' defAttr (B8.drop lo msg) | otherwise = case nameLookup identFromHi users of Nothing -> aux lo (advance hi) Just hit -> utf8Bytestring' defAttr (B8.take (hi-lo) (B8.drop lo msg)) <|> utf8Bytestring' (withForeColor defAttr color) matchRegion <|> aux hi' hi' where -- use the original match region to preserve original case matchRegion = B8.take (B8.length (idBytes hit)) (B8.drop hi msg) hi' = hi + B8.length (idDenote hit) color | me == hit = red | otherwise = colors !! mod (nickHash (idDenote hit)) ncolors where identFromHi = mkId (B8.drop hi lowmsg) advance curHi | curHi + 1 == n = curHi + 1 | isAlphaNum (B8.index lowmsg curHi) , isAlphaNum (B8.index lowmsg (curHi+1)) = advance (curHi+1) | otherwise = curHi+1 nameLookup :: Identifier -> Set Identifier -> Maybe Identifier nameLookup haystack s = case Set.lookupLE haystack s of Just x | idDenote x `B8.isPrefixOf` idDenote haystack , boundaryCheck (idDenote x) -> Just x _ -> Nothing where boundaryCheck needle = B8.length needle == B8.length (idDenote haystack) || not (isAlphaNum (B8.index (idDenote haystack) (B8.length needle))) nickHash :: ByteString -> Int nickHash n = let h1 = B.foldl' (\acc b -> fromIntegral b + 33 * acc) 0 n in h1 + (h1 `quot` 32) irc-core-1.1.3/driver/Main.hs0000644000000000000000000010505312622517457014137 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} module Main where import Control.Applicative hiding ((<|>)) import Control.Concurrent (killThread, forkIO) import Control.Concurrent.STM import Control.Exception import Control.Lens import Control.Monad import Control.Monad.Trans.State import Control.Monad.IO.Class import Data.ByteString (ByteString) import Data.Char import Data.Fixed (Centi, Pico, showFixed) import Data.Foldable (for_, traverse_) import Data.List (elemIndex) import Data.List.Split (chunksOf) import Data.IORef import Data.Maybe (fromMaybe) import Data.Monoid import Data.Set (Set) import Data.Text (Text) import Data.Time import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Traversable (for) import Graphics.Vty import Network.Connection import System.IO import System.IO.Error (isEOFError) import qualified Config import qualified Config.Lens as C import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Lens as Text import qualified Data.Text.Encoding as Text import Irc.Core import Irc.Cmd import Irc.Format import Irc.Message import Irc.Model import Irc.RateLimit import ConnectCmds (connectCmds) import ClientState import Connection (connect, getRawIrcLine) import CommandArgs import CommandParser import CtcpHandler import ImageUtils import Moderation import ServerSettings import Views.BanList import Views.Channel import Views.ChannelInfo import qualified EditBox as Edit data SendType = SendCtcp String | SendPriv | SendNotice | SendAction makePrisms ''SendType main :: IO () main = do args <- getCommandArgs let debugFile = view cmdArgDebug args `mplus` preview ( cmdArgConfigValue . C.key "debug-file" . C.text . Text.unpacked) args hErr <- for debugFile $ \fn -> do hErr <- openFile fn WriteMode hSetBuffering hErr NoBuffering return hErr vtyEventChan <- atomically newTChan recvChan <- atomically newTChan withVty $ \vty -> do _ <- forkIO (vtyEventLoop vtyEventChan vty) settings <- initialServerSettings args server0 <- startIrcConnection (view cmdArgConfigValue args) recvChan settings hErr (width,height) <- displayBounds (outputIface vty) zone <- getCurrentTimeZone let st0 = ClientState { _clientServer0 = server0 , _clientRecvChan = recvChan , _clientErrors = hErr , _clientFocus = ChannelFocus "" , _clientDetailView = False , _clientTimeView = True , _clientMetaView = True , _clientFullView = False , _clientEditBox = Edit.empty , _clientTabPattern = Nothing , _clientScrollPos = 0 , _clientHeight = height , _clientWidth = width , _clientIgnores = mempty , _clientHighlights = mempty , _clientMessages = mempty , _clientNickColors = defaultNickColors , _clientAutomation = [ctcpHandler,cancelDeopTimerOnDeop,connectCmds] , _clientTimers = mempty , _clientTimeZone = zone , _clientConfig = view cmdArgConfigValue args } st1 <- schedulePing st0 driver vty vtyEventChan recvChan st1 withVty :: (Vty -> IO a) -> IO a withVty k = do cfg <- standardIOConfig bracket (mkVty cfg) shutdown k startIrcConnection :: Config.Value {- ^ user configuration -} -> TChan (UTCTime, MsgFromServer) {- ^ incoming client events -} -> ServerSettings {- ^ network parameters -} -> Maybe Handle {- ^ error log -} -> IO ClientConnection startIrcConnection config recvChan settings hErr = do connectRes <- try (connect config settings) case connectRes of Left e -> connectionFailed e Right h -> connectionSuceeded h where utf8Bytes = Text.encodeUtf8 . Text.pack nick = mkId (utf8Bytes (view ssNick settings)) user = utf8Bytes (view ssUser settings) real = utf8Bytes (view ssReal settings) sasl = over (mapped.both) utf8Bytes (view ssSaslCredential settings) pass = over mapped utf8Bytes (view ssPassword settings) connectionSuceeded h = do sendChan <- atomically newTChan connectedRef <- newIORef True sendThreadId <- forkIO (sendLoop connectedRef sendChan h) recvThreadId <- forkIO (socketLoop recvChan h hErr) initializeConnection pass nick user real h return ClientConnection { _ccServerSettings = settings , _ccConnection = defaultIrcConnection { _connNick = nick , _connSasl = sasl } , _ccSendChan = Just (connectedRef, sendChan) , _ccRecvThread = Just recvThreadId , _ccSendThread = Just sendThreadId } connectionFailed (SomeException e) = do let eUtf8 = utf8Bytes (show e) now <- getCurrentTime atomically (writeTChan recvChan (now, Error eUtf8)) return ClientConnection { _ccServerSettings = settings , _ccConnection = defaultIrcConnection { _connNick = nick , _connSasl = sasl } , _ccSendChan = Nothing , _ccRecvThread = Nothing , _ccSendThread = Nothing } initializeConnection :: Maybe ByteString {- ^ server password -} -> Identifier {- ^ nickname -} -> ByteString {- ^ username -} -> ByteString {- ^ realname -} -> Connection -> IO () initializeConnection pass nick user real h = do connectionPut h capLsCmd traverse_ (connectionPut h . passCmd) pass connectionPut h (nickCmd nick) connectionPut h (userCmd user real) driver :: Vty -> TChan Event -> TChan (UTCTime, MsgFromServer) -> ClientState -> IO () driver vty vtyEventChan ircMsgChan st0 = do let (scroll', pic) = picForState st0 st1 = set clientScrollPos scroll' st0 update vty pic e <- readEitherTChan vtyEventChan ircMsgChan case e of Left vtyEvent -> processVtyEvent st1 vtyEvent Right (time,msg) -> processIrcMsg st1 time msg where -- processVtyEvent and processIrcMsg jump here continue = considerTimers . resetCurrentChannelMessages considerTimers st = do now <- getCurrentTime case nextTimerEvent now st of Nothing -> driver vty vtyEventChan ircMsgChan st Just (e,st') -> processTimerEvent e st' processTimerEvent e st = case e of TransmitPing -> do sendTimestampPing st st' <- schedulePing st considerTimers st' DropOperator chan -> do clientSend (modeCmd chan ["-o",views connNick idBytes conn]) st considerTimers st where conn = view (clientServer0 . ccConnection) st processVtyEvent st event = case event of EvResize width height -> continue $ set clientWidth width $ set clientHeight height st EvKey (KChar 'l') [MCtrl] -> do refresh vty (width,height) <- displayBounds (outputIface vty) continue $ set clientHeight height $ set clientWidth width st EvKey key mods -> do r <- keyEvent key mods st case r of KeepGoing st' -> continue st' Exit -> return () _ -> continue st processIrcMsg st time msg = do let m :: IO (Either String IrcConnection, ClientState) m = flip runStateT st $ runLogic time (interpretLogicOp ircMsgChan) (advanceModel msg (view (clientServer0 . ccConnection) st)) res <- m case res of (Left e,st') -> do for_ (view clientErrors st) $ \h -> hPutStrLn h ("!!! " ++ e) continue st' (Right conn',st') -> do continue (set (clientServer0 . ccConnection) conn' st') interpretLogicOp :: TChan (UTCTime, MsgFromServer) -> LogicOp a -> StateT ClientState IO a interpretLogicOp ircMsgChan (Expect k) = do fmap (k.snd) (liftIO (atomically (readTChan ircMsgChan))) interpretLogicOp _ (Emit bytes r) = do st <- get liftIO (clientSend bytes st) return r interpretLogicOp _ (Record target message r) = do put =<< liftIO . runEventHandlers target message . addMessage target message =<< get return r ------------------------------------------------------------------------ -- Key Event Handlers! ------------------------------------------------------------------------ data KeyEventResult = KeepGoing ClientState | Exit changeInput :: (Edit.EditBox -> Edit.EditBox) -> ClientState -> ClientState changeInput f st = clearTabPattern (over clientEditBox f st) inputLogic :: ClientState -> (Image, IO KeyEventResult) inputLogic st = case clientInput st of '/':_ -> case commandEvent st of (img, Nothing) -> (img, return (KeepGoing st)) (img, Just m ) -> (img, m) txt -> (stringWithControls defAttr txt, fmap KeepGoing (doSendMessageCurrent SendPriv st)) keyEvent :: Key -> [Modifier] -> ClientState -> IO KeyEventResult keyEvent k ms st = let more = return . KeepGoing in case (k,ms) of (KFun 2 , [] ) -> more $ over clientDetailView not st (KFun 3 , [] ) -> more $ over clientTimeView not st (KFun 4 , [] ) -> more $ over clientMetaView not st (KFun 5 , [] ) -> more $ over clientFullView not st (KPageUp , _ ) -> more $ scrollUp st (KPageDown, _ ) -> more $ scrollDown st (KChar 'n', [MCtrl]) -> more $ nextFocus st (KChar 'p', [MCtrl]) -> more $ prevFocus st (KChar c , [MMeta]) | Just i <- jumpNumber c -> more $ jumpFocus i st (KChar 'a', [MMeta]) -> more $ jumpActivity st (KBS , _ ) -> more $ changeInput Edit.backspace st (KChar 'd', [MCtrl]) -> more $ changeInput Edit.delete st (KDel , _ ) -> more $ changeInput Edit.delete st (KUp , _ ) -> more $ maybe st clearTabPattern $ clientEditBox Edit.earlier st (KDown , _ ) -> more $ maybe st clearTabPattern $ clientEditBox Edit.later st (KLeft , _ ) -> more $ changeInput Edit.left st (KRight , _ ) -> more $ changeInput Edit.right st (KHome , _ ) -> more $ changeInput Edit.home st (KEnd , _ ) -> more $ changeInput Edit.end st (KChar 'a', [MCtrl]) -> more $ changeInput Edit.home st (KChar 'e', [MCtrl]) -> more $ changeInput Edit.end st (KChar 'u', [MCtrl]) -> more $ changeInput Edit.killHome st (KChar 'k', [MCtrl]) -> more $ changeInput Edit.killEnd st (KChar 'y', [MCtrl]) -> more $ changeInput Edit.paste st (KChar 'w', [MCtrl]) -> more $ changeInput (Edit.killWord True) st (KChar 'b', [MMeta]) -> more $ changeInput Edit.leftWord st (KChar 'f', [MMeta]) -> more $ changeInput Edit.rightWord st (KChar '\t', [] ) -> more $ tabComplete st (KChar 'b', [MCtrl]) -> more $ changeInput (Edit.insert '\^B') st (KChar 'c', [MCtrl]) -> more $ changeInput (Edit.insert '\^C') st (KChar ']', [MCtrl]) -> more $ changeInput (Edit.insert '\^]') st (KChar '_', [MCtrl]) -> more $ changeInput (Edit.insert '\^_') st (KChar 'o', [MCtrl]) -> more $ changeInput (Edit.insert '\^O') st (KChar 'v', [MCtrl]) -> more $ changeInput (Edit.insert '\^V') st (KChar c , [] ) -> more $ changeInput (Edit.insert c) st (KEnter , [] ) -> snd (inputLogic st) _ -> more st -- | Map keyboard numbers 1-9,0 to the numbers 0-9 jumpNumber :: Char -> Maybe Int jumpNumber c = elemIndex c jumps where jumps = "1234567890qwertyuiop" -- TODO: Don't scroll off the end of the channel scrollOffset :: ClientState -> Int scrollOffset st = max 1 (view clientHeight st - 4) scrollUp :: ClientState -> ClientState scrollUp st = over clientScrollPos (+ scrollOffset st) st scrollDown :: ClientState -> ClientState scrollDown st = over clientScrollPos (\x -> max 0 (x - scrollOffset st)) st doSendMessageCurrent :: SendType -> ClientState -> IO ClientState doSendMessageCurrent sendType st = case view clientFocus st of ChannelFocus c | not (null (dropWhile isSpace (clientInput st))) -> doSendMessage sendType c (Text.pack (clientInput st)) st _ -> return st doSendMessage :: SendType -> Identifier -> Text -> ClientState -> IO ClientState doSendMessage sendType _ message st | Text.null message && hasn't _SendCtcp sendType = return st doSendMessage sendType target message st = do let bs = case sendType of SendPriv -> privMsgCmd target (Text.encodeUtf8 message) SendAction -> privMsgCmd target ("\SOHACTION " <> Text.encodeUtf8 message <> "\SOH") SendNotice -> noticeCmd target (Text.encodeUtf8 message) SendCtcp cmd -> ctcpRequestCmd target (Text.encodeUtf8 (Text.pack (map toUpper cmd))) (Text.encodeUtf8 message) clientSend bs st now <- getCurrentTime let myNick = view connNick conn myModes = view (connChannels . ix target' . chanUsers . ix myNick) conn return (addMessage target' (fakeMsg now myModes) (clearInput st)) where conn = view (clientServer0 . ccConnection) st (statusmsg, target') = splitStatusMsg target conn fakeMsg now modes = IrcMessage { _mesgSender = who , _mesgStatus = statusmsg , _mesgType = case sendType of SendPriv -> PrivMsgType message SendNotice -> NoticeMsgType message SendAction -> ActionMsgType message SendCtcp cmd -> CtcpReqMsgType (Text.encodeUtf8 (Text.pack cmd)) (Text.encodeUtf8 message) , _mesgStamp = now , _mesgModes = modes , _mesgMe = True } who = UserInfo (view connNick conn) Nothing Nothing commandEvent :: ClientState -> (Image, Maybe (IO KeyEventResult)) commandEvent st = commandsParser (clientInput st) (exitCommand : normalCommands) where st' = clearInput st toB = Text.encodeUtf8 . Text.pack conn = view (clientServer0 . ccConnection) st exitCommand = ("exit", [], pure (return Exit)) normalCommands = over (mapped . _3 . mapped . mapped) KeepGoing $ -- focus setting [ ("server", [], pure (return (set clientFocus (ChannelFocus "") st'))) , ("channel", [], (\chan -> return (set clientFocus (ChannelFocus chan) st')) <$> pChannel st) , ("query", [], (\user -> return (set clientFocus (ChannelFocus user) st')) <$> pNick st) , ("window", [], (\n -> return (jumpFocus n st')) <$> pNumber) , ("channelinfo", [], pure (doChannelInfoCmd st)) , ("bans", [], pure (doMasksCmd 'b' st)) , ("masks", [], (\mode -> doMasksCmd mode st) <$> pValidToken "mode" (\m -> case m of [x] | x `elem` view (connChanModeTypes . modesLists) conn -> Just x _ -> Nothing)) -- chat , ("me", [], (\msg -> doAction msg st) <$> pRemainingNoSp) , ("notice", [], (\target msg -> doSendMessage SendNotice target (Text.pack msg) st) <$> pTarget <*> pRemainingNoSp) , ("msg", [], (\target msg -> doSendMessage SendPriv target (Text.pack msg) st) <$> pTarget <*> pRemainingNoSp) , ("ctcp", [], (\command params -> doSendMessage (SendCtcp command) (focusedName st) (Text.pack params) st) <$> pToken "command" <*> pRemainingNoSp) -- carefully preserve whitespace after the command , ("hs", [], (\src -> let msg = Text.pack src in case view clientFocus st of ChannelFocus c -> doSendMessage SendPriv c msg st _ -> return st) <$> pHaskell) -- raw , ("quote", [], (\rest -> doQuote rest st') <$> pRemainingNoSp) , ("help", [], (\mbTopic -> st' <$ clientSend (helpCmd (maybe "" toB mbTopic)) st') <$> optional (pToken "topic")) -- channel commands , ("join", ["j"], (\c key -> doJoinCmd c (fmap toB key) st') <$> pChannel st <*> optional (pToken "key")) , ("umode", [], (\args -> st' <$ clientSend (modeCmd (view connNick conn) (map toB (words args))) st') <$> pRemainingNoSp) , ("mode", [], (\args -> doMode (Text.encodeUtf8 (Text.pack args)) st) <$> pRemainingNoSp) , ("kick", [], doKick st <$> pNick st <*> (Text.pack <$> pRemainingNoSp)) , ("remove", [], doRemove st <$> pNick st <*> (Text.pack <$> pRemainingNoSp)) , ("invite", [], doInvite st <$> pNick st) , ("knock", [], (\chan -> doKnock chan st) <$> pChannel st) , ("part", [], (\msg -> case focusedChan st of Nothing -> return st Just chan -> st' <$ clientSend (partCmd chan (toB msg)) st') <$> pRemainingNoSp) , ("whois", ["wi"], (\u -> st' <$ clientSend (whoisCmd u) st') <$> pNick st) , ("whowas", [], (\u -> st' <$ clientSend (whowasCmd u) st') <$> pNick st) , ("topic", ["t"], (\rest -> doTopicCmd (toB rest) st) -- TODO: the limit should check bytes not chars <$> pRemainingNoSpLimit (view connTopicLen conn)) , ("ignore", [], (\u -> return (over (clientIgnores . contains u) not st')) <$> pNick st) , ("highlight", [], (\w -> return (over (clientHighlights . contains (ircFoldCase (Text.encodeUtf8 (Text.pack w)))) not st')) <$> pRemainingNoSp) , ("clear", [], (\chan -> return (set (clientMessages . at (fromMaybe (focusedName st) chan)) Nothing st')) <$> optional pTarget) , ("accept", [], (\mbNick -> doAccept True mbNick st) <$> optional (pNick st)) , ("unaccept", [], (\mbNick -> doAccept False mbNick st) <$> optional (pNick st)) , ("acceptlist", [], pure (doAccept True (Just "*") st)) , ("nick", [], doNick st <$> pNick st) , ("away", [], (\rest -> st' <$ clientSend (awayCmd (toB rest)) st') <$> pRemainingNoSp) , ("quit", [], (\rest -> st' <$ clientSend (quitCmd (toB rest)) st') <$> pRemainingNoSp) , ("who", [], (\whomask -> st' <$ clientSend (whoCmd (toB whomask)) st') <$> pToken "mask") , ("op" , [], doOp st <$> many' (pNick st)) , ("deop" , [], doDeop st <$> many' (pNick st)) , ("voice" , [], doVoice st <$> many' (pNick st)) , ("devoice", [], doDevoice st <$> many' (pNick st)) , ("akb", [], (\nick reason -> case focusedChan st of Nothing -> return st Just chan -> doWithOps chan (doAutoKickBan chan nick (Text.pack reason)) st') <$> pNick st <*> pRemainingNoSp) , ("time", [], (\mbServer -> st' <$ clientSend (timeCmd (fmap (Text.encodeUtf8 . Text.pack) mbServer)) st') <$> optional (pToken "server")) , ("admin", [], (\mbServer -> st' <$ clientSend (adminCmd (fmap (Text.encodeUtf8 . Text.pack) mbServer)) st') <$> optional (pToken "server")) , ("stats", [], (\letter mbTarget -> st' <$ clientSend (statsCmd letter (fmap (Text.encodeUtf8 . Text.pack) mbTarget)) st') <$> pAnyChar <*> optional (pToken "target")) , ("oper", [], (\user pass -> st' <$ clientSend (operCmd (Text.encodeUtf8 (Text.pack user)) (Text.encodeUtf8 (Text.pack pass))) st') <$> pToken "username" <*> pToken "password") , ("reconnect", [], pure (doReconnect st')) , ("ping", [], (\msg -> st' <$ doPingCmd msg st') <$> pRemainingNoSp) ] doPingCmd :: String -> ClientState -> IO () doPingCmd "" st = sendTimestampPing st doPingCmd msg st = clientSend (pingCmd (Text.encodeUtf8 (Text.pack msg))) st doReconnect :: ClientState -> IO ClientState doReconnect st = do let server0 = view clientServer0 st traverse_ killThread (view ccRecvThread server0) traverse_ killThread (view ccSendThread server0) let settings = view ccServerSettings server0 recvChan = view clientRecvChan st hErr = view clientErrors st config = view clientConfig st server0' <- startIrcConnection config recvChan settings hErr return (set clientServer0 server0' st) doNick :: ClientState -> Identifier {- ^ new nickname -} -> IO ClientState doNick st nick | B8.length (idBytes nick) > view connNickLen conn = return st | view connPhase conn /= ActivePhase = let st' = clearInput $ set (clientServer0 . ccConnection . connNick) nick st in st' <$ clientSend (nickCmd nick) st' | otherwise = clearInput st <$ clientSend (nickCmd nick) st where conn = view (clientServer0 . ccConnection) st doMode :: ByteString {- mode change -} -> ClientState -> IO ClientState doMode args st = fromMaybe (return st) $ do chan <- focusedChan st modes:params <- Just (B8.words args) parsedModes <- splitModes (view connChanModeTypes conn) modes params let modeChunks = chunksOf (view connModes conn) parsedModes return $ doWithOps chan (\evSt -> do for_ modeChunks $ \modeChunk -> clientSend (modeCmd chan (unsplitModes modeChunk)) evSt return evSt) (clearInput st) where conn = view (clientServer0 . ccConnection) st doAccept :: Bool {- ^ add to list -} -> Maybe Identifier {- ^ optional nick -} -> ClientState -> IO ClientState doAccept add mbNick st = case mbNick of Just n -> go n Nothing | isNickName (focusedName st) conn -> go (focusedName st) | otherwise -> return st where conn = view (clientServer0 . ccConnection) st go nick = do let nickBytes | add = idBytes nick | otherwise = "-" <> idBytes nick clientSend (acceptCmd nickBytes) st return (clearInput st) doAction :: String {- ^ action text -} -> ClientState -> IO ClientState doAction msg st = case view clientFocus st of ChannelFocus c -> doSendMessage SendAction c (Text.pack msg) (clearInput st) _ -> return st doKnock :: Identifier {- ^ channel -} -> ClientState -> IO ClientState doKnock chan st | not available || not isChannel || inChannel = return st | otherwise = do clientSend (knockCmd chan) st return (clearInput st) where conn = view (clientServer0 . ccConnection) st available = view connKnock conn inChannel = has (connChannels . ix chan) conn isChannel = isChannelName chan conn doChannelInfoCmd :: ClientState -> IO ClientState doChannelInfoCmd st | Just chan <- focusedChan st = do let modesKnown = has ( connChannels . ix chan . chanModes . folded) conn unless modesKnown $ clientSend (modeCmd chan []) st return (clearInput (set clientFocus (ChannelInfoFocus chan) st)) | otherwise = return st where conn = view (clientServer0 . ccConnection) st doMasksCmd :: Char {- ^ mode -} -> ClientState -> IO ClientState doMasksCmd mode st | Just chan <- focusedChan st = do let masksKnown = has ( connChannels . ix chan . chanMaskLists . ix mode) conn unless masksKnown $ clientSend (modeCmd chan [B8.pack ['+',mode]]) st return (set clientFocus (MaskListFocus mode chan) (clearInput st)) | otherwise = return st where conn = view (clientServer0 . ccConnection) st doJoinCmd :: Identifier -> Maybe ByteString -> ClientState -> IO ClientState doJoinCmd c mbKey st = do clientSend (joinCmd c mbKey) st -- When joining you can specify more than one channel split on commas let c' = mkId (B8.takeWhile (/=',') (idBytes c)) return (set clientFocus (ChannelFocus c') st) doQuote :: String -> ClientState -> IO ClientState doQuote cmd st = st <$ clientSend (Text.encodeUtf8 (Text.pack (cmd ++ "\r\n"))) st ------------------------------------------------------------------------ -- Primary UI rendering ------------------------------------------------------------------------ picForState :: ClientState -> (Int,Picture) picForState st = (scroll', pic) where conn = view (clientServer0 . ccConnection) st pic = Picture { picCursor = Cursor (min (view clientWidth st - 1) (view (clientEditBox. Edit.pos) st+1)) (view clientHeight st - 1) , picLayers = [ translateY (view clientHeight st - 2) (divider <-> textbox st) , everythingBeforeInput ] , picBackground = ClearBackground } everythingBeforeInput = vertCat [ titlebar , string defAttr (replicate (view clientWidth st) '─') , mainFocusImage ] divider = dividerImage st -- Pad the main image when it doesn't fill the screen -- so that it starts at the bottom of the frame startFromBottom :: Image -> Image startFromBottom img = pad 0 top 0 0 img where top = max 0 (view clientHeight st - 4 - imageHeight img) mainFocusImage = startFromBottom . vertCat . reverse $ scrolledLines (scroll', scrolledLines) = scrollList (view clientHeight st - 4) (view clientScrollPos st) wrappedLines wrappedLines = reverse . lineWrap (view clientWidth st) =<< mainFocusLines mainFocusLines = case view clientFocus st of MaskListFocus mode chan -> banListImage mode chan st ChannelInfoFocus chan -> channelInfoImage chan st _ -> channelImage st titlebar = case view clientFocus st of ChannelFocus "" -> string defAttr "Server" ChannelFocus c -> topicbar c ChannelInfoFocus c -> string defAttr "Channel Info: " <|> identImg defAttr c MaskListFocus mode c -> string defAttr (maskListTitle mode ++ ": ") <|> identImg defAttr c topicbar chan = case preview (connChannels . ix chan . chanTopic . folded . folded . _1) conn of Just topic | not (Text.null topic) -> cleanText topic _ -> char defAttr ' ' -- | Try to drop the suggested number of elements and then -- take the requested number of elements. If the drop drops -- too many, drop fewer (when possible) in favor of taking -- the correct number of elements. Return the actual number -- of elements dropped along with the elements kept. scrollList :: Int {- ^ take parameter -} -> Int {- ^ suggested drop -} -> [a] {- ^ all elements -} -> (Int,[a]) {- ^ (actual drop, selected elements) -} scrollList t d xs | length xs' == t = (d,xs') | otherwise = (d',drop d' xs) where xs' = take t (drop d xs) x'len = length xs' d' = max 0 (d - (t - x'len)) maskListTitle :: Char -> String maskListTitle 'b' = "Bans" maskListTitle 'q' = "Quiets" maskListTitle 'I' = "Invite exceptions" maskListTitle 'e' = "Ban exceptions" maskListTitle m = "Unknown '" ++ [m] ++ "' masks" textbox :: ClientState -> Image textbox st = applyCrop $ beginning <|> content <|> ending where pos = view (clientEditBox . Edit.pos) st width = view clientWidth st (content,_) = inputLogic st applyCrop | 1+pos < width = cropRight width | otherwise = cropLeft width . cropRight (pos+2) beginning = char (withForeColor defAttr brightBlack) '^' ending = char (withForeColor defAttr brightBlack) '$' dividerImage :: ClientState -> Image dividerImage st = extendToWidth (nickPart <|> channelPart <|> lagPart) where conn = view (clientServer0 . ccConnection) st myNick = view connNick conn lagPart = case view connPingTime conn of Just s -> let s' = realToFrac s :: Centi -- truncate to two decimal places sStr = showFixed True s' <> "s" in string defAttr "-[" <|> string (withForeColor defAttr yellow) sStr <|> string defAttr "]" _ -> emptyImage channelPart = ifoldr (\i x xs -> drawOne i x <|> xs) emptyImage (fullMessageLists st <> extraDefaults) -- e.g. glguy(+Zi) nickPart = identImg defAttr myNick <|> string defAttr "(+" <|> utf8Bytestring' defAttr (view connUmode conn) <|> char defAttr ')' drawOne :: Identifier -> MessageList -> Image drawOne i seen | focusedName st == i = string defAttr "─(" <|> string (withForeColor defAttr blue) focusedChanPrefixes <|> utf8Bytestring' (withForeColor defAttr green) (identToBytes i) <|> string defAttr ")" | views mlNewMessages (>0) seen = string defAttr "─[" <|> utf8Bytestring' (withForeColor defAttr brightBlue) (identToBytes i) <|> string defAttr ":" <|> string (withForeColor defAttr (seenColor seen)) (show (view mlNewMessages seen)) <|> string defAttr "]" | otherwise = string defAttr "─o" -- e.g. [('o','@'),('v','+')] prefixMapping = view (connChanModeTypes . modesPrefixModes) conn myFocusedModes = view (connChannels . ix (focusedName st) . chanUsers . ix myNick) conn -- allow prefixMapping to dictate the ordering focusedChanPrefixes = [ prefix | (mode,prefix) <- prefixMapping, mode `elem` myFocusedModes ] -- deal with the fact that the server window uses the "" identifier identToBytes x | x == "" = "server" | otherwise = idBytes x seenColor :: MessageList -> Color seenColor seen | view mlMentioned seen = red | view mlNewMessages seen > 0 = green | otherwise = brightBlack extendToWidth img = img <|> string defAttr (replicate (view clientWidth st - imageWidth img) '─') extraDefaults = Map.singleton (focusedName st) defaultMessageList ------------------------------------------------------------------------ -- Event loops ------------------------------------------------------------------------ sendLoop :: IORef Bool -> TChan ByteString -> Connection -> IO () sendLoop connectedRef queue h = do r <- newRateLimitDefault forever $ do x <- atomically (readTChan queue) tickRateLimit r connectionPut h x `catch` \(SomeException _) -> writeIORef connectedRef False -- exit silently socketLoop :: TChan (UTCTime, MsgFromServer) -> Connection -> Maybe Handle -> IO () socketLoop chan h hErr = forever (atomically . writeTChan chan =<< getOne h hErr) `catches` [ Handler $ \ioe -> do let msg = if isEOFError ioe then "Connection terminated" else Text.encodeUtf8 (Text.pack (show ioe)) now <- getCurrentTime atomically (writeTChan chan (now, Error msg)) , Handler $ \(SomeException e) -> do now <- getCurrentTime atomically (writeTChan chan (now, Error (Text.encodeUtf8 (Text.pack (show e))))) ] vtyEventLoop :: TChan Event -> Vty -> IO a vtyEventLoop chan vty = forever (atomically . writeTChan chan =<< nextEvent vty) getOne :: Connection -> Maybe Handle -> IO (UTCTime, MsgFromServer) getOne h hErr = do xs <- getRawIrcLine h case parseRawIrcMsg xs of _ | B.null xs -> connectionClosed Nothing -> unparsableLine xs Just rawMsg -> do t <- maybe getCurrentTime return (msgTime rawMsg) case ircMsgToServerMsg rawMsg of Nothing -> unhandledMsg t rawMsg Just msg -> handledMsg t msg where debugPrint x = for_ hErr (`hPrint` x) connectionClosed = do t <- getCurrentTime return (t,Error "Connection closed") unparsableLine xs = do debugPrint xs t <- getCurrentTime return (t,Error ("Unparsable IRC line: " <> xs)) unhandledMsg t rawMsg = do debugPrint rawMsg return (t,Error ("Unhandled IRC line: " <> Text.encodeUtf8 (Text.pack (show rawMsg)))) handledMsg t msg = do debugPrint msg return (t,msg) readEitherTChan :: TChan a -> TChan b -> IO (Either a b) readEitherTChan a b = atomically (fmap Left (readTChan a) `orElse` fmap Right (readTChan b)) ------------------------------------------------------------------------ -- Tab completion logic ------------------------------------------------------------------------ tabComplete :: ClientState -> ClientState tabComplete st = fromMaybe st $ do let current = currentWord st guard (not (null current)) c <- focusedChan st let vals = userSet c <> channelSet case view clientTabPattern st of Just pat -> do next <- tabSearch pat current vals Just $ replaceWith next st Nothing -> do next <- tabSearch current current vals Just $ set clientTabPattern (Just current) $ replaceWith next st where conn = view (clientServer0 . ccConnection) st replaceWith str = over clientEditBox $ \box -> let box1 = Edit.killWord False box str1 | view Edit.pos box1 == 0 = str ++ ": " | otherwise = str in Edit.insertString str1 box1 userSet c = views (connChannels . ix c . chanUsers) Map.keysSet conn channelSet = views connChannels Map.keysSet conn currentWord :: ClientState -> String currentWord st = reverse $ takeWhile (not . isSpace) $ dropWhile (\x -> x==' ' || x==':') $ reverse $ take (view (clientEditBox . Edit.pos) st) (clientInput st) tabSearch :: String -> String -> Set Identifier -> Maybe String tabSearch pat cur vals | Just next <- Set.lookupGT cur' vals , B.isPrefixOf (idDenote pat') (idDenote next) = Just (B8.unpack (idBytes next)) -- wrap around when pat is a user | Just next <- Set.lookupGE pat' vals , B.isPrefixOf (idDenote pat') (idDenote next) = Just (B8.unpack (idBytes next)) -- TODO: Use original case -- if all else fails, do nothing | otherwise = Nothing where pat' = mkId (B8.pack pat) cur' = mkId (B8.pack cur) defaultNickColors :: [Color] defaultNickColors = [cyan, magenta, green, yellow, blue, brightCyan, brightMagenta, brightGreen, brightBlue] schedulePing :: ClientState -> IO ClientState schedulePing st = do now <- getCurrentTime let pingTime = addUTCTime 60 now return (addTimerEvent pingTime TransmitPing st) sendTimestampPing :: ClientState -> IO () sendTimestampPing st = do now <- getCurrentTime let ts = realToFrac (utcTimeToPOSIXSeconds now) :: Pico chopTrailingZeros = True tsStr = B8.pack (showFixed chopTrailingZeros ts) clientSend (pingCmd tsStr) st irc-core-1.1.3/driver/Moderation.hs0000644000000000000000000001750412622517457015357 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {- | Administrative channel operations -} module Moderation where import Control.Applicative import Control.Lens import Data.ByteString (ByteString) import Data.Foldable (for_) import Data.Maybe (fromMaybe) import Data.Time import Data.Text (Text) import Data.List (nub, delete) import Data.List.Split (chunksOf) import Data.Monoid import qualified Data.ByteString.Char8 as B8 import qualified Data.Text.Encoding as Text import Irc.Cmd import Irc.Format import Irc.Model import Irc.Message import ClientState deopWaitDuration :: NominalDiffTime deopWaitDuration = 5*60 -- seconds -- | Perform a privileged operation. If the connection doesn't -- already have +o on the channel it will be requested from -- ChanServ and the privileged operation will be scheduled to -- run when the connection gets +o. doWithOps :: Identifier {- ^ channel -} -> (ClientState -> IO ClientState) {- ^ privileged operation -} -> ClientState -> IO ClientState doWithOps = doWithOps' False doWithOps' :: Bool {- ^ permanent change -} -> Identifier {- ^ channel -} -> (ClientState -> IO ClientState) {- ^ privileged operation -} -> ClientState -> IO ClientState doWithOps' perm chan privop st | initiallyOp = finishUp st | otherwise = getOpFirst where conn = view (clientServer0 . ccConnection) st myNick = view connNick conn -- was I op when the command was entered initiallyOp = nickHasModeInChannel myNick 'o' chan conn handler = EventHandler { _evName = "Get op for privop" , _evOnEvent = \evTgt evMsg evSt -> case view mesgType evMsg of ModeMsgType True 'o' modeNick | mkId modeNick == myNick , evTgt == chan -> finishUp evSt _ -> return (over clientAutomation (cons handler) evSt) } finishUp st1 = privop =<< installTimer st1 getOpFirst = do clientSend (privMsgCmd "chanserv" ("op " <> idDenote chan)) st return (over clientAutomation (cons handler) st) computeDeopTime = do now <- getCurrentTime return (addUTCTime deopWaitDuration now) installTimer st0 | perm && deopScheduled chan st0 = return $ filterTimerEvents (/= DropOperator chan) st0 | perm = return st0 | deopScheduled chan st0 || not initiallyOp = do time <- computeDeopTime return $ addTimerEvent time (DropOperator chan) $ filterTimerEvents (/= DropOperator chan) st0 | otherwise = return st0 -- | Predicate to determine if a deop is scheduled to happen deopScheduled :: Identifier {- ^ channel -} -> ClientState -> Bool deopScheduled = elemOf (clientTimers . folded . folded . _DropOperator) doAutoKickBan :: Identifier {- ^ channel -} -> Identifier {- ^ nick -} -> Text {- ^ reason -} -> ClientState -> IO ClientState doAutoKickBan chan nick reason st = -- TODO: Look up account name or hostname! do clientSend (modeCmd chan ["+b",banMask]) st clientSend (kickCmd chan nick (Text.encodeUtf8 reason)) st return st where conn = view (clientServer0 . ccConnection) st usr = view (connUsers . at nick) conn nickMask = idDenote nick <> "!*@*" banMask = fromMaybe nickMask $ previews (folded . usrAccount . folded) ("$a:"<>) usr <|> previews (folded . usrHost . folded) ("*!*@"<>) usr -- | Cancel any pending deop timer if I'm deopped cancelDeopTimerOnDeop :: EventHandler cancelDeopTimerOnDeop = EventHandler { _evName = "cancel deop timer on deop" , _evOnEvent = \evTgt evMsg evSt -> let evSt' = reschedule evSt conn = view (clientServer0 . ccConnection) evSt in case view mesgType evMsg of ModeMsgType False 'o' modeNick | mkId modeNick == view connNick conn -> return $ filterTimerEvents (/= DropOperator evTgt) evSt' _ -> return evSt' } where reschedule = over clientAutomation (cons cancelDeopTimerOnDeop) doOp :: ClientState -> [Identifier] -> IO ClientState doOp st nicks | Just chan <- focusedChan st = doWithOps' (null nicks || myNick `elem` nicks) -- permanent? chan (massModeChange True 'o' chan (nub (delete myNick nicks))) (clearInput st) | otherwise = return st where conn = view (clientServer0 . ccConnection) st myNick = view connNick conn doDeop :: ClientState -> [Identifier] -> IO ClientState doDeop st nicks | Just chan <- focusedChan st = doWithOps chan (massModeChange False 'o' chan nicks') (clearInput st) | otherwise = return st where -- deop myself last nicks' | null nicks = [myNick] | myNick `elem` nicks = nub (delete myNick nicks) ++ [myNick] | otherwise = nicks conn = view (clientServer0 . ccConnection) st myNick = view connNick conn doVoice :: ClientState -> [Identifier] -> IO ClientState doVoice st nicks | Just chan <- focusedChan st = doWithOps chan (massModeChange True 'v' chan nicks') (clearInput st) | otherwise = return st where conn = view (clientServer0 . ccConnection) st nicks' | null nicks = [view connNick conn] | otherwise = nub nicks doDevoice :: ClientState -> [Identifier] -> IO ClientState doDevoice st nicks | Just chan <- focusedChan st = doWithOps chan (massModeChange False 'v' chan nicks') (clearInput st) | otherwise = return st where conn = view (clientServer0 . ccConnection) st nicks' | null nicks = [view connNick conn] | otherwise = nub nicks massModeChange :: Bool {- ^ polarity -} -> Char {- ^ mode -} -> Identifier {- ^ channel -} -> [Identifier] {- ^ nicks -} -> ClientState -> IO ClientState massModeChange polarity mode chan nicks st = do let nickChunks = chunksOf (view connModes conn) nicks for_ nickChunks $ \nickChunk -> clientSend (modeCmd chan (modeArg (length nickChunk) : map idBytes nickChunk)) st return st where conn = view (clientServer0 . ccConnection) st polarityBs | polarity = B8.empty | otherwise = B8.singleton '-' modeArg n = polarityBs <> B8.replicate n mode doTopicCmd :: ByteString {- ^ new topic -} -> ClientState -> IO ClientState doTopicCmd topic st | not (B8.null topic) , Just chan <- focusedChan st = let go st' = st' <$ clientSend (topicCmd chan topic) st' in case preview (connChannels . ix chan . chanModes . folded) conn of -- check if it's known that the mode isn't +t Just modes | hasn't (ix 't') modes -> go (clearInput st) _ -> doWithOps chan go (clearInput st) | otherwise = return st where conn = view (clientServer0 . ccConnection) st doInvite :: ClientState -> Identifier {- ^ nickname -} -> IO ClientState doInvite st nick = case focusedChan st of Nothing -> return st Just chan -- 'g' is the "FREEINVITE" mode, don't check for ops | channelHasMode chan 'g' conn -> go (clearInput st) -- it's an error to invite someone already in channel | has (connChannels . ix chan . chanUsers . ix nick) conn -> return st | otherwise -> doWithOps chan go (clearInput st) where conn = view (clientServer0 . ccConnection) st go st' = st' <$ clientSend (inviteCmd nick chan) st' doKick :: ClientState -> Identifier {- ^ nick -} -> Text {- ^ reason -} -> IO ClientState doKick st nick msg | Just chan <- focusedChan st = doWithOps chan (\evSt -> evSt <$ clientSend (kickCmd chan nick (Text.encodeUtf8 msg)) evSt) (clearInput st) | otherwise = return st doRemove :: ClientState -> Identifier {- ^ nick -} -> Text {- ^ reason -} -> IO ClientState doRemove st nick msg | Just chan <- focusedChan st = doWithOps chan (\evSt -> evSt <$ clientSend (removeCmd chan nick (Text.encodeUtf8 msg)) evSt) (clearInput st) | otherwise = return st irc-core-1.1.3/driver/ServerSettings.hs0000644000000000000000000000132112622517457016233 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module ServerSettings where import Control.Lens import Data.Text import Network.Socket (HostName, PortNumber) data ServerSettings = ServerSettings { _ssNick :: String , _ssUser :: String , _ssReal :: String , _ssUserInfo :: String , _ssPassword :: Maybe String , _ssSaslCredential:: Maybe (String,String) , _ssHostName :: HostName , _ssPort :: Maybe PortNumber , _ssTls :: Bool , _ssTlsInsecure :: Bool , _ssTlsClientCert :: Maybe FilePath , _ssTlsClientKey :: Maybe FilePath , _ssConnectCmds :: [Text] , _ssSocksProxy :: Maybe (HostName,PortNumber) } makeLenses ''ServerSettings irc-core-1.1.3/driver/Views/0000755000000000000000000000000012622517457014010 5ustar0000000000000000irc-core-1.1.3/driver/Views/BanList.hs0000644000000000000000000000153512622517457015704 0ustar0000000000000000module Views.BanList where import ClientState import Control.Lens import Graphics.Vty.Image import Irc.Format import Irc.Model banListImage :: Char -> Identifier -> ClientState -> [Image] banListImage mode chan st = case view (connChannels . ix chan . chanMaskLists . at mode) conn of Nothing -> [string (withForeColor defAttr red) "Unknown list"] Just [] -> [string (withForeColor defAttr green) "Empty list"] Just xs -> map renderEntry xs where conn = view (clientServer0 . ccConnection) st renderEntry :: IrcMaskEntry -> Image renderEntry entry = utf8Bytestring' (withForeColor defAttr red) (view maskEntryMask entry) <|> string defAttr " - " <|> utf8Bytestring' (withForeColor defAttr green) (view maskEntryWho entry) <|> string defAttr " - " <|> string (withForeColor defAttr yellow) (show (view maskEntryStamp entry)) irc-core-1.1.3/driver/Views/Channel.hs0000644000000000000000000004351412622517457015723 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 #endif #ifndef MIN_VERSION_time #define MIN_VERSION_time(x,y,z) 1 #endif module Views.Channel (channelImage) where import Control.Lens import qualified Data.ByteString as BS import Data.Foldable (toList) import Data.List (intersperse) import Data.Maybe (isJust) import qualified Data.Map as Map import Data.Monoid import qualified Data.Set as Set import Data.Text (Text) import Data.Time (TimeZone, UTCTime, formatTime, utcToZonedTime) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Graphics.Vty.Image import Text.Regex.TDFA import Text.Regex.TDFA.ByteString (compile, execute) #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Irc.Format import Irc.Message import Irc.Model import Irc.Core import ClientState import ImageUtils channelImage :: ClientState -> [Image] channelImage st | view clientDetailView st = detailedImageForState st | otherwise = compressedImageForState st detailedImageForState :: ClientState -> [Image] detailedImageForState !st = [ renderOne chan msg | (chan, msg, _img) <- activeMessages st] where zone = view clientTimeZone st renderOne chan x = timestamp <|> channel <|> string (withForeColor defAttr tyColor) (ty ++ " ") <|> statusMsgImage (view mesgStatus x) <|> renderFullUsermask (view mesgSender x) <|> string (withForeColor defAttr blue) (": ") <|> cleanText content where timestamp | view clientTimeView st = renderTimestamp zone (view mesgStamp x) | otherwise = emptyImage -- show all channel names in detailed/full view channel | view clientFullView st = identImg (withForeColor defAttr brightBlack) chan <|> string defAttr " " | otherwise = emptyImage (tyColor, ty, content) = case view mesgType x of JoinMsgType -> (green , "Join", "") PartMsgType txt -> (red , "Part", txt) NickMsgType txt -> (yellow , "Nick", asUtf8 (idBytes txt)) QuitMsgType txt -> (red , "Quit", txt) PrivMsgType txt -> (blue , "Priv", txt) TopicMsgType txt -> (yellow , "Topc", txt) ActionMsgType txt -> (blue , "Actn", txt) CtcpRspMsgType cmd txt -> (yellow , "Ctcp", asUtf8 (cmd <> " " <> txt)) CtcpReqMsgType cmd txt -> (yellow , "Ctcp", asUtf8 (cmd <> " " <> txt)) AwayMsgType txt -> (yellow , "Away", txt) NoticeMsgType txt -> (blue , "Note", txt) KickMsgType who txt -> (red , "Kick", asUtf8 (idBytes who) <> " - " <> txt) ErrorMsgType txt -> (red , "ErrT", txt) ErrMsgType err -> (red , "ErrR", Text.pack (show err)) InviteMsgType -> (yellow , "Invt", "") KnockMsgType -> (yellow , "Knoc", "") CallerIdDeliveredMsgType -> (yellow , "Delv", "") CallerIdMsgType -> (yellow , "Call", "") ModeMsgType pol mode arg -> (yellow , "Mode", (if pol then "+" else "-") <> Text.pack [mode, ' '] <> asUtf8 arg) renderTimestamp :: TimeZone -> UTCTime -> Image renderTimestamp zone = string (withForeColor defAttr brightBlack) . formatTime defaultTimeLocale "%F %H:%M:%S " . utcToZonedTime zone renderCompressedTimestamp :: TimeZone -> UTCTime -> Image renderCompressedTimestamp zone = string (withForeColor defAttr brightBlack) . formatTime defaultTimeLocale "[%H:%M] " . utcToZonedTime zone activeMessages :: ClientState -> [(Identifier,IrcMessage,Image)] activeMessages st = case clientInputFilter st of FilterNicks nicks -> let nickset = Set.fromList (mkId . toUtf8 <$> nicks) in filter (nicksFilter nickset . view _2) msgs FilterBody regex -> let r = compile defaultCompOpt defaultExecOpt regex in filter (bodyFilter r . view _2) msgs NoFilter -> msgs where focus = focusedName st msgs :: [(Identifier,IrcMessage,Image)] msgs | view clientFullView st = interleavedMessages st | otherwise = [ (focus, msg, img) | (msg,img) <- views (clientMessages . ix (focusedName st) . mlMessages) toList st ] nicksFilter nickset msg = views mesgSender userNick msg `Set.member` nickset bodyFilter :: Either a Regex -> IrcMessage -> Bool bodyFilter (Left _) _ = True -- regex compilation failed bodyFilter (Right r) msg = let isMatch = either (const True) isJust . execute r in isMatch (textOfMessage msg) textOfMessage :: IrcMessage -> BS.ByteString textOfMessage mesg = let f n = idBytes (views mesgSender userNick mesg) <> ": " <> Text.encodeUtf8 n in f (case mesg ^. mesgType of PrivMsgType t -> t NoticeMsgType t -> t ActionMsgType t -> t KickMsgType _ t -> t PartMsgType t -> t QuitMsgType t -> t TopicMsgType t -> t ErrorMsgType t -> t _ -> "") data InputFilter = FilterNicks [String] | FilterBody BS.ByteString | NoFilter clientInputFilter :: ClientState -> InputFilter clientInputFilter st = go (clientInput st) where go (splitAt 8 -> ("/filter ",nicks)) = FilterNicks (words nicks) go (splitAt 6 -> ("/grep ", txt)) = FilterBody (toUtf8 txt) go _ = NoFilter compressedImageForState :: ClientState -> [Image] compressedImageForState !st = renderOne (activeMessages st) where zone = view clientTimeZone st width = view clientWidth st activeChan = focusedName st ncolors = views clientNickColors length st formatNick me nick = identImg (withForeColor defAttr color) nick where color | me = red | otherwise = view clientNickColors st !! mod (nickHash (idDenote nick)) ncolors ignores = view clientIgnores st renderOne [] = [] renderOne ((chan,msg,colored):msgs) = case mbImg of Just img -> (timestamp <|> channel <|> img) : renderOne msgs Nothing -> renderMeta ((chan,msg,colored):msgs) where timestamp | view clientTimeView st = renderCompressedTimestamp zone (view mesgStamp msg) | otherwise = emptyImage nick = views mesgSender userNick msg visible = not (view (contains nick) ignores) -- when in the full monitor view we only show the names of the channels -- next to messages for the unfocused channel channel | chan == activeChan = emptyImage | otherwise = identImg (withForeColor defAttr brightBlack) chan <|> string defAttr " " mbImg = case view mesgType msg of PrivMsgType _ | visible -> Just $ statusMsgImage (view mesgStatus msg) <|> views mesgModes modePrefix msg <|> formatNick (view mesgMe msg) nick <|> string (withForeColor defAttr blue) (": ") <|> colored NoticeMsgType _ | visible -> Just $ statusMsgImage (view mesgStatus msg) <|> string (withForeColor defAttr red) "! " <|> views mesgModes modePrefix msg <|> identImg (withForeColor defAttr red) nick <|> string (withForeColor defAttr blue) (": ") <|> colored ActionMsgType _ | visible -> Just $ statusMsgImage (view mesgStatus msg) <|> string (withForeColor defAttr blue) "* " <|> views mesgModes modePrefix msg <|> identImg (withForeColor defAttr blue) nick <|> char defAttr ' ' <|> colored CtcpRspMsgType cmd params | visible -> Just $ string (withForeColor defAttr red) "C " <|> views mesgModes modePrefix msg <|> identImg (withForeColor defAttr blue) nick <|> char defAttr ' ' <|> cleanText (asUtf8 cmd) <|> char defAttr ' ' <|> cleanText (asUtf8 params) KickMsgType who reason -> Just $ views mesgModes modePrefix msg <|> formatNick (view mesgMe msg) nick <|> string (withForeColor defAttr red) " kicked " <|> identImg (withForeColor defAttr yellow) who <|> string (withForeColor defAttr blue) (": ") <|> cleanText reason ErrorMsgType err -> Just $ string (withForeColor defAttr red) "Error: " <|> cleanText err ErrMsgType err -> Just $ string (withForeColor defAttr red) "Error: " <|> text' defAttr (errorMessage err) InviteMsgType -> Just $ identImg (withForeColor defAttr green) nick <|> text' defAttr " has invited you to join" CallerIdDeliveredMsgType -> Just $ identImg (withForeColor defAttr green) nick <|> text' defAttr " has been notified of your message" CallerIdMsgType -> Just $ identImg (withForeColor defAttr green) nick <|> text' defAttr " has sent you a message, use /ACCEPT to accept" ModeMsgType pol m arg -> Just $ views mesgModes modePrefix msg <|> formatNick (view mesgMe msg) nick <|> string (withForeColor defAttr red) " set mode " <|> string (withForeColor defAttr white) ((if pol then '+' else '-'):[m,' ']) <|> utf8Bytestring' (withForeColor defAttr yellow) arg TopicMsgType txt -> Just $ views mesgModes modePrefix msg <|> formatNick (view mesgMe msg) nick <|> string (withForeColor defAttr red) " set topic " <|> cleanText txt AwayMsgType txt -> Just $ string (withForeColor defAttr red) "A " <|> formatNick (view mesgMe msg) nick <|> string (withForeColor defAttr red) " is away: " <|> cleanText txt _ -> Nothing renderMeta msgs = img ++ renderOne rest where (mds,rest) = splitWith processMeta msgs mds1 = mergeMetadatas mds gap = char defAttr ' ' -- the mds1 can be null in the full view due to dropped metas img | not (null mds1), view clientMetaView st = return -- singleton list $ cropRight width $ horizCat $ intersperse gap $ map renderCompressed mds1 | otherwise = [] processMeta (chan,msg,_) = case view mesgType msg of CtcpReqMsgType{} -> keep $ SimpleMetadata (char (withForeColor defAttr brightBlue) 'C') who JoinMsgType -> keep $ SimpleMetadata (char (withForeColor defAttr green) '+') who PartMsgType{} -> keep $ SimpleMetadata (char (withForeColor defAttr red) '-') who QuitMsgType{} -> keep $ SimpleMetadata (char (withForeColor defAttr red) 'x') who KnockMsgType -> keep $ SimpleMetadata (char (withForeColor defAttr yellow) 'K') who NickMsgType who' -> keep $ NickChange who who' _ | not visible -> keep $ SimpleMetadata (char (withForeColor defAttr yellow) 'I') who | otherwise -> Done where keep | chan == activeChan = Keep | otherwise = const Drop who = views mesgSender userNick msg visible = not (view (contains who) ignores) conn = view (clientServer0 . ccConnection) st prefixes = view (connChanModeTypes . modesPrefixModes) conn modePrefix modes = string (withForeColor defAttr blue) [ prefix | (mode,prefix) <- prefixes, mode `elem` modes] data CompressedMetadata = SimpleMetadata Image Identifier | NickChange Identifier Identifier renderCompressed :: CompressedMetadata -> Image renderCompressed md = case md of SimpleMetadata img who -> img <|> identImg metaAttr who NickChange who who' -> identImg metaAttr who <|> char (withForeColor defAttr yellow) '-' <|> identImg metaAttr who' where metaAttr = withForeColor defAttr brightBlack statusMsgImage :: String -> Image statusMsgImage status | null status = emptyImage | otherwise = char defAttr '(' <|> string (withForeColor defAttr brightRed) status <|> string defAttr ") " errorMessage :: IrcError -> Text errorMessage e = case e of ErrCantKillServer -> "Can't kill server" ErrYoureBannedCreep -> "Banned from server" ErrNoOrigin -> "No origin on PING or PONG" ErrErroneousNickname nick -> "Erroneous nickname: " <> asUtf8 nick ErrNoNicknameGiven -> "No nickname given" ErrNicknameInUse nick -> "Nickname in use: " <> asUtf8 (idBytes nick) ErrNotRegistered -> "Not registered" ErrNoSuchServer server -> "No such server: " <> asUtf8 server ErrUnknownMode mode -> "Unknown mode: " <> Text.pack [mode] ErrNoPrivileges -> "No privileges" ErrUnknownUmodeFlag mode -> "Unknown UMODE: " <> Text.pack [mode] ErrUnknownCommand cmd -> "Unknown command: " <> asUtf8 cmd ErrNoTextToSend -> "No text to send" ErrNoMotd -> "No MOTD" ErrNoRecipient -> "No recipient" ErrNoAdminInfo server -> "No admin info for server: "<> asUtf8 server ErrAcceptFull -> "ACCEPT list is full" ErrAcceptExist -> "Already on ACCEPT list" ErrAcceptNot -> "Not on ACCEPT list" ErrNeedMoreParams cmd -> "Need more parameters: " <> asUtf8 cmd ErrAlreadyRegistered -> "Already registered" ErrNoPermForHost -> "No permission for host" ErrPasswordMismatch -> "Password mismatch" ErrUsersDontMatch -> "Can't change modes for other users" ErrHelpNotFound _ -> "Help topic not found" ErrBadChanName name -> "Illegal channel name: " <> asUtf8 name ErrNoOperHost -> "No OPER line for this host" ErrNoSuchNick -> "No such nick" ErrWasNoSuchNick -> "Was no such nick" ErrOwnMode -> "Can't send while +g is set" ErrNoNonReg -> "Messages blocked from unregistered users" ErrIsChanService nick -> "Protected service: " <> asUtf8 (idBytes nick) ErrBanNickChange -> "Can't change kick when banned" ErrNickTooFast -> "Changed nickname too fast" ErrUnavailResource -> "Resource unavailable" ErrThrottle -> "Unable to join due to throttle" ErrTooManyChannels -> "Too many channels joined" ErrServicesDown -> "Services are unavailable" ErrUserNotInChannel nick -> "Not in channel: " <> asUtf8 (idBytes nick) ErrNotOnChannel -> "Must join channel" ErrChanOpPrivsNeeded -> "Channel privileges needed" ErrBadChannelKey -> "Bad channel key" ErrBannedFromChan -> "Unable to join due to ban" ErrChannelFull -> "Channel is full" ErrInviteOnlyChan -> "Invite only channel" ErrNoSuchChannel -> "No such channel" ErrCannotSendToChan -> "Cannot send to channel" ErrTooManyTargets -> "Too many targets" ErrBanListFull mode -> "Ban list full: " <> Text.singleton mode ErrUserOnChannel nick -> "User already on channel: " <> asUtf8 (idBytes nick) ErrLinkChannel chan -> "Forwarded to: " <> asUtf8 (idBytes chan) ErrNeedReggedNick -> "Registered nick required" ErrVoiceNeeded -> "Voice or operator status required" ErrKnockOnChan -> "Attempted to knock joined channel" ErrTooManyKnocks -> "Too many knocks" ErrChanOpen -> "Knock unnecessary" ErrTargUmodeG -> "Message ignored by +g mode" ErrNoPrivs priv -> "Oper privilege required: " <> asUtf8 priv ErrMlockRestricted m ms -> "Mode '" <> Text.singleton m <> "' in locked set \"" <> asUtf8 ms <> "\"" data SplitResult a = Drop -- drop this element but keep processing | Done -- stop processing | Keep a -- produce an output and keep processing splitWith :: (a -> SplitResult b) -> [a] -> ([b],[a]) splitWith _ [] = ([],[]) splitWith f (x:xs) = case f x of Done -> ([],x:xs) Drop -> splitWith f xs Keep y -> case splitWith f xs of (ys,xs') -> (y:ys, xs') mergeMetadatas :: [CompressedMetadata] -> [CompressedMetadata] mergeMetadatas (SimpleMetadata img1 who1 : SimpleMetadata img2 who2 : xs) | who1 == who2 = mergeMetadatas (SimpleMetadata (img1 <|> img2) who1 : xs) mergeMetadatas (x:xs) = x : mergeMetadatas xs mergeMetadatas [] = [] interleavedMessages :: ClientState -> [(Identifier,IrcMessage,Image)] interleavedMessages st = merge lists where lists :: [[(Identifier,IrcMessage,Image)]] lists = [ [ (chan, msg, img) | (msg,img) <- view mlMessages msgs ] | (chan,msgs) <- views clientMessages Map.toList st ] merge :: [[(Identifier,IrcMessage,Image)]] -> [(Identifier,IrcMessage,Image)] merge [] = [] merge [x] = x merge xs = merge (mergeN1 xs) -- merge every two lists into one mergeN1 :: [[(Identifier,IrcMessage,Image)]] -> [[(Identifier,IrcMessage,Image)]] mergeN1 [] = [] mergeN1 [x] = [x] mergeN1 (x:y:z) = merge2 x y : mergeN1 z -- merge two sorted lists into one merge2 :: [(Identifier,IrcMessage,Image)] -> [(Identifier,IrcMessage,Image)] -> [(Identifier,IrcMessage,Image)] merge2 [] ys = ys merge2 xs [] = xs merge2 (x:xs) (y:ys) | view (_2.mesgStamp) x >= view (_2.mesgStamp) y = x : merge2 xs (y:ys) | otherwise = y : merge2 (x:xs) ys toUtf8 :: String -> BS.ByteString toUtf8 = Text.encodeUtf8 . Text.pack irc-core-1.1.3/driver/Views/ChannelInfo.hs0000644000000000000000000000653112622517457016535 0ustar0000000000000000module Views.ChannelInfo where import ClientState import Control.Lens import Data.ByteString (ByteString) import Data.List (partition) import Data.Map (Map) import Data.Monoid import Graphics.Vty.Image import ImageUtils import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as Map import Irc.Format import Irc.Model channelInfoImage :: Identifier -> ClientState -> [Image] channelInfoImage chan st = let conn = view (clientServer0 . ccConnection) st in case view (connChannels . at chan) conn of Nothing -> [string (withForeColor defAttr red) "Unknown channel"] Just channel -> topicLines ++ creationLines ++ modeLines ++ urlLines ++ usersLines where topicLines = case view chanTopic channel of Nothing -> [string (withForeColor defAttr red) "Unknown topic"] Just Nothing -> [ string (withForeColor defAttr green) "Empty Topic " ] Just (Just (topic, user, time)) -> [ string (withForeColor defAttr green) "Topic: " <|> cleanText topic , string (withForeColor defAttr green) "Set by: " <|> cleanText (asUtf8 user) , string (withForeColor defAttr green) "Set on: " <|> string defAttr (show time) ] creationLines = case view chanCreation channel of Nothing -> [string (withForeColor defAttr red) "Unknown creation time"] Just time -> [ string (withForeColor defAttr green) "Created on: " <|> string defAttr (show time) ] modeLines = case view chanModes channel of Nothing -> [string (withForeColor defAttr red) "Unknown mode"] Just modes -> [ string (withForeColor defAttr green) "Mode: " <|> utf8Bytestring' defAttr (renderModes modes) ] urlLines = case view chanUrl channel of Nothing -> [string (withForeColor defAttr red) "Unknown URL"] Just url -> [ string (withForeColor defAttr green) "URL: " <|> cleanText (asUtf8 url) ] prefixes = view (connChanModeTypes . modesPrefixModes) conn modePrefix modes = string (withForeColor defAttr blue) [ prefix | (mode,prefix) <- prefixes, mode `elem` modes ] usersLines = return $ horizCat $ string (withForeColor defAttr green) "Users (" : string defAttr (show (Map.size (view chanUsers channel))) : string (withForeColor defAttr green) "):" : [ char defAttr ' ' <|> modePrefix modes <|> identImg defAttr nick | (nick,modes) <- reorderUsers (map fst prefixes) $ Map.toList (view chanUsers channel) ] reorderUsers :: [Char] -> [(Identifier,[Char])] -> [(Identifier,[Char])] reorderUsers [] users = users reorderUsers (m:ms) users = haves ++ reorderUsers ms havenots where (haves,havenots) = partition (elem m . snd) users renderModes :: Map Char ByteString -> ByteString renderModes modes = B8.pack ('+':modeLetters) <> B8.concat (map (B8.cons ' ') (filter (not . B8.null) modeArgs)) where (modeLetters,modeArgs) = unzip (Map.toList modes) irc-core-1.1.3/src/0000755000000000000000000000000012622517457012207 5ustar0000000000000000irc-core-1.1.3/src/Irc/0000755000000000000000000000000012622517457012724 5ustar0000000000000000irc-core-1.1.3/src/Irc/Cmd.hs0000644000000000000000000002405612622517457013772 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This module provides functions for constructing -- outgoing IRC messages from the client to the server. -- -- Note: These functions add the required trailing newline -- characters. module Irc.Cmd ( passCmd , nickCmd , userCmd , operCmd , modeCmd , quitCmd , joinCmd , partCmd , topicCmd , namesCmd , listCmd , inviteCmd , kickCmd , privMsgCmd , ctcpRequestCmd , ctcpResponseCmd , noticeCmd , whoisCmd , whowasCmd , whoCmd , pongCmd , pingCmd , capLsCmd , capReqCmd , capEndCmd , authenticateCmd , awayCmd , helpCmd , removeCmd , knockCmd , acceptCmd , timeCmd , adminCmd , statsCmd ) where import Data.Monoid import Data.ByteString (ByteString) import Data.Foldable (toList) import qualified Data.ByteString.Char8 as B8 import Irc.Format outgoingMsg :: RawIrcMsg outgoingMsg = RawIrcMsg { msgTime = Nothing , msgPrefix = Nothing , msgCommand = "" , msgParams = [] } -- | Construct a MODE command -- -- @MODE target *(mode) *(modeparams)@ modeCmd :: Identifier {- ^ target -} -> [ByteString] {- ^ modes and params -} -> ByteString modeCmd c modes = renderRawIrcMsg outgoingMsg { msgCommand = "MODE" , msgParams = idBytes c : modes } -- | Construct a KICK command -- -- @KICK channel nick msg kickCmd :: Identifier {- ^ channel -} -> Identifier {- ^ nick -} -> ByteString {- ^ msg -} -> ByteString kickCmd c nick msg = renderRawIrcMsg outgoingMsg { msgCommand = "KICK" , msgParams = [idBytes c, idBytes nick, msg] } -- | Construct a REMOVE command -- -- @REMOVE channel nick msg removeCmd :: Identifier {- ^ channel -} -> Identifier {- ^ nick -} -> ByteString {- ^ msg -} -> ByteString removeCmd c nick msg = renderRawIrcMsg outgoingMsg { msgCommand = "REMOVE" , msgParams = [idBytes c, idBytes nick, msg] } -- | Construct a JOIN command. A join command -- can support multiple channels separated by -- commas, and takes an optional channel key. -- -- @JOIN channel [key]@ joinCmd :: Identifier -> Maybe ByteString -> ByteString joinCmd chan mbKeys = renderRawIrcMsg outgoingMsg { msgCommand = "JOIN" , msgParams = [idBytes chan] <> toList mbKeys } -- | Construct a PART command. -- -- @PART channel message@ partCmd :: Identifier {- ^ channel -} -> ByteString {- ^ message -} -> ByteString partCmd chan msg = renderRawIrcMsg outgoingMsg { msgCommand = "PART" , msgParams = [idBytes chan,msg] } -- | Construct a TOPIC command. This is used to lookup -- the current topic or to change it. -- -- @TOPIC channel message@ topicCmd :: Identifier {- ^ channel -} -> ByteString {- ^ topic -} -> ByteString topicCmd chan msg = renderRawIrcMsg outgoingMsg { msgCommand = "TOPIC" , msgParams = [idBytes chan,msg] } -- | Construct a WHOIS command. -- -- @WHOIS user@ whoisCmd :: Identifier {- ^ user -} -> ByteString whoisCmd user = renderRawIrcMsg outgoingMsg { msgCommand = "WHOIS" , msgParams = [idBytes user] } -- | Construct a WHOWAS command. -- -- @WHOWAS user@ whowasCmd :: Identifier {- ^ user -} -> ByteString whowasCmd user = renderRawIrcMsg outgoingMsg { msgCommand = "WHOWAS" , msgParams = [idBytes user] } -- | Construct a NICK command. This is used to specify -- the initial nickname as well as to change it. -- -- @NICK nickname@ nickCmd :: Identifier {- ^ nickname -} -> ByteString nickCmd nick = renderRawIrcMsg outgoingMsg { msgCommand = "NICK" , msgParams = [idBytes nick] } -- | Construct a USER command. This is used in the initial -- handshake to specify username and realname. -- -- @USER username 0 * realname@ userCmd :: ByteString {- ^ username -} -> ByteString {- ^ realname -} -> ByteString userCmd user realname = renderRawIrcMsg outgoingMsg { msgCommand = "USER" , msgParams = [user,"0","*",realname] } -- | Construct a PING command. This is used to respond to the PING -- command to keep a connection alive. -- -- @PONG token@ pingCmd :: ByteString {- ^ token -} -> ByteString pingCmd token = renderRawIrcMsg outgoingMsg { msgCommand = "PING" , msgParams = [token] } -- | Construct a PONG command. This is used to respond to the PING -- command to keep a connection alive. -- -- @PONG token@ pongCmd :: ByteString {- ^ token -} -> ByteString pongCmd token = renderRawIrcMsg outgoingMsg { msgCommand = "PONG" , msgParams = [token] } -- | Construct a PASS command. This is used in the initial handshake -- to specify a password for the connection. -- -- @PASS password@ passCmd :: ByteString {- ^ password -} -> ByteString passCmd password = renderRawIrcMsg outgoingMsg { msgCommand = "PASS" , msgParams = [password] } -- | Construct a CAP LS command. This is used during the inital connection -- to request a list of extensions that are supported by the server. It -- should be followed by CAP REQ and eventually CAP END commands. -- -- @CAP LS@ capLsCmd :: ByteString capLsCmd = renderRawIrcMsg outgoingMsg { msgCommand = "CAP" , msgParams = ["LS"] } -- | Construct a CAP REQ command. This is used to request a subset of -- the capabilities returned in response to a CAP LS command. -- -- @CAP REQ :cap0 cap1 .. capN@ capReqCmd :: [ByteString] -> ByteString capReqCmd caps = renderRawIrcMsg outgoingMsg { msgCommand = "CAP" , msgParams = ["REQ",B8.unwords caps] } -- | Construct a CAP END command. This terminates the capability -- negotiation portion of the initial connection. -- -- @CAP END@ capEndCmd :: ByteString capEndCmd = renderRawIrcMsg outgoingMsg { msgCommand = "CAP" , msgParams = ["END"] } -- | Construct a PRIVMSG command. This send normal chat messages -- to both users as well as channels. -- -- @PRIVMSG target message@ privMsgCmd :: Identifier {- ^ target -} -> ByteString {- ^ message -} -> ByteString privMsgCmd target msg = renderRawIrcMsg outgoingMsg { msgCommand = "PRIVMSG" , msgParams = [idBytes target,msg] } ctcpRequestCmd :: Identifier {- ^ target -} -> ByteString {- ^ command -} -> ByteString {- ^ parameters -} -> ByteString ctcpRequestCmd target command params = renderRawIrcMsg outgoingMsg { msgCommand = "PRIVMSG" , msgParams = [idBytes target, "\x01" <> command <> " " <> params <> "\x01"] } ctcpResponseCmd :: Identifier {- ^ target -} -> ByteString {- ^ command -} -> ByteString {- ^ parameters -} -> ByteString ctcpResponseCmd target command params = renderRawIrcMsg outgoingMsg { msgCommand = "NOTICE" , msgParams = [idBytes target, "\x01" <> command <> " " <> params <> "\x01"] } -- | Construct a NOTICE command. This send notice chat messages -- to both users as well as channels. -- -- @NOTICE target message@ noticeCmd :: Identifier {- ^ target -} -> ByteString {- ^ message -} -> ByteString noticeCmd target msg = renderRawIrcMsg outgoingMsg { msgCommand = "NOTICE" , msgParams = [idBytes target,msg] } -- | Construct an AUTHENTICATE command. -- -- @AUTHENTICATE message@ authenticateCmd :: ByteString {- ^ message -} -> ByteString authenticateCmd msg = renderRawIrcMsg outgoingMsg { msgCommand = "AUTHENTICATE" , msgParams = [msg] } -- | Construct a HELP command. -- -- @HELP topic@ helpCmd :: ByteString {- ^ topic -} -> ByteString helpCmd msg = renderRawIrcMsg outgoingMsg { msgCommand = "HELP" , msgParams = [msg] } -- | Construct an AWAY command. -- -- @AWAY away_message@ awayCmd :: ByteString {- ^ message -} -> ByteString awayCmd msg = renderRawIrcMsg outgoingMsg { msgCommand = "AWAY" , msgParams = [msg] } -- | Construct a QUIT command. -- -- @QUIT quit_message@ quitCmd :: ByteString {- ^ message -} -> ByteString quitCmd msg = renderRawIrcMsg outgoingMsg { msgCommand = "QUIT" , msgParams = [msg] } -- | Construct a LIST command. -- -- @LIST *("," ) @ listCmd :: [Identifier] {- ^ channels -} -> ByteString listCmd chans = renderRawIrcMsg outgoingMsg { msgCommand = "LIST" , msgParams = [B8.intercalate "," (map idBytes chans)] } -- | Construct a INVITE command. -- -- @INVITE @ inviteCmd :: Identifier {- ^ nickname -} -> Identifier {- ^ channel -} -> ByteString inviteCmd nick chan = renderRawIrcMsg outgoingMsg { msgCommand = "INVITE" , msgParams = [idBytes nick,idBytes chan] } -- | Construct a NAMES command. -- -- @NAMES [ *("," )@ namesCmd :: [Identifier] {- ^ channels -} -> ByteString namesCmd chans = renderRawIrcMsg outgoingMsg { msgCommand = "NAMES" , msgParams = if null chans then [] else [B8.intercalate "," (map idBytes chans)] } -- | Construct an OPER command. -- -- @OPER @ operCmd :: ByteString {- ^ name -} -> ByteString {- ^ password -} -> ByteString operCmd name pass = renderRawIrcMsg outgoingMsg { msgCommand = "OPER" , msgParams = [name,pass] } -- | Construct a WHO command. -- -- @WHO @ whoCmd :: ByteString {- ^ mask -} -> ByteString whoCmd mask = renderRawIrcMsg outgoingMsg { msgCommand = "WHO" , msgParams = [mask] } -- | Construct a KNOCK command. -- -- @KNOCK @ knockCmd :: Identifier {- ^ channel -} -> ByteString knockCmd chan = renderRawIrcMsg outgoingMsg { msgCommand = "KNOCK" , msgParams = [idBytes chan] } -- | Construct an ACCEPT command. -- -- @ACCEPT @ acceptCmd :: ByteString {- ^ nick, -nick, * -} -> ByteString acceptCmd nick = renderRawIrcMsg outgoingMsg { msgCommand = "ACCEPT" , msgParams = [nick] } -- | Construct an TIME command. -- -- @TIME []>@ timeCmd :: Maybe ByteString {- ^ server -} -> ByteString timeCmd server = renderRawIrcMsg outgoingMsg { msgCommand = "TIME" , msgParams = toList server } -- | Construct an ADMIN command. -- -- @ADMIN []>@ adminCmd :: Maybe ByteString {- ^ server -} -> ByteString adminCmd server = renderRawIrcMsg outgoingMsg { msgCommand = "ADMIN" , msgParams = toList server } -- | Construct a STATS command. -- -- @STATS []>@ statsCmd :: Char -> Maybe ByteString {- ^ target -} -> ByteString statsCmd letter target = renderRawIrcMsg outgoingMsg { msgCommand = "STATS" , msgParams = B8.singleton letter : toList target } irc-core-1.1.3/src/Irc/Core.hs0000644000000000000000000006003212622517457014151 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | This module provides a bridge between the low-level text protocol that -- IRC uses and the high-level events in the "Irc.Model" module. module Irc.Core ( MsgFromServer(..) , IrcError(..) , ircMsgToServerMsg ) where import Control.Lens (over, _2) import Data.ByteString (ByteString) import Data.Time import Data.Time.Clock.POSIX import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Irc.Format -- | 'MsgFromServer' provides a typed view of the various IRC protocol messages. -- There are more messages defined for IRC (and many of those overlap) than -- are in common use. Please report a bug if a common message is missing -- from this type. data MsgFromServer -- 001-099 Client-server connection messages = RplWelcome ByteString -- ^ 001 "Welcome to the Internet Relay Network \!\\@\" | RplYourHost ByteString -- ^ 002 "Your host is \, running version \" | RplCreated ByteString -- ^ 003 "This server was created \" | RplMyInfo ByteString ByteString [ByteString] -- ^ 004 servername version *(modes) | RplISupport [(ByteString,ByteString)] -- ^ 005 *(KEY=VALUE) | RplSnoMask ByteString -- ^ 008 snomask | RplYourId ByteString -- ^ 042 unique-id -- 200-399 Command responses | RplStatsLinkInfo [ByteString] -- ^ 211 arguments | RplStatsCommands [ByteString] -- ^ 212 arguments | RplStatsCLine [ByteString] -- ^ 213 arguments | RplStatsNLine [ByteString] -- ^ 214 arguments | RplStatsILine [ByteString] -- ^ 215 arguments | RplStatsKLine [ByteString] -- ^ 216 arguments | RplStatsQLine [ByteString] -- ^ 217 arguments | RplStatsYLine [ByteString] -- ^ 218 arguments | RplEndOfStats Char -- ^ 219 mode | RplStatsPLine [ByteString] -- ^ 220 arguments | RplUmodeIs ByteString [ByteString] -- ^ 221 modes *(params) | RplStatsDLine [ByteString] -- ^ 225 | RplStatsVLine [ByteString] -- ^ 240 | RplStatsLLine [ByteString] -- ^ 241 | RplStatsUptime ByteString -- ^ 242 | RplStatsOLine [ByteString] -- ^ 243 | RplStatsHLine [ByteString] -- ^ 244 | RplStatsSLine [ByteString] -- ^ 245 | RplStatsPing [ByteString] -- ^ 246 | RplStatsXLine [ByteString] -- ^ 247 | RplStatsULine [ByteString] -- ^ 248 | RplStatsDebug [ByteString] -- ^ 249 | RplStatsConn ByteString -- ^ 250 connection | RplLuserClient ByteString -- ^ 251 "There are \ users and \ services on \ servers" | RplLuserOp ByteString -- ^ 252 number-of-ops | RplLuserUnknown ByteString -- ^ 253 number-of-unknown | RplLuserChannels ByteString -- ^ 254 number-of-channels | RplLuserMe ByteString -- ^ 255 "I have \ clients and \ servers" | RplLuserAdminMe ByteString -- ^ 256 server | RplLuserAdminLoc1 ByteString -- ^ 257 admin-info-1 | RplLuserAdminLoc2 ByteString -- ^ 258 admin-info-2 | RplLuserAdminEmail ByteString -- ^ 259 admin-email | RplLoadTooHigh ByteString -- ^ 263 command | RplLocalUsers [ByteString] -- ^ 265 [local] [max] txt | RplGlobalUsers [ByteString] -- ^ 266 [global] [max] txt | RplPrivs ByteString -- ^ 270 privstring | RplWhoisCertFp Identifier ByteString -- ^ 276 nick txt | RplAcceptList Identifier -- ^ 281 | RplEndOfAccept -- ^ 282 | RplAway Identifier ByteString -- ^ 301 nick away_message | RplUserHost [ByteString] -- ^ 302 *(user hosts) | RplIsOn [Identifier] -- ^ 303 *(nick) | RplSyntax ByteString -- ^ (inspircd) 304 text | RplUnAway -- ^ 305 | RplNowAway -- ^ 306 | RplWhoisUser Identifier ByteString ByteString ByteString -- ^ 311 nick user host realname | RplWhoisServer Identifier ByteString ByteString -- ^ 312 nick server serverinfo | RplWhoisOperator Identifier ByteString -- ^ 313 nick "is an IRC operator" | RplWhoWasUser Identifier ByteString ByteString ByteString -- ^ 314 nick user host realname | RplEndOfWho Identifier -- ^ 315 channel | RplWhoisIdle Identifier Integer (Maybe UTCTime) -- ^ 317 nick idle signon | RplEndOfWhois Identifier -- ^ 318 nick | RplWhoisChannels Identifier ByteString -- ^ 319 nick channels | RplListStart -- ^ 321 | RplList Identifier Integer ByteString -- ^ 322 channel usercount topic | RplListEnd -- ^ 323 | RplChannelModeIs Identifier ByteString [ByteString] -- ^ 324 channel modes *(params) | RplNoTopicSet Identifier -- ^ 331 channel | RplTopic Identifier ByteString -- ^ 332 channel topic | RplChannelUrl Identifier ByteString -- ^ 328 channel url | RplCreationTime Identifier UTCTime -- ^ 329 channel timestamp | RplWhoisAccount Identifier ByteString -- ^ 330 nick account | RplTopicWhoTime Identifier ByteString UTCTime -- ^ 333 channel nickname timestamp | RplInviting Identifier Identifier -- ^ 341 nick channel | RplInviteList Identifier ByteString ByteString UTCTime -- ^ 346 channel mask who timestamp | RplEndOfInviteList Identifier -- ^ 347 channel | RplExceptionList Identifier ByteString ByteString UTCTime -- ^ 348 channel mask who timestamp | RplEndOfExceptionList Identifier -- ^ 349 channel | RplVersion [ByteString] -- ^ 351 version server comments | RplWhoReply Identifier ByteString ByteString ByteString Identifier ByteString ByteString -- ^ 352 channel user host server nick flags txt | RplNameReply ChannelType Identifier [ByteString] -- ^ 353 channeltype channel names | RplLinks ByteString ByteString ByteString -- ^ 364 mask server info | RplEndOfLinks ByteString -- ^ 365 mask | RplEndOfNames Identifier -- ^ 366 channel | RplBanList Identifier ByteString ByteString UTCTime -- ^ 367 channel banned banner timestamp | RplEndOfBanList Identifier -- ^ 368 channel | RplEndOfWhoWas Identifier -- ^ 369 nick | RplMotd ByteString -- ^ 372 line-of-motd | RplMotdStart -- ^ 375 | RplEndOfMotd -- ^ 376 | RplTime ByteString ByteString -- ^ 391 server "\" | RplInfo ByteString -- ^ 371 info | RplEndOfInfo -- ^ 374 | RplWhoisHost Identifier ByteString -- ^ 378 nick host | RplWhoisModes Identifier ByteString [ByteString] -- ^ 379 nick modes *(args) | RplYoureOper ByteString -- ^ 381 text | RplHostHidden ByteString -- ^ 396 hostname | Err Identifier IrcError -- Random high-numbered stuff | RplWhoisSecure Identifier -- ^ 671 nick | RplHelpStart ByteString ByteString -- ^ 704 topic text | RplHelp ByteString ByteString -- ^ 705 topic text | RplEndOfHelp ByteString -- ^ 706 topic text | RplKnock Identifier UserInfo -- ^ 710 channel | RplKnockDelivered Identifier -- ^ 711 channel | RplTargNotify Identifier -- ^ 717 nick | RplUmodeGMsg Identifier ByteString -- ^ 718 nick mask | RplQuietList Identifier Char ByteString ByteString UTCTime -- ^ 728 channel mode mask who timestamp | RplEndOfQuietList Identifier Char -- ^ 729 channel mode -- SASL stuff | RplLoggedIn ByteString -- ^ 900 account | RplLoggedOut -- ^ 901 | RplNickLocked -- ^ 902 | RplSaslSuccess -- ^ 903 | RplSaslFail -- ^ 904 | RplSaslTooLong -- ^ 905 | RplSaslAborted -- ^ 906 | RplSaslAlready -- ^ 907 | RplSaslMechs ByteString -- ^ 908 comma-sep-mechs | Away UserInfo (Maybe ByteString) | Ping ByteString | Pong ByteString (Maybe ByteString) | Notice UserInfo Identifier ByteString | Topic UserInfo Identifier ByteString | PrivMsg UserInfo Identifier ByteString | ExtJoin UserInfo Identifier (Maybe ByteString) ByteString | Join UserInfo Identifier | Nick UserInfo Identifier | Mode UserInfo Identifier [ByteString] | Quit UserInfo ByteString | Cap ByteString ByteString | Kick UserInfo Identifier Identifier ByteString | Part UserInfo Identifier ByteString | Invite UserInfo Identifier | Error ByteString | Authenticate ByteString | Account UserInfo (Maybe ByteString) deriving (Read, Show) data IrcError -- 400-499 Errors = ErrNoSuchNick -- ^ 401 | ErrNoSuchServer ByteString -- ^ 402 server | ErrNoSuchChannel -- ^ 403 | ErrCannotSendToChan -- ^ 404 | ErrTooManyChannels -- ^ 405 | ErrWasNoSuchNick -- ^ 406 | ErrTooManyTargets -- ^ 407 | ErrNoOrigin -- ^ 409 | ErrNoRecipient -- ^ 411 | ErrNoTextToSend -- ^ 412 | ErrUnknownCommand ByteString -- ^ 421 command | ErrNoMotd -- ^ 422 | ErrNoAdminInfo ByteString -- ^ 423 server | ErrNoNicknameGiven -- ^ 431 | ErrErroneousNickname ByteString -- ^ 432 badnick | ErrNicknameInUse Identifier -- ^ 433 nick | ErrBanNickChange -- ^ 435 | ErrUnavailResource -- ^ 437 | ErrNickTooFast -- ^ 438 | ErrServicesDown -- ^ 440 | ErrUserNotInChannel Identifier -- ^ 441 nick | ErrNotOnChannel -- ^ 442 channel | ErrUserOnChannel Identifier -- ^ 443 nick | ErrNotRegistered -- ^ 451 | ErrAcceptFull -- ^ 456 | ErrAcceptExist -- ^ 457 | ErrAcceptNot -- ^ 458 | ErrNeedMoreParams ByteString -- ^ 461 command | ErrAlreadyRegistered -- ^ 462 | ErrNoPermForHost -- ^ 463 | ErrPasswordMismatch -- ^ 464 | ErrYoureBannedCreep -- ^ 465 | ErrLinkChannel Identifier -- ^ 470 dstchannel | ErrChannelFull -- ^ 471 channel | ErrUnknownMode Char -- ^ 472 mode | ErrInviteOnlyChan -- ^ 473 | ErrBannedFromChan -- ^ 474 | ErrBadChannelKey -- ^ 475 | ErrNeedReggedNick -- ^ 477 | ErrBanListFull Char -- ^ 478 mode | ErrBadChanName ByteString -- ^ 479 name | ErrThrottle -- ^ 480 | ErrNoPrivileges -- ^ 481 | ErrChanOpPrivsNeeded -- ^ 482 | ErrCantKillServer -- ^ 483 | ErrIsChanService Identifier -- ^ 484 nick | ErrNoNonReg -- ^ 486 | ErrVoiceNeeded -- ^ 489 | ErrNoOperHost -- ^ 491 | ErrOwnMode -- ^ 494 | ErrUnknownUmodeFlag Char -- ^ 501 mode | ErrUsersDontMatch -- ^ 502 | ErrHelpNotFound ByteString -- ^ 524 topic | ErrTooManyKnocks -- ^ 713 | ErrChanOpen -- ^ 713 | ErrKnockOnChan -- ^ 714 | ErrTargUmodeG -- ^ 716 | ErrNoPrivs ByteString -- ^ 723 priv | ErrMlockRestricted Char ByteString -- ^ 742 mode setting deriving (Read, Show) data ChannelType = SecretChannel | PrivateChannel | PublicChannel deriving (Read, Show) ircMsgToServerMsg :: RawIrcMsg -> Maybe MsgFromServer ircMsgToServerMsg ircmsg = case (msgCommand ircmsg, msgParams ircmsg) of ("001",[_,txt]) -> Just (RplWelcome txt) ("002",[_,txt]) -> Just (RplYourHost txt) ("003",[_,txt]) -> Just (RplCreated txt) ("004", _:host:version:modes) -> Just (RplMyInfo host version modes) ("005",_:params) | not (null params) -> let parse1 = over _2 (B.drop 1) . B8.break (=='=') in Just (RplISupport (map parse1 (init params))) ("008",[_,snomask,_]) -> Just (RplSnoMask (B.tail snomask)) ("042",[_,yourid,_]) -> Just (RplYourId yourid) ("211", _:linkinfo) -> Just (RplStatsLinkInfo linkinfo) ("212", _:commands) -> Just (RplStatsCommands commands) ("213", _:cline ) -> Just (RplStatsCLine cline) ("214", _:nline ) -> Just (RplStatsNLine nline) ("215", _:iline ) -> Just (RplStatsILine iline) ("216", _:kline ) -> Just (RplStatsKLine kline) ("217", _:qline ) -> Just (RplStatsQLine qline) ("218", _:yline ) -> Just (RplStatsYLine yline) ("219",[_,mode,_] ) -> Just (RplEndOfStats (B8.head mode)) ("220", _:pline ) -> Just (RplStatsPLine pline) ("221", _:mode:params) -> Just (RplUmodeIs mode params) ("225", _:dline ) -> Just (RplStatsDLine dline) ("240", _:vline ) -> Just (RplStatsVLine vline) ("241", _:lline ) -> Just (RplStatsLLine lline) ("242", [_,uptime]) -> Just (RplStatsUptime uptime) ("243", _:oline ) -> Just (RplStatsOLine oline) ("244", _:hline ) -> Just (RplStatsHLine hline) ("245", _:sline ) -> Just (RplStatsSLine sline) ("246", _:ping ) -> Just (RplStatsPing ping ) ("247", _:xline ) -> Just (RplStatsXLine xline) ("248", _:uline ) -> Just (RplStatsULine uline) ("249", _:debug ) -> Just (RplStatsDebug debug) ("250",[_,stats]) -> Just (RplStatsConn stats) ("251",[_,stats]) -> Just (RplLuserClient stats) ("252",[_,num,_]) -> Just (RplLuserOp num) ("253",[_,num,_]) -> Just (RplLuserUnknown num) ("254",[_,num,_]) -> Just (RplLuserChannels num) ("255",[_,txt]) -> Just (RplLuserMe txt) ("256",[_,server]) -> Just (RplLuserAdminMe server) ("257",[_,txt]) -> Just (RplLuserAdminLoc1 txt) ("258",[_,txt]) -> Just (RplLuserAdminLoc2 txt) ("259",[_,txt]) -> Just (RplLuserAdminEmail txt) ("263",[_,cmd,_]) -> Just (RplLoadTooHigh cmd) ("265", _:params) -> Just (RplLocalUsers params) ("266", _:params ) -> Just (RplGlobalUsers params) ("270",[_,txt]) -> Just (RplPrivs txt) ("276",[_,nick,txt]) -> Just (RplWhoisCertFp (mkId nick) txt) ("281",[_,nick]) -> Just (RplAcceptList (mkId nick)) ("282",[_,_]) -> Just RplEndOfAccept ("301",[_,nick,message]) -> Just (RplAway (mkId nick) message) ("302",[_,txt]) -> Just (RplUserHost (filter (not . B.null) (B8.split ' ' txt))) ("303",[_,txt]) -> Just (RplIsOn (map mkId (filter (not . B.null) (B8.split ' ' txt)))) ("304",[_,txt]) -> Just (RplSyntax txt) ("305",[_,_]) -> Just RplUnAway ("306",[_,_]) -> Just RplNowAway ("311",[_,nick,user,host,_star,txt]) -> Just (RplWhoisUser (mkId nick) user host txt) ("312",[_,nick,server,txt]) -> Just (RplWhoisServer (mkId nick) server txt) ("314",[_,nick,user,host,_star,txt]) -> Just (RplWhoWasUser (mkId nick) user host txt) ("319",[_,nick,txt]) -> Just (RplWhoisChannels (mkId nick) txt) ("313",[_,nick,txt]) -> Just (RplWhoisOperator (mkId nick) txt) ("315",[_,chan,_]) -> Just (RplEndOfWho (mkId chan)) ("317",[_,nick,idle,signon,_txt]) -> Just (RplWhoisIdle (mkId nick) (asNumber idle) (Just (asTimeStamp signon))) ("317",[_,nick,idle,_txt]) -> Just (RplWhoisIdle (mkId nick) (asNumber idle) Nothing) ("318",[_,nick,_txt]) -> Just (RplEndOfWhois (mkId nick)) ("321",[_,_,_]) -> Just RplListStart ("322",[_,chan,num,topic]) -> Just (RplList (mkId chan) (asNumber num) topic) ("323",[_,_]) -> Just RplListEnd ("324",_:chan:modes:params) -> Just (RplChannelModeIs (mkId chan) modes params) ("328",[_,chan,url]) -> Just (RplChannelUrl (mkId chan) url) ("329",[_,chan,time]) -> Just (RplCreationTime (mkId chan) (asTimeStamp time)) ("330",[_,nick,account,_txt]) -> Just (RplWhoisAccount (mkId nick) account) ("331",[_,chan,_]) -> Just (RplNoTopicSet (mkId chan)) ("332",[_,chan,txt]) -> Just (RplTopic (mkId chan) txt) ("333",[_,chan,who,time]) -> Just (RplTopicWhoTime (mkId chan) who (asTimeStamp time)) ("341",[_,nick,chan,_]) -> Just (RplInviting (mkId nick) (mkId chan)) ("346",[_,chan,mask,who,time]) -> Just (RplInviteList (mkId chan) mask who (asTimeStamp time)) ("347",[_,chan,_txt]) -> Just (RplEndOfInviteList (mkId chan)) ("348",[_,chan,mask,who,time]) -> Just (RplExceptionList (mkId chan) mask who (asTimeStamp time)) ("349",[_,chan,_txt]) -> Just (RplEndOfExceptionList (mkId chan)) ("351", _:version) -> Just (RplVersion version) ("352",[_,chan,user,host,server,nick,flags,txt]) -> Just (RplWhoReply (mkId chan) user host server (mkId nick) flags txt) -- trailing is: ("353",[_,ty,chan,txt]) -> do ty' <- case ty of "=" -> Just PublicChannel "*" -> Just PrivateChannel "@" -> Just SecretChannel _ -> Nothing Just (RplNameReply ty' (mkId chan) (filter (not . B.null) (B8.split ' ' txt))) ("364",[_,mask,server,info]) -> Just (RplLinks mask server info) ("365",[_,mask,_] ) -> Just (RplEndOfLinks mask) ("366",[_,chan,_]) -> Just (RplEndOfNames (mkId chan)) ("367",[_,chan,banned,banner,time]) -> Just (RplBanList (mkId chan) banned banner (asTimeStamp time)) ("368",[_,chan,_txt]) -> Just (RplEndOfBanList (mkId chan)) ("369",[_,nick,_]) -> Just (RplEndOfWhoWas (mkId nick)) ("371",[_,txt]) -> Just (RplInfo txt) ("374",[_,_]) -> Just RplEndOfInfo ("375",[_,_]) -> Just RplMotdStart ("372",[_,txt]) -> Just (RplMotd txt) ("376",[_,_]) -> Just RplEndOfMotd ("379",_:nick:modes:args) -> Just (RplWhoisModes (mkId nick) modes args) ("378",[_,nick,txt]) -> Just (RplWhoisHost (mkId nick) txt) ("381",[_,txt]) -> Just (RplYoureOper txt) ("391",[_,server,txt]) -> Just (RplTime server txt) ("396",[_,host,_]) -> Just (RplHostHidden host) ("401",[_,nick,_]) -> Just (Err (mkId nick) ErrNoSuchNick) ("402",[_,server,_]) -> Just (Err "" (ErrNoSuchServer server)) ("403",[_,channel,_]) -> Just (Err (mkId channel) ErrNoSuchChannel) ("404",[_,channel,_]) -> Just (Err (mkId channel) ErrCannotSendToChan) ("405",[_,channel,_]) -> Just (Err (mkId channel) ErrTooManyChannels) ("406",[_,nick,_]) -> Just (Err (mkId nick) ErrWasNoSuchNick) ("407",[_,target,_]) -> Just (Err (mkId target) ErrTooManyTargets) ("409",[_,_]) -> Just (Err "" ErrNoOrigin) ("411",[_,_]) -> Just (Err "" ErrNoRecipient) ("412",[_,_]) -> Just (Err "" ErrNoTextToSend) ("421",[_,cmd,_]) -> Just (Err "" (ErrUnknownCommand cmd)) ("422",[_,_]) -> Just (Err "" ErrNoMotd) ("423",[_,server,_]) -> Just (Err "" (ErrNoAdminInfo server)) ("431",[_,_]) -> Just (Err "" ErrNoNicknameGiven) ("432",[_,nick,_]) -> Just (Err "" (ErrErroneousNickname nick)) ("433",[_,nick,_]) -> Just (Err "" (ErrNicknameInUse (mkId nick))) ("435",[_,chan,_]) -> Just (Err (mkId chan) ErrBanNickChange) ("437",[_,ident,_]) -> Just (Err (mkId ident) ErrUnavailResource) ("438",[_,_,_,_]) -> Just (Err "" ErrNickTooFast) ("441",[_,nick,_]) -> Just (Err (mkId nick) ErrServicesDown) ("441",[_,nick,chan,_]) -> Just (Err (mkId chan) (ErrUserNotInChannel (mkId nick))) ("442",[_,chan,_]) -> Just (Err (mkId chan) ErrNotOnChannel) ("443",[_,nick,chan,_]) -> Just (Err (mkId chan) (ErrUserOnChannel (mkId nick))) ("451",[_,_]) -> Just (Err "" ErrNotRegistered) ("456",[_,_]) -> Just (Err "" ErrAcceptFull) ("457",[_,nick,_]) -> Just (Err (mkId nick) ErrAcceptExist) ("458",[_,nick,_]) -> Just (Err (mkId nick) ErrAcceptNot) ("461",[_,cmd,_]) -> Just (Err "" (ErrNeedMoreParams cmd)) ("462",[_,_]) -> Just (Err "" ErrAlreadyRegistered) ("463",[_,_]) -> Just (Err "" ErrNoPermForHost) ("464",[_,_]) -> Just (Err "" ErrPasswordMismatch) ("465",[_,_]) -> Just (Err "" ErrYoureBannedCreep) ("470",[_,chan1,chan2,_]) -> Just (Err (mkId chan1) (ErrLinkChannel (mkId chan2))) ("471",[_,chan,_]) -> Just (Err (mkId chan) ErrChannelFull) ("472",[_,mode,_]) -> Just (Err "" (ErrUnknownMode (B8.head mode))) ("473",[_,chan,_]) -> Just (Err (mkId chan) ErrInviteOnlyChan) ("474",[_,chan,_]) -> Just (Err (mkId chan) ErrBannedFromChan) ("475",[_,chan,_]) -> Just (Err (mkId chan) ErrBadChannelKey) ("477",[_,chan,_]) -> Just (Err (mkId chan) ErrNeedReggedNick) ("478",[_,chan,mode,_]) -> Just (Err (mkId chan) (ErrBanListFull (B8.head mode))) ("479",[_,chan,_]) -> Just (Err "" (ErrBadChanName chan)) ("480",[_,chan,_]) -> Just (Err (mkId chan) ErrThrottle) ("481",[_,_]) -> Just (Err "" ErrNoPrivileges) ("482",[_,chan,_]) -> Just (Err (mkId chan) ErrChanOpPrivsNeeded) ("483",[_,_]) -> Just (Err "" ErrCantKillServer) ("484",[_,nick,chan,_]) -> Just (Err (mkId chan) (ErrIsChanService (mkId nick))) ("486",[_,nick,_]) -> Just (Err (mkId nick) ErrNoNonReg) ("489",[_,chan,_]) -> Just (Err (mkId chan) ErrVoiceNeeded) ("491",[_,_]) -> Just (Err "" ErrNoOperHost) ("494",[_,nick,_]) -> Just (Err (mkId nick) ErrOwnMode) ("501",[_,mode,_]) -> Just (Err "" (ErrUnknownUmodeFlag (B8.head mode))) ("502",[_,_]) -> Just (Err "" ErrUsersDontMatch) ("524",[_,topic,_]) -> Just (Err "" (ErrHelpNotFound topic)) ("671",[_,nick,_]) -> Just (RplWhoisSecure (mkId nick)) ("704",[_,topic,txt]) -> Just (RplHelpStart topic txt) ("705",[_,topic,txt]) -> Just (RplHelp topic txt) ("706",[_,topic,_]) -> Just (RplEndOfHelp topic) ("710",[_,chan,who,_]) -> Just (RplKnock (mkId chan) (parseUserInfo who)) ("711",[_,chan,_]) -> Just (RplKnockDelivered (mkId chan)) ("712",[_,chan,_]) -> Just (Err (mkId chan) ErrTooManyKnocks) ("713",[_,chan,_]) -> Just (Err (mkId chan) ErrChanOpen) ("714",[_,chan,_]) -> Just (Err (mkId chan) ErrKnockOnChan) ("716",[_,nick,_]) -> Just (Err (mkId nick) ErrTargUmodeG) ("723",[_,priv,_]) -> Just (Err "" (ErrNoPrivs priv)) ("717",[_,nick,_]) -> Just (RplTargNotify (mkId nick)) ("718",[_,nick,mask,_]) -> Just (RplUmodeGMsg (mkId nick) mask) ("728",[_,chan,mode,banned,banner,time]) -> Just (RplQuietList (mkId chan) (B8.head mode) banned banner (asTimeStamp time)) ("729",[_,chan,mode,_]) -> Just (RplEndOfQuietList (mkId chan) (B8.head mode)) ("742",[_,chan,mode,setting,_]) -> Just (Err (mkId chan) (ErrMlockRestricted (B8.head mode) setting)) ("900",[_,_,account,_]) -> Just (RplLoggedIn account) ("901",[_,_,_]) -> Just RplLoggedOut ("902",[_,_]) -> Just RplNickLocked ("903",[_,_]) -> Just RplSaslSuccess ("904",[_,_]) -> Just RplSaslFail ("905",[_,_]) -> Just RplSaslTooLong ("906",[_,_]) -> Just RplSaslAborted ("907",[_,_]) -> Just RplSaslAlready ("908",[_,mechs,_]) -> Just (RplSaslMechs mechs) ("PING",[txt]) -> Just (Ping txt) ("PONG",[server ]) -> Just (Pong server Nothing) ("PONG",[server,txt]) -> Just (Pong server (Just txt)) ("PRIVMSG",[dst,txt]) -> do src <- msgPrefix ircmsg Just (PrivMsg src (mkId dst) txt) ("NOTICE",[dst,txt]) -> do src <- msgPrefix ircmsg Just (Notice src (mkId dst) txt) ("TOPIC",[chan,txt]) -> do who <- msgPrefix ircmsg Just (Topic who (mkId chan) txt) ("JOIN",[chan,account,real]) -> do who <- msgPrefix ircmsg Just (ExtJoin who (mkId chan) (if account == "*" then Nothing else Just account) real) ("JOIN",[chan]) -> do who <- msgPrefix ircmsg Just (Join who (mkId chan)) ("NICK",[newnick]) -> do who <- msgPrefix ircmsg Just (Nick who (mkId newnick)) ("MODE",tgt:modes) -> do who <- msgPrefix ircmsg Just (Mode who (mkId tgt) modes) ("PART",[chan]) -> do who <- msgPrefix ircmsg Just (Part who (mkId chan) "") ("PART",[chan,txt]) -> do who <- msgPrefix ircmsg Just (Part who (mkId chan) txt) ("AWAY",[txt]) -> do who <- msgPrefix ircmsg Just (Away who (Just txt)) ("AWAY",[]) -> do who <- msgPrefix ircmsg Just (Away who Nothing) ("QUIT",[txt]) -> do who <- msgPrefix ircmsg Just (Quit who txt) ("KICK",[chan,tgt,txt]) -> do who <- msgPrefix ircmsg Just (Kick who (mkId chan) (mkId tgt) txt) ("INVITE",[_,chan]) -> do who <- msgPrefix ircmsg Just (Invite who (mkId chan)) ("CAP",[_,cmd,txt]) -> Just (Cap cmd txt) ("ERROR",[txt]) -> Just (Error txt) ("AUTHENTICATE",[txt]) -> Just (Authenticate txt) ("ACCOUNT",[acct]) -> do who <- msgPrefix ircmsg Just (Account who (if acct == "*" then Nothing else Just acct)) _ -> Nothing asTimeStamp :: ByteString -> UTCTime asTimeStamp = posixSecondsToUTCTime . fromInteger . asNumber asNumber :: ByteString -> Integer asNumber b = case B8.readInteger b of Nothing -> 0 Just (x,_) -> x irc-core-1.1.3/src/Irc/Format.hs0000644000000000000000000002601412622517457014513 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- | This module provides a parser and printer for the low-level IRC -- message format. module Irc.Format ( UserInfo(..) , RawIrcMsg(..) , parseRawIrcMsg , renderRawIrcMsg , parseUserInfo , renderUserInfo , Identifier , mkId , idBytes , idDenote , asUtf8 , ircFoldCase ) where import Control.Applicative import Control.Monad (when) import Data.Array import Data.Attoparsec.ByteString.Char8 as P import Data.ByteString (ByteString) import Data.ByteString.Builder (Builder) import Data.Functor import Data.Monoid import Data.String import Data.Text (Text) import Data.Time (UTCTime) import Data.Word (Word8) import qualified Data.ByteString as B import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Irc.Time (myParseTime) -- | 'UserInfo' packages a nickname along with the username and hsotname -- if they are known in the current context. data UserInfo = UserInfo { userNick :: Identifier , userName :: Maybe ByteString , userHost :: Maybe ByteString } deriving (Read, Show) -- | '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 { msgTime :: Maybe UTCTime , msgPrefix :: Maybe UserInfo , msgCommand :: ByteString , msgParams :: [ByteString] } deriving (Read, Show) -- | Case insensitive identifier representing channels and nicknames data Identifier = Identifier ByteString ByteString deriving (Read, Show) -- Equality on normalized 'Identifiers' instance Eq Identifier where x == y = idDenote x == idDenote y -- Comparison on normalized 'Identifiers' instance Ord Identifier where compare x y = compare (idDenote x) (idDenote y) instance IsString Identifier where fromString = mkId . fromString -- | Construct an 'Identifier' from a 'ByteString' mkId :: ByteString -> Identifier mkId x = Identifier x (ircFoldCase x) -- | Returns the original 'ByteString' of an 'Identifier' idBytes :: Identifier -> ByteString idBytes (Identifier x _) = x -- | Returns the case-normalized 'ByteString' of an 'Identifier' -- which is suitable for comparison. idDenote :: Identifier -> ByteString idDenote (Identifier _ x) = x -- | Attempt to split an IRC protocol message without its trailing newline -- information into a structured message. parseRawIrcMsg :: ByteString -> 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 { msgTime = 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 [ByteString] 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 <- takeByteString let !x' = B.copy x return [x'] middleParam = do x <- P.takeWhile (/= ' ') when (B8.null x) (fail "Empty middle parameter") let !x' = B.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 (B8.unpack timeBytes) of Nothing -> fail "Bad server-time format" Just t -> return t parseIrcTime :: String -> Maybe UTCTime parseIrcTime = myParseTime "%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 ByteString simpleTokenParser = do xs <- P.takeWhile (/= ' ') when (B8.null xs) (fail "Empty token") return $! B8.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 -- | Render 'UserInfo' as @nick!username\@hostname@ renderUserInfo :: UserInfo -> ByteString renderUserInfo u = idBytes (userNick u) <> maybe B.empty ("!" <>) (userName u) <> maybe B.empty ("@" <>) (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 :: ByteString -> UserInfo parseUserInfo x = UserInfo { userNick = mkId nick , userName = if B.null user then Nothing else Just (B.drop 1 user) , userHost = if B.null host then Nothing else Just (B.drop 1 host) } where (nickuser,host) = B8.break (=='@') x (nick,user) = B8.break (=='!') nickuser -- | 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 (msgPrefix m) <> Builder.byteString (msgCommand m) <> buildParams (msgParams m) <> Builder.word8 13 <> Builder.word8 10 renderPrefix :: UserInfo -> Builder renderPrefix u = Builder.char8 ':' <> Builder.byteString (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 :: [ByteString] -> Builder buildParams [x] | B.elem 32 x || B.elem 58 x = Builder.word8 32 <> Builder.word8 58 <> Builder.byteString x buildParams (x:xs) = Builder.word8 32 <> Builder.byteString 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 -- | 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 = "\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" -- 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 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'] irc-core-1.1.3/src/Irc/Message.hs0000644000000000000000000000420012622517457014640 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module Irc.Message ( -- * High-level IRC events IrcMessage(..) , IrcMessageType(..) , mesgType , mesgSender , mesgStamp , mesgStatus , mesgMe , mesgModes , defaultIrcMessage -- * Prisms , _PrivMsgType , _NoticeMsgType , _ActionMsgType , _AwayMsgType , _JoinMsgType , _KickMsgType , _PartMsgType , _QuitMsgType , _NickMsgType , _TopicMsgType , _ErrorMsgType , _ErrMsgType , _ModeMsgType , _InviteMsgType , _KnockMsgType , _CallerIdMsgType , _CallerIdDeliveredMsgType , _CtcpReqMsgType , _CtcpRspMsgType ) where import Control.Lens import Data.ByteString (ByteString) import Data.Text (Text) import Data.Time import Data.Time.Clock.POSIX import Irc.Core import Irc.Format -- | 'IrcMessage' represents a high-level event to be communicated out -- to the library user when something changes on a connection. data IrcMessage = IrcMessage { _mesgType :: !IrcMessageType , _mesgSender :: !UserInfo , _mesgStamp :: !UTCTime , _mesgMe :: !Bool , _mesgModes :: String , _mesgStatus :: String -- for Statusmsg feature } deriving (Read, Show) defaultIrcMessage :: IrcMessage defaultIrcMessage = IrcMessage { _mesgType = PrivMsgType "" , _mesgSender = UserInfo "" Nothing Nothing , _mesgStamp = posixSecondsToUTCTime 0 , _mesgMe = False , _mesgModes = "" , _mesgStatus = "" } -- | Event types and associated fields used by 'IrcMessage'. data IrcMessageType = PrivMsgType Text | NoticeMsgType Text | ActionMsgType Text | AwayMsgType Text | JoinMsgType | KickMsgType Identifier Text | PartMsgType Text | QuitMsgType Text | NickMsgType Identifier | TopicMsgType Text | ErrorMsgType Text | ErrMsgType IrcError -- Family of various responses | ModeMsgType Bool Char ByteString | InviteMsgType | KnockMsgType | CallerIdMsgType | CallerIdDeliveredMsgType | CtcpReqMsgType ByteString ByteString -- ^ ctcp command and arguments | CtcpRspMsgType ByteString ByteString -- ^ ctcp command and arguments deriving (Read, Show) makeLenses ''IrcMessage makePrisms ''IrcMessageType irc-core-1.1.3/src/Irc/Model.hs0000644000000000000000000013523512622517457014331 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- | This module implements a high-level view of the state of -- the IRC connection. The library user calls 'advanceModel' to -- step the 'IrcConnection' as new messages arrive. module Irc.Model ( -- * IRC Connection model IrcConnection(..) , connNick , connChannels , connId , connChanModeTypes , connUserModeTypes , connKnock , connNickLen , connExcepts , connInvex , connStatusMsg , connTopicLen , connPhase , connModes , connUsers , connMyInfo , connSasl , connUmode , connSnoMask , connPingTime , defaultIrcConnection -- * Phases , Phase(..) -- * IRC Channel model , IrcChannel(..) , chanTopic , chanUsers , chanModes , chanCreation , chanMaskLists , chanUrl -- * Mode Settings , ModeTypes(..) , modesLists , modesAlwaysArg , modesSetArg , modesNeverArg , modesPrefixModes , defaultChanModeTypes , defaultUmodeTypes -- * Channel Mask Entry , IrcMaskEntry(..) , maskEntryMask , maskEntryWho , maskEntryStamp -- * User metadata , IrcUser(..) , usrAway , usrAccount , usrHost , defaultIrcUser -- * Model execution , runLogic , LogicOp(..) , Logic -- * General functionality , advanceModel , isChannelName , isNickName , isMyNick , splitStatusMsg , splitModes , unsplitModes , nickHasModeInChannel , channelHasMode ) where import Control.Monad (guard) import Control.Lens import Control.Monad (foldM) import Control.Monad.Free import Control.Monad.Trans.Error import Control.Monad.Trans.Reader import Data.ByteString (ByteString) import Data.Char (toUpper) import Data.Fixed (Pico) import Data.List (foldl',find,nub,delete,intersect) import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) import Data.Time import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as Map import Text.Read (readMaybe) #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Irc.Format import Irc.Message import Irc.Cmd import Irc.Core import Irc.Core.Prisms -- | 'IrcConnection' is the state of an IRC connection. It maintains -- channel membership, user and channel modes, and other connection -- state. data IrcConnection = IrcConnection { _connNick :: !Identifier , _connChannels :: !(Map Identifier IrcChannel) , _connId :: Maybe ByteString , _connChanTypes :: [Char] , _connStatusMsg :: [Char] , _connKnock :: !Bool , _connNickLen :: !Int , _connExcepts :: Maybe Char , _connInvex :: Maybe Char , _connUsers :: !(Map Identifier IrcUser) , _connChanModeTypes :: !ModeTypes , _connUserModeTypes :: !ModeTypes , _connModes :: !Int , _connTopicLen :: !Int , _connMyInfo :: Maybe (ByteString,ByteString) , _connSasl :: Maybe (ByteString,ByteString) , _connUmode :: !ByteString , _connSnoMask :: !ByteString , _connPhase :: !Phase , _connPingTime :: Maybe Pico -- No read instance for NominalDiffTime } deriving (Read, Show) -- | 'IrcConnection' value with everything unspecified defaultIrcConnection :: IrcConnection defaultIrcConnection = IrcConnection { _connNick = mkId "" , _connChannels = mempty , _connId = Nothing , _connChanTypes = "#&" -- default per RFC , _connStatusMsg = "" , _connKnock = False , _connNickLen = 9 , _connExcepts = Nothing , _connInvex = Nothing , _connUsers = mempty , _connModes = 3 , _connTopicLen = 400 -- default is unbounded but message length is bounded , _connChanModeTypes = defaultChanModeTypes , _connUserModeTypes = defaultUmodeTypes , _connMyInfo = Nothing , _connSasl = Nothing , _connUmode = "" , _connSnoMask = "" , _connPhase = RegistrationPhase , _connPingTime = Nothing } data Phase = RegistrationPhase | ActivePhase | SaslPhase deriving (Read, Show, Eq) -- | Settings that describe how to interpret channel modes data ModeTypes = ModeTypes { _modesLists :: String , _modesAlwaysArg :: String , _modesSetArg :: String , _modesNeverArg :: String , _modesPrefixModes :: [(Char,Char)] } deriving (Read, Show) -- | The channel modes used by Freenode defaultChanModeTypes :: ModeTypes defaultChanModeTypes = ModeTypes { _modesLists = "eIbq" , _modesAlwaysArg = "k" , _modesSetArg = "flj" , _modesNeverArg = "CFLMPQScgimnprstz" , _modesPrefixModes = [('o','@'),('v','+')] } -- | The default UMODE as defined by Freenode defaultUmodeTypes :: ModeTypes defaultUmodeTypes = ModeTypes { _modesLists = "" , _modesAlwaysArg = "" , _modesSetArg = "s" , _modesNeverArg = "" , _modesPrefixModes = [] } -- | 'IrcChannel' represents the current state of a channel -- as seen on the connection. It includes all user lists, -- modes, and other metadata about a channel. data IrcChannel = IrcChannel { _chanTopic :: Maybe (Maybe (Text, ByteString, UTCTime)) -- TODO: use UserInfo , _chanUsers :: !(Map Identifier String) -- modes: ov , _chanModes :: Maybe (Map Char ByteString) , _chanCreation :: Maybe UTCTime , _chanMaskLists :: Map Char [IrcMaskEntry] , _chanUrl :: Maybe ByteString } deriving (Read, Show) -- | Default value for 'IrcChannel' with everything unspecified. defaultChannel :: IrcChannel defaultChannel = IrcChannel { _chanTopic = Nothing , _chanModes = Nothing , _chanCreation = Nothing , _chanUsers = mempty , _chanMaskLists = mempty , _chanUrl = Nothing } -- | Mask entries are used to represent an entry in a ban list for -- a channel. data IrcMaskEntry = IrcMaskEntry { _maskEntryMask :: ByteString , _maskEntryWho :: ByteString , _maskEntryStamp :: UTCTime } deriving (Read, Show) -- | 'IrcUser' is the type of user-level metadata tracked for -- the users visible on the current IRC connection. data IrcUser = IrcUser { _usrAway :: !Bool , _usrAccount :: !(Maybe ByteString) , _usrHost :: !(Maybe ByteString) } deriving (Read,Show) -- | This represents the metadata of an unknown user. defaultIrcUser :: IrcUser defaultIrcUser = IrcUser { _usrAway = False , _usrAccount = Nothing , _usrHost = Nothing } data Fuzzy a = Known !a | Unknown | None deriving (Read,Show) makeLenses ''IrcConnection makeLenses ''IrcChannel makeLenses ''IrcUser makeLenses ''IrcMaskEntry makeLenses ''ModeTypes -- | Primary state machine step function. Call this function with a timestamp -- and a server message to update the 'IrcConnection' state. If additional -- messages are required they will be requested via the 'Logic' type. advanceModel :: MsgFromServer -> IrcConnection -> Logic IrcConnection advanceModel msg0 conn = case msg0 of Ping x -> sendMessage (pongCmd x) >> return conn -- Treat numbers as POSIX times when PING was sent Pong _ (Just txt) | Just sec <- readMaybe (B8.unpack txt) -> do now <- getStamp let past = posixSecondsToUTCTime (realToFrac (sec :: Pico)) delta = realToFrac (now `diffUTCTime` past) return (set connPingTime (Just delta) conn) Pong server mbMsg -> doServerMessage "Pong" (server <> maybe "" (" "<>) mbMsg) conn RplWelcome txt -> doServerMessage "Welcome" txt $ set connPhase ActivePhase conn RplYourHost txt -> doServerMessage "YourHost" txt conn RplCreated txt -> doServerMessage "Created" txt conn RplMyInfo host version _ -> return (set connMyInfo (Just (host,version)) conn) -- Random uninteresting statistics RplLuserOp _ -> return conn RplLuserChannels _ -> return conn RplLuserMe _ -> return conn RplLuserClient _ -> return conn RplLocalUsers _ -> return conn RplGlobalUsers _ -> return conn RplStatsConn _ -> return conn RplLuserUnknown _ -> return conn RplLuserAdminMe txt -> doServerMessage "ADMIN" txt conn RplLuserAdminLoc1 txt -> doServerMessage "ADMIN" txt conn RplLuserAdminLoc2 txt -> doServerMessage "ADMIN" txt conn RplLuserAdminEmail txt -> doServerMessage "ADMIN" txt conn -- Channel list not implemented RplListStart -> return conn RplList chan count topic -> doList chan count topic conn RplListEnd -> return conn RplUserHost host -> doServerMessage "USERHOST" (B8.unwords host) conn RplTime server time -> doServerMessage "TIME" (B8.unwords [server,time]) conn RplInfo _ -> return conn RplEndOfInfo -> return conn Join who chan -> doJoinChannel who Unknown chan conn ExtJoin who chan account _realname -> doJoinChannel who (maybe None Known account) chan conn Part who chan reason -> doPart who chan reason conn Kick who chan tgt reason -> doKick who chan tgt reason conn Quit who reason -> doQuit who reason conn Nick who newnick -> doNick who newnick conn RplChannelUrl chan url -> return (set (connChannels . ix chan . chanUrl) (Just url) conn) RplNoTopicSet chan -> return (set (connChannels . ix chan . chanTopic) (Just Nothing) conn) RplTopic chan topic -> do RplTopicWhoTime _ who time <- getMessage return (set (connChannels . ix chan . chanTopic) (Just (Just (asUtf8 topic,who,time))) conn) RplTopicWhoTime _ _ _ -> fail "Unexpected RPL_TOPICWHOTIME" Topic who chan topic -> doTopic who chan topic conn PrivMsg who chan msg -> doPrivMsg who chan msg conn Notice who chan msg -> doNotifyChannel who chan msg conn Account who acct -> return (set (connUsers . ix (userNick who) . usrAccount) acct conn) Away who Just{} -> return (updateUserRecord (userNick who) (set usrAway True) conn) Away who Nothing -> return (updateUserRecord (userNick who) (set usrAway False) conn) RplYourId yourId -> return (set connId (Just yourId) conn) RplMotdStart -> return conn RplEndOfMotd -> return conn RplMotd x -> doServerMessage "MOTD" x conn RplNameReply _ chan xs -> doNameReply chan xs conn RplEndOfNames _ -> return conn RplChannelModeIs chan modes params -> doChannelModeIs chan modes params conn RplCreationTime chan creation -> return (set (connChannels . ix chan . chanCreation) (Just creation) conn) RplWhoReply _chan _username hostname _servername nickname flags _realname -> doWhoReply nickname hostname flags conn RplEndOfWho _chan -> return conn RplIsOn nicks -> return (doIsOn nicks conn) RplBanList chan mask who when -> doMaskList (preview _RplBanList) (has _RplEndOfBanList) 'b' chan [IrcMaskEntry { _maskEntryMask = mask , _maskEntryWho = who , _maskEntryStamp = when } ] conn RplEndOfBanList chan -> return (set (connChannels . ix chan . chanMaskLists . at 'b') (Just []) conn) RplInviteList chan mask who when -> doMaskList (preview _RplInviteList) (has _RplEndOfInviteList) 'I' chan [IrcMaskEntry { _maskEntryMask = mask , _maskEntryWho = who , _maskEntryStamp = when } ] conn RplEndOfInviteList chan -> return (set (connChannels . ix chan . chanMaskLists . at 'I') (Just []) conn) RplExceptionList chan mask who when -> doMaskList (preview _RplExceptionList) (has _RplEndOfExceptionList) 'e' chan [IrcMaskEntry { _maskEntryMask = mask , _maskEntryWho = who , _maskEntryStamp = when } ] conn RplEndOfExceptionList chan -> return (set (connChannels . ix chan . chanMaskLists . at 'e') (Just []) conn) RplQuietList chan mode mask who when -> let fixup (a,_,c,d,e) = (a,c,d,e) in -- drop the matched mode field doMaskList (previews _RplQuietList fixup) (has _RplEndOfQuietList) mode chan [IrcMaskEntry { _maskEntryMask = mask , _maskEntryWho = who , _maskEntryStamp = when } ] conn RplEndOfQuietList chan mode -> return (set (connChannels . ix chan . chanMaskLists . at mode) (Just []) conn) Mode _ _ [] -> fail "Unexpected MODE" Mode who target (modes:args) -> doModeChange who target modes args conn RplSnoMask snomask -> return (set connSnoMask snomask conn) RplUmodeIs mode _params -> -- TODO: params? return (set connUmode (B.tail mode) conn) Err target err -> do now <- getStamp let mesg = defaultIrcMessage { _mesgType = ErrMsgType err , _mesgSender = UserInfo "" Nothing Nothing , _mesgStamp = now } recordMessage mesg target conn RplKnockDelivered chan -> doChannelError chan "Knock delivered" conn RplKnock chan who -> do now <- getStamp let mesg = defaultIrcMessage { _mesgType = KnockMsgType , _mesgSender = who , _mesgStamp = now } recordMessage mesg chan conn RplInviting nick chan -> doChannelError chan ("Inviting " <> asUtf8 (idBytes nick)) conn Invite who chan -> do now <- getStamp let mesg = defaultIrcMessage { _mesgType = InviteMsgType , _mesgSender = who , _mesgStamp = now } recordMessage mesg chan conn -- TODO: Structure this more nicely than as simple message, -- perhaps store it in the user map RplWhoisUser nick user host real -> doServerMessage "WHOIS" (B8.unwords [idBytes nick, user, host, real]) (updateUserRecord nick (set usrHost (Just host)) conn) RplWhoisChannels _nick channels -> doServerMessage "WHOIS" channels conn RplWhoisServer _nick host txt -> doServerMessage "WHOIS" (B8.unwords [host,txt]) conn RplWhoisSecure _nick -> doServerMessage "WHOIS" "secure connection" conn RplWhoisHost _nick txt -> doServerMessage "WHOIS" txt conn RplWhoisIdle _nick idle signon -> doServerMessage "WHOIS" ("Idle seconds: " <> B8.pack (show idle) <> ", Sign-on: " <> maybe "unknown" (B8.pack . show) signon ) conn RplWhoisAccount nick account -> doServerMessage "WHOIS" ("Logged in as: " <> account) (set (connUsers . ix nick . usrAccount) (Just account) conn) RplWhoisModes _nick modes args -> doServerMessage "WHOIS" ("Modes: " <> B8.unwords (modes:args)) conn RplWhoisOperator _nick txt -> doServerMessage "WHOIS" ("Operator: " <> txt) conn RplWhoisCertFp _nick txt -> doServerMessage "WHOIS" ("CertFP: " <> txt) conn RplEndOfWhois _nick -> doServerMessage "WHOIS" "--END--" conn RplSyntax txt -> doServerMessage "SYNTAX" txt conn RplAway nick message -> doAwayReply nick (asUtf8 message) conn RplUnAway -> doServerMessage "AWAY" "You are no longer marked away" conn RplNowAway -> doServerMessage "AWAY" "You are marked away" conn RplWhoWasUser nick user host real -> doServerMessage "WHOWAS" (B8.unwords [idBytes nick, user, host, real]) conn RplEndOfWhoWas _nick -> doServerMessage "WHOWAS" "--END--" conn RplHostHidden host -> doServerMessage "HOST" ("Host hidden: " <> host) conn RplYoureOper txt -> doServerMessage "OPER" txt conn RplHelpStart topic txt -> doServerMessage topic txt conn RplHelp topic txt -> doServerMessage topic txt conn RplEndOfHelp topic -> doServerMessage topic "--END--" conn Cap "LS" caps -> doCapLs caps conn Cap "ACK" caps -> doCapAck caps conn Cap "NACK" _caps -> sendMessage capEndCmd >> return conn Cap _ _ -> fail "Unexpected CAP" RplSaslAborted -> return conn RplLoadTooHigh cmd -> doServerError ("Command rate limited: " <> asUtf8 cmd) conn RplNickLocked -> doServerError "Nickname locked" conn RplLoggedIn account -> doServerMessage "LOGIN" account conn RplLoggedOut -> doServerMessage "LOGOUT" "" conn RplSaslTooLong -> doServerError "Unexpected SASL Too Long" conn RplSaslAlready -> doServerError "Unexpected SASL Already" conn RplSaslMechs _ -> doServerError "Unexpected SASL Mechanism List" conn Error e -> doServerError (asUtf8 e) conn RplISupport isupport -> doISupport isupport conn RplVersion version -> doServerMessage "VERSION" (B8.unwords version) conn RplUmodeGMsg nick mask -> doCallerId nick mask conn RplTargNotify nick -> doCallerIdDeliver nick conn RplAcceptList nick -> doAcceptList [nick] conn RplEndOfAccept -> doServerMessage "ACCEPTLIST" "Accept list empty" conn RplLinks mask server info -> doServerMessage "LINKS" (B8.unwords [mask,server,info]) conn RplEndOfLinks mask -> doServerMessage "LINKS" mask conn RplStatsLinkInfo linkinfo -> doServerMessage "LINKINFO" (B8.unwords linkinfo) conn RplStatsCommands commands -> doServerMessage "COMMANDS" (B8.unwords commands) conn RplStatsCLine cline -> doServerMessage "CLINE" (B8.unwords cline) conn RplStatsNLine nline -> doServerMessage "NLINE" (B8.unwords nline) conn RplStatsILine iline -> doServerMessage "ILINE" (B8.unwords iline) conn RplStatsKLine kline -> doServerMessage "KLINE" (B8.unwords kline) conn RplStatsQLine qline -> doServerMessage "QLINE" (B8.unwords qline) conn RplStatsYLine yline -> doServerMessage "YLINE" (B8.unwords yline) conn RplEndOfStats mode -> doServerMessage "ENDSTATS" (B8.pack [mode]) conn RplStatsPLine pline -> doServerMessage "PLINE" (B8.unwords pline) conn RplStatsDLine dline -> doServerMessage "DLINE" (B8.unwords dline) conn RplStatsVLine vline -> doServerMessage "VLINE" (B8.unwords vline) conn RplStatsLLine lline -> doServerMessage "LLINE" (B8.unwords lline) conn RplStatsUptime uptime -> doServerMessage "UPTIME" uptime conn RplStatsOLine oline -> doServerMessage "OLINE" (B8.unwords oline) conn RplStatsHLine hline -> doServerMessage "HLINE" (B8.unwords hline) conn RplStatsSLine sline -> doServerMessage "SLINE" (B8.unwords sline) conn RplStatsPing ping -> doServerMessage "STATSPING" (B8.unwords ping) conn RplStatsXLine xline -> doServerMessage "XLINE" (B8.unwords xline) conn RplStatsULine uline -> doServerMessage "ULINE" (B8.unwords uline) conn RplStatsDebug debug -> doServerMessage "STATSDEBUG" (B8.unwords debug) conn RplPrivs txt -> doServerMessage "PRIVS" txt conn Authenticate msg | view connPhase conn == SaslPhase , msg == "+" , Just (user,pass) <- view connSasl conn -> do sendMessage (authenticateCmd (encodePlainAuthentication user pass)) return conn | otherwise -> doServerError "Unexpected Authenticate" conn RplSaslSuccess | view connPhase conn == SaslPhase -> do sendMessage capEndCmd doServerMessage "SASL" "Authentication successful" $ set connPhase RegistrationPhase conn | otherwise -> doServerError "Unexpected SASL Success" conn RplSaslFail | view connPhase conn == SaslPhase -> do sendMessage capEndCmd doServerMessage "SASL" "Authentication failed" $ set connPhase RegistrationPhase conn | otherwise -> doServerError "Unexpected SASL Fail" conn -- ISUPPORT is defined by -- https://tools.ietf.org/html/draft-brocklesby-irc-isupport-03#section-3.14 doISupport :: [(ByteString,ByteString)] {- ^ [(key,value)] -} -> IrcConnection -> Logic IrcConnection doISupport params conn = return (foldl' (flip support) conn params) support :: (ByteString,ByteString) -> IrcConnection -> IrcConnection support ("CHANTYPES",types) = set connChanTypes (B8.unpack types) support ("CHANMODES",modes) = updateChanModes (B8.unpack modes) support ("STATUSMSG",modes) = set connStatusMsg (B8.unpack modes) support ("PREFIX",modes) = updateChanPrefix (B8.unpack modes) support ("KNOCK",_) = set connKnock True support ("NICKLEN",len) = case B8.readInt len of Just (n,rest) | B.null rest -> set connNickLen n _ -> id support ("TOPICLEN",len) = case B8.readInt len of Just (n,rest) | B.null rest -> set connTopicLen n _ -> id support ("MODES",str) = case B8.readInt str of Just (n,rest) | B.null rest -> set connModes (max 1 n) _ -> id support ("INVEX",mode) = case B8.uncons mode of Nothing -> set connInvex (Just 'I') Just (m,_) -> set connInvex (Just $! m) support ("EXCEPTS",mode) = case B8.uncons mode of Nothing -> set connExcepts (Just 'e') Just (m,_) -> set connExcepts (Just $! m) support _ = id updateChanModes :: String {- lists,always,set,never -} -> IrcConnection -> IrcConnection updateChanModes modes = over connChanModeTypes $ set modesLists listModes . set modesAlwaysArg alwaysModes . set modesSetArg setModes . set modesNeverArg neverModes where next = over _2 (drop 1) . break (==',') (listModes ,modes1) = next modes (alwaysModes,modes2) = next modes1 (setModes ,modes3) = next modes2 (neverModes ,_) = next modes3 updateChanPrefix :: String {- e.g. (ov)@+ -} -> IrcConnection -> IrcConnection updateChanPrefix [] = id updateChanPrefix (_:modes) = set (connChanModeTypes . modesPrefixModes) (zip a b) where (a,b) = over _2 (drop 1) (break (==')') modes) doAcceptList :: [Identifier] {- ^ nicks -} -> IrcConnection -> Logic IrcConnection doAcceptList acc conn = do msg <- getMessage case msg of RplAcceptList nick -> doAcceptList (nick:acc) conn RplEndOfAccept -> doServerMessage "ACCEPTLIST" (B8.unwords (map idBytes (reverse acc))) conn _ -> fail "doAcceptList: Unexpected message!" doCallerIdDeliver :: Identifier {- ^ nick -} -> IrcConnection -> Logic IrcConnection doCallerIdDeliver nick conn = do stamp <- getStamp let mesg = defaultIrcMessage { _mesgType = CallerIdDeliveredMsgType , _mesgSender = UserInfo nick Nothing Nothing , _mesgStamp = stamp } recordMessage mesg nick conn doCallerId :: Identifier {- ^ nick -} -> ByteString {- ^ user\@host -} -> IrcConnection -> Logic IrcConnection doCallerId nick mask conn = do stamp <- getStamp let (user,host) = B8.break (=='@') mask let mesg = defaultIrcMessage { _mesgType = CallerIdMsgType , _mesgSender = UserInfo nick (Just user) (Just (B8.drop 1 host)) , _mesgStamp = stamp } recordMessage mesg nick conn doList :: Identifier {- ^ channel -} -> Integer {- ^ members -} -> ByteString {- ^ topic -} -> IrcConnection -> Logic IrcConnection doList chan num topic = doServerMessage "LIST" (B8.unwords [idBytes chan, " - ", B8.pack (show num), " - ", topic]) doAwayReply :: Identifier {- ^ nickname -} -> Text {- ^ away message -} -> IrcConnection -> Logic IrcConnection doAwayReply nick message conn = do stamp <- getStamp let mesg = defaultIrcMessage { _mesgType = AwayMsgType message , _mesgSender = UserInfo nick Nothing Nothing , _mesgStamp = stamp } recordMessage mesg nick conn doChannelError :: Identifier {- ^ channel -} -> Text {- ^ error -} -> IrcConnection -> Logic IrcConnection doChannelError chan reason conn = do stamp <- getStamp let mesg = defaultIrcMessage { _mesgType = ErrorMsgType reason , _mesgSender = UserInfo (mkId "server") Nothing Nothing , _mesgStamp = stamp } recordMessage mesg chan conn -- | Event handler when receiving a new privmsg. -- The message will be passed along as an event. doPrivMsg :: UserInfo {- ^ sender -} -> Identifier {- ^ message target -} -> ByteString {- ^ message -} -> IrcConnection -> Logic IrcConnection doPrivMsg who chan msg conn = do stamp <- getStamp let (statusmsg, chan') = splitStatusMsg chan conn modes = view (connChannels . ix chan' . chanUsers . ix (userNick who)) conn mesg = defaultIrcMessage { _mesgType = ty , _mesgSender = who , _mesgStamp = stamp , _mesgStatus = statusmsg , _mesgModes = modes } ty = case parseCtcpCommand msg of Nothing -> PrivMsgType (asUtf8 msg) Just ("ACTION", action) -> ActionMsgType (asUtf8 action) Just (command , args ) -> CtcpReqMsgType command args recordMessage mesg chan' conn parseCtcpCommand :: ByteString -> Maybe (ByteString, ByteString) parseCtcpCommand msg | B8.length msg >= 3 , B8.head msg == '\^A' , B8.last msg == '\^A' = Just (B8.map toUpper command, B8.drop 1 rest) | otherwise = Nothing where sansControls = B8.tail (B8.init msg) (command,rest) = B8.break (==' ') sansControls -- | Record the new topic as set by the given user and -- emit a change event. doTopic :: UserInfo {- ^ changed by -} -> Identifier {- ^ channel -} -> ByteString {- ^ topic text -} -> IrcConnection -> Logic IrcConnection doTopic who chan topic conn = do stamp <- getStamp let topicText = asUtf8 topic modes = view (connChannels . ix chan . chanUsers . ix (userNick who)) conn m = defaultIrcMessage { _mesgType = TopicMsgType topicText , _mesgSender = who , _mesgStamp = stamp , _mesgModes = modes } topicEntry = Just (topicText,renderUserInfo who,stamp) conn1 = set (connChannels . ix chan . chanTopic) (Just topicEntry) conn recordMessage m chan conn1 doCapLs :: ByteString -> IrcConnection -> Logic IrcConnection doCapLs rawCaps conn = do sendMessage (capReqCmd activeCaps) return conn where activeCaps = intersect supportedCaps offeredCaps offeredCaps = B8.words rawCaps supportedCaps = saslSupport ++ ["away-notify","account-notify","userhost-in-names", "extended-join","multi-prefix", "znc.in/server-time-iso","server-time"] saslSupport = case view connSasl conn of Nothing -> [] Just{} -> ["sasl"] doCapAck :: ByteString {- ^ raw, spaces delimited caps list -} -> IrcConnection -> Logic IrcConnection doCapAck rawCaps conn = let ackCaps = B8.words rawCaps in case view connSasl conn of Just{} | "sasl" `elem` ackCaps -> do sendMessage (authenticateCmd "PLAIN") return (set connPhase SaslPhase conn) _ -> do sendMessage capEndCmd return conn encodePlainAuthentication :: ByteString {- ^ username -} -> ByteString {- ^ password -} -> ByteString encodePlainAuthentication user pass = Base64.encode $ B8.intercalate "\0" [user,user,pass] doChannelModeIs :: Identifier {- ^ Channel -} -> ByteString {- ^ modes -} -> [ByteString] {- ^ mode parameters -} -> IrcConnection -> Logic IrcConnection doChannelModeIs chan modes args conn = case splitModes (view connChanModeTypes conn) modes args of Nothing -> fail "Bad mode string" Just xs -> return (set (connChannels . ix chan . chanModes) (Just modeMap) conn) where modeMap = Map.fromList [ (mode,arg) | (True,mode,arg) <- xs ] doServerError :: Text -> IrcConnection -> Logic IrcConnection doServerError err conn = do stamp <- getStamp let mesg = defaultIrcMessage { _mesgType = ErrorMsgType err , _mesgSender = UserInfo (mkId "server") Nothing Nothing , _mesgStamp = stamp } recordFor "" mesg return conn -- | Mark all the given nicks as active (not-away). doIsOn :: [Identifier] {- ^ active nicks -} -> IrcConnection -> IrcConnection doIsOn nicks conn = foldl' setIsOn conn nicks where setIsOn connAcc nick = updateUserRecord nick (set usrAway False) connAcc doModeChange :: UserInfo {- ^ who -} -> Identifier {- ^ target -} -> ByteString {- ^ modes changed -} -> [ByteString] {- ^ arguments -} -> IrcConnection -> Logic IrcConnection doModeChange who target modes0 args0 conn | isChannelName target conn = case splitModes modeSettings modes0 args0 of Nothing -> return conn Just ms -> doChannelModeChanges ms who target conn -- TODO: Implement user modes | otherwise = case splitModes (view connUserModeTypes conn) modes0 args0 of Nothing -> return conn Just ms -> return (doUserModeChanges ms conn) where modeSettings = view connChanModeTypes conn doUserModeChanges :: [(Bool, Char, ByteString)] {- ^ [(+/-,mode,argument)] -} -> IrcConnection -> IrcConnection doUserModeChanges ms = over connUmode addModes where addModes bs = B.sort (foldl' aux bs ms) aux bs (polarity,m,_) | polarity && B8.elem m bs = bs | polarity = B8.cons m bs | otherwise = B8.filter (/= m) bs doChannelModeChanges :: [(Bool, Char, ByteString)] {- ^ [(+/-,mode,argument)] -} -> UserInfo {- ^ changer -} -> Identifier {- ^ channel -} -> IrcConnection -> Logic IrcConnection doChannelModeChanges ms who chan conn0 = do now <- getStamp foldM (aux now) conn0 ms where settings = view connChanModeTypes conn0 aux now conn (polarity,m,a) = fmap (over (connChannels . ix chan) (installModeChange settings now who polarity m a)) (recordMessage modeMsg chan conn) where modeMsg = defaultIrcMessage { _mesgType = ModeMsgType polarity m a , _mesgSender = who , _mesgStamp = now , _mesgModes = view ( connChannels . ix chan . chanUsers . ix (userNick who) ) conn } installModeChange :: ModeTypes {- ^ settings -} -> UTCTime {- ^ timestamp -} -> UserInfo {- ^ changer -} -> Bool {- ^ +/- -} -> Char {- ^ mode -} -> ByteString {- ^ argument -} -> IrcChannel -> IrcChannel installModeChange settings now who polarity mode arg -- Handle bans, exceptions, invex, quiets | mode `elem` view modesLists settings = if polarity then over (chanMaskLists . ix mode) (cons (IrcMaskEntry arg (renderUserInfo who) now)) else over (chanMaskLists . ix mode) (filter (\x -> ircFoldCase (view maskEntryMask x) /= ircFoldCase arg)) -- Handle ops and voices | mode `elem` views modesPrefixModes (map fst) settings = if polarity then over (chanUsers . ix (mkId arg)) (nub . cons mode) else over (chanUsers . ix (mkId arg)) (delete mode) | otherwise = if polarity then set (chanModes . mapped . at mode) (Just arg) else set (chanModes . mapped . at mode) Nothing unsplitModes :: [(Bool,Char,ByteString)] -> [ByteString] unsplitModes modes = B8.pack (foldr combineModeChars (const "") modes True) : [arg | (_,_,arg) <- modes, not (B.null arg)] where combineModeChars (q,m,_) rest p | p == q = m : rest p | q = '+' : m : rest True | otherwise = '-' : m : rest False -- | Split up a mode change command and arguments into individual changes -- given a configuration. splitModes :: ModeTypes {- ^ mode interpretation -} -> ByteString {- ^ modes -} -> [ByteString] {- ^ arguments -} -> Maybe [(Bool,Char,ByteString)] splitModes icm modes0 = foldr aux (\_ args -> [] <$ guard (null args)) (B8.unpack modes0) True where aux :: Char {- current mode -} -> (Bool -> [ByteString] -> Maybe [(Bool,Char,ByteString)]) {- continuation with updated polarity and arguments -} -> Bool {- current polarity -} -> [ByteString] {- current arguments -} -> Maybe [(Bool,Char,ByteString)] aux m rec polarity args = case m of '+' -> rec True args '-' -> rec False args _ | m `elem` view modesAlwaysArg icm || polarity && m `elem` view modesSetArg icm || m `elem` views modesPrefixModes (map fst) icm || m `elem` view modesLists icm -> do x:xs <- Just args fmap (cons (polarity,m,x)) (rec polarity xs) | otherwise -> -- default to no arg fmap (cons (polarity,m,"")) (rec polarity args) doMaskList :: (MsgFromServer -> Maybe (Identifier,ByteString,ByteString,UTCTime)) -> (MsgFromServer -> Bool) -> Char -> Identifier -> [IrcMaskEntry] -> IrcConnection -> Logic IrcConnection doMaskList matchEntry matchEnd mode chan acc conn = do msg <- getMessage case matchEntry msg of Just (_,mask,who,stamp) -> doMaskList matchEntry matchEnd mode chan (IrcMaskEntry { _maskEntryMask = mask , _maskEntryWho = who , _maskEntryStamp = stamp } : acc) conn _ | matchEnd msg -> return (set (connChannels . ix chan . chanMaskLists . at mode) (Just (reverse acc)) conn) _ -> fail "Expected mode list end" -- | Update an 'IrcConnection' when a user changes nicknames. doNick :: UserInfo {- ^ old user infomation -} -> Identifier {- ^ new nickname -} -> IrcConnection -> Logic IrcConnection doNick who newnick conn = do stamp <- getStamp let m = defaultIrcMessage { _mesgType = NickMsgType newnick , _mesgSender = who , _mesgStamp = stamp } let conn1 | isMyNick (userNick who) conn = set connNick newnick conn | otherwise = conn conn2 = set (connUsers . at newnick) (view (connUsers . at (userNick who)) conn1) $ set (connUsers . at (userNick who)) Nothing $ conn1 iforOf (connChannels . itraversed) conn2 (updateChannel m) where oldnick = userNick who updateChannel :: IrcMessage -> Identifier -> IrcChannel -> Logic IrcChannel updateChannel m tgt chan | has (chanUsers . ix oldnick) chan = do recordFor tgt m pure $ set (chanUsers . at oldnick) Nothing $ set (chanUsers . at newnick) (view (chanUsers . at oldnick) chan) $ chan | otherwise = pure chan -- | Update the 'IrcConnection' when a user parts from a channel. doPart :: UserInfo {- ^ user information -} -> Identifier {- ^ channel -} -> ByteString {- ^ part reason -} -> IrcConnection -> Logic IrcConnection doPart who chan reason conn = do stamp <- getStamp let mesg = defaultIrcMessage { _mesgType = PartMsgType (asUtf8 reason) , _mesgSender = who , _mesgStamp = stamp } removeUser = set (chanUsers . at (userNick who)) Nothing conn1 <- fmap (over (connChannels . ix chan) removeUser) (recordMessage mesg chan conn) let stillKnown = has (connChannels . folded . chanUsers . ix (userNick who)) conn1 conn2 | stillKnown = conn1 | otherwise = set (connUsers . at (userNick who)) Nothing conn1 conn3 | isMyNick (userNick who) conn = set (connChannels . at chan) Nothing conn2 | otherwise = conn2 return conn3 -- | Update an 'IrcConnection' when a user is kicked from a channel. doKick :: UserInfo {- ^ kicker -} -> Identifier {- ^ channel -} -> Identifier {- ^ kicked -} -> ByteString {- ^ kick reason -} -> IrcConnection -> Logic IrcConnection doKick who chan tgt reason conn = do stamp <- getStamp let modes = view (connChannels . ix chan . chanUsers . ix (userNick who)) conn mesg = defaultIrcMessage { _mesgType = KickMsgType tgt (asUtf8 reason) , _mesgSender = who , _mesgStamp = stamp , _mesgModes = modes } let conn1 = set (connChannels . ix chan . chanUsers . at tgt) Nothing conn stillKnown = has (connChannels . folded . chanUsers . ix (userNick who)) conn1 conn2 | stillKnown = conn1 | otherwise = set (connUsers . at (userNick who)) Nothing conn1 conn3 | isMyNick tgt conn2 = set (connChannels . at chan) Nothing conn2 | otherwise = conn2 recordMessage mesg chan conn3 updateUserRecord :: Identifier -> (IrcUser -> IrcUser) -> IrcConnection -> IrcConnection updateUserRecord nick f conn = case view (connUsers . at nick) conn of Nothing -> conn Just old -> (set (connUsers . ix nick) $! f old) conn doWhoReply :: Identifier -> ByteString -> ByteString -> IrcConnection -> Logic IrcConnection doWhoReply nickname hostname flags conn = return $! updateUserRecord nickname (set usrAway away . updateHost) conn where away = not (B.null flags) && B.take 1 flags == "G" updateHost = set usrHost (Just hostname) -- | Update an 'IrcConnection' with the quitting of a user. doQuit :: UserInfo {- ^ user info -} -> ByteString {- ^ quit reason -} -> IrcConnection -> Logic IrcConnection doQuit who reason conn = do stamp <- getStamp let mesg = defaultIrcMessage { _mesgType = QuitMsgType (asUtf8 reason) , _mesgSender = who , _mesgStamp = stamp } iforOf (connChannels . itraversed) (set (connUsers . at (userNick who)) Nothing conn) $ \tgt chan -> if has (chanUsers . ix (userNick who)) chan then do recordFor tgt mesg pure (set (chanUsers . at (userNick who)) Nothing chan) else pure chan doJoinChannel :: UserInfo {- ^ who joined -} -> Fuzzy ByteString {- ^ account name -} -> Identifier {- ^ channel -} -> IrcConnection -> Logic IrcConnection doJoinChannel who acct chan conn = do stamp <- getStamp -- add channel if necessary let conn1 | isMyNick (userNick who) conn = set (connChannels . at chan) (Just defaultChannel) conn | otherwise = conn -- add user to channel conn2 = set (connChannels . ix chan . chanUsers . at (userNick who)) (Just "") -- empty modes conn1 conn3 = recordAccount (learnUserInfo who (ensureRecord conn2)) -- update user record ensureRecord = over (connUsers . at (userNick who)) (Just . fromMaybe defaultIrcUser) recordAccount = case acct of None -> over (connUsers . ix (userNick who)) (set usrAccount Nothing) Known a -> over (connUsers . ix (userNick who)) (set usrAccount (Just a)) Unknown -> id -- record join event m = defaultIrcMessage { _mesgType = JoinMsgType , _mesgSender = who , _mesgStamp = stamp } recordMessage m chan conn3 learnUserInfo :: UserInfo -> IrcConnection -> IrcConnection learnUserInfo ui conn = case userHost ui of Nothing -> conn Just host -> let update Nothing = Just defaultIrcUser { _usrHost = Just host } update (Just u) = Just $! set usrHost (Just host) u in over (connUsers . at (userNick ui)) update conn doNotifyChannel :: UserInfo -> Identifier -> ByteString -> IrcConnection -> Logic IrcConnection doNotifyChannel who chan msg conn = do stamp <- getStamp let (statusmsg, chan') = splitStatusMsg chan conn let ty = case parseCtcpCommand msg of Nothing -> NoticeMsgType (asUtf8 msg) Just (command , args ) -> CtcpRspMsgType command args modes = view (connChannels . ix chan' . chanUsers . ix (userNick who)) conn mesg = defaultIrcMessage { _mesgType = ty , _mesgSender = who , _mesgStamp = stamp , _mesgStatus = statusmsg , _mesgModes = modes } recordMessage mesg chan' conn doServerMessage :: ByteString {- ^ who -} -> ByteString {- ^ message -} -> IrcConnection -> Logic IrcConnection doServerMessage who txt conn = do stamp <- getStamp let m = defaultIrcMessage { _mesgType = PrivMsgType (asUtf8 txt) , _mesgSender = UserInfo (mkId who) Nothing Nothing , _mesgStamp = stamp } recordFor "" m return conn doNameReply :: Identifier -> [ByteString] -> IrcConnection -> Logic IrcConnection doNameReply chan xs conn = do msg <- getMessage case msg of RplNameReply _ _ x -> doNameReply chan (x++xs) conn RplEndOfNames _ -> return $ learnAllHosts $ set (connChannels . ix chan . chanUsers) users conn _ -> fail "Expected end of names" where modeMap = view (connChanModeTypes . modesPrefixModes) conn splitNames :: [(UserInfo, String)] splitNames = map (splitNamesReplyName modeMap) xs users :: Map Identifier String users = Map.fromList (map (over _1 userNick) splitNames) learnAllHosts x = foldl' (flip learnUserInfo) x (map fst splitNames) -- | Compute the nickname and channel modes from an entry in -- a NAMES reply. The leading channel prefixes are translated -- into the appropriate modes. splitNamesReplyName :: [(Char,Char)] {- ^ [(mode,prefix)] -} -> ByteString {- ^ names entry -} -> (UserInfo, String) {- ^ (nickname, modes) -} splitNamesReplyName modeMap = aux [] where aux modes n = case B8.uncons n of Just (x,xs) | Just (mode,_) <- find (\(_mode,symbol) -> x == symbol) modeMap -> aux (mode:modes) xs _ -> (parseUserInfo n,modes) ------------------------------------------------------------------------ -- Type describing computations that will require zero or more messages -- to perform complex updates to the model. ------------------------------------------------------------------------ -- | Execute the 'Logic' value using a given operation for sending and -- recieving IRC messages. runLogic :: (Functor m,Monad m) => UTCTime -> (forall r. LogicOp r -> m r) -> Logic a -> m (Either String a) runLogic now ops (Logic f) = retract $ hoistFree ops $ runErrorT $ runReaderT f now data LogicOp r = Expect (MsgFromServer -> r) | Emit ByteString r | Record Identifier IrcMessage r deriving (Functor) newtype Logic a = Logic (ReaderT UTCTime (ErrorT String (Free LogicOp)) a) deriving (Functor, Applicative, Monad) getStamp :: Logic UTCTime getStamp = Logic ask recordFor :: Identifier -> IrcMessage -> Logic () recordFor target msg = Logic (wrap (Record target msg (return ()))) getMessage :: Logic MsgFromServer getMessage = Logic (wrap (Expect return)) sendMessage :: ByteString -> Logic () sendMessage x = Logic (wrap (Emit x (return ()))) -- | Add a message to the client state for users and channels. -- The user or channel record should be added if it does not already -- exist. recordMessage :: IrcMessage -> Identifier {- ^ target -} -> IrcConnection -> Logic IrcConnection recordMessage mesg target conn = do let mesg1 = set mesgMe isMe mesg recordFor target mesg1 return conn where isMe = isMyNick (views mesgSender userNick mesg) conn -- | Predicate to determine if a given identifier is the primary nick -- for the given connection. isMyNick :: Identifier -> IrcConnection -> Bool isMyNick nick conn = nick == view connNick conn -- | Predicate for identifiers to identify which represent channel names. -- Channel prefixes are configurable, but the most common is @#@ isChannelName :: Identifier -> IrcConnection -> Bool isChannelName c conn = case B8.uncons (idBytes c) of Just (x,xs) -> not (B.null xs) && x `elem` view connChanTypes conn _ -> False -- probably shouldn't happen -- | Predicate for identifiers to identify which represent nicknames isNickName :: Identifier -> IrcConnection -> Bool isNickName c conn = case B8.uncons (idBytes c) of Just (x,_) -> not (x `elem` view connChanTypes conn) _ -> False -- probably shouldn't happen splitStatusMsg :: Identifier -> IrcConnection -> (String,Identifier) splitStatusMsg target conn = aux [] (idBytes target) where aux acc bs = case B8.uncons bs of Just (x,xs) | x `elem` view connStatusMsg conn -> aux (x:acc) xs _ -> (reverse acc, mkId bs) nickHasModeInChannel :: Identifier {- ^ nick -} -> Char {- ^ mode -} -> Identifier {- ^ channel -} -> IrcConnection -> Bool nickHasModeInChannel nick mode chan = elemOf ( connChannels . ix chan . chanUsers . ix nick . folded) mode channelHasMode :: Identifier {- ^ channel -} -> Char {- ^ mode -} -> IrcConnection -> Bool channelHasMode chan mode = has ( connChannels . ix chan . chanModes . folded . ix mode ) irc-core-1.1.3/src/Irc/RateLimit.hs0000644000000000000000000000360512622517457015156 0ustar0000000000000000-- | This module implements a simple rate limiter based on the -- to be used to keep an IRC client from getting kicked due to -- flooding. It allows one event per duration with a given threshold. 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) , rateThreshold :: !Int , ratePenalty :: !Int } -- | Construct a new rate limit with the RFC 2813 specified -- 2 second penalty and 10 second threshold newRateLimitDefault :: IO RateLimit newRateLimitDefault = newRateLimit 2 10 -- | 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' irc-core-1.1.3/src/Irc/Time.hs0000644000000000000000000000116312622517457014157 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Compatibility shim to keep CPP out of my other files module Irc.Time (myParseTime) where #if MIN_VERSION_time(1,5,0) import Data.Time (UTCTime, parseTimeM, defaultTimeLocale) #else import Data.Time (UTCTime, parseTime) import System.Locale (defaultTimeLocale) #endif -- | Compatibility indirection for time-1.4.2 and time-1.5 compatibility myParseTime :: String {- ^ Format string -} -> String {- ^ Input string -} -> Maybe UTCTime #if MIN_VERSION_time(1,5,0) myParseTime = parseTimeM True defaultTimeLocale #else myParseTime = parseTime defaultTimeLocale #endif {-# INLINE myParseTime #-} irc-core-1.1.3/src/Irc/Core/0000755000000000000000000000000012622517457013614 5ustar0000000000000000irc-core-1.1.3/src/Irc/Core/Prisms.hs0000644000000000000000000000031612622517457015425 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | Automatically generated 'Prism's for all of the types in 'MsgFromServer' module Irc.Core.Prisms where import Control.Lens import Irc.Core makePrisms ''MsgFromServer