irc-core 1.1.1.1 → 1.1.2

raw patch · 9 files changed

+194/−83 lines, 9 filesdep ~lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: lens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +3/−1
• driver/ClientState.hs +11/−8
• driver/CommandArgs.hs +48/−27
• driver/Main.hs +81/−32
• driver/Views/Channel.hs +26/−11
• irc-core.cabal +2/−2
• src/Irc/Model.hs +15/−1
• stack.yaml +1/−1

@@ -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

@@ -149,10 +149,12 @@ * `/knock` - Request an /invite/ to a restricted channel * `/invite <nick>` - Invite the given user to the current channel * `/reconnect` - Reconnect to the current server+* `/ping` - Send ping to upload current roundtrip time+* `/ping <msg>` - 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

@@ -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])

@@ -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"   ] 

@@ -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

@@ -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)

@@ -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.

@@ -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

@@ -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