irc-fun-bot 0.3.0.0 → 0.4.0.0
raw patch · 16 files changed
+741/−360 lines, 16 filesdep +clockdep ~irc-fun-clientdep ~irc-fun-messages
Dependencies added: clock
Dependency ranges changed: irc-fun-client, irc-fun-messages
Files
- NEWS +32/−0
- irc-fun-bot.cabal +5/−4
- src/Network/IRC/Fun/Bot.hs +136/−28
- src/Network/IRC/Fun/Bot/Behavior.hs +19/−16
- src/Network/IRC/Fun/Bot/EventMatch.hs +11/−15
- src/Network/IRC/Fun/Bot/Internal/Chat.hs +40/−9
- src/Network/IRC/Fun/Bot/Internal/Event.hs +236/−157
- src/Network/IRC/Fun/Bot/Internal/Failure.hs +4/−4
- src/Network/IRC/Fun/Bot/Internal/IrcLog.hs +11/−10
- src/Network/IRC/Fun/Bot/Internal/Logger.hs +1/−1
- src/Network/IRC/Fun/Bot/Internal/Nicks.hs +25/−24
- src/Network/IRC/Fun/Bot/Internal/Persist.hs +66/−26
- src/Network/IRC/Fun/Bot/Internal/State.hs +56/−21
- src/Network/IRC/Fun/Bot/Internal/Types.hs +93/−45
- src/Network/IRC/Fun/Bot/State.hs +5/−0
- src/Network/IRC/Fun/Bot/Types.hs +1/−0
NEWS view
@@ -3,6 +3,38 @@ +irc-fun-bot 0.4.0.0 -- 2015-10-17+=================================++General, build and documentation changes:++* (None)++New APIs, features and enhancements:++* Add 'defConfig' function, allowing new fields to be added without breakage+* Support splitting long messages+* Change some record field names to avoid collisions and mess+* Move channel list from Config.hs to the state file+* Add channel management controls and queries+* Detect IRC lag+* Revise event matchers and add several new features+* BotMessage event now also provides the full message text+* Support /me messages in events, logging and history++Bug fixes:++* When an error occurs in the IRC listener thread, inform the main thread++Dependency changes:++* Require irc-fun-client >= 0.3+* Require irc-fun-messages >= 0.2+++++ irc-fun-bot 0.3.0.0 -- 2015-09-22 =================================
irc-fun-bot.cabal view
@@ -1,5 +1,5 @@ name: irc-fun-bot-version: 0.3.0.0+version: 0.4.0.0 synopsis: Library for writing fun IRC bots. description: One day an idea came up on the #freepost IRC channel: We didn't need much of@@ -26,7 +26,7 @@ source-repository head type: darcs- location: http://dev.rel4tion.org/fr33domlover/irc-fun-bot+ location: http://hub.darcs.net/fr33domlover/irc-fun-bot library exposed-modules: Network.IRC.Fun.Bot@@ -51,9 +51,10 @@ -- other-extensions: build-depends: aeson , base >=4.7 && <5+ , clock >=0.5 , fast-logger- , irc-fun-client >=0.2.0.0- , irc-fun-messages+ , irc-fun-client >=0.3+ , irc-fun-messages >=0.2 , json-state , time , time-interval
src/Network/IRC/Fun/Bot.hs view
@@ -17,24 +17,63 @@ -- just run event source and sink threads in your @main@ function and let them -- handle all the details. module Network.IRC.Fun.Bot- ( runBot+ ( defConfig+ , runBot ) where -import Control.Concurrent (forkIO)+import Control.Concurrent (threadDelay, forkIO) import Control.Concurrent.Chan-import Control.Monad (forever, liftM, void)+import Control.Concurrent.MVar+import Control.Monad (liftM, void, when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.RWS (ask) import Data.List (transpose)-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Time.Interval+import Data.Time.Units import Network.IRC.Fun.Bot.Internal.Event import Network.IRC.Fun.Bot.Internal.Logger import Network.IRC.Fun.Bot.Internal.Types import Network.IRC.Fun.Bot.Chat (login, joinConfig, run)-import Network.IRC.Fun.Client.ChannelLogger (LogEvent, fromClientEvent)+import Network.IRC.Fun.Bot.Types (Connection (..))+import Network.IRC.Fun.Client.ChannelLogger (fromClientEvent) import Network.IRC.Fun.Client.Events (hGetIrcEvents)+import Network.IRC.Fun.Client.IO (hPutIrc)+import Network.IRC.Fun.Messages.Types (Message (PingMessage))+import System.Clock+import System.IO.Error (tryIOError) +import qualified Network.IRC.Fun.Client.Events as C (Event (Pong))++-- | A default bot configuration. You can use it with record syntax to override+-- just the fields you need. It also allows your code to remain valid when a+-- new config option is added, since you won't be using the 'Config'+-- constructor directy.+--+-- In the future the constructor may be removed, and then this function will be+-- the only way to create a configuration. It allows adding a field without+-- incrementing the library's major version and breaking compatibility.+defConfig :: Config+defConfig = Config+ { connection = Connection+ { server = "irc.freenode.net"+ , port = 6667+ , tls = False -- not supported yet+ , nick = "bot_test_joe"+ , password = Nothing+ }+ , channels = ["#freepost-bot-test"]+ , logDir = "state/chanlogs"+ , stateRepo = Nothing+ , stateFile = "state/state.json"+ , saveInterval = time (3 :: Second)+ , botEventLogFile = "state/bot.log"+ , maxMsgChars = Nothing+ , lagCheck = Just $ time (1 :: Minute)+ , lagMax = time (5 :: Minute)+ }+ -- Get the bot ready for listening to IRC messages. startBot :: Session e s () startBot = do@@ -44,32 +83,94 @@ joinConfig -- Wait for an IRC event, then handle it according to bot behavior definition.-listenToEvent :: Chan (Either (Either LogEvent Event) a)- -> EventHandler e s a- -> Session e s ()+-- Return whether listening should continue.+listenToEvent :: Chan (Msg a) -- Chan from which to read events+ -> EventHandler e s a -- Handler for external events+ -> Session e s Bool listenToEvent chan handler = do- event <- liftIO $ readChan chan- either handleEvent handler event+ msg <- liftIO $ readChan chan+ case msg of+ MsgLogEvent event -> handleEvent (Left event) >> return True+ MsgBotEvent event -> handleEvent (Right event) >> return True+ MsgExtEvent event -> handler event >> return True+ MsgQuit -> return False +-- Get time since epoch.+getNow :: IO TimeSpec+getNow = getTime Realtime+ -- Collect IRC events from the server and push into a 'Chan' for the main -- thread to handle. listenToIrc :: [EventMatcher e s] -> BotEnv e s- -> Chan (Either (Either LogEvent Event) a)+ -> Chan (Msg a)+ -> MVar TimeSpec -> IO ()-listenToIrc ms bot chan = do+listenToIrc ms bot chan pongvar = do logger <-- newLogger (liftM snd $ getTime bot) (botEventLogFile $ config bot)+ newLogger (liftM snd $ beGetTime bot) (botEventLogFile $ beConfig bot) putStrLn "Bot: IRC event source listening to IRC events"- let match e = matchEvent ms e (config bot) (commandSets $ behavior bot)- forever $ do- ircEvents <- hGetIrcEvents $ handle bot- let botEvents = map match ircEvents- logEvents = catMaybes $ map fromClientEvent ircEvents- interleave l1 l2 = concat $ transpose [map Left l1, map Right l2]- mapM_ (logLine logger . show) botEvents- writeList2Chan chan $ map Left $ interleave logEvents botEvents+ let match e = matchEvent ms e (beConfig bot) (commandSets $ beBehavior bot)+ loop = do+ r <- tryIOError $ hGetIrcEvents $ beHandle bot+ case r of+ Left e -> do+ putStrLn "Bot: IRC event listener hGetIrcEvents IO error"+ print e+ writeChan chan MsgQuit+ Right ircEvents -> do+ let botEvents = map match ircEvents+ logEvents = catMaybes $ map fromClientEvent ircEvents+ interleave logs bots = concat $ transpose+ [map MsgLogEvent logs, map MsgBotEvent bots]+ isPong (C.Pong _ _) = True+ isPong _ = False+ when (any isPong ircEvents) $ do+ now <- getNow+ void $ tryTakeMVar pongvar+ putMVar pongvar now+ mapM_ (logLine logger . show) botEvents+ writeList2Chan chan $ interleave logEvents botEvents+ loop+ loop +intervalToSpec :: TimeInterval -> TimeSpec+intervalToSpec ti =+ let t = microseconds ti+ (s, us) = t `divMod` (1000 * 1000)+ in TimeSpec+ { sec = fromInteger s+ , nsec = 1000 * fromInteger us+ }++-- Send pings periodically to the server, and track the latest PONGs received,+-- as reported by the receiver thread. If it has been long enough since the+-- last PONG, tell the main thread to shut down.+manageLag :: BotEnv e s+ -> Chan (Msg a)+ -> MVar TimeSpec+ -> IO ()+manageLag bot chan pongvar =+ case lagCheck $ beConfig bot of+ Nothing -> return ()+ Just iv -> do+ putStrLn "Bot: IRC lag manager thread running"+ let maxdiff = intervalToSpec $ lagMax $ beConfig bot+ loop prev = do+ mpong <- tryTakeMVar pongvar+ let pong = fromMaybe prev mpong+ now <- getNow+ if now - pong > maxdiff+ then do+ putStrLn "Bot: IRC max lag reached"+ writeChan chan MsgQuit+ else do+ let serv = server $ connection $ beConfig bot+ hPutIrc (beHandle bot) $ PingMessage serv Nothing+ threadDelay $ fromInteger $ microseconds iv+ loop pong+ loop =<< getNow+ -- Connect, login, join. Then listen to events and handle them, forever. botSession :: [EventMatcher e s] -> [EventSource e s a]@@ -80,16 +181,23 @@ actInit chan <- liftIO newChan bot <- ask- liftIO $ void $ forkIO $ listenToIrc matchers bot chan- let launch s = forkIO $ s (config bot)- (custom bot)- (writeChan chan . Right)- (writeList2Chan chan . map Right)- (newLogger $ liftM snd $ getTime bot)+ pongvar <- liftIO newEmptyMVar+ liftIO $ void $ forkIO $ listenToIrc matchers bot chan pongvar+ liftIO $ void $ forkIO $ manageLag bot chan pongvar+ let launch s = forkIO $ s (beConfig bot)+ (beCustom bot)+ (writeChan chan . MsgExtEvent)+ (writeList2Chan chan . map MsgExtEvent)+ (newLogger $ liftM snd $ beGetTime bot) liftIO $ mapM_ launch sources startBot liftIO $ putStrLn "Bot: Event sink listening to events"- forever $ listenToEvent chan handler+ let loop = do+ proceed <- listenToEvent chan handler+ if proceed+ then loop+ else liftIO $ putStrLn "Bot: Event sink asked to stop"+ loop -- | Start the bot and run its event loop. The bot will listen to messages from -- the IRC server and other provided sources, and will respond according to the
src/Network/IRC/Fun/Bot/Behavior.hs view
@@ -47,16 +47,18 @@ -- could be added in the future. defaultBehavior :: Behavior e s defaultBehavior = Behavior- { handleJoin = \ _ _ -> return ()- , handlePart = \ _ _ _ -> return ()- , handleQuit = \ _ _ -> return ()- , handleMsg = \ _ _ _ _ -> return ()- , handleBotMsg = \ _ _ _ -> return ()- , commandSets = []- , handlePersonalMsg = \ _ _ -> return ()- , handleNickChange = \ _ _ -> return ()- , handleTopicChange = \ _ _ _ -> return ()- , handleNames = \ _ _ _ -> return ()+ { handleJoin = \ _ _ -> return ()+ , handlePart = \ _ _ _ -> return ()+ , handleQuit = \ _ _ -> return ()+ , handleMsg = \ _ _ _ _ -> return ()+ , handleAction = \ _ _ _ _ -> return ()+ , handleBotMsg = \ _ _ _ _ -> return ()+ , commandSets = []+ , handlePersonalMsg = \ _ _ -> return ()+ , handlePersonalAction = \ _ _ -> return ()+ , handleNickChange = \ _ _ -> return ()+ , handleTopicChange = \ _ _ _ -> return ()+ , handleNames = \ _ _ _ -> return () } -------------------------------------------------------------------------------@@ -67,7 +69,7 @@ -- (leftmost) command which has that name, or 'Nothing' if there is no such -- command. findCmdInSet :: String -> CommandSet e s -> Maybe (Command e s)-findCmdInSet name = find ((name `elem`) . names) . commands+findCmdInSet name = find ((name `elem`) . cmdNames) . csetCommands -- | Find a command in a list of command sets, using the given prefix character -- and command name. This is a shortcut for 'findCmd' which doesn't return the@@ -97,7 +99,7 @@ -- | Take a command prefix and a list of command sets, and return the -- (leftmost) set which has that prefex, or 'Nothing' if there is no such set. findSet :: Char -> [CommandSet e s] -> Maybe (CommandSet e s)-findSet p = find ((== p) . prefix)+findSet p = find ((== p) . csetPrefix) -- | Search for commands by testing a search string against their textual -- fields: Names and help strings. Each returned pair is a command and the@@ -106,9 +108,9 @@ searchCmds search = concatMap (f $ lower search) where lower = map toLower- match s cmd = any (s `isInfixOf`) (map lower $ names cmd)- || s `isInfixOf` (lower $ help cmd)- f s cset = [(prefix cset, cmd) | cmd <- commands cset, match s cmd]+ match s cmd = any (s `isInfixOf`) (map lower $ cmdNames cmd)+ || s `isInfixOf` (lower $ cmdHelp cmd)+ f s cset = [(csetPrefix cset, cmd) | cmd <- csetCommands cset, match s cmd] ------------------------------------------------------------------------------- -- Showing@@ -132,4 +134,5 @@ -- (otherwise spaces) -> [Command e s] -- ^ List of commands -> String-listPrimaryNames pref qs comma = listNames pref qs comma . map (head . names)+listPrimaryNames pref qs comma =+ listNames pref qs comma . map (head . cmdNames)
src/Network/IRC/Fun/Bot/EventMatch.hs view
@@ -21,30 +21,26 @@ -- In addition to the event matchers given here, you can easily write your own -- custom matchers. ----- Event matchers with a @C@ prefix are handle only channel events.--- Event matchers with a @P@ prefix are handle only private message events.--- -- The 'defaultMatch' matcher matches some essential events, such as pings, and -- you should probably use it in your matcher list (e.g. as the last item). module Network.IRC.Fun.Bot.EventMatch- ( matchPrefixedCommandC- , matchPrefixedCommandP+ ( -- * Modifiers+ modId+ , modPrefix+ , modPrefixes+ , modPrefixCI+ , modPrefixesCI+ , modPleasePrefix+ , modPleasePrefix'+ -- * Matchers , matchPrefixedCommand- , matchRefCommandC- , matchRefCommandP+ , matchPrefixedCommandFromSet+ , matchPrefixedCommandFromNames , matchRefCommand- , matchRefCommandFromSetC- , matchRefCommandFromSetP , matchRefCommandFromSet- , matchRefCommandFromNamesC- , matchRefCommandFromNamesP , matchRefCommandFromNames , matchPlainPrivateCommand- , matchNoticeC- , matchNoticeP , matchNotice- , matchRefC- , matchRefP , matchRef , defaultMatch )
src/Network/IRC/Fun/Bot/Internal/Chat.hs view
@@ -34,8 +34,11 @@ where import Control.Exception (bracket)+import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS (runRWST)+import Control.Monad.Trans.RWS (gets, runRWST)+import Data.Char (isSpace)+import Data.List (union) import Network.IRC.Fun.Bot.Internal.Persist import Network.IRC.Fun.Bot.Internal.State import Network.IRC.Fun.Bot.Internal.Types@@ -44,6 +47,8 @@ import Network.IRC.Fun.Client.Time (currentTimeGetter) import Network.IRC.Fun.Messages.Types (Message) +import qualified Data.HashSet as S (toList)+ ------------------------------------------------------------------------------- -- Connection Management -------------------------------------------------------------------------------@@ -116,7 +121,7 @@ -- connection. The server closes the connection automatically if a PONG -- response isn't sent from the client within a certain amount of time. ----- Therefore, an IRC client (both humans users and bots) usually listens to+-- Therefore, an IRC client (both human users and bots) usually listens to -- these PINGs and sends back PONG messages. This function sends a PONG. The -- parameters should simply be the ones received in the PING message. pong :: String -- ^ Server name@@ -145,12 +150,16 @@ h <- askHandle liftIO $ ircJoinMulti h channels --- | Join the IRC channels listed in the configuration, without leaving any--- other channels the bot already joined.+-- | Join the IRC channels listed for joining in the persistent state and in+-- the configuration, without leaving any other channels the bot already+-- joined. joinConfig :: Session e s () joinConfig = do- chans <- askConfigS channels- joinMulti $ map (flip (,) Nothing) chans --TODO avoid unnecessary JOINs?+ chansC <- askConfigS channels+ chansP <- liftM S.toList $ gets bsSelChans+ let chans = union chansC chansP+ joinMulti $ map (flip (,) Nothing) chans+ --TODO avoid unnecessary JOINs? -- | Leave an IRC channel. partChannel :: String -- ^ Channel name@@ -160,6 +169,7 @@ partChannel channel reason = do h <- askHandle liftIO $ ircPart h channel reason+ removeCurrChan channel -- | Leave one or more IRC channels. partMulti :: [String] -- ^ List of channel names@@ -172,12 +182,31 @@ -- | Leave all IRC channels the bot joined. partAll :: Session e s ()-partAll = askHandle >>= liftIO . ircPartAll+partAll = do+ askHandle >>= liftIO . ircPartAll+ clearCurrChans ------------------------------------------------------------------------------- -- Sending Messages ------------------------------------------------------------------------------- +-- Split a string into N-sized substrings, whose concatenation is the original+-- string. The last substring may be shorter than N.+splitN :: Int -> String -> [String]+splitN n s =+ case splitAt n s of+ (l, "") -> [l]+ (l, r) -> l : splitN n (dropWhile isSpace r)++-- Split a message by newlines and possibly length.+makeLines :: String -> Session e s [String]+makeLines msg = do+ let ls = lines msg+ maybelen <- askConfigS maxMsgChars+ case maybelen of+ Nothing -> return ls+ Just maxlen -> return $ concatMap (splitN maxlen) ls+ -- | Send a message to an IRC channel. -- -- This usually requires that the bot joins the channel first, because many@@ -190,7 +219,8 @@ -> Session e s () sendToChannel channel msg = do h <- askHandle- liftIO $ mapM_ (ircSendToChannel h channel) $ lines msg+ msgs <- makeLines msg+ liftIO $ mapM_ (ircSendToChannel h channel) msgs -- | Send a private message to an IRC user. sendToUser :: String -- ^ The user's nickname@@ -200,7 +230,8 @@ -> Session e s () sendToUser nick msg = do h <- askHandle- liftIO $ mapM_ (ircSendToUser h nick) $ lines msg+ msgs <- makeLines msg+ liftIO $ mapM_ (ircSendToUser h nick) msgs -- | Send a message back to the sender. If a channel is specified, send to the -- channel. If not, send a private message.
src/Network/IRC/Fun/Bot/Internal/Event.hs view
@@ -14,24 +14,21 @@ -} module Network.IRC.Fun.Bot.Internal.Event- ( matchPrefixedCommandC- , matchPrefixedCommandP+ ( modId+ , modPrefix+ , modPrefixes+ , modPrefixCI+ , modPrefixesCI+ , modPleasePrefix+ , modPleasePrefix' , matchPrefixedCommand- , matchRefCommandC- , matchRefCommandP+ , matchPrefixedCommandFromSet+ , matchPrefixedCommandFromNames , matchRefCommand- , matchRefCommandFromSetC- , matchRefCommandFromSetP , matchRefCommandFromSet- , matchRefCommandFromNamesC- , matchRefCommandFromNamesP , matchRefCommandFromNames , matchPlainPrivateCommand- , matchNoticeC- , matchNoticeP , matchNotice- , matchRefC- , matchRefP , matchRef , defaultMatch , matchEvent@@ -39,26 +36,72 @@ ) where -import Control.Monad (when)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS-import Data.Char (isSpace)+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.RWS+import Data.Char (isSpace, toLower)+import Data.Maybe+import Data.List (find, stripPrefix)+import Network.IRC.Fun.Bot.Internal.Chat (pong, sendBack)+import Network.IRC.Fun.Bot.Internal.Failure+import Network.IRC.Fun.Bot.Internal.Nicks+import Network.IRC.Fun.Bot.Internal.State+import Network.IRC.Fun.Bot.Internal.Types hiding (Logger)+import Network.IRC.Fun.Bot.Behavior (findCmd, findCmdInSet)+import Network.IRC.Fun.Client.ChannelLogger hiding (LogEvent (..))+import Network.IRC.Fun.Client.IO (nick)+import Network.IRC.Fun.Client.Util (mentions)+ import qualified Data.HashMap.Lazy as M-import Data.Maybe (catMaybes, fromMaybe, maybeToList)-import Data.List (stripPrefix)-import Network.IRC.Fun.Bot.Internal.Chat (pong, sendBack)-import Network.IRC.Fun.Bot.Internal.Failure-import Network.IRC.Fun.Bot.Internal.Nicks-import Network.IRC.Fun.Bot.Internal.State (askBehavior, askBehaviorS)-import Network.IRC.Fun.Bot.Internal.Types hiding (Logger)-import Network.IRC.Fun.Bot.Behavior (findCmd, findCmdInSet)-import Network.IRC.Fun.Client.ChannelLogger hiding (LogEvent (..)) import qualified Network.IRC.Fun.Client.ChannelLogger as L import qualified Network.IRC.Fun.Client.Events as C (Event (..))-import Network.IRC.Fun.Client.IO (nick)-import Network.IRC.Fun.Client.Util (mentions) -------------------------------------------------------------------------------+-- Modifiers+-------------------------------------------------------------------------------++modId :: String -> String+modId = id++modPrefix :: String -> Bool -> String -> String+modPrefix p d s =+ case stripPrefix p s of+ Just s' -> if d then dropWhile isSpace s' else s'+ Nothing -> s++modPrefixes :: [String] -> Bool -> String -> String+modPrefixes ps d s =+ case listToMaybe $ mapMaybe (flip stripPrefix s) ps of+ Just s' -> if d then dropWhile isSpace s' else s'+ Nothing -> s++stripPrefixCI :: String -> String -> Maybe String+stripPrefixCI [] ys = Just ys+stripPrefixCI (_:_) [] = Nothing+stripPrefixCI (x:xs) (y:ys) =+ if toLower x == toLower y+ then stripPrefixCI xs ys+ else Nothing++modPrefixCI :: String -> Bool -> String -> String+modPrefixCI p d s =+ case stripPrefixCI p s of+ Just s' -> if d then dropWhile isSpace s' else s'+ Nothing -> s++modPrefixesCI :: [String] -> Bool -> String -> String+modPrefixesCI ps d s =+ case listToMaybe $ mapMaybe (flip stripPrefixCI s) ps of+ Just s' -> if d then dropWhile isSpace s' else s'+ Nothing -> s++modPleasePrefix :: String -> String+modPleasePrefix = modPrefixCI "please" True++modPleasePrefix' :: String -> String+modPleasePrefix' = modPrefixesCI ["please", "plz", "pls"] True++------------------------------------------------------------------------------- -- Make Events ------------------------------------------------------------------------------- @@ -81,47 +124,94 @@ args = if null w then [] else tail w in (name, args) -makePrefixedCommand :: [CommandSet e s]+expand :: [String] -> Maybe (CommandSet e s) -> [String]+expand ns Nothing = ns+expand ns (Just cset) =+ let ls = map cmdNames $ csetCommands cset+ in concat $ mapMaybe (\ n -> find (n `elem`) ls) ns++makePrefixedCommand :: Maybe Config+ -> [CommandSet e s] -> MessageSource -> Char -> String -> Maybe Event-makePrefixedCommand csets src pref msg =- if pref `elem` map prefix csets- then- let (name, args) = mkCmd msg- in Just $ BotCommand src (Just pref) name args- else Nothing+makePrefixedCommand mconf csets src pref msg =+ let (pref', msg') =+ case mconf >>= flip detectRef (pref:msg) of+ Just (p:m) -> (p, m)+ _ -> (pref, msg)+ in if pref' `elem` map csetPrefix csets && not (null msg')+ then+ let (name, args) = mkCmd msg'+ in Just $ BotCommand src (Just pref') name args+ else Nothing +makePrefixedCommandFromSet :: Maybe Config+ -> CommandSet e s+ -> MessageSource+ -> Char+ -> String+ -> Maybe Event+makePrefixedCommandFromSet mconf cset =+ let names = concatMap cmdNames $ csetCommands cset+ in makePrefixedCommandFromNames mconf (Left $ csetPrefix cset) names++makePrefixedCommandFromNames :: Maybe Config+ -> Either Char (CommandSet e s)+ -> [String]+ -> MessageSource+ -> Char+ -> String+ -> Maybe Event+makePrefixedCommandFromNames mconf eith names src pref msg =+ let (pref', msg') =+ case mconf >>= flip detectRef (pref:msg) of+ Just (p:m) -> (p, m)+ _ -> (pref, msg)+ in if pref' == either id csetPrefix eith && not (null msg')+ then+ let (name, args) = mkCmd msg'+ cset = either (const Nothing) Just eith+ in if name `elem` expand names cset+ then Just $ BotCommand src (Just pref') name args+ else Nothing+ else Nothing+ makeRefCommand :: Config -> MessageSource+ -> (String -> String) -> String -> Maybe Event-makeRefCommand conf src msg =+makeRefCommand conf src f msg = case detectRef conf msg of Just s ->- let (name, args) = mkCmd s+ let (name, args) = mkCmd $ f s in Just $ BotCommand src Nothing name args Nothing -> Nothing makeRefCommandFromSet :: Config -> CommandSet e s -> MessageSource+ -> (String -> String) -> String -> Maybe Event makeRefCommandFromSet conf cset =- makeRefCommandFromNames conf (concatMap names $ commands cset)+ let names = concatMap cmdNames $ csetCommands cset+ in makeRefCommandFromNames conf Nothing names makeRefCommandFromNames :: Config+ -> Maybe (CommandSet e s) -> [String] -> MessageSource+ -> (String -> String) -> String -> Maybe Event-makeRefCommandFromNames conf names src msg =+makeRefCommandFromNames conf cset names src f msg = case detectRef conf msg of Just s ->- let (name, args) = mkCmd s- in if name `elem` names+ let (name, args) = mkCmd $ f s+ in if name `elem` expand names cset then Just $ BotCommand src Nothing name args else Nothing Nothing -> Nothing@@ -136,7 +226,7 @@ makeRefC :: Config -> String -> String -> String -> Maybe Event makeRefC conf chan nick msg = case detectRef conf msg of- Just s -> Just $ BotMessage chan nick s+ Just s -> Just $ BotMessage chan nick s msg Nothing -> Nothing makeRefP :: Config -> String -> String -> Maybe Event@@ -149,100 +239,104 @@ -- Match Events ------------------------------------------------------------------------------- -matchPrefixedCommandC :: EventMatcher e s-matchPrefixedCommandC event _conf csets =- case event of- C.ChannelMessage chan nick (c:cs) False ->- makePrefixedCommand csets (Channel chan nick) c cs- _ -> Nothing+ifPriv :: EventMatchSpace -> Maybe Event -> Maybe Event+ifPriv MatchInChannel _ = Nothing+ifPriv _ e = e -matchPrefixedCommandP :: EventMatcher e s-matchPrefixedCommandP event _conf csets =- case event of- C.PrivateMessage nick (c:cs) False ->- makePrefixedCommand csets (User nick) c cs- _ -> Nothing+ifChan :: EventMatchSpace -> Maybe Event -> Maybe Event+ifChan MatchInPrivate _ = Nothing+ifChan _ e = e -matchPrefixedCommand :: EventMatcher e s-matchPrefixedCommand event _conf csets =+matchPrefixedCommand :: EventMatchSpace+ -> Bool+ -> EventMatcher e s+matchPrefixedCommand space ref event conf csets = case event of C.ChannelMessage chan nick (c:cs) False ->- makePrefixedCommand csets (Channel chan nick) c cs+ ifChan space $+ makePrefixedCommand mconf csets (Channel chan nick) c cs C.PrivateMessage nick (c:cs) False ->- makePrefixedCommand csets (User nick) c cs- _ -> Nothing--matchRefCommandC :: EventMatcher e s-matchRefCommandC event conf _csets =- case event of- C.ChannelMessage chan nick msg False ->- makeRefCommand conf (Channel chan nick) msg- _ -> Nothing--matchRefCommandP :: EventMatcher e s-matchRefCommandP event conf _csets =- case event of- C.PrivateMessage nick msg False ->- makeRefCommand conf (User nick) msg- _ -> Nothing--matchRefCommand :: EventMatcher e s-matchRefCommand event conf _csets =- case event of- C.ChannelMessage chan nick msg False ->- makeRefCommand conf (Channel chan nick) msg- C.PrivateMessage nick msg False ->- makeRefCommand conf (User nick) msg+ ifPriv space $+ makePrefixedCommand mconf csets (User nick) c cs _ -> Nothing+ where+ mconf = if ref then Just conf else Nothing -matchRefCommandFromSetC :: EventMatcher e s-matchRefCommandFromSetC _ _ [] = Nothing-matchRefCommandFromSetC event conf (cset:_) =- case event of- C.ChannelMessage chan nick msg False ->- makeRefCommandFromSet conf cset (Channel chan nick) msg- _ -> Nothing+matchPrefixedCommandFromSet :: EventMatchSpace+ -> Bool+ -> Maybe (CommandSet e s)+ -> EventMatcher e s+matchPrefixedCommandFromSet space ref mcset event conf csets =+ case maybe (listToMaybe csets) Just mcset of+ Nothing -> Nothing+ Just cset ->+ case event of+ C.ChannelMessage chan nick (c:cs) False ->+ ifChan space $+ makePrefixedCommandFromSet+ mconf cset (Channel chan nick) c cs+ C.PrivateMessage nick (c:cs) False ->+ ifPriv space $+ makePrefixedCommandFromSet+ mconf cset (User nick) c cs+ _ -> Nothing+ where+ mconf = if ref then Just conf else Nothing -matchRefCommandFromSetP :: EventMatcher e s-matchRefCommandFromSetP _ _ [] = Nothing-matchRefCommandFromSetP event conf (cset:_) =+matchPrefixedCommandFromNames :: EventMatchSpace+ -> Bool+ -> Either Char (CommandSet e s)+ -> [String]+ -> EventMatcher e s+matchPrefixedCommandFromNames space ref eith names event conf csets = case event of- C.PrivateMessage nick msg False ->- makeRefCommandFromSet conf cset (User nick) msg+ C.ChannelMessage chan nick (c:cs) False ->+ ifChan space $+ makePrefixedCommandFromNames+ mconf eith names (Channel chan nick) c cs+ C.PrivateMessage nick (c:cs) False ->+ ifPriv space $+ makePrefixedCommandFromNames+ mconf eith names (User nick) c cs _ -> Nothing+ where+ mconf = if ref then Just conf else Nothing -matchRefCommandFromSet :: EventMatcher e s-matchRefCommandFromSet _ _ [] = Nothing-matchRefCommandFromSet event conf (cset:_) =+matchRefCommand :: EventMatchSpace -> (String -> String) -> EventMatcher e s+matchRefCommand space f event conf _csets = case event of C.ChannelMessage chan nick msg False ->- makeRefCommandFromSet conf cset (Channel chan nick) msg+ ifChan space $ makeRefCommand conf (Channel chan nick) f msg C.PrivateMessage nick msg False ->- makeRefCommandFromSet conf cset (User nick) msg- _ -> Nothing--matchRefCommandFromNamesC :: [String] -> EventMatcher e s-matchRefCommandFromNamesC names event conf _csets =- case event of- C.ChannelMessage chan nick msg False ->- makeRefCommandFromNames conf names (Channel chan nick) msg+ ifPriv space $ makeRefCommand conf (User nick) f msg _ -> Nothing -matchRefCommandFromNamesP :: [String] -> EventMatcher e s-matchRefCommandFromNamesP names event conf _csets =+matchRefCommandFromSet :: EventMatchSpace+ -> (String -> String)+ -> EventMatcher e s+matchRefCommandFromSet _ _ _ _ [] = Nothing+matchRefCommandFromSet space f event conf (cset:_) = case event of- C.PrivateMessage nick msg False ->- makeRefCommandFromNames conf names (User nick) msg+ C.ChannelMessage chan nick msg False -> ifChan space $+ makeRefCommandFromSet conf cset (Channel chan nick) f msg+ C.PrivateMessage nick msg False -> ifPriv space $+ makeRefCommandFromSet conf cset (User nick) f msg _ -> Nothing -matchRefCommandFromNames :: [String] -> EventMatcher e s-matchRefCommandFromNames names event conf _csets =+matchRefCommandFromNames :: EventMatchSpace+ -> (String -> String)+ -> Bool+ -> [String]+ -> EventMatcher e s+matchRefCommandFromNames space f ex names event conf csets = case event of- C.ChannelMessage chan nick msg False ->- makeRefCommandFromNames conf names (Channel chan nick) msg- C.PrivateMessage nick msg False ->- makeRefCommandFromNames conf names (User nick) msg+ C.ChannelMessage chan nick msg False -> ifChan space $+ makeRefCommandFromNames conf cset names (Channel chan nick) f msg+ C.PrivateMessage nick msg False -> ifPriv space $+ makeRefCommandFromNames conf cset names (User nick) f msg _ -> Nothing+ where+ cset = if ex then listToMaybe csets else Nothing matchPlainPrivateCommand :: EventMatcher e s matchPlainPrivateCommand event _conf _csets =@@ -251,46 +345,22 @@ makePlainCommand (User nick) msg _ -> Nothing -matchNoticeC :: EventMatcher e s-matchNoticeC event _conf _csets =- case event of- C.ChannelMessage chan nick msg True ->- Just $ Notice (Just chan) nick msg- _ -> Nothing--matchNoticeP :: EventMatcher e s-matchNoticeP event _conf _csets =- case event of- C.PrivateMessage nick msg True ->- Just $ Notice Nothing nick msg- _ -> Nothing--matchNotice :: EventMatcher e s-matchNotice event _conf _csets =+matchNotice :: EventMatchSpace -> EventMatcher e s+matchNotice space event _conf _csets = case event of C.ChannelMessage chan nick msg True ->- Just $ Notice (Just chan) nick msg+ ifChan space $ Just $ Notice (Just chan) nick msg C.PrivateMessage nick msg True ->- Just $ Notice Nothing nick msg- _ -> Nothing--matchRefC :: EventMatcher e s-matchRefC event conf _csets =- case event of- C.ChannelMessage chan nick msg False -> makeRefC conf chan nick msg- _ -> Nothing--matchRefP :: EventMatcher e s-matchRefP event conf _csets =- case event of- C.PrivateMessage nick msg False -> makeRefP conf nick msg+ ifPriv space $ Just $ Notice Nothing nick msg _ -> Nothing -matchRef :: EventMatcher e s-matchRef event conf _csets =+matchRef :: EventMatchSpace -> EventMatcher e s+matchRef space event conf _csets = case event of- C.ChannelMessage chan nick msg False -> makeRefC conf chan nick msg- C.PrivateMessage nick msg False -> makeRefP conf nick msg+ C.ChannelMessage chan nick msg False ->+ ifChan space $ makeRefC conf chan nick msg+ C.PrivateMessage nick msg False ->+ ifPriv space $ makeRefP conf nick msg _ -> Nothing defaultMatch :: EventMatcher e s@@ -303,7 +373,10 @@ C.Quit nick reason -> Just $ Quit nick reason C.ChannelMessage channel nick msg False -> Just $ Message channel nick msg $ msg `mentions` bnick+ C.ChannelAction channel nick msg ->+ Just $ Action channel nick msg $ msg `mentions` bnick C.PrivateMessage nick msg False -> Just $ PersonalMessage nick msg+ C.PrivateAction nick msg -> Just $ PersonalAction nick msg C.NickChange oldnick newnick -> Just $ NickChange oldnick newnick C.Topic channel nick topic -> Just $ TopicChange channel nick topic C.Names priv chan pnicks -> Just $ Names chan priv pnicks@@ -362,12 +435,12 @@ case mchan of Just chan -> defaultRespondToChan- chan (Just $ prefix cset) cname (Just cset)+ chan (Just $ csetPrefix cset) cname (Just cset) Nothing -> defaultRespondToUser- sender (Just $ prefix cset) cname (Just cset)+ sender (Just $ csetPrefix cset) cname (Just cset) Just (Right cmd) ->- respond cmd mchan sender cparams (sendBack mchan sender)+ cmdRespond cmd mchan sender cparams (sendBack mchan sender) -- React to a bot event. handleBotEvent :: Event -> Session e s ()@@ -376,10 +449,12 @@ case event of Ping s1 s2 -> pong s1 s2 Kick chan users why -> return ()- Join chan nick -> do+ Join chan user -> do tracked <- channelIsTracked chan- when tracked $ addMember chan nick- handleJoin b chan nick+ when tracked $ addMember chan user+ self <- askConfigS $ nick . connection+ when (user == self) $ addCurrChan chan+ handleJoin b chan user Part chan nick why -> do tracked <- channelIsTracked chan when tracked $ removeMemberOnce chan nick@@ -389,13 +464,16 @@ handleQuit b nick why Message chan sender msg mentioned -> handleMsg b chan sender msg mentioned+ Action chan sender msg mentioned ->+ handleAction b chan sender msg mentioned Notice mchan sender msg -> return ()- BotMessage chan sender msg -> handleBotMsg b chan sender msg+ BotMessage chan sender msg full -> handleBotMsg b chan sender msg full BotCommand (Channel chan sender) cpref cname cargs -> runCommand cpref cname cargs (Just chan) sender BotCommand (User sender) cpref cname cargs -> runCommand cpref cname cargs Nothing sender PersonalMessage sender msg -> handlePersonalMsg b sender msg+ PersonalAction sender msg -> handlePersonalAction b sender msg NickChange oldnick newnick -> do changeNick oldnick newnick handleNickChange b oldnick newnick@@ -413,11 +491,11 @@ detectLogEvents e = let detect event cstate = fmap (\ cl -> (cl, event)) $ chanLogger cstate detectOne chan event = do- cstates <- gets chanstate+ cstates <- gets bsChannels return $ maybeToList $ M.lookup chan cstates >>= detect event detectMany nick event = do chans <- presence nick- cstates <- gets chanstate+ cstates <- gets bsChannels let cstatesP = cstates `M.difference` M.fromList (zip chans (repeat ())) return $ catMaybes $ map (detect event) $ M.elems cstatesP@@ -426,6 +504,7 @@ L.Leave nick chan -> detectOne chan $ LeaveChan nick L.LeaveAll nick -> detectMany nick $ LeaveChan nick L.Message nick chan msg -> detectOne chan $ MessageChan nick msg+ L.Action nick chan msg -> detectOne chan $ ActInChan nick msg L.Rename oldN newN -> detectMany oldN $ RenameInChan oldN newN -- Possibly write a log event into the right file(s), according to logging
src/Network/IRC/Fun/Bot/Internal/Failure.hs view
@@ -24,7 +24,7 @@ import Data.Char (toLower) import Data.List (intercalate)-import Network.IRC.Fun.Bot.Internal.Chat (sendToChannel, sendToUser, sendBack)+import Network.IRC.Fun.Bot.Internal.Chat (sendToChannel, sendToUser) import Network.IRC.Fun.Bot.Internal.State (askBehaviorS) import Network.IRC.Fun.Bot.Internal.Types import Text.Printf (printf)@@ -39,20 +39,20 @@ -> Maybe (CommandSet e s) -- The command set matching the -- prefix, if one was found -> String-defaultResponse Nothing _cname csets _ =+defaultResponse Nothing _cname _csets _ = "Expected to find a default command prefix, but there’s none." defaultResponse (Just cpref) _cname csets Nothing = printf "Expected to find a command with prefix ‘%v’, but there’s none. \ \Available prefixes are: ‘%v’." cpref $- intercalate "’, ‘" $ map ((: []) . prefix) csets+ intercalate "’, ‘" $ map ((: []) . csetPrefix) csets defaultResponse (Just cpref) cname _csets (Just cset) = printf "The command ‘%v%v’ isn’t available. Available commands for prefix \ \‘%v’ are: ‘%v’." cpref cname cpref $- intercalate "’, ‘" $ map (head . names) $ commands cset+ intercalate "’, ‘" $ map (head . cmdNames) $ csetCommands cset -- | Send the default response to an IRC channel defaultRespondToChan
src/Network/IRC/Fun/Bot/Internal/IrcLog.hs view
@@ -25,20 +25,21 @@ ) where -import Control.Monad (liftM)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS (ask)+import Control.Monad (liftM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.RWS (ask)+import Data.Maybe (isJust)+import Data.Traversable (traverse)+import Network.IRC.Fun.Bot.Internal.State+import Network.IRC.Fun.Bot.Internal.Types hiding (Logger)+import Network.IRC.Fun.Client.ChannelLogger+ import qualified Data.HashMap.Lazy as M-import Data.Maybe (isJust)-import Data.Traversable (traverse)-import Network.IRC.Fun.Bot.Internal.State-import Network.IRC.Fun.Bot.Internal.Types hiding (Logger)-import Network.IRC.Fun.Client.ChannelLogger makeLogger :: BotEnv e s -> String -> IO Logger makeLogger env chan =- let timeGetter = getTime env- logdir = logDir $ config env+ let timeGetter = beGetTime env+ logdir = logDir $ beConfig env file = logFilePath logdir "server" chan in newLogger (liftM snd timeGetter) file
src/Network/IRC/Fun/Bot/Internal/Logger.hs view
@@ -42,7 +42,7 @@ -- | Create a logger inside the bot session. newLogger' :: FilePath -> Session e s Logger newLogger' path = do- timeGetter <- asks getTime+ timeGetter <- asks beGetTime liftIO $ newLogger (liftM snd timeGetter) path -- | Flush buffers and release resources.
src/Network/IRC/Fun/Bot/Internal/Nicks.hs view
@@ -33,16 +33,17 @@ ) where -import Control.Monad (unless)-import Control.Monad.Trans.RWS+import Control.Monad (unless)+import Control.Monad.Trans.RWS+import Data.Maybe (fromMaybe)+import Network.IRC.Fun.Bot.Internal.Chat (putIrc)+import Network.IRC.Fun.Bot.Internal.State+import Network.IRC.Fun.Bot.Internal.Types+import Network.IRC.Fun.Messages.TypeAliases (ChannelName)+import Network.IRC.Fun.Messages.Types (Message (NamesMessage))+ import qualified Data.HashMap.Lazy as M-import Data.Maybe (fromMaybe)-import Network.IRC.Fun.Bot.Internal.Chat (putIrc)-import Network.IRC.Fun.Bot.Internal.State-import Network.IRC.Fun.Bot.Internal.Types import qualified Network.IRC.Fun.Client.NickTracker as NT-import Network.IRC.Fun.Messages.TypeAliases (ChannelName)-import Network.IRC.Fun.Messages.Types (Message (NamesMessage)) enable :: ChannelState -> ChannelState enable cstate = cstate { chanTracking = True }@@ -94,25 +95,25 @@ stopTrackingAll :: Session e s () stopTrackingAll = modify $ \ bstate -> bstate- { tracker = NT.newNetwork- , chanstate = M.map disable $ chanstate bstate+ { bsTracker = NT.newNetwork+ , bsChannels = M.map disable $ bsChannels bstate } -- | Stop tracking nicks in the given channel, if tracked. stopTrackingChannel :: String -> Session e s () stopTrackingChannel chan = modify $ \ bstate -> bstate- { tracker = NT.removeChannel chan $ tracker bstate- , chanstate = M.adjust disable chan $ chanstate bstate+ { bsTracker = NT.removeChannel chan $ bsTracker bstate+ , bsChannels = M.adjust disable chan $ bsChannels bstate } -- | Stop tracking nicks in the tracked channels among the ones given. stopTrackingChannels :: [String] -> Session e s () stopTrackingChannels chans = modify $ \ bstate -> bstate- { tracker = NT.removeChannels chans $ tracker bstate- , chanstate =- let chanmap = chanstate bstate+ { bsTracker = NT.removeChannels chans $ bsTracker bstate+ , bsChannels =+ let chanmap = bsChannels bstate chanmapE = M.filter chanTracking chanmap chanmapD = M.map disable chanmapE in chanmapD `M.union` chanmap@@ -121,54 +122,54 @@ -- | Check whether a nickname is present in a channel. isInChannel :: String -> String -> Session e s Bool nick `isInChannel` chan = do- nt <- gets tracker+ nt <- gets bsTracker return $ NT.isInChannel nick chan nt -- | Check in which channels a nickname is present. presence :: String -> Session e s [ChannelName] presence nick = do- nt <- gets tracker+ nt <- gets bsTracker return $ NT.presence nick nt -- | Record a nickname being present in a channel. addMember :: String -> String -> Session e s ()-addMember chan nick = modify $ \ s -> s { tracker = f $ tracker s }+addMember chan nick = modify $ \ s -> s { bsTracker = f $ bsTracker s } where f = NT.addToChannel chan nick -- | Record a nickname change. Remove old nickname from the channels in which -- it's present, and add the new nickname to them. changeNick :: String -> String -> Session e s ()-changeNick old new = modify $ \ s -> s { tracker = f $ tracker s }+changeNick old new = modify $ \ s -> s { bsTracker = f $ bsTracker s } where f = NT.changeNick old new -- | Record a channel with the given present nicknames. addChannel :: String -> [String] -> Session e s ()-addChannel chan nicks = modify $ \ s -> s { tracker = f $ tracker s }+addChannel chan nicks = modify $ \ s -> s { bsTracker = f $ bsTracker s } where f = NT.addChannel chan nicks -- | Record a channel not having a given nickname anymore. removeMemberOnce :: String -> String -> Session e s ()-removeMemberOnce chan nick = modify $ \ s -> s { tracker = f $ tracker s }+removeMemberOnce chan nick = modify $ \ s -> s { bsTracker = f $ bsTracker s } where f = NT.removeFromChannel chan nick -- | Record a nickname not being present in any channel anymore. removeMember :: String -> Session e s ()-removeMember nick = modify $ \ s -> s { tracker = f $ tracker s }+removeMember nick = modify $ \ s -> s { bsTracker = f $ bsTracker s } where f = NT.removeFromNetwork nick -- | Remove a channel from the records. removeChannel :: String -> Session e s ()-removeChannel chan = modify $ \ s -> s { tracker = f $ tracker s }+removeChannel chan = modify $ \ s -> s { bsTracker = f $ bsTracker s } where f = NT.removeChannel chan -- | Remove channels from the records. removeChannels :: [String] -> Session e s ()-removeChannels chans = modify $ \ s -> s { tracker = f $ tracker s }+removeChannels chans = modify $ \ s -> s { bsTracker = f $ bsTracker s } where f = NT.removeChannels chans
src/Network/IRC/Fun/Bot/Internal/Persist.hs view
@@ -20,34 +20,41 @@ ( loadBotState , mkSaveBotState , saveBotState+ , selectChannel+ , unselectChannel+ , addChannelState ) where -import Control.Applicative-import Control.Monad (liftM, mzero)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS-import Data.Aeson+import Control.Applicative+import Control.Monad (mzero, unless, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.RWS+import Data.Aeson+import Data.Maybe (isJust)+import Data.JsonState+import Data.List (union)+import Data.Time.Interval+import Data.Time.Units (Microsecond)+import Network.IRC.Fun.Bot.Internal.IrcLog (makeLogger)+import Network.IRC.Fun.Bot.Internal.State+import Network.IRC.Fun.Bot.Internal.Types+import Network.IRC.Fun.Client.NickTracker (newNetwork)+ import qualified Data.HashMap.Lazy as M-import Data.Maybe (isJust)-import Data.JsonState-import Data.Time.Interval-import Data.Time.Units (Microsecond)-import Network.IRC.Fun.Bot.Internal.IrcLog (makeLogger)-import Network.IRC.Fun.Bot.Internal.Types-import Network.IRC.Fun.Client.NickTracker (newNetwork)+import qualified Data.HashSet as S data ChannelStateJ = ChannelStateJ Bool Bool -data BotStateJ = BotStateJ (M.HashMap String ChannelStateJ)+data BotStateJ = BotStateJ (M.HashMap String ChannelStateJ) (S.HashSet String) toJ :: BotState s -> BotStateJ-toJ bstate = BotStateJ $ M.map f $ chanstate bstate+toJ bstate = BotStateJ (M.map f $ bsChannels bstate) (bsSelChans bstate) where f (ChannelState track mlogger) = ChannelStateJ track (isJust mlogger) -fromJ :: BotStateJ -> BotEnv e s -> s -> IO (BotState s)-fromJ (BotStateJ chansJ) env pub = do+fromJ :: BotEnv e s -> BotStateJ -> s -> IO (BotState s)+fromJ env (BotStateJ stateJ selJ) pub = do let f chan (ChannelStateJ tracking logging) = do mlogger <- if logging@@ -55,10 +62,11 @@ else return Nothing return $ ChannelState tracking mlogger defstate = ChannelStateJ False False- chansConf = M.fromList $ zip (channels $ config env) (repeat defstate)- chansAll = chansJ `M.union` chansConf- chans <- M.traverseWithKey f chansAll- return $ BotState newNetwork chans pub+ chansConf = S.toList selJ `union` channels (beConfig env)+ stateConf = M.fromList $ zip chansConf (repeat defstate)+ stateAll = stateJ `M.union` stateConf+ cstate <- M.traverseWithKey f stateAll+ return $ BotState newNetwork cstate S.empty selJ pub instance FromJSON ChannelStateJ where parseJSON (Object o) =@@ -76,12 +84,14 @@ instance FromJSON BotStateJ where parseJSON (Object o) = BotStateJ <$>- o .: "channels"+ o .: "chan-state" <*>+ o .: "chans-join" parseJSON _ = mzero instance ToJSON BotStateJ where- toJSON (BotStateJ chans) = object- [ "channels" .= chans+ toJSON (BotStateJ chans sel) = object+ [ "chan-state" .= chans+ , "chans-join" .= sel ] instance ToJSON (BotState s) where@@ -89,12 +99,12 @@ loadBotState :: BotEnv e s -> s -> IO (BotState s) loadBotState env pub = do- let conf = config env+ let conf = beConfig env r <- loadState $ stateFilePath (stateFile conf) (stateRepo conf) case r of Left (False, e) -> error $ "Failed to read state file: " ++ e Left (True, e) -> error $ "Failed to parse state file: " ++ e- Right sj -> fromJ sj env pub+ Right sj -> fromJ env sj pub mkSaveBotState :: Config -> IO (BotState s -> IO ()) mkSaveBotState conf =@@ -105,5 +115,35 @@ saveBotState :: Session e s () saveBotState = do bstate <- get- save <- asks saveState+ save <- asks beSaveState liftIO $ save bstate++-- | Add a channel to the persistent list of channels to be joined. Next time+-- the bot launches (or, say, 'joinConfig` is called), it will join this+-- channel. If the channel is already listed, nothing happens.+selectChannel :: String -> Session e s ()+selectChannel chan = do+ chans <- gets bsSelChans+ unless (chan `S.member` chans) $ do+ modify $ \ s -> s { bsSelChans = S.insert chan chans }+ saveBotState++-- | Remove a channel from the persistent list of channels to be joined. Next+-- time the bot launches, it won't join this channel (unless listed in the+-- config or otherwise requested). If the channel isn't listed, nothing+-- happens.+unselectChannel :: String -> Session e s ()+unselectChannel chan = do+ chans <- gets bsSelChans+ when (chan `S.member` chans) $ do+ modify $ \ s -> s { bsSelChans = S.delete chan chans }+ saveBotState++-- | Add default channel state for the given channel. It will be stored into+-- the state file. If the channel already has state, nothing will happen.+addChannelState :: String -> Session e s ()+addChannelState chan = do+ chans <- getChans+ unless (chan `M.member` chans) $ do+ putChans $ M.insert chan (ChannelState False Nothing) chans+ saveBotState
src/Network/IRC/Fun/Bot/Internal/State.hs view
@@ -30,44 +30,52 @@ , getChans , putChans , modifyChans+ , addCurrChan+ , removeCurrChan+ , clearCurrChans+ , channelSelected+ , botMemberOf ) where -import Control.Monad.Trans.RWS-import Data.HashMap.Lazy (HashMap)+import Control.Monad (liftM)+import Control.Monad.Trans.RWS+import Data.HashMap.Lazy (HashMap)+import Data.Maybe (isJust)+import Data.Time.Clock (UTCTime)+import Network.IRC.Fun.Bot.Internal.Types+import Network.IRC.Fun.Client.IO (Handle)+ import qualified Data.HashMap.Lazy as M-import Data.Maybe (isJust)-import Data.Time.Clock (UTCTime)-import Network.IRC.Fun.Bot.Internal.Types-import Network.IRC.Fun.Client.IO (Handle)+import qualified Data.HashSet as S -- | Fetch the bot configuration. askConfig :: Session e s Config-askConfig = asks config+askConfig = asks beConfig -- | Retrieve a function of the bot configuration. askConfigS :: (Config -> a) -> Session e s a-askConfigS f = asks $ f . config+askConfigS f = asks $ f . beConfig -- | Fetch the bot behavior definition. askBehavior :: Session e s (Behavior e s)-askBehavior = asks behavior+askBehavior = asks beBehavior -- | Retrieve a function of the bot behavior definition. askBehaviorS :: (Behavior e s -> a) -> Session e s a-askBehaviorS f = asks $ f . behavior+askBehaviorS f = asks $ f . beBehavior -- | Fetch the bot environment, i.e. read-only state. askEnv :: Session e s e-askEnv = asks custom+askEnv = asks beCustom -- | Retrieve a function of the bot environment. askEnvS :: (e -> a) -> Session e s a-askEnvS f = asks $ f . custom+askEnvS f = asks $ f . beCustom -- | Fetch the bot session socket handle. askHandle :: Session e s Handle-askHandle = asks handle+askHandle = asks beHandle -- | Fetch the time getter. The actual time data is cached and updated at most -- once per second depending on need. You can safely use it at any frequency@@ -76,26 +84,26 @@ -- The second item is a formatted time string in the form -- @2015-09-01 18:10:00@, and is always expressed in UTC. askTimeGetter :: Session e s (IO (UTCTime, String))-askTimeGetter = asks getTime+askTimeGetter = asks beGetTime -- | Fetch the current value of the state within the session. getState :: Session e s s-getState = gets public+getState = gets bsPublic -- | Get a specific component of the state, using a projection function -- supplied. getStateS :: (s -> a) -> Session e s a-getStateS f = gets $ f . public+getStateS f = gets $ f . bsPublic -- | Set the state within the session. putState :: s -> Session e s ()-putState st = modify $ \ old -> old { public = st }+putState st = modify $ \ old -> old { bsPublic = st } -- | Update the state to the result of applying a function to the current -- state. modifyState :: (s -> s) -> Session e s () modifyState f =- modify $ \ old@(BotState { public = st }) -> old { public = f st }+ modify $ \ old@(BotState { bsPublic = st }) -> old { bsPublic = f st } -- | Get channel state information, in the form of a mapping from channel names -- to their data.@@ -111,13 +119,40 @@ -- Get the channel state map. getChans :: Session e s (HashMap String ChannelState)-getChans = gets chanstate+getChans = gets bsChannels -- Set a new value for the channel state map. putChans :: HashMap String ChannelState -> Session e s ()-putChans chans = modify $ \ s -> s { chanstate = chans }+putChans chans = modify $ \ s -> s { bsChannels = chans } -- Update the channel state map value with the result of applying a function. modifyChans :: (HashMap String ChannelState -> HashMap String ChannelState) -> Session e s ()-modifyChans f = modify $ \ s -> s { chanstate = f $ chanstate s }+modifyChans f = modify $ \ s -> s { bsChannels = f $ bsChannels s }++-- Add a channel to the list of currently really-joined channels.+addCurrChan :: String -> Session e s ()+addCurrChan chan =+ let f = S.insert chan+ in modify $ \ s -> s { bsCurrChans = f $ bsCurrChans s }++-- Remove a channel from the list of currently really-joined channels.+removeCurrChan :: String -> Session e s ()+removeCurrChan chan =+ let f = S.delete chan+ in modify $ \ s -> s { bsCurrChans = f $ bsCurrChans s }++-- Remove all channels from the list of currently really-joined channels.+clearCurrChans :: Session e s ()+clearCurrChans = modify $ \ s -> s { bsCurrChans = S.empty }++-- | Check whether a channel is listed in persistent state to be joined.+channelSelected :: String -> Session e s Bool+channelSelected chan = liftM (chan `S.member`) $ gets bsSelChans++-- | Check whether, as far as the bot knows, if it currently a member of the+-- given channel. Currently kicks, bans, etc. are fully tracked, therefore this+-- information isn't 100% accurate, but if you aren't planning to ban your bot+-- you can probably rely on it.+botMemberOf :: String -> Session e s Bool+botMemberOf chan = liftM (chan `S.member`) $ gets bsCurrChans
src/Network/IRC/Fun/Bot/Internal/Types.hs view
@@ -27,8 +27,10 @@ , Privilege (..) , Event (..) , EventMatcher+ , EventMatchSpace (..) , Behavior (..) , Logger (..)+ , Msg (..) , EventSource , EventHandler , Quotes (..)@@ -37,20 +39,27 @@ import Control.Monad.Trans.RWS (RWST) import Data.HashMap.Lazy (HashMap)+import Data.HashSet (HashSet) import Data.Time.Clock (UTCTime) import Data.Time.Interval (TimeInterval)-import qualified Network.IRC.Fun.Client.ChannelLogger as L (Logger)+import Network.IRC.Fun.Client.ChannelLogger (LogEvent) import Network.IRC.Fun.Client.IO (Connection, Handle) import Network.IRC.Fun.Client.Events (ChannelPrivacy (..), Privilege (..))-import qualified Network.IRC.Fun.Client.Events as C (Event) import Network.IRC.Fun.Client.NickTracker (NetworkTracker) import System.Log.FastLogger (LoggerSet) +import qualified Network.IRC.Fun.Client.ChannelLogger as L (Logger)+import qualified Network.IRC.Fun.Client.Events as C (Event)+ -- | Configuration for the bot connection to IRC. data Config = Config { -- | Connection details, including nickname and optional password connection :: Connection- -- | List of channels to join, e.g. @["#freepost", "#rel4tion"]@+ -- | The list of channels for the bot to join is generally set in the+ -- state file, but when the bot launches it joins both the channels+ -- listed there and the ones listed here. This list is intended to be+ -- used as hard-coded backup, i.e. the bot will always join these+ -- channels regardless of what the state file says. , channels :: [String] -- | Directory path under which IRC log files will be placed. Relative to -- the bot process working directory, or absolute.@@ -72,13 +81,20 @@ -- | Filename for the bot's main event log, i.e. produced by the IRC -- event source. , botEventLogFile :: FilePath+ -- | Maximal number of characters in a message the bot can send to a user+ -- or a channel. Longer messages will be split. 'Nothing' means no limit,+ -- i.e. let the IRC server truncate long messages. This limit applies to+ -- 'sendToUser' and 'sendToChannel' and all the functions which use them.+ -- A safe default if you want to set a limit is 400.+ , maxMsgChars :: Maybe Int+ -- | Time interval for sending PINGs to the server, to make sure the+ -- connection is alive. 'Nothing' means no PINGs sent.+ , lagCheck :: Maybe TimeInterval+ -- | Maximal lag time allowed before the bot quits.+ , lagMax :: TimeInterval } deriving Show --- / A discussion space where the bot is involved. An IRC channel or a private--- session with a specific user.---data Room = Channel String | User String deriving (Eq, Show)- -- | A message for the bot can come privately or in a channel by a given user. data MessageSource = Channel String String | User String deriving (Eq, Show) @@ -111,7 +127,7 @@ -- -- The first name in the list is considered the /primary name/. When one -- name is shown, e.g. in help messages, it will be the primary name.- names :: [String]+ cmdNames :: [String] -- | What to do in response to the command being triggered by an IRC -- user. The bot can send an IRC message back to the channel, or modify@@ -129,15 +145,15 @@ -- (3) Command parameters given -- (4) Action for sending a message back to the sender, same as using -- @sendBack@ with the channel and nickname- , respond :: Maybe String- -> String- -> [String]- -> (String -> Session e s ())- -> Session e s ()+ , cmdRespond :: Maybe String+ -> String+ -> [String]+ -> (String -> Session e s ())+ -> Session e s () -- | Help string for the command, explaining it purpose, its parameters -- and its usage, possibly giving an example. May contain newlines.- , help :: String+ , cmdHelp :: String } -- | The bot recognizes commands by picking IRC channel messages which begin@@ -149,8 +165,8 @@ -- -- Common prefixes are @'!', '\@', '>', ':'@. data CommandSet e s = CommandSet- { prefix :: Char- , commands :: [Command e s]+ { csetPrefix :: Char+ , csetCommands :: [Command e s] } -- Read-only bot environment.@@ -165,12 +181,12 @@ -- the password to automatically re-identify in case of any problem with -- NickServ. And so on. data BotEnv e s = BotEnv- { config :: Config- , behavior :: Behavior e s- , handle :: Handle- , getTime :: IO (UTCTime, String)- , saveState :: BotState s -> IO ()- , custom :: e+ { beConfig :: Config+ , beBehavior :: Behavior e s+ , beHandle :: Handle+ , beGetTime :: IO (UTCTime, String)+ , beSaveState :: BotState s -> IO ()+ , beCustom :: e } -- Per-channel modifiable state@@ -182,9 +198,16 @@ -- Readable and writable bot state. Contains internal state used by this -- library, and public state managed by the bot's behavior logic. data BotState s = BotState- { tracker :: NetworkTracker- , chanstate :: HashMap String ChannelState- , public :: s+ { -- Keeps track of which users are in which channels+ bsTracker :: NetworkTracker+ -- Per-channel persistent state+ , bsChannels :: HashMap String ChannelState+ -- Channels of which the bot is currently a member+ , bsCurrChans :: HashSet String+ -- Channels the bot should join when it launches+ , bsSelChans :: HashSet String+ -- Custom state+ , bsPublic :: s } -- | Bot monad. It provides read-only bot environment (e.g. the configuration),@@ -209,16 +232,18 @@ -- with the given nickname (2nd parameter). The last parameter says whether -- the bot's nick is mentioned in the message. | Message String String String Bool+ -- | Like 'Message', but it's a pseudo action (/me).+ | Action String String String Bool -- | Like 'Message', but this is a notice. The bot shouldn't send a -- response (but it can modify its state etc.). First parameter: Just -- channel, or Nothing. The latter means a private message. | Notice (Maybe String) String String- -- | Message (3rd parameter) referring to the bot sent by nick (2nd- -- parameter) in a channel (1st parameter). The message begins with the- -- bot's nick, followed by a colon or a comma. That part is however removed- -- from the 3rd parameter. For example, if the message was- -- \"funbot, hello!\" then the 3rd parameter will be \"hello!\".- | BotMessage String String String+ -- | Message referring to the bot sent in a channel. The message begins+ -- with the bot's nick, followed by a colon or a comma. For example, if the+ -- message was \"funbot, hello!\" then the 3rd parameter will be+ -- \"hello!\". The parameters are: Channel, nickname, stripped message,+ -- full message including the reference.+ | BotMessage String String String String -- | A bot command, which is a message with a special prefix, was sent to -- a channel or privately to the bot. Parameters: Source, prefix character, -- command name, command arguments.@@ -227,6 +252,8 @@ -- given nickname (1st parameter) and with the given content (2nd -- parameter). | PersonalMessage String String+ -- | Like 'PersonalMessage', but it's a pseudo action (/me).+ | PersonalAction String String -- | Old nick, new nick. | NickChange String String -- | Channel, nickname, topic@@ -240,36 +267,57 @@ | OtherEvent String deriving Show --- Tries to match a client event to a bot event.+-- | Tries to match a client event to a bot event. type EventMatcher e s = C.Event -> Config -> [CommandSet e s] -> Maybe Event +-- | Where an event matcher applies.+data EventMatchSpace = MatchInChannel | MatchInPrivate | MatchInBoth+ -- | Bot behavior definition. data Behavior e s = Behavior- { handleJoin :: String -> String -> Session e s ()- , handlePart :: String -> String -> Maybe String -> Session e s ()- , handleQuit :: String -> Maybe String -> Session e s ()- , handleMsg :: String -> String -> String -> Bool -> Session e s ()- , handleBotMsg :: String -> String -> String -> Session e s ()- , commandSets :: [CommandSet e s]- , handlePersonalMsg :: String -> String -> Session e s ()- , handleNickChange :: String -> String -> Session e s ()- , handleTopicChange :: String -> String -> String -> Session e s ()+ { handleJoin+ :: String -> String -> Session e s ()+ , handlePart+ :: String -> String -> Maybe String -> Session e s ()+ , handleQuit+ :: String -> Maybe String -> Session e s ()+ , handleMsg+ :: String -> String -> String -> Bool -> Session e s ()+ , handleAction+ :: String -> String -> String -> Bool -> Session e s ()+ , handleBotMsg+ :: String -> String -> String -> String -> Session e s ()+ , commandSets+ :: [CommandSet e s]+ , handlePersonalMsg+ :: String -> String -> Session e s ()+ , handlePersonalAction+ :: String -> String -> Session e s ()+ , handleNickChange+ :: String -> String -> Session e s ()+ , handleTopicChange+ :: String -> String -> String -> Session e s () -- | Handle a channel member list received. Parameters: -- -- (1) Channel name -- (2) Channel privacy -- (3) List of channel members: their privilege level in the channel and -- their nicknames- , handleNames :: String- -> ChannelPrivacy- -> [(Privilege, String)]- -> Session e s ()+ , handleNames+ :: String -> ChannelPrivacy -> [(Privilege, String)] -> Session e s () } data Logger = Logger { loggerSet :: LoggerSet , loggerGetTime :: IO String }++-- An event passed to the main thread (event handler) from other threads.+data Msg a+ = MsgLogEvent LogEvent+ | MsgBotEvent Event+ | MsgExtEvent a+ | MsgQuit -- | An 'IO' action, possibly running forever, which produces events for the -- bot to process. These event sources are run by the bot in dedicated threads.
src/Network/IRC/Fun/Bot/State.hs view
@@ -28,6 +28,11 @@ , putState , modifyState , getChannelState+ , selectChannel+ , unselectChannel+ , channelSelected+ , botMemberOf+ , addChannelState , saveBotState ) where
src/Network/IRC/Fun/Bot/Types.hs view
@@ -22,6 +22,7 @@ , Command (..) , CommandSet (..) , Session+ , EventMatchSpace (..) , Behavior (..) , EventSource , EventHandler