diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ` - Connect to the given hostname +* `/disconnect` - Forcefully terminate connection to the current server * `/reconnect` - Reconnect to the current server + +Connection commands + +* `/nick ` - Change nickname +* `/away ` - Set away status + +Window management + * `/focus ` - Change focus to server window * `/focus ` - Change focus to channel window -* `/clear` - ` - Toggle ignore of a user -* `/quote ` - Send a raw IRC command to the server + +Channel membership + * `/join ` - Join a channel -* `/mode ` - Change modes on the current channel +* `/part` - Part from current channel + +Chat commands + * `/msg ` - Send a message on the current server to target -* `/nick ` - Change nickname -* `/who ` - Perform WHO query (use detailed view to see output) -* `/whois ` - Perform WHOIS query -* `/whowas ` - Perform WHOWAS query -* `/invite ` - Invite a user to the current channel -* `/topic ` - Change the topic +* `/notice ` - Send a notice message on the current server to target +* `/ctcp ` - Send a ctcp command on the current server to target +* `/me` - Send action message to channel + +Channel management + +* `/mode ` - Change modes on the current channel (advanced tab completion) * `/kick ` - Kick a user * `/kickban ` - Kick and ban a user * `/remove` - Gracefully kick a user -* `/me` - Send action message to channel -* `/part` - Part from current channel +* `/topic ` - Change the topic (tab completion for topic) +* `/invite ` - Invite a user to the current channel + +Queries + +* `/who ` - Perform WHO query (use detailed view to see output) +* `/whois ` - Perform WHOIS query +* `/whowas ` - Perform WHOWAS query +* `/ison ` - Perform ISON query +* `/userhost ` - Perform USERHOST query +* `/links ` - Perform LINKS query +* `/time` - Perform TIME query +* `/stats ` - Perform STATS query + +Channel information + * `/users` - Show channel user list * `/masks ` - 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 ` - Send a raw IRC command to the server Keyboard Shortcuts ================== diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -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 diff --git a/src/Client/ChannelState.hs b/src/Client/ChannelState.hs --- a/src/Client/ChannelState.hs +++ b/src/Client/ChannelState.hs @@ -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 diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -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 diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -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) diff --git a/src/Client/ConnectionState.hs b/src/Client/ConnectionState.hs --- a/src/Client/ConnectionState.hs +++ b/src/Client/ConnectionState.hs @@ -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 diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -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) diff --git a/src/Client/IdentifierColors.hs b/src/Client/IdentifierColors.hs --- a/src/Client/IdentifierColors.hs +++ b/src/Client/IdentifierColors.hs @@ -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] diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -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 diff --git a/src/Client/Image/ChannelInfo.hs b/src/Client/Image/ChannelInfo.hs --- a/src/Client/Image/ChannelInfo.hs +++ b/src/Client/Image/ChannelInfo.hs @@ -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 diff --git a/src/Client/Image/MaskList.hs b/src/Client/Image/MaskList.hs --- a/src/Client/Image/MaskList.hs +++ b/src/Client/Image/MaskList.hs @@ -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 diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -1,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) diff --git a/src/Client/Image/UserList.hs b/src/Client/Image/UserList.hs --- a/src/Client/Image/UserList.hs +++ b/src/Client/Image/UserList.hs @@ -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' diff --git a/src/Client/MircFormatting.hs b/src/Client/MircFormatting.hs --- a/src/Client/MircFormatting.hs +++ b/src/Client/MircFormatting.hs @@ -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 diff --git a/src/Client/ServerSettings.hs b/src/Client/ServerSettings.hs --- a/src/Client/ServerSettings.hs +++ b/src/Client/ServerSettings.hs @@ -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 diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -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 diff --git a/src/Client/Window.hs b/src/Client/Window.hs --- a/src/Client/Window.hs +++ b/src/Client/Window.hs @@ -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 diff --git a/src/Config/FromConfig.hs b/src/Config/FromConfig.hs --- a/src/Config/FromConfig.hs +++ b/src/Config/FromConfig.hs @@ -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 diff --git a/src/Irc/Commands.hs b/src/Irc/Commands.hs --- a/src/Irc/Commands.hs +++ b/src/Irc/Commands.hs @@ -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 -} -> diff --git a/src/Irc/Message.hs b/src/Irc/Message.hs --- a/src/Irc/Message.hs +++ b/src/Irc/Message.hs @@ -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 diff --git a/src/Irc/Modes.hs b/src/Irc/Modes.hs --- a/src/Irc/Modes.hs +++ b/src/Irc/Modes.hs @@ -61,7 +61,7 @@ { _modesLists = "" , _modesAlwaysArg = "" , _modesSetArg = "s" - , _modesNeverArg = "" + , _modesNeverArg = "DQRZgiow" , _modesPrefixModes = [] } diff --git a/src/Irc/RateLimit.hs b/src/Irc/RateLimit.hs --- a/src/Irc/RateLimit.hs +++ b/src/Irc/RateLimit.hs @@ -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' diff --git a/src/Irc/RawIrcMsg.hs b/src/Irc/RawIrcMsg.hs --- a/src/Irc/RawIrcMsg.hs +++ b/src/Irc/RawIrcMsg.hs @@ -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'] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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.