irc-core 1.1.2 → 1.1.3
raw patch · 11 files changed
+203/−65 lines, 11 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- README.md +8/−0
- driver/ClientState.hs +1/−0
- driver/CommandArgs.hs +12/−0
- driver/ConnectCmds.hs +34/−0
- driver/Connection.hs +5/−1
- driver/Main.hs +4/−1
- driver/ServerSettings.hs +3/−0
- driver/Views/Channel.hs +126/−51
- irc-core.cabal +4/−4
- stack.yaml +0/−8
CHANGELOG.md view
@@ -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`
README.md view
@@ -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
driver/ClientState.hs view
@@ -63,6 +63,7 @@ , _clientDetailView :: !Bool , _clientTimeView :: !Bool , _clientMetaView :: !Bool+ , _clientFullView :: !Bool , _clientEditBox :: EditBox , _clientTabPattern :: Maybe String , _clientScrollPos :: Int
driver/CommandArgs.hs view
@@ -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) }
+ driver/ConnectCmds.hs view
@@ -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)
driver/Connection.hs view
@@ -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
driver/Main.hs view
@@ -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
driver/ServerSettings.hs view
@@ -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
driver/Views/Channel.hs view
@@ -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
irc-core.cabal view
@@ -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,
− stack.yaml
@@ -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