diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for glirc2 +## 2.5 + +* Add facilities for hooks that can alter the irc message stream. +* Implement a hook that handles the znc buffextras plugin. +* Implement configurable nick color highlight palette. +* Resolve relative paths starting at the home directory. +* Significantly configurable UI colors + ## 2.4 * Support XDG configuration directory, e.g. `~/.config/glirc/config` 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. +Relative paths are relative to the home directory. + Learn more about this file format at [config-value](http://hackage.haskell.org/package/config-value) ``` @@ -84,6 +86,18 @@ server-certificates: * "/path/to/extra/certificate.pem" +palette: + time: [10,10,10] -- RGB values for color for timestamps + nick-colors: + [ cyan, magenta, green, yellow, blue + , bright-cyan, bright-magenta, bright-green, bright-blue + , 218, 88, 89, 124, 160, 205, 212, 224 -- reds + , 94, 130, 166, 172, 208, 214, 216, 180 -- oranges + , 58, 226, 229, 184, 187, 100, 142, 220 -- yellows + , 22, 34, 40, 82, 70, 64, 48, 85 -- greens + , 25, 27, 33, 39, 51, 80, 81, 75 -- blues + , 69, 61, 56, 54, 129, 93, 99, 147 -- purples + ] ``` Configuration sections: @@ -91,6 +105,7 @@ * `defaults` - These settings are used for all connections * `servers` - These settings are used to override defaults when the hostname matches +* `palette` - Client color overrides Settings -------- @@ -114,8 +129,23 @@ * `chanserv-channels` - list of text - list of channels with chanserv op permission * `flood-penalty` - number - cost in seconds per message * `flood-threshold` - number - threshold of seconds for burst +* `message-hooks` - list of text - names of hooks to enable +Palette +------- +* `nick-colors` - List of colors - Use for nick highlights +* `time` - color - color for timestamp +* `meta` - color - color for metadata +* `sigil` - color - color for sigils +* `label` - color - color for information labels +* `latency` - color - color for latency time +* `error` - color - color for error messages +* `textbox` - color - color for textbox edges +* `window-name` - color - color for current window name +* `activity` - color - color for activity notification +* `mention` - color - color for mention notification + Commands ======== @@ -221,3 +251,12 @@ * `^_` underline * `^]` italic * `^O` reset formatting + +Hooks +===== + +buffextras +---------- + +Enable this hook when using ZNC and the `buffextra` module in order to reinterpret +this module's messages natively in the client. diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.4 +version: 2.5 synopsis: Console IRC client description: Console IRC client license: ISC @@ -30,15 +30,19 @@ Client.CommandArguments Client.Commands Client.Configuration + Client.Configuration.Colors Client.Connect Client.ConnectionState Client.EditBox Client.EventLoop - Client.IdentifierColors + Client.Hook + Client.Hooks + Client.Hook.Znc.Buffextras Client.Image Client.Image.ChannelInfo Client.Image.MaskList Client.Image.Message + Client.Image.Palette Client.Image.UserList Client.Message Client.MircFormatting @@ -77,6 +81,7 @@ 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/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns, OverloadedStrings #-} {-| Module : Client.Commands @@ -18,7 +18,7 @@ ) where import Client.ConnectionState -import qualified Client.EditBox as EditBox +import qualified Client.EditBox as Edit import Client.Message import Client.ServerSettings import Client.ChannelState @@ -45,7 +45,6 @@ import Irc.UserInfo import Irc.Modes import LensUtils -import qualified Client.EditBox as Edit -- | Possible results of running a command data CommandResult @@ -101,11 +100,11 @@ executeChat msg st = case view clientFocus st of ChannelFocus network channel - | Just cs <- preview (clientConnection network) st -> + | Just !cs <- preview (clientConnection network) st -> do now <- getZonedTime let msgTxt = Text.pack msg ircMsg = rawIrcMsg "PRIVMSG" [idText channel, msgTxt] - myNick = UserInfo (view csNick cs) Nothing Nothing + myNick = UserInfo (view csNick cs) "" "" entry = ClientMessage { _msgTime = now , _msgNetwork = network @@ -281,7 +280,7 @@ cmdMe network cs channelId st rest = do now <- getZonedTime let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A") - myNick = UserInfo (view csNick cs) Nothing Nothing + !myNick = UserInfo (view csNick cs) "" "" entry = ClientMessage { _msgTime = now , _msgNetwork = network @@ -353,7 +352,7 @@ do now <- getZonedTime let targetTxts = Text.split (==',') targetsTxt targetIds = mkId <$> targetTxts - myNick = UserInfo (view csNick cs) Nothing Nothing + !myNick = UserInfo (view csNick cs) "" "" entries = [ (targetId, ClientMessage { _msgTime = now @@ -405,8 +404,8 @@ where networks = map mkId $ HashMap.keys $ view clientNetworkMap st textBox = view clientTextBox st - params = words $ take (view EditBox.pos textBox) - (view EditBox.content textBox) + params = words $ take (view Edit.pos textBox) + (view Edit.content textBox) completions | length params == 2 = networks @@ -615,8 +614,8 @@ computeBanUserInfo :: Identifier -> ConnectionState -> UserInfo computeBanUserInfo who cs = case view (csUser who) cs of - Nothing -> UserInfo who (Just "*") (Just "*") - Just (UserAndHost _ host) -> UserInfo (mkId "*") (Just "*") (Just host) + Nothing -> UserInfo who "*" "*" + Just (UserAndHost _ host) -> UserInfo (mkId "*") "*" host cmdRemove :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdRemove _ cs channelId st rest = @@ -742,8 +741,8 @@ where textBox = view clientTextBox st - paramIndex = length $ words $ take (view EditBox.pos textBox) - (view EditBox.content textBox) + paramIndex = length $ words $ take (view Edit.pos textBox) + (view Edit.content textBox) -- | Use the *!*@host masks of users for channel lists when setting list modes -- diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -20,14 +20,21 @@ , ConfigurationFailure(..) , configDefaults , configServers + , configPalette -- * Loading configuration , loadConfiguration + + -- * Resolving paths + , resolveConfigurationPath ) where +import Client.Image.Palette +import Client.Configuration.Colors import Client.ServerSettings import Control.Applicative import Control.Exception +import Control.Monad import Config import Config.FromConfig import Control.Lens hiding (List) @@ -38,6 +45,7 @@ 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 @@ -49,7 +57,8 @@ -- otherwise '_configDefaults' is used. data Configuration = Configuration { _configDefaults :: ServerSettings -- ^ Default connection settings - , _configServers :: HashMap HostName ServerSettings -- ^ Host-specific settings + , _configServers :: (HashMap HostName ServerSettings) -- ^ Host-specific settings + , _configPalette :: Palette } deriving Show @@ -143,8 +152,40 @@ _configServers <- fromMaybe HashMap.empty <$> sectionOptWith (parseServers _configDefaults) "servers" + _configPalette <- fromMaybe defaultPalette + <$> sectionOptWith parsePalette "palette" + return Configuration{..} +parsePalette :: Value -> ConfigParser Palette +parsePalette (Sections ss) = foldM paletteHelper defaultPalette ss +parsePalette _ = failure "Expected sections" + +paletteHelper :: Palette -> Section -> ConfigParser Palette +paletteHelper p (Section k v) = + extendLoc k $ + case k of + "nick-colors" -> do xs <- parseColors v + return $! set palNicks xs p + + "time" -> setAttr palTime + "meta" -> setAttr palMeta + "sigil" -> setAttr palSigil + "label" -> setAttr palLabel + "latency" -> setAttr palLatency + "error" -> setAttr palError + "textbox" -> setAttr palTextBox + "window-name" -> setAttr palWindowName + "activity" -> setAttr palActivity + "mention" -> setAttr palMention + _ -> failure "Unknown palette entry" + where + setAttr l = + do x <- parseColor v + let !attr = withForeColor defAttr x + return $! set l attr p + + parseServers :: ServerSettings -> Value -> ConfigParser (HashMap HostName ServerSettings) parseServers def (List xs) = do ys <- traverse (parseServerSettings def) xs @@ -186,6 +227,7 @@ _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) @@ -203,3 +245,11 @@ "yes" -> return True "no" -> return False _ -> liftConfigParser (failure "expected yes or no") + +-- | Resolve relative paths starting at the home directory rather than +-- the current directory of the client. +resolveConfigurationPath :: FilePath -> IO FilePath +resolveConfigurationPath path + | isAbsolute path = return path + | otherwise = do home <- getHomeDirectory + return (home path) diff --git a/src/Client/Configuration/Colors.hs b/src/Client/Configuration/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Client/Configuration/Colors.hs @@ -0,0 +1,91 @@ +{-# Language OverloadedStrings #-} + +{-| +Module : Client.Configuration +Description : Client configuration format and operations +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module defines the top-level configuration information for the client. +-} + +module Client.Configuration.Colors + ( parseColors + , parseColor + ) where + +import Config +import Config.FromConfig +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Ratio +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Graphics.Vty.Attributes + +parseColors :: Value -> ConfigParser (Vector Color) +parseColors (List []) = failure "Empty color palette" +parseColors (List xs) = traverse parseColor (Vector.fromList xs) +parseColors _ = failure "Expected list of colors or default" + +-- | Parse a color. Support formats are: +-- +-- * Number between 0-255 +-- * Name of color +-- * RGB values of color as a list +parseColor :: Value -> ConfigParser Color +parseColor v = + case v of + _ | Just i <- parseInteger v -> parseColorNumber i + Atom a | Just c <- HashMap.lookup (atomName a) namedColors -> return c + List [r,g,b] + | Just r' <- parseInteger r + , Just g' <- parseInteger g + , Just b' <- parseInteger b -> + parseRgb r' g' b' + _ -> failure "Expected a color number, name, or RBG list" + +parseColorNumber :: Integer -> ConfigParser Color +parseColorNumber i + | i < 0 = failure "Negative color not supported" + | i < 16 = return (ISOColor (fromInteger i)) + | i < 256 = return (Color240 (fromInteger (i - 16))) + | otherwise = failure "Color value too high" + +parseInteger :: Value -> Maybe Integer +parseInteger v = + case v of + Number _ i -> Just i + Floating c e + | denominator r == 1 -> Just (numerator r) + where r = fromInteger c * 10^^e + _ -> Nothing + +parseRgb :: Integer -> Integer -> Integer -> ConfigParser Color +parseRgb r g b + | valid r, valid g, valid b = return (rgbColor r g b) + | otherwise = failure "RGB values must be in range 0-255" + where + valid x = 0 <= x && x < 256 + +namedColors :: HashMap Text Color +namedColors = HashMap.fromList + [ ("black" , black ) + , ("red" , red ) + , ("green" , green ) + , ("yellow" , yellow ) + , ("blue" , blue ) + , ("magenta" , magenta ) + , ("cyan" , cyan ) + , ("white" , white ) + , ("bright-black" , brightBlack ) + , ("bright-red" , brightRed ) + , ("bright-green" , brightGreen ) + , ("bright-yellow" , brightYellow ) + , ("bright-blue" , brightBlue ) + , ("bright-magenta", brightMagenta) + , ("bright-cyan" , brightCyan ) + , ("bright-white" , brightWhite ) + ] diff --git a/src/Client/Connect.hs b/src/Client/Connect.hs --- a/src/Client/Connect.hs +++ b/src/Client/Connect.hs @@ -14,23 +14,25 @@ network connection library. -} -module Client.Connect (withConnection) where - -import Control.Lens -import Control.Exception (bracket) -import Data.Default.Class (def) -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.X509 (CertificateChain(..)) -import Data.X509.CertificateStore (CertificateStore, makeCertificateStore) -import Data.X509.File (readSignedObject, readKeyFile) -import Network.Connection -import Network.Socket (PortNumber) -import Network.TLS -import Network.TLS.Extra (ciphersuite_all) -import System.X509 (getSystemCertificateStore) +module Client.Connect + ( withConnection + ) where -import Client.ServerSettings +import Client.Configuration +import Client.ServerSettings +import Control.Exception (bracket) +import Control.Lens +import Control.Monad +import Data.Default.Class (def) +import Data.Monoid ((<>)) +import Data.X509 (CertificateChain(..)) +import Data.X509.CertificateStore (CertificateStore, makeCertificateStore) +import Data.X509.File (readSignedObject, readKeyFile) +import Network.Connection +import Network.Socket (PortNumber) +import Network.TLS +import Network.TLS.Extra (ciphersuite_all) +import System.X509 (getSystemCertificateStore) buildConnectionParams :: ServerSettings -> IO ConnectionParams buildConnectionParams args = @@ -60,7 +62,8 @@ buildCertificateStore :: ServerSettings -> IO CertificateStore buildCertificateStore args = do systemStore <- getSystemCertificateStore - userCerts <- traverse readSignedObject (view ssServerCerts args) + userCerts <- traverse (readSignedObject <=< resolveConfigurationPath) + (view ssServerCerts args) let userStore = makeCertificateStore (concat userCerts) return (userStore <> systemStore) @@ -96,8 +99,13 @@ case view ssTlsClientCert args of Nothing -> return Nothing Just certPath -> - do cert <- readSignedObject certPath - keys <- readKeyFile (fromMaybe certPath (view ssTlsClientKey args)) + do certPath' <- resolveConfigurationPath certPath + cert <- readSignedObject certPath' + + keyPath <- case view ssTlsClientKey args of + Nothing -> return certPath' + Just keyPath -> resolveConfigurationPath keyPath + keys <- readKeyFile keyPath case keys of [key] -> return (Just (CertificateChain cert, key)) [] -> fail "No private keys found" diff --git a/src/Client/ConnectionState.hs b/src/Client/ConnectionState.hs --- a/src/Client/ConnectionState.hs +++ b/src/Client/ConnectionState.hs @@ -37,6 +37,7 @@ , csNetwork , csNextPingTime , csPingStatus + , csMessageHooks , newConnectionState @@ -60,6 +61,7 @@ , PingStatus(..) , TimedAction(..) , nextTimedAction + , applyTimedAction ) where import Client.ChannelState @@ -106,6 +108,7 @@ , _csNetwork :: !Text , _csNextPingTime :: !(Maybe UTCTime) , _csPingStatus :: !PingStatus + , _csMessageHooks :: ![Text] } deriving Show @@ -181,7 +184,7 @@ ConnectionState newConnectionState networkId network settings sock = ConnectionState { _csNetworkId = networkId - , _csUserInfo = UserInfo (mkId (view ssNick settings)) Nothing Nothing + , _csUserInfo = UserInfo (mkId (view ssNick settings)) "" "" , _csChannels = HashMap.empty , _csSocket = sock , _csChannelTypes = "#&" @@ -195,6 +198,7 @@ , _csNetwork = network , _csPingStatus = PingNever , _csNextPingTime = Nothing + , _csMessageHooks = view ssMessageHooks settings } @@ -387,8 +391,9 @@ case args of _me:_tgt:uname:host:_server:nick:_ -> over csTransaction $ \t -> - let !xs = view _WhoTransaction t - in WhoTransaction (UserInfo (mkId nick) (Just uname) (Just host) : xs) + let !x = UserInfo (mkId nick) uname host + !xs = view _WhoTransaction t + in WhoTransaction (x : xs) _ -> id RPL_ENDOFWHO -> massRegistration @@ -397,9 +402,10 @@ case args of _me:chan:modes:params -> snd -- channel mode reply shouldn't trigger messages - . doMode msgWhen (UserInfo (mkId "*") Nothing Nothing) chanId modes params + . doMode msgWhen who chanId modes params . set (csChannels . ix chanId . chanModes) Map.empty where chanId = mkId chan + !who = UserInfo (mkId "*") "" "" _ -> id _ -> id @@ -698,11 +704,10 @@ csUser i = csUsers . at i recordUser :: UserInfo -> ConnectionState -> ConnectionState -recordUser user = - case (userName user, userHost user) of - (Just u, Just h) -> set (csUsers . at (userNick user)) - (Just (UserAndHost u h)) - _ -> id +recordUser (UserInfo nick user host) + | Text.null user || Text.null host = id + | otherwise = set (csUsers . at nick) + (Just (UserAndHost user host)) forgetUser :: Identifier -> ConnectionState -> ConnectionState forgetUser nick = set (csUsers . at nick) Nothing @@ -732,11 +737,11 @@ updateUsers users = foldl' updateUser users infos - updateUser users !info - | Just u <- userName info - , Just h <- userHost info - , HashSet.member (userNick info) channelUsers = - HashMap.insert (userNick info) (UserAndHost u h) users + updateUser users (UserInfo nick user host) + | not (Text.null user) + , not (Text.null host) + , HashSet.member nick channelUsers = + HashMap.insert nick (UserAndHost user host) users | otherwise = users -- | Timer-based events @@ -763,4 +768,18 @@ delta = case view csPingStatus cs of PingSent sent -> realToFrac (diffUTCTime (zonedTimeToUTC when) sent) - _ -> 0 + _ -> 0 + +-- | Apply the given 'TimedAction' to a connection state. +applyTimedAction :: TimedAction -> ConnectionState -> IO ConnectionState +applyTimedAction action cs = + case action of + TimedDisconnect -> + do abortConnection (view csSocket cs) + return $! set csNextPingTime Nothing cs + + TimedSendPing -> + do now <- getCurrentTime + sendMsg cs (ircPing ["ping"]) + return $! set csNextPingTime (Just $! addUTCTime 60 now) + $ set csPingStatus (PingSent now) cs diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -18,6 +18,8 @@ import Client.Commands import Client.ConnectionState import qualified Client.EditBox as Edit +import Client.Hook +import Client.Hooks import Client.Image import Client.Message import Client.NetworkConnection @@ -34,6 +36,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Ord +import qualified Data.Text as Text import Data.Time import Graphics.Vty import Irc.Message @@ -88,6 +91,7 @@ vty = view clientVty st (pic, st) = clientPicture st1 + -- check st0 for bell, it will be always be cleared in st1 when (view clientBell st0) (beep vty) update vty pic @@ -101,6 +105,8 @@ NetworkError network time ex -> doNetworkError network time ex st NetworkClose network time -> doNetworkClose network time st +-- | Sound the terminal bell assuming that the @BEL@ control code +-- is supported. beep :: Vty -> IO () beep vty = outputByteBuffer (outputIface vty) "\BEL" @@ -157,27 +163,57 @@ eventLoop (recordNetworkMessage msg st) Just raw -> - do let irc = cookIrcMsg raw - time' = case view msgServerTime raw of - Nothing -> time - Just stime -> utcToZonedTime (zonedTimeZone time) stime - msg = ClientMessage - { _msgTime = time' - , _msgNetwork = network - , _msgBody = IrcBody irc - } - myNick = view csNick cs - target = msgTarget myNick irc + do let time' = computeEffectiveTime time (view msgTags raw) - -- record messages *before* applying the changes - let (msgs, st') - = applyMessageToClientState time irc networkId cs - $ recordIrcMessage network target msg st + (stateHook, viewHook) + = over both applyMessageHooks + $ partition (view messageHookStateful) + $ lookups + (view csMessageHooks cs) + messageHooks - traverse_ (sendMsg cs) msgs - eventLoop st' + case stateHook (cookIrcMsg raw) of + Nothing -> eventLoop st -- Message ignored + Just irc -> do traverse_ (sendMsg cs) replies + eventLoop st' + where + -- state with message recorded + recSt = case viewHook irc of + Nothing -> st -- Message hidden + Just irc' -> recordIrcMessage network target msg st + where + myNick = view csNick cs + target = msgTarget myNick irc + msg = ClientMessage + { _msgTime = time' + , _msgNetwork = network + , _msgBody = IrcBody irc' + } + -- record messages *before* applying the changes + (replies, st') = applyMessageToClientState time irc networkId cs recSt +-- | Find the ZNC provided server time +computeEffectiveTime :: ZonedTime -> [TagEntry] -> ZonedTime +computeEffectiveTime time tags = fromMaybe time zncTime + where + isTimeTag (TagEntry key _) = key == "time" + zncTime = + do TagEntry _ txt <- find isTimeTag tags + tagTime <- parseZncTime (Text.unpack txt) + return (utcToZonedTime (zonedTimeZone time) tagTime) + +-- | Parses the time format used by ZNC for buffer playback +parseZncTime :: String -> Maybe UTCTime +parseZncTime = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" + + +-- | Returns the list of values that were stored at the given indexes, if +-- a value was stored at that index. +lookups :: Ixed m => [Index m] -> m -> [IxValue m] +lookups ks m = mapMaybe (\k -> preview (ix k) m) ks + + -- | Respond to a VTY event. doVtyEvent :: Event -> ClientState -> IO () doVtyEvent vtyEvent st = @@ -189,7 +225,7 @@ (w,h) <- displayBounds (outputIface vty) eventLoop $ set clientWidth w $ set clientHeight h st - _ -> eventLoop st + _ -> eventLoop st -- | Map keyboard inputs to actions in the client @@ -250,6 +286,8 @@ _ -> eventLoop st -- unsupported modifier +-- | Process 'CommandResult' by either running the 'eventLoop' with the +-- new 'ClientState' or returning. doCommandResult :: CommandResult -> IO () doCommandResult res = case res of @@ -298,17 +336,6 @@ NetworkId {- ^ Network related to event -} -> TimedAction {- ^ Action to perform -} -> ClientState -> IO () -doTimerEvent networkId action st = - do st' <- forOf (clientConnections . ix networkId) st $ \cs -> - case action of - TimedDisconnect -> - do abortConnection (view csSocket cs) - return $! set csNextPingTime Nothing cs - - TimedSendPing -> - do now <- getCurrentTime - let cs' = set csNextPingTime (Just $! addUTCTime 60 now) - $ set csPingStatus (PingSent now) cs - sendMsg cs' (rawIrcMsg "PING" ["ping"]) - return cs' - eventLoop st' +doTimerEvent networkId action = + eventLoop <=< traverseOf (clientConnections . ix networkId) + (applyTimedAction action) diff --git a/src/Client/Hook.hs b/src/Client/Hook.hs new file mode 100644 --- /dev/null +++ b/src/Client/Hook.hs @@ -0,0 +1,67 @@ +{-# Language TemplateHaskell #-} + +{-| +Module : Client.Hook +Description : Hooks into the operation of the client. +Copyright : (c) Dan Doel, 2016 +License : ISC +Maintainer : dan.doel@gmail.com + +This module defines types for hooking into the operation of the client. + +-} + +module Client.Hook + ( -- | * Message hook results + MessageResult(..) + -- | * Message hooks + , MessageHook(..) + , messageHookName + , messageHookStateful + , messageHookAction + , applyMessageHooks + ) where + +import Control.Lens +import Data.Text + +import Irc.Message + +-- | The possible results of a 'MessageHook' action. A hook can decline to +-- handle a message ('PassMessage'), filter out a message ('OmitMessage'), +-- or change a message into an arbitrary other message ('RemapMessage'). +data MessageResult + = PassMessage + | OmitMessage + | RemapMessage IrcMsg + +instance Monoid MessageResult where + mempty = PassMessage + PassMessage `mappend` r = r + l `mappend` _ = l + +maybeFromResult :: IrcMsg -> MessageResult -> Maybe IrcMsg +maybeFromResult original PassMessage = Just original +maybeFromResult _ OmitMessage = Nothing +maybeFromResult _ (RemapMessage new) = Just new + +-- A hook into the IRC message portion of the event loop. 'MessageHook's are +-- able to filter out or alter 'IrcMsg's, and may do so in a way that either +-- affects the overall 'ClientState' or just the chat view. +data MessageHook = MessageHook + { _messageHookName :: Text -- ^ Identifying name for the hook + , _messageHookStateful :: Bool -- ^ Whether the remapping should affect client state + , _messageHookAction :: IrcMsg -> MessageResult + -- ^ (Partial) message remapping action + } + +makeLenses ''MessageHook + +-- | Apply the given message hooks to an 'IrcMsg'. The hooks are tried in +-- order until one handles the message. A 'Nothing' result means the message was +-- filtered out by a hook. A 'Just' result contains the actual 'IrcMsg' to be +-- processed. +applyMessageHooks :: [MessageHook] -> IrcMsg -> Maybe IrcMsg +applyMessageHooks hs msg = + maybeFromResult msg $ + foldMap (\h -> view messageHookAction h msg) hs diff --git a/src/Client/Hook/Znc/Buffextras.hs b/src/Client/Hook/Znc/Buffextras.hs new file mode 100644 --- /dev/null +++ b/src/Client/Hook/Znc/Buffextras.hs @@ -0,0 +1,83 @@ +{-# Language OverloadedStrings #-} + +{-| +Module : Client.Hook.Znc.Buffextras +Description : Hook to remap znc buffextras messages +Copyright : (c) Dan Doel, 2016 +License : ISC +Maintainer : dan.doel@gmail.com + +This hook remaps output from the znc buffextras plugin to the +actual IRC commands they represent, so that they can show up +normally in the client output. + +-} + +module Client.Hook.Znc.Buffextras + ( buffextrasHook + ) where + +import Data.Attoparsec.Text as P +import Data.Monoid +import Data.Text as Text hiding (head) + +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 +-- the hook doesn't understand. +buffextrasHook :: Bool {- ^ enable debugging -} -> MessageHook +buffextrasHook = MessageHook "buffextras" False . remap + +remap :: + Bool {- ^ enable debugging -} -> + IrcMsg -> MessageResult +remap debug (Privmsg user chan msg) + | userNick user == mkId "*buffextras" + , Right newMsg <- parseOnly (mainParser chan) msg + = RemapMessage newMsg + + | userNick user == mkId "*buffextras" + , not debug + = OmitMessage + +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 + ] + +allTokens :: Parser [Text] +allTokens = Text.words <$> P.takeText + +sepMsg :: Text -> Parser () +sepMsg m = P.skipWhile (==' ') *> 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 ']' + +filterEmpty :: Text -> Maybe Text +filterEmpty tx + | Text.null tx = Nothing + | otherwise = Just tx diff --git a/src/Client/Hooks.hs b/src/Client/Hooks.hs new file mode 100644 --- /dev/null +++ b/src/Client/Hooks.hs @@ -0,0 +1,29 @@ +{-# Language OverloadedStrings #-} + +{-| +Module : Client.Hooks +Description : Available hooks +Copyright : (c) Dan Doel, 2016 +License : ISC +Maintainer : dan.doel@gmail.com + +The collection of all hooks available in the client. + +-} + +module Client.Hooks + ( messageHooks + ) where + +import Data.Text +import Data.HashMap.Strict +import Client.Hook + +import Client.Hook.Znc.Buffextras + +-- | All the available message hooks. +messageHooks :: HashMap Text MessageHook +messageHooks = fromList + [ ("buffextras", buffextrasHook False) + , ("buffextras-debug", buffextrasHook True) + ] diff --git a/src/Client/IdentifierColors.hs b/src/Client/IdentifierColors.hs deleted file mode 100644 --- a/src/Client/IdentifierColors.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-| -Module : Client.IdentifierColors -Description : Mapping from identifiers to console colors -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module provides the color mapping for nick highlighting. - --} - -module Client.IdentifierColors (identifierColor) where - -import qualified Data.ByteString as B -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Irc.Identifier -import Graphics.Vty.Image - --- | Compute a color from the denotation of an identifier. --- This color will be consistent for different capitalizations --- and will be consistent across program executions. -identifierColor :: Identifier -> Color -identifierColor ident = nickColorPalette Vector.! i - where - i = hashIdentity ident `mod` Vector.length nickColorPalette - -hashIdentity :: Identifier -> Int -hashIdentity ident = - let h1 = B.foldl' (\acc b -> fromIntegral b + 33 * acc) 0 (idDenote ident) - in h1 + (h1 `quot` 32) - -nickColorPalette :: Vector Color -nickColorPalette = Vector.fromList - [cyan, magenta, green, yellow, blue, - brightCyan, brightMagenta, brightGreen, brightBlue] diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -12,11 +12,13 @@ module Client.Image (clientPicture) where import Client.ChannelState +import Client.Configuration import Client.ConnectionState import qualified Client.EditBox as Edit import Client.Image.ChannelInfo import Client.Image.MaskList import Client.Image.Message +import Client.Image.Palette import Client.Image.UserList import Client.Message import Client.MircFormatting @@ -125,7 +127,8 @@ else windowLinesToImagesMd st (finish <|> char defAttr ' ' <|> img) ident wls _ -> finish : windowLinesToImages st wwls where - finish = acc <|> maybe emptyImage quietIdentifier who + palette = view (clientConfig . configPalette) st + finish = acc <|> maybe emptyImage (quietIdentifier palette) who metadataWindowLine :: ClientState -> WindowLine -> Maybe (Image, Maybe Identifier) @@ -133,8 +136,10 @@ case view wlBody wl of IrcBody irc | Just who <- ircIgnorable irc st -> Just (ignoreImage, Just who) - | otherwise -> metadataImg irc + | otherwise -> metadataImg palette irc _ -> Nothing + where + palette = view (clientConfig . configPalette) st lineWrap :: Int -> Image -> Image lineWrap w img @@ -166,18 +171,22 @@ | 0 == view clientScroll st = emptyImage | otherwise = horizCat [ string defAttr "─(" - , string (withForeColor defAttr red) "scroll" + , string attr "scroll" , string defAttr ")" ] + where + attr = view (clientConfig . configPalette . palLabel) st detailImage :: ClientState -> Image detailImage st | view clientDetailView st = horizCat [ string defAttr "─(" - , string (withForeColor defAttr red) "detail" + , string attr "detail" , string defAttr ")" ] | otherwise = emptyImage + where + attr = view (clientConfig . configPalette . palLabel) st activityImage :: ClientState -> Image activityImage st @@ -192,10 +201,11 @@ aux [] = [] aux ((i,w):ws) | view winUnread w == 0 = aux ws - | otherwise = char (withForeColor defAttr color) i : aux ws + | otherwise = char attr i : aux ws where - color | view winMention w = red - | otherwise = green + pal = view (clientConfig . configPalette) st + attr | view winMention w = view palMention pal + | otherwise = view palActivity pal myNickImage :: ClientState -> Image @@ -205,10 +215,11 @@ ChannelFocus network chan -> nickPart network (Just chan) Unfocused -> emptyImage where + pal = view (clientConfig . configPalette) st nickPart network mbChan = case preview (clientConnection network) st of Nothing -> emptyImage - Just cs -> string (withForeColor defAttr cyan) myChanModes + Just cs -> string (view palSigil pal) myChanModes <|> text' defAttr (idText nick) <|> parens defAttr (string defAttr ('+' : view csModes cs)) <|> char defAttr '─' @@ -224,11 +235,12 @@ focusImage st = parens defAttr majorImage <|> renderedSubfocus where majorImage = horizCat - [ char (withForeColor defAttr cyan) windowName + [ char (view palWindowName pal) windowName , char defAttr ':' , renderedFocus ] + pal = view (clientConfig . configPalette) st focus = view clientFocus st windowName = case Map.lookupIndex focus (view clientWindows st) of @@ -238,12 +250,12 @@ subfocusName = case view clientSubfocus st of FocusMessages -> Nothing - FocusInfo -> Just $ string (withForeColor defAttr green) "info" - FocusUsers -> Just $ string (withForeColor defAttr green) "users" + FocusInfo -> Just $ string (view palLabel pal) "info" + FocusUsers -> Just $ string (view palLabel pal) "users" FocusMasks m -> Just $ horizCat - [ string (withForeColor defAttr green) "masks" + [ string (view palLabel pal) "masks" , char defAttr ':' - , char (withForeColor defAttr green) m + , char (view palLabel pal) m ] renderedSubfocus = @@ -256,13 +268,13 @@ renderedFocus = case focus of Unfocused -> - char (withForeColor defAttr red) '*' + char (view palError pal) '*' NetworkFocus network -> - text' (withForeColor defAttr green) network + text' (view palLabel pal) network ChannelFocus network channel -> - text' (withForeColor defAttr green) network <|> + text' (view palLabel pal) network <|> char defAttr ':' <|> - text' (withForeColor defAttr green) (idText channel) <|> + text' (view palLabel pal) (idText channel) <|> channelModesImage network channel st channelModesImage :: Text -> Identifier -> ClientState -> Image @@ -286,8 +298,9 @@ | 1+pos < width = cropRight width | otherwise = cropLeft width . cropRight (pos+2) - beginning = char (withForeColor defAttr brightBlack) '^' - ending = char (withForeColor defAttr brightBlack) '$' + attr = view (clientConfig . configPalette . palTextBox) st + beginning = char attr '^' + ending = char attr '$' latencyImage :: ClientState -> Image latencyImage st @@ -298,7 +311,9 @@ PingSent {} -> emptyImage PingLatency delta -> horizCat [ string defAttr "─(" - , string (withForeColor defAttr yellow) (showFFloat (Just 2) delta "s") + , string (view palLatency pal) (showFFloat (Just 2) delta "s") , string defAttr ")" ] | otherwise = emptyImage + where + pal = view (clientConfig . configPalette) 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 @@ -17,7 +17,9 @@ ) where import Client.ChannelState +import Client.Configuration import Client.ConnectionState +import Client.Image.Palette import Client.Image.Message import Client.MircFormatting import Client.State @@ -32,19 +34,21 @@ | Just cs <- preview (clientConnection network) st , Just channel <- preview (csChannels . ix channelId) cs - = channelInfoImages' channel cs + = channelInfoImages' pal channel cs - | otherwise = [text' (withForeColor defAttr red) "No channel information"] + | otherwise = [text' (view palError pal) "No channel information"] + where + pal = view (clientConfig . configPalette) st -channelInfoImages' :: ChannelState -> ConnectionState -> [Image] -channelInfoImages' !channel !cs +channelInfoImages' :: Palette -> ChannelState -> ConnectionState -> [Image] +channelInfoImages' pal !channel !cs = topicLine : provenanceLines ++ creationLines ++ urlLines where - label = text' (withForeColor defAttr green) + label = text' (view palLabel pal) topicLine = label "Topic: " <|> parseIrcText (view chanTopic channel) @@ -56,7 +60,8 @@ case view chanTopicProvenance channel of Nothing -> [] Just !prov -> - [ label "Topic set by: " <|> coloredUserInfo DetailedRender [myNick] (view topicAuthor prov) + [ label "Topic set by: " <|> + coloredUserInfo pal DetailedRender [myNick] (view topicAuthor prov) , label "Topic set on: " <|> utcTimeImage (view topicTime prov) ] 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 @@ -14,7 +14,9 @@ ) where import Client.ChannelState +import Client.Configuration import Client.ConnectionState +import Client.Image.Palette import Client.State import Control.Lens import Data.HashMap.Strict (HashMap) @@ -34,10 +36,11 @@ ClientState -> [Image] maskListImages mode network channel st = case mbEntries of - Nothing -> [text' (withForeColor defAttr red) "Mask list not loaded"] + Nothing -> [text' (view palError pal) "Mask list not loaded"] Just entries -> maskListImages' entries st where + pal = view (clientConfig . configPalette) st mbEntries = preview ( clientConnection network . csChannels . ix channel @@ -47,9 +50,11 @@ maskListImages' :: HashMap Text MaskListEntry -> ClientState -> [Image] maskListImages' entries st = countImage : images where - countImage = text' (withForeColor defAttr green) "Masks (visible/total): " <|> + pal = view (clientConfig . configPalette) st + + countImage = text' (view palLabel pal) "Masks (visible/total): " <|> string defAttr (show (length entryList)) <|> - char (withForeColor defAttr green) '/' <|> + char (view palLabel pal) '/' <|> string defAttr (show (HashMap.size entries)) matcher = clientMatcher st 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 @@ -1,4 +1,4 @@ -{-# Language OverloadedStrings #-} +{-# Language OverloadedStrings, BangPatterns #-} {-| Module : Client.Image.Message Description : Renderer for message lines @@ -22,7 +22,7 @@ , coloredIdentifier ) where -import Client.IdentifierColors +import Client.Image.Palette import Client.Message import Client.MircFormatting import Control.Lens @@ -33,11 +33,13 @@ import Irc.Message import Irc.RawIrcMsg import Irc.UserInfo +import Data.Char +import Data.Hashable (hash) import qualified Data.HashSet as HashSet import Data.List import qualified Data.Text as Text import Data.Text (Text) -import Data.Char +import qualified Data.Vector as Vector -- | Parameters used when rendering messages data MessageRendererParams = MessageRendererParams @@ -45,6 +47,7 @@ , rendUserSigils :: [Char] -- ^ sender sigils , rendNicks :: [Identifier] -- ^ nicknames to highlight , rendMyNicks :: [Identifier] -- ^ nicknames to highlight in red + , rendPalette :: Palette -- ^ nick color palette } -- | Default 'MessageRenderParams' with no sigils or nicknames specified @@ -54,6 +57,7 @@ , rendUserSigils = "" , rendNicks = [] , rendMyNicks = [] + , rendPalette = defaultPalette } -- | Construct a message given the time the message was received and its @@ -62,18 +66,18 @@ ZonedTime {- ^ time of message -} -> MessageRendererParams -> MessageBody -> Image msgImage when params body = horizCat - [ timeImage when + [ timeImage (rendPalette params) when , statusMsgImage (rendStatusMsg params) - , bodyImage NormalRender (rendUserSigils params) (rendMyNicks params) (rendNicks params) body + , bodyImage NormalRender params body ] -- | Construct a message given the time the message was received and its -- render parameters using a detailed view. detailedMsgImage :: ZonedTime -> MessageRendererParams -> MessageBody -> Image detailedMsgImage when params body = horizCat - [ datetimeImage when + [ datetimeImage (rendPalette params) when , statusMsgImage (rendStatusMsg params) - , bodyImage DetailedRender (rendUserSigils params) (rendMyNicks params) (rendNicks params) body + , bodyImage DetailedRender params body ] -- | Render the sigils for a restricted message. @@ -90,13 +94,11 @@ -- highlight. bodyImage :: RenderMode -> - [Char] {- ^ sigils -} -> - [Identifier] {- ^ my nicknames -} -> - [Identifier] {- ^ nicknames to highlight -} -> + MessageRendererParams -> MessageBody -> Image -bodyImage rm modes myNicks nicks body = +bodyImage rm params body = case body of - IrcBody irc -> ircLineImage rm modes myNicks nicks irc + IrcBody irc -> ircLineImage rm params irc ErrorBody ex -> string defAttr ("Exception: " ++ show ex) ExitBody -> string defAttr "Thread finished" @@ -105,9 +107,9 @@ -- @ -- 23:15 -- @ -timeImage :: ZonedTime -> Image -timeImage - = string (withForeColor defAttr brightBlack) +timeImage :: Palette -> ZonedTime -> Image +timeImage palette + = string (view palTime palette) . formatTime defaultTimeLocale "%R " -- | Render a 'ZonedTime' as full date and time user quiet attributes @@ -115,9 +117,9 @@ -- @ -- 2016-07-24 23:15:10 -- @ -datetimeImage :: ZonedTime -> Image -datetimeImage - = string (withForeColor defAttr brightBlack) +datetimeImage :: Palette -> ZonedTime -> Image +datetimeImage palette + = string (view palTime palette) . formatTime defaultTimeLocale "%F %T " -- | Level of detail to use when rendering @@ -125,20 +127,19 @@ = NormalRender -- ^ only render nicknames | DetailedRender -- ^ render full user info --- | The attribute to be used for "quiet" content -quietAttr :: Attr -quietAttr = withForeColor defAttr brightBlack - -- | Render a chat message given a rendering mode, the sigils of the user -- who sent the message, and a list of nicknames to highlight. ircLineImage :: RenderMode -> - [Char] {- ^ sigils (e.g. \@+) -} -> - [Identifier] {- ^ my nicknames to highlight -} -> - [Identifier] {- ^ nicknames to highlight -} -> + MessageRendererParams -> IrcMsg -> Image -ircLineImage rm sigils myNicks nicks body = - let detail img = +ircLineImage rm !rp body = + let quietAttr = view palMeta pal + pal = rendPalette rp + sigils = rendUserSigils rp + myNicks = rendMyNicks rp + nicks = rendNicks rp + detail img = case rm of NormalRender -> emptyImage DetailedRender -> img @@ -146,78 +147,78 @@ case body of Nick old new -> detail (string quietAttr "nick ") <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks old <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks old <|> string defAttr " became " <|> - coloredIdentifier myNicks new + coloredIdentifier pal myNicks new Join nick _chan -> string quietAttr "join " <|> - coloredUserInfo rm myNicks nick + coloredUserInfo pal rm myNicks nick Part nick _chan mbreason -> string quietAttr "part " <|> - coloredUserInfo rm myNicks nick <|> + coloredUserInfo pal rm myNicks nick <|> foldMap (\reason -> string quietAttr " (" <|> parseIrcText reason <|> string quietAttr ")") mbreason Quit nick mbreason -> string quietAttr "quit " <|> - coloredUserInfo rm myNicks nick <|> + coloredUserInfo pal rm myNicks nick <|> foldMap (\reason -> string quietAttr " (" <|> parseIrcText reason <|> string quietAttr ")") mbreason Kick kicker _channel kickee reason -> detail (string quietAttr "kick ") <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks kicker <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks kicker <|> string defAttr " kicked " <|> - coloredIdentifier myNicks kickee <|> + coloredIdentifier pal myNicks kickee <|> string defAttr ": " <|> parseIrcText reason Topic src _dst txt -> - coloredUserInfo rm myNicks src <|> + coloredUserInfo pal rm myNicks src <|> string defAttr " changed topic to " <|> parseIrcText txt Notice src _dst txt -> detail (string quietAttr "note ") <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks src <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks src <|> string (withForeColor defAttr red) ": " <|> - parseIrcTextWithNicks myNicks nicks txt + parseIrcTextWithNicks pal myNicks nicks txt Privmsg src _dst txt -> detail (string quietAttr "chat ") <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks src <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks src <|> string defAttr ": " <|> - parseIrcTextWithNicks myNicks nicks txt + parseIrcTextWithNicks pal myNicks nicks txt Ctcp src _dst "ACTION" txt -> detail (string quietAttr "actp ") <|> string (withForeColor defAttr blue) "* " <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks src <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks src <|> string defAttr " " <|> - parseIrcTextWithNicks myNicks nicks txt + parseIrcTextWithNicks pal myNicks nicks txt CtcpNotice src _dst "ACTION" txt -> detail (string quietAttr "actn ") <|> string (withForeColor defAttr red) "* " <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks src <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks src <|> string defAttr " " <|> - parseIrcTextWithNicks myNicks nicks txt + parseIrcTextWithNicks pal myNicks nicks txt Ctcp src _dst cmd txt -> detail (string quietAttr "ctcp ") <|> string (withForeColor defAttr blue) "! " <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks src <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks src <|> string defAttr " " <|> parseIrcText cmd <|> separatorImage <|> @@ -226,8 +227,8 @@ CtcpNotice src _dst cmd txt -> detail (string quietAttr "ctcp ") <|> string (withForeColor defAttr red) "! " <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks src <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks src <|> string defAttr " " <|> parseIrcText cmd <|> separatorImage <|> @@ -240,7 +241,7 @@ string defAttr "PONG " <|> separatedParams params Error reason -> - string (withForeColor defAttr red) "ERROR " <|> + string (view palError pal) "ERROR " <|> parseIrcText reason Reply code params -> @@ -253,26 +254,36 @@ NormalRender -> drop 1 UnknownMsg irc -> - maybe emptyImage (\ui -> coloredUserInfo rm myNicks ui <|> char defAttr ' ') + maybe emptyImage (\ui -> coloredUserInfo pal rm myNicks ui <|> char defAttr ' ') (view msgPrefix irc) <|> text' defAttr (view msgCommand irc) <|> char defAttr ' ' <|> separatedParams (view msgParams irc) Cap cmd args -> - string defAttr (show cmd) <|> - char defAttr ' ' <|> + text' (withForeColor defAttr magenta) (renderCapCmd cmd) <|> + text' defAttr ": " <|> separatedParams args Authenticate{} -> string defAttr "AUTHENTICATE ***" Mode nick _chan params -> detail (string quietAttr "mode ") <|> - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo rm myNicks nick <|> + string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks nick <|> string defAttr " set mode: " <|> separatedParams params +renderCapCmd :: CapCmd -> Text +renderCapCmd cmd = + case cmd of + CapLs -> "caps available" + CapList -> "caps active" + CapAck -> "caps acknowledged" + CapNak -> "caps rejected" + CapEnd -> "caps finished" -- server shouldn't send this + CapReq -> "caps requested" -- server shouldn't send this + separatorImage :: Image separatorImage = char (withForeColor defAttr blue) '·' @@ -298,71 +309,91 @@ -- | Render a nickname in its hash-based color. -coloredIdentifier :: [Identifier] {- ^ my nicknames -} -> Identifier -> Image -coloredIdentifier myNicks ident = +coloredIdentifier :: + Palette -> + [Identifier] {- ^ my nicknames -} -> + Identifier -> + Image +coloredIdentifier palette myNicks ident = text' (withForeColor defAttr color) (idText ident) where color | ident `elem` myNicks = red - | otherwise = identifierColor ident + | otherwise = v Vector.! i + v = _palNicks palette + i = hash ident `mod` Vector.length v + -- | Render an a full user. In normal mode only the nickname will be rendered. -- If detailed mode the full user info including the username and hostname parts -- will be rendered. The nickname will be colored. -coloredUserInfo :: RenderMode -> [Identifier] -> UserInfo -> Image -coloredUserInfo NormalRender myNicks ui = coloredIdentifier myNicks (userNick ui) -coloredUserInfo DetailedRender myNicks ui = horizCat - [ coloredIdentifier myNicks (userNick ui) - , foldMap (\user -> char defAttr '!' <|> text' quietAttr user) (userName ui) - , foldMap (\host -> char defAttr '@' <|> text' quietAttr host) (userHost ui) - ] +coloredUserInfo :: + Palette -> + RenderMode -> + [Identifier] {- ^ my nicks -} -> + UserInfo -> Image +coloredUserInfo palette NormalRender myNicks ui = + coloredIdentifier palette myNicks (userNick ui) +coloredUserInfo palette DetailedRender myNicks !ui = + horizCat + [ coloredIdentifier palette myNicks (userNick ui) + , aux '!' (userName ui) + , aux '@' (userHost ui) + ] + where + quietAttr = view palMeta palette + aux x xs + | Text.null xs = emptyImage + | otherwise = char defAttr x <|> text' quietAttr xs -- | Render an identifier without using colors. This is useful for metadata. -quietIdentifier :: Identifier -> Image -quietIdentifier ident = - text' (withForeColor defAttr brightBlack) (idText ident) +quietIdentifier :: Palette -> Identifier -> Image +quietIdentifier palette ident = + text' (view palMeta palette) (idText ident) -- | Parse message text to construct an image. If the text has formatting -- control characters in it then the text will be rendered according to -- the formatting codes. Otherwise the nicknames in the message are -- highlighted. parseIrcTextWithNicks :: + Palette -> [Identifier] {- ^ my nicks -} -> [Identifier] {- ^ other nicks -} -> Text -> Image -parseIrcTextWithNicks myNicks nicks txt +parseIrcTextWithNicks palette myNicks nicks txt | Text.any isControl txt = parseIrcText txt - | otherwise = highlightNicks myNicks nicks txt + | otherwise = highlightNicks palette myNicks nicks txt -- | Given a list of nicknames and a chat message, this will generate -- an image where all of the occurrences of those nicknames are colored. highlightNicks :: + Palette -> [Identifier] {- ^ my nicks -} -> [Identifier] {- ^ other nicks -} -> Text -> Image -highlightNicks myNicks nicks txt = horizCat (highlight1 <$> txtParts) +highlightNicks palette myNicks nicks txt = horizCat (highlight1 <$> txtParts) where nickSet = HashSet.fromList nicks txtParts = nickSplit txt highlight1 part - | HashSet.member partId nickSet = coloredIdentifier myNicks partId + | HashSet.member partId nickSet = coloredIdentifier palette myNicks partId | otherwise = text' defAttr part where partId = mkId part -- | Returns image and identifier to be used when collapsing metadata -- messages. -metadataImg :: IrcMsg -> Maybe (Image, Maybe Identifier) -metadataImg msg = +metadataImg :: Palette -> IrcMsg -> Maybe (Image, Maybe Identifier) +metadataImg palette msg = case msg of Quit who _ -> Just (char (withForeColor defAttr red ) 'x', Just (userNick who)) Part who _ _ -> Just (char (withForeColor defAttr red ) '-', Just (userNick who)) Join who _ -> Just (char (withForeColor defAttr green) '+', Just (userNick who)) Ctcp who _ cmd _ | cmd /= "ACTION" -> Just (char (withForeColor defAttr white) 'C', Just (userNick who)) - Nick old new -> Just (quietIdentifier (userNick old) <|> + Nick old new -> Just (quietIdentifier palette (userNick old) <|> char (withForeColor defAttr yellow) '-' <|> - quietIdentifier new, Nothing) + quietIdentifier palette new, Nothing) _ -> Nothing -- | Image used when treating ignored chat messages as metadata diff --git a/src/Client/Image/Palette.hs b/src/Client/Image/Palette.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/Palette.hs @@ -0,0 +1,75 @@ +{-# Language TemplateHaskell #-} +{-| +Module : Client.Image.Palette +Description : Palette of colors used to render the UI +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides names for all of the colors used in the UI. +-} +module Client.Image.Palette + ( + -- * Palette type + Palette(..) + , palNicks + , palTime + , palMeta + , palSigil + , palLabel + , palLatency + , palWindowName + , palError + , palTextBox + , palActivity + , palMention + + -- * Defaults + , defaultPalette + ) where + +import Control.Lens +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Graphics.Vty.Attributes + +-- | Color palette used for rendering the client UI +data Palette = Palette + { _palNicks :: Vector Color -- ^ colors for highlighting nicknames + , _palTime :: Attr -- ^ color of message timestamps + , _palMeta :: Attr -- ^ color of coalesced metadata + , _palSigil :: Attr -- ^ color of sigils (e.g. @+) + , _palLabel :: Attr -- ^ color of information labels + , _palLatency :: Attr -- ^ color of ping latency + , _palWindowName :: Attr -- ^ color of window name + , _palError :: Attr -- ^ color of error messages + , _palTextBox :: Attr -- ^ color of textbox markers + , _palActivity :: Attr -- ^ color of window name with activity + , _palMention :: Attr -- ^ color of window name with mention + } + deriving Show + +makeLenses ''Palette + +-- | Default UI colors that look nice in my dark solarized color scheme +defaultPalette :: Palette +defaultPalette = Palette + { _palNicks = defaultNickColorPalette + , _palTime = withForeColor defAttr brightBlack + , _palMeta = withForeColor defAttr brightBlack + , _palSigil = withForeColor defAttr cyan + , _palLabel = withForeColor defAttr green + , _palLatency = withForeColor defAttr yellow + , _palWindowName = withForeColor defAttr cyan + , _palError = withForeColor defAttr red + , _palTextBox = withForeColor defAttr brightBlack + , _palActivity = withForeColor defAttr green + , _palMention = withForeColor defAttr red + } + +-- | Default nick highlighting colors that look nice in my dark solarized +-- color scheme. +defaultNickColorPalette :: Vector Color +defaultNickColorPalette = Vector.fromList + [cyan, magenta, green, yellow, blue, + brightCyan, brightMagenta, brightGreen, brightBlue] diff --git a/src/Client/Image/UserList.hs b/src/Client/Image/UserList.hs --- a/src/Client/Image/UserList.hs +++ b/src/Client/Image/UserList.hs @@ -11,8 +11,10 @@ module Client.Image.UserList where import Client.ChannelState +import Client.Configuration import Client.ConnectionState import Client.Image.Message +import Client.Image.Palette import Client.State import Control.Lens import qualified Data.HashMap.Strict as HashMap @@ -30,18 +32,26 @@ Identifier {- ^ Focused channel name -} -> ClientState -> [Image] userListImages network channel st = + case preview (clientConnection network) st of + Just cs -> userListImages' cs channel st + Nothing -> [text' (view palError pal) "No connection"] + where + pal = view (clientConfig . configPalette) st + +userListImages' :: ConnectionState -> Identifier -> ClientState -> [Image] +userListImages' cs channel st = [countImage, horizCat (intersperse gap (map renderUser usersList))] where - countImage = text' (withForeColor defAttr green) "Users:" <|> + countImage = text' (view palLabel pal) "Users:" <|> sigilCountImage matcher = clientMatcher st - myNicks = toListOf (clientConnection network . csNick) st + myNicks = toListOf csNick cs renderUser (ident, sigils) = - string (withForeColor defAttr cyan) sigils <|> - coloredIdentifier myNicks ident + string (view palSigil pal) sigils <|> + coloredIdentifier pal myNicks ident gap = char defAttr ' ' @@ -55,47 +65,54 @@ [ (take 1 sigil, 1::Int) | (_,sigil) <- usersList ] sigilCountImage = horizCat - [ string (withForeColor defAttr cyan) (' ':sigil) <|> + [ string (view palSigil pal) (' ':sigil) <|> string defAttr (show n) | (sigil,n) <- Map.toList sigilCounts ] + pal = view (clientConfig . configPalette) st + usersHashMap = - view ( clientConnection network - . csChannels . ix channel - . chanUsers ) st + view (csChannels . ix channel . chanUsers) cs -- | Render lines for detailed channel user list which shows full user info. userInfoImages :: NetworkName {- ^ Focused network name -} -> Identifier {- ^ Focused channel name -} -> ClientState -> [Image] -userInfoImages network channel st = renderEntry <$> usersList +userInfoImages network channel st = + case preview (clientConnection network) st of + Just cs -> userInfoImages' cs channel st + Nothing -> [text' (view palError pal) "No connection"] where + pal = view (clientConfig . configPalette) st + +userInfoImages' :: ConnectionState -> Identifier -> ClientState -> [Image] +userInfoImages' cs channel st = renderEntry <$> usersList + where matcher = clientMatcher st - myNicks = toListOf (clientConnection network . csNick) st + myNicks = toListOf csNick cs + pal = view (clientConfig . configPalette) st + renderEntry (info, sigils) = - string (withForeColor defAttr cyan) sigils <|> - coloredUserInfo DetailedRender myNicks info + string (view palSigil pal) sigils <|> + coloredUserInfo pal DetailedRender myNicks info matcher' (info,sigils) = matcher (Text.pack sigils `Text.append` renderUserInfo info) - userInfos = view (clientConnection network . csUsers) st + userInfos = view csUsers cs toInfo nick = case view (at nick) userInfos of - Just (UserAndHost n h) -> UserInfo nick (Just n) (Just h) - Nothing -> UserInfo nick Nothing Nothing + Just (UserAndHost n h) -> UserInfo nick n h + Nothing -> UserInfo nick "" "" usersList = sortBy (flip (comparing (userNick . fst))) $ filter matcher' $ map (over _1 toInfo) $ HashMap.toList usersHashMap - usersHashMap = - view ( clientConnection network - . csChannels . ix channel - . chanUsers ) st + usersHashMap = view (csChannels . ix channel . chanUsers) cs diff --git a/src/Client/ServerSettings.hs b/src/Client/ServerSettings.hs --- a/src/Client/ServerSettings.hs +++ b/src/Client/ServerSettings.hs @@ -36,6 +36,7 @@ , ssChanservChannels , ssFloodPenalty , ssFloodThreshold + , ssMessageHooks -- * Load function , loadDefaultServerSettings @@ -73,6 +74,7 @@ , _ssChanservChannels :: ![Identifier] -- ^ Channels with chanserv permissions , _ssFloodPenalty :: !Rational -- ^ Flood limiter penalty (seconds) , _ssFloodThreshold :: !Rational -- ^ Flood limited threshold (seconds) + , _ssMessageHooks :: ![Text] -- ^ Initial message hooks } deriving Show @@ -107,4 +109,5 @@ , _ssChanservChannels = [] , _ssFloodPenalty = 2 -- RFC 1459 defaults , _ssFloodThreshold = 10 + , _ssMessageHooks = [] } diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -69,6 +69,7 @@ import Client.ConnectionState import qualified Client.EditBox as Edit import Client.Image.Message +import Client.Image.Palette import Client.Message import Client.NetworkConnection import Client.ServerSettings @@ -230,8 +231,11 @@ , rendUserSigils = computeMsgLineSigils network channel' msg st , rendNicks = channelUserList network channel' st , rendMyNicks = myNicks + , rendPalette = palette } + palette = view (clientConfig . configPalette) st + -- on failure returns mempty/"" possibleStatusModes = view (clientConnection network . csStatusMsg) st (statusModes, channel') = splitStatusMsgModes possibleStatusModes channel @@ -262,12 +266,15 @@ Notice _ tgt txt | isMe tgt -> WLImportant | otherwise -> checkTxt txt - Ctcp _ _ _ _ -> WLNormal + Ctcp _ tgt "ACTION" txt + | isMe tgt -> WLImportant + | otherwise -> checkTxt txt + Ctcp{} -> WLNormal Part who _ _ | isMe (userNick who) -> WLImportant | otherwise -> WLBoring Kick _ _ kicked _ | isMe kicked -> WLImportant | otherwise -> WLNormal - Error{} -> WLImportant + Error{} -> WLImportant Reply cmd _ -> case replyCodeType (replyCodeInfo cmd) of ErrorReply -> WLImportant @@ -308,7 +315,8 @@ (addToWindow WLBoring wl) st') st chans where - wl = toWindowLine' msg + pal = view (clientConfig . configPalette) st + wl = toWindowLine' pal msg chans = user : case preview (clientConnection network . csChannels) st of Nothing -> [] @@ -356,7 +364,8 @@ st where network = view msgNetwork msg - wl = toWindowLine' msg + pal = view (clientConfig . configPalette) st + wl = toWindowLine' pal msg toWindowLine :: MessageRendererParams -> ClientMessage -> WindowLine toWindowLine params msg = WindowLine @@ -366,8 +375,8 @@ , _wlFullImage = force $ detailedMsgImage (view msgTime msg) params (view msgBody msg) } -toWindowLine' :: ClientMessage -> WindowLine -toWindowLine' = toWindowLine defaultRenderParams +toWindowLine' :: Palette -> ClientMessage -> WindowLine +toWindowLine' pal = toWindowLine defaultRenderParams { rendPalette = pal } clientTick :: ClientState -> ClientState clientTick = set clientBell False . markSeen @@ -379,34 +388,38 @@ FocusMessages -> overStrict (clientWindows . ix (view clientFocus st)) windowSeen st _ -> st +-- | Add the textbox input to the edit history and clear the textbox. consumeInput :: ClientState -> ClientState consumeInput = over clientTextBox Edit.success +-- | Step focus to the next window when on message view. Otherwise +-- switch to message view. advanceFocus :: ClientState -> ClientState -advanceFocus st - | view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st - | otherwise = - case Map.split oldFocus windows of - (l,r) - | Just ((k,_),_) <- Map.minViewWithKey r -> success k - | Just ((k,_),_) <- Map.minViewWithKey l -> success k - | otherwise -> st - where - success x = set clientScroll 0 - $ set clientFocus x st - oldFocus = view clientFocus st - windows = view clientWindows st +advanceFocus = stepFocus False +-- | Step focus to the previous window when on message view. Otherwise +-- switch to message view. retreatFocus :: ClientState -> ClientState -retreatFocus st +retreatFocus = stepFocus True + +-- | Step focus to the next window when on message view. Otherwise +-- switch to message view. Reverse the step order when argument is 'True'. +stepFocus :: Bool {- ^ reversed -} -> ClientState -> ClientState +stepFocus isReversed st | view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st - | otherwise = - case Map.split oldFocus windows of - (l,r) - | Just ((k,_),_) <- Map.maxViewWithKey l -> success k - | Just ((k,_),_) <- Map.maxViewWithKey r -> success k - | otherwise -> st + + | isReversed, Just ((k,_),_) <- Map.maxViewWithKey l = success k + | isReversed, Just ((k,_),_) <- Map.maxViewWithKey r = success k + + | isForward , Just ((k,_),_) <- Map.minViewWithKey r = success k + | isForward , Just ((k,_),_) <- Map.minViewWithKey l = success k + + | otherwise = st where + isForward = not isReversed + + (l,r) = Map.split oldFocus windows + success x = set clientScroll 0 $ set clientFocus x st oldFocus = view clientFocus st diff --git a/src/Client/WordCompletion.hs b/src/Client/WordCompletion.hs --- a/src/Client/WordCompletion.hs +++ b/src/Client/WordCompletion.hs @@ -15,10 +15,8 @@ import Irc.Identifier import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.ByteString as B import qualified Data.Set as Set import Data.Char -import Data.Function import Data.List import Control.Lens import Client.EditBox as Edit @@ -61,9 +59,6 @@ str1 | view Edit.pos box1 == 0 = leadingCase str | otherwise = str in Edit.insertString str1 box1 - -idPrefix :: Identifier -> Identifier -> Bool -idPrefix = B.isPrefixOf `on` idDenote idString :: Identifier -> String idString = Text.unpack . idText diff --git a/src/Config/FromConfig.hs b/src/Config/FromConfig.hs --- a/src/Config/FromConfig.hs +++ b/src/Config/FromConfig.hs @@ -18,6 +18,7 @@ , decodeConfig , runConfigParser , failure + , extendLoc , FromConfig(parseConfig) -- * Section parsing diff --git a/src/Irc/Commands.hs b/src/Irc/Commands.hs --- a/src/Irc/Commands.hs +++ b/src/Irc/Commands.hs @@ -1,7 +1,7 @@ {-# Language OverloadedStrings #-} {-| Module : Irc.Commands -Description : Smart constructors for 'RawIrcMsg' +Description : Smart constructors for "RawIrcMsg" Copyright : (c) Eric Mertens, 2016 License : ISC Maintainer : emertens@gmail.com @@ -23,6 +23,7 @@ , ircNotice , ircPart , ircPass + , ircPing , ircPong , ircPrivmsg , ircQuit @@ -159,6 +160,12 @@ -- | PASS command ircPass :: Text {- ^ password -} -> RawIrcMsg ircPass pass = rawIrcMsg "PASS" [pass] + +-- | PING command +ircPing :: + [Text] {- ^ parameters -} -> + RawIrcMsg +ircPing = rawIrcMsg "PING" -- | PONG command ircPong :: diff --git a/src/Irc/Identifier.hs b/src/Irc/Identifier.hs --- a/src/Irc/Identifier.hs +++ b/src/Irc/Identifier.hs @@ -16,18 +16,23 @@ , idDenote , mkId , idText + , idPrefix ) where -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Char import Data.Function -import Data.Hashable (Hashable (hashWithSalt)) -import Data.Text (Text) -import qualified Data.Text.Encoding as Text +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 Text ByteString +data Identifier = Identifier {-# UNPACK #-} !Text + {-# UNPACK #-} !(PV.Vector Word8) deriving (Read, Show) -- | Equality on normalized identifier @@ -40,8 +45,12 @@ -- | Hash on normalized identifier instance Hashable Identifier where - hashWithSalt s = hashWithSalt s . idDenote + 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)) @@ -52,15 +61,20 @@ -- | Returns the case-normalized 'ByteString' of an 'Identifier' -- which is suitable for comparison or hashing. -idDenote :: Identifier -> ByteString +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 -> ByteString -ircFoldCase = B.map (B.index casemap . fromIntegral) +ircFoldCase :: ByteString -> PV.Vector Word8 +ircFoldCase = PV.fromList . map (\i -> casemap PV.! fromIntegral i) . B.unpack -casemap :: ByteString +casemap :: PV.Vector Word8 casemap - = B8.pack + = PV.fromList + $ map (fromIntegral . ord) $ ['\x00'..'`'] ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^" ++ ['\x7f'..'\xff'] diff --git a/src/Irc/Message.hs b/src/Irc/Message.hs --- a/src/Irc/Message.hs +++ b/src/Irc/Message.hs @@ -71,15 +71,17 @@ | 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 "REQ" = Just CapReq 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'. @@ -192,7 +194,7 @@ Pong{} -> TargetHidden Error{} -> TargetNetwork Cap{} -> TargetNetwork - Reply {} -> TargetNetwork + Reply{} -> TargetNetwork -- | 'UserInfo' of the user responsible for a message. msgActor :: IrcMsg -> Maybe UserInfo diff --git a/src/Irc/RawIrcMsg.hs b/src/Irc/RawIrcMsg.hs --- a/src/Irc/RawIrcMsg.hs +++ b/src/Irc/RawIrcMsg.hs @@ -18,8 +18,9 @@ ( -- * Low-level IRC messages RawIrcMsg(..) + , TagEntry(..) , rawIrcMsg - , msgServerTime + , msgTags , msgPrefix , msgCommand , msgParams @@ -27,6 +28,8 @@ -- * Text format for IRC messages , parseRawIrcMsg , renderRawIrcMsg + , prefixParser + , simpleTokenParser -- * Permissive text decoder , asUtf8 @@ -40,12 +43,12 @@ 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.Time (UTCTime, parseTimeM, defaultTimeLocale) import Data.Vector (Vector) import qualified Data.Vector as Vector @@ -64,13 +67,19 @@ -- -- @:prefix COMMAND param0 param1 param2 .. paramN@ data RawIrcMsg = RawIrcMsg - { _msgServerTime :: Maybe UTCTime -- ^ Time from znc.in/server-time-iso extension + { _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 @@ -110,15 +119,15 @@ -- invalid messages! rawIrcMsgParser :: Parser RawIrcMsg rawIrcMsgParser = - do time <- guarded (string "@time=") timeParser - prefix <- guarded (char ':') prefixParser + do tags <- fromMaybe [] <$> guarded '@' tagsParser + prefix <- guarded ':' prefixParser cmd <- simpleTokenParser params <- paramsParser maxMiddleParams return $! RawIrcMsg - { _msgServerTime = time - , _msgPrefix = prefix - , _msgCommand = cmd - , _msgParams = params + { _msgTags = tags + , _msgPrefix = prefix + , _msgCommand = cmd + , _msgParams = params } -- | Parse the list of parameters in a raw message. The RFC @@ -129,8 +138,8 @@ do end <- P.atEnd if end then return [] - else do mbColon <- optional (char ':') - if n == 0 || isJust mbColon + else do isColon <- optionalChar ':' + if isColon || n == 0 then finalParam else middleParam @@ -146,18 +155,41 @@ xs <- paramsParser (n-1) return (x:xs) --- | Parse the server-time message prefix: --- @time=2015-03-04T22:29:04.064Z -timeParser :: Parser UTCTime -timeParser = - do timeBytes <- simpleTokenParser - case parseIrcTime (Text.unpack timeBytes) of - Nothing -> fail "Bad server-time format" - Just t -> return t +tagsParser :: Parser [TagEntry] +tagsParser = tagParser `sepBy1` char ';' <* char ' ' -parseIrcTime :: String -> Maybe UTCTime -parseIrcTime = parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Z" +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 @@ -170,17 +202,15 @@ P.skipWhile (== ' ') return $! Text.copy xs --- | Take the bytes up to the next space delimiter. --- If the first character of this token is a ':' --- then take the whole remaining bytestring - - -- | Serialize a structured IRC protocol message back into its wire -- format. This command adds the required trailing newline. renderRawIrcMsg :: RawIrcMsg -> ByteString -renderRawIrcMsg m = L.toStrict $ Builder.toLazyByteString $ - maybe mempty renderPrefix (view msgPrefix m) +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' @@ -190,12 +220,26 @@ rawIrcMsg :: Text {- ^ command -} -> [Text] {- ^ parameters -} -> RawIrcMsg -rawIrcMsg = RawIrcMsg Nothing Nothing +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 ' ' +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 @@ -208,16 +252,19 @@ = Builder.char8 ' ' <> Text.encodeUtf8Builder x <> buildParams xs buildParams [] = mempty --- | When the first parser succeeds require the second parser to succeed. --- Otherwise return Nothing -guarded :: Parser a -> Parser b -> Parser (Maybe b) -guarded pa pb = - do mb <- optional pa - case mb of - Nothing -> return Nothing - Just{} -> fmap Just pb +-- | 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. @@ -226,6 +273,7 @@ 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 ] diff --git a/src/Irc/UserInfo.hs b/src/Irc/UserInfo.hs --- a/src/Irc/UserInfo.hs +++ b/src/Irc/UserInfo.hs @@ -28,9 +28,9 @@ -- | 'UserInfo' packages a nickname along with the username and hsotname -- if they are known in the current context. data UserInfo = UserInfo - { userNick :: !Identifier -- ^ nickname - , userName :: !(Maybe Text) -- ^ username - , userHost :: !(Maybe Text) -- ^ hostname + { userNick :: {-# UNPACK #-} !Identifier -- ^ nickname + , userName :: {-# UNPACK #-} !Text -- ^ username, empty when missing + , userHost :: {-# UNPACK #-} !Text -- ^ hostname, empty when missing } deriving (Read, Show) @@ -40,9 +40,10 @@ -- | Render 'UserInfo' as @nick!username\@hostname@ renderUserInfo :: UserInfo -> Text -renderUserInfo u = idText (userNick u) - <> maybe "" ("!" <>) (userName u) - <> maybe "" ("@" <>) (userHost u) +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 @@ -50,8 +51,8 @@ parseUserInfo :: Text -> UserInfo parseUserInfo x = UserInfo { userNick = mkId nick - , userName = if Text.null user then Nothing else Just $! Text.drop 1 user - , userHost = if Text.null host then Nothing else Just $! Text.drop 1 host + , userName = Text.drop 1 user + , userHost = Text.drop 1 host } where (nickuser,host) = Text.break (=='@') x