diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +1.1.3 +------- +* Support for running commands upon connection +* Support for SOCKS5 proxy +* Merge view of all channels (F5) + 1.1.2 ------- * Support multiple nicknames in `/filter` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -28,6 +28,8 @@ * Command syntax highlighting with hints. * Each user's nick is assigned a consistent color, when a user's nick is rendered in a chat message it uses that same color. * Support for /STATUSMSG/ messages +* Togglable support for merged view of all joined channels (F5). +* Run commands upon connection TLS === @@ -93,9 +95,14 @@ * hostname: "chat.freenode.net" sasl-username: "someuser" sasl-password: "somepass" + socks-host: "socks5.example.com" + socks-port: 8080 -- defaults to 1080 * hostname: "example.com" port: 7000 + connect-cmds: + * "JOIN #favoritechannel,#otherchannel" + * "PRIVMSG mybot another command" -- Specify additional certificates beyond the system CAs server-certificates: @@ -178,6 +185,7 @@ * `F2` toggle detailed view * `F3` toggle timestamps * `F4` toggle compressed metadata +* `F5` toggle all channel view * `Page Up` scroll up * `Page Down` scroll down * `^B` bold diff --git a/driver/ClientState.hs b/driver/ClientState.hs --- a/driver/ClientState.hs +++ b/driver/ClientState.hs @@ -63,6 +63,7 @@ , _clientDetailView :: !Bool , _clientTimeView :: !Bool , _clientMetaView :: !Bool + , _clientFullView :: !Bool , _clientEditBox :: EditBox , _clientTabPattern :: Maybe String , _clientScrollPos :: Int diff --git a/driver/CommandArgs.hs b/driver/CommandArgs.hs --- a/driver/CommandArgs.hs +++ b/driver/CommandArgs.hs @@ -14,6 +14,7 @@ import Data.Text (Text) import Data.Text.Lens (unpacked) import Data.Version (showVersion) +import Network.Socket (PortNumber) import System.Console.GetOpt import System.Directory import System.Environment @@ -28,6 +29,9 @@ import ServerSettings import Paths_irc_core +defaultSocksPort :: PortNumber +defaultSocksPort = 1080 + defaultConfigPath :: IO FilePath defaultConfigPath = do dir <- getAppUserDataDirectory "glirc" @@ -176,6 +180,14 @@ , _ssTlsClientKey = view cmdArgTlsClientKey args <|> defaultStr hostTxt "tls-client-key" args + + , _ssConnectCmds = toListOf (cmdArgConfigValue . configPath hostTxt "connect-cmds" + . values . text) args + + , _ssSocksProxy = do h <- defaultStr hostTxt "socks-host" args + let p = maybe defaultSocksPort fromIntegral + $ defaultNum hostTxt "socks-port" args + return (h,p) } diff --git a/driver/ConnectCmds.hs b/driver/ConnectCmds.hs new file mode 100644 --- /dev/null +++ b/driver/ConnectCmds.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +module ConnectCmds (connectCmds) where + +import Control.Lens +import Data.Foldable (for_) +import Data.Text.Encoding +import Data.Monoid ((<>)) + +import Irc.Message +import Irc.Format +import ClientState +import ServerSettings + +connectCmds :: EventHandler +connectCmds = EventHandler + { _evName = "connect commands" + , _evOnEvent = handler + } + +handler :: Identifier -> IrcMessage -> ClientState -> IO ClientState + +handler ident mesg st + | ident == "" + , views mesgSender userNick mesg == "Welcome" = + do let cmds = view (clientServer0 . ccServerSettings . ssConnectCmds) st + for_ cmds $ \cmd -> + clientSend (encodeUtf8 cmd<>"\r\n") st + return st + + | otherwise = return (reschedule st) + +-- Reschedule the autojoin handler for the next message +reschedule :: ClientState -> ClientState +reschedule = over clientAutomation (cons connectCmds) diff --git a/driver/Connection.hs b/driver/Connection.hs --- a/driver/Connection.hs +++ b/driver/Connection.hs @@ -49,11 +49,15 @@ do useSecure <- if view ssTls args then fmap Just (buildTlsSettings config args) else return Nothing + + let proxySettings = fmap (uncurry SockSettingsSimple) + (view ssSocksProxy args) + return ConnectionParams { connectionHostname = view ssHostName args , connectionPort = ircPort args , connectionUseSecure = useSecure - , connectionUseSocks = Nothing + , connectionUseSocks = proxySettings } ircPort :: ServerSettings -> PortNumber diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -48,6 +48,7 @@ import Irc.Model import Irc.RateLimit +import ConnectCmds (connectCmds) import ClientState import Connection (connect, getRawIrcLine) import CommandArgs @@ -98,6 +99,7 @@ , _clientDetailView = False , _clientTimeView = True , _clientMetaView = True + , _clientFullView = False , _clientEditBox = Edit.empty , _clientTabPattern = Nothing , _clientScrollPos = 0 @@ -107,7 +109,7 @@ , _clientHighlights = mempty , _clientMessages = mempty , _clientNickColors = defaultNickColors - , _clientAutomation = [ctcpHandler,cancelDeopTimerOnDeop] + , _clientAutomation = [ctcpHandler,cancelDeopTimerOnDeop,connectCmds] , _clientTimers = mempty , _clientTimeZone = zone , _clientConfig = view cmdArgConfigValue args @@ -296,6 +298,7 @@ (KFun 2 , [] ) -> more $ over clientDetailView not st (KFun 3 , [] ) -> more $ over clientTimeView not st (KFun 4 , [] ) -> more $ over clientMetaView not st + (KFun 5 , [] ) -> more $ over clientFullView not st (KPageUp , _ ) -> more $ scrollUp st (KPageDown, _ ) -> more $ scrollDown st (KChar 'n', [MCtrl]) -> more $ nextFocus st diff --git a/driver/ServerSettings.hs b/driver/ServerSettings.hs --- a/driver/ServerSettings.hs +++ b/driver/ServerSettings.hs @@ -3,6 +3,7 @@ module ServerSettings where import Control.Lens +import Data.Text import Network.Socket (HostName, PortNumber) @@ -19,6 +20,8 @@ , _ssTlsInsecure :: Bool , _ssTlsClientCert :: Maybe FilePath , _ssTlsClientKey :: Maybe FilePath + , _ssConnectCmds :: [Text] + , _ssSocksProxy :: Maybe (HostName,PortNumber) } makeLenses ''ServerSettings diff --git a/driver/Views/Channel.hs b/driver/Views/Channel.hs --- a/driver/Views/Channel.hs +++ b/driver/Views/Channel.hs @@ -13,18 +13,21 @@ module Views.Channel (channelImage) where -import Control.Lens -import Data.Monoid -import Data.Maybe (fromMaybe) -import Data.Foldable (toList) -import Data.List (intersperse) +import Control.Lens +import qualified Data.ByteString as BS +import Data.Foldable (toList) +import Data.List (intersperse) +import Data.Maybe (isJust) +import qualified Data.Map as Map +import Data.Monoid import qualified Data.Set as Set -import Data.Text (Text) -import Data.Time (TimeZone, UTCTime, formatTime, utcToZonedTime) -import Graphics.Vty.Image -import qualified Data.ByteString.Char8 as BS8 +import Data.Text (Text) +import Data.Time (TimeZone, UTCTime, formatTime, utcToZonedTime) import qualified Data.Text as Text -import Text.Regex.TDFA +import qualified Data.Text.Encoding as Text +import Graphics.Vty.Image +import Text.Regex.TDFA +import Text.Regex.TDFA.ByteString (compile, execute) #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) @@ -51,13 +54,12 @@ detailedImageForState :: ClientState -> [Image] detailedImageForState !st - = map renderOne - $ map fst - $ activeMessages st + = [ renderOne chan msg | (chan, msg, _img) <- activeMessages st] where zone = view clientTimeZone st - renderOne x = + renderOne chan x = timestamp <|> + channel <|> string (withForeColor defAttr tyColor) (ty ++ " ") <|> statusMsgImage (view mesgStatus x) <|> renderFullUsermask (view mesgSender x) <|> @@ -68,6 +70,12 @@ | view clientTimeView st = renderTimestamp zone (view mesgStamp x) | otherwise = emptyImage + -- show all channel names in detailed/full view + channel + | view clientFullView st = identImg (withForeColor defAttr brightBlack) chan + <|> string defAttr " " + | otherwise = emptyImage + (tyColor, ty, content) = case view mesgType x of JoinMsgType -> (green , "Join", "") PartMsgType txt -> (red , "Part", txt) @@ -94,7 +102,7 @@ renderTimestamp :: TimeZone -> UTCTime -> Image renderTimestamp zone = string (withForeColor defAttr brightBlack) - . formatTime defaultTimeLocale "%H:%M:%S " + . formatTime defaultTimeLocale "%F %H:%M:%S " . utcToZonedTime zone renderCompressedTimestamp :: TimeZone -> UTCTime -> Image @@ -103,25 +111,34 @@ . formatTime defaultTimeLocale "[%H:%M] " . utcToZonedTime zone -activeMessages :: ClientState -> [(IrcMessage,Image)] +activeMessages :: ClientState -> [(Identifier,IrcMessage,Image)] activeMessages st = case clientInputFilter st of - 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 + FilterNicks nicks -> let nickset = Set.fromList (mkId . toUtf8 <$> nicks) + in filter (nicksFilter nickset . view _2) msgs + FilterBody regex -> let r = compile defaultCompOpt defaultExecOpt regex + in filter (bodyFilter r . view _2) msgs + NoFilter -> msgs where - msgs = view (clientMessages . ix (focusedName st) . mlMessages) st + focus = focusedName st + + msgs :: [(Identifier,IrcMessage,Image)] + msgs | view clientFullView st = interleavedMessages st + | otherwise = + [ (focus, msg, img) | (msg,img) <- views (clientMessages . ix (focusedName st) . mlMessages) toList st ] + nicksFilter nickset msg = views mesgSender userNick msg `Set.member` nickset - bodyFilter :: String -> IrcMessage -> Bool - bodyFilter regex msg - = fromMaybe False (textOfMessage msg =~~ regex) + bodyFilter :: Either a Regex -> IrcMessage -> Bool + bodyFilter (Left _) _ = True -- regex compilation failed + bodyFilter (Right r) msg = + let isMatch = either (const True) isJust . execute r + in isMatch (textOfMessage msg) -textOfMessage :: IrcMessage -> String +textOfMessage :: IrcMessage -> BS.ByteString textOfMessage mesg = - let f n = (BS8.unpack $ idBytes $ views mesgSender userNick mesg) <> ": " <> Text.unpack n + let f n = idBytes (views mesgSender userNick mesg) <> ": " <> Text.encodeUtf8 n in f (case mesg ^. mesgType of PrivMsgType t -> t NoticeMsgType t -> t @@ -133,13 +150,13 @@ ErrorMsgType t -> t _ -> "") -data InputFilter = FilterNicks [String] | FilterBody String | NoFilter +data InputFilter = FilterNicks [String] | FilterBody BS.ByteString | NoFilter clientInputFilter :: ClientState -> InputFilter clientInputFilter st = go (clientInput st) where go (splitAt 8 -> ("/filter ",nicks)) = FilterNicks (words nicks) - go (splitAt 6 -> ("/grep ", txt)) = FilterBody txt + go (splitAt 6 -> ("/grep ", txt)) = FilterBody (toUtf8 txt) go _ = NoFilter compressedImageForState :: ClientState -> [Image] @@ -147,6 +164,7 @@ where zone = view clientTimeZone st width = view clientWidth st + activeChan = focusedName st ncolors = views clientNickColors length st formatNick me nick = identImg (withForeColor defAttr color) nick @@ -158,10 +176,10 @@ ignores = view clientIgnores st renderOne [] = [] - renderOne ((msg,colored):msgs) = + renderOne ((chan,msg,colored):msgs) = case mbImg of - Just img -> (timestamp <|> img) : renderOne msgs - Nothing -> renderMeta ((msg,colored):msgs) + Just img -> (timestamp <|> channel <|> img) : renderOne msgs + Nothing -> renderMeta ((chan,msg,colored):msgs) where timestamp @@ -172,6 +190,13 @@ visible = not (view (contains nick) ignores) + -- when in the full monitor view we only show the names of the channels + -- next to messages for the unfocused channel + channel + | chan == activeChan = emptyImage + | otherwise = identImg (withForeColor defAttr brightBlack) chan + <|> string defAttr " " + mbImg = case view mesgType msg of PrivMsgType _ | visible -> Just $ @@ -255,29 +280,35 @@ _ -> Nothing - filterMeta x - | view clientMetaView st = [x] - | otherwise = [] - - renderMeta msgs = filterMeta (cropRight width img) + renderMeta msgs = img ++ renderOne rest where - (mds,rest) = splitWith (processMeta . fst) msgs + (mds,rest) = splitWith processMeta msgs mds1 = mergeMetadatas mds - img = horizCat (intersperse gap (map renderCompressed mds1)) gap = char defAttr ' ' - processMeta msg = + -- the mds1 can be null in the full view due to dropped metas + img | not (null mds1), view clientMetaView st + = return -- singleton list + $ cropRight width + $ horizCat + $ intersperse gap + $ map renderCompressed mds1 + | otherwise = [] + + processMeta (chan,msg,_) = case view mesgType msg of - CtcpReqMsgType{} -> Just $ SimpleMetadata (char (withForeColor defAttr brightBlue) 'C') who - JoinMsgType -> Just $ SimpleMetadata (char (withForeColor defAttr green) '+') who - PartMsgType{} -> Just $ SimpleMetadata (char (withForeColor defAttr red) '-') who - QuitMsgType{} -> Just $ SimpleMetadata (char (withForeColor defAttr red) 'x') who - KnockMsgType -> Just $ SimpleMetadata (char (withForeColor defAttr yellow) 'K') who - NickMsgType who' -> Just $ NickChange who who' - _ | not visible -> Just $ SimpleMetadata (char (withForeColor defAttr yellow) 'I') who - | otherwise -> Nothing + CtcpReqMsgType{} -> keep $ SimpleMetadata (char (withForeColor defAttr brightBlue) 'C') who + JoinMsgType -> keep $ SimpleMetadata (char (withForeColor defAttr green) '+') who + PartMsgType{} -> keep $ SimpleMetadata (char (withForeColor defAttr red) '-') who + QuitMsgType{} -> keep $ SimpleMetadata (char (withForeColor defAttr red) 'x') who + KnockMsgType -> keep $ SimpleMetadata (char (withForeColor defAttr yellow) 'K') who + NickMsgType who' -> keep $ NickChange who who' + _ | not visible -> keep $ SimpleMetadata (char (withForeColor defAttr yellow) 'I') who + | otherwise -> Done where + keep | chan == activeChan = Keep + | otherwise = const Drop who = views mesgSender userNick msg visible = not (view (contains who) ignores) @@ -376,14 +407,21 @@ ErrChanOpen -> "Knock unnecessary" ErrTargUmodeG -> "Message ignored by +g mode" ErrNoPrivs priv -> "Oper privilege required: " <> asUtf8 priv - ErrMlockRestricted m ms -> "Mode '" <> Text.singleton m <> "' in locked set \"" <> asUtf8 ms <> "\"" + ErrMlockRestricted m ms -> "Mode '" <> Text.singleton m <> "' in locked set \"" + <> asUtf8 ms <> "\"" -splitWith :: (a -> Maybe b) -> [a] -> ([b],[a]) +data SplitResult a + = Drop -- drop this element but keep processing + | Done -- stop processing + | Keep a -- produce an output and keep processing + +splitWith :: (a -> SplitResult b) -> [a] -> ([b],[a]) splitWith _ [] = ([],[]) splitWith f (x:xs) = case f x of - Nothing -> ([],x:xs) - Just y -> case splitWith f xs of + Done -> ([],x:xs) + Drop -> splitWith f xs + Keep y -> case splitWith f xs of (ys,xs') -> (y:ys, xs') mergeMetadatas :: [CompressedMetadata] -> [CompressedMetadata] @@ -391,3 +429,40 @@ | who1 == who2 = mergeMetadatas (SimpleMetadata (img1 <|> img2) who1 : xs) mergeMetadatas (x:xs) = x : mergeMetadatas xs mergeMetadatas [] = [] + +interleavedMessages :: ClientState -> [(Identifier,IrcMessage,Image)] +interleavedMessages st = merge lists + where + lists :: [[(Identifier,IrcMessage,Image)]] + lists = [ [ (chan, msg, img) | (msg,img) <- view mlMessages msgs ] + | (chan,msgs) <- views clientMessages Map.toList st + ] + + merge :: + [[(Identifier,IrcMessage,Image)]] -> + [(Identifier,IrcMessage,Image)] + merge [] = [] + merge [x] = x + merge xs = merge (mergeN1 xs) + + -- merge every two lists into one + mergeN1 :: + [[(Identifier,IrcMessage,Image)]] -> + [[(Identifier,IrcMessage,Image)]] + mergeN1 [] = [] + mergeN1 [x] = [x] + mergeN1 (x:y:z) = merge2 x y : mergeN1 z + + -- merge two sorted lists into one + merge2 :: + [(Identifier,IrcMessage,Image)] -> + [(Identifier,IrcMessage,Image)] -> + [(Identifier,IrcMessage,Image)] + merge2 [] ys = ys + merge2 xs [] = xs + merge2 (x:xs) (y:ys) + | view (_2.mesgStamp) x >= view (_2.mesgStamp) y = x : merge2 xs (y:ys) + | otherwise = y : merge2 (x:xs) ys + +toUtf8 :: String -> BS.ByteString +toUtf8 = Text.encodeUtf8 . Text.pack 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.2 +version: 1.1.3 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues license: BSD3 @@ -69,7 +69,6 @@ extra-source-files: README.md CHANGELOG.md - stack.yaml -- Use time-1.5 and drop old-locale flag time15 @@ -98,7 +97,7 @@ base64-bytestring>= 1.0.0.1 && < 1.1, containers >= 0.5 && < 0.6, free >= 4.11 && < 4.13, - lens >= 4.7 && < 4.13, + lens >= 4.7 && < 4.14, text >= 1.2.0.4 && < 1.3, transformers >= 0.2 && < 0.5, regex-tdfa >= 1.2 && < 1.3 @@ -118,6 +117,7 @@ CommandArgs CommandParser Connection + ConnectCmds CtcpHandler EditBox HaskellHighlighter @@ -148,7 +148,7 @@ deepseq >= 1.3.0.2 && < 1.5, directory >= 1.2.1.0 && < 1.3, filepath >= 1.3.0.2 && < 1.5, - lens >= 4.7 && < 4.13, + lens >= 4.7 && < 4.14, network >= 2.6.0.2 && < 2.7, old-locale >= 1.0.0.6 && < 1.1, split >= 0.2.2 && < 0.3, diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,8 +0,0 @@ -flags: {} -packages: -- '.' -extra-deps: -- config-value-0.4.0.1 -- time-1.5.0.1 -- vty-5.4.0 -resolver: lts-3.4