irc-core (empty) → 1.0
raw patch · 27 files changed
+6616/−0 lines, 27 filesdep +arraydep +attoparsecdep +basesetup-changed
Dependencies added: array, attoparsec, base, base64-bytestring, bytestring, config-value, connection, containers, data-default-class, deepseq, directory, filepath, free, haskell-lexer, irc-core, lens, network, old-locale, split, stm, text, time, tls, transformers, vty, x509, x509-store, x509-system, x509-validation
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- README.md +181/−0
- Setup.hs +2/−0
- driver/ClientState.hs +317/−0
- driver/CommandArgs.hs +216/−0
- driver/CommandParser.hs +168/−0
- driver/Connection.hs +123/−0
- driver/CtcpHandler.hs +69/−0
- driver/EditBox.hs +187/−0
- driver/HaskellHighlighter.hs +74/−0
- driver/ImageUtils.hs +219/−0
- driver/Main.hs +983/−0
- driver/Moderation.hs +274/−0
- driver/ServerSettings.hs +24/−0
- driver/Views/BanList.hs +26/−0
- driver/Views/Channel.hs +351/−0
- driver/Views/ChannelInfo.hs +91/−0
- irc-core.cabal +161/−0
- src/Irc/Cmd.hs +438/−0
- src/Irc/Core.hs +776/−0
- src/Irc/Core/Prisms.hs +9/−0
- src/Irc/Format.hs +303/−0
- src/Irc/Message.hs +93/−0
- src/Irc/Model.hs +1411/−0
- src/Irc/RateLimit.hs +63/−0
- src/Irc/Time.hs +24/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+1.0+---+* Initial hackage release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (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.
+ README.md view
@@ -0,0 +1,181 @@+My IRC client+=============++[](http://travis-ci.org/glguy/irc-core)++++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++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 <options> 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=<your irc password>+SASLPASSWORD=<your sasl password>+```++Configuration file+=================++A configuration file can currently be used to provide some default values instead of+using command line arguments. If any value is missing the default will be used.++Learn more about this file format at [config-value](http://hackage.haskell.org/package/config-value)++```+-- 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"++ * hostname: "example.com"+ port: 7000++-- Specify additional certificates beyond the system CAs+server-certificates:+ * "/path/to/extra/certificate.pem"+```++Commands+========++* `/exit` - *Exit!*++* `/akb <nick> <message>` - 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 <channel> +b`+* `/channel <channel>` - switch to a user message window+* `/channelinfo` - Show information for the current channel+* `/ctcp <command> <params>` - Send CTCP command to current window+* `/clear` - Clear all messages for the current channel+* `/help <topic>` - Request help from the server+* `/hs <haskell source code>` - Send syntax highlighted source code as a message to the current channel+* `/ignore <nick>` - Toggle ignoring a user by nickname.+* `/join <channel>` - join a new channel (optional key argument)+* `/kick <nick> <msg>` - Kick a user from the current channel+* `/masks <mode>` - Show the bans (b), quiets (q), invex (I), or ban exemptions (e) for a channel. The list must be requested as above.+* `/me <message>` - send an action to the current channel+* `/mode <mode> <arguments>` - Set modes on the current channel+* `/msg <nick> <message>` - send a private message+* `/nick <nick>` - Change your nickname+* `/notice <nick> <message>` - send a notice message+* `/op <nicks>` - Op nicks in the channel, self when no nicks given+* `/deop <nicks>` - Deop nicks in the channel, self when no nicks given+* `/voice <nicks>` - Voice nicks in the channel, self when no nicks given+* `/devoice <nicks>` - Devoice nicks in the channel, self when no nicks given+* `/part <message>` - part the current channel with the given message+* `/query <nick>` - switch to a user message window+* `/quote <raw client command>` - send a client command verbatim+* `/remove <nick> <msg>` - Force a user to part from the current channel+* `/server` - switch to the server message window+* `/topic <topic>` - Change the topic for the current channel+* `/umode <mode>` - Set modes on yourself+* `/window <number>` - Jump to a window by index+* `/whois <nick>` - Query the server for information about a user+* `/whowas <nick>` - Query the server for information about a user who recently disconnected.+* `/stats <letter>` - Request server stat information, try `/help stats` on Freenode first.+* `/admin` - Request some basic admin contact information+* `/away <message>` - 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 <nick>` - Invite the given user to the current channel+* `/reconnect` - Reconnect to the current server++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+* `Page Up` scroll up+* `Page Down` scroll down+* `^B` bold+* `^C` color+* `^V` reverse video+* `^_` underline+* `^]` italic+* `^O` reset formatting
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ driver/ClientState.hs view
@@ -0,0 +1,317 @@+{-# 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)+import Data.ByteString (ByteString)+import Data.Char (isControl)+import Data.Functor.Compose+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+ , _ccSendChan :: TChan ByteString+ , _ccConnection :: IrcConnection+ , _ccRecvThread :: ThreadId+ , _ccSendThread :: 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+ , _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+ 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 =+ atomically (writeTChan (view (clientServer0.ccSendChan) st) 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++ aux = case views mesgType isRelevant message of+ Nothing -> over mlMessages (cons (message,error "unused colored message"))+ Just txt -> over mlNewMessages (+1)+ . over mlMentioned (|| mention txt || private)+ . over mlMessages (cons (message,coloredImage))+ where+ !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 ((when,events), timers1) <- Map.minViewWithKey timers+ guard (when <= now)+ case events of+ [] -> error "nextTimerEvent: empty entry!"+ [e] -> return (e, timers1)+ e:es -> return (e, Map.insert when 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 when e = over clientTimers (Map.insertWith (++) when [e])
+ driver/CommandArgs.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module CommandArgs where++import Config+import Config.Lens+import Control.Applicative+import Control.Exception+import Control.Monad (when)+import Data.Foldable (traverse_)+import Data.Maybe+import Data.Text (Text)+import Data.Text.Lens (unpacked)+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++defaultConfigPath :: IO FilePath+defaultConfigPath =+ do dir <- getAppUserDataDirectory "glirc"+ return (dir </> "config")++data CommandArgs = CommandArgs+ { _cmdArgNick :: Maybe String+ , _cmdArgServer :: String+ , _cmdArgPort :: Maybe Int+ , _cmdArgHelp :: 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++getCommandArgs :: IO CommandArgs+getCommandArgs =+ do args <- getArgs++ r <- case getOpt RequireOrder optDescrs args of+ (fs, [server], []) ->+ do let r0 = CommandArgs+ { _cmdArgServer = server+ , _cmdArgReal = Nothing+ , _cmdArgUser = Nothing+ , _cmdArgNick = Nothing+ , _cmdArgUserInfo = Nothing++ , _cmdArgSaslUser = Nothing+ , _cmdArgPort = Nothing+ , _cmdArgHelp = False+ , _cmdArgDebug = Nothing+ , _cmdArgTls = False+ , _cmdArgTlsClientCert = Nothing+ , _cmdArgTlsClientKey = Nothing+ , _cmdArgTlsInsecure = False+ , _cmdArgConfigFile = Nothing+ , _cmdArgConfigValue = Sections []+ }+ return (foldl (\acc f -> f acc) r0 fs)++ (_ , _, errs) ->+ do traverse_ (hPutStrLn stderr) errs+ help++ when (view cmdArgHelp r) help++ v <- loadConfigValue (view cmdArgConfigFile r)+ return (set cmdArgConfigValue v r)++help :: IO a+help =+ do prog <- getProgName+ let txt = prog ++ " <options> SERVER"+ hPutStr stderr (usageInfo txt optDescrs)+ exitFailure++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 "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)+ 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+ }+++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)
+ driver/CommandParser.hs view
@@ -0,0 +1,168 @@+{-# 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
+ driver/Connection.hs view
@@ -0,0 +1,123 @@+{-# 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+ return ConnectionParams+ { connectionHostname = view ssHostName args+ , connectionPort = ircPort args+ , connectionUseSecure = useSecure+ , connectionUseSocks = Nothing+ }++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
+ driver/CtcpHandler.hs view
@@ -0,0 +1,69 @@+{-# 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)+ }
+ driver/EditBox.hs view
@@ -0,0 +1,187 @@+{-# 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
+ driver/HaskellHighlighter.hs view
@@ -0,0 +1,74 @@+module 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"
+ driver/ImageUtils.hs view
@@ -0,0 +1,219 @@+{-# 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)++
+ driver/Main.hs view
@@ -0,0 +1,983 @@+{-# 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.Foldable (for_, traverse_)+import Data.List (elemIndex)+import Data.List.Split (chunksOf)+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Set (Set)+import Data.Text (Text)+import Data.Time+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 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+ driver vty vtyEventChan recvChan ClientState+ { _clientServer0 = server0+ , _clientRecvChan = recvChan+ , _clientErrors = hErr+ , _clientFocus = ChannelFocus ""+ , _clientDetailView = False+ , _clientTimeView = True+ , _clientMetaView = True+ , _clientEditBox = Edit.empty+ , _clientTabPattern = Nothing+ , _clientScrollPos = 0+ , _clientHeight = height+ , _clientWidth = width+ , _clientIgnores = mempty+ , _clientHighlights = mempty+ , _clientMessages = mempty+ , _clientNickColors = defaultNickColors+ , _clientAutomation = [ctcpHandler,cancelDeopTimerOnDeop]+ , _clientTimers = mempty+ , _clientTimeZone = zone+ , _clientConfig = view cmdArgConfigValue args+ }++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 h <- connect config settings+ sendChan <- atomically newTChan+ sendThreadId <- forkIO (sendLoop sendChan h)+ recvThreadId <- forkIO (socketLoop recvChan h hErr)++ let 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)++ initializeConnection pass nick user real h++ return ClientConnection+ { _ccServerSettings = settings+ , _ccSendChan = sendChan+ , _ccConnection = defaultIrcConnection+ { _connNick = nick+ , _connSasl = sasl+ }+ , _ccRecvThread = recvThreadId+ , _ccSendThread = sendThreadId+ }++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+ 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 EventResult+ = KeepGoing ClientState+ | Exit++changeInput :: (Edit.EditBox -> Edit.EditBox) -> ClientState -> ClientState+changeInput f st = clearTabPattern (over clientEditBox f st)++inputLogic :: ClientState -> (Image, IO EventResult)+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 EventResult+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+ (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 EventResult))+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'))++ ]++-- Exploratory!+doReconnect :: ClientState -> IO ClientState+doReconnect st =+ do let server0 = view clientServer0 st+ views ccRecvThread killThread server0+ views ccSendThread killThread server0++ let settings = view ccServerSettings server0+ recvChan = view clientRecvChan st+ hErr = view clientErrors st+ config = view clientConfig st+ server0' <- startIrcConnection config recvChan settings hErr+ let st' = set clientServer0 server0' st+ return 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)+ where+ conn = view (clientServer0 . ccConnection) st++ myNick = view connNick conn++ 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 :: TChan ByteString -> Connection -> IO ()+sendLoop queue h =+ do r <- newRateLimitDefault+ forever $+ do x <- atomically (readTChan queue)+ tickRateLimit r+ connectionPut h x++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+ let debug x = for_ hErr (`hPrint` x)+ case parseRawIrcMsg xs of+ Nothing ->+ do debug xs+ t <- getCurrentTime+ return (t,Error ("Parse: " <> xs))+ Just msg ->+ do t <- maybe getCurrentTime return (msgTime msg)+ case ircMsgToServerMsg msg of+ Nothing ->+ do debug msg+ return (t,Error ("Unknown: " <> xs))+ Just x ->+ do debug x+ return (t,x)++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]
+ driver/Moderation.hs view
@@ -0,0 +1,274 @@+{-# 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
+ driver/ServerSettings.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}++module ServerSettings where++import Control.Lens++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+ }++makeLenses ''ServerSettings
+ driver/Views/BanList.hs view
@@ -0,0 +1,26 @@+module 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))
+ driver/Views/Channel.hs view
@@ -0,0 +1,351 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Views.Channel (channelImage) where++import Control.Lens+import Data.Monoid+import Data.Foldable (toList)+import Data.List (stripPrefix)+import Data.Text (Text)+import Data.Time (TimeZone, UTCTime, formatTime, utcToZonedTime)+import Graphics.Vty.Image+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Text as Text++#if MIN_VERSION_time(1,5,0)+import Data.Time (defaultTimeLocale)+#else+import System.Locale (defaultTimeLocale)+#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+ = map renderOne+ $ map fst+ $ activeMessages st+ where+ zone = view clientTimeZone st+ renderOne x =+ timestamp <|>+ 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++ (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 "%H:%M:%S "+ . utcToZonedTime zone++renderCompressedTimestamp :: TimeZone -> UTCTime -> Image+renderCompressedTimestamp zone+ = string (withForeColor defAttr brightBlack)+ . formatTime defaultTimeLocale "[%H:%M] "+ . utcToZonedTime zone++activeMessages :: ClientState -> [(IrcMessage,Image)]+activeMessages st =+ case stripPrefix "/filter " (clientInput st) of+ Nothing -> toList msgs+ Just nick -> filter (nickFilter (BS8.pack nick) . fst) (toList msgs)+ where+ msgs = view (clientMessages . ix (focusedName st) . mlMessages) st+ nickFilter nick msg+ = views mesgSender userNick msg == mkId nick++compressedImageForState :: ClientState -> [Image]+compressedImageForState !st = renderOne (activeMessages st)+ where+ zone = view clientTimeZone st+ width = view clientWidth 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 ((msg,colored):msgs) =+ case mbImg of+ Just img -> (timestamp <|> img) : renderOne msgs+ Nothing -> renderMeta emptyImage ((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)++ 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++ filterMeta x+ | view clientMetaView st = [x]+ | otherwise = []++ renderMeta img [] = filterMeta (cropRight width img)+ renderMeta img ((msg,colored):msgs) =+ let who = views mesgSender userNick msg+ visible = not (view (contains who) ignores)+ metaAttr = withForeColor defAttr brightBlack+ in case view mesgType msg of+ CtcpReqMsgType{} ->+ renderMeta+ (img <|>+ char (withForeColor defAttr brightBlue) 'C' <|>+ identImg metaAttr who <|>+ char defAttr ' ') msgs+ JoinMsgType ->+ renderMeta+ (img <|>+ char (withForeColor defAttr green) '+' <|>+ identImg metaAttr who <|>+ char defAttr ' ') msgs+ PartMsgType{} ->+ renderMeta+ (img <|>+ char (withForeColor defAttr red) '-' <|>+ identImg metaAttr who <|>+ char defAttr ' ') msgs+ QuitMsgType{} ->+ renderMeta+ (img <|>+ char (withForeColor defAttr red) 'x' <|>+ identImg metaAttr who <|>+ char defAttr ' ') msgs+ NickMsgType who' ->+ renderMeta+ (img <|>+ identImg metaAttr who <|>+ char (withForeColor defAttr yellow) '-' <|>+ identImg metaAttr who' <|>+ char defAttr ' ') msgs+ KnockMsgType ->+ renderMeta+ (img <|>+ char (withForeColor defAttr yellow) 'K' <|>+ identImg metaAttr who <|>+ char defAttr ' ') msgs+ _ | not visible ->+ renderMeta+ (img <|>+ char (withForeColor defAttr brightBlack) 'I' <|>+ identImg metaAttr who <|>+ char defAttr ' ') msgs+ | otherwise ->+ filterMeta (cropRight width img)+ ++ renderOne ((msg,colored):msgs)+++ conn = view (clientServer0 . ccConnection) st++ prefixes = view (connChanModeTypes . modesPrefixModes) conn++ modePrefix modes =+ string (withForeColor defAttr blue)+ [ prefix | (mode,prefix) <- prefixes, mode `elem` modes]+++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 <> "\""
+ driver/Views/ChannelInfo.hs view
@@ -0,0 +1,91 @@+module 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:"+ : [ 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.cabal view
@@ -0,0 +1,161 @@+name: irc-core+version: 1.0+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 <emertens@gmail.com>+copyright: 2015 Eric Mertens+category: Network+build-type: Simple+cabal-version: >=1.10+synopsis: An IRC client library and text client+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.13,+ bytestring >= 0.10 && < 0.11,+ base64-bytestring>= 1.0.0.1 && < 1.1,+ containers >= 0.5 && < 0.6,+ free >= 4.11 && < 4.12,+ lens >= 4.7 && < 4.10,+ text >= 1.2.0.4 && < 1.3,+ transformers >= 0.2 && < 0.5++ 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+ CtcpHandler+ EditBox+ HaskellHighlighter+ ImageUtils+ Moderation+ ServerSettings+ Views.BanList+ Views.Channel+ Views.ChannelInfo+ hs-source-dirs: driver+ ghc-options: -threaded+ build-depends: irc-core,++ connection >= 0.2.4 && < 0.3,+ tls >= 1.2.16 && < 1.3,+ data-default-class >= 0.0.1 && < 0.1,+ x509 >= 1.5.0.1 && < 1.6,+ x509-system >= 1.5.0 && < 1.6,+ x509-store >= 1.5.0 && < 1.6,+ x509-validation >= 1.5.1 && < 1.6,++ 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.9,+ 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.3,+ haskell-lexer >= 1.0 && < 1.1,+ transformers >= 0.2 && < 0.5+ default-language: Haskell2010++source-repository head+ type: git+ location: git://github.com/glguy/irc-core.git
+ src/Irc/Cmd.hs view
@@ -0,0 +1,438 @@+{-# 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+ , 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 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 <channel> *("," <channel>) @+listCmd ::+ [Identifier] {- ^ channels -} ->+ ByteString+listCmd chans = renderRawIrcMsg outgoingMsg+ { msgCommand = "LIST"+ , msgParams = [B8.intercalate "," (map idBytes chans)]+ }++-- | Construct a INVITE command.+--+-- @INVITE <nickanme> <channel>@+inviteCmd ::+ Identifier {- ^ nickname -} ->+ Identifier {- ^ channel -} ->+ ByteString+inviteCmd nick chan = renderRawIrcMsg outgoingMsg+ { msgCommand = "INVITE"+ , msgParams = [idBytes nick,idBytes chan]+ }++-- | Construct a NAMES command.+--+-- @NAMES [ <channel> *("," <channel>)@+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 <name> <password>@+operCmd ::+ ByteString {- ^ name -} ->+ ByteString {- ^ password -} ->+ ByteString+operCmd name pass = renderRawIrcMsg outgoingMsg+ { msgCommand = "OPER"+ , msgParams = [name,pass]+ }++-- | Construct a WHO command.+--+-- @WHO <mask>@+whoCmd ::+ ByteString {- ^ mask -} ->+ ByteString+whoCmd mask = renderRawIrcMsg outgoingMsg+ { msgCommand = "WHO"+ , msgParams = [mask]+ }++-- | Construct a KNOCK command.+--+-- @KNOCK <channel>@+knockCmd ::+ Identifier {- ^ channel -} ->+ ByteString+knockCmd chan = renderRawIrcMsg outgoingMsg+ { msgCommand = "KNOCK"+ , msgParams = [idBytes chan]+ }++-- | Construct an ACCEPT command.+--+-- @ACCEPT <nick>@+acceptCmd ::+ ByteString {- ^ nick, -nick, * -} ->+ ByteString+acceptCmd nick = renderRawIrcMsg outgoingMsg+ { msgCommand = "ACCEPT"+ , msgParams = [nick]+ }++-- | Construct an TIME command.+--+-- @TIME [<server>]>@+timeCmd ::+ Maybe ByteString {- ^ server -} ->+ ByteString+timeCmd server = renderRawIrcMsg outgoingMsg+ { msgCommand = "TIME"+ , msgParams = toList server+ }++-- | Construct an ADMIN command.+--+-- @ADMIN [<server>]>@+adminCmd ::+ Maybe ByteString {- ^ server -} ->+ ByteString+adminCmd server = renderRawIrcMsg outgoingMsg+ { msgCommand = "ADMIN"+ , msgParams = toList server+ }++-- | Construct a STATS command.+--+-- @STATS <letter> [<server>]>@+statsCmd ::+ Char ->+ Maybe ByteString {- ^ target -} ->+ ByteString+statsCmd letter target = renderRawIrcMsg outgoingMsg+ { msgCommand = "STATS"+ , msgParams = B8.singleton letter : toList target+ }
+ src/Irc/Core.hs view
@@ -0,0 +1,776 @@+{-# 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 \<nick\>!\<user\>\@\<host\>"+ | RplYourHost ByteString -- ^ 002 "Your host is \<servername\>, running version \<ver\>"+ | RplCreated ByteString -- ^ 003 "This server was created \<date\>"+ | 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 \<integer\> users and \<integer\> services on \<integer\> servers"+ | RplLuserOp ByteString -- ^ 252 number-of-ops+ | RplLuserUnknown ByteString -- ^ 253 number-of-unknown+ | RplLuserChannels ByteString -- ^ 254 number-of-channels+ | RplLuserMe ByteString -- ^ 255 "I have \<integer\> clients and \<integer\> 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 "\<string showing server's local time\>"+ | 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: <hop> <realname>++ ("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
+ src/Irc/Core/Prisms.hs view
@@ -0,0 +1,9 @@+{-# 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
+ src/Irc/Format.hs view
@@ -0,0 +1,303 @@+{-# 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 _ <- optional (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']
+ src/Irc/Message.hs view
@@ -0,0 +1,93 @@+{-# 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
+ src/Irc/Model.hs view
@@ -0,0 +1,1411 @@+{-# 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+ , 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.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 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++#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+ }+ 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+ }++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++ 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+ )
+ src/Irc/RateLimit.hs view
@@ -0,0 +1,63 @@+-- | 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'
+ src/Irc/Time.hs view
@@ -0,0 +1,24 @@+{-# 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 #-}