diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +1.1.2 +------- +* Support multiple nicknames in `/filter` +* Periodically ping to determine ping-times and keep connection alive. +* Added ping time field to IrcConnection datatype. +* Add `/ping` command + 1.1.1.1 ------- * Better error handling diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -149,10 +149,12 @@ * `/knock` - Request an /invite/ to a restricted channel * `/invite ` - Invite the given user to the current channel * `/reconnect` - Reconnect to the current server +* `/ping` - Send ping to upload current roundtrip time +* `/ping ` - Send manually specified ping message Filters -* `/filter` - Filter chat messages by nickname +* `/filter` - Filter chat messages by space-delimited set of nicknames * `/grep` - Filter chat messages using a regular expression on the message Keyboard Shortcuts diff --git a/driver/ClientState.hs b/driver/ClientState.hs --- a/driver/ClientState.hs +++ b/driver/ClientState.hs @@ -9,11 +9,12 @@ import Control.Concurrent.STM (TChan, atomically, writeTChan) import Control.DeepSeq (force) import Control.Lens -import Control.Monad (foldM, guard) +import Control.Monad (foldM, guard, when) import Data.ByteString (ByteString) import Data.Char (isControl) import Data.Foldable (for_) import Data.Functor.Compose +import Data.IORef import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Monoid @@ -47,7 +48,7 @@ data ClientConnection = ClientConnection { _ccServerSettings :: ServerSettings , _ccConnection :: IrcConnection - , _ccSendChan :: Maybe (TChan ByteString) + , _ccSendChan :: Maybe (IORef Bool, TChan ByteString) , _ccRecvThread :: Maybe ThreadId , _ccSendThread :: Maybe ThreadId } @@ -80,6 +81,7 @@ data TimerEvent = DropOperator Identifier + | TransmitPing deriving (Read, Show, Eq) data MessageList = MessageList @@ -201,8 +203,9 @@ clientSend :: ByteString -> ClientState -> IO () clientSend x st = - for_ (view (clientServer0.ccSendChan) st) $ \chan -> - atomically (writeTChan chan x) + for_ (view (clientServer0.ccSendChan) st) $ \(connectedRef,chan) -> + do connected <- readIORef connectedRef + when connected (atomically (writeTChan chan x)) focusedName :: ClientState -> Identifier focusedName st = @@ -306,12 +309,12 @@ where aux :: Map UTCTime [TimerEvent] -> Maybe (TimerEvent, Map UTCTime [TimerEvent]) aux timers = - do ((when,events), timers1) <- Map.minViewWithKey timers - guard (when <= now) + do ((trigger,events), timers1) <- Map.minViewWithKey timers + guard (trigger <= now) case events of [] -> error "nextTimerEvent: empty entry!" [e] -> return (e, timers1) - e:es -> return (e, Map.insert when es timers1) + e:es -> return (e, Map.insert trigger es timers1) filterTimerEvents :: (TimerEvent -> Bool) -> ClientState -> ClientState filterTimerEvents p = over clientTimers (Map.mapMaybe aux) @@ -322,4 +325,4 @@ where xs' = filter p xs addTimerEvent :: UTCTime -> TimerEvent -> ClientState -> ClientState -addTimerEvent when e = over clientTimers (Map.insertWith (++) when [e]) +addTimerEvent trigger e = over clientTimers (Map.insertWith (++) trigger [e]) diff --git a/driver/CommandArgs.hs b/driver/CommandArgs.hs --- a/driver/CommandArgs.hs +++ b/driver/CommandArgs.hs @@ -7,11 +7,13 @@ import Config.Lens import Control.Applicative import Control.Exception -import Control.Monad (when) +import Control.Monad (when, unless) import Data.Foldable (traverse_) import Data.Maybe +import Data.List (foldl') import Data.Text (Text) import Data.Text.Lens (unpacked) +import Data.Version (showVersion) import System.Console.GetOpt import System.Directory import System.Environment @@ -24,6 +26,7 @@ import qualified Data.Text.IO as Text import ServerSettings +import Paths_irc_core defaultConfigPath :: IO FilePath defaultConfigPath = @@ -35,6 +38,7 @@ , _cmdArgServer :: String , _cmdArgPort :: Maybe Int , _cmdArgHelp :: Bool + , _cmdArgVersion :: Bool , _cmdArgReal :: Maybe String , _cmdArgUser :: Maybe String , _cmdArgSaslUser :: Maybe String @@ -50,41 +54,52 @@ makeLenses ''CommandArgs +emptyCommandArgs :: CommandArgs +emptyCommandArgs = CommandArgs + { _cmdArgServer = "" + , _cmdArgReal = Nothing + , _cmdArgUser = Nothing + , _cmdArgNick = Nothing + , _cmdArgUserInfo = Nothing + + , _cmdArgSaslUser = Nothing + , _cmdArgPort = Nothing + , _cmdArgHelp = False + , _cmdArgVersion = False + , _cmdArgDebug = Nothing + , _cmdArgTls = False + , _cmdArgTlsClientCert = Nothing + , _cmdArgTlsClientKey = Nothing + , _cmdArgTlsInsecure = False + , _cmdArgConfigFile = Nothing + , _cmdArgConfigValue = Sections [] + } + getCommandArgs :: IO CommandArgs getCommandArgs = do args <- getArgs - r <- case getOpt RequireOrder optDescrs args of - (fs, [server], []) -> - do let r0 = CommandArgs - { _cmdArgServer = server - , _cmdArgReal = Nothing - , _cmdArgUser = Nothing - , _cmdArgNick = Nothing - , _cmdArgUserInfo = Nothing - - , _cmdArgSaslUser = Nothing - , _cmdArgPort = Nothing - , _cmdArgHelp = False - , _cmdArgDebug = Nothing - , _cmdArgTls = False - , _cmdArgTlsClientCert = Nothing - , _cmdArgTlsClientKey = Nothing - , _cmdArgTlsInsecure = False - , _cmdArgConfigFile = Nothing - , _cmdArgConfigValue = Sections [] - } - return (foldl (\acc f -> f acc) r0 fs) - - (_ , _, errs) -> - do traverse_ (hPutStrLn stderr) errs - help + let (flags, servers, errors) = getOpt Permute optDescrs args + r = foldl' (\acc f -> f acc) emptyCommandArgs flags when (view cmdArgHelp r) help + when (view cmdArgVersion r) emitVersion + unless (null errors) $ + do traverse_ (hPutStrLn stderr) errors + exitFailure + server <- case servers of + [server] -> return server + [] -> do hPutStrLn stderr "Expected server name argument (try --help)" + exitFailure + _ -> do hPutStrLn stderr "Too many server name arguments (try --help)" + exitFailure v <- loadConfigValue (view cmdArgConfigFile r) - return (set cmdArgConfigValue v r) + return $ set cmdArgServer server + $ set cmdArgConfigValue v + $ r + help :: IO a help = do prog <- getProgName @@ -92,6 +107,11 @@ hPutStr stderr (usageInfo txt optDescrs) exitFailure +emitVersion :: IO a +emitVersion = + do putStrLn ("glirc " ++ showVersion version) + exitSuccess + optDescrs :: [OptDescr (CommandArgs -> CommandArgs)] optDescrs = [ Option "c" [ "config"] (ReqArg (set cmdArgConfigFile . Just) "FILENAME") "Configuration file path (default ~/.glirc/config)" @@ -106,6 +126,7 @@ , Option "" [ "tls-client-cert"] (ReqArg (set cmdArgTlsClientCert . Just) "PATH") "Path to PEM encoded client certificate" , Option "" [ "tls-client-key"] (ReqArg (set cmdArgTlsClientKey . Just) "PATH") "Path to PEM encoded client key" , Option "" [ "tls-insecure"] (NoArg (set cmdArgTlsInsecure True)) "Disable server certificate verification" + , Option "v" [ "version"] (NoArg (set cmdArgVersion True)) "Show version" , Option "h" [ "help"] (NoArg (set cmdArgHelp True)) "Show help" ] diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -15,19 +15,22 @@ import Control.Monad.IO.Class import Data.ByteString (ByteString) import Data.Char +import Data.Fixed (Centi, Pico, showFixed) import Data.Foldable (for_, traverse_) import Data.List (elemIndex) import Data.List.Split (chunksOf) +import Data.IORef import Data.Maybe (fromMaybe) import Data.Monoid import Data.Set (Set) import Data.Text (Text) import Data.Time +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Traversable (for) import Graphics.Vty import Network.Connection import System.IO -import System.IO.Error (isEOFError, ioeGetErrorString) +import System.IO.Error (isEOFError) import qualified Config import qualified Config.Lens as C import qualified Data.ByteString as B @@ -86,29 +89,33 @@ recvChan settings hErr (width,height) <- displayBounds (outputIface vty) zone <- getCurrentTimeZone - driver vty vtyEventChan recvChan ClientState - { _clientServer0 = server0 - , _clientRecvChan = recvChan - , _clientErrors = hErr - , _clientFocus = ChannelFocus "" - , _clientDetailView = False - , _clientTimeView = True - , _clientMetaView = True - , _clientEditBox = Edit.empty - , _clientTabPattern = Nothing - , _clientScrollPos = 0 - , _clientHeight = height - , _clientWidth = width - , _clientIgnores = mempty - , _clientHighlights = mempty - , _clientMessages = mempty - , _clientNickColors = defaultNickColors - , _clientAutomation = [ctcpHandler,cancelDeopTimerOnDeop] - , _clientTimers = mempty - , _clientTimeZone = zone - , _clientConfig = view cmdArgConfigValue args - } + let st0 = ClientState + { _clientServer0 = server0 + , _clientRecvChan = recvChan + , _clientErrors = hErr + , _clientFocus = ChannelFocus "" + , _clientDetailView = False + , _clientTimeView = True + , _clientMetaView = True + , _clientEditBox = Edit.empty + , _clientTabPattern = Nothing + , _clientScrollPos = 0 + , _clientHeight = height + , _clientWidth = width + , _clientIgnores = mempty + , _clientHighlights = mempty + , _clientMessages = mempty + , _clientNickColors = defaultNickColors + , _clientAutomation = [ctcpHandler,cancelDeopTimerOnDeop] + , _clientTimers = mempty + , _clientTimeZone = zone + , _clientConfig = view cmdArgConfigValue args + } + st1 <- schedulePing st0 + + driver vty vtyEventChan recvChan st1 + withVty :: (Vty -> IO a) -> IO a withVty k = do cfg <- standardIOConfig @@ -136,7 +143,8 @@ connectionSuceeded h = do sendChan <- atomically newTChan - sendThreadId <- forkIO (sendLoop sendChan h) + connectedRef <- newIORef True + sendThreadId <- forkIO (sendLoop connectedRef sendChan h) recvThreadId <- forkIO (socketLoop recvChan h hErr) initializeConnection pass nick user real h return ClientConnection @@ -145,7 +153,7 @@ { _connNick = nick , _connSasl = sasl } - , _ccSendChan = Just sendChan + , _ccSendChan = Just (connectedRef, sendChan) , _ccRecvThread = Just recvThreadId , _ccSendThread = Just sendThreadId } @@ -200,6 +208,11 @@ processTimerEvent e st = case e of + TransmitPing -> + do sendTimestampPing st + st' <- schedulePing st + considerTimers st' + DropOperator chan -> do clientSend (modeCmd chan ["-o",views connNick idBytes conn]) st considerTimers st @@ -261,14 +274,14 @@ -- Key Event Handlers! ------------------------------------------------------------------------ -data EventResult +data KeyEventResult = KeepGoing ClientState | Exit changeInput :: (Edit.EditBox -> Edit.EditBox) -> ClientState -> ClientState changeInput f st = clearTabPattern (over clientEditBox f st) -inputLogic :: ClientState -> (Image, IO EventResult) +inputLogic :: ClientState -> (Image, IO KeyEventResult) inputLogic st = case clientInput st of '/':_ -> case commandEvent st of @@ -276,7 +289,7 @@ (img, Just m ) -> (img, m) txt -> (stringWithControls defAttr txt, fmap KeepGoing (doSendMessageCurrent SendPriv st)) -keyEvent :: Key -> [Modifier] -> ClientState -> IO EventResult +keyEvent :: Key -> [Modifier] -> ClientState -> IO KeyEventResult keyEvent k ms st = let more = return . KeepGoing in case (k,ms) of @@ -386,7 +399,7 @@ who = UserInfo (view connNick conn) Nothing Nothing -commandEvent :: ClientState -> (Image, Maybe (IO EventResult)) +commandEvent :: ClientState -> (Image, Maybe (IO KeyEventResult)) commandEvent st = commandsParser (clientInput st) (exitCommand : normalCommands) where @@ -574,8 +587,16 @@ , ("reconnect", [], pure (doReconnect st')) + , ("ping", [], + (\msg -> st' <$ doPingCmd msg st') + <$> pRemainingNoSp) + ] +doPingCmd :: String -> ClientState -> IO () +doPingCmd "" st = sendTimestampPing st +doPingCmd msg st = clientSend (pingCmd (Text.encodeUtf8 (Text.pack msg))) st + doReconnect :: ClientState -> IO ClientState doReconnect st = do let server0 = view clientServer0 st @@ -824,12 +845,24 @@ dividerImage :: ClientState -> Image dividerImage st - = extendToWidth (nickPart <|> channelPart) + = extendToWidth (nickPart <|> channelPart <|> lagPart) where conn = view (clientServer0 . ccConnection) st myNick = view connNick conn + lagPart = + case view connPingTime conn of + Just s -> + let s' = realToFrac s :: Centi -- truncate to two decimal places + sStr = showFixed True s' <> "s" + in + string defAttr "-[" + <|> string (withForeColor defAttr yellow) sStr + <|> string defAttr "]" + + _ -> emptyImage + channelPart = ifoldr (\i x xs -> drawOne i x <|> xs) emptyImage @@ -891,13 +924,15 @@ -- Event loops ------------------------------------------------------------------------ -sendLoop :: TChan ByteString -> Connection -> IO () -sendLoop queue h = +sendLoop :: IORef Bool -> TChan ByteString -> Connection -> IO () +sendLoop connectedRef queue h = do r <- newRateLimitDefault forever $ do x <- atomically (readTChan queue) tickRateLimit r connectionPut h x + `catch` \(SomeException _) -> + writeIORef connectedRef False -- exit silently socketLoop :: TChan (UTCTime, MsgFromServer) -> Connection -> Maybe Handle -> IO () socketLoop chan h hErr = @@ -1010,3 +1045,17 @@ defaultNickColors = [cyan, magenta, green, yellow, blue, brightCyan, brightMagenta, brightGreen, brightBlue] + +schedulePing :: ClientState -> IO ClientState +schedulePing st = + do now <- getCurrentTime + let pingTime = addUTCTime 60 now + return (addTimerEvent pingTime TransmitPing st) + +sendTimestampPing :: ClientState -> IO () +sendTimestampPing st = + do now <- getCurrentTime + let ts = realToFrac (utcTimeToPOSIXSeconds now) :: Pico + chopTrailingZeros = True + tsStr = B8.pack (showFixed chopTrailingZeros ts) + clientSend (pingCmd tsStr) st diff --git a/driver/Views/Channel.hs b/driver/Views/Channel.hs --- a/driver/Views/Channel.hs +++ b/driver/Views/Channel.hs @@ -2,15 +2,24 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} + +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + +#ifndef MIN_VERSION_time +#define MIN_VERSION_time(x,y,z) 1 +#endif + module Views.Channel (channelImage) where import Control.Lens import Data.Monoid import Data.Maybe (fromMaybe) import Data.Foldable (toList) -import Data.List (stripPrefix, intersperse) +import Data.List (intersperse) +import qualified Data.Set as Set import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) import Data.Time (TimeZone, UTCTime, formatTime, utcToZonedTime) import Graphics.Vty.Image import qualified Data.ByteString.Char8 as BS8 @@ -23,6 +32,10 @@ import System.Locale (defaultTimeLocale) #endif +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + import Irc.Format import Irc.Message import Irc.Model @@ -93,16 +106,18 @@ activeMessages :: ClientState -> [(IrcMessage,Image)] activeMessages st = case clientInputFilter st of - FilterNick nick -> filter (nickFilter (BS8.pack nick) . fst) (toList msgs) - FilterBody text -> filter (bodyFilter text . fst) (toList msgs) + FilterNicks nicks -> let nickset = Set.fromList (mkId . BS8.pack <$> nicks) + in filter (nicksFilter nickset . fst) (toList msgs) + FilterBody regex -> filter (bodyFilter regex . fst) (toList msgs) NoFilter -> toList msgs where msgs = view (clientMessages . ix (focusedName st) . mlMessages) st - nickFilter nick msg - = views mesgSender userNick msg == mkId nick + nicksFilter nickset msg + = views mesgSender userNick msg `Set.member` nickset + bodyFilter :: String -> IrcMessage -> Bool - bodyFilter re msg - = fromMaybe False (textOfMessage msg =~~ re) + bodyFilter regex msg + = fromMaybe False (textOfMessage msg =~~ regex) textOfMessage :: IrcMessage -> String textOfMessage mesg = @@ -118,12 +133,12 @@ ErrorMsgType t -> t _ -> "") -data InputFilter = FilterNick String | FilterBody String | NoFilter +data InputFilter = FilterNicks [String] | FilterBody String | NoFilter clientInputFilter :: ClientState -> InputFilter clientInputFilter st = go (clientInput st) where - go (splitAt 8 -> ("/filter ",nick)) = FilterNick nick + go (splitAt 8 -> ("/filter ",nicks)) = FilterNicks (words nicks) go (splitAt 6 -> ("/grep ", txt)) = FilterBody txt go _ = NoFilter @@ -364,7 +379,7 @@ ErrMlockRestricted m ms -> "Mode '" <> Text.singleton m <> "' in locked set \"" <> asUtf8 ms <> "\"" splitWith :: (a -> Maybe b) -> [a] -> ([b],[a]) -splitWith f [] = ([],[]) +splitWith _ [] = ([],[]) splitWith f (x:xs) = case f x of Nothing -> ([],x:xs) diff --git a/irc-core.cabal b/irc-core.cabal --- a/irc-core.cabal +++ b/irc-core.cabal @@ -1,5 +1,5 @@ name: irc-core -version: 1.1.1.1 +version: 1.1.2 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues license: BSD3 @@ -11,7 +11,7 @@ build-type: Simple cabal-version: >=1.10 synopsis: An IRC client library and text client -tested-with: GHC == 7.8.4, GHC == 7.10.1 +tested-with: GHC == 7.8.4, GHC == 7.10.2 description: This package provides an IRC connection library as well as a console-based IRC client that uses the library. diff --git a/src/Irc/Model.hs b/src/Irc/Model.hs --- a/src/Irc/Model.hs +++ b/src/Irc/Model.hs @@ -31,6 +31,7 @@ , connSasl , connUmode , connSnoMask + , connPingTime , defaultIrcConnection -- * Phases @@ -93,16 +94,19 @@ import Control.Monad.Trans.Reader import Data.ByteString (ByteString) import Data.Char (toUpper) +import Data.Fixed (Pico) import Data.List (foldl',find,nub,delete,intersect) import Data.Map (Map) import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) import Data.Time +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as B8 import qualified Data.Map as Map +import Text.Read (readMaybe) #if !MIN_VERSION_base(4,8,0) import Control.Applicative @@ -137,6 +141,7 @@ , _connUmode :: !ByteString , _connSnoMask :: !ByteString , _connPhase :: !Phase + , _connPingTime :: Maybe Pico -- No read instance for NominalDiffTime } deriving (Read, Show) @@ -162,6 +167,7 @@ , _connUmode = "" , _connSnoMask = "" , _connPhase = RegistrationPhase + , _connPingTime = Nothing } data Phase @@ -268,8 +274,16 @@ case msg0 of Ping x -> sendMessage (pongCmd x) >> return conn + -- Treat numbers as POSIX times when PING was sent + Pong _ (Just txt) + | Just sec <- readMaybe (B8.unpack txt) -> + do now <- getStamp + let past = posixSecondsToUTCTime (realToFrac (sec :: Pico)) + delta = realToFrac (now `diffUTCTime` past) + return (set connPingTime (Just delta) conn) + Pong server mbMsg -> - doServerMessage "PONG" (server <> maybe "" (" "<>) mbMsg) conn + doServerMessage "Pong" (server <> maybe "" (" "<>) mbMsg) conn RplWelcome txt -> doServerMessage "Welcome" txt $ set connPhase ActivePhase conn diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -5,4 +5,4 @@ - config-value-0.4.0.1 - time-1.5.0.1 - vty-5.4.0 -resolver: lts-3.2 +resolver: lts-3.4