diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for glirc2 +## 2.6 + +* connect-cmds now use actual client commands instead of raw IRC messages. For example `msg user my message` or `join #mychannel` +* Multiple lines can be held in the textbox at once. Pasting mutiple lines insert those lines into the textbox rather than sending them immediately. +* Added `M-d` and `M-Enter` key bindings +* Added `name` field to server configuration +* Extract irc-core library again +* Configurable self color + ## 2.5 * Add facilities for hooks that can alter the irc message stream. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -52,6 +52,8 @@ 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. +The default configuration file path is `~/.config/glirc/config` + Relative paths are relative to the home directory. Learn more about this file format at [config-value](http://hackage.haskell.org/package/config-value) @@ -76,7 +78,8 @@ socks-host: "socks5.example.com" socks-port: 8080 -- defaults to 1080 - * hostname: "example.com" + * name: "example" + hostname: "example.com" port: 7000 connect-cmds: * "JOIN #favoritechannel,#otherchannel" @@ -106,10 +109,12 @@ * `defaults` - These settings are used for all connections * `servers` - These settings are used to override defaults when the hostname matches * `palette` - Client color overrides +* `window-names` - text - Names of windows (typically overridden on non QWERTY layouts) Settings -------- +* `name` - text - name of server entry, defaults to `hostname` * `hostname` - text - hostname used to connect and to specify the server * `port` - number - port number, defaults to 6667 without TLS and 6697 with TLS * `nick` - text - nickname @@ -153,7 +158,7 @@ * `/exit` - Terminate the client * `/quit` - Gracefully terminate connection to the current server -* `/connect ` - Connect to the given hostname +* `/connect ` - Connect to the given server * `/disconnect` - Forcefully terminate connection to the current server * `/reconnect` - Reconnect to the current server @@ -230,17 +235,19 @@ * `^N` next channel * `^P` previous channel -* `M-#` jump to window - 1234567890qwertyuiop!@#$%^&*()QWERTYUIOP +* `M-#` jump to window - `1234567890qwertyuiop!@#$%^&*()QWERTYUIOP` * `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 +* `^W` delete word backwards * `^Y` paste from yank buffer * `M-F` forward word * `M-B` backward word +* `M-BACKSPACE` delete word backwards +* `M-D` delete word forwards * `TAB` nickname completion * `F2` toggle detailed view * `Page Up` scroll up @@ -251,6 +258,7 @@ * `^_` underline * `^]` italic * `^O` reset formatting +* `M-Enter` insert newline Hooks ===== diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.5 +version: 2.6 synopsis: Console IRC client description: Console IRC client license: ISC @@ -52,19 +52,10 @@ Client.Window Client.WordCompletion Config.FromConfig - Irc.Codes - Irc.Commands - Irc.Identifier - Irc.Message - Irc.Modes - Irc.RateLimit - Irc.RawIrcMsg - Irc.UserInfo LensUtils StrictUnit Paths_glirc - -- other-extensions: build-depends: base >=4.9 && <4.10, async >=2.1 && < 2.2, attoparsec >=0.13 && <0.14, @@ -78,10 +69,9 @@ filepath >=1.4.1 && <1.5, gitrev >=1.2 && <1.3, hashable >=1.2.4 && <1.3, + irc-core >=2.0 && <2.1, lens >=4.14 && <4.15, - memory >=0.13 && <0.14, network >=2.6.2 && <2.7, - primitive >=0.6 && <0.7, split >=0.2 && <0.3, stm >=2.4 && <2.5, text >=1.2.2 && <1.3, diff --git a/src/Client/ChannelState.hs b/src/Client/ChannelState.hs --- a/src/Client/ChannelState.hs +++ b/src/Client/ChannelState.hs @@ -15,7 +15,7 @@ module Client.ChannelState ( - -- * Channel state type + -- * Channel state ChannelState(..) , chanTopic , chanTopicProvenance diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -14,6 +14,7 @@ module Client.Commands ( CommandResult(..) , execute + , executeCommand , tabCompletion ) where @@ -48,7 +49,10 @@ -- | Possible results of running a command data CommandResult - = CommandContinue ClientState -- ^ Continue running client with updated state + = CommandSuccess ClientState + -- ^ Continue running the client, consume input if command was from input + | CommandFailure ClientState + -- ^ Continue running the client, report an error | CommandQuit -- ^ Client should close type ClientCommand = ClientState -> String -> IO CommandResult @@ -64,24 +68,22 @@ | ChatCommand ChannelCommand (Bool -> ChannelCommand) -- ^ requires an active chat window | ChannelCommand ChannelCommand (Bool -> ChannelCommand) -- ^ requires an active channel window --- | Resume the client without further state changes -commandContinue :: Monad m => ClientState -> m CommandResult -commandContinue = return . CommandContinue - -- | Consider the text entry successful and resume the client commandSuccess :: Monad m => ClientState -> m CommandResult -commandSuccess = commandContinue . consumeInput +commandSuccess = return . CommandSuccess -- | Consider the text entry a failure and resume the client commandFailure :: Monad m => ClientState -> m CommandResult -commandFailure = commandContinue . set clientBell True +commandFailure = return . CommandFailure --- | Interpret whatever text is in the textbox. Leading @/@ indicates a +-- | Interpret the given chat message or command. Leading @/@ indicates a -- command. Otherwise if a channel or user query is focused a chat message -- will be sent. -execute :: ClientState -> IO CommandResult -execute st = - case clientInput st of +execute :: + String {- ^ chat or command -} -> + ClientState -> IO CommandResult +execute str st = + case str of [] -> commandFailure st '/':command -> executeCommand Nothing command st msg -> executeChat msg st @@ -91,9 +93,9 @@ -- input based on the users of the channel related to the current buffer. tabCompletion :: Bool {- ^ reversed -} -> ClientState -> IO CommandResult tabCompletion isReversed st = - case clientInput st of + case snd $ clientLine st of '/':command -> executeCommand (Just isReversed) command st - _ -> commandContinue (nickTabCompletion isReversed st) + _ -> commandSuccess (nickTabCompletion isReversed st) -- | Treat the current text input as a chat message and send it. executeChat :: String -> ClientState -> IO CommandResult @@ -102,7 +104,7 @@ ChannelFocus network channel | Just !cs <- preview (clientConnection network) st -> do now <- getZonedTime - let msgTxt = Text.pack msg + let msgTxt = Text.pack $ takeWhile (/='\n') msg ircMsg = rawIrcMsg "PRIVMSG" [idText channel, msgTxt] myNick = UserInfo (view csNick cs) "" "" entry = ClientMessage @@ -132,7 +134,7 @@ executeCommand :: Maybe Bool -> String -> ClientState -> IO CommandResult executeCommand (Just isReversed) _ st - | Just st' <- commandNameCompletion isReversed st = commandContinue st' + | Just st' <- commandNameCompletion isReversed st = commandSuccess st' executeCommand tabCompleteReversed str st = let (cmd, rest) = splitWord str @@ -164,7 +166,7 @@ _ -> case tabCompleteReversed of Nothing -> commandFailure st - Just isReversed -> commandContinue (nickTabCompletion isReversed st) + Just isReversed -> commandSuccess (nickTabCompletion isReversed st) -- Expands each alias to have its own copy of the command callbacks expandAliases :: [([a],b)] -> [(a,b)] @@ -228,15 +230,15 @@ simpleClientTab :: Bool -> ClientCommand simpleClientTab isReversed st _ = - commandContinue (nickTabCompletion isReversed st) + commandSuccess (nickTabCompletion isReversed st) simpleNetworkTab :: Bool -> NetworkCommand simpleNetworkTab isReversed _ _ st _ = - commandContinue (nickTabCompletion isReversed st) + commandSuccess (nickTabCompletion isReversed st) simpleChannelTab :: Bool -> ChannelCommand simpleChannelTab isReversed _ _ _ st _ = - commandContinue (nickTabCompletion isReversed st) + commandSuccess (nickTabCompletion isReversed st) cmdExit :: ClientCommand cmdExit _ _ = return CommandQuit @@ -398,14 +400,12 @@ -- the current networks are used. tabFocus :: Bool -> ClientCommand tabFocus isReversed st _ - = commandContinue + = commandSuccess $ fromMaybe st $ clientTextBox (wordComplete id isReversed completions) st where networks = map mkId $ HashMap.keys $ view clientNetworkMap st - textBox = view clientTextBox st - params = words $ take (view Edit.pos textBox) - (view Edit.content textBox) + params = words $ uncurry take $ clientLine st completions | length params == 2 = networks @@ -532,12 +532,12 @@ cs' <- if freeTarget then cs <$ sendMsg cs cmd else sendModeration channelId [cmd] cs - commandContinueUpdateCS cs' st + commandSuccessUpdateCS cs' st _ -> commandFailure st -commandContinueUpdateCS :: ConnectionState -> ClientState -> IO CommandResult -commandContinueUpdateCS cs st = +commandSuccessUpdateCS :: ConnectionState -> ClientState -> IO CommandResult +commandSuccessUpdateCS cs st = let networkId = view csNetworkId cs in commandSuccess $ setStrict (clientConnections . ix networkId) cs st @@ -565,8 +565,8 @@ | all isSpace rest , Just topic <- preview (csChannels . ix channelId . chanTopic) cs = do let textBox = Edit.end - . set Edit.content ("/topic " ++ Text.unpack topic) - commandContinue (over clientTextBox textBox st) + . set Edit.line (Edit.endLine $ "/topic " ++ Text.unpack topic) + commandSuccess (over clientTextBox textBox st) | otherwise = commandFailure st @@ -592,7 +592,7 @@ do let msg = Text.pack (dropWhile isSpace reason) cmd = ircKick channelId (Text.pack who) msg cs' <- sendModeration channelId [cmd] cs - commandContinueUpdateCS cs' st + commandSuccessUpdateCS cs' st cmdKickBan :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult @@ -609,7 +609,7 @@ , ircKick channelId whoTxt msg ] cs' <- sendModeration channelId cmds cs - commandContinueUpdateCS cs' st + commandSuccessUpdateCS cs' st computeBanUserInfo :: Identifier -> ConnectionState -> UserInfo computeBanUserInfo who cs = @@ -625,7 +625,7 @@ do let msg = Text.pack (dropWhile isSpace reason) cmd = ircRemove channelId (Text.pack who) msg cs' <- sendModeration channelId [cmd] cs - commandContinueUpdateCS cs' st + commandSuccessUpdateCS cs' st cmdJoin :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult cmdJoin network cs st rest = @@ -718,7 +718,7 @@ cs' <- if needOp then sendModeration chan cmds cs else cs <$ traverse_ (sendMsg cs) cmds - commandContinueUpdateCS cs' st + commandSuccessUpdateCS cs' st _ -> commandFailure st @@ -733,16 +733,14 @@ [ (pol,mode) | (pol,mode,arg) <- parsedModes, not (Text.null arg) ] , (pol,mode):_ <- drop (paramIndex-3) parsedModesWithParams , let completions = computeModeCompletion pol mode channel cs - -> commandContinue + -> commandSuccess $ fromMaybe st $ clientTextBox (wordComplete id isReversed completions) st - _ -> commandContinue st + _ -> commandSuccess st where - textBox = view clientTextBox st - paramIndex = length $ words $ take (view Edit.pos textBox) - (view Edit.content textBox) + paramIndex = length $ words $ uncurry take $ clientLine st -- | Use the *!*@host masks of users for channel lists when setting list modes -- @@ -778,8 +776,8 @@ clientTextBox (wordComplete id isReversed possibilities) st where n = length leadingPart - leadingPart = takeWhile (not . isSpace) (clientInput st) - cursorPos = view (clientTextBox . Edit.pos) st + (cursorPos, line) = clientLine st + leadingPart = takeWhile (not . isSpace) line possibilities = mkId . Text.cons '/' <$> HashMap.keys commands -- | Complete the nickname at the current cursor position using the diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -21,6 +21,7 @@ , configDefaults , configServers , configPalette + , configWindowNames -- * Loading configuration , loadConfiguration @@ -32,7 +33,6 @@ import Client.Image.Palette import Client.Configuration.Colors import Client.ServerSettings -import Control.Applicative import Control.Exception import Control.Monad import Config @@ -44,10 +44,8 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text -import Data.Traversable import Graphics.Vty.Attributes import Irc.Identifier (Identifier, mkId) -import Network.Socket (HostName) import System.Directory import System.FilePath import System.IO.Error @@ -57,8 +55,9 @@ -- otherwise '_configDefaults' is used. data Configuration = Configuration { _configDefaults :: ServerSettings -- ^ Default connection settings - , _configServers :: (HashMap HostName ServerSettings) -- ^ Host-specific settings + , _configServers :: (HashMap Text ServerSettings) -- ^ Host-specific settings , _configPalette :: Palette + , _configWindowNames :: Text -- ^ Names of windows, used when alt-jumping } deriving Show @@ -72,6 +71,9 @@ instance Exception ConfigurationFailure +defaultWindowNames :: Text +defaultWindowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP" + -- | Uses 'getAppUserDataDirectory' to find @.glirc/config@ getOldConfigPath :: IO FilePath getOldConfigPath = @@ -155,19 +157,21 @@ _configPalette <- fromMaybe defaultPalette <$> sectionOptWith parsePalette "palette" + _configWindowNames <- fromMaybe defaultWindowNames + <$> sectionOpt "window-names" + return Configuration{..} parsePalette :: Value -> ConfigParser Palette -parsePalette (Sections ss) = foldM paletteHelper defaultPalette ss -parsePalette _ = failure "Expected sections" +parsePalette = parseSectionsWith paletteHelper defaultPalette -paletteHelper :: Palette -> Section -> ConfigParser Palette -paletteHelper p (Section k v) = - extendLoc k $ +paletteHelper :: Palette -> Text -> Value -> ConfigParser Palette +paletteHelper p k v = case k of "nick-colors" -> do xs <- parseColors v return $! set palNicks xs p + "self" -> setAttr palSelf "time" -> setAttr palTime "meta" -> setAttr palMeta "sigil" -> setAttr palSigil @@ -185,66 +189,79 @@ let !attr = withForeColor defAttr x return $! set l attr p +parseSectionsWith :: (a -> Text -> Value -> ConfigParser a) -> a -> Value -> ConfigParser a +parseSectionsWith p start s = + case s of + Sections xs -> foldM (\x (Section k v) -> extendLoc k (p x k v)) start xs + _ -> failure "Expected sections" -parseServers :: ServerSettings -> Value -> ConfigParser (HashMap HostName ServerSettings) -parseServers def (List xs) = - do ys <- traverse (parseServerSettings def) xs - return (HashMap.fromList [(view ssHostName ss, ss) | ss <- ys]) -parseServers _ _ = failure "expected list" +parseServers :: ServerSettings -> Value -> ConfigParser (HashMap Text ServerSettings) +parseServers def v = + do sss <- parseList (parseServerSettings def) v + return (HashMap.fromList [(serverSettingName ss, ss) | ss <- sss]) + where + serverSettingName ss = + fromMaybe (views ssHostName Text.pack ss) + (view ssName ss) -sectionOptString :: Text -> SectionParser (Maybe String) -sectionOptString key = fmap Text.unpack <$> sectionOpt key +parseServerSettings :: ServerSettings -> Value -> ConfigParser ServerSettings +parseServerSettings = parseSectionsWith parseServerSetting -sectionOptStrings :: Text -> SectionParser (Maybe [String]) -sectionOptStrings key = fmap (fmap Text.unpack) <$> sectionOpt key +parseServerSetting :: ServerSettings -> Text -> Value -> ConfigParser ServerSettings +parseServerSetting ss k v = + case k of + "nick" -> setField ssNick + "username" -> setField ssUser + "realname" -> setField ssReal + "userinfo" -> setField ssUserInfo + "password" -> setFieldMb ssPassword + "sasl-username" -> setFieldMb ssSaslUsername + "sasl-password" -> setFieldMb ssSaslPassword + "hostname" -> setFieldWith ssHostName parseString + "port" -> setFieldWithMb ssPort parseNum + "tls" -> setFieldWith ssTls parseBoolean + "tls-insecure" -> setFieldWith ssTlsInsecure parseBoolean + "tls-client-cert" -> setFieldWithMb ssTlsClientCert parseString + "tls-client-key" -> setFieldWithMb ssTlsClientKey parseString + "server-certificates" -> setFieldWith ssServerCerts (parseList parseString) + "connect-cmds" -> setField ssConnectCmds + "socks-host" -> setFieldWithMb ssSocksHost parseString + "socks-port" -> setFieldWith ssSocksPort parseNum + "chanserv-channels" -> setFieldWith ssChanservChannels (parseList parseIdentifier) + "flood-penalty" -> setField ssFloodPenalty + "flood-threshold" -> setField ssFloodThreshold + "message-hooks" -> setField ssMessageHooks + "name" -> setFieldMb ssName + _ -> failure "Unknown section" + where + setField l = setFieldWith l parseConfig + setFieldMb l = setFieldWithMb l parseConfig -sectionOptNum :: Num a => Text -> SectionParser (Maybe a) -sectionOptNum key = fmap fromInteger <$> sectionOpt key + setFieldWith l p = + do x <- p v + return $! set l x ss -sectionOptIdentifiers :: Text -> SectionParser (Maybe [Identifier]) -sectionOptIdentifiers key = fmap (fmap mkId) <$> sectionOpt key + setFieldWithMb l p = + do x <- p v + return $! set l (Just x) ss -parseServerSettings :: ServerSettings -> Value -> ConfigParser ServerSettings -parseServerSettings !def = - parseSections $ - do _ssNick <- fieldReq ssNick "nick" - _ssUser <- fieldReq ssUser "username" - _ssReal <- fieldReq ssReal "realname" - _ssUserInfo <- fieldReq ssUserInfo "userinfo" - _ssPassword <- field ssPassword "password" - _ssSaslUsername <- field ssSaslUsername "sasl-username" - _ssSaslPassword <- field ssSaslPassword "sasl-password" - _ssHostName <- fieldReq' ssHostName (sectionOptString "hostname") - _ssPort <- field' ssPort (sectionOptNum "port") - _ssTls <- fieldReq' ssTls (boolean "tls") - _ssTlsInsecure <- fieldReq' ssTlsInsecure (boolean "tls-insecure") - _ssTlsClientCert <- field' ssTlsClientCert (sectionOptString "tls-client-cert") - _ssTlsClientKey <- field' ssTlsClientKey (sectionOptString "tls-client-key") - _ssConnectCmds <- fieldReq ssConnectCmds "connect-cmds" - _ssSocksHost <- field' ssSocksHost (sectionOptString "socks-host") - _ssSocksPort <- fieldReq' ssSocksPort (sectionOptNum "socks-port") - _ssServerCerts <- fieldReq' ssServerCerts (sectionOptStrings "server-certificates") - _ssChanservChannels <- fieldReq' ssChanservChannels (sectionOptIdentifiers "chanserv-channels") - _ssFloodPenalty <- fieldReq ssFloodPenalty "flood-penalty" - _ssFloodThreshold <- fieldReq ssFloodThreshold "flood-threshold" - _ssMessageHooks <- fieldReq ssMessageHooks "message-hooks" - return ServerSettings{..} - where - field l key = field' l (sectionOpt key) - fieldReq l key = fieldReq' l (sectionOpt key) +parseBoolean :: Value -> ConfigParser Bool +parseBoolean (Atom "yes") = return True +parseBoolean (Atom "no") = return False +parseBoolean _ = failure "expected yes or no" - fieldReq' l p = fromMaybe (view l def) <$> p +parseList :: (Value -> ConfigParser a) -> Value -> ConfigParser [a] +parseList p (List xs) = traverse p xs +parseList _ _ = failure "expected list" - field' l p = (<|> view l def) <$> p +parseNum :: Num a => Value -> ConfigParser a +parseNum v = fromInteger <$> parseConfig v -boolean :: Text -> SectionParser (Maybe Bool) -boolean key = - do mb <- sectionOpt key - for mb $ \a -> - case atomName a of - "yes" -> return True - "no" -> return False - _ -> liftConfigParser (failure "expected yes or no") +parseIdentifier :: Value -> ConfigParser Identifier +parseIdentifier v = mkId <$> parseConfig v + +parseString :: Value -> ConfigParser String +parseString v = Text.unpack <$> parseConfig v -- | Resolve relative paths starting at the home directory rather than -- the current directory of the client. diff --git a/src/Client/ConnectionState.hs b/src/Client/ConnectionState.hs --- a/src/Client/ConnectionState.hs +++ b/src/Client/ConnectionState.hs @@ -18,8 +18,10 @@ module Client.ConnectionState ( - -- * Connection state type + -- * Connection state ConnectionState(..) + , newConnectionState + , csNick , csChannels , csSocket @@ -39,8 +41,6 @@ , csPingStatus , csMessageHooks - , newConnectionState - -- * User information , UserAndHost(..) @@ -92,33 +92,38 @@ import Irc.UserInfo import LensUtils +-- | State tracked for each IRC connection data ConnectionState = ConnectionState - { _csNetworkId :: !NetworkId - , _csChannels :: !(HashMap Identifier ChannelState) - , _csSocket :: !NetworkConnection - , _csModeTypes :: !ModeTypes - , _csChannelTypes :: ![Char] - , _csTransaction :: !Transaction - , _csModes :: ![Char] - , _csStatusMsg :: ![Char] - , _csSettings :: !ServerSettings - , _csUserInfo :: !UserInfo - , _csUsers :: !(HashMap Identifier UserAndHost) - , _csModeCount :: !Int - , _csNetwork :: !Text - , _csNextPingTime :: !(Maybe UTCTime) - , _csPingStatus :: !PingStatus - , _csMessageHooks :: ![Text] + { _csNetworkId :: !NetworkId -- ^ network connection identifier + , _csChannels :: !(HashMap Identifier ChannelState) -- ^ joined channels + , _csSocket :: !NetworkConnection -- ^ network socket + , _csModeTypes :: !ModeTypes -- ^ channel mode meanings + , _csChannelTypes :: ![Char] -- ^ channel identifier prefixes + , _csTransaction :: !Transaction -- ^ state for multi-message sequences + , _csModes :: ![Char] -- ^ modes for the connected user + , _csStatusMsg :: ![Char] -- ^ modes that prefix statusmsg channel names + , _csSettings :: !ServerSettings -- ^ settings used for this connection + , _csUserInfo :: !UserInfo -- ^ usermask used by the server for this connection + , _csUsers :: !(HashMap Identifier UserAndHost) -- ^ user and hostname for other nicks + , _csModeCount :: !Int -- ^ maximum mode changes per MODE command + , _csNetwork :: !Text -- ^ name of network connection + , _csNextPingTime :: !(Maybe UTCTime) -- ^ time for next ping event + , _csPingStatus :: !PingStatus -- ^ state of ping timer + , _csMessageHooks :: ![Text] -- ^ names of message hooks to apply to this connection } deriving Show -data UserAndHost = UserAndHost {-# UNPACK #-} !Text {-# UNPACK #-} !Text +-- | Pair of username and hostname. Empty strings represent missing information. +data UserAndHost = + UserAndHost {-# UNPACK #-} !Text {-# UNPACK #-} !Text + -- ^ username hostname deriving Show +-- | Status of the ping timer data PingStatus - = PingSent !UTCTime - | PingLatency !Double -- seconds - | PingNever + = PingSent !UTCTime -- ^ ping sent waiting for pong + | PingLatency !Double -- ^ latency in seconds for last ping + | PingNever -- ^ no ping sent deriving Show data Transaction @@ -263,13 +268,10 @@ ZonedTime {- ^ message received -} -> Identifier {- ^ my nickname -} -> ConnectionState -> ([RawIrcMsg], ConnectionState) -doWelcome msgWhen me cs = (reply, update cs) - where - reply = mapMaybe parseRawIrcMsg (view (csSettings . ssConnectCmds) cs) - - update - = set csNick me - . set csNextPingTime (Just $! addUTCTime 30 (zonedTimeToUTC msgWhen)) +doWelcome msgWhen me + = noReply + . set csNick me + . set csNextPingTime (Just $! addUTCTime 30 (zonedTimeToUTC msgWhen)) doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> ConnectionState -> ConnectionState doTopic when user chan topic = diff --git a/src/Client/EditBox.hs b/src/Client/EditBox.hs --- a/src/Client/EditBox.hs +++ b/src/Client/EditBox.hs @@ -15,9 +15,17 @@ -} module Client.EditBox - ( EditBox + ( Line(Line) + , endLine + , HasLine(..) + , Content + , above + , current + , below + , singleLine + , firstLine + , EditBox , content - , pos , tabSeed , delete , backspace @@ -25,7 +33,8 @@ , end , killHome , killEnd - , killWord + , killWordBackward + , killWordForward , paste , left , right @@ -39,12 +48,199 @@ , success ) where -import Control.Lens +import Control.Lens hiding (below) import Data.Char +data Line = Line + { _pos :: !Int + , _text :: !String + } + deriving (Read, Show) + +makeClassy ''Line + +emptyLine :: Line +emptyLine = Line 0 "" + +endLine :: String -> Line +endLine s = Line (length s) s + +-- | Zipper-ish view of the multi-line content of an 'EditBox'. +-- Lines 'above' the 'current' are stored in reverse order. +data Content = Content + { _above :: ![String] + , _current :: !Line + , _below :: ![String] + } + deriving (Read, Show) + +makeLenses ''Content + +instance HasLine Content where + line = current + +-- | Default 'Content' value +noContent :: Content +noContent = Content [] emptyLine [] + +-- | Single line 'Content'. +singleLine :: Line -> Content +singleLine l = Content [] l [] + +-- | Shifts the first line off of the 'Content', yielding the +-- text of the line and the rest of the content. +shift :: Content -> (String, Content) +shift (Content [] l []) = (view text l, noContent) +shift (Content a@(_:_) l b) = (last a, Content (init a) l b) +shift (Content [] l (b:bs)) = (view text l, Content [] (endLine b) bs) + +firstLine :: Content -> String +firstLine (Content a c _) = head (reverse a ++ [_text c]) + +jumpLeft :: Content -> Content +jumpLeft c + | view pos c == 0 + , a:as <- view above c + = over below (cons $ view text c) + . set text a + . set above as + $ c + | otherwise = set pos 0 c + +jumpRight :: Content -> Content +jumpRight c + | view pos c == len + , b:bs <- view below c + = over above (cons $ view text c) + . set text b + . set pos len + . set below bs + $ c + | otherwise = set pos len c + where len = views text length c + +-- Move the cursor left, across lines if necessary. +left :: Content -> Content +left c + | n > 0 + = over (current.pos) (subtract 1) c + + | n == 0 + , a:as <- view above c + = over below (cons s) + . set above as + . set current (endLine a) + $ c + + | otherwise = c + where Line n s = view current c + +-- Move the cursor right, across lines if necessary. +right :: Content -> Content +right c + | n < length s + = over (current.pos) (+1) c + + | n == length s + , b:bs <- view below c + = over above (cons s) + . set below bs + . set current (Line 0 b) + $ c + + | otherwise = c + where Line n s = view current c + +-- | Move the cursor left to the previous word boundary. +leftWord :: Content -> Content +leftWord c + | n == 0 + = case view above c of + [] -> c + (a:as) -> leftWord + . set current (endLine a) + . over below (cons txt) + . set above as + $ c + | otherwise + = case search of + [] -> set (current.pos) 0 c + (i,_):_ -> set (current.pos) (i+1) c + where + Line n txt = view current c + search = dropWhile (isAlphaNum . snd) + $ dropWhile (not . isAlphaNum . snd) + $ reverse + $ take n + $ zip [0..] + $ txt + +-- | Move the cursor right to the next word boundary. +rightWord :: Content -> Content +rightWord c + | n == length txt + = case view below c of + [] -> c + (b:bs) -> rightWord + . set current (endLine b) + . over above (cons txt) + . set below bs + $ c + | otherwise + = case search of + [] -> set (current.pos) (length txt) c + (i,_):_ -> set (current.pos) i c + where + Line n txt = view current c + search = dropWhile (isAlphaNum . snd) + $ dropWhile (not . isAlphaNum . snd) + $ drop n + $ zip [0..] + $ txt + +-- | Delete the character before the cursor. +backspace :: Content -> Content +backspace c + | n == 0 + = case view above c of + [] -> c + a:as -> set above as + . set current (Line (length a) (a ++ s)) + $ c + + | (preS, postS) <- splitAt (n-1) s + = set current (Line (n-1) (preS ++ drop 1 postS)) c + where + Line n s = view current c + +-- | Delete the character after/under the cursor. +delete :: Content -> Content +delete c + | n == length s + = case view below c of + [] -> c + b:bs -> set below bs + . set current (Line n (s ++ b)) + $ c + + | (preS, postS) <- splitAt n s + = set current (Line n (preS ++ drop 1 postS)) c + where + Line n s = view current c + +insertString :: String -> Content -> Content +insertString ins c = case push (view above c) (preS ++ l) ls of + (newAbove, newCurrent) -> set above newAbove . set current newCurrent $ c + where + l:ls = lines (ins ++ "\n") + Line n txt = view current c + (preS, postS) = splitAt n txt + + push stk x [] = (stk, Line (length x) (x ++ postS)) + push stk x (y:ys) = push (x:stk) y ys + data EditBox = EditBox - { _content :: !String - , _pos :: !Int + { _content :: !Content , _history :: ![String] , _historyPos :: !Int , _yankBuffer :: !(String) @@ -54,17 +250,19 @@ makeLenses ''EditBox --- | Default 'EditBox value +-- | Default 'EditBox' value empty :: EditBox empty = EditBox - { _content = "" - , _pos = 0 + { _content = noContent , _history = [] , _historyPos = -1 , _yankBuffer = "" , _tabSeed = Nothing } +instance HasLine EditBox where + line = content . line + -- | Sets the given string to the yank buffer unless the string is empty. updateYankBuffer :: String -> EditBox -> EditBox updateYankBuffer str @@ -72,23 +270,24 @@ | otherwise = set yankBuffer str -- | Indicate that the contents of the text box were successfully used --- by the program. This clears the contents and cursor and updates the --- history. +-- by the program. This clears the first line of the contents and updates +-- the history. success :: EditBox -> EditBox success e - = over history (cons (view content e)) - $ set content "" + = over history (cons sent) + $ set content c $ set tabSeed Nothing $ set historyPos (-1) - $ set pos 0 e + $ e + where + (sent, c) = shift $ view content e -- | Update the editbox to reflect the earlier element in the history. earlier :: EditBox -> Maybe EditBox earlier e = do let i = view historyPos e + 1 x <- preview (history . ix i) e - return $ set content x - $ set pos (length x) + return $ set content (singleLine . endLine $ x) $ set historyPos i e -- | Update the editbox to reflect the later element in the history. @@ -96,84 +295,76 @@ later e | i < 0 = Nothing | i == 0 = Just - $ set content "" - $ set pos 0 + $ set content noContent $ set historyPos (-1) e | otherwise = do x <- preview (history . ix (i-1)) e - return $ set content x - $ set pos (length x) + return $ set content (singleLine . endLine $ x) $ set historyPos (i-1) e where i = view historyPos e --- Remove a character without the associated checks --- internal helper for backspace and delete -removeImpl :: EditBox -> EditBox -removeImpl e - = set content (a++drop 1 b) - $ set tabSeed Nothing - $ over pos (min (views content length e - 1)) e - where - (a,b) = splitAt (view pos e) (view content e) - --- | Delete the character after the cursor. -delete :: EditBox -> EditBox -delete e - | view pos e < views content length e = removeImpl e - | otherwise = e - --- | Delete the character before the cursor. -backspace :: EditBox -> EditBox -backspace e - | view pos e > 0 = removeImpl (left e) - | otherwise = e - -- | Jump the cursor to the beginning of the input. home :: EditBox -> EditBox home = set tabSeed Nothing - . set pos 0 + . over content jumpLeft -- | Jump the cursor to the end of the input. end :: EditBox -> EditBox -end e +end = set tabSeed Nothing - $ set pos (views content length e) e + . over content jumpRight -- | Delete all text from the cursor to the end and store it in -- the yank buffer. killEnd :: EditBox -> EditBox killEnd e - = set content keep + | null kill + = case view (content.below) e of + [] -> e + b:bs -> set (content.below) bs + $ updateYankBuffer b e + | otherwise + = set (content.current) (endLine keep) $ updateYankBuffer kill e where - (keep,kill) = splitAt (view pos e) (view content e) + Line n txt = view (content.current) e + (keep,kill) = splitAt n txt -- | Delete all text from the cursor to the beginning and store it in -- the yank buffer. killHome :: EditBox -> EditBox killHome e - = set content keep - $ set pos 0 + | null kill + = case view (content.above) e of + [] -> e + a:as -> set (content.above) as + . set tabSeed Nothing + $ updateYankBuffer a e + + | otherwise + = set (content.current) (Line 0 keep) $ set tabSeed Nothing $ updateYankBuffer kill e where - (kill,keep) = splitAt (view pos e) (view content e) + Line n txt = view (content.current) e + (kill,keep) = splitAt n txt -- | Insert the yank buffer at the cursor. paste :: EditBox -> EditBox -paste e = insertString (view yankBuffer e) e +paste e = over content (insertString (view yankBuffer e)) e -- | Kill the content from the cursor back to the previous word boundary. -- When @yank@ is set the yank buffer will be updated. -killWord :: Bool {- ^ yank -} -> EditBox -> EditBox -killWord yank e - = set pos (length l') - $ sometimesUpdateYank - $ set content (l'++r) e +killWordBackward :: Bool {- ^ yank -} -> EditBox -> EditBox +killWordBackward yank e + = sometimesUpdateYank + $ set (content.current) (Line (length l') (l'++r)) + $ e where - (l,r) = splitAt (view pos e) (view content e) + Line n txt = view (content.current) e + (l,r) = splitAt n txt (sp,l1) = span isSpace (reverse l) (wd,l2) = break isSpace l1 l' = reverse l2 @@ -183,51 +374,26 @@ | yank = updateYankBuffer yanked | otherwise = id +-- | Kill the content from the curser forward to the next word boundary. +-- When @yank@ is set the yank buffer will be updated +killWordForward :: Bool {- ^ yank -} -> EditBox -> EditBox +killWordForward yank e + = sometimesUpdateYank + $ set (content.current) (Line (length l) (l++r2)) + $ e + where + Line n txt = view (content.current) e + (l,r) = splitAt n txt + (sp,r1) = span isSpace r + (wd,r2) = break isSpace r1 + yanked = sp++wd + + sometimesUpdateYank + | yank = updateYankBuffer yanked + | otherwise = id + -- | Insert a character at the cursor and advance the cursor. insert :: Char -> EditBox -> EditBox insert c = set tabSeed Nothing - . insertString [c] - --- | Insert a string at the cursor and advance the cursor. -insertString :: String -> EditBox -> EditBox -insertString str e - = over pos (+length str) - $ set content (a ++ str ++ b) e - where - (a,b) = splitAt (view pos e) (view content e) - --- | Move the cursor left. -left :: EditBox -> EditBox -left = over pos (max 0 . subtract 1) - --- | Move the cursor right. -right :: EditBox -> EditBox -right e = over pos (min (views content length e) . (+1)) e - --- | Move the cursor left to the previous word boundary. -leftWord :: EditBox -> EditBox -leftWord e = - case search of - [] -> set pos 0 e - (i,_):_ -> set pos (i+1) e - where - search = dropWhile (isAlphaNum . snd) - $ dropWhile (not . isAlphaNum . snd) - $ reverse - $ take (view pos e) - $ zip [0..] - $ view content e - --- | Move the cursor right to the next word boundary. -rightWord :: EditBox -> EditBox -rightWord e = - case search of - [] -> set pos (views content length e) e - (i,_):_ -> set pos i e - where - search = dropWhile (isAlphaNum . snd) - $ dropWhile (not . isAlphaNum . snd) - $ drop (view pos e) - $ zip [0..] - $ view content e + . over content (insertString [c]) diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -16,6 +16,7 @@ ) where import Client.Commands +import Client.Configuration import Client.ConnectionState import qualified Client.EditBox as Edit import Client.Hook @@ -23,6 +24,7 @@ import Client.Image import Client.Message import Client.NetworkConnection +import Client.ServerSettings import Client.State import Client.Window import Control.Concurrent.STM @@ -36,9 +38,11 @@ import qualified Data.Map as Map import Data.Maybe import Data.Ord +import Data.Text (Text) import qualified Data.Text as Text import Data.Time import Graphics.Vty +import Irc.Codes import Irc.Message import Irc.RawIrcMsg @@ -175,7 +179,8 @@ case stateHook (cookIrcMsg raw) of Nothing -> eventLoop st -- Message ignored Just irc -> do traverse_ (sendMsg cs) replies - eventLoop st' + st2 <- clientResponse time' irc cs st1 + eventLoop st2 where -- state with message recorded recSt = case viewHook irc of @@ -191,8 +196,48 @@ } -- record messages *before* applying the changes - (replies, st') = applyMessageToClientState time irc networkId cs recSt + (replies, st1) = applyMessageToClientState time irc networkId cs recSt +-- | Client-level responses to specific IRC messages. +-- This is in contrast to the connection state tracking logic in +-- "Client.ConnectionState" +clientResponse :: ZonedTime -> IrcMsg -> ConnectionState -> ClientState -> IO ClientState +clientResponse now irc cs st = + case irc of + Reply RPL_WELCOME _ -> + foldM + (processConnectCmd now cs) + st + (view (csSettings . ssConnectCmds) cs) + _ -> return st + +processConnectCmd :: + ZonedTime {- ^ now -} -> + ConnectionState {- ^ current network -} -> + ClientState -> + Text {- ^ command -} -> + IO ClientState +processConnectCmd now cs st0 cmdTxt = + do res <- executeCommand Nothing (Text.unpack cmdTxt) st0 + return $! case res of + CommandFailure st -> reportConnectCmdError now cs cmdTxt st + CommandSuccess st -> st + CommandQuit -> st0 -- not supported + + +reportConnectCmdError :: + ZonedTime {- ^ now -} -> + ConnectionState {- ^ current network -} -> + Text {- ^ bad command -} -> + ClientState -> + ClientState +reportConnectCmdError now cs cmdTxt = + recordNetworkMessage ClientMessage + { _msgTime = now + , _msgNetwork = view csNetwork cs + , _msgBody = ErrorBody ("Bad connect-cmd: " ++ Text.unpack cmdTxt) + } + -- | Find the ZNC provided server time computeEffectiveTime :: ZonedTime -> [TagEntry] -> ZonedTime computeEffectiveTime time tags = fromMaybe time zncTime @@ -225,29 +270,31 @@ (w,h) <- displayBounds (outputIface vty) eventLoop $ set clientWidth w $ set clientHeight h st + EvPaste s -> eventLoop (over (clientTextBox . Edit.content) (Edit.insertString s) st) _ -> eventLoop st -- | Map keyboard inputs to actions in the client doKey :: Key -> [Modifier] -> ClientState -> IO () doKey key modifier st = - let changeInput f = eventLoop (over clientTextBox f st) in + let changeEditor f = eventLoop (over clientTextBox f st) + changeContent f = eventLoop (over (clientTextBox . Edit.content) f st) in case modifier of [MCtrl] -> case key of - KChar 'd' -> changeInput Edit.delete - KChar 'a' -> changeInput Edit.home - KChar 'e' -> changeInput Edit.end - KChar 'u' -> changeInput Edit.killHome - KChar 'k' -> changeInput Edit.killEnd - KChar 'y' -> changeInput Edit.paste - KChar 'w' -> changeInput (Edit.killWord True) - KChar 'b' -> changeInput (Edit.insert '\^B') - KChar 'c' -> changeInput (Edit.insert '\^C') - KChar ']' -> changeInput (Edit.insert '\^]') - KChar '_' -> changeInput (Edit.insert '\^_') - KChar 'o' -> changeInput (Edit.insert '\^O') - KChar 'v' -> changeInput (Edit.insert '\^V') + KChar 'd' -> changeContent Edit.delete + KChar 'a' -> changeEditor Edit.home + KChar 'e' -> changeEditor Edit.end + KChar 'u' -> changeEditor Edit.killHome + KChar 'k' -> changeEditor Edit.killEnd + KChar 'y' -> changeEditor Edit.paste + KChar 'w' -> changeEditor (Edit.killWordBackward True) + KChar 'b' -> changeEditor (Edit.insert '\^B') + KChar 'c' -> changeEditor (Edit.insert '\^C') + KChar ']' -> changeEditor (Edit.insert '\^]') + KChar '_' -> changeEditor (Edit.insert '\^_') + KChar 'o' -> changeEditor (Edit.insert '\^O') + KChar 'v' -> changeEditor (Edit.insert '\^V') KChar 'p' -> eventLoop (retreatFocus st) KChar 'n' -> eventLoop (advanceFocus st) KChar 'l' -> refresh (view clientVty st) >> eventLoop st @@ -255,32 +302,35 @@ [MMeta] -> case key of - KBS -> changeInput (Edit.killWord True) - KChar 'b' -> changeInput Edit.leftWord - KChar 'f' -> changeInput Edit.rightWord + KEnter -> changeEditor (Edit.insert '\^J') + KBS -> changeEditor (Edit.killWordBackward True) + KChar 'd' -> changeEditor (Edit.killWordForward True) + KChar 'b' -> changeContent Edit.leftWord + KChar 'f' -> changeContent Edit.rightWord KChar 'a' -> eventLoop (jumpToActivity st) - KChar c | Just i <- elemIndex c windowNames -> + KChar c | let names = view (clientConfig . configWindowNames) st + , Just i <- Text.findIndex (==c) names -> eventLoop (jumpFocus i st) _ -> eventLoop st [] -> -- no modifier case key of - KBS -> changeInput Edit.backspace - KDel -> changeInput Edit.delete - KLeft -> changeInput Edit.left - KRight -> changeInput Edit.right - KHome -> changeInput Edit.home - KEnd -> changeInput Edit.end - KUp -> changeInput $ \ed -> fromMaybe ed $ Edit.earlier ed - KDown -> changeInput $ \ed -> fromMaybe ed $ Edit.later ed + KBS -> changeContent Edit.backspace + KDel -> changeContent Edit.delete + KLeft -> changeContent Edit.left + KRight -> changeContent Edit.right + KHome -> changeEditor Edit.home + KEnd -> changeEditor Edit.end + KUp -> changeEditor $ \ed -> fromMaybe ed $ Edit.earlier ed + KDown -> changeEditor $ \ed -> fromMaybe ed $ Edit.later ed KPageUp -> eventLoop (pageUp st) KPageDown -> eventLoop (pageDown st) - KEnter -> doCommandResult =<< execute st - KBackTab -> doCommandResult =<< tabCompletion True st - KChar '\t' -> doCommandResult =<< tabCompletion False st + KEnter -> doCommandResult True =<< executeInput st + KBackTab -> doCommandResult False =<< tabCompletion True st + KChar '\t' -> doCommandResult False =<< tabCompletion False st - KChar c -> changeInput (Edit.insert c) + KChar c -> changeEditor (Edit.insert c) KFun 2 -> eventLoop (over clientDetailView not st) _ -> eventLoop st @@ -288,11 +338,15 @@ -- | Process 'CommandResult' by either running the 'eventLoop' with the -- new 'ClientState' or returning. -doCommandResult :: CommandResult -> IO () -doCommandResult res = +doCommandResult :: Bool -> CommandResult -> IO () +doCommandResult clearOnSuccess res = case res of - CommandQuit -> return () - CommandContinue st -> eventLoop st + CommandQuit -> return () + CommandSuccess st -> eventLoop (if clearOnSuccess then consumeInput st else st) + CommandFailure st -> eventLoop (set clientBell True st) + +executeInput :: ClientState -> IO CommandResult +executeInput st = execute (clientFirstLine st) st -- | Scroll the current buffer to show older messages pageUp :: ClientState -> ClientState diff --git a/src/Client/Hook.hs b/src/Client/Hook.hs --- a/src/Client/Hook.hs +++ b/src/Client/Hook.hs @@ -23,6 +23,7 @@ ) where import Control.Lens +import Data.Semigroup import Data.Text import Irc.Message @@ -35,10 +36,13 @@ | OmitMessage | RemapMessage IrcMsg +instance Semigroup MessageResult where + PassMessage <> r = r + l <> _ = l + instance Monoid MessageResult where mempty = PassMessage - PassMessage `mappend` r = r - l `mappend` _ = l + mappend = (<>) maybeFromResult :: IrcMsg -> MessageResult -> Maybe IrcMsg maybeFromResult original PassMessage = Just original diff --git a/src/Client/Hook/Znc/Buffextras.hs b/src/Client/Hook/Znc/Buffextras.hs --- a/src/Client/Hook/Znc/Buffextras.hs +++ b/src/Client/Hook/Znc/Buffextras.hs @@ -17,15 +17,15 @@ ( buffextrasHook ) where -import Data.Attoparsec.Text as P -import Data.Monoid -import Data.Text as Text hiding (head) +import Control.Monad +import Data.Attoparsec.Text as P +import Data.Text as Text hiding (head) -import Client.Hook -import Irc.Identifier -import Irc.Message -import Irc.RawIrcMsg -import Irc.UserInfo +import Client.Hook +import Irc.Identifier +import Irc.Message +import Irc.RawIrcMsg +import Irc.UserInfo -- | Map ZNC's buffextras messages to native client messages. -- Set debugging to pass through buffextras messages that @@ -38,7 +38,7 @@ IrcMsg -> MessageResult remap debug (Privmsg user chan msg) | userNick user == mkId "*buffextras" - , Right newMsg <- parseOnly (mainParser chan) msg + , Right newMsg <- parseOnly (prefixedParser chan) msg = RemapMessage newMsg | userNick user == mkId "*buffextras" @@ -47,37 +47,34 @@ remap _ _ = PassMessage --- Note: the "Server set mode:" message is intentionally not handled at this --- time. -mainParser :: Identifier -> Parser IrcMsg -mainParser = prefixedParser - prefixedParser :: Identifier -> Parser IrcMsg prefixedParser chan = do pfx <- prefixParser - choice [ Join pfx chan <$ sepMsg "joined" - , Quit pfx <$> parseLeave "quit" - , Part pfx chan <$> parseLeave "parted" - , Nick pfx . mkId <$ sepMsg "is now known as" <*> simpleTokenParser - , Mode pfx chan <$ sepMsg "set mode:" <*> allTokens - ] + choice + [ Join pfx chan <$ skipToken "joined" + , Quit pfx . filterEmpty <$ skipToken "quit with message:" <*> parseReason + , Part pfx chan . filterEmpty <$ skipToken "parted with message:" <*> parseReason + , Nick pfx . mkId <$ skipToken "is now known as" <*> simpleTokenParser + , Mode pfx chan <$ skipToken "set mode:" <*> allTokens + , Kick pfx chan <$ skipToken "kicked" <*> parseId <* skipToken "Reason:" <*> parseReason + ] allTokens :: Parser [Text] allTokens = Text.words <$> P.takeText -sepMsg :: Text -> Parser () -sepMsg m = P.skipWhile (==' ') *> string m *> P.skipWhile (==' ') +skipToken :: Text -> Parser () +skipToken m = string m *> P.skipWhile (==' ') --- Parts and quits have a similar format. -parseLeave - :: Text - -> Parser (Maybe Text) -parseLeave small = - do sepMsg (small <> " with message:") - P.skipWhile (==' ') - filterEmpty <$ char '[' <*> P.takeWhile (/=']') <* char ']' +parseId :: Parser Identifier +parseId = mkId <$> simpleTokenParser filterEmpty :: Text -> Maybe Text -filterEmpty tx - | Text.null tx = Nothing - | otherwise = Just tx +filterEmpty txt + | Text.null txt = Nothing + | otherwise = Just txt + +parseReason :: Parser Text +parseReason = + do txt <- char '[' *> P.takeText + guard (not (Text.null txt) && Text.last txt == ']') + return (Text.init txt) diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -39,21 +39,21 @@ clientPicture :: ClientState -> (Picture, ClientState) clientPicture st = (pic, st') where - (img, st') = clientImage st + (pos, img, st') = clientImage st pic0 = picForImage img pic = pic0 { picCursor = cursor } - cursor = Cursor (min (view clientWidth st - 1) - (view (clientTextBox . Edit.pos) st+1)) + cursor = Cursor (min (view clientWidth st - 1) (pos+1)) (view clientHeight st - 1) -clientImage :: ClientState -> (Image, ClientState) -clientImage st = (img, st') +clientImage :: ClientState -> (Int, Image, ClientState) +clientImage st = (pos, img, st') where (mp, st') = messagePane st + (pos, tbImg) = textboxImage st' img = vertCat [ mp , horizDividerImage st' - , textboxImage st' + , tbImg ] messagePaneImages :: ClientState -> [Image] @@ -196,7 +196,8 @@ string defAttr "]" where windows = views clientWindows Map.elems st - winNames = windowNames ++ repeat '?' + windowNames = view (clientConfig . configWindowNames) st + winNames = Text.unpack windowNames ++ repeat '?' indicators = aux (zip winNames windows) aux [] = [] aux ((i,w):ws) @@ -242,10 +243,12 @@ pal = view (clientConfig . configPalette) st focus = view clientFocus st + windowNames = view (clientConfig . configWindowNames) st + windowName = case Map.lookupIndex focus (view clientWindows st) of - Nothing -> '?' - Just i -> (windowNames ++ repeat '?') !! i + Just i | i < Text.length windowNames -> Text.index windowNames i + _ -> '?' subfocusName = case view clientSubfocus st of @@ -286,14 +289,12 @@ where (modes,args) = unzip (Map.toList modeMap) _ -> emptyImage -textboxImage :: ClientState -> Image +textboxImage :: ClientState -> (Int, Image) textboxImage st - = applyCrop - $ beginning <|> content <|> ending + = (pos, applyCrop $ beginning <|> content <|> ending) where - pos = view (clientTextBox . Edit.pos) st width = view clientWidth st - content = parseIrcTextExplicit (Text.pack (view (clientTextBox . Edit.content) st)) + (pos, content) = views (clientTextBox . Edit.content) renderContent st applyCrop | 1+pos < width = cropRight width | otherwise = cropLeft width . cropRight (pos+2) @@ -301,6 +302,21 @@ attr = view (clientConfig . configPalette . palTextBox) st beginning = char attr '^' ending = char attr '$' + +renderContent :: Edit.Content -> (Int, Image) +renderContent c = (imgPos, wholeImg) + where + as = view Edit.above c + bs = view Edit.below c + cur = view Edit.current c + + imgPos = view Edit.pos cur + length as + sum (map length as) + + renderLine l = parseIrcTextExplicit $ Text.pack l + + curImg = views Edit.text renderLine cur + rightImg = foldl (\i b -> i <|> renderLine ('\n':b)) curImg bs + wholeImg = foldl (\i a -> renderLine (a ++ "\n") <|> i) rightImg as latencyImage :: ClientState -> Image latencyImage st diff --git a/src/Client/Image/ChannelInfo.hs b/src/Client/Image/ChannelInfo.hs --- a/src/Client/Image/ChannelInfo.hs +++ b/src/Client/Image/ChannelInfo.hs @@ -29,7 +29,10 @@ import Irc.Identifier -- | Render the lines used in a channel mask list -channelInfoImages :: NetworkName -> Identifier -> ClientState -> [Image] +channelInfoImages :: + NetworkName {- ^ network -} -> + Identifier {- ^ channel -} -> + ClientState -> [Image] channelInfoImages network channelId st | Just cs <- preview (clientConnection network) st diff --git a/src/Client/Image/MaskList.hs b/src/Client/Image/MaskList.hs --- a/src/Client/Image/MaskList.hs +++ b/src/Client/Image/MaskList.hs @@ -31,8 +31,8 @@ -- | Render the lines used in a channel mask list maskListImages :: Char {- ^ Mask mode -} -> - NetworkName {- ^ Focused network -} -> - Identifier {- ^ Focused channel -} -> + NetworkName {- ^ network -} -> + Identifier {- ^ channel -} -> ClientState -> [Image] maskListImages mode network channel st = case mbEntries of diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -14,7 +14,6 @@ , RenderMode(..) , defaultRenderParams , msgImage - , detailedMsgImage , metadataImg , ignoreImage , quietIdentifier @@ -63,23 +62,28 @@ -- | Construct a message given the time the message was received and its -- render parameters. msgImage :: + RenderMode -> ZonedTime {- ^ time of message -} -> MessageRendererParams -> MessageBody -> Image -msgImage when params body = horizCat - [ timeImage (rendPalette params) when +msgImage rm when params body = horizCat + [ renderTime rm (rendPalette params) when , statusMsgImage (rendStatusMsg params) - , bodyImage NormalRender params body + , bodyImage rm params body ] --- | Construct a message given the time the message was received and its --- render parameters using a detailed view. -detailedMsgImage :: ZonedTime -> MessageRendererParams -> MessageBody -> Image -detailedMsgImage when params body = horizCat - [ datetimeImage (rendPalette params) when - , statusMsgImage (rendStatusMsg params) - , bodyImage DetailedRender params body +errorImage :: + MessageRendererParams -> + String {- ^ error message -} -> + Image +errorImage params txt = horizCat + [ text' (view palError (rendPalette params)) "Error " + , string defAttr txt ] +renderTime :: RenderMode -> Palette -> ZonedTime -> Image +renderTime DetailedRender = datetimeImage +renderTime NormalRender = timeImage + -- | Render the sigils for a restricted message. statusMsgImage :: [Char] {- ^ sigils -} -> Image statusMsgImage modes @@ -98,9 +102,9 @@ MessageBody -> Image bodyImage rm params body = case body of - IrcBody irc -> ircLineImage rm params irc - ErrorBody ex -> string defAttr ("Exception: " ++ show ex) - ExitBody -> string defAttr "Thread finished" + IrcBody irc -> ircLineImage rm params irc + ErrorBody txt -> errorImage params txt + ExitBody -> string defAttr "Thread finished" -- | Render a 'ZonedTime' as time using quiet attributes -- @@ -315,11 +319,11 @@ Identifier -> Image coloredIdentifier palette myNicks ident = - text' (withForeColor defAttr color) (idText ident) + text' color (idText ident) where color - | ident `elem` myNicks = red - | otherwise = v Vector.! i + | ident `elem` myNicks = _palSelf palette + | otherwise = withForeColor defAttr $ v Vector.! i v = _palNicks palette i = hash ident `mod` Vector.length v diff --git a/src/Client/Image/Palette.hs b/src/Client/Image/Palette.hs --- a/src/Client/Image/Palette.hs +++ b/src/Client/Image/Palette.hs @@ -13,6 +13,7 @@ -- * Palette type Palette(..) , palNicks + , palSelf , palTime , palMeta , palSigil @@ -36,6 +37,7 @@ -- | Color palette used for rendering the client UI data Palette = Palette { _palNicks :: Vector Color -- ^ colors for highlighting nicknames + , _palSelf :: Attr -- ^ color of our own nickname(s) , _palTime :: Attr -- ^ color of message timestamps , _palMeta :: Attr -- ^ color of coalesced metadata , _palSigil :: Attr -- ^ color of sigils (e.g. @+) @@ -55,6 +57,7 @@ defaultPalette :: Palette defaultPalette = Palette { _palNicks = defaultNickColorPalette + , _palSelf = withForeColor defAttr red , _palTime = withForeColor defAttr brightBlack , _palMeta = withForeColor defAttr brightBlack , _palSigil = withForeColor defAttr cyan diff --git a/src/Client/ServerSettings.hs b/src/Client/ServerSettings.hs --- a/src/Client/ServerSettings.hs +++ b/src/Client/ServerSettings.hs @@ -37,6 +37,7 @@ , ssFloodPenalty , ssFloodThreshold , ssMessageHooks + , ssName -- * Load function , loadDefaultServerSettings @@ -75,6 +76,7 @@ , _ssFloodPenalty :: !Rational -- ^ Flood limiter penalty (seconds) , _ssFloodThreshold :: !Rational -- ^ Flood limited threshold (seconds) , _ssMessageHooks :: ![Text] -- ^ Initial message hooks + , _ssName :: !(Maybe Text) -- ^ The name referencing the server in commands } deriving Show @@ -110,4 +112,5 @@ , _ssFloodPenalty = 2 -- RFC 1459 defaults , _ssFloodThreshold = 10 , _ssMessageHooks = [] + , _ssName = Nothing } diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -40,7 +40,8 @@ , consumeInput , currentCompletionList , ircIgnorable - , clientInput + , clientFirstLine + , clientLine , abortNetwork , addConnection , removeNetwork @@ -60,7 +61,6 @@ , changeSubfocus , advanceFocus , retreatFocus - , windowNames ) where @@ -169,9 +169,13 @@ Just i -> clientConnections (ix i f) st -- | Full content of the edit box -clientInput :: ClientState -> String -clientInput = view (clientTextBox . Edit.content) +clientFirstLine :: ClientState -> String +clientFirstLine = views (clientTextBox . Edit.content) Edit.firstLine +-- | The line under the cursor in the edit box. +clientLine :: ClientState -> (Int, String) +clientLine = views (clientTextBox . Edit.line) (\(Edit.Line n t) -> (n, t)) + -- | Return the network associated with the current focus focusNetwork :: ClientFocus -> Maybe NetworkName focusNetwork Unfocused = Nothing @@ -371,8 +375,8 @@ toWindowLine params msg = WindowLine { _wlBody = view msgBody msg , _wlText = views msgBody msgText msg - , _wlImage = force $ msgImage (view msgTime msg) params (view msgBody msg) - , _wlFullImage = force $ detailedMsgImage (view msgTime msg) params (view msgBody msg) + , _wlImage = force $ msgImage NormalRender (view msgTime msg) params (view msgBody msg) + , _wlFullImage = force $ msgImage DetailedRender (view msgTime msg) params (view msgBody msg) } toWindowLine' :: Palette -> ClientMessage -> WindowLine @@ -455,12 +459,9 @@ = set clientScroll 0 . set clientSubfocus focus -windowNames :: [Char] -windowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP" - clientMatcher :: ClientState -> Text -> Bool clientMatcher st = - case break (==' ') (clientInput st) of + case break (==' ') (clientFirstLine st) of ("/grep" ,_:reStr) -> go [] reStr ("/grepi",_:reStr) -> go [ICU.CaseInsensitive] reStr _ -> const True @@ -488,11 +489,11 @@ addConnection :: Text -> ClientState -> IO ClientState addConnection network st = - do let host = Text.unpack network - defSettings = (view (clientConfig . configDefaults) st) - { _ssHostName = host } + do let defSettings = (view (clientConfig . configDefaults) st) + { _ssName = Just network } + settings = fromMaybe defSettings - (view (clientConfig . configServers . at host) st) + $ preview (clientConfig . configServers . ix network) st let (i,st') = st & clientNextConnectionId <+~ 1 c <- createConnection diff --git a/src/Client/WordCompletion.hs b/src/Client/WordCompletion.hs --- a/src/Client/WordCompletion.hs +++ b/src/Client/WordCompletion.hs @@ -19,7 +19,7 @@ import Data.Char import Data.List import Control.Lens -import Client.EditBox as Edit +import qualified Client.EditBox as Edit import Control.Monad -- | Perform word completion on a text box. @@ -50,15 +50,15 @@ _ -> do next <- tabSearch isReversed cur cur vals - Just $ set tabSeed (Just current) + Just $ set Edit.tabSeed (Just current) $ replaceWith leadingCase (idString next) box replaceWith :: (String -> String) -> String -> Edit.EditBox -> Edit.EditBox replaceWith leadingCase str box = - let box1 = Edit.killWord False box + let box1 = Edit.killWordBackward False box str1 | view Edit.pos box1 == 0 = leadingCase str | otherwise = str - in Edit.insertString str1 box1 + in over Edit.content (Edit.insertString str1) box1 idString :: Identifier -> String idString = Text.unpack . idText @@ -69,7 +69,8 @@ $ takeWhile (not . isSpace) $ dropWhile (\x -> x==' ' || x==':') $ reverse - $ take (view Edit.pos box) (view Edit.content box) + $ take n txt + where Edit.Line n txt = view (Edit.content . Edit.current) box class Prefix a where isPrefix :: a -> a -> Bool instance Prefix Identifier where isPrefix = idPrefix diff --git a/src/Irc/Codes.hs b/src/Irc/Codes.hs deleted file mode 100644 --- a/src/Irc/Codes.hs +++ /dev/null @@ -1,854 +0,0 @@ -{-# Language PatternSynonyms, OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} - -{-| -Module : Irc.Codes -Description : Helpers for interpreting IRC reply codes -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module defines support for working with IRC's numeric reply -codes. Pattern synonyms are provided for each of the possible IRC reply codes. - -Reply code information was extracted from https://www.alien.net.au/irc/irc2numerics.html - --} - -module Irc.Codes where - -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Data.Text (Text) -import qualified Data.Text as Text - --- | Type of numeric reply codes -newtype ReplyCode = ReplyCode Word - -instance Show ReplyCode where - showsPrec p (ReplyCode x) = showsPrec p x - --- | Categories for reply codes -data ReplyType - = ClientServerReply -- ^ 0-99 Messages between client and server - | CommandReply -- ^ 200-399 Responses to commands - | ErrorReply -- ^ 200-399 Errors - | UnknownReply -- ^ Uncategorized - -pattern RPL_WELCOME = ReplyCode 001 -pattern RPL_YOURHOST = ReplyCode 002 -pattern RPL_CREATED = ReplyCode 003 -pattern RPL_MYINFO = ReplyCode 004 -pattern RPL_ISUPPORT = ReplyCode 005 -pattern RPL_SNOMASK = ReplyCode 008 -pattern RPL_STATMEMTOT = ReplyCode 009 -pattern RPL_REDIR = ReplyCode 010 -pattern RPL_YOURCOOKIE = ReplyCode 014 -pattern RPL_MAP = ReplyCode 015 -pattern RPL_MAPEND = ReplyCode 017 -pattern RPL_YOURID = ReplyCode 042 -pattern RPL_SAVENICK = ReplyCode 043 -pattern RPL_ATTEMPTINGJUNC = ReplyCode 050 -pattern RPL_ATTEMPTINGREROUTE = ReplyCode 051 -pattern RPL_TRACELINK = ReplyCode 200 -pattern RPL_TRACECONNECTING = ReplyCode 201 -pattern RPL_TRACEHANDSHAKE = ReplyCode 202 -pattern RPL_TRACEUNKNOWN = ReplyCode 203 -pattern RPL_TRACEOPERATOR = ReplyCode 204 -pattern RPL_TRACEUSER = ReplyCode 205 -pattern RPL_TRACESERVER = ReplyCode 206 -pattern RPL_TRACESERVICE = ReplyCode 207 -pattern RPL_TRACENEWTYPE = ReplyCode 208 -pattern RPL_TRACECLASS = ReplyCode 209 -pattern RPL_TRACERECONNECT = ReplyCode 210 -pattern RPL_STATS = ReplyCode 210 -pattern RPL_STATSLINKINFO = ReplyCode 211 -pattern RPL_STATSCOMMANDS = ReplyCode 212 -pattern RPL_STATSCLINE = ReplyCode 213 -pattern RPL_STATSNLINE = ReplyCode 214 -pattern RPL_STATSILINE = ReplyCode 215 -pattern RPL_STATSKLINE = ReplyCode 216 -pattern RPL_STATSQLINE = ReplyCode 217 -pattern RPL_STATSYLINE = ReplyCode 218 -pattern RPL_ENDOFSTATS = ReplyCode 219 -pattern RPL_STATSPLINE = ReplyCode 220 -pattern RPL_UMODEIS = ReplyCode 221 -pattern RPL_SQLINE_NICK = ReplyCode 222 -pattern RPL_STATSDLINE = ReplyCode 225 -pattern RPL_STATSZLINE = ReplyCode 225 -pattern RPL_STATSCOUNT = ReplyCode 226 -pattern RPL_SERVICEINFO = ReplyCode 231 -pattern RPL_ENDOFSERVICES = ReplyCode 232 -pattern RPL_SERVICE = ReplyCode 233 -pattern RPL_SERVLIST = ReplyCode 234 -pattern RPL_SERVLISTEND = ReplyCode 235 -pattern RPL_STATSVERBOSE = ReplyCode 236 -pattern RPL_STATSIAUTH = ReplyCode 239 -pattern RPL_STATSLLINE = ReplyCode 241 -pattern RPL_STATSUPTIME = ReplyCode 242 -pattern RPL_STATSOLINE = ReplyCode 243 -pattern RPL_STATSHLINE = ReplyCode 244 -pattern RPL_STATSSLINE = ReplyCode 245 -pattern RPL_STATSPING = ReplyCode 246 -pattern RPL_STATSXLINE = ReplyCode 247 -pattern RPL_STATSULINE = ReplyCode 248 -pattern RPL_STATSDEBUG = ReplyCode 249 -pattern RPL_STATSCONN = ReplyCode 250 -pattern RPL_LUSERCLIENT = ReplyCode 251 -pattern RPL_LUSEROP = ReplyCode 252 -pattern RPL_LUSERUNKNOWN = ReplyCode 253 -pattern RPL_LUSERCHANNELS = ReplyCode 254 -pattern RPL_LUSERME = ReplyCode 255 -pattern RPL_ADMINME = ReplyCode 256 -pattern RPL_ADMINLOC1 = ReplyCode 257 -pattern RPL_ADMINLOC2 = ReplyCode 258 -pattern RPL_ADMINEMAIL = ReplyCode 259 -pattern RPL_TRACELOG = ReplyCode 261 -pattern RPL_ENDOFTRACE = ReplyCode 262 -pattern RPL_LOAD2HI = ReplyCode 263 -pattern RPL_LOCALUSERS = ReplyCode 265 -pattern RPL_GLOBALUSERS = ReplyCode 266 -pattern RPL_START_NETSTAT = ReplyCode 267 -pattern RPL_NETSTAT = ReplyCode 268 -pattern RPL_END_NETSTAT = ReplyCode 269 -pattern RPL_PRIVS = ReplyCode 270 -pattern RPL_SILELIST = ReplyCode 271 -pattern RPL_ENDOFSILELIST = ReplyCode 272 -pattern RPL_NOTIFY = ReplyCode 273 -pattern RPL_ENDNOTIFY = ReplyCode 274 -pattern RPL_STATSDELTA = ReplyCode 274 -pattern RPL_WHOISCERTFP = ReplyCode 276 -pattern RPL_VCHANLIST = ReplyCode 277 -pattern RPL_VCHANHELP = ReplyCode 278 -pattern RPL_GLIST = ReplyCode 280 -pattern RPL_ACCEPTLIST = ReplyCode 281 -pattern RPL_ENDOFACCEPT = ReplyCode 282 -pattern RPL_ENDOFJUPELIST = ReplyCode 283 -pattern RPL_FEATURE = ReplyCode 284 -pattern RPL_DATASTR = ReplyCode 290 -pattern RPL_END_CHANINFO = ReplyCode 299 -pattern RPL_NONE = ReplyCode 300 -pattern RPL_AWAY = ReplyCode 301 -pattern RPL_USERHOST = ReplyCode 302 -pattern RPL_ISON = ReplyCode 303 -pattern RPL_TEXT = ReplyCode 304 -pattern RPL_UNAWAY = ReplyCode 305 -pattern RPL_NOWAWAY = ReplyCode 306 -pattern RPL_WHOISREGNICK = ReplyCode 307 -pattern RPL_SUSERHOST = ReplyCode 307 -pattern RPL_NOTIFYACTION = ReplyCode 308 -pattern RPL_WHOISADMIN = ReplyCode 308 -pattern RPL_NICKTRACE = ReplyCode 309 -pattern RPL_WHOISSADMIN = ReplyCode 309 -pattern RPL_WHOISHELPER = ReplyCode 309 -pattern RPL_WHOISUSER = ReplyCode 311 -pattern RPL_WHOISSERVER = ReplyCode 312 -pattern RPL_WHOISOPERATOR = ReplyCode 313 -pattern RPL_WHOWASUSER = ReplyCode 314 -pattern RPL_ENDOFWHO = ReplyCode 315 -pattern RPL_WHOISCHANOP = ReplyCode 316 -pattern RPL_WHOISIDLE = ReplyCode 317 -pattern RPL_ENDOFWHOIS = ReplyCode 318 -pattern RPL_WHOISCHANNELS = ReplyCode 319 -pattern RPL_WHOISSPECIAL = ReplyCode 320 -pattern RPL_LISTSTART = ReplyCode 321 -pattern RPL_LIST = ReplyCode 322 -pattern RPL_LISTEND = ReplyCode 323 -pattern RPL_CHANNELMODEIS = ReplyCode 324 -pattern RPL_CHANNELMLOCKIS = ReplyCode 325 -pattern RPL_NOCHANPASS = ReplyCode 326 -pattern RPL_CHPASSUNKNOWN = ReplyCode 327 -pattern RPL_CHANNEL_URL = ReplyCode 328 -pattern RPL_CREATIONTIME = ReplyCode 329 -pattern RPL_WHOWAS_TIME = ReplyCode 330 -pattern RPL_WHOISACCOUNT = ReplyCode 330 -pattern RPL_NOTOPIC = ReplyCode 331 -pattern RPL_TOPIC = ReplyCode 332 -pattern RPL_TOPICWHOTIME = ReplyCode 333 -pattern RPL_LISTUSAGE = ReplyCode 334 -pattern RPL_COMMANDSYNTAX = ReplyCode 334 -pattern RPL_LISTSYNTAX = ReplyCode 334 -pattern RPL_WHOISACTUALLY = ReplyCode 338 -pattern RPL_BADCHANPASS = ReplyCode 339 -pattern RPL_INVITING = ReplyCode 341 -pattern RPL_SUMMONING = ReplyCode 342 -pattern RPL_INVITED = ReplyCode 345 -pattern RPL_INVEXLIST = ReplyCode 346 -pattern RPL_ENDOFINVEXLIST = ReplyCode 347 -pattern RPL_EXCEPTLIST = ReplyCode 348 -pattern RPL_ENDOFEXCEPTLIST = ReplyCode 349 -pattern RPL_VERSION = ReplyCode 351 -pattern RPL_WHOREPLY = ReplyCode 352 -pattern RPL_NAMREPLY = ReplyCode 353 -pattern RPL_WHOSPCRPL = ReplyCode 354 -pattern RPL_NAMREPLY_ = ReplyCode 355 -pattern RPL_WHOWASREAL = ReplyCode 360 -pattern RPL_KILLDONE = ReplyCode 361 -pattern RPL_CLOSING = ReplyCode 362 -pattern RPL_CLOSEEND = ReplyCode 363 -pattern RPL_LINKS = ReplyCode 364 -pattern RPL_ENDOFLINKS = ReplyCode 365 -pattern RPL_ENDOFNAMES = ReplyCode 366 -pattern RPL_BANLIST = ReplyCode 367 -pattern RPL_ENDOFBANLIST = ReplyCode 368 -pattern RPL_ENDOFWHOWAS = ReplyCode 369 -pattern RPL_INFO = ReplyCode 371 -pattern RPL_MOTD = ReplyCode 372 -pattern RPL_INFOSTART = ReplyCode 373 -pattern RPL_ENDOFINFO = ReplyCode 374 -pattern RPL_MOTDSTART = ReplyCode 375 -pattern RPL_ENDOFMOTD = ReplyCode 376 -pattern RPL_WHOISHOST = ReplyCode 378 -pattern RPL_KICKLINKED = ReplyCode 379 -pattern RPL_YOUREOPER = ReplyCode 381 -pattern RPL_REHASHING = ReplyCode 382 -pattern RPL_YOURESERVICE = ReplyCode 383 -pattern RPL_MYPORTIS = ReplyCode 384 -pattern RPL_NOTOPERANYMORE = ReplyCode 385 -pattern RPL_RSACHALLENGE = ReplyCode 386 -pattern RPL_TIME = ReplyCode 391 -pattern RPL_USERSSTART = ReplyCode 392 -pattern RPL_USERS = ReplyCode 393 -pattern RPL_ENDOFUSERS = ReplyCode 394 -pattern RPL_NOUSERS = ReplyCode 395 -pattern RPL_HOSTHIDDEN = ReplyCode 396 -pattern ERR_UNKNOWNERROR = ReplyCode 400 -pattern ERR_NOSUCHNICK = ReplyCode 401 -pattern ERR_NOSUCHSERVER = ReplyCode 402 -pattern ERR_NOSUCHCHANNEL = ReplyCode 403 -pattern ERR_CANNOTSENDTOCHAN = ReplyCode 404 -pattern ERR_TOOMANYCHANNELS = ReplyCode 405 -pattern ERR_WASNOSUCHNICK = ReplyCode 406 -pattern ERR_TOOMANYTARGETS = ReplyCode 407 -pattern ERR_NOORIGIN = ReplyCode 409 -pattern ERR_NORECIPIENT = ReplyCode 411 -pattern ERR_NOTEXTTOSEND = ReplyCode 412 -pattern ERR_NOTOPLEVEL = ReplyCode 413 -pattern ERR_WILDTOPLEVEL = ReplyCode 414 -pattern ERR_BADMASK = ReplyCode 415 -pattern ERR_TOOMANYMATCHES = ReplyCode 416 -pattern ERR_LENGTHTRUNCATED = ReplyCode 419 -pattern ERR_UNKNOWNCOMMAND = ReplyCode 421 -pattern ERR_NOMOTD = ReplyCode 422 -pattern ERR_NOADMININFO = ReplyCode 423 -pattern ERR_FILEERROR = ReplyCode 424 -pattern ERR_NOOPERMOTD = ReplyCode 425 -pattern ERR_TOOMANYAWAY = ReplyCode 429 -pattern ERR_EVENTNICKCHANGE = ReplyCode 430 -pattern ERR_NONICKNAMEGIVEN = ReplyCode 431 -pattern ERR_ERRONEUSNICKNAME = ReplyCode 432 -pattern ERR_NICKNAMEINUSE = ReplyCode 433 -pattern ERR_SERVICENAMEINUSE = ReplyCode 434 -pattern ERR_NORULES = ReplyCode 434 -pattern ERR_BANNICKCHANGE = ReplyCode 435 -pattern ERR_NICKCOLLISION = ReplyCode 436 -pattern ERR_UNAVAILRESOURCE = ReplyCode 437 -pattern ERR_NICKTOOFAST = ReplyCode 438 -pattern ERR_TARGETTOOFAST = ReplyCode 439 -pattern ERR_SERVICESDOWN = ReplyCode 440 -pattern ERR_USERNOTINCHANNEL = ReplyCode 441 -pattern ERR_NOTONCHANNEL = ReplyCode 442 -pattern ERR_USERONCHANNEL = ReplyCode 443 -pattern ERR_NOLOGIN = ReplyCode 444 -pattern ERR_SUMMONDISABLED = ReplyCode 445 -pattern ERR_USERSDISABLED = ReplyCode 446 -pattern ERR_NONICKCHANGE = ReplyCode 447 -pattern ERR_NOTIMPLEMENTED = ReplyCode 449 -pattern ERR_NOTREGISTERED = ReplyCode 451 -pattern ERR_IDCOLLISION = ReplyCode 452 -pattern ERR_NICKLOST = ReplyCode 453 -pattern ERR_HOSTILENAME = ReplyCode 455 -pattern ERR_ACCEPTFULL = ReplyCode 456 -pattern ERR_ACCEPTEXIST = ReplyCode 457 -pattern ERR_ACCEPTNOT = ReplyCode 458 -pattern ERR_NOHIDING = ReplyCode 459 -pattern ERR_NOTFORHALFOPS = ReplyCode 460 -pattern ERR_NEEDMOREPARAMS = ReplyCode 461 -pattern ERR_ALREADYREGISTERED = ReplyCode 462 -pattern ERR_NOPERMFORHOST = ReplyCode 463 -pattern ERR_PASSWDMISMATCH = ReplyCode 464 -pattern ERR_YOUREBANNEDCREEP = ReplyCode 465 -pattern ERR_YOUWILLBEBANNED = ReplyCode 466 -pattern ERR_KEYSET = ReplyCode 467 -pattern ERR_INVALIDUSERNAME = ReplyCode 468 -pattern ERR_ONLYSERVERSCANCHANGE = ReplyCode 468 -pattern ERR_LINKSET = ReplyCode 469 -pattern ERR_LINKCHANNEL = ReplyCode 470 -pattern ERR_CHANNELISFULL = ReplyCode 471 -pattern ERR_UNKNOWNMODE = ReplyCode 472 -pattern ERR_INVITEONLYCHAN = ReplyCode 473 -pattern ERR_BANNEDFROMCHAN = ReplyCode 474 -pattern ERR_BADCHANNELKEY = ReplyCode 475 -pattern ERR_BADCHANMASK = ReplyCode 476 -pattern ERR_NEEDREGGEDNICK = ReplyCode 477 -pattern ERR_BANLISTFULL = ReplyCode 478 -pattern ERR_BADCHANNAME = ReplyCode 479 -pattern ERR_THROTTLE = ReplyCode 480 -pattern ERR_NOPRIVILEGES = ReplyCode 481 -pattern ERR_CHANOPRIVSNEEDED = ReplyCode 482 -pattern ERR_CANTKILLSERVER = ReplyCode 483 -pattern ERR_ISCHANSERVICE = ReplyCode 484 -pattern ERR_BANNEDNICK = ReplyCode 485 -pattern ERR_NONONREG = ReplyCode 486 -pattern ERR_TSLESSCHAN = ReplyCode 488 -pattern ERR_VOICENEEDED = ReplyCode 489 -pattern ERR_NOOPERHOST = ReplyCode 491 -pattern ERR_NOSERVICEHOST = ReplyCode 492 -pattern ERR_NOFEATURE = ReplyCode 493 -pattern ERR_OWNMODE = ReplyCode 494 -pattern ERR_BADLOGTYPE = ReplyCode 495 -pattern ERR_BADLOGSYS = ReplyCode 496 -pattern ERR_BADLOGVALUE = ReplyCode 497 -pattern ERR_ISOPERLCHAN = ReplyCode 498 -pattern ERR_CHANOWNPRIVNEEDED = ReplyCode 499 -pattern ERR_UMODEUNKNOWNFLAG = ReplyCode 501 -pattern ERR_USERSDONTMATCH = ReplyCode 502 -pattern ERR_GHOSTEDCLIENT = ReplyCode 503 -pattern ERR_USERNOTONSERV = ReplyCode 504 -pattern ERR_SILELISTFULL = ReplyCode 511 -pattern ERR_TOOMANYWATCH = ReplyCode 512 -pattern ERR_WRONGPONG = ReplyCode 513 -pattern ERR_BADEXPIRE = ReplyCode 515 -pattern ERR_DONTCHEAT = ReplyCode 516 -pattern ERR_DISABLED = ReplyCode 517 -pattern ERR_NOINVITE = ReplyCode 518 -pattern ERR_LONGMASK = ReplyCode 518 -pattern ERR_ADMONLY = ReplyCode 519 -pattern ERR_TOOMANYUSERS = ReplyCode 519 -pattern ERR_OPERONLY = ReplyCode 520 -pattern ERR_MASKTOOWIDE = ReplyCode 520 -pattern ERR_WHOTRUNC = ReplyCode 520 -pattern ERR_LISTSYNTAX = ReplyCode 521 -pattern ERR_WHOSYNTAX = ReplyCode 522 -pattern ERR_WHOLIMEXCEED = ReplyCode 523 -pattern ERR_HELPNOTFOUND = ReplyCode 524 -pattern ERR_REMOTEPFX = ReplyCode 525 -pattern ERR_PFXUNROUTABLE = ReplyCode 526 -pattern ERR_BADHOSTMASK = ReplyCode 550 -pattern ERR_HOSTUNAVAIL = ReplyCode 551 -pattern ERR_USINGSLINE = ReplyCode 552 -pattern ERR_STATSSLINE = ReplyCode 553 -pattern RPL_LOGON = ReplyCode 600 -pattern RPL_LOGOFF = ReplyCode 601 -pattern RPL_WATCHOFF = ReplyCode 602 -pattern RPL_WATCHSTAT = ReplyCode 603 -pattern RPL_NOWON = ReplyCode 604 -pattern RPL_NOWOFF = ReplyCode 605 -pattern RPL_WATCHLIST = ReplyCode 606 -pattern RPL_ENDOFWATCHLIST = ReplyCode 607 -pattern RPL_WATCHCLEAR = ReplyCode 608 -pattern RPL_ISOPER = ReplyCode 610 -pattern RPL_ISLOCOP = ReplyCode 611 -pattern RPL_ISNOTOPER = ReplyCode 612 -pattern RPL_ENDOFISOPER = ReplyCode 613 -pattern RPL_DCCSTATUS = ReplyCode 617 -pattern RPL_DCCLIST = ReplyCode 618 -pattern RPL_ENDOFDCCLIST = ReplyCode 619 -pattern RPL_WHOWASHOST = ReplyCode 619 -pattern RPL_DCCINFO = ReplyCode 620 -pattern RPL_RULES = ReplyCode 621 -pattern RPL_ENDOFO = ReplyCode 626 -pattern RPL_SETTINGS = ReplyCode 630 -pattern RPL_ENDOFSETTINGS = ReplyCode 631 -pattern RPL_DUMPING = ReplyCode 640 -pattern RPL_DUMPRPL = ReplyCode 641 -pattern RPL_EODUMP = ReplyCode 642 -pattern RPL_TRACEROUTE_HOP = ReplyCode 660 -pattern RPL_TRACEROUTE_START = ReplyCode 661 -pattern RPL_MODECHANGEWARN = ReplyCode 662 -pattern RPL_CHANREDIR = ReplyCode 663 -pattern RPL_SERVMODEIS = ReplyCode 664 -pattern RPL_OTHERUMODEIS = ReplyCode 665 -pattern RPL_ENDOF_GENERIC = ReplyCode 666 -pattern RPL_WHOWASDETAILS = ReplyCode 670 -pattern RPL_WHOISSECURE = ReplyCode 671 -pattern RPL_UNKNOWNMODES = ReplyCode 672 -pattern RPL_CANNOTSETMODES = ReplyCode 673 -pattern RPL_LUSERSTAFF = ReplyCode 678 -pattern RPL_TIMEONSERVERIS = ReplyCode 679 -pattern RPL_NETWORKS = ReplyCode 682 -pattern RPL_YOURLANGUAGEIS = ReplyCode 687 -pattern RPL_LANGUAGE = ReplyCode 688 -pattern RPL_WHOISSTAFF = ReplyCode 689 -pattern RPL_WHOISLANGUAGE = ReplyCode 690 -pattern RPL_MODLIST = ReplyCode 702 -pattern RPL_ENDOFMODLIST = ReplyCode 703 -pattern RPL_HELPSTART = ReplyCode 704 -pattern RPL_HELPTXT = ReplyCode 705 -pattern RPL_ENDOFHELP = ReplyCode 706 -pattern ERR_TARGCHANGE = ReplyCode 707 -pattern RPL_ETRACEFULL = ReplyCode 708 -pattern RPL_ETRACE = ReplyCode 709 -pattern RPL_KNOCK = ReplyCode 710 -pattern RPL_KNOCKDLVR = ReplyCode 711 -pattern ERR_TOOMANYKNOCK = ReplyCode 712 -pattern ERR_CHANOPEN = ReplyCode 713 -pattern ERR_KNOCKONCHAN = ReplyCode 714 -pattern ERR_KNOCKDISABLED = ReplyCode 715 -pattern RPL_TARGUMODEG = ReplyCode 716 -pattern RPL_TARGNOTIFY = ReplyCode 717 -pattern RPL_UMODEGMSG = ReplyCode 718 -pattern RPL_OMOTDSTART = ReplyCode 720 -pattern RPL_OMOTD = ReplyCode 721 -pattern RPL_ENDOFOMOTD = ReplyCode 722 -pattern ERR_NOPRIVS = ReplyCode 723 -pattern RPL_TESTMASK = ReplyCode 724 -pattern RPL_TESTLINE = ReplyCode 725 -pattern RPL_NOTESTLINE = ReplyCode 726 -pattern RPL_QUIETLIST = ReplyCode 728 -pattern RPL_ENDOFQUIETLIST = ReplyCode 729 -pattern RPL_MONONLINE = ReplyCode 730 -pattern RPL_MONOFFLINE = ReplyCode 731 -pattern RPL_MONLIST = ReplyCode 732 -pattern RPL_ENDOFMONLIST = ReplyCode 733 -pattern ERR_MONLISTFULL = ReplyCode 734 -pattern RPL_RSACHALLENGE2 = ReplyCode 740 -pattern RPL_ENDOFRSACHALLENGE2 = ReplyCode 741 -pattern ERR_MLOCKRESTRICTED = ReplyCode 742 -pattern RPL_SCANMATCHED = ReplyCode 750 -pattern RPL_SCANUMODES = ReplyCode 751 -pattern RPL_XINFO = ReplyCode 771 -pattern RPL_XINFOSTART = ReplyCode 773 -pattern RPL_XINFOEND = ReplyCode 774 -pattern RPL_LOGGEDIN = ReplyCode 900 -pattern RPL_LOGGEDOUT = ReplyCode 901 -pattern RPL_NICKLOCKED = ReplyCode 902 -pattern RPL_SASLSUCCESS = ReplyCode 903 -pattern RPL_SASLFAIL = ReplyCode 904 -pattern RPL_SASLTOOLONG = ReplyCode 905 -pattern RPL_SASLABORTED = ReplyCode 906 -pattern RPL_SASLALREADY = ReplyCode 907 -pattern RPL_SASLMECHS = ReplyCode 908 -pattern ERR_CANNOTDOCOMMAND = ReplyCode 972 -pattern ERR_CANNOTCHANGEUMODE = ReplyCode 973 -pattern ERR_CANNOTCHANGECHANMODE = ReplyCode 974 -pattern ERR_CANNOTCHANGESERVERMODE = ReplyCode 975 -pattern ERR_CANNOTSENDTONICK = ReplyCode 976 -pattern ERR_UNKNOWNSERVERMODE = ReplyCode 977 -pattern ERR_SERVERMODELOCK = ReplyCode 979 -pattern ERR_BADCHARENCODING = ReplyCode 980 -pattern ERR_TOOMANYLANGUAGES = ReplyCode 981 -pattern ERR_NOLANGUAGE = ReplyCode 982 -pattern ERR_TEXTTOOSHORT = ReplyCode 983 -pattern ERR_NUMERIC_ERR = ReplyCode 999 - -data ReplyCodeInfo = ReplyCodeInfo - { replyCodeType :: !ReplyType - , replyCodeText :: !Text - } - -replyCodeInfo :: ReplyCode -> ReplyCodeInfo -replyCodeInfo (ReplyCode w) = - case replyCodeInfoTable Vector.!? i of - Nothing -> defaultReplyCodeInfo i - Just info -> info - where - i = fromIntegral w - -defaultReplyCodeInfo :: Int -> ReplyCodeInfo -defaultReplyCodeInfo = ReplyCodeInfo UnknownReply . Text.pack . show - -replyCodeInfoTable :: Vector ReplyCodeInfo -replyCodeInfoTable - = Vector.accumulate - (\_def new -> new) - (Vector.generate 1000 defaultReplyCodeInfo) - $ fmap (\(ReplyCode code,info) -> (fromIntegral code, info)) - $ Vector.fromList - [ (RPL_WELCOME , ReplyCodeInfo ClientServerReply "WELCOME") - , (RPL_YOURHOST , ReplyCodeInfo ClientServerReply "YOURHOST") - , (RPL_CREATED , ReplyCodeInfo ClientServerReply "CREATED") - , (RPL_MYINFO , ReplyCodeInfo ClientServerReply "MYINFO") - , (RPL_ISUPPORT , ReplyCodeInfo ClientServerReply "ISUPPORT") - , (RPL_SNOMASK , ReplyCodeInfo ClientServerReply "SNOMASK") - , (RPL_STATMEMTOT , ReplyCodeInfo ClientServerReply "STATMEMTOT") - , (RPL_REDIR , ReplyCodeInfo ClientServerReply "REDIR") - , (RPL_YOURCOOKIE , ReplyCodeInfo ClientServerReply "YOURCOOKIE") - , (RPL_MAP , ReplyCodeInfo ClientServerReply "MAP") - , (RPL_MAPEND , ReplyCodeInfo ClientServerReply "MAPEND") - , (RPL_YOURID , ReplyCodeInfo ClientServerReply "YOURID") - , (RPL_SAVENICK , ReplyCodeInfo ClientServerReply "SAVENICK") - , (RPL_ATTEMPTINGJUNC , ReplyCodeInfo ClientServerReply "ATTEMPTINGJUNC") - , (RPL_ATTEMPTINGREROUTE , ReplyCodeInfo ClientServerReply "ATTEMPTINGREROUTE") - , (RPL_TRACELINK , ReplyCodeInfo CommandReply "TRACELINK") - , (RPL_TRACECONNECTING , ReplyCodeInfo CommandReply "TRACECONNECTING") - , (RPL_TRACEHANDSHAKE , ReplyCodeInfo CommandReply "TRACEHANDSHAKE") - , (RPL_TRACEUNKNOWN , ReplyCodeInfo CommandReply "TRACEUNKNOWN") - , (RPL_TRACEOPERATOR , ReplyCodeInfo CommandReply "TRACEOPERATOR") - , (RPL_TRACEUSER , ReplyCodeInfo CommandReply "TRACEUSER") - , (RPL_TRACESERVER , ReplyCodeInfo CommandReply "TRACESERVER") - , (RPL_TRACESERVICE , ReplyCodeInfo CommandReply "TRACESERVICE") - , (RPL_TRACENEWTYPE , ReplyCodeInfo CommandReply "TRACENEWTYPE") - , (RPL_TRACECLASS , ReplyCodeInfo CommandReply "TRACECLASS") - , (RPL_TRACERECONNECT , ReplyCodeInfo CommandReply "TRACERECONNECT") - , (RPL_STATS , ReplyCodeInfo CommandReply "STATS") - , (RPL_STATSLINKINFO , ReplyCodeInfo CommandReply "STATSLINKINFO") - , (RPL_STATSCOMMANDS , ReplyCodeInfo CommandReply "STATSCOMMANDS") - , (RPL_STATSCLINE , ReplyCodeInfo CommandReply "STATSCLINE") - , (RPL_STATSNLINE , ReplyCodeInfo CommandReply "STATSNLINE") - , (RPL_STATSILINE , ReplyCodeInfo CommandReply "STATSILINE") - , (RPL_STATSKLINE , ReplyCodeInfo CommandReply "STATSKLINE") - , (RPL_STATSQLINE , ReplyCodeInfo CommandReply "STATSQLINE") - , (RPL_STATSYLINE , ReplyCodeInfo CommandReply "STATSYLINE") - , (RPL_ENDOFSTATS , ReplyCodeInfo CommandReply "ENDOFSTATS") - , (RPL_STATSPLINE , ReplyCodeInfo CommandReply "STATSPLINE") - , (RPL_UMODEIS , ReplyCodeInfo CommandReply "UMODEIS") - , (RPL_SQLINE_NICK , ReplyCodeInfo CommandReply "SQLINE_NICK") - , (RPL_STATSDLINE , ReplyCodeInfo CommandReply "STATSDLINE") - , (RPL_STATSZLINE , ReplyCodeInfo CommandReply "STATSZLINE") - , (RPL_STATSCOUNT , ReplyCodeInfo CommandReply "STATSCOUNT") - , (RPL_SERVICEINFO , ReplyCodeInfo CommandReply "SERVICEINFO") - , (RPL_ENDOFSERVICES , ReplyCodeInfo CommandReply "ENDOFSERVICES") - , (RPL_SERVICE , ReplyCodeInfo CommandReply "SERVICE") - , (RPL_SERVLIST , ReplyCodeInfo CommandReply "SERVLIST") - , (RPL_SERVLISTEND , ReplyCodeInfo CommandReply "SERVLISTEND") - , (RPL_STATSVERBOSE , ReplyCodeInfo CommandReply "STATSVERBOSE") - , (RPL_STATSIAUTH , ReplyCodeInfo CommandReply "STATSIAUTH") - , (RPL_STATSLLINE , ReplyCodeInfo CommandReply "STATSLLINE") - , (RPL_STATSUPTIME , ReplyCodeInfo CommandReply "STATSUPTIME") - , (RPL_STATSOLINE , ReplyCodeInfo CommandReply "STATSOLINE") - , (RPL_STATSHLINE , ReplyCodeInfo CommandReply "STATSHLINE") - , (RPL_STATSSLINE , ReplyCodeInfo CommandReply "STATSSLINE") - , (RPL_STATSPING , ReplyCodeInfo CommandReply "STATSPING") - , (RPL_STATSXLINE , ReplyCodeInfo CommandReply "STATSXLINE") - , (RPL_STATSULINE , ReplyCodeInfo CommandReply "STATSULINE") - , (RPL_STATSDEBUG , ReplyCodeInfo CommandReply "STATSDEBUG") - , (RPL_STATSCONN , ReplyCodeInfo CommandReply "STATSCONN") - , (RPL_LUSERCLIENT , ReplyCodeInfo CommandReply "LUSERCLIENT") - , (RPL_LUSEROP , ReplyCodeInfo CommandReply "LUSEROP") - , (RPL_LUSERUNKNOWN , ReplyCodeInfo CommandReply "LUSERUNKNOWN") - , (RPL_LUSERCHANNELS , ReplyCodeInfo CommandReply "LUSERCHANNELS") - , (RPL_LUSERME , ReplyCodeInfo CommandReply "LUSERME") - , (RPL_ADMINME , ReplyCodeInfo CommandReply "ADMINME") - , (RPL_ADMINLOC1 , ReplyCodeInfo CommandReply "ADMINLOC1") - , (RPL_ADMINLOC2 , ReplyCodeInfo CommandReply "ADMINLOC2") - , (RPL_ADMINEMAIL , ReplyCodeInfo CommandReply "ADMINEMAIL") - , (RPL_TRACELOG , ReplyCodeInfo CommandReply "TRACELOG") - , (RPL_ENDOFTRACE , ReplyCodeInfo CommandReply "ENDOFTRACE") - , (RPL_LOAD2HI , ReplyCodeInfo CommandReply "LOAD2HI") - , (RPL_LOCALUSERS , ReplyCodeInfo CommandReply "LOCALUSERS") - , (RPL_GLOBALUSERS , ReplyCodeInfo CommandReply "GLOBALUSERS") - , (RPL_START_NETSTAT , ReplyCodeInfo CommandReply "START_NETSTAT") - , (RPL_NETSTAT , ReplyCodeInfo CommandReply "NETSTAT") - , (RPL_END_NETSTAT , ReplyCodeInfo CommandReply "END_NETSTAT") - , (RPL_PRIVS , ReplyCodeInfo CommandReply "PRIVS") - , (RPL_SILELIST , ReplyCodeInfo CommandReply "SILELIST") - , (RPL_ENDOFSILELIST , ReplyCodeInfo CommandReply "ENDOFSILELIST") - , (RPL_NOTIFY , ReplyCodeInfo CommandReply "NOTIFY") - , (RPL_ENDNOTIFY , ReplyCodeInfo CommandReply "ENDNOTIFY") - , (RPL_STATSDELTA , ReplyCodeInfo CommandReply "STATSDELTA") - , (RPL_WHOISCERTFP , ReplyCodeInfo CommandReply "WHOISCERTFP") - , (RPL_VCHANLIST , ReplyCodeInfo CommandReply "VCHANLIST") - , (RPL_VCHANHELP , ReplyCodeInfo CommandReply "VCHANHELP") - , (RPL_GLIST , ReplyCodeInfo CommandReply "GLIST") - , (RPL_ACCEPTLIST , ReplyCodeInfo CommandReply "ACCEPTLIST") - , (RPL_ENDOFACCEPT , ReplyCodeInfo CommandReply "ENDOFACCEPT") - , (RPL_ENDOFJUPELIST , ReplyCodeInfo CommandReply "ENDOFJUPELIST") - , (RPL_FEATURE , ReplyCodeInfo CommandReply "FEATURE") - , (RPL_DATASTR , ReplyCodeInfo CommandReply "DATASTR") - , (RPL_END_CHANINFO , ReplyCodeInfo CommandReply "END_CHANINFO") - , (RPL_NONE , ReplyCodeInfo CommandReply "NONE") - , (RPL_AWAY , ReplyCodeInfo CommandReply "AWAY") - , (RPL_USERHOST , ReplyCodeInfo CommandReply "USERHOST") - , (RPL_ISON , ReplyCodeInfo CommandReply "ISON") - , (RPL_TEXT , ReplyCodeInfo CommandReply "TEXT") - , (RPL_UNAWAY , ReplyCodeInfo CommandReply "UNAWAY") - , (RPL_NOWAWAY , ReplyCodeInfo CommandReply "NOWAWAY") - , (RPL_WHOISREGNICK , ReplyCodeInfo CommandReply "WHOISREGNICK") - , (RPL_SUSERHOST , ReplyCodeInfo CommandReply "SUSERHOST") - , (RPL_NOTIFYACTION , ReplyCodeInfo CommandReply "NOTIFYACTION") - , (RPL_WHOISADMIN , ReplyCodeInfo CommandReply "WHOISADMIN") - , (RPL_NICKTRACE , ReplyCodeInfo CommandReply "NICKTRACE") - , (RPL_WHOISSADMIN , ReplyCodeInfo CommandReply "WHOISSADMIN") - , (RPL_WHOISHELPER , ReplyCodeInfo CommandReply "WHOISHELPER") - , (RPL_WHOISUSER , ReplyCodeInfo CommandReply "WHOISUSER") - , (RPL_WHOISSERVER , ReplyCodeInfo CommandReply "WHOISSERVER") - , (RPL_WHOISOPERATOR , ReplyCodeInfo CommandReply "WHOISOPERATOR") - , (RPL_WHOWASUSER , ReplyCodeInfo CommandReply "WHOWASUSER") - , (RPL_ENDOFWHO , ReplyCodeInfo CommandReply "ENDOFWHO") - , (RPL_WHOISCHANOP , ReplyCodeInfo CommandReply "WHOISCHANOP") - , (RPL_WHOISIDLE , ReplyCodeInfo CommandReply "WHOISIDLE") - , (RPL_ENDOFWHOIS , ReplyCodeInfo CommandReply "ENDOFWHOIS") - , (RPL_WHOISCHANNELS , ReplyCodeInfo CommandReply "WHOISCHANNELS") - , (RPL_WHOISSPECIAL , ReplyCodeInfo CommandReply "WHOISSPECIAL") - , (RPL_LISTSTART , ReplyCodeInfo CommandReply "LISTSTART") - , (RPL_LIST , ReplyCodeInfo CommandReply "LIST") - , (RPL_LISTEND , ReplyCodeInfo CommandReply "LISTEND") - , (RPL_CHANNELMODEIS , ReplyCodeInfo CommandReply "CHANNELMODEIS") - , (RPL_CHANNELMLOCKIS , ReplyCodeInfo CommandReply "CHANNELMLOCKIS") - , (RPL_NOCHANPASS , ReplyCodeInfo CommandReply "NOCHANPASS") - , (RPL_CHPASSUNKNOWN , ReplyCodeInfo CommandReply "CHPASSUNKNOWN") - , (RPL_CHANNEL_URL , ReplyCodeInfo CommandReply "CHANNEL_URL") - , (RPL_CREATIONTIME , ReplyCodeInfo CommandReply "CREATIONTIME") - , (RPL_WHOWAS_TIME , ReplyCodeInfo CommandReply "WHOWAS_TIME") - , (RPL_WHOISACCOUNT , ReplyCodeInfo CommandReply "WHOISACCOUNT") - , (RPL_NOTOPIC , ReplyCodeInfo CommandReply "NOTOPIC") - , (RPL_TOPIC , ReplyCodeInfo CommandReply "TOPIC") - , (RPL_TOPICWHOTIME , ReplyCodeInfo CommandReply "TOPICWHOTIME") - , (RPL_LISTUSAGE , ReplyCodeInfo CommandReply "LISTUSAGE") - , (RPL_COMMANDSYNTAX , ReplyCodeInfo CommandReply "COMMANDSYNTAX") - , (RPL_LISTSYNTAX , ReplyCodeInfo CommandReply "LISTSYNTAX") - , (RPL_WHOISACTUALLY , ReplyCodeInfo CommandReply "WHOISACTUALLY") - , (RPL_BADCHANPASS , ReplyCodeInfo CommandReply "BADCHANPASS") - , (RPL_INVITING , ReplyCodeInfo CommandReply "INVITING") - , (RPL_SUMMONING , ReplyCodeInfo CommandReply "SUMMONING") - , (RPL_INVITED , ReplyCodeInfo CommandReply "INVITED") - , (RPL_INVEXLIST , ReplyCodeInfo CommandReply "INVEXLIST") - , (RPL_ENDOFINVEXLIST , ReplyCodeInfo CommandReply "ENDOFINVEXLIST") - , (RPL_EXCEPTLIST , ReplyCodeInfo CommandReply "EXCEPTLIST") - , (RPL_ENDOFEXCEPTLIST , ReplyCodeInfo CommandReply "ENDOFEXCEPTLIST") - , (RPL_VERSION , ReplyCodeInfo CommandReply "VERSION") - , (RPL_WHOREPLY , ReplyCodeInfo CommandReply "WHOREPLY") - , (RPL_NAMREPLY , ReplyCodeInfo CommandReply "NAMREPLY") - , (RPL_WHOSPCRPL , ReplyCodeInfo CommandReply "WHOSPCRPL") - , (RPL_NAMREPLY_ , ReplyCodeInfo CommandReply "NAMREPLY_") - , (RPL_WHOWASREAL , ReplyCodeInfo CommandReply "WHOWASREAL") - , (RPL_KILLDONE , ReplyCodeInfo CommandReply "KILLDONE") - , (RPL_CLOSING , ReplyCodeInfo CommandReply "CLOSING") - , (RPL_CLOSEEND , ReplyCodeInfo CommandReply "CLOSEEND") - , (RPL_LINKS , ReplyCodeInfo CommandReply "LINKS") - , (RPL_ENDOFLINKS , ReplyCodeInfo CommandReply "ENDOFLINKS") - , (RPL_ENDOFNAMES , ReplyCodeInfo CommandReply "ENDOFNAMES") - , (RPL_BANLIST , ReplyCodeInfo CommandReply "BANLIST") - , (RPL_ENDOFBANLIST , ReplyCodeInfo CommandReply "ENDOFBANLIST") - , (RPL_ENDOFWHOWAS , ReplyCodeInfo CommandReply "ENDOFWHOWAS") - , (RPL_INFO , ReplyCodeInfo CommandReply "INFO") - , (RPL_MOTD , ReplyCodeInfo CommandReply "MOTD") - , (RPL_INFOSTART , ReplyCodeInfo CommandReply "INFOSTART") - , (RPL_ENDOFINFO , ReplyCodeInfo CommandReply "ENDOFINFO") - , (RPL_MOTDSTART , ReplyCodeInfo CommandReply "MOTDSTART") - , (RPL_ENDOFMOTD , ReplyCodeInfo CommandReply "ENDOFMOTD") - , (RPL_WHOISHOST , ReplyCodeInfo CommandReply "WHOISHOST") - , (RPL_KICKLINKED , ReplyCodeInfo CommandReply "KICKLINKED") - , (RPL_YOUREOPER , ReplyCodeInfo CommandReply "YOUREOPER") - , (RPL_REHASHING , ReplyCodeInfo CommandReply "REHASHING") - , (RPL_YOURESERVICE , ReplyCodeInfo CommandReply "YOURESERVICE") - , (RPL_MYPORTIS , ReplyCodeInfo CommandReply "MYPORTIS") - , (RPL_NOTOPERANYMORE , ReplyCodeInfo CommandReply "NOTOPERANYMORE") - , (RPL_RSACHALLENGE , ReplyCodeInfo CommandReply "RSACHALLENGE") - , (RPL_TIME , ReplyCodeInfo CommandReply "TIME") - , (RPL_USERSSTART , ReplyCodeInfo CommandReply "USERSSTART") - , (RPL_USERS , ReplyCodeInfo CommandReply "USERS") - , (RPL_ENDOFUSERS , ReplyCodeInfo CommandReply "ENDOFUSERS") - , (RPL_NOUSERS , ReplyCodeInfo CommandReply "NOUSERS") - , (RPL_HOSTHIDDEN , ReplyCodeInfo CommandReply "HOSTHIDDEN") - , (ERR_UNKNOWNERROR , ReplyCodeInfo ErrorReply "UNKNOWNERROR") - , (ERR_NOSUCHNICK , ReplyCodeInfo ErrorReply "NOSUCHNICK") - , (ERR_NOSUCHSERVER , ReplyCodeInfo ErrorReply "NOSUCHSERVER") - , (ERR_NOSUCHCHANNEL , ReplyCodeInfo ErrorReply "NOSUCHCHANNEL") - , (ERR_CANNOTSENDTOCHAN , ReplyCodeInfo ErrorReply "CANNOTSENDTOCHAN") - , (ERR_TOOMANYCHANNELS , ReplyCodeInfo ErrorReply "TOOMANYCHANNELS") - , (ERR_WASNOSUCHNICK , ReplyCodeInfo ErrorReply "WASNOSUCHNICK") - , (ERR_TOOMANYTARGETS , ReplyCodeInfo ErrorReply "TOOMANYTARGETS") - , (ERR_NOORIGIN , ReplyCodeInfo ErrorReply "NOORIGIN") - , (ERR_NORECIPIENT , ReplyCodeInfo ErrorReply "NORECIPIENT") - , (ERR_NOTEXTTOSEND , ReplyCodeInfo ErrorReply "NOTEXTTOSEND") - , (ERR_NOTOPLEVEL , ReplyCodeInfo ErrorReply "NOTOPLEVEL") - , (ERR_WILDTOPLEVEL , ReplyCodeInfo ErrorReply "WILDTOPLEVEL") - , (ERR_BADMASK , ReplyCodeInfo ErrorReply "BADMASK") - , (ERR_TOOMANYMATCHES , ReplyCodeInfo ErrorReply "TOOMANYMATCHES") - , (ERR_LENGTHTRUNCATED , ReplyCodeInfo ErrorReply "LENGTHTRUNCATED") - , (ERR_UNKNOWNCOMMAND , ReplyCodeInfo ErrorReply "UNKNOWNCOMMAND") - , (ERR_NOMOTD , ReplyCodeInfo ErrorReply "NOMOTD") - , (ERR_NOADMININFO , ReplyCodeInfo ErrorReply "NOADMININFO") - , (ERR_FILEERROR , ReplyCodeInfo ErrorReply "FILEERROR") - , (ERR_NOOPERMOTD , ReplyCodeInfo ErrorReply "NOOPERMOTD") - , (ERR_TOOMANYAWAY , ReplyCodeInfo ErrorReply "TOOMANYAWAY") - , (ERR_EVENTNICKCHANGE , ReplyCodeInfo ErrorReply "EVENTNICKCHANGE") - , (ERR_NONICKNAMEGIVEN , ReplyCodeInfo ErrorReply "NONICKNAMEGIVEN") - , (ERR_ERRONEUSNICKNAME , ReplyCodeInfo ErrorReply "ERRONEUSNICKNAME") - , (ERR_NICKNAMEINUSE , ReplyCodeInfo ErrorReply "NICKNAMEINUSE") - , (ERR_SERVICENAMEINUSE , ReplyCodeInfo ErrorReply "SERVICENAMEINUSE") - , (ERR_NORULES , ReplyCodeInfo ErrorReply "NORULES") - , (ERR_BANNICKCHANGE , ReplyCodeInfo ErrorReply "BANNICKCHANGE") - , (ERR_NICKCOLLISION , ReplyCodeInfo ErrorReply "NICKCOLLISION") - , (ERR_UNAVAILRESOURCE , ReplyCodeInfo ErrorReply "UNAVAILRESOURCE") - , (ERR_NICKTOOFAST , ReplyCodeInfo ErrorReply "NICKTOOFAST") - , (ERR_TARGETTOOFAST , ReplyCodeInfo ErrorReply "TARGETTOOFAST") - , (ERR_SERVICESDOWN , ReplyCodeInfo ErrorReply "SERVICESDOWN") - , (ERR_USERNOTINCHANNEL , ReplyCodeInfo ErrorReply "USERNOTINCHANNEL") - , (ERR_NOTONCHANNEL , ReplyCodeInfo ErrorReply "NOTONCHANNEL") - , (ERR_USERONCHANNEL , ReplyCodeInfo ErrorReply "USERONCHANNEL") - , (ERR_NOLOGIN , ReplyCodeInfo ErrorReply "NOLOGIN") - , (ERR_SUMMONDISABLED , ReplyCodeInfo ErrorReply "SUMMONDISABLED") - , (ERR_USERSDISABLED , ReplyCodeInfo ErrorReply "USERSDISABLED") - , (ERR_NONICKCHANGE , ReplyCodeInfo ErrorReply "NONICKCHANGE") - , (ERR_NOTIMPLEMENTED , ReplyCodeInfo ErrorReply "NOTIMPLEMENTED") - , (ERR_NOTREGISTERED , ReplyCodeInfo ErrorReply "NOTREGISTERED") - , (ERR_IDCOLLISION , ReplyCodeInfo ErrorReply "IDCOLLISION") - , (ERR_NICKLOST , ReplyCodeInfo ErrorReply "NICKLOST") - , (ERR_HOSTILENAME , ReplyCodeInfo ErrorReply "HOSTILENAME") - , (ERR_ACCEPTFULL , ReplyCodeInfo ErrorReply "ACCEPTFULL") - , (ERR_ACCEPTEXIST , ReplyCodeInfo ErrorReply "ACCEPTEXIST") - , (ERR_ACCEPTNOT , ReplyCodeInfo ErrorReply "ACCEPTNOT") - , (ERR_NOHIDING , ReplyCodeInfo ErrorReply "NOHIDING") - , (ERR_NOTFORHALFOPS , ReplyCodeInfo ErrorReply "NOTFORHALFOPS") - , (ERR_NEEDMOREPARAMS , ReplyCodeInfo ErrorReply "NEEDMOREPARAMS") - , (ERR_ALREADYREGISTERED , ReplyCodeInfo ErrorReply "ALREADYREGISTERED") - , (ERR_NOPERMFORHOST , ReplyCodeInfo ErrorReply "NOPERMFORHOST") - , (ERR_PASSWDMISMATCH , ReplyCodeInfo ErrorReply "PASSWDMISMATCH") - , (ERR_YOUREBANNEDCREEP , ReplyCodeInfo ErrorReply "YOUREBANNEDCREEP") - , (ERR_YOUWILLBEBANNED , ReplyCodeInfo ErrorReply "YOUWILLBEBANNED") - , (ERR_KEYSET , ReplyCodeInfo ErrorReply "KEYSET") - , (ERR_INVALIDUSERNAME , ReplyCodeInfo ErrorReply "INVALIDUSERNAME") - , (ERR_ONLYSERVERSCANCHANGE , ReplyCodeInfo ErrorReply "ONLYSERVERSCANCHANGE") - , (ERR_LINKSET , ReplyCodeInfo ErrorReply "LINKSET") - , (ERR_LINKCHANNEL , ReplyCodeInfo ErrorReply "LINKCHANNEL") - , (ERR_CHANNELISFULL , ReplyCodeInfo ErrorReply "CHANNELISFULL") - , (ERR_UNKNOWNMODE , ReplyCodeInfo ErrorReply "UNKNOWNMODE") - , (ERR_INVITEONLYCHAN , ReplyCodeInfo ErrorReply "INVITEONLYCHAN") - , (ERR_BANNEDFROMCHAN , ReplyCodeInfo ErrorReply "BANNEDFROMCHAN") - , (ERR_BADCHANNELKEY , ReplyCodeInfo ErrorReply "BADCHANNELKEY") - , (ERR_BADCHANMASK , ReplyCodeInfo ErrorReply "BADCHANMASK") - , (ERR_NEEDREGGEDNICK , ReplyCodeInfo ErrorReply "NEEDREGGEDNICK") - , (ERR_BANLISTFULL , ReplyCodeInfo ErrorReply "BANLISTFULL") - , (ERR_BADCHANNAME , ReplyCodeInfo ErrorReply "BADCHANNAME") - , (ERR_THROTTLE , ReplyCodeInfo ErrorReply "THROTTLE") - , (ERR_NOPRIVILEGES , ReplyCodeInfo ErrorReply "NOPRIVILEGES") - , (ERR_CHANOPRIVSNEEDED , ReplyCodeInfo ErrorReply "CHANOPRIVSNEEDED") - , (ERR_CANTKILLSERVER , ReplyCodeInfo ErrorReply "CANTKILLSERVER") - , (ERR_ISCHANSERVICE , ReplyCodeInfo ErrorReply "ISCHANSERVICE") - , (ERR_BANNEDNICK , ReplyCodeInfo ErrorReply "BANNEDNICK") - , (ERR_NONONREG , ReplyCodeInfo ErrorReply "NONONREG") - , (ERR_TSLESSCHAN , ReplyCodeInfo ErrorReply "TSLESSCHAN") - , (ERR_VOICENEEDED , ReplyCodeInfo ErrorReply "VOICENEEDED") - , (ERR_NOOPERHOST , ReplyCodeInfo ErrorReply "NOOPERHOST") - , (ERR_NOSERVICEHOST , ReplyCodeInfo ErrorReply "NOSERVICEHOST") - , (ERR_NOFEATURE , ReplyCodeInfo ErrorReply "NOFEATURE") - , (ERR_OWNMODE , ReplyCodeInfo ErrorReply "OWNMODE") - , (ERR_BADLOGTYPE , ReplyCodeInfo ErrorReply "BADLOGTYPE") - , (ERR_BADLOGSYS , ReplyCodeInfo ErrorReply "BADLOGSYS") - , (ERR_BADLOGVALUE , ReplyCodeInfo ErrorReply "BADLOGVALUE") - , (ERR_ISOPERLCHAN , ReplyCodeInfo ErrorReply "ISOPERLCHAN") - , (ERR_CHANOWNPRIVNEEDED , ReplyCodeInfo ErrorReply "CHANOWNPRIVNEEDED") - , (ERR_UMODEUNKNOWNFLAG , ReplyCodeInfo ErrorReply "UMODEUNKNOWNFLAG") - , (ERR_USERSDONTMATCH , ReplyCodeInfo ErrorReply "USERSDONTMATCH") - , (ERR_GHOSTEDCLIENT , ReplyCodeInfo ErrorReply "GHOSTEDCLIENT") - , (ERR_USERNOTONSERV , ReplyCodeInfo ErrorReply "USERNOTONSERV") - , (ERR_SILELISTFULL , ReplyCodeInfo ErrorReply "SILELISTFULL") - , (ERR_TOOMANYWATCH , ReplyCodeInfo ErrorReply "TOOMANYWATCH") - , (ERR_WRONGPONG , ReplyCodeInfo ErrorReply "WRONGPONG") - , (ERR_BADEXPIRE , ReplyCodeInfo ErrorReply "BADEXPIRE") - , (ERR_DONTCHEAT , ReplyCodeInfo ErrorReply "DONTCHEAT") - , (ERR_DISABLED , ReplyCodeInfo ErrorReply "DISABLED") - , (ERR_NOINVITE , ReplyCodeInfo ErrorReply "NOINVITE") - , (ERR_LONGMASK , ReplyCodeInfo ErrorReply "LONGMASK") - , (ERR_ADMONLY , ReplyCodeInfo ErrorReply "ADMONLY") - , (ERR_TOOMANYUSERS , ReplyCodeInfo ErrorReply "TOOMANYUSERS") - , (ERR_OPERONLY , ReplyCodeInfo ErrorReply "OPERONLY") - , (ERR_MASKTOOWIDE , ReplyCodeInfo ErrorReply "MASKTOOWIDE") - , (ERR_WHOTRUNC , ReplyCodeInfo ErrorReply "WHOTRUNC") - , (ERR_LISTSYNTAX , ReplyCodeInfo ErrorReply "LISTSYNTAX") - , (ERR_WHOSYNTAX , ReplyCodeInfo ErrorReply "WHOSYNTAX") - , (ERR_WHOLIMEXCEED , ReplyCodeInfo ErrorReply "WHOLIMEXCEED") - , (ERR_HELPNOTFOUND , ReplyCodeInfo ErrorReply "HELPNOTFOUND") - , (ERR_REMOTEPFX , ReplyCodeInfo ErrorReply "REMOTEPFX") - , (ERR_PFXUNROUTABLE , ReplyCodeInfo ErrorReply "PFXUNROUTABLE") - , (ERR_BADHOSTMASK , ReplyCodeInfo ErrorReply "BADHOSTMASK") - , (ERR_HOSTUNAVAIL , ReplyCodeInfo ErrorReply "HOSTUNAVAIL") - , (ERR_USINGSLINE , ReplyCodeInfo ErrorReply "USINGSLINE") - , (ERR_STATSSLINE , ReplyCodeInfo ErrorReply "STATSSLINE") - , (RPL_LOGON , ReplyCodeInfo CommandReply "LOGON") - , (RPL_LOGOFF , ReplyCodeInfo CommandReply "LOGOFF") - , (RPL_WATCHOFF , ReplyCodeInfo CommandReply "WATCHOFF") - , (RPL_WATCHSTAT , ReplyCodeInfo CommandReply "WATCHSTAT") - , (RPL_NOWON , ReplyCodeInfo CommandReply "NOWON") - , (RPL_NOWOFF , ReplyCodeInfo CommandReply "NOWOFF") - , (RPL_WATCHLIST , ReplyCodeInfo CommandReply "WATCHLIST") - , (RPL_ENDOFWATCHLIST , ReplyCodeInfo CommandReply "ENDOFWATCHLIST") - , (RPL_WATCHCLEAR , ReplyCodeInfo CommandReply "WATCHCLEAR") - , (RPL_ISOPER , ReplyCodeInfo CommandReply "ISOPER") - , (RPL_ISLOCOP , ReplyCodeInfo CommandReply "ISLOCOP") - , (RPL_ISNOTOPER , ReplyCodeInfo CommandReply "ISNOTOPER") - , (RPL_ENDOFISOPER , ReplyCodeInfo CommandReply "ENDOFISOPER") - , (RPL_DCCSTATUS , ReplyCodeInfo CommandReply "DCCSTATUS") - , (RPL_DCCLIST , ReplyCodeInfo CommandReply "DCCLIST") - , (RPL_ENDOFDCCLIST , ReplyCodeInfo CommandReply "ENDOFDCCLIST") - , (RPL_WHOWASHOST , ReplyCodeInfo CommandReply "WHOWASHOST") - , (RPL_DCCINFO , ReplyCodeInfo CommandReply "DCCINFO") - , (RPL_RULES , ReplyCodeInfo CommandReply "RULES") - , (RPL_ENDOFO , ReplyCodeInfo CommandReply "ENDOFO") - , (RPL_SETTINGS , ReplyCodeInfo CommandReply "SETTINGS") - , (RPL_ENDOFSETTINGS , ReplyCodeInfo CommandReply "ENDOFSETTINGS") - , (RPL_DUMPING , ReplyCodeInfo CommandReply "DUMPING") - , (RPL_DUMPRPL , ReplyCodeInfo CommandReply "DUMPRPL") - , (RPL_EODUMP , ReplyCodeInfo CommandReply "EODUMP") - , (RPL_TRACEROUTE_HOP , ReplyCodeInfo CommandReply "TRACEROUTE_HOP") - , (RPL_TRACEROUTE_START , ReplyCodeInfo CommandReply "TRACEROUTE_START") - , (RPL_MODECHANGEWARN , ReplyCodeInfo CommandReply "MODECHANGEWARN") - , (RPL_CHANREDIR , ReplyCodeInfo CommandReply "CHANREDIR") - , (RPL_SERVMODEIS , ReplyCodeInfo CommandReply "SERVMODEIS") - , (RPL_OTHERUMODEIS , ReplyCodeInfo CommandReply "OTHERUMODEIS") - , (RPL_ENDOF_GENERIC , ReplyCodeInfo CommandReply "ENDOF_GENERIC") - , (RPL_WHOWASDETAILS , ReplyCodeInfo CommandReply "WHOWASDETAILS") - , (RPL_WHOISSECURE , ReplyCodeInfo CommandReply "WHOISSECURE") - , (RPL_UNKNOWNMODES , ReplyCodeInfo CommandReply "UNKNOWNMODES") - , (RPL_CANNOTSETMODES , ReplyCodeInfo CommandReply "CANNOTSETMODES") - , (RPL_LUSERSTAFF , ReplyCodeInfo CommandReply "LUSERSTAFF") - , (RPL_TIMEONSERVERIS , ReplyCodeInfo CommandReply "TIMEONSERVERIS") - , (RPL_NETWORKS , ReplyCodeInfo CommandReply "NETWORKS") - , (RPL_YOURLANGUAGEIS , ReplyCodeInfo CommandReply "YOURLANGUAGEIS") - , (RPL_LANGUAGE , ReplyCodeInfo CommandReply "LANGUAGE") - , (RPL_WHOISSTAFF , ReplyCodeInfo CommandReply "WHOISSTAFF") - , (RPL_WHOISLANGUAGE , ReplyCodeInfo CommandReply "WHOISLANGUAGE") - , (RPL_MODLIST , ReplyCodeInfo CommandReply "MODLIST") - , (RPL_ENDOFMODLIST , ReplyCodeInfo CommandReply "ENDOFMODLIST") - , (RPL_HELPSTART , ReplyCodeInfo CommandReply "HELPSTART") - , (RPL_HELPTXT , ReplyCodeInfo CommandReply "HELPTXT") - , (RPL_ENDOFHELP , ReplyCodeInfo CommandReply "ENDOFHELP") - , (ERR_TARGCHANGE , ReplyCodeInfo ErrorReply "TARGCHANGE") - , (RPL_ETRACEFULL , ReplyCodeInfo CommandReply "ETRACEFULL") - , (RPL_ETRACE , ReplyCodeInfo CommandReply "ETRACE") - , (RPL_KNOCK , ReplyCodeInfo CommandReply "KNOCK") - , (RPL_KNOCKDLVR , ReplyCodeInfo CommandReply "KNOCKDLVR") - , (ERR_TOOMANYKNOCK , ReplyCodeInfo ErrorReply "TOOMANYKNOCK") - , (ERR_CHANOPEN , ReplyCodeInfo ErrorReply "CHANOPEN") - , (ERR_KNOCKONCHAN , ReplyCodeInfo ErrorReply "KNOCKONCHAN") - , (ERR_KNOCKDISABLED , ReplyCodeInfo ErrorReply "KNOCKDISABLED") - , (RPL_TARGUMODEG , ReplyCodeInfo CommandReply "TARGUMODEG") - , (RPL_TARGNOTIFY , ReplyCodeInfo CommandReply "TARGNOTIFY") - , (RPL_UMODEGMSG , ReplyCodeInfo CommandReply "UMODEGMSG") - , (RPL_OMOTDSTART , ReplyCodeInfo CommandReply "OMOTDSTART") - , (RPL_OMOTD , ReplyCodeInfo CommandReply "OMOTD") - , (RPL_ENDOFOMOTD , ReplyCodeInfo CommandReply "ENDOFOMOTD") - , (ERR_NOPRIVS , ReplyCodeInfo ErrorReply "NOPRIVS") - , (RPL_TESTMASK , ReplyCodeInfo CommandReply "TESTMASK") - , (RPL_TESTLINE , ReplyCodeInfo CommandReply "TESTLINE") - , (RPL_NOTESTLINE , ReplyCodeInfo CommandReply "NOTESTLINE") - , (RPL_QUIETLIST , ReplyCodeInfo CommandReply "QUIETLIST") - , (RPL_ENDOFQUIETLIST , ReplyCodeInfo CommandReply "ENDOFQUIETLIST") - , (RPL_MONONLINE , ReplyCodeInfo CommandReply "MONONLINE") - , (RPL_MONOFFLINE , ReplyCodeInfo CommandReply "MONOFFLINE") - , (RPL_MONLIST , ReplyCodeInfo CommandReply "MONLIST") - , (RPL_ENDOFMONLIST , ReplyCodeInfo CommandReply "ENDOFMONLIST") - , (ERR_MONLISTFULL , ReplyCodeInfo ErrorReply "MONLISTFULL") - , (RPL_RSACHALLENGE2 , ReplyCodeInfo CommandReply "RSACHALLENGE2") - , (RPL_ENDOFRSACHALLENGE2 , ReplyCodeInfo CommandReply "ENDOFRSACHALLENGE2") - , (ERR_MLOCKRESTRICTED , ReplyCodeInfo ErrorReply "MLOCKRESTRICTED") - , (RPL_SCANMATCHED , ReplyCodeInfo CommandReply "SCANMATCHED") - , (RPL_SCANUMODES , ReplyCodeInfo CommandReply "SCANUMODES") - , (RPL_XINFO , ReplyCodeInfo CommandReply "XINFO") - , (RPL_XINFOSTART , ReplyCodeInfo CommandReply "XINFOSTART") - , (RPL_XINFOEND , ReplyCodeInfo CommandReply "XINFOEND") - , (RPL_LOGGEDIN , ReplyCodeInfo CommandReply "LOGGEDIN") - , (RPL_LOGGEDOUT , ReplyCodeInfo CommandReply "LOGGEDOUT") - , (RPL_NICKLOCKED , ReplyCodeInfo CommandReply "NICKLOCKED") - , (RPL_SASLSUCCESS , ReplyCodeInfo CommandReply "SASLSUCCESS") - , (RPL_SASLFAIL , ReplyCodeInfo CommandReply "SASLFAIL") - , (RPL_SASLTOOLONG , ReplyCodeInfo CommandReply "SASLTOOLONG") - , (RPL_SASLABORTED , ReplyCodeInfo CommandReply "SASLABORTED") - , (RPL_SASLALREADY , ReplyCodeInfo CommandReply "SASLALREADY") - , (RPL_SASLMECHS , ReplyCodeInfo CommandReply "SASLMECHS") - , (ERR_CANNOTDOCOMMAND , ReplyCodeInfo ErrorReply "CANNOTDOCOMMAND") - , (ERR_CANNOTCHANGEUMODE , ReplyCodeInfo ErrorReply "CANNOTCHANGEUMODE") - , (ERR_CANNOTCHANGECHANMODE , ReplyCodeInfo ErrorReply "CANNOTCHANGECHANMODE") - , (ERR_CANNOTCHANGESERVERMODE, ReplyCodeInfo ErrorReply "CANNOTCHANGESERVERMODE") - , (ERR_CANNOTSENDTONICK , ReplyCodeInfo ErrorReply "CANNOTSENDTONICK") - , (ERR_UNKNOWNSERVERMODE , ReplyCodeInfo ErrorReply "UNKNOWNSERVERMODE") - , (ERR_SERVERMODELOCK , ReplyCodeInfo ErrorReply "SERVERMODELOCK") - , (ERR_BADCHARENCODING , ReplyCodeInfo ErrorReply "BADCHARENCODING") - , (ERR_TOOMANYLANGUAGES , ReplyCodeInfo ErrorReply "TOOMANYLANGUAGES") - , (ERR_NOLANGUAGE , ReplyCodeInfo ErrorReply "NOLANGUAGE") - , (ERR_TEXTTOOSHORT , ReplyCodeInfo ErrorReply "TEXTTOOSHORT") - , (ERR_NUMERIC_ERR , ReplyCodeInfo ErrorReply "NUMERIC_ERR") - ] diff --git a/src/Irc/Commands.hs b/src/Irc/Commands.hs deleted file mode 100644 --- a/src/Irc/Commands.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# Language OverloadedStrings #-} -{-| -Module : Irc.Commands -Description : Smart constructors for "RawIrcMsg" -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module provides smart constructors for IRC commands. --} -module Irc.Commands - ( ircAway - , ircCapEnd - , ircCapLs - , ircCapReq - , ircInvite - , ircIson - , ircJoin - , ircKick - , ircLinks - , ircMode - , ircNick - , ircNotice - , ircPart - , ircPass - , ircPing - , ircPong - , ircPrivmsg - , ircQuit - , ircRemove - , ircStats - , ircTime - , ircTopic - , ircUser - , ircUserhost - , ircWho - , ircWhois - , ircWhowas - - -- * ZNC support - , ircZnc - - -- * SASL support - , ircAuthenticate - , plainAuthenticationMode - , encodePlainAuthentication - ) where - -import Irc.RawIrcMsg -import Irc.Identifier -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.ByteArray.Encoding as Enc - --- | PRIVMSG command -ircPrivmsg :: - Identifier {- ^ target -} -> - Text {- ^ message -} -> - RawIrcMsg -ircPrivmsg who msg = rawIrcMsg "PRIVMSG" [idText who, msg] - --- | NOTICE command -ircNotice :: - Identifier {- ^ target -} -> - Text {- ^ message -} -> - RawIrcMsg -ircNotice who msg = rawIrcMsg "NOTICE" [idText who, msg] - --- | MODE command -ircMode :: - Identifier {- ^ target -} -> - [Text] {- ^ parameters -} -> - RawIrcMsg -ircMode tgt params = rawIrcMsg "MODE" (idText tgt : params) - --- | WHOIS command -ircWhois :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircWhois = rawIrcMsg "WHOIS" - --- | WHO command -ircWho :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircWho = rawIrcMsg "WHO" - --- | WHOWAS command -ircWhowas :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircWhowas = rawIrcMsg "WHOWAS" - --- | NICK command -ircNick :: - Identifier {- ^ nickname -} -> - RawIrcMsg -ircNick nick = rawIrcMsg "NICK" [idText nick] - --- | PART command -ircPart :: - Identifier {- ^ channel -} -> - Text {- ^ message -} -> - RawIrcMsg -ircPart chan msg - | Text.null msg = rawIrcMsg "PART" [idText chan] - | otherwise = rawIrcMsg "PART" [idText chan, msg] - --- | JOIN command -ircJoin :: - Text {- ^ channel -} -> - Maybe Text {- ^ key -} -> - RawIrcMsg -ircJoin chan (Just key) = rawIrcMsg "JOIN" [chan, key] -ircJoin chan Nothing = rawIrcMsg "JOIN" [chan] - --- | INVITE command -ircInvite :: - Text {- ^ nickname -} -> - Identifier {- ^ channel -} -> - RawIrcMsg -ircInvite nick channel = rawIrcMsg "INVITE" [nick, idText channel] - --- | TOPIC command -ircTopic :: - Identifier {- ^ channel -} -> - Text {- ^ topic -} -> - RawIrcMsg -ircTopic chan msg - | Text.null msg = rawIrcMsg "TOPIC" [idText chan] - | otherwise = rawIrcMsg "TOPIC" [idText chan, msg] - --- | KICK command -ircKick :: - Identifier {- ^ channel -} -> - Text {- ^ nickname -} -> - Text {- ^ message -} -> - RawIrcMsg -ircKick chan who msg - | Text.null msg = rawIrcMsg "KICK" [idText chan, who] - | otherwise = rawIrcMsg "KICK" [idText chan, who, msg] - --- | REMOVE command -ircRemove :: - Identifier {- ^ channel -} -> - Text {- ^ nickname -} -> - Text {- ^ message -} -> - RawIrcMsg -ircRemove chan who msg - | Text.null msg = rawIrcMsg "REMOVE" [idText chan, who] - | otherwise = rawIrcMsg "REMOVE" [idText chan, who, msg] - --- | QUIT command -ircQuit :: Text {- ^ quit message -} -> RawIrcMsg -ircQuit msg - | Text.null msg = rawIrcMsg "QUIT" [] - | otherwise = rawIrcMsg "QUIT" [msg] - --- | PASS command -ircPass :: Text {- ^ password -} -> RawIrcMsg -ircPass pass = rawIrcMsg "PASS" [pass] - --- | PING command -ircPing :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircPing = rawIrcMsg "PING" - --- | PONG command -ircPong :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircPong = rawIrcMsg "PONG" - --- | ISON command -ircIson :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircIson = rawIrcMsg "ISON" - --- | TIME command -ircTime :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircTime = rawIrcMsg "TIME" - --- | USERHOST command -ircUserhost :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircUserhost = rawIrcMsg "USERHOST" - --- | STATS command -ircStats :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircStats = rawIrcMsg "STATS" - --- | LINKS command -ircLinks :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircLinks = rawIrcMsg "LINKS" - --- | AWAY command -ircAway :: - Text {- ^ message -} -> - RawIrcMsg -ircAway msg - | Text.null msg = rawIrcMsg "AWAY" [] - | otherwise = rawIrcMsg "AWAY" [msg] - --- | USER command -ircUser :: - Text {- ^ username -} -> - Bool {- ^ set +w -} -> - Bool {- ^ set +i -} -> - Text {- ^ realname -} -> RawIrcMsg -ircUser user set_w set_i real = rawIrcMsg "USER" [user, modeTxt, "*", real] - where - modeTxt = Text.pack (show mode) - mode :: Int - mode = (if set_w then 4 else 0) -- bit 2 - + (if set_i then 8 else 0) -- bit 3 - --- | CAP REQ command -ircCapReq :: - [Text] {- ^ capabilities -} -> - RawIrcMsg -ircCapReq caps = rawIrcMsg "CAP" ["REQ", Text.unwords caps] - --- | CAP END command -ircCapEnd :: RawIrcMsg -ircCapEnd = rawIrcMsg "CAP" ["END"] - --- | CAP LS command -ircCapLs :: RawIrcMsg -ircCapLs = rawIrcMsg "CAP" ["LS"] - --- | ZNC command --- --- /specific to ZNC/ -ircZnc :: - [Text] {- ^ parameters -} -> - RawIrcMsg -ircZnc = rawIrcMsg "ZNC" - --- | AUTHENTICATE command -ircAuthenticate :: Text -> RawIrcMsg -ircAuthenticate msg = rawIrcMsg "AUTHENTICATE" [msg] - --- | PLAIN authentiation mode -plainAuthenticationMode :: Text -plainAuthenticationMode = "PLAIN" - --- | Encoding of username and password in PLAIN authentication -encodePlainAuthentication :: - Text {- ^ username -} -> - Text {- ^ password -} -> - Text -encodePlainAuthentication user pass - = Text.decodeUtf8 - $ Enc.convertToBase Enc.Base64 - $ Text.encodeUtf8 - $ Text.intercalate "\0" [user,user,pass] diff --git a/src/Irc/Identifier.hs b/src/Irc/Identifier.hs deleted file mode 100644 --- a/src/Irc/Identifier.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-| -Module : Irc.Identifier -Description : Type and operations for nicknames and channel names -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module defines support for working with IRC's numeric reply -codes. Pattern synonyms are provided for each of the possible IRC reply codes. - -Reply code information was extracted from https://www.alien.net.au/irc/irc2numerics.html - --} -module Irc.Identifier - ( Identifier - , idDenote - , mkId - , idText - , idPrefix - ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Char -import Data.Function -import Data.Hashable -import Data.Primitive.ByteArray -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import qualified Data.Vector.Primitive as PV -import Data.Word - --- | Identifier representing channels and nicknames -data Identifier = Identifier {-# UNPACK #-} !Text - {-# UNPACK #-} !(PV.Vector Word8) - deriving (Read, Show) - --- | Equality on normalized identifier -instance Eq Identifier where - (==) = (==) `on` idDenote - --- | Comparison on normalized identifier -instance Ord Identifier where - compare = compare `on` idDenote - --- | Hash on normalized identifier -instance Hashable Identifier where - hashWithSalt s = hashPV8WithSalt s . idDenote - -hashPV8WithSalt :: Int -> PV.Vector Word8 -> Int -hashPV8WithSalt salt (PV.Vector off len (ByteArray arr)) = - hashByteArrayWithSalt arr off len salt - --- | Construct an 'Identifier' from a 'ByteString' -mkId :: Text -> Identifier -mkId x = Identifier x (ircFoldCase (Text.encodeUtf8 x)) - --- | Returns the original 'Text' of an 'Identifier' -idText :: Identifier -> Text -idText (Identifier x _) = x - --- | Returns the case-normalized 'ByteString' of an 'Identifier' --- which is suitable for comparison or hashing. -idDenote :: Identifier -> PV.Vector Word8 -idDenote (Identifier _ x) = x - --- | Returns 'True' when the first argument is a prefix of the second. -idPrefix :: Identifier -> Identifier -> Bool -idPrefix (Identifier _ x) (Identifier _ y) = x == PV.take (PV.length x) y - --- | Capitalize a string according to RFC 2812 --- Latin letters are capitalized and {|}~ are mapped to [\]^ -ircFoldCase :: ByteString -> PV.Vector Word8 -ircFoldCase = PV.fromList . map (\i -> casemap PV.! fromIntegral i) . B.unpack - -casemap :: PV.Vector Word8 -casemap - = PV.fromList - $ map (fromIntegral . ord) - $ ['\x00'..'`'] ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^" ++ ['\x7f'..'\xff'] diff --git a/src/Irc/Message.hs b/src/Irc/Message.hs deleted file mode 100644 --- a/src/Irc/Message.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# Language OverloadedStrings #-} - -{-| -Module : Irc.Message -Description : High-level representation of IRC messages -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module defines high-level IRC commands. Commands are interpreted -and their arguments are extracted into the appropriate types. - --} - -module Irc.Message - ( - -- * High-level messages - IrcMsg(..) - , CapCmd(..) - , cookIrcMsg - - -- * Properties of messages - , MessageTarget(..) - , ircMsgText - , msgTarget - , msgActor - - -- * Helper functions - , nickSplit - , computeMaxMessageLength - ) where - -import Control.Lens -import Control.Monad -import Data.Function -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Read as Text -import Irc.Identifier -import Irc.RawIrcMsg -import Irc.UserInfo -import Irc.Codes - --- | High-level IRC message representation -data IrcMsg - = UnknownMsg !RawIrcMsg -- ^ pass-through for unhandled messages - | Reply !ReplyCode [Text] -- ^ code arguments - | Nick !UserInfo !Identifier -- ^ old new - | Join !UserInfo !Identifier -- ^ user channel - | Part !UserInfo !Identifier (Maybe Text) -- ^ user channel reason - | Quit !UserInfo (Maybe Text) -- ^ user reason - | Kick !UserInfo !Identifier !Identifier !Text -- ^ kicker channel kickee comment - | Topic !UserInfo !Identifier !Text -- ^ user channel topic - | Privmsg !UserInfo !Identifier !Text -- ^ source target txt - | Ctcp !UserInfo !Identifier !Text !Text -- ^ source target command txt - | CtcpNotice !UserInfo !Identifier !Text !Text -- ^ source target command txt - | Notice !UserInfo !Identifier !Text -- ^ source target txt - | Mode !UserInfo !Identifier [Text] -- ^ source target txt - | Authenticate !Text -- ^ parameters - | Cap !CapCmd [Text] -- ^ command parameters - | Ping [Text] -- ^ parameters - | Pong [Text] -- ^ parameters - | Error !Text -- ^ message - deriving Show - --- | Sub-commands of the CAP command -data CapCmd - = CapLs -- ^ request list of supported caps - | CapList -- ^ request list of active caps - | CapReq -- ^ request activation of cap - | CapAck -- ^ request accepted - | CapNak -- ^ request denied - | CapEnd -- ^ end negotiation - deriving (Show, Eq, Ord) - --- | Match command text to structured cap sub-command -cookCapCmd :: Text -> Maybe CapCmd -cookCapCmd "LS" = Just CapLs -cookCapCmd "LIST" = Just CapList -cookCapCmd "ACK" = Just CapAck -cookCapCmd "NAK" = Just CapNak -cookCapCmd "END" = Just CapEnd -cookCapCmd "REQ" = Just CapReq -cookCapCmd _ = Nothing - --- | Interpret a low-level 'RawIrcMsg' as a high-level 'IrcMsg'. --- Messages that can't be understood are wrapped in 'UnknownMsg'. -cookIrcMsg :: RawIrcMsg -> IrcMsg -cookIrcMsg msg = - case view msgCommand msg of - cmd | Right (n,"") <- decimal cmd -> - Reply (ReplyCode n) (view msgParams msg) - "CAP" | _target:cmdTxt:rest <- view msgParams msg - , Just cmd <- cookCapCmd cmdTxt -> - Cap cmd rest - - "AUTHENTICATE" | x:_ <- view msgParams msg -> - Authenticate x - - "PING" -> Ping (view msgParams msg) - "PONG" -> Pong (view msgParams msg) - - "PRIVMSG" | Just user <- view msgPrefix msg - , [chan,txt] <- view msgParams msg -> - - case parseCtcp txt of - Just (cmd,args) -> Ctcp user (mkId chan) (Text.toUpper cmd) args - Nothing -> Privmsg user (mkId chan) txt - - "NOTICE" | Just user <- view msgPrefix msg - , [chan,txt] <- view msgParams msg -> - - case parseCtcp txt of - Just (cmd,args) -> CtcpNotice user (mkId chan) (Text.toUpper cmd) args - Nothing -> Notice user (mkId chan) txt - - "JOIN" | Just user <- view msgPrefix msg - , chan:_ <- view msgParams msg -> - - Join user (mkId chan) - - "QUIT" | Just user <- view msgPrefix msg - , reasons <- view msgParams msg -> - Quit user (listToMaybe reasons) - - "PART" | Just user <- view msgPrefix msg - , chan:reasons <- view msgParams msg -> - Part user (mkId chan) (listToMaybe reasons) - - "NICK" | Just user <- view msgPrefix msg - , newNick:_ <- view msgParams msg -> - Nick user (mkId newNick) - - "KICK" | Just user <- view msgPrefix msg - , [chan,nick,reason] <- view msgParams msg -> - Kick user (mkId chan) (mkId nick) reason - - "TOPIC" | Just user <- view msgPrefix msg - , [chan,topic] <- view msgParams msg -> - Topic user (mkId chan) topic - - "MODE" | Just user <- view msgPrefix msg - , target:modes <- view msgParams msg -> - Mode user (mkId target) modes - - "ERROR" | [reason] <- view msgParams msg -> - Error reason - - _ -> UnknownMsg msg - --- | Parse a CTCP encoded message: --- --- @\^ACOMMAND arguments\^A@ -parseCtcp :: Text -> Maybe (Text, Text) -parseCtcp txt = - do txt1 <- Text.stripSuffix "\^A" =<< Text.stripPrefix "\^A" txt - let (cmd,args) = Text.break (==' ') txt1 - guard (not (Text.null cmd)) - return (cmd, Text.drop 1 args) - - --- | Targets used to direct a message to a window for display -data MessageTarget - = TargetUser !Identifier -- ^ Metadata update for a user - | TargetWindow !Identifier -- ^ Directed message to channel or from user - | TargetNetwork -- ^ Network-level message - | TargetHidden -- ^ Completely hidden message - --- | Target information for the window that could be appropriate to --- display this message in. -msgTarget :: Identifier -> IrcMsg -> MessageTarget -msgTarget me msg = - case msg of - UnknownMsg{} -> TargetNetwork - Nick user _ -> TargetUser (userNick user) - Mode _ tgt _ | tgt == me -> TargetNetwork - | otherwise -> TargetWindow tgt - Join _ chan -> TargetWindow chan - Part _ chan _ -> TargetWindow chan - Quit user _ -> TargetUser (userNick user) - Kick _ chan _ _ -> TargetWindow chan - Topic _ chan _ -> TargetWindow chan - Privmsg src tgt _ | tgt == me -> TargetWindow (userNick src) - | otherwise -> TargetWindow tgt - Ctcp src tgt _ _ | tgt == me -> TargetWindow (userNick src) - | otherwise -> TargetWindow tgt - CtcpNotice src tgt _ _ | tgt == me -> TargetWindow (userNick src) - | otherwise -> TargetWindow tgt - Notice src tgt _ | tgt == me -> TargetWindow (userNick src) - | otherwise -> TargetWindow tgt - Authenticate{} -> TargetHidden - Ping{} -> TargetHidden - Pong{} -> TargetHidden - Error{} -> TargetNetwork - Cap{} -> TargetNetwork - Reply{} -> TargetNetwork - --- | 'UserInfo' of the user responsible for a message. -msgActor :: IrcMsg -> Maybe UserInfo -msgActor msg = - case msg of - UnknownMsg{} -> Nothing - Reply{} -> Nothing - Nick x _ -> Just x - Join x _ -> Just x - Part x _ _ -> Just x - Quit x _ -> Just x - Kick x _ _ _ -> Just x - Topic x _ _ -> Just x - Privmsg x _ _ -> Just x - Ctcp x _ _ _ -> Just x - CtcpNotice x _ _ _ -> Just x - Notice x _ _ -> Just x - Mode x _ _ -> Just x - Authenticate{}-> Nothing - Ping{} -> Nothing - Pong{} -> Nothing - Error{} -> Nothing - Cap{} -> Nothing - --- | Text representation of an IRC message to be used for matching with --- regular expressions. -ircMsgText :: IrcMsg -> Text -ircMsgText msg = - case msg of - UnknownMsg raw -> Text.unwords (view msgCommand raw : view msgParams raw) - Reply (ReplyCode n) xs -> Text.unwords (Text.pack (show n) : xs) - Nick x y -> Text.unwords [renderUserInfo x, idText y] - Join x _ -> renderUserInfo x - Part x _ mb -> Text.unwords (renderUserInfo x : maybeToList mb) - Quit x mb -> Text.unwords (renderUserInfo x : maybeToList mb) - Kick x _ z r -> Text.unwords [renderUserInfo x, idText z, r] - Topic x _ t -> Text.unwords [renderUserInfo x, t] - Privmsg x _ t -> Text.unwords [renderUserInfo x, t] - Ctcp x _ c t -> Text.unwords [renderUserInfo x, c, t] - CtcpNotice x _ c t -> Text.unwords [renderUserInfo x, c, t] - Notice x _ t -> Text.unwords [renderUserInfo x, t] - Mode x _ xs -> Text.unwords (renderUserInfo x:"set mode":xs) - Ping xs -> Text.unwords xs - Pong xs -> Text.unwords xs - Cap _ xs -> Text.unwords xs - Error t -> t - Authenticate{} -> "" - --- nickname = ( letter / special ) *8( letter / digit / special / "-" ) --- letter = %x41-5A / %x61-7A ; A-Z / a-z --- digit = %x30-39 ; 0-9 --- special = %x5B-60 / %x7B-7D -isNickChar :: Char -> Bool -isNickChar x = '0' <= x && x <= '9' - || 'A' <= x && x <= '}' - || '-' == x - --- | Split a nick into text parts group by whether or not those parts are valid --- nickname characters. -nickSplit :: Text -> [Text] -nickSplit = Text.groupBy ((==) `on` isNickChar) - --- | Maximum length computation for the message part for --- privmsg and notice. Note that the need for the limit is because --- the server will limit the length of the message sent out to each --- client, not just the length of the messages it will recieve. --- --- Note that the length is on the *encoded message* which is UTF-8 --- The calculation isn't using UTF-8 on the userinfo part because --- I'm assuming that the channel name and userinfo are all ASCII --- --- @ --- :my!user@info PRIVMSG #channel :messagebody\r\n --- @ -computeMaxMessageLength :: UserInfo -> Text -> Int -computeMaxMessageLength myUserInfo target - = 512 -- max IRC command - - Text.length (renderUserInfo myUserInfo) - - length (": PRIVMSG :\r\n"::String) - - Text.length target diff --git a/src/Irc/Modes.hs b/src/Irc/Modes.hs deleted file mode 100644 --- a/src/Irc/Modes.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# Language TemplateHaskell #-} -{-# Language BangPatterns #-} - -{-| -Module : Irc.Modes -Description : Operations for interpreting mode changes -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module provides support for interpreting the modes changed by -a MODE command. - --} -module Irc.Modes - ( - -- * Interpretation of modes - ModeTypes(..) - , modesLists - , modesAlwaysArg - , modesSetArg - , modesNeverArg - , modesPrefixModes - , defaultModeTypes - , defaultUmodeTypes - - -- * Operations for working with MODE command parameters - , splitModes - , unsplitModes - ) where - -import Control.Lens -import Data.Text (Text) -import qualified Data.Text as Text - --- | Settings that describe how to interpret channel modes -data ModeTypes = ModeTypes - { _modesLists :: [Char] -- ^ modes for channel lists (e.g. ban) - , _modesAlwaysArg :: [Char] -- ^ modes that always have an argument - , _modesSetArg :: [Char] -- ^ modes that have an argument when set - , _modesNeverArg :: [Char] -- ^ modes that never have arguments - , _modesPrefixModes :: [(Char,Char)] -- ^ modes requiring a nickname argument (mode,sigil) - } - deriving Show - -makeLenses ''ModeTypes - --- | The channel modes used by Freenode -defaultModeTypes :: ModeTypes -defaultModeTypes = ModeTypes - { _modesLists = "eIbq" - , _modesAlwaysArg = "k" - , _modesSetArg = "flj" - , _modesNeverArg = "CFLMPQScgimnprstz" - , _modesPrefixModes = [('o','@'),('v','+')] - } - --- | The default UMODE used by Freenode -defaultUmodeTypes :: ModeTypes -defaultUmodeTypes = ModeTypes - { _modesLists = "" - , _modesAlwaysArg = "" - , _modesSetArg = "s" - , _modesNeverArg = "DQRZgiow" - , _modesPrefixModes = [] - } - --- | Split up a mode change command and arguments into individual changes --- given a configuration. -splitModes :: - ModeTypes {- ^ mode interpretation -} -> - Text {- ^ modes -} -> - [Text] {- ^ arguments -} -> - Maybe [(Bool,Char,Text)] {- ^ (set, mode, parameter) -} -splitModes !icm = computeMode True . Text.unpack - where - computeMode :: - Bool {- current polarity -} -> - [Char] {- remaining modes -} -> - [Text] {- remaining arguments -} -> - Maybe [(Bool,Char,Text)] - computeMode polarity modes args = - - case modes of - [] | null args -> Just [] - | otherwise -> Nothing - - '+':ms -> computeMode True ms args - '-':ms -> computeMode False ms args - - m:ms - | m `elem` view modesAlwaysArg icm - || polarity && m `elem` view modesSetArg icm - || m `elem` map fst (view modesPrefixModes icm) - || m `elem` view modesLists icm -> - let (arg,args') = - case args of - [] -> (Text.empty,[]) - x:xs -> (x,xs) - in cons (polarity,m,arg) <$> computeMode polarity ms args' - - | not polarity && m `elem` view modesSetArg icm - || m `elem` view modesNeverArg icm -> - do res <- computeMode polarity ms args - return ((polarity,m,Text.empty) : res) - - | otherwise -> Nothing - --- | Construct the arguments to a MODE command corresponding to the given --- mode changes. -unsplitModes :: - [(Bool,Char,Text)] {- ^ (set,mode,parameter) -} -> - [Text] -unsplitModes modes - = Text.pack (foldr combineModeChars (const "") modes True) - : args - where - args = [arg | (_,_,arg) <- modes, not (Text.null arg)] - combineModeChars (q,m,_) rest p - | p == q = m : rest p - | q = '+' : m : rest True - | otherwise = '-' : m : rest False diff --git a/src/Irc/RateLimit.hs b/src/Irc/RateLimit.hs deleted file mode 100644 --- a/src/Irc/RateLimit.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-| -Module : Irc.RateLimit -Description : Rate limit operations for IRC -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module implements a simple rate limiter based on the IRC RFC -to be used to keep an IRC client from getting disconnected for -flooding. It allows one event per duration with a given threshold. - -This algorithm keeps track of the time at which the client may -start sending messages. Each message sent advances that time into -the future by the @penalty@. The client is allowed to transmit -up to @threshold@ seconds ahead of this time. - --} -module Irc.RateLimit - ( RateLimit - , newRateLimit - , tickRateLimit - ) where - -import Control.Concurrent -import Control.Monad -import Data.Time - --- | The 'RateLimit' keeps track of rate limit settings as well --- as the current state of the limit. -data RateLimit = RateLimit - { rateStamp :: !(MVar UTCTime) -- ^ Time that client can send - , rateThreshold :: !NominalDiffTime - , ratePenalty :: !NominalDiffTime - } - --- | Construct a new rate limit with the given penalty and threshold. -newRateLimit :: - Rational {- ^ penalty seconds -} -> - Rational {- ^ threshold seconds -} -> - 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 = realToFrac threshold - , ratePenalty = realToFrac 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' = ratePenalty r `addUTCTime` max stamp now - diff = diffUTCTime stamp' now - excess = diff - rateThreshold r - - when (excess > 0) (threadDelay (ceiling (1000000 * excess))) - - return stamp' diff --git a/src/Irc/RawIrcMsg.hs b/src/Irc/RawIrcMsg.hs deleted file mode 100644 --- a/src/Irc/RawIrcMsg.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# Language TemplateHaskell #-} - -{-| -Module : Irc.RawIrcMsg -Description : Low-level representation of IRC messages -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module provides a parser and printer for the low-level IRC -message format. It handles splitting up IRC commands into the -prefix, command, and arguments. - --} -module Irc.RawIrcMsg - ( - -- * Low-level IRC messages - RawIrcMsg(..) - , TagEntry(..) - , rawIrcMsg - , msgTags - , msgPrefix - , msgCommand - , msgParams - - -- * Text format for IRC messages - , parseRawIrcMsg - , renderRawIrcMsg - , prefixParser - , simpleTokenParser - - -- * Permissive text decoder - , asUtf8 - ) where - -import Control.Applicative -import Control.Lens -import Data.Attoparsec.Text as P -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Builder -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Vector (Vector) -import qualified Data.Vector as Vector - -import Irc.UserInfo - --- | 'RawIrcMsg' breaks down the IRC protocol into its most basic parts. --- The "trailing" parameter indicated in the IRC protocol with a leading --- colon will appear as the last parameter in the parameter list. --- --- Note that RFC 2812 specifies a maximum of 15 parameters. --- --- This parser is permissive regarding spaces. It aims to parse carefully --- constructed messages exactly and to make a best effort to recover from --- extraneous spaces. It makes no effort to validate nicknames, usernames, --- hostnames, commands, etc. Servers don't all agree on these things. --- --- @:prefix COMMAND param0 param1 param2 .. paramN@ -data RawIrcMsg = RawIrcMsg - { _msgTags :: [TagEntry] -- ^ IRCv3.2 message tags - , _msgPrefix :: Maybe UserInfo -- ^ Optional sender of message - , _msgCommand :: !Text -- ^ command - , _msgParams :: [Text] -- ^ command parameters - } - deriving (Read, Show) - --- | Key value pair representing an IRCv3.2 message tag. --- The value in this pair has had the message tag unescape --- algorithm applied. -data TagEntry = TagEntry {-# UNPACK #-} !Text {-# UNPACK #-} !Text - deriving (Read, Show) - -makeLenses ''RawIrcMsg - --- | Attempt to split an IRC protocol message without its trailing newline --- information into a structured message. -parseRawIrcMsg :: Text -> Maybe RawIrcMsg -parseRawIrcMsg x = - case parseOnly rawIrcMsgParser x of - Left{} -> Nothing - Right r -> Just r - --- | RFC 2812 specifies that there can only be up to --- 14 "middle" parameters, after that the fifteenth is --- the final parameter and the trailing : is optional! -maxMiddleParams :: Int -maxMiddleParams = 14 - --- Excerpt from https://tools.ietf.org/html/rfc2812#section-2.3.1 - --- message = [ ":" prefix SPACE ] command [ params ] crlf --- prefix = servername / ( nickname [ [ "!" user ] "@" host ] ) --- command = 1*letter / 3digit --- params = *14( SPACE middle ) [ SPACE ":" trailing ] --- =/ 14( SPACE middle ) [ SPACE [ ":" ] trailing ] - --- nospcrlfcl = %x01-09 / %x0B-0C / %x0E-1F / %x21-39 / %x3B-FF --- ; any octet except NUL, CR, LF, " " and ":" --- middle = nospcrlfcl *( ":" / nospcrlfcl ) --- trailing = *( ":" / " " / nospcrlfcl ) - --- SPACE = %x20 ; space character --- crlf = %x0D %x0A ; "carriage return" "linefeed" - --- | Parse a whole IRC message assuming that the trailing --- newlines have already been removed. This parser will --- parse valid messages correctly but will also accept some --- invalid messages. Presumably the server isn't sending --- invalid messages! -rawIrcMsgParser :: Parser RawIrcMsg -rawIrcMsgParser = - do tags <- fromMaybe [] <$> guarded '@' tagsParser - prefix <- guarded ':' prefixParser - cmd <- simpleTokenParser - params <- paramsParser maxMiddleParams - return $! RawIrcMsg - { _msgTags = tags - , _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 {- ^ possible middle parameters -} -> Parser [Text] -paramsParser !n = - do end <- P.atEnd - if end - then return [] - else do isColon <- optionalChar ':' - if isColon || n == 0 - then finalParam - else middleParam - - where - - finalParam = - do x <- takeText - let !x' = Text.copy x - return [x'] - - middleParam = - do x <- simpleTokenParser - xs <- paramsParser (n-1) - return (x:xs) - -tagsParser :: Parser [TagEntry] -tagsParser = tagParser `sepBy1` char ';' <* char ' ' - -tagParser :: Parser TagEntry -tagParser = - do key <- P.takeWhile (notInClass " =;") - hasValue <- optionalChar '=' - val <- if hasValue - then unescapeTagVal <$> P.takeWhile (notInClass " ;") - else return "" - return $! TagEntry key val - - -unescapeTagVal :: Text -> Text -unescapeTagVal = Text.pack . aux . Text.unpack - where - aux ('\\':':':xs) = ';':aux xs - aux ('\\':'s':xs) = ' ':aux xs - aux ('\\':'\\':xs) = '\\':aux xs - aux ('\\':'r':xs) = '\r':aux xs - aux ('\\':'n':xs) = '\n':aux xs - aux (x:xs) = x : aux xs - aux "" = "" - -escapeTagVal :: Text -> Text -escapeTagVal = Text.concatMap aux - where - aux ';' = "\\:" - aux ' ' = "\\s" - aux '\\' = "\\\\" - aux '\r' = "\\r" - aux '\n' = "\\n" - aux x = Text.singleton x - --- | Parse a rendered 'UserInfo' token. -prefixParser :: Parser UserInfo -prefixParser = - do tok <- simpleTokenParser - return $! parseUserInfo tok - --- | Take the next space-delimited lexeme -simpleTokenParser :: Parser Text -simpleTokenParser = - do xs <- P.takeWhile1 (/= ' ') - P.skipWhile (== ' ') - return $! Text.copy xs - - --- | 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 - $ renderTags (view msgTags m) - <> maybe mempty renderPrefix (view msgPrefix m) - <> Text.encodeUtf8Builder (view msgCommand m) - <> buildParams (view msgParams m) - <> Builder.char8 '\r' - <> Builder.char8 '\n' - --- | Construct a new 'RawIrcMsg' without a time or prefix. -rawIrcMsg :: - Text {- ^ command -} -> - [Text] {- ^ parameters -} -> RawIrcMsg -rawIrcMsg = RawIrcMsg [] Nothing - -renderTags :: [TagEntry] -> Builder -renderTags [] = mempty -renderTags xs - = Builder.char8 '@' - <> mconcat (intersperse (Builder.char8 ';') (map renderTag xs)) - <> Builder.char8 ' ' - -renderTag :: TagEntry -> Builder -renderTag (TagEntry key val) - = Text.encodeUtf8Builder key - <> Builder.char8 '=' - <> Text.encodeUtf8Builder (escapeTagVal val) - -renderPrefix :: UserInfo -> Builder -renderPrefix u - = Builder.char8 ':' - <> Text.encodeUtf8Builder (renderUserInfo u) - <> Builder.char8 ' ' - --- | Build concatenate a list of parameters into a single, space- --- delimited bytestring. Use a colon for the last parameter if it contains --- a colon or a space. -buildParams :: [Text] -> Builder -buildParams [x] - | " " `Text.isInfixOf` x || ":" `Text.isPrefixOf` x - = Builder.char8 ' ' <> Builder.char8 ':' <> Text.encodeUtf8Builder x -buildParams (x:xs) - = Builder.char8 ' ' <> Text.encodeUtf8Builder x <> buildParams xs -buildParams [] = mempty - --- | When the current input matches the given character parse --- using the given parser. -guarded :: Char -> Parser b -> Parser (Maybe b) -guarded c p = - do success <- optionalChar c - if success then Just <$> p else pure Nothing - - --- | Returns 'True' iff next character in stream matches argument. -optionalChar :: Char -> Parser Bool -optionalChar c = True <$ char c <|> pure False - - --- | 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 - --- | Decode a 'ByteString' as CP1252 -decodeCP1252 :: ByteString -> Text -decodeCP1252 bs = Text.pack [ cp1252 Vector.! fromIntegral x | x <- B.unpack bs ] - --- This character encoding is a superset of ISO 8859-1 in terms of printable --- characters, but differs from the IANA's ISO-8859-1 by using displayable --- characters rather than control characters in the 80 to 9F (hex) range. -cp1252 :: Vector Char -cp1252 = Vector.fromList - $ ['\x00'..'\x7f'] - ++ "€\x81‚ƒ„…†‡ˆ‰Š‹Œ\x8dŽ\x8f\x90‘’“”•–—˜™š›œ\x9džŸ" - ++ ['\xa0'..'\xff'] diff --git a/src/Irc/UserInfo.hs b/src/Irc/UserInfo.hs deleted file mode 100644 --- a/src/Irc/UserInfo.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# Language OverloadedStrings #-} - -{-| -Module : Irc.UserInfo -Description : User hostmasks -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -Information identifying users on IRC. This information includes -a nickname and optionally a username and hostname. - --} - -module Irc.UserInfo - ( UserInfo(..) - , renderUserInfo - , parseUserInfo - , uiNick - ) where - -import Data.Text (Text) -import qualified Data.Text as Text -import Irc.Identifier -import Data.Monoid ((<>)) -import Control.Lens - --- | 'UserInfo' packages a nickname along with the username and hsotname --- if they are known in the current context. -data UserInfo = UserInfo - { userNick :: {-# UNPACK #-} !Identifier -- ^ nickname - , userName :: {-# UNPACK #-} !Text -- ^ username, empty when missing - , userHost :: {-# UNPACK #-} !Text -- ^ hostname, empty when missing - } - deriving (Read, Show) - --- | 'Lens' into 'userNick' field. -uiNick :: Lens' UserInfo Identifier -uiNick f ui@UserInfo{userNick = n} = (\n' -> ui{userNick = n'}) <$> f n - --- | Render 'UserInfo' as @nick!username\@hostname@ -renderUserInfo :: UserInfo -> Text -renderUserInfo (UserInfo a b c) - = idText a - <> (if Text.null b then "" else "!" <> b) - <> (if Text.null c then "" else "@" <> c) - --- | Split up a hostmask into a nickname, username, and hostname. --- The username and hostname might not be defined but are delimited by --- a @!@ and @\@@ respectively. -parseUserInfo :: Text -> UserInfo -parseUserInfo x = UserInfo - { userNick = mkId nick - , userName = Text.drop 1 user - , userHost = Text.drop 1 host - } - where - (nickuser,host) = Text.break (=='@') x - (nick,user) = Text.break (=='!') nickuser diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -27,7 +27,7 @@ -- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' -- once the continuation finishes. withVty :: (Vty -> IO a) -> IO a -withVty = bracket (mkVty def) shutdown +withVty = bracket (mkVty def{bracketedPasteMode = Just True}) shutdown -- | Main action for IRC client main :: IO ()