glirc 2.4 → 2.5
raw patch · 28 files changed
+962/−341 lines, 28 filesdep +primitive
Dependencies added: primitive
Files
- ChangeLog.md +8/−0
- README.md +39/−0
- glirc.cabal +7/−2
- src/Client/Commands.hs +12/−13
- src/Client/Configuration.hs +51/−1
- src/Client/Configuration/Colors.hs +91/−0
- src/Client/Connect.hs +27/−19
- src/Client/ConnectionState.hs +34/−15
- src/Client/EventLoop.hs +59/−32
- src/Client/Hook.hs +67/−0
- src/Client/Hook/Znc/Buffextras.hs +83/−0
- src/Client/Hooks.hs +29/−0
- src/Client/IdentifierColors.hs +0/−36
- src/Client/Image.hs +35/−20
- src/Client/Image/ChannelInfo.hs +11/−6
- src/Client/Image/MaskList.hs +8/−3
- src/Client/Image/Message.hs +111/−80
- src/Client/Image/Palette.hs +75/−0
- src/Client/Image/UserList.hs +36/−19
- src/Client/ServerSettings.hs +3/−0
- src/Client/State.hs +39/−26
- src/Client/WordCompletion.hs +0/−5
- src/Config/FromConfig.hs +1/−0
- src/Irc/Commands.hs +8/−1
- src/Irc/Identifier.hs +27/−13
- src/Irc/Message.hs +4/−2
- src/Irc/RawIrcMsg.hs +88/−40
- src/Irc/UserInfo.hs +9/−8
ChangeLog.md view
@@ -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`
README.md view
@@ -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.
glirc.cabal view
@@ -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,
src/Client/Commands.hs view
@@ -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 --
src/Client/Configuration.hs view
@@ -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)
+ src/Client/Configuration/Colors.hs view
@@ -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 )+ ]
src/Client/Connect.hs view
@@ -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"
src/Client/ConnectionState.hs view
@@ -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
src/Client/EventLoop.hs view
@@ -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)
+ src/Client/Hook.hs view
@@ -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
+ src/Client/Hook/Znc/Buffextras.hs view
@@ -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
+ src/Client/Hooks.hs view
@@ -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)+ ]
− src/Client/IdentifierColors.hs
@@ -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]
src/Client/Image.hs view
@@ -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
src/Client/Image/ChannelInfo.hs view
@@ -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) ]
src/Client/Image/MaskList.hs view
@@ -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
src/Client/Image/Message.hs view
@@ -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
+ src/Client/Image/Palette.hs view
@@ -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]
src/Client/Image/UserList.hs view
@@ -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
src/Client/ServerSettings.hs view
@@ -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 = [] }
src/Client/State.hs view
@@ -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
src/Client/WordCompletion.hs view
@@ -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
src/Config/FromConfig.hs view
@@ -18,6 +18,7 @@ , decodeConfig , runConfigParser , failure+ , extendLoc , FromConfig(parseConfig) -- * Section parsing
src/Irc/Commands.hs view
@@ -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 ::
src/Irc/Identifier.hs view
@@ -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']
src/Irc/Message.hs view
@@ -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
src/Irc/RawIrcMsg.hs view
@@ -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 ]
src/Irc/UserInfo.hs view
@@ -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