glirc 2.1 → 2.2
raw patch · 25 files changed
+742/−277 lines, 25 filesdep +deepseqdep −arraydep ~config-value
Dependencies added: deepseq
Dependencies removed: array
Dependency ranges changed: config-value
Files
- ChangeLog.md +11/−0
- README.md +47/−13
- glirc.cabal +28/−22
- src/Client/ChannelState.hs +2/−0
- src/Client/Commands.hs +158/−19
- src/Client/Configuration.hs +30/−14
- src/Client/ConnectionState.hs +41/−15
- src/Client/EventLoop.hs +6/−5
- src/Client/IdentifierColors.hs +10/−13
- src/Client/Image.hs +3/−1
- src/Client/Image/ChannelInfo.hs +0/−3
- src/Client/Image/MaskList.hs +7/−3
- src/Client/Image/Message.hs +33/−2
- src/Client/Image/UserList.hs +15/−4
- src/Client/MircFormatting.hs +20/−16
- src/Client/ServerSettings.hs +3/−2
- src/Client/State.hs +122/−34
- src/Client/Window.hs +2/−2
- src/Config/FromConfig.hs +15/−1
- src/Irc/Commands.hs +57/−1
- src/Irc/Message.hs +52/−29
- src/Irc/Modes.hs +1/−1
- src/Irc/RateLimit.hs +9/−11
- src/Irc/RawIrcMsg.hs +49/−65
- src/Main.hs +21/−1
ChangeLog.md view
@@ -1,5 +1,16 @@ # Revision history for glirc2 +## 2.2++* Add commands `/ison`, `/userhost`, `/away`, `/notice`, `/ctcp`, `/links`, `/time`, `/stats`+* Added context-sensitive completion to `/mode`+* Render CTCP messages+* Memory performance improvements+* Improved logic on nick changes+* Support for fractional flood settings+* Fixed VTY formatting bug+* Add counts to the mask and user lists+ ## 2.1 * Add red highlighting for own nick
README.md view
@@ -119,38 +119,72 @@ Commands ======== +Client commands+ * `/exit` - Terminate the client * `/quit` - Gracefully terminate connection to the current server-* `/disconnect` - Forcefully terminate connection to the current server * `/connect <hostname>` - Connect to the given hostname+* `/disconnect` - Forcefully terminate connection to the current server * `/reconnect` - Reconnect to the current server++Connection commands++* `/nick <nick>` - Change nickname+* `/away <message>` - Set away status++Window management+ * `/focus <server>` - Change focus to server window * `/focus <server> <channel>` - Change focus to channel window-* `/clear` - <Clear contents of current window+* `/clear` - Clear contents of current window * `/ignore <nick>` - Toggle ignore of a user-* `/quote <raw command>` - Send a raw IRC command to the server++Channel membership+ * `/join <channel>` - Join a channel-* `/mode <mode> <params>` - Change modes on the current channel+* `/part` - Part from current channel++Chat commands+ * `/msg <target> <msg>` - Send a message on the current server to target-* `/nick <nick>` - Change nickname-* `/who <query>` - Perform WHO query (use detailed view to see output)-* `/whois <nick>` - Perform WHOIS query-* `/whowas <nick>` - Perform WHOWAS query-* `/invite <nick>` - Invite a user to the current channel-* `/topic <topic>` - Change the topic+* `/notice <target> <msg>` - Send a notice message on the current server to target+* `/ctcp <target> <command> <args>` - Send a ctcp command on the current server to target+* `/me` - Send action message to channel++Channel management++* `/mode <mode> <params>` - Change modes on the current channel (advanced tab completion) * `/kick <nick>` - Kick a user * `/kickban <nick>` - Kick and ban a user * `/remove` - Gracefully kick a user-* `/me` - Send action message to channel-* `/part` - Part from current channel+* `/topic <topic>` - Change the topic (tab completion for topic)+* `/invite <nick>` - Invite a user to the current channel++Queries++* `/who <query>` - Perform WHO query (use detailed view to see output)+* `/whois <nick>` - Perform WHOIS query+* `/whowas <nick>` - Perform WHOWAS query+* `/ison <nick>` - Perform ISON query+* `/userhost <nick>` - Perform USERHOST query+* `/links <server>` - Perform LINKS query+* `/time` - Perform TIME query+* `/stats <query>` - Perform STATS query++Channel information+ * `/users` - Show channel user list * `/masks <mode>` - Show channel bans(b), quiets(q), exempts(e), or invex(I) * `/channelinfo` - Show channel topic, creation, url -Filters+Window filters * `/grep` - Filter chat messages using a regular expression * `/grepi` - Filter chat messages using a case-insensitive regular expression on the message++Low-level++* `/quote <raw command>` - Send a raw IRC command to the server Keyboard Shortcuts ==================
glirc.cabal view
@@ -1,5 +1,5 @@ name: glirc-version: 2.1+version: 2.2 synopsis: Console IRC client description: Console IRC client license: ISC@@ -10,9 +10,15 @@ category: Network build-type: Custom extra-source-files: ChangeLog.md README.md-cabal-version: >=1.10+cabal-version: >=1.23+homepage: https://github.com/glguy/irc-core+bug-reports: https://github.com/glguy/irc-core/issues tested-with: GHC==8.0.1 +custom-setup+ setup-depends: base >=4.9 && <4.10,+ Cabal >=1.24 && <1.25+ source-repository head type: git location: git://github.com/glguy/irc-core.git@@ -56,33 +62,33 @@ -- other-extensions: build-depends: base >=4.9 && <4.10, async >=2.1 && < 2.2,+ attoparsec >=0.13 && <0.14,+ bytestring >=0.10.8 && <0.11,+ config-value >=0.5 && <0.6, connection >=0.2.5 && <0.3,+ containers >=0.5.7 && <0.6,+ data-default-class >=0.1.2 && <0.2,+ deepseq >=1.4 && <1.5,+ directory >=1.2.6 && <1.3,+ filepath >=1.4.1 && <1.5,+ hashable >=1.2.4 && <1.3,+ lens >=4.14 && <4.15,+ memory >=0.13 && <0.14,+ network >=2.6.2 && <2.7,+ profunctors >=5.2 && <5.3,+ split >=0.2 && <0.3,+ stm >=2.4 && <2.5, text >=1.2.2 && <1.3, text-icu >=0.7 && <0.8,- config-value >=0.4 && <0.5,- bytestring >=0.10.8 && <0.11, time >=1.6 && <1.7,- attoparsec >=0.13 && <0.14,- array >=0.5 && <0.6,- vty >=5.7 && <5.8,- lens >=4.14 && <4.15,- containers >=0.5.7 && <0.6,+ tls >=1.3.8 && <1.4,+ transformers >=0.5.2 && <0.6, unordered-containers >=0.2.7 && <0.3,- hashable >=1.2.4 && <1.3,- network >=2.6.2 && <2.7, vector >=0.11 && <0.12,- tls >=1.3.8 && <1.4,- split >=0.2 && <0.3,- profunctors >=5.2 && <5.3,- x509-system >=1.6.3 && <1.7,- x509-store >=1.6.1 && <1.7,+ vty >=5.7 && <5.8, x509 >=1.6.3 && <1.7,- transformers >=0.5.2 && <0.6,- data-default-class >=0.1.2 && <0.2,- stm >=2.4 && <2.5,- directory >=1.2.6 && <1.3,- memory >=0.13 && <0.14,- filepath >=1.4.1 && <1.5+ x509-store >=1.6.1 && <1.7,+ x509-system >=1.6.3 && <1.7 ghc-options: -threaded -rtsopts hs-source-dirs: src
src/Client/ChannelState.hs view
@@ -52,6 +52,7 @@ import Irc.RawIrcMsg (RawIrcMsg) import Irc.UserInfo +-- | Dynamic information about the state of an IRC channel data ChannelState = ChannelState { _chanTopic :: !Text -- ^ topic text@@ -97,6 +98,7 @@ Functor f => Char {- ^ mode -} -> LensLike' f ChannelState (HashMap Text (Text, UTCTime))+ {- ^ HashMap mask (setby, setwhen) -} chanList mode = chanLists . at mode . non' _Empty -- | Add a user to the user list
src/Client/Commands.hs view
@@ -18,6 +18,7 @@ ) where import Client.ConnectionState+import qualified Client.EditBox as EditBox import Client.Message import Client.ServerSettings import Client.ChannelState@@ -123,14 +124,22 @@ , ("quote" , NetworkCommand cmdQuote simpleNetworkTab) , ("join" , NetworkCommand cmdJoin simpleNetworkTab)- , ("mode" , NetworkCommand cmdMode simpleNetworkTab)+ , ("mode" , NetworkCommand cmdMode tabMode) , ("msg" , NetworkCommand cmdMsg simpleNetworkTab)+ , ("notice" , NetworkCommand cmdNotice simpleNetworkTab)+ , ("ctcp" , NetworkCommand cmdCtcp simpleNetworkTab) , ("nick" , NetworkCommand cmdNick simpleNetworkTab) , ("quit" , NetworkCommand cmdQuit simpleNetworkTab) , ("disconnect", NetworkCommand cmdDisconnect noNetworkTab) , ("who" , NetworkCommand cmdWho simpleNetworkTab) , ("whois" , NetworkCommand cmdWhois simpleNetworkTab) , ("whowas" , NetworkCommand cmdWhowas simpleNetworkTab)+ , ("ison" , NetworkCommand cmdIson simpleNetworkTab)+ , ("userhost" , NetworkCommand cmdUserhost simpleNetworkTab)+ , ("away" , NetworkCommand cmdAway simpleNetworkTab)+ , ("links" , NetworkCommand cmdLinks simpleNetworkTab)+ , ("time" , NetworkCommand cmdTime simpleNetworkTab)+ , ("stats" , NetworkCommand cmdStats simpleNetworkTab) , ("invite" , ChannelCommand cmdInvite simpleChannelTab) , ("topic" , ChannelCommand cmdTopic tabTopic )@@ -215,41 +224,90 @@ entry = ClientMessage { _msgTime = now , _msgNetwork = network- , _msgBody = IrcBody (Action myNick channelId (Text.pack rest))+ , _msgBody = IrcBody (Ctcp myNick channelId "ACTION" (Text.pack rest)) } sendMsg cs (ircPrivmsg channelId actionTxt) commandContinue $ recordChannelMessage network channelId entry $ consumeInput st +-- | Implementation of @/ctcp@+cmdCtcp :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdCtcp network cs st rest =+ case parse of+ Nothing -> commandContinue st+ Just (target, cmd, args) ->+ do let cmdTxt = Text.toUpper (Text.pack cmd)+ argTxt = Text.pack args+ tgtTxt = Text.pack target++ sendMsg cs (ircPrivmsg (mkId tgtTxt) ("\^A" <> cmdTxt <> " " <> argTxt <> "\^A"))+ chatCommand+ (\src tgt -> Ctcp src tgt cmdTxt argTxt)+ tgtTxt+ network cs st+ where+ parse =+ do (target, rest1) <- nextWord rest+ (cmd , args ) <- nextWord rest1+ return (target, cmd, args)++-- | Implementation of @/notice@+cmdNotice :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdNotice network cs st rest =+ case nextWord rest of+ Nothing -> commandContinue st+ Just (target, rest1) ->+ do let restTxt = Text.pack rest1+ tgtTxt = Text.pack target++ sendMsg cs (ircNotice (mkId tgtTxt) restTxt)+ chatCommand+ (\src tgt -> Notice src tgt restTxt)+ tgtTxt+ network cs st+ -- | Implementation of @/msg@ cmdMsg :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult cmdMsg network cs st rest = case nextWord rest of Nothing -> commandContinue st- Just (targetsStr, msgStr) ->- do now <- getZonedTime- let targetsTxt = Text.pack targetsStr- targetTxts = Text.split (==',') targetsTxt- targetIds = mkId <$> targetTxts- msgTxt = Text.pack msgStr- myNick = UserInfo (view csNick cs) Nothing Nothing- entries = [ (targetId,+ Just (target, rest1) ->+ do let restTxt = Text.pack rest1+ tgtTxt = Text.pack target++ sendMsg cs (ircPrivmsg (mkId tgtTxt) restTxt)+ chatCommand+ (\src tgt -> Notice src tgt restTxt)+ tgtTxt+ network cs st++chatCommand ::+ (UserInfo -> Identifier -> IrcMsg) ->+ Text {- ^ target -} ->+ NetworkName ->+ ConnectionState ->+ ClientState ->+ IO CommandResult+chatCommand con targetsTxt network cs st =+ do now <- getZonedTime+ let targetTxts = Text.split (==',') targetsTxt+ targetIds = mkId <$> targetTxts+ myNick = UserInfo (view csNick cs) Nothing Nothing+ entries = [ (targetId, ClientMessage { _msgTime = now , _msgNetwork = network- , _msgBody = IrcBody (Privmsg myNick targetId msgTxt)+ , _msgBody = IrcBody (con myNick targetId) }) | targetId <- targetIds ] - sendMsg cs (ircPrivmsg (mkId targetsTxt) msgTxt)-- let st' = foldl' (\acc (targetId, entry) ->+ st' = foldl' (\acc (targetId, entry) -> recordChannelMessage network targetId entry acc) st entries - commandContinue (consumeInput st')+ commandContinue (consumeInput st') cmdConnect :: ClientState -> String -> IO CommandResult cmdConnect st rest =@@ -296,6 +354,36 @@ do sendMsg cs (ircWhowas (Text.pack <$> words rest)) commandContinue (consumeInput st) +cmdIson :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdIson _ cs st rest =+ do sendMsg cs (ircIson (Text.pack <$> words rest))+ commandContinue (consumeInput st)++cmdUserhost :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdUserhost _ cs st rest =+ do sendMsg cs (ircUserhost (Text.pack <$> words rest))+ commandContinue (consumeInput st)++cmdStats :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdStats _ cs st rest =+ do sendMsg cs (ircStats (Text.pack <$> words rest))+ commandContinue (consumeInput st)++cmdAway :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdAway _ cs st rest =+ do sendMsg cs (ircAway (Text.pack (dropWhile (==' ') rest)))+ commandContinue (consumeInput st)++cmdLinks :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdLinks _ cs st rest =+ do sendMsg cs (ircLinks (Text.pack <$> words rest))+ commandContinue (consumeInput st)++cmdTime :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdTime _ cs st rest =+ do sendMsg cs (ircTime (Text.pack <$> words rest))+ commandContinue (consumeInput st)+ cmdMode :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult cmdMode _ cs st rest = modeCommand (Text.pack <$> words rest) cs st @@ -345,7 +433,12 @@ sendMsg cs cmd commandContinue (consumeInput st) -tabTopic :: Bool -> NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+tabTopic ::+ Bool {- ^ reversed -} ->+ NetworkName ->+ ConnectionState ->+ Identifier {- ^ channel -} ->+ ClientState -> String -> IO CommandResult tabTopic _ _ cs channelId st rest | all isSpace rest@@ -356,6 +449,7 @@ | otherwise = commandContinue st + cmdUsers :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdUsers _ _ _ st _ = commandContinue $ changeSubfocus FocusUsers@@ -385,6 +479,7 @@ cs' <- sendModeration channelId [cmd] cs commandContinueUpdateCS cs' st + cmdKickBan :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdKickBan _ cs channelId st rest = case nextWord rest of@@ -403,9 +498,9 @@ computeBanUserInfo :: Identifier -> ConnectionState -> UserInfo computeBanUserInfo who cs =- case view (csUser who . _2) cs of- Nothing -> UserInfo who (Just "*") (Just "*")- Just host -> UserInfo (mkId "*") (Just "*") (Just host)+ case view (csUser who) cs of+ Nothing -> UserInfo who (Just "*") (Just "*")+ Just (UserAndHost _ host) -> UserInfo (mkId "*") (Just "*") (Just host) cmdRemove :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdRemove _ cs channelId st rest =@@ -503,6 +598,50 @@ commandContinueUpdateCS cs' st _ -> commandContinue st++tabMode :: Bool -> NetworkCommand+tabMode isReversed _ cs st rest =+ case view clientFocus st of++ ChannelFocus _ channel+ | flags:params <- Text.words (Text.pack rest)+ , Just parsedModes <- splitModes (view csModeTypes cs) flags params+ , let parsedModesWithParams =+ [ (pol,mode) | (pol,mode,arg) <- parsedModes, not (Text.null arg) ]+ , (pol,mode):_ <- drop (paramIndex-3) parsedModesWithParams+ , let completions = computeModeCompletion pol mode channel cs+ -> commandContinue+ $ fromMaybe st+ $ clientTextBox (wordComplete id isReversed completions) st++ _ -> commandContinue st++ where+ textBox = view clientTextBox st+ paramIndex = length $ words $ take (view EditBox.pos textBox)+ (view EditBox.content textBox)++-- | Use the *!*@host masks of users for channel lists when setting list modes+--+-- Use the channel's mask list for removing modes+--+-- Use the nick list otherwise+computeModeCompletion :: Bool -> Char -> Identifier -> ConnectionState -> [Identifier]+computeModeCompletion pol mode channel cs+ | mode `elem` view modesLists modeSettings =+ if pol then usermasks else masks+ | otherwise = nicks+ where+ modeSettings = view csModeTypes cs+ nicks = HashMap.keys (view (csChannels . ix channel . chanUsers) cs)++ masks = mkId <$> HashMap.keys (view (csChannels . ix channel . chanLists . ix mode) cs)++ usermasks =+ [ mkId ("*!*@" <> host)+ | nick <- HashMap.keys (view (csChannels . ix channel . chanUsers) cs)+ , UserAndHost _ host <- toListOf (csUsers . ix nick) cs+ ] -- | Predicate for mode commands that can be performed without ops isPublicChannelMode :: (Bool, Char, Text) -> Bool
src/Client/Configuration.hs view
@@ -17,6 +17,7 @@ ( -- * Configuration type Configuration(..)+ , ConfigurationFailure(..) , configDefaults , configServers @@ -41,6 +42,7 @@ import Network.Socket (HostName) import System.Directory import System.FilePath+import System.IO.Error -- | Top-level client configuration information. When connecting to a -- server configuration from '_configServers' is used where possible,@@ -55,7 +57,8 @@ data ConfigurationFailure = ConfigurationParseFailed String- | ConfigurationMalformed Text+ | ConfigurationMalformed String+ | ConfigurationReadFailed String deriving Show instance Exception ConfigurationFailure@@ -65,24 +68,37 @@ do dir <- getAppUserDataDirectory "glirc" return (dir </> "config") +-- | Empty configuration file used when no path is specified+-- and the configuration file is missing.+emptyConfigFile :: Text+emptyConfigFile = "{}\n"+ -- | Load the configuration file defaulting to @~/.glirc/config@.--- This action can throw 'IOError' and 'ConfigurationFailure'--- exceptions. loadConfiguration :: Maybe FilePath {- ^ path to configuration file -} ->- IO Configuration-loadConfiguration mbPath =+ IO (Either ConfigurationFailure Configuration)+loadConfiguration mbPath = try $ do path <- maybe getConfigPath return mbPath- file <- Text.readFile path+ fileRes <- try (Text.readFile path)+ file <- case fileRes of+ Right file -> return file+ Left e | isNothing mbPath+ , isDoesNotExistError e -> return emptyConfigFile+ | otherwise ->+ throwIO (ConfigurationReadFailed (show e))+ def <- loadDefaultServerSettings- case parse file of- Left parseError -> throwIO (ConfigurationParseFailed parseError)- Right rawcfg ->- case runConfigParser (parseConfiguration def rawcfg) of- Left loadError -> throwIO (ConfigurationMalformed loadError)- Right cfg -> return cfg + rawcfg <-+ case parse file of+ Left parseError -> throwIO (ConfigurationParseFailed parseError)+ Right rawcfg -> return rawcfg + case runConfigParser (parseConfiguration def rawcfg) of+ Left loadError -> throwIO (ConfigurationMalformed (Text.unpack loadError))+ Right cfg -> return cfg++ parseConfiguration :: ServerSettings -> Value -> ConfigParser Configuration parseConfiguration def = parseSections $ @@ -133,8 +149,8 @@ _ssSocksPort <- fieldReq' ssSocksPort (sectionOptNum "socks-port") _ssServerCerts <- fieldReq' ssServerCerts (sectionOptStrings "server-certificates") _ssChanservChannels <- fieldReq' ssChanservChannels (sectionOptIdentifiers "chanserv-channels")- _ssFloodPenalty <- fieldReq' ssFloodPenalty (sectionOptNum "flood-penalty")- _ssFloodThreshold <- fieldReq' ssFloodThreshold (sectionOptNum "flood-threshold")+ _ssFloodPenalty <- fieldReq ssFloodPenalty "flood-penalty"+ _ssFloodThreshold <- fieldReq ssFloodThreshold "flood-threshold" return ServerSettings{..} where field l key = field' l (sectionOpt key)
src/Client/ConnectionState.hs view
@@ -40,6 +40,12 @@ , newConnectionState + -- * User information+ , UserAndHost(..)++ -- * Cross-message state+ , Transaction(..)+ -- * Connection predicates , isChannelIdentifier , iHaveOp@@ -95,7 +101,7 @@ , _csStatusMsg :: ![Char] , _csSettings :: !ServerSettings , _csUserInfo :: !UserInfo- , _csUsers :: !(HashMap Identifier (Maybe Text, Maybe Text))+ , _csUsers :: !(HashMap Identifier UserAndHost) , _csModeCount :: !Int , _csNetwork :: !Text , _csNextPingTime :: !(Maybe UTCTime)@@ -103,6 +109,9 @@ } deriving Show +data UserAndHost = UserAndHost {-# UNPACK #-} !Text {-# UNPACK #-} !Text+ deriving Show+ data PingStatus = PingSent !UTCTime | PingLatency !Double -- seconds@@ -277,10 +286,19 @@ doRpl :: ReplyCode -> ZonedTime -> [Text] -> ConnectionState -> ConnectionState doRpl cmd msgWhen args = case cmd of+ RPL_UMODEIS ->+ case args of+ _me:modes:params+ | Just xs <- splitModes defaultUmodeTypes modes params ->+ doMyModes xs+ . set csModes "" -- reset modes+ _ -> id RPL_NOTOPIC -> case args of- _me:chan:_ -> overChannel (mkId chan) (setTopic "" . set chanTopicProvenance Nothing)+ _me:chan:_ -> overChannel+ (mkId chan)+ (setTopic "" . set chanTopicProvenance Nothing) _ -> id RPL_TOPIC ->@@ -415,8 +433,7 @@ -- | These replies are interpreted by the client and should only be shown--- in the detailed view. Any reply interpreted by 'doRpl' should be--- listed here.+-- in the detailed view. squelchReply :: ReplyCode -> Bool squelchReply rpl = case rpl of@@ -436,6 +453,7 @@ RPL_CREATIONTIME -> True RPL_CHANNEL_URL -> True RPL_NOTOPIC -> True+ RPL_UMODEIS -> True RPL_WHOREPLY -> True RPL_ENDOFWHO -> True _ -> False@@ -515,7 +533,7 @@ doMyModes :: [(Bool, Char, Text)] -> ConnectionState -> ConnectionState-doMyModes changes = over csModes $ \modes -> foldl applyOne modes changes+doMyModes changes = over csModes $ \modes -> sort (foldl' applyOne modes changes) where applyOne modes (True, mode, _) | mode `elem` modes = modes@@ -526,8 +544,8 @@ supportedCaps cs = sasl ++ ["multi-prefix", "znc.in/server-time-iso"] where ss = view csSettings cs- sasl = ["sasl" | has ssSaslUsername ss- , has ssSaslPassword ss ]+ sasl = ["sasl" | isJust (view ssSaslUsername ss)+ , isJust (view ssSaslPassword ss) ] doAuthenticate :: Text -> ConnectionState -> ([RawIrcMsg], ConnectionState) doAuthenticate "+" cs@@ -666,12 +684,15 @@ -- Helpers for managing the user list ------------------------------------------------------------------------ -csUser :: Functor f => Identifier -> LensLike' f ConnectionState (Maybe Text, Maybe Text)-csUser i = csUsers . at i . non (Nothing,Nothing)+csUser :: Functor f => Identifier -> LensLike' f ConnectionState (Maybe UserAndHost)+csUser i = csUsers . at i recordUser :: UserInfo -> ConnectionState -> ConnectionState-recordUser !user = set (csUsers . at (userNick user))- (Just (userName user, userHost user))+recordUser user =+ case (userName user, userHost user) of+ (Just u, Just h) -> set (csUsers . at (userNick user))+ (Just (UserAndHost u h))+ _ -> id forgetUser :: Identifier -> ConnectionState -> ConnectionState forgetUser nick = set (csUsers . at nick) Nothing@@ -688,6 +709,7 @@ where keep = has (csChannels . folded . chanUsers . ix nick) cs +-- | Process a list of WHO replies massRegistration :: ConnectionState -> ConnectionState massRegistration cs = set csTransaction NoTransaction@@ -701,15 +723,19 @@ updateUsers users = foldl' updateUser users infos updateUser users !info- | HashSet.member (userNick info) channelUsers =- HashMap.insert (userNick info) (userName info, userHost info) users+ | Just u <- userName info+ , Just h <- userHost info+ , HashSet.member (userNick info) channelUsers =+ HashMap.insert (userNick info) (UserAndHost u h) users | otherwise = users +-- | Timer-based events data TimedAction- = TimedDisconnect- | TimedSendPing+ = TimedDisconnect -- ^ terminate the connection due to timeout+ | TimedSendPing -- ^ transmit a ping to the server deriving (Eq, Ord, Show) +-- | Compute the earliest timed action for a connection, if any nextTimedAction :: ConnectionState -> Maybe (UTCTime, TimedAction) nextTimedAction cs = do runAt <- view csNextPingTime cs
src/Client/EventLoop.hs view
@@ -133,6 +133,7 @@ } in eventLoop $ recordNetworkMessage msg st' + -- | Respond to an IRC protocol line. This will parse the message, updated the -- relevant connection state and update the UI buffers. doNetworkLine ::@@ -169,15 +170,13 @@ -- record messages *before* applying the changes let (msgs, st')- = traverseOf- (clientConnection network)- (applyMessage time irc)- $ recordIrcMessage network target msg- $ st+ = applyMessageToClientState time irc networkId cs+ $ recordIrcMessage network target msg st traverse_ (sendMsg cs) msgs eventLoop st' + -- | Respond to a VTY event. doVtyEvent :: Event -> ClientState -> IO () doVtyEvent vtyEvent st =@@ -191,6 +190,7 @@ $ set clientHeight h st _ -> eventLoop st + -- | Map keyboard inputs to actions in the client doKey :: Key -> [Modifier] -> ClientState -> IO () doKey key modifier st =@@ -218,6 +218,7 @@ [MMeta] -> case key of+ KBS -> changeInput (Edit.killWord True) KChar 'b' -> changeInput Edit.leftWord KChar 'f' -> changeInput Edit.rightWord KChar 'a' -> eventLoop (jumpToActivity st)
src/Client/IdentifierColors.hs view
@@ -11,29 +11,26 @@ module Client.IdentifierColors (identifierColor) where -import Graphics.Vty.Image-import Irc.Identifier-import Data.Array 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 ! i+identifierColor ident = nickColorPalette Vector.! i where- hash = hashIdentity ident- (0,hi) = bounds nickColorPalette- n = hi+1- i = hash`mod`n+ 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 :: Array Int Color-nickColorPalette = listArray (0, length xs - 1) xs- where- xs = [cyan, magenta, green, yellow, blue,- brightCyan, brightMagenta, brightGreen, brightBlue]+nickColorPalette :: Vector Color+nickColorPalette = Vector.fromList+ [cyan, magenta, green, yellow, blue,+ brightCyan, brightMagenta, brightGreen, brightBlue]
src/Client/Image.hs view
@@ -139,7 +139,9 @@ lineWrap :: Int -> Image -> Image lineWrap w img | imageWidth img > w = cropRight w img <-> lineWrap w (cropLeft (imageWidth img - w) img)- | otherwise = img+ | otherwise = img <|> char defAttr ' '+ -- trailing space with default attributes deals with bug in VTY+ -- where the formatting will continue past the end of chat messages horizDividerImage :: ClientState -> Image
src/Client/Image/ChannelInfo.hs view
@@ -22,9 +22,6 @@ import Client.MircFormatting import Client.State import Control.Lens-import qualified Data.HashMap.Strict as HashMap-import Data.List-import Data.Ord import Data.Time import Graphics.Vty.Image import Irc.Identifier
src/Client/Image/MaskList.hs view
@@ -1,3 +1,4 @@+{-# Language OverloadedStrings #-} {-| Module : Client.Image.MaskList Description : Line renderers for channel mask list view@@ -29,10 +30,13 @@ NetworkName {- ^ Focused network -} -> Identifier {- ^ Focused channel -} -> ClientState -> [Image]-maskListImages mode network channel st- | null entryList = [string (withForeColor defAttr red) "No masks"]- | otherwise = images+maskListImages mode network channel st = countImage : images where+ countImage = text' (withForeColor defAttr green) "Masks (visible/total): " <|>+ string defAttr (show (length entryList)) <|>+ char (withForeColor defAttr green) '/' <|>+ string defAttr (show (HashMap.size entries))+ matcher = clientMatcher st matcher' (x,(y,_)) = matcher x || matcher y
src/Client/Image/Message.hs view
@@ -1,3 +1,4 @@+{-# Language OverloadedStrings #-} {-| Module : Client.Image.Message Description : Renderer for message lines@@ -196,14 +197,42 @@ string defAttr ": " <|> parseIrcTextWithNicks myNicks nicks txt - Action src _dst txt ->- detail (string quietAttr "chat ") <|>+ Ctcp src _dst "ACTION" txt ->+ detail (string quietAttr "actp ") <|> string (withForeColor defAttr blue) "* " <|> string (withForeColor defAttr cyan) sigils <|> coloredUserInfo rm myNicks src <|> string defAttr " " <|> parseIrcTextWithNicks 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 defAttr " " <|>+ parseIrcTextWithNicks 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 defAttr " " <|>+ parseIrcText cmd <|>+ separatorImage <|>+ parseIrcText txt++ CtcpNotice src _dst cmd txt ->+ detail (string quietAttr "ctcp ") <|>+ string (withForeColor defAttr red) "! " <|>+ string (withForeColor defAttr cyan) sigils <|>+ coloredUserInfo rm myNicks src <|>+ string defAttr " " <|>+ parseIrcText cmd <|>+ separatorImage <|>+ parseIrcText txt+ Ping params -> string defAttr "PING " <|> separatedParams params @@ -329,6 +358,8 @@ 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) <|> char (withForeColor defAttr yellow) '-' <|> quietIdentifier new, Nothing)
src/Client/Image/UserList.hs view
@@ -16,6 +16,7 @@ import Client.State import Control.Lens import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map.Strict as Map import Data.List import Data.Ord import qualified Data.Text as Text@@ -31,8 +32,8 @@ userListImages network channel st = [countImage, horizCat (intersperse gap (map renderUser usersList))] where- countImage = text' (withForeColor defAttr green) "Users: " <|>- string defAttr (show (HashMap.size usersHashMap))+ countImage = text' (withForeColor defAttr green) "Users:" <|>+ sigilCountImage matcher = clientMatcher st @@ -50,6 +51,15 @@ $ filter matcher' $ HashMap.toList usersHashMap + sigilCounts = Map.fromListWith (+)+ [ (take 1 sigil, 1::Int) | (_,sigil) <- usersList ]++ sigilCountImage = horizCat+ [ string (withForeColor defAttr cyan) (' ':sigil) <|>+ string defAttr (show n)+ | (sigil,n) <- Map.toList sigilCounts+ ]+ usersHashMap = view ( clientConnection network . csChannels . ix channel@@ -76,8 +86,9 @@ userInfos = view (clientConnection network . csUsers) st toInfo nick =- case view (at nick . non (Nothing,Nothing)) userInfos of- (n,h) -> UserInfo nick n h+ case view (at nick) userInfos of+ Just (UserAndHost n h) -> UserInfo nick (Just n) (Just h)+ Nothing -> UserInfo nick Nothing Nothing usersList = sortBy (flip (comparing (userNick . fst))) $ filter matcher'
src/Client/MircFormatting.hs view
@@ -15,13 +15,14 @@ , parseIrcTextExplicit ) where -import Graphics.Vty hiding ((<|>))+import Control.Applicative ((<|>))+import Control.Lens+import Data.Attoparsec.Text as Parse+import Data.Char+import Data.Maybe+import Data.Text (Text)+import Graphics.Vty hiding ((<|>)) import qualified Graphics.Vty as Vty-import Data.Attoparsec.Text as Parse-import Data.Char-import Data.Text (Text)-import Control.Applicative ((<|>))-import Control.Lens data FormatState = FormatState { _fmtFore :: Maybe Color@@ -87,11 +88,14 @@ Vty.<|> rest else rest Just (ControlSegment c)- | explicit -> do rest <- next- return (Vty.char controlAttr (controlName c) Vty.<|> rest)+ -- always render control codes that we don't understand+ | isNothing mbFmt' || explicit ->+ do rest <- next+ return (Vty.char controlAttr (controlName c) Vty.<|> rest) | otherwise -> next where- next = pIrcLine explicit $ applyControlEffect c fmt+ mbFmt' = applyControlEffect c fmt+ next = pIrcLine explicit (fromMaybe fmt mbFmt') pColorNumbers :: Parser (Maybe Int, Maybe Int) pColorNumbers = option (Nothing,Nothing) $@@ -135,13 +139,13 @@ rgbColor' :: Int -> Int -> Int -> Color rgbColor' = rgbColor -- fix the type to Int -applyControlEffect :: Char -> FormatState -> FormatState-applyControlEffect '\^B' = over fmtBold not-applyControlEffect '\^O' = const defaultFormatState-applyControlEffect '\^V' = over fmtReverse not-applyControlEffect '\^]' = over fmtItalic not-applyControlEffect '\^_' = over fmtUnderline not-applyControlEffect _ = id+applyControlEffect :: Char -> FormatState -> Maybe FormatState+applyControlEffect '\^B' = Just . over fmtBold not+applyControlEffect '\^O' = Just . const defaultFormatState+applyControlEffect '\^V' = Just . over fmtReverse not+applyControlEffect '\^]' = Just . over fmtItalic not+applyControlEffect '\^_' = Just . over fmtUnderline not+applyControlEffect _ = const Nothing controlAttr :: Attr controlAttr = defAttr `withStyle` reverseVideo
src/Client/ServerSettings.hs view
@@ -51,6 +51,7 @@ import Network.Socket (HostName, PortNumber) +-- | Static server-level settings data ServerSettings = ServerSettings { _ssNick :: !Text -- ^ connection nickname , _ssUser :: !Text -- ^ connection username@@ -70,8 +71,8 @@ , _ssSocksPort :: !PortNumber -- ^ port of SOCKS proxy , _ssServerCerts :: ![FilePath] -- ^ additional CA certificates for validating server , _ssChanservChannels :: ![Identifier] -- ^ Channels with chanserv permissions- , _ssFloodPenalty :: !Int -- ^ Flood limiter penalty (seconds)- , _ssFloodThreshold :: !Int -- ^ Flood limited threshold (seconds)+ , _ssFloodPenalty :: !Rational -- ^ Flood limiter penalty (seconds)+ , _ssFloodThreshold :: !Rational -- ^ Flood limited threshold (seconds) } deriving Show
src/Client/State.hs view
@@ -1,4 +1,4 @@-{-# Language TemplateHaskell, BangPatterns #-}+{-# Language TemplateHaskell, BangPatterns, OverloadedStrings #-} {-| Module : Client.State Description : Primary client state type and update operations@@ -44,6 +44,7 @@ , addConnection , removeNetwork , clientTick+ , applyMessageToClientState -- * Add messages to buffers , recordChannelMessage@@ -65,49 +66,55 @@ import Client.ChannelState import Client.Configuration import Client.ConnectionState+import qualified Client.EditBox as Edit import Client.Image.Message import Client.Message import Client.NetworkConnection import Client.ServerSettings import Client.Window import Control.Concurrent.STM+import Control.DeepSeq import Control.Lens import Data.Foldable import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Maybe import Data.Map (Map)+import qualified Data.Map as Map import Data.Monoid import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.ICU as ICU+import Data.Time import Graphics.Vty+import Irc.Codes import Irc.Identifier import Irc.Message+import Irc.RawIrcMsg import Irc.UserInfo-import Irc.Codes import LensUtils import Network.Connection-import qualified Client.EditBox as Edit-import qualified Data.HashMap.Strict as HashMap-import qualified Data.HashSet as HashSet-import qualified Data.Map as Map +-- | Textual name of a network connection type NetworkName = Text +-- | Currently focused window data ClientFocus- = Unfocused- | NetworkFocus !NetworkName- | ChannelFocus !NetworkName !Identifier+ = Unfocused -- ^ No network+ | NetworkFocus !NetworkName -- ^ Network+ | ChannelFocus !NetworkName !Identifier -- ^ Channel on network deriving Eq +-- | Subfocus for a channel view data ClientSubfocus- = FocusMessages- | FocusInfo- | FocusUsers- | FocusMasks !Char+ = FocusMessages -- ^ Show chat messages+ | FocusInfo -- ^ Show channel metadata+ | FocusUsers -- ^ Show user list+ | FocusMasks !Char -- ^ Show mask list for given mode deriving Eq -- | Unfocused first, followed by focuses sorted by network.@@ -150,20 +157,25 @@ makeLenses ''ClientState +-- | 'Traversal' for finding the 'ConnectionState' associated with a given network+-- if that connection is currently active. clientConnection :: Applicative f => NetworkName -> LensLike' f ClientState ConnectionState clientConnection network f st = case view (clientNetworkMap . at network) st of Nothing -> pure st Just i -> clientConnections (ix i f) st +-- | Full content of the edit box clientInput :: ClientState -> String clientInput = view (clientTextBox . Edit.content) +-- | Return the network associated with the current focus focusNetwork :: ClientFocus -> Maybe NetworkName focusNetwork Unfocused = Nothing focusNetwork (NetworkFocus network) = Just network focusNetwork (ChannelFocus network _) = Just network +-- | Construct an initial 'ClientState' using default values. initialClientState :: Configuration -> Vty -> IO ClientState initialClientState cfg vty = do (width,height) <- displayBounds (outputIface vty)@@ -188,6 +200,8 @@ , _clientIgnores = HashSet.empty } +-- | Forcefully terminate the connection currently associated+-- with a given network name. abortNetwork :: NetworkName -> ClientState -> IO ClientState abortNetwork network st = case preview (clientConnection network) st of@@ -195,16 +209,22 @@ Just cs -> do abortConnection (view csSocket cs) return $ set (clientNetworkMap . at network) Nothing st -recordChannelMessage :: NetworkName -> Identifier -> ClientMessage -> ClientState -> ClientState+-- | Add a message to the window associated with a given channel+recordChannelMessage ::+ NetworkName ->+ Identifier {- ^ channel -} ->+ ClientMessage -> ClientState -> ClientState recordChannelMessage network channel msg st =- over (clientWindows . at focus) (\w -> Just $! addToWindow importance wl (fromMaybe emptyWindow w)) st+ over (clientWindows . at focus)+ (\w -> Just $! addToWindow importance wl (fromMaybe emptyWindow w))+ st where focus = ChannelFocus network channel' wl = toWindowLine rendParams msg myNicks = toListOf (clientConnection network . csNick) st rendParams = MessageRendererParams { rendStatusMsg = statusModes- , rendUserSigils = computeMsgLineModes network channel' msg st+ , rendUserSigils = computeMsgLineSigils network channel' msg st , rendNicks = channelUserList network channel' st , rendMyNicks = myNicks }@@ -214,6 +234,8 @@ (statusModes, channel') = splitStatusMsgModes possibleStatusModes channel importance = msgImportance msg st +-- | Compute the importance of a message to be used when computing+-- change notifications in the client. msgImportance :: ClientMessage -> ClientState -> WindowLineImportance msgImportance msg st = let network = view msgNetwork msg@@ -237,7 +259,7 @@ Notice _ tgt txt | isMe tgt -> WLImportant | otherwise -> checkTxt txt- Action _ _ txt -> checkTxt txt+ Ctcp _ _ _ _ -> WLNormal Part who _ _ | isMe (userNick who) -> WLImportant | otherwise -> WLBoring Kick _ _ kicked _ | isMe kicked -> WLImportant@@ -257,6 +279,10 @@ case msg of Privmsg who _ _ -> checkUser who Notice who _ _ -> checkUser who+ -- privmsg ctcp commands are already metadata+ Ctcp who _ "ACTION" _ -> checkUser who+ -- notice ctcp responses are not already metadata+ CtcpNotice who _ _ _ -> checkUser who _ -> Nothing where ignores = view clientIgnores st@@ -265,40 +291,61 @@ | otherwise = Nothing -recordIrcMessage :: NetworkName -> MessageTarget -> ClientMessage -> ClientState -> ClientState+-- | Record a message in the windows corresponding to the given target+recordIrcMessage ::+ NetworkName -> MessageTarget -> ClientMessage -> ClientState -> ClientState recordIrcMessage network target msg st = case target of TargetHidden -> st TargetNetwork -> recordNetworkMessage msg st TargetWindow chan -> recordChannelMessage network chan msg st- TargetUser user -> foldl' (\st' chan -> overStrict- (clientWindows . ix (ChannelFocus network chan))- (addToWindow WLBoring wl) st')- st chans+ TargetUser user ->+ foldl' (\st' chan -> overStrict+ (clientWindows . ix (ChannelFocus network chan))+ (addToWindow WLBoring wl) st')+ st chans where wl = toWindowLine' msg- chans =- case preview (clientConnection network . csChannels) st of- Nothing -> []- Just m -> [chan | (chan, cs) <- HashMap.toList m, HashMap.member user (view chanUsers cs) ]+ chans = user+ : case preview (clientConnection network . csChannels) st of+ Nothing -> []+ Just m -> [chan | (chan, cs) <- HashMap.toList m+ , HashMap.member user (view chanUsers cs) ] -splitStatusMsgModes :: [Char] -> Identifier -> ([Char], Identifier)+-- | Extract the status mode sigils from a message target.+splitStatusMsgModes ::+ [Char] {- ^ possible modes -} ->+ Identifier {- ^ target -} ->+ ([Char], Identifier) {- ^ actual modes, actual target -} splitStatusMsgModes possible ident = (Text.unpack modes, mkId ident') where (modes, ident') = Text.span (`elem` possible) (idText ident) -computeMsgLineModes :: NetworkName -> Identifier -> ClientMessage -> ClientState -> [Char]-computeMsgLineModes network channel msg st =+-- | Compute the sigils of the user who sent a message.+computeMsgLineSigils ::+ NetworkName ->+ Identifier {- ^ channel -} ->+ ClientMessage ->+ ClientState ->+ [Char] {- ^ sigils -}+computeMsgLineSigils network channel msg st = case msgActor =<< preview (msgBody . _IrcBody) msg of- Just user -> computeLineModes network channel (userNick user) st+ Just user -> computeUserSigils network channel (userNick user) st Nothing -> [] -computeLineModes :: NetworkName -> Identifier -> Identifier -> ClientState -> [Char]-computeLineModes network channel user =+-- | Compute sigils for a user on a channel+computeUserSigils ::+ NetworkName ->+ Identifier {- ^ channel -} ->+ Identifier {- ^ user -} ->+ ClientState ->+ [Char] {- ^ sigils -}+computeUserSigils network channel user = view $ clientConnection network . csChannels . ix channel . chanUsers . ix user +-- | Record a message on a network window recordNetworkMessage :: ClientMessage -> ClientState -> ClientState recordNetworkMessage msg st = over (clientWindows . at (NetworkFocus network))@@ -312,8 +359,8 @@ toWindowLine params msg = WindowLine { _wlBody = view msgBody msg , _wlText = views msgBody msgText msg- , _wlImage = msgImage (view msgTime msg) params (view msgBody msg)- , _wlFullImage = detailedMsgImage (view msgTime msg) params (view msgBody msg)+ , _wlImage = force $ msgImage (view msgTime msg) params (view msgBody msg)+ , _wlFullImage = force $ detailedMsgImage (view msgTime msg) params (view msgBody msg) } toWindowLine' :: ClientMessage -> WindowLine@@ -428,4 +475,45 @@ return $ set (clientNetworkMap . at network) (Just i) $ set (clientConnections . at i) (Just cs) st'++applyMessageToClientState ::+ ZonedTime {- ^ message received -} ->+ IrcMsg {- ^ message recieved -} ->+ NetworkId {- ^ messge network -} ->+ ConnectionState {- ^ network connection state -} ->+ ClientState ->+ ([RawIrcMsg], ClientState) {- ^ response , updated state -}+applyMessageToClientState time irc networkId cs st =+ cs' `seq` (reply, st')+ where+ (reply, cs') = applyMessage time irc cs+ network = view csNetwork cs+ st' = applyWindowRenames network irc+ $ set (clientConnections . ix networkId) cs' st++-- | When a nick change happens and there is an open query window for that nick+-- and there isn't an open query window for the new nick, rename the window.+applyWindowRenames :: NetworkName -> IrcMsg -> ClientState -> ClientState+applyWindowRenames network (Nick old new) st+ | hasWindow old'+ , not (hasWindow new) = over clientFocus moveFocus+ $ over clientWindows moveWindow st+ | otherwise = st+ where+ old' = userNick old++ mkFocus = ChannelFocus network++ hasWindow who = has (clientWindows . ix (mkFocus who)) st++ moveWindow :: Map ClientFocus Window -> Map ClientFocus Window+ moveWindow wins =+ let (win,wins') = (at (mkFocus old') <<.~ Nothing) wins+ in set (at (mkFocus new)) win wins'++ moveFocus x+ | x == mkFocus old' = mkFocus new+ | otherwise = x++applyWindowRenames _ _ st = st
src/Client/Window.hs view
@@ -1,4 +1,4 @@-{-# Language TemplateHaskell #-}+{-# Language BangPatterns, TemplateHaskell #-} {-| Module : Client.Window@@ -77,7 +77,7 @@ -- | Adds a given line to a window as the newest message. Window's -- unread count will be updated according to the given importance. addToWindow :: WindowLineImportance -> WindowLine -> Window -> Window-addToWindow importance msg win = Window+addToWindow importance msg !win = Window { _winMessages = msg : _winMessages win , _winUnread = _winUnread win + (if importance == WLBoring then 0 else 1) , _winMention = _winMention win || importance == WLImportant
src/Config/FromConfig.hs view
@@ -38,6 +38,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Monoid+import Data.Ratio import Data.Text (Text) import qualified Data.Text as Text @@ -81,8 +82,18 @@ -- | Matches 'Number' values ignoring the base instance FromConfig Integer where parseConfig (Number _ n) = return n- parseConfig _ = failure "expected number"+ parseConfig (Floating c e)+ | denominator n == 1 = return $! numerator n+ where+ n = floatingToRatio c e+ parseConfig _ = failure "expected integral number" +-- | Matches 'Number' values ignoring the base+instance Integral a => FromConfig (Ratio a) where+ parseConfig (Number _ n) = return $! fromIntegral n+ parseConfig (Floating c e) = return $! floatingToRatio c e+ parseConfig _ = failure "expected fractional number"+ -- | Matches 'Atom' values instance FromConfig Atom where parseConfig (Atom a) = return a@@ -146,3 +157,6 @@ toHashMap :: [Section] -> HashMap Text Value toHashMap xs = HashMap.fromList [ (k,v) | Section k v <- xs ] -- todo: handle duplicate sections++floatingToRatio :: Integral a => Integer -> Integer -> Ratio a+floatingToRatio c e = fromIntegral c * 10 ^^ e
src/Irc/Commands.hs view
@@ -9,22 +9,29 @@ This module provides smart constructors for IRC commands. -} module Irc.Commands- ( ircCapEnd+ ( ircAway+ , ircCapEnd , ircCapLs , ircCapReq , ircInvite+ , ircIson , ircJoin , ircKick+ , ircLinks , ircMode , ircNick+ , ircNotice , ircPart , ircPass , ircPong , ircPrivmsg , ircQuit , ircRemove+ , ircStats+ , ircTime , ircTopic , ircUser+ , ircUserhost , ircWho , ircWhois , ircWhowas@@ -49,6 +56,13 @@ RawIrcMsg ircPrivmsg who msg = rawIrcMsg "PRIVMSG" [idText who, msg] +-- | NOTICE command+ircNotice ::+ Identifier {- ^ target -} ->+ Text {- ^ message -} ->+ RawIrcMsg+ircNotice who msg = rawIrcMsg "NOTICE" [idText who, msg]+ -- | MODE command ircMode :: Identifier {- ^ target -} ->@@ -149,6 +163,45 @@ RawIrcMsg ircPong = rawIrcMsg "PONG" +-- | ISON command+ircIson ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircIson = rawIrcMsg "ISON"++-- | TIME command+ircTime ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircTime = rawIrcMsg "TIME"++-- | USERHOST command+ircUserhost ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircUserhost = rawIrcMsg "USERHOST"++-- | STATS command+ircStats ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircStats = rawIrcMsg "STATS"++-- | LINKS command+ircLinks ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircLinks = rawIrcMsg "LINKS"++-- | AWAY command+ircAway ::+ Text {- ^ message -} ->+ RawIrcMsg+ircAway msg+ | Text.null msg = rawIrcMsg "AWAY" []+ | otherwise = rawIrcMsg "AWAY" [msg]++-- | USER command ircUser :: Text {- ^ username -} -> Bool {- ^ set +w -} ->@@ -175,12 +228,15 @@ ircCapLs :: RawIrcMsg ircCapLs = rawIrcMsg "CAP" ["LS"] +-- | AUTHENTICATE command ircAuthenticate :: Text -> RawIrcMsg ircAuthenticate msg = rawIrcMsg "AUTHENTICATE" [msg] +-- | PLAIN authentiation mode plainAuthenticationMode :: Text plainAuthenticationMode = "PLAIN" +-- | Encoding of username and password in PLAIN authentication encodePlainAuthentication :: Text {- ^ username -} -> Text {- ^ password -} ->
src/Irc/Message.hs view
@@ -31,6 +31,7 @@ ) where import Control.Lens+import Control.Monad import Data.Function import Data.Maybe import Data.Text (Text)@@ -41,34 +42,38 @@ import Irc.UserInfo import Irc.Codes +-- | High-level IRC message representation data IrcMsg- = UnknownMsg RawIrcMsg- | Reply ReplyCode [Text]- | Nick UserInfo Identifier- | Join UserInfo Identifier- | Part UserInfo Identifier (Maybe Text)- | Quit UserInfo (Maybe Text)- | Kick UserInfo Identifier Identifier Text -- ^ kicker channel kickee comment- | Topic UserInfo Identifier Text -- ^ user channel topic- | Privmsg UserInfo Identifier Text -- ^ source target txt- | Action UserInfo Identifier Text -- ^ source target txt- | Notice UserInfo Identifier Text -- ^ source target txt- | Mode UserInfo Identifier [Text] -- ^ source target txt- | Authenticate Text- | Cap CapCmd [Text]- | Ping [Text]- | Pong [Text]- | Error Text+ = UnknownMsg !RawIrcMsg -- ^ pass-through for unhandled messages+ | Reply !ReplyCode [Text] -- ^ code arguments+ | Nick !UserInfo !Identifier -- ^ old new+ | Join !UserInfo !Identifier -- ^ user channel+ | Part !UserInfo !Identifier (Maybe Text) -- ^ user channel reason+ | Quit !UserInfo (Maybe Text) -- ^ user reason+ | Kick !UserInfo !Identifier !Identifier !Text -- ^ kicker channel kickee comment+ | Topic !UserInfo !Identifier !Text -- ^ user channel topic+ | Privmsg !UserInfo !Identifier !Text -- ^ source target txt+ | Ctcp !UserInfo !Identifier !Text !Text -- ^ source target command txt+ | CtcpNotice !UserInfo !Identifier !Text !Text -- ^ source target command txt+ | Notice !UserInfo !Identifier !Text -- ^ source target txt+ | Mode !UserInfo !Identifier [Text] -- ^ source target txt+ | Authenticate !Text -- ^ parameters+ | Cap !CapCmd [Text] -- ^ command parameters+ | Ping [Text] -- ^ parameters+ | Pong [Text] -- ^ parameters+ | Error !Text -- ^ message deriving Show +-- | Sub-commands of the CAP command data CapCmd- = CapLs- | CapList- | CapReq- | CapAck- | CapNak+ = CapLs -- ^ request list of supported caps+ | CapList -- ^ request list of active caps+ | CapReq -- ^ request activation of cap+ | CapAck -- ^ request accepted+ | CapNak -- ^ request denied deriving (Show, Eq, Ord) +-- | Match command text to structured cap sub-command cookCapCmd :: Text -> Maybe CapCmd cookCapCmd "LS" = Just CapLs cookCapCmd "LIST" = Just CapList@@ -97,14 +102,17 @@ "PRIVMSG" | Just user <- view msgPrefix msg , [chan,txt] <- view msgParams msg -> - case Text.stripSuffix "\^A" =<< Text.stripPrefix "\^AACTION " txt of- Just action -> Action user (mkId chan) action- Nothing -> Privmsg user (mkId chan) txt+ case parseCtcp txt of+ Just (cmd,args) -> Ctcp user (mkId chan) (Text.toUpper cmd) args+ Nothing -> Privmsg user (mkId chan) txt "NOTICE" | Just user <- view msgPrefix msg , [chan,txt] <- view msgParams msg ->- Notice user (mkId chan) txt + case parseCtcp txt of+ Just (cmd,args) -> CtcpNotice user (mkId chan) (Text.toUpper cmd) args+ Nothing -> Notice user (mkId chan) txt+ "JOIN" | Just user <- view msgPrefix msg , chan:_ <- view msgParams msg -> @@ -139,6 +147,17 @@ _ -> UnknownMsg msg +-- | Parse a CTCP encoded message:+--+-- @\^ACOMMAND arguments\^A@+parseCtcp :: Text -> Maybe (Text, Text)+parseCtcp txt =+ do txt1 <- Text.stripSuffix "\^A" =<< Text.stripPrefix "\^A" txt+ let (cmd,args) = Text.break (==' ') txt1+ guard (not (Text.null cmd))+ return (cmd, Text.drop 1 args)++ -- | Targets used to direct a message to a window for display data MessageTarget = TargetUser !Identifier -- ^ Metadata update for a user@@ -162,8 +181,10 @@ Topic _ chan _ -> TargetWindow chan Privmsg src tgt _ | tgt == me -> TargetWindow (userNick src) | otherwise -> TargetWindow tgt- Action src tgt _ | tgt == me -> TargetWindow (userNick src)+ Ctcp src tgt _ _ | tgt == me -> TargetWindow (userNick src) | otherwise -> TargetWindow tgt+ CtcpNotice src tgt _ _ | tgt == me -> TargetWindow (userNick src)+ | otherwise -> TargetWindow tgt Notice src tgt _ | tgt == me -> TargetWindow (userNick src) | otherwise -> TargetWindow tgt Authenticate{} -> TargetHidden@@ -186,7 +207,8 @@ Kick x _ _ _ -> Just x Topic x _ _ -> Just x Privmsg x _ _ -> Just x- Action x _ _ -> Just x+ Ctcp x _ _ _ -> Just x+ CtcpNotice x _ _ _ -> Just x Notice x _ _ -> Just x Mode x _ _ -> Just x Authenticate{}-> Nothing@@ -209,7 +231,8 @@ Kick x _ z r -> Text.unwords [renderUserInfo x, idText z, r] Topic x _ t -> Text.unwords [renderUserInfo x, t] Privmsg x _ t -> Text.unwords [renderUserInfo x, t]- Action x _ t -> Text.unwords [renderUserInfo x, t]+ Ctcp x _ c t -> Text.unwords [renderUserInfo x, c, t]+ CtcpNotice x _ c t -> Text.unwords [renderUserInfo x, c, t] Notice x _ t -> Text.unwords [renderUserInfo x, t] Mode x _ xs -> Text.unwords (renderUserInfo x:"set mode":xs) Ping xs -> Text.unwords xs
src/Irc/Modes.hs view
@@ -61,7 +61,7 @@ { _modesLists = "" , _modesAlwaysArg = "" , _modesSetArg = "s"- , _modesNeverArg = ""+ , _modesNeverArg = "DQRZgiow" , _modesPrefixModes = [] }
src/Irc/RateLimit.hs view
@@ -29,14 +29,14 @@ -- as the current state of the limit. data RateLimit = RateLimit { rateStamp :: !(MVar UTCTime) -- ^ Time that client can send- , rateThreshold :: !Int -- ^ seconds- , ratePenalty :: !Int -- ^ seconds+ , rateThreshold :: !NominalDiffTime+ , ratePenalty :: !NominalDiffTime } -- | Construct a new rate limit with the given penalty and threshold. newRateLimit ::- Int {- ^ penalty -} ->- Int {- ^ threshold -} ->+ Rational {- ^ penalty seconds -} ->+ Rational {- ^ threshold seconds -} -> IO RateLimit newRateLimit penalty threshold = do unless (penalty > 0)@@ -50,8 +50,8 @@ return RateLimit { rateStamp = ref- , rateThreshold = threshold- , ratePenalty = penalty+ , rateThreshold = realToFrac threshold+ , ratePenalty = realToFrac penalty } -- | Account for an event in the context of a 'RateLimit'. This command@@ -60,12 +60,10 @@ tickRateLimit :: RateLimit -> IO () tickRateLimit r = modifyMVar_ (rateStamp r) $ \stamp -> do now <- getCurrentTime- let stamp' = fromIntegral (ratePenalty r) `addUTCTime` max stamp now+ let stamp' = ratePenalty r `addUTCTime` max stamp now diff = diffUTCTime stamp' now- excess = diff - fromIntegral (rateThreshold r)+ excess = diff - rateThreshold r - when (excess > 0)- (threadDelay- (ceiling (1000000 * realToFrac excess :: Rational)))+ when (excess > 0) (threadDelay (ceiling (1000000 * excess))) return stamp'
src/Irc/RawIrcMsg.hs view
@@ -32,25 +32,24 @@ , asUtf8 ) where -import Control.Applicative-import Control.Monad (when)-import Control.Lens-import Data.Array-import Data.Attoparsec.Text as P-import Data.ByteString (ByteString)-import Data.ByteString.Builder (Builder)-import Data.Functor-import Data.Monoid-import Data.Text (Text)-import Data.Time (UTCTime, parseTimeM, defaultTimeLocale)-import Data.Word (Word8)+import Control.Applicative+import Control.Lens+import Data.Attoparsec.Text as P+import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as Builder+import Data.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 -import Irc.UserInfo+import Irc.UserInfo -- | 'RawIrcMsg' breaks down the IRC protocol into its most basic parts. -- The "trailing" parameter indicated in the IRC protocol with a leading@@ -58,12 +57,17 @@ -- -- Note that RFC 2812 specifies a maximum of 15 parameters. --+-- This parser is permissive regarding spaces. It aims to parse carefully+-- constructed messages exactly and to make a best effort to recover from+-- extraneous spaces. It makes no effort to validate nicknames, usernames,+-- hostnames, commands, etc. Servers don't all agree on these things.+-- -- @:prefix COMMAND param0 param1 param2 .. paramN@ data RawIrcMsg = RawIrcMsg { _msgServerTime :: Maybe UTCTime -- ^ Time from znc.in/server-time-iso extension- , _msgPrefix :: Maybe UserInfo -- ^ Optional sender of message- , _msgCommand :: Text -- ^ command- , _msgParams :: [Text] -- ^ command parameters+ , _msgPrefix :: Maybe UserInfo -- ^ Optional sender of message+ , _msgCommand :: !Text -- ^ command+ , _msgParams :: [Text] -- ^ command parameters } deriving (Read, Show) @@ -110,30 +114,27 @@ prefix <- guarded (char ':') prefixParser cmd <- simpleTokenParser params <- paramsParser maxMiddleParams- return RawIrcMsg- { _msgServerTime = time- , _msgPrefix = prefix- , _msgCommand = cmd- , _msgParams = params- }+ return $! RawIrcMsg+ { _msgServerTime = time+ , _msgPrefix = prefix+ , _msgCommand = cmd+ , _msgParams = params+ } -- | Parse the list of parameters in a raw message. The RFC -- allows for up to 15 parameters.-paramsParser :: Int -> Parser [Text]-paramsParser n =- do _ <- skipMany (char ' ') -- Freenode requires this exception- endOfInput $> [] <|> more- where- more- | n == 0 =- do _ <- optional (char ':')- finalParam+paramsParser ::+ Int {- ^ possible middle parameters -} -> Parser [Text]+paramsParser !n =+ do end <- P.atEnd+ if end+ then return []+ else do mbColon <- optional (char ':')+ if n == 0 || isJust mbColon+ then finalParam+ else middleParam - | otherwise =- do mbColon <- optional (char ':')- case mbColon of- Just{} -> finalParam- Nothing -> middleParam+ where finalParam = do x <- takeText@@ -141,18 +142,15 @@ return [x'] middleParam =- do x <- P.takeWhile (/= ' ')- when (Text.null x) (fail "Empty middle parameter")- let !x' = Text.copy x+ do x <- simpleTokenParser xs <- paramsParser (n-1)- return (x':xs)+ return (x:xs) -- | Parse the server-time message prefix: -- @time=2015-03-04T22:29:04.064Z timeParser :: Parser UTCTime timeParser = do timeBytes <- simpleTokenParser- _ <- char ' ' case parseIrcTime (Text.unpack timeBytes) of Nothing -> fail "Bad server-time format" Just t -> return t@@ -163,14 +161,13 @@ prefixParser :: Parser UserInfo prefixParser = do tok <- simpleTokenParser- _ <- char ' '- return (parseUserInfo tok)+ return $! parseUserInfo tok --- | Take the bytes up to the next space delimiter+-- | Take the next space-delimited lexeme simpleTokenParser :: Parser Text simpleTokenParser =- do xs <- P.takeWhile (/= ' ')- when (Text.null xs) (fail "Empty token")+ do xs <- P.takeWhile1 (/= ' ')+ P.skipWhile (== ' ') return $! Text.copy xs -- | Take the bytes up to the next space delimiter.@@ -230,26 +227,13 @@ Left{} -> decodeCP1252 x decodeCP1252 :: ByteString -> Text-decodeCP1252 = Text.pack . map (cp1252!) . B.unpack+decodeCP1252 bs = Text.pack [ cp1252 Vector.! fromIntegral x | x <- B.unpack bs ] -- This character encoding is a superset of ISO 8859-1 in terms of printable -- characters, but differs from the IANA's ISO-8859-1 by using displayable -- characters rather than control characters in the 80 to 9F (hex) range.-cp1252 :: Array Word8 Char-cp1252 = listArray (0,255)- ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK','\a','\b','\t','\n','\v','\f','\r','\SO','\SI',- '\DLE','\DC1','\DC2','\DC3','\DC4','\NAK','\SYN','\ETB','\CAN','\EM','\SUB','\ESC','\FS','\GS','\RS','\US',- ' ','!','\"','#','$','%','&','\'','(',')','*','+',',','-','.','/',- '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',- '@','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',- 'P','Q','R','S','T','U','V','W','X','Y','Z','[','\\',']','^','_',- '`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',- 'p','q','r','s','t','u','v','w','x','y','z','{','|','}','~','\DEL',- '\8364','\129','\8218','\402','\8222','\8230','\8224','\8225','\710','\8240','\352','\8249','\338','\141','\381','\143',- '\144','\8216','\8217','\8220','\8221','\8226','\8211','\8212','\732','\8482','\353','\8250','\339','\157','\382','\376',- '\160','\161','\162','\163','\164','\165','\166','\167','\168','\169','\170','\171','\172','\173','\174','\175',- '\176','\177','\178','\179','\180','\181','\182','\183','\184','\185','\186','\187','\188','\189','\190','\191',- '\192','\193','\194','\195','\196','\197','\198','\199','\200','\201','\202','\203','\204','\205','\206','\207',- '\208','\209','\210','\211','\212','\213','\214','\215','\216','\217','\218','\219','\220','\221','\222','\223',- '\224','\225','\226','\227','\228','\229','\230','\231','\232','\233','\234','\235','\236','\237','\238','\239',- '\240','\241','\242','\243','\244','\245','\246','\247','\248','\249','\250','\251','\252','\253','\254','\255']+cp1252 :: Vector Char+cp1252 = Vector.fromList+ $ ['\x00'..'\x7f']+ ++ "€\x81‚ƒ„…†‡ˆ‰Š‹Œ\x8dŽ\x8f\x90‘’“”•–—˜™š›œ\x9džŸ"+ ++ ['\xa0'..'\xff']
src/Main.hs view
@@ -16,6 +16,8 @@ import Control.Monad import Data.Default.Class import Graphics.Vty+import System.IO+import System.Exit import Client.EventLoop import Client.Configuration@@ -31,12 +33,30 @@ main :: IO () main = do args <- getCommandArguments- cfg <- loadConfiguration (view cmdArgConfigFile args)+ cfg <- loadConfiguration' (view cmdArgConfigFile args) withVty $ \vty -> runInUnboundThread $ do st <- initialClientState cfg vty st' <- addInitialNetworks (view cmdArgInitialNetworks args) st eventLoop st'++-- | Load configuration and handle errors along the way.+loadConfiguration' :: Maybe FilePath -> IO Configuration+loadConfiguration' path =+ do cfgRes <- loadConfiguration path+ case cfgRes of+ Right cfg -> return cfg+ Left (ConfigurationReadFailed e) ->+ report "Failed to open configuration:" e+ Left (ConfigurationParseFailed e) ->+ report "Failed to parse configuration:" e+ Left (ConfigurationMalformed e) ->+ report "Configuration malformed: " e+ where+ report problem msg =+ do hPutStrLn stderr problem+ hPutStrLn stderr msg+ exitFailure -- | Create connections for all the networks on the command line. -- Set the client focus to the first network listed.