glirc 2.2 → 2.3
raw patch · 15 files changed
+317/−205 lines, 15 files
Files
- ChangeLog.md +7/−0
- README.md +7/−0
- glirc.cabal +1/−1
- src/Client/ChannelState.hs +13/−9
- src/Client/Commands.hs +136/−101
- src/Client/Connect.hs +3/−6
- src/Client/ConnectionState.hs +58/−48
- src/Client/EventLoop.hs +8/−4
- src/Client/Image.hs +10/−0
- src/Client/Image/MaskList.hs +19/−9
- src/Client/State.hs +25/−8
- src/Irc/Commands.hs +11/−0
- src/Irc/Identifier.hs +3/−14
- src/Irc/Modes.hs +5/−5
- src/LensUtils.hs +11/−0
ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for glirc2 +## 2.3++* Add commands `/znc`+* Add initial support for ZNC's playback module and `/znc-playback` command+* Don't consider message seen when in masklist, userlist, or channelinfo windows+* Add terminal bell on command error+ ## 2.2 * Add commands `/ison`, `/userhost`, `/away`, `/notice`, `/ctcp`, `/links`, `/time`, `/stats`
README.md view
@@ -182,6 +182,13 @@ * `/grep` - Filter chat messages using a regular expression * `/grepi` - Filter chat messages using a case-insensitive regular expression on the message +ZNC-specific++* `/znc <module> <parameters>` - send command to ZNC module without echoing to all clients+* `/znc-playback` - ZNC playback module - play everything+* `/znc-playback <time>` - ZNC playback module - play everything start at the given time today+* `/znc-playback <date> <time>` - ZNC playback module - play everything start at the given time+ Low-level * `/quote <raw command>` - Send a raw IRC command to the server
glirc.cabal view
@@ -1,5 +1,5 @@ name: glirc-version: 2.2+version: 2.3 synopsis: Console IRC client description: Console IRC client license: ISC
src/Client/ChannelState.hs view
@@ -23,10 +23,14 @@ , chanUsers , chanModes , chanLists- , chanList , chanCreation , chanQueuedModeration + -- * Mask list entries+ , MaskListEntry(..)+ , maskListSetter+ , maskListTime+ -- * Topic information , TopicProvenance(..) , topicAuthor@@ -64,7 +68,7 @@ -- ^ user list and sigils , _chanModes :: !(Map Char Text) -- ^ channel settings and parameters- , _chanLists :: !(Map Char (HashMap Text (Text, UTCTime)))+ , _chanLists :: !(Map Char (HashMap Text MaskListEntry)) -- ^ mode, mask, setter, set time , _chanCreation :: !(Maybe UTCTime) -- ^ creation time of channel , _chanQueuedModeration :: ![RawIrcMsg] -- ^ delayed op messages@@ -77,8 +81,15 @@ } deriving Show +data MaskListEntry = MaskListEntry+ { _maskListSetter :: {-# UNPACK #-} !Text+ , _maskListTime :: {-# UNPACK #-} !UTCTime+ }+ deriving Show+ makeLenses ''ChannelState makeLenses ''TopicProvenance+makeLenses ''MaskListEntry -- | Construct an empty 'ChannelState' newChannel :: ChannelState@@ -93,13 +104,6 @@ , _chanQueuedModeration = [] } --- | 'Lens' into a mask list for a given mode.-chanList ::- 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 joinChannel :: Identifier -> ChannelState -> ChannelState
src/Client/Commands.hs view
@@ -68,6 +68,12 @@ commandContinue :: Monad m => ClientState -> m CommandResult commandContinue = return . CommandContinue +commandSuccess :: Monad m => ClientState -> m CommandResult+commandSuccess = return . CommandContinue . consumeInput++commandFailure :: Monad m => ClientState -> m CommandResult+commandFailure = return . CommandContinue . set clientBell True+ splitWord :: String -> (String, String) splitWord str = (w, drop 1 rest) where@@ -110,7 +116,7 @@ network cs channelId st rest _ -> case tabCompleteReversed of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just isReversed -> commandContinue (nickTabCompletion isReversed st) commands :: HashMap Text Command@@ -140,6 +146,8 @@ , ("links" , NetworkCommand cmdLinks simpleNetworkTab) , ("time" , NetworkCommand cmdTime simpleNetworkTab) , ("stats" , NetworkCommand cmdStats simpleNetworkTab)+ , ("znc" , NetworkCommand cmdZnc simpleNetworkTab)+ , ("znc-playback", NetworkCommand cmdZncPlayback noNetworkTab) , ("invite" , ChannelCommand cmdInvite simpleChannelTab) , ("topic" , ChannelCommand cmdTopic tabTopic )@@ -155,13 +163,13 @@ ] noClientTab :: Bool -> ClientCommand-noClientTab _ st _ = commandContinue st+noClientTab _ st _ = commandFailure st noNetworkTab :: Bool -> NetworkCommand-noNetworkTab _ _ _ st _ = commandContinue st+noNetworkTab _ _ _ st _ = commandFailure st noChannelTab :: Bool -> ChannelCommand-noChannelTab _ _ _ _ st _ = commandContinue st+noChannelTab _ _ _ _ st _ = commandFailure st simpleClientTab :: Bool -> ClientCommand simpleClientTab isReversed st _ =@@ -175,18 +183,15 @@ simpleChannelTab isReversed _ _ _ st _ = commandContinue (nickTabCompletion isReversed st) -cmdExit :: ClientState -> String -> IO CommandResult+cmdExit :: ClientCommand cmdExit _ _ = return CommandQuit -- | When used on a channel that the user is currently -- joined to this command will clear the messages but -- preserve the window. When used on a window that the -- user is not joined to this command will delete the window.-cmdClear :: ClientState -> String -> IO CommandResult-cmdClear st _- = commandContinue- $ windowEffect- $ consumeInput st+cmdClear :: ClientCommand+cmdClear st _ = commandSuccess (windowEffect st) where windowEffect | isActive = clearWindow@@ -207,16 +212,16 @@ . csChannels . ix channel) st -cmdQuote :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdQuote :: NetworkCommand cmdQuote _ cs st rest = case parseRawIrcMsg (Text.pack rest) of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just raw -> do sendMsg cs raw- commandContinue (consumeInput st)+ commandSuccess st -- | Implementation of @/me@-cmdMe :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdMe :: ChannelCommand cmdMe network cs channelId st rest = do now <- getZonedTime let actionTxt = Text.pack ("\^AACTION " ++ rest ++ "\^A")@@ -227,15 +232,14 @@ , _msgBody = IrcBody (Ctcp myNick channelId "ACTION" (Text.pack rest)) } sendMsg cs (ircPrivmsg channelId actionTxt)- commandContinue- $ recordChannelMessage network channelId entry- $ consumeInput st+ commandSuccess+ $ recordChannelMessage network channelId entry st -- | Implementation of @/ctcp@-cmdCtcp :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdCtcp :: NetworkCommand cmdCtcp network cs st rest = case parse of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just (target, cmd, args) -> do let cmdTxt = Text.toUpper (Text.pack cmd) argTxt = Text.pack args@@ -253,10 +257,10 @@ return (target, cmd, args) -- | Implementation of @/notice@-cmdNotice :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdNotice :: NetworkCommand cmdNotice network cs st rest = case nextWord rest of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just (target, rest1) -> do let restTxt = Text.pack rest1 tgtTxt = Text.pack target@@ -268,10 +272,10 @@ network cs st -- | Implementation of @/msg@-cmdMsg :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdMsg :: NetworkCommand cmdMsg network cs st rest = case nextWord rest of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just (target, rest1) -> do let restTxt = Text.pack rest1 tgtTxt = Text.pack target@@ -307,99 +311,140 @@ st entries - commandContinue (consumeInput st')+ commandSuccess st' -cmdConnect :: ClientState -> String -> IO CommandResult+cmdConnect :: ClientCommand cmdConnect st rest = case words rest of [networkStr] -> do -- abort any existing connection before connecting let network = Text.pack networkStr st' <- addConnection network =<< abortNetwork network st- commandContinue- $ changeFocus (NetworkFocus network)- $ consumeInput st'+ commandSuccess+ $ changeFocus (NetworkFocus network) st' - _ -> commandContinue st+ _ -> commandFailure st -cmdFocus :: ClientState -> String -> IO CommandResult+cmdFocus :: ClientCommand cmdFocus st rest = case words rest of [network] -> let focus = NetworkFocus (Text.pack network) in- commandContinue- $ changeFocus focus- $ consumeInput st+ commandSuccess (changeFocus focus st) [network,channel] -> let focus = ChannelFocus (Text.pack network) (mkId (Text.pack channel)) in- commandContinue- $ changeFocus focus- $ consumeInput st+ commandSuccess+ $ changeFocus focus st - _ -> commandContinue st+ _ -> commandFailure st -cmdWhois :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdWhois :: NetworkCommand cmdWhois _ cs st rest = do sendMsg cs (ircWhois (Text.pack <$> words rest))- commandContinue (consumeInput st)+ commandSuccess st -cmdWho :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdWho :: NetworkCommand cmdWho _ cs st rest = do sendMsg cs (ircWho (Text.pack <$> words rest))- commandContinue (consumeInput st)+ commandSuccess st -cmdWhowas :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdWhowas :: NetworkCommand cmdWhowas _ cs st rest = do sendMsg cs (ircWhowas (Text.pack <$> words rest))- commandContinue (consumeInput st)+ commandSuccess st -cmdIson :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdIson :: NetworkCommand cmdIson _ cs st rest = do sendMsg cs (ircIson (Text.pack <$> words rest))- commandContinue (consumeInput st)+ commandSuccess st -cmdUserhost :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdUserhost :: NetworkCommand cmdUserhost _ cs st rest = do sendMsg cs (ircUserhost (Text.pack <$> words rest))- commandContinue (consumeInput st)+ commandSuccess st -cmdStats :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdStats :: NetworkCommand cmdStats _ cs st rest = do sendMsg cs (ircStats (Text.pack <$> words rest))- commandContinue (consumeInput st)+ commandSuccess st -cmdAway :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdAway :: NetworkCommand cmdAway _ cs st rest = do sendMsg cs (ircAway (Text.pack (dropWhile (==' ') rest)))- commandContinue (consumeInput st)+ commandSuccess st -cmdLinks :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdLinks :: NetworkCommand cmdLinks _ cs st rest = do sendMsg cs (ircLinks (Text.pack <$> words rest))- commandContinue (consumeInput st)+ commandSuccess st -cmdTime :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdTime :: NetworkCommand cmdTime _ cs st rest = do sendMsg cs (ircTime (Text.pack <$> words rest))- commandContinue (consumeInput st)+ commandSuccess st -cmdMode :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdZnc :: NetworkCommand+cmdZnc _ cs st rest =+ do sendMsg cs (ircZnc (Text.words (Text.pack rest)))+ commandSuccess st++-- TODO: support time ranges+cmdZncPlayback :: NetworkCommand+cmdZncPlayback _ cs st rest =+ case words rest of++ -- request everything+ [] -> success "0"++ -- current date explicit time+ [timeStr]+ | Just tod <- parse timeFormats timeStr ->+ do now <- getZonedTime+ successZoned+ (set (zonedTimeLocalTime . localTimeTimeOfDay) tod now)++ -- explicit date and time+ [dateStr,timeStr]+ | Just day <- parse dateFormats dateStr+ , Just tod <- parse timeFormats timeStr ->+ do tz <- getCurrentTimeZone+ successZoned ZonedTime+ { zonedTimeZone = tz+ , zonedTimeToLocalTime = LocalTime+ { localTimeOfDay = tod+ , localDay = day } }++ _ -> commandFailure st++ where+ timeFormats = ["%T","%R"]+ dateFormats = ["%F"]+ parse formats str =+ asum (map (parseTimeM False defaultTimeLocale ?? str) formats)++ successZoned = success . formatTime defaultTimeLocale "%s"++ success start =+ do sendMsg cs (ircZnc ["*playback", "play", "*", Text.pack start])+ commandSuccess st++cmdMode :: NetworkCommand cmdMode _ cs st rest = modeCommand (Text.pack <$> words rest) cs st -cmdNick :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult+cmdNick :: NetworkCommand cmdNick _ cs st rest = case words rest of [nick] -> do sendMsg cs (ircNick (mkId (Text.pack nick)))- commandContinue (consumeInput st)- _ -> commandContinue st+ commandSuccess st+ _ -> commandFailure st -cmdPart :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdPart :: ChannelCommand cmdPart _ cs channelId st rest = do let msg = dropWhile isSpace rest sendMsg cs (ircPart channelId (Text.pack msg))- commandContinue (consumeInput st)+ commandSuccess st cmdInvite :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdInvite _ cs channelId st rest =@@ -412,14 +457,13 @@ else sendModeration channelId [cmd] cs commandContinueUpdateCS cs' st - _ -> commandContinue st+ _ -> commandFailure st commandContinueUpdateCS :: ConnectionState -> ClientState -> IO CommandResult commandContinueUpdateCS cs st = let networkId = view csNetworkId cs in- commandContinue- $ setStrict (clientConnections . ix networkId) cs- $ consumeInput st+ commandSuccess+ $ setStrict (clientConnections . ix networkId) cs st cmdTopic :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdTopic _ cs channelId st rest =@@ -431,7 +475,7 @@ ("TOPIC " <> idText channelId <> Text.pack (' ' : topic)) | otherwise -> ircTopic channelId (Text.pack topic) sendMsg cs cmd- commandContinue (consumeInput st)+ commandSuccess st tabTopic :: Bool {- ^ reversed -} ->@@ -447,32 +491,26 @@ . set Edit.content ("/topic " ++ Text.unpack topic) commandContinue (over clientTextBox textBox st) - | otherwise = commandContinue st+ | otherwise = commandFailure st -cmdUsers :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult-cmdUsers _ _ _ st _ = commandContinue- $ changeSubfocus FocusUsers- $ consumeInput st+cmdUsers :: ChannelCommand+cmdUsers _ _ _ st _ = commandSuccess (changeSubfocus FocusUsers st) -cmdChannelInfo :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult-cmdChannelInfo _ _ _ st _- = commandContinue- $ changeSubfocus FocusInfo- $ consumeInput st+cmdChannelInfo :: ChannelCommand+cmdChannelInfo _ _ _ st _ = commandSuccess (changeSubfocus FocusInfo st) -cmdMasks :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult+cmdMasks :: ChannelCommand cmdMasks _ cs _ st rest = case words rest of [[mode]] | mode `elem` view (csModeTypes . modesLists) cs ->- commandContinue $ changeSubfocus (FocusMasks mode)- $ consumeInput st- _ -> commandContinue st+ commandSuccess (changeSubfocus (FocusMasks mode) st)+ _ -> commandFailure st cmdKick :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdKick _ cs channelId st rest = case nextWord rest of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just (who,reason) -> do let msg = Text.pack (dropWhile isSpace reason) cmd = ircKick channelId (Text.pack who) msg@@ -483,7 +521,7 @@ cmdKickBan :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdKickBan _ cs channelId st rest = case nextWord rest of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just (whoStr,reason) -> do let msg = Text.pack (dropWhile isSpace reason) @@ -505,7 +543,7 @@ cmdRemove :: NetworkName -> ConnectionState -> Identifier -> ClientState -> String -> IO CommandResult cmdRemove _ cs channelId st rest = case nextWord rest of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just (who,reason) -> do let msg = Text.pack (dropWhile isSpace reason) cmd = ircRemove channelId (Text.pack who) msg@@ -518,25 +556,24 @@ doJoin channelStr keyStr = do let channelId = mkId (Text.pack (takeWhile (/=',') channelStr)) sendMsg cs (ircJoin (Text.pack channelStr) (Text.pack <$> keyStr))- commandContinue- $ changeFocus (ChannelFocus network channelId)- $ consumeInput st+ commandSuccess+ $ changeFocus (ChannelFocus network channelId) st in case ws of [channel] -> doJoin channel Nothing [channel,key] -> doJoin channel (Just key)- _ -> commandContinue st+ _ -> commandFailure st cmdQuit :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult cmdQuit _ cs st rest = do let msg = Text.pack (dropWhile isSpace rest) sendMsg cs (ircQuit msg)- commandContinue (consumeInput st)+ commandSuccess st cmdDisconnect :: NetworkName -> ConnectionState -> ClientState -> String -> IO CommandResult cmdDisconnect network _ st _ = do st' <- abortNetwork network st- commandContinue (consumeInput st')+ commandSuccess st' -- | Reconnect to the currently focused network. It's possible -- that we're not currently connected to a network, so@@ -546,19 +583,17 @@ | Just network <- views clientFocus focusNetwork st = do st' <- addConnection network =<< abortNetwork network st- commandContinue- $ changeFocus (NetworkFocus network)- $ consumeInput st'+ commandSuccess+ $ changeFocus (NetworkFocus network) st' - | otherwise = commandContinue st+ | otherwise = commandFailure st cmdIgnore :: ClientState -> String -> IO CommandResult cmdIgnore st rest = case mkId . Text.pack <$> words rest of- [] -> commandContinue st- xs -> commandContinue- $ over clientIgnores updateIgnores- $ consumeInput st+ [] -> commandFailure st+ xs -> commandSuccess+ $ over clientIgnores updateIgnores st where updateIgnores :: HashSet Identifier -> HashSet Identifier updateIgnores s = foldl' updateIgnore s xs@@ -570,14 +605,14 @@ NetworkFocus _ -> do sendMsg cs (ircMode (view csNick cs) modes)- commandContinue (consumeInput st)+ commandSuccess st ChannelFocus _ chan -> case modes of [] -> success False [[]] flags:params -> case splitModes (view csModeTypes cs) flags params of- Nothing -> commandContinue st+ Nothing -> commandFailure st Just parsedModes -> success needOp (unsplitModes <$> chunksOf (view csModeCount cs) parsedModes') where@@ -597,7 +632,7 @@ else cs <$ traverse_ (sendMsg cs) cmds commandContinueUpdateCS cs' st - _ -> commandContinue st+ _ -> commandFailure st tabMode :: Bool -> NetworkCommand tabMode isReversed _ cs st rest =@@ -666,7 +701,7 @@ = fromMaybe st $ clientTextBox (wordComplete (++": ") isReversed completions) st where- completions = currentUserList st+ completions = currentCompletionList st sendModeration :: Identifier -> [RawIrcMsg] -> ConnectionState -> IO ConnectionState sendModeration channel cmds cs
src/Client/Connect.hs view
@@ -103,11 +103,8 @@ [] -> fail "No private keys found" _ -> fail "Too many private keys found" -connect :: ConnectionContext -> ServerSettings -> IO Connection-connect connectionContext args = do- connectionParams <- buildConnectionParams args- connectTo connectionContext connectionParams- -- | Create a new 'Connection' which will be closed when the continuation finishes. withConnection :: ConnectionContext -> ServerSettings -> (Connection -> IO a) -> IO a-withConnection cxt settings = bracket (connect cxt settings) connectionClose+withConnection cxt settings k =+ do params <- buildConnectionParams settings+ bracket (connectTo cxt params) connectionClose k
src/Client/ConnectionState.hs view
@@ -121,7 +121,7 @@ data Transaction = NoTransaction | NamesTransaction [Text]- | BanTransaction [(Text,(Text,UTCTime))]+ | BanTransaction [(Text,MaskListEntry)] | WhoTransaction [UserInfo] deriving Show @@ -345,71 +345,43 @@ RPL_BANLIST -> case args of- _me:_tgt:mask:who:whenTxt:_ | Just when <- parseTimeParam whenTxt ->- over csTransaction $ \t ->- let !xs = view _BanTransaction t- in BanTransaction ((mask,(who,when)):xs)- _ -> id+ _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt+ _ -> id RPL_ENDOFBANLIST -> case args of- _me:tgt:_ -> \cs ->- set csTransaction NoTransaction- $ setStrict (csChannels . ix (mkId tgt) . chanList 'b')- (HashMap.fromList (view (csTransaction . _BanTransaction) cs))- cs- _ -> id+ _me:tgt:_ -> saveList 'b' tgt+ _ -> id RPL_QUIETLIST -> case args of- _me:_tgt:_q:mask:who:whenTxt:_ | Just when <- parseTimeParam whenTxt ->- over csTransaction $ \t ->- let !xs = view _BanTransaction t- in BanTransaction ((mask,(who,when)):xs)- _ -> id+ _me:_tgt:_q:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt+ _ -> id RPL_ENDOFQUIETLIST -> case args of- _me:tgt:_ -> \cs ->- set csTransaction NoTransaction- $ setStrict (csChannels . ix (mkId tgt) . chanList 'q')- (HashMap.fromList (view (csTransaction . _BanTransaction) cs))- cs- _ -> id+ _me:tgt:_ -> saveList 'q' tgt+ _ -> id RPL_INVEXLIST -> case args of- _me:_tgt:mask:who:whenTxt:_ | Just when <- parseTimeParam whenTxt ->- over csTransaction $ \t ->- let !xs = view _BanTransaction t- in BanTransaction ((mask,(who,when)):xs)- _ -> id+ _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt+ _ -> id RPL_ENDOFINVEXLIST -> case args of- _me:tgt:_ -> \cs ->- set csTransaction NoTransaction- $ setStrict (csChannels . ix (mkId tgt) . chanList 'I')- (HashMap.fromList (view (csTransaction . _BanTransaction) cs))- cs- _ -> id+ _me:tgt:_ -> saveList 'I' tgt+ _ -> id RPL_EXCEPTLIST -> case args of- _me:_tgt:mask:who:whenTxt:_ | Just when <- parseTimeParam whenTxt ->- over csTransaction $ \t ->- let !xs = view _BanTransaction t- in BanTransaction ((mask,(who,when)):xs)- _ -> id+ _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt+ _ -> id RPL_ENDOFEXCEPTLIST -> case args of- _me:tgt:_ -> \cs ->- set csTransaction NoTransaction- $ setStrict (csChannels . ix (mkId tgt) . chanList 'e')- (HashMap.fromList (view (csTransaction . _BanTransaction) cs))- cs- _ -> id+ _me:tgt:_ -> saveList 'e' tgt+ _ -> id RPL_WHOREPLY -> case args of@@ -432,6 +404,41 @@ _ -> id +-- | Add an entry to a mode list transaction+recordListEntry ::+ Text {- ^ mask -} ->+ Text {- ^ set by -} ->+ Text {- ^ set time -} ->+ ConnectionState -> ConnectionState+recordListEntry mask who whenTxt =+ case parseTimeParam whenTxt of+ Nothing -> id+ Just when ->+ over csTransaction $ \t ->+ let !x = MaskListEntry+ { _maskListSetter = who+ , _maskListTime = when+ }+ !xs = view _BanTransaction t+ in BanTransaction ((mask,x):xs)+++-- | Save a completed ban, quiet, invex, or exempt list into the channel+-- state.+saveList ::+ Char {- ^ mode -} ->+ Text {- ^ channel -} ->+ ConnectionState -> ConnectionState+saveList mode tgt cs+ = set csTransaction NoTransaction+ $ setStrict+ (csChannels . ix (mkId tgt) . chanLists . at mode)+ (Just $! newList)+ cs+ where+ newList = HashMap.fromList (view (csTransaction . _BanTransaction) cs)++ -- | These replies are interpreted by the client and should only be shown -- in the detailed view. squelchReply :: ReplyCode -> Bool@@ -517,9 +524,12 @@ c | mode `elem` listModes =- let entry | polarity = Just (renderUserInfo who, zonedTimeToUTC when)+ let entry | polarity = Just $! MaskListEntry+ { _maskListSetter = renderUserInfo who+ , _maskListTime = zonedTimeToUTC when+ } | otherwise = Nothing- in setStrict (chanList mode . at arg) entry c+ in setStrict (chanLists . ix mode . at arg) entry c | polarity = set (chanModes . at mode) (Just arg) c | otherwise = set (chanModes . at mode) Nothing c@@ -541,7 +551,7 @@ applyOne modes (False, mode, _) = delete mode modes supportedCaps :: ConnectionState -> [Text]-supportedCaps cs = sasl ++ ["multi-prefix", "znc.in/server-time-iso"]+supportedCaps cs = sasl ++ ["multi-prefix", "znc.in/playback", "znc.in/server-time-iso"] where ss = view csSettings cs sasl = ["sasl" | isJust (view ssSaslUsername ss)
src/Client/EventLoop.hs view
@@ -87,10 +87,11 @@ -- | Apply this function to an initial 'ClientState' to launch the client. eventLoop :: ClientState -> IO () eventLoop st0 =- do st1 <- clientTick st0- let vty = view clientVty st+ do let st1 = clientTick st0+ vty = view clientVty st (pic, st) = clientPicture st1 + when (view clientBell st0) (beep vty) update vty pic event <- getEvent st@@ -103,6 +104,9 @@ NetworkError network time ex -> doNetworkError network time ex st NetworkClose network time -> doNetworkClose network time st +beep :: Vty -> IO ()+beep vty = outputByteBuffer (outputIface vty) "\BEL"+ -- | Respond to a network connection closing normally. doNetworkClose :: NetworkId {- ^ finished network -} ->@@ -301,7 +305,7 @@ execute :: ClientState -> IO () execute st = case clientInput st of- [] -> eventLoop st+ [] -> eventLoop (set clientBell True st) '/':command -> do res <- executeCommand Nothing command st case res of CommandQuit -> return ()@@ -327,7 +331,7 @@ eventLoop $ recordChannelMessage network channel entry $ consumeInput st - _ -> eventLoop st+ _ -> eventLoop (set clientBell True st) -- | Respond to a timer event. doTimerEvent ::
src/Client/Image.hs view
@@ -153,6 +153,7 @@ [ myNickImage st , focusImage st , activityImage st+ , detailImage st , scrollImage st , latencyImage st ]@@ -168,6 +169,15 @@ , string (withForeColor defAttr red) "scroll" , string defAttr ")" ]++detailImage :: ClientState -> Image+detailImage st+ | view clientDetailView st = horizCat+ [ string defAttr "─("+ , string (withForeColor defAttr red) "detail"+ , string defAttr ")"+ ]+ | otherwise = emptyImage activityImage :: ClientState -> Image activityImage st
src/Client/Image/MaskList.hs view
@@ -17,9 +17,11 @@ import Client.ConnectionState import Client.State import Control.Lens+import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.List import Data.Ord+import Data.Text (Text) import Data.Time import Graphics.Vty.Image import Irc.Identifier@@ -30,8 +32,21 @@ NetworkName {- ^ Focused network -} -> Identifier {- ^ Focused channel -} -> ClientState -> [Image]-maskListImages mode network channel st = countImage : images+maskListImages mode network channel st =+ case mbEntries of+ Nothing -> [text' (withForeColor defAttr red) "Mask list not loaded"]+ Just entries -> maskListImages' entries st+ where+ mbEntries = preview+ ( clientConnection network+ . csChannels . ix channel+ . chanLists . ix mode+ ) st++maskListImages' :: HashMap Text MaskListEntry -> ClientState -> [Image]+maskListImages' entries st = countImage : images+ where countImage = text' (withForeColor defAttr green) "Masks (visible/total): " <|> string defAttr (show (length entryList)) <|> char (withForeColor defAttr green) '/' <|>@@ -39,17 +54,12 @@ matcher = clientMatcher st - matcher' (x,(y,_)) = matcher x || matcher y+ matcher' (mask,entry) = matcher mask || matcher (view maskListSetter entry) - entryList = sortBy (flip (comparing (snd . snd)))+ entryList = sortBy (flip (comparing (view (_2 . maskListTime)))) $ filter matcher' $ HashMap.toList entries - entries = view ( clientConnection network- . csChannels . ix channel- . chanList mode- ) st- renderWhen = formatTime defaultTimeLocale " %F %T" (masks, whoWhens) = unzip entryList@@ -61,7 +71,7 @@ images = [ cropLine $ mask <|> text' defAttr who <|> string defAttr (renderWhen when)- | (mask, (who, when)) <- zip paddedMaskImages whoWhens ]+ | (mask, MaskListEntry who when) <- zip paddedMaskImages whoWhens ] cropLine img | imageWidth img > width = cropRight width img
src/Client/State.hs view
@@ -32,12 +32,13 @@ , clientNetworkMap , clientIgnores , clientConnection+ , clientBell , initialClientState -- * Client operations , clientMatcher , consumeInput- , currentUserList+ , currentCompletionList , ircIgnorable , clientInput , abortNetwork@@ -151,6 +152,7 @@ , _clientConfig :: !Configuration -- ^ client configuration , _clientScroll :: !Int -- ^ buffer scroll lines , _clientDetailView :: !Bool -- ^ use detailed rendering mode+ , _clientBell :: !Bool -- ^ sound a bell next draw , _clientIgnores :: !(HashSet Identifier) -- ^ ignored nicknames }@@ -198,6 +200,7 @@ , _clientNextConnectionId = 0 , _clientNetworkMap = HashMap.empty , _clientIgnores = HashSet.empty+ , _clientBell = False } -- | Forcefully terminate the connection currently associated@@ -366,10 +369,16 @@ toWindowLine' :: ClientMessage -> WindowLine toWindowLine' = toWindowLine defaultRenderParams -clientTick :: ClientState -> IO ClientState-clientTick st =- return $! over (clientWindows . ix (view clientFocus st)) windowSeen st+clientTick :: ClientState -> ClientState+clientTick = set clientBell False . markSeen ++markSeen :: ClientState -> ClientState+markSeen st =+ case view clientSubfocus st of+ FocusMessages -> overStrict (clientWindows . ix (view clientFocus st)) windowSeen st+ _ -> st+ consumeInput :: ClientState -> ClientState consumeInput = over clientTextBox Edit.success @@ -403,12 +412,21 @@ oldFocus = view clientFocus st windows = view clientWindows st -currentUserList :: ClientState -> [Identifier]-currentUserList st =+-- | Returns the current network's channels and current channel's users.+currentCompletionList :: ClientState -> [Identifier]+currentCompletionList st = case view clientFocus st of- ChannelFocus network chan -> channelUserList network chan st+ NetworkFocus network ->+ networkChannelList network st+ ChannelFocus network chan ->+ networkChannelList network st+ ++ channelUserList network chan st _ -> [] +networkChannelList :: NetworkName -> ClientState -> [Identifier]+networkChannelList network =+ views (clientConnection network . csChannels) HashMap.keys+ channelUserList :: NetworkName -> Identifier -> ClientState -> [Identifier] channelUserList network channel = views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys@@ -516,4 +534,3 @@ | otherwise = x applyWindowRenames _ _ st = st-
src/Irc/Commands.hs view
@@ -36,6 +36,9 @@ , ircWhois , ircWhowas + -- * ZNC support+ , ircZnc+ -- * SASL support , ircAuthenticate , plainAuthenticationMode@@ -227,6 +230,14 @@ -- | CAP LS command ircCapLs :: RawIrcMsg ircCapLs = rawIrcMsg "CAP" ["LS"]++-- | ZNC command+--+-- /specific to ZNC/+ircZnc ::+ [Text] {- ^ parameters -} ->+ RawIrcMsg+ircZnc = rawIrcMsg "ZNC" -- | AUTHENTICATE command ircAuthenticate :: Text -> RawIrcMsg
src/Irc/Identifier.hs view
@@ -61,17 +61,6 @@ ircFoldCase = B.map (B.index casemap . fromIntegral) casemap :: ByteString-casemap = B8.pack- "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\- \\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\- \ !\"#$%&'()*+,-./0123456789:;<=>?\- \@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_\- \`ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^\x7f\- \\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\- \\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\- \\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\- \\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\- \\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\- \\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\- \\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\- \\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff"+casemap+ = B8.pack+ $ ['\x00'..'`'] ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^" ++ ['\x7f'..'\xff']
src/Irc/Modes.hs view
@@ -35,11 +35,11 @@ -- | Settings that describe how to interpret channel modes data ModeTypes = ModeTypes- { _modesLists :: ![Char] -- ^ modes for channel lists (e.g. ban)- , _modesAlwaysArg :: ![Char] -- ^ modes that always have an argument- , _modesSetArg :: ![Char] -- ^ modes that have an argument when set- , _modesNeverArg :: ![Char] -- ^ modes that never have arguments- , _modesPrefixModes :: ![(Char,Char)] -- ^ modes requiring a nickname argument (mode,sigil)+ { _modesLists :: [Char] -- ^ modes for channel lists (e.g. ban)+ , _modesAlwaysArg :: [Char] -- ^ modes that always have an argument+ , _modesSetArg :: [Char] -- ^ modes that have an argument when set+ , _modesNeverArg :: [Char] -- ^ modes that never have arguments+ , _modesPrefixModes :: [(Char,Char)] -- ^ modes requiring a nickname argument (mode,sigil) } deriving Show
src/LensUtils.hs view
@@ -12,11 +12,16 @@ ( Id' , overStrict , setStrict++ -- * time lenses+ , zonedTimeLocalTime+ , localTimeTimeOfDay ) where import Control.Lens import Control.Applicative import Data.Profunctor.Unsafe+import Data.Time newtype Id' a = Id' { runId' :: a } @@ -40,3 +45,9 @@ setStrict :: ASetter s t a b -> b -> s -> t setStrict l x = set l $! x {-# INLINE setStrict #-}++zonedTimeLocalTime :: Lens' ZonedTime LocalTime+zonedTimeLocalTime f (ZonedTime t z) = f t <&> \t' -> ZonedTime t' z++localTimeTimeOfDay :: Lens' LocalTime TimeOfDay+localTimeTimeOfDay f (LocalTime d t) = LocalTime d <$> f t