irc-fun-bot 0.5.0.0 → 0.6.0.0
raw patch · 24 files changed
+1217/−912 lines, 24 filesdep +case-insensitivedep +data-default-classdep +formattingdep −irc-fun-messagesdep ~irc-fun-clientdep ~transformers
Dependencies added: case-insensitive, data-default-class, formatting, irc-fun-types, text
Dependencies removed: irc-fun-messages
Dependency ranges changed: irc-fun-client, transformers
Files
- NEWS +0/−146
- NEWS.md +184/−0
- irc-fun-bot.cabal +11/−6
- src/Network/IRC/Fun/Bot.hs +54/−72
- src/Network/IRC/Fun/Bot/Behavior.hs +18/−67
- src/Network/IRC/Fun/Bot/Chat.hs +5/−0
- src/Network/IRC/Fun/Bot/EventMatch.hs +1/−1
- src/Network/IRC/Fun/Bot/Internal/Chat.hs +174/−126
- src/Network/IRC/Fun/Bot/Internal/ChatExt.hs +4/−5
- src/Network/IRC/Fun/Bot/Internal/Event.hs +195/−162
- src/Network/IRC/Fun/Bot/Internal/Failure.hs +101/−70
- src/Network/IRC/Fun/Bot/Internal/History.hs +10/−8
- src/Network/IRC/Fun/Bot/Internal/Instances.hs +26/−0
- src/Network/IRC/Fun/Bot/Internal/IrcLog.hs +12/−10
- src/Network/IRC/Fun/Bot/Internal/Logger.hs +4/−3
- src/Network/IRC/Fun/Bot/Internal/Monad.hs +61/−0
- src/Network/IRC/Fun/Bot/Internal/MsgCount.hs +47/−38
- src/Network/IRC/Fun/Bot/Internal/Nicks.hs +18/−19
- src/Network/IRC/Fun/Bot/Internal/Persist.hs +33/−16
- src/Network/IRC/Fun/Bot/Internal/State.hs +47/−20
- src/Network/IRC/Fun/Bot/Internal/Types.hs +178/−86
- src/Network/IRC/Fun/Bot/State.hs +2/−0
- src/Network/IRC/Fun/Bot/Types.hs +32/−7
- src/Network/IRC/Fun/Bot/Util.hs +0/−50
− NEWS
@@ -1,146 +0,0 @@-This file lists the user-visible interesting changes between releases. For a-full list of changes to the source, see the ChangeLog.----irc-fun-bot 0.5.0.0 -- 2015-12-17-=================================--General, build and documentation changes:--* (None)--New APIs, features and enhancements:--* Debug log-* History logging (moved code from funbot)-* Per-channel history lines limit-* Message delay thread with configurable delay-* Prefix `Config` fields-* Message counting system--Bug fixes:--* Log and remember bot's own messages, otherwise logs were incomplete--Dependency changes:--* Require irc-fun-client >= 0.4------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-=================================--General, build and documentation changes:--* (None)--New APIs, features and enhancements:--* Allow sending commands in private messages-* Version control support (via Git) for state file-* Nick change event available, and new nick tracker action: changeNick-* New config option, stateRepo, to specify the git repo for state file--Bug fixes:--* (None)--Dependency changes:--* Add json-state-* Require irc-fun-client >= 0.2.0.0------irc-fun-bot 0.2.0.0 -- 2015-09-10-=================================--General, build and documentation changes:--* (None)--New APIs, features and enhancements:--* Nickname tracker with control API-* Channel logger with control API-* Persistent state using JSON files-* Bot events logged into a file now, not stdout-* Event sources have access to a logging API-* Support prefix-less bot commands-* Event matching control--Bug fixes:--* (None)--Dependency changes:--* Add aeson-* Add fast-logger-* Add settings-* Add time-* Add time-interval-* Add time-units-* Add unordered-containers-* Require irc-fun-client >= 0.1.1.0------irc-fun-bot 0.1.0.0 -- 2015-08-09-=================================--General, build and documentation changes:--* (This is the first release, so everything is new)--New APIs, features and enhancements:--* (This is the first release, so everything is a new feature)--Bug fixes:--* (This is just the first release, many bugs haven't been discovered yet)--Dependency changes:--* (This is the first release)
+ NEWS.md view
@@ -0,0 +1,184 @@+This file lists the user-visible interesting changes between releases. For a+full list of changes to the source, see the ChangeLog.++++irc-fun-bot 0.6.0.0 -- 2016-01-27+=================================++General, build and documentation changes:++* (None)++New APIs, features and enhancements:++* `send*Now` variants for sending a message without delay+* `send*'` variants which allow to send a notice+* Move from `String` to `Text` and wrapper `newtype`s+* Remove quoting and command-list showing utilities+* `Behavior` is now abstract and has a `Default` instance+* Command names are now case-insensitive+* Optional loggers for ext event handler+* IRC event logger is now optional+* Response to nonexistent command can be turned off+* `Command` new field: Usage examples++Bug fixes:++* (None)++Dependency changes:++* Add case-insensitive >= 1+ data-default-class+ formatting >= 6.2+ irc-fun-types+ text+* Require irc-fun-client >= 0.5+* Remove irc-fun-messages++++++irc-fun-bot 0.5.0.0 -- 2015-12-17+=================================++General, build and documentation changes:++* (None)++New APIs, features and enhancements:++* Debug log+* History logging (moved code from funbot)+* Per-channel history lines limit+* Message delay thread with configurable delay+* Prefix `Config` fields+* Message counting system++Bug fixes:++* Log and remember bot's own messages, otherwise logs were incomplete++Dependency changes:++* Require irc-fun-client >= 0.4++++++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+=================================++General, build and documentation changes:++* (None)++New APIs, features and enhancements:++* Allow sending commands in private messages+* Version control support (via Git) for state file+* Nick change event available, and new nick tracker action: changeNick+* New config option, stateRepo, to specify the git repo for state file++Bug fixes:++* (None)++Dependency changes:++* Add json-state+* Require irc-fun-client >= 0.2.0.0++++++irc-fun-bot 0.2.0.0 -- 2015-09-10+=================================++General, build and documentation changes:++* (None)++New APIs, features and enhancements:++* Nickname tracker with control API+* Channel logger with control API+* Persistent state using JSON files+* Bot events logged into a file now, not stdout+* Event sources have access to a logging API+* Support prefix-less bot commands+* Event matching control++Bug fixes:++* (None)++Dependency changes:++* Add aeson+* Add fast-logger+* Add settings+* Add time+* Add time-interval+* Add time-units+* Add unordered-containers+* Require irc-fun-client >= 0.1.1.0++++++irc-fun-bot 0.1.0.0 -- 2015-08-09+=================================++General, build and documentation changes:++* (This is the first release, so everything is new)++New APIs, features and enhancements:++* (This is the first release, so everything is a new feature)++Bug fixes:++* (This is just the first release, many bugs haven't been discovered yet)++Dependency changes:++* (This is the first release)
irc-fun-bot.cabal view
@@ -1,5 +1,5 @@ name: irc-fun-bot-version: 0.5.0.0+version: 0.6.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@@ -21,7 +21,7 @@ copyright: ♡ Copying is an act of love. Please copy, reuse and share. category: Network, IRC build-type: Simple-extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS README.md+extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS.md README.md cabal-version: >=1.10 source-repository head@@ -39,15 +39,16 @@ , Network.IRC.Fun.Bot.Nicks , Network.IRC.Fun.Bot.State , Network.IRC.Fun.Bot.Types- , Network.IRC.Fun.Bot.Util other-modules: Data.Sequence.Util , Network.IRC.Fun.Bot.Internal.Chat , Network.IRC.Fun.Bot.Internal.ChatExt , Network.IRC.Fun.Bot.Internal.Event , Network.IRC.Fun.Bot.Internal.Failure , Network.IRC.Fun.Bot.Internal.History+ , Network.IRC.Fun.Bot.Internal.Instances , Network.IRC.Fun.Bot.Internal.IrcLog , Network.IRC.Fun.Bot.Internal.Logger+ , Network.IRC.Fun.Bot.Internal.Monad , Network.IRC.Fun.Bot.Internal.MsgCount , Network.IRC.Fun.Bot.Internal.Nicks , Network.IRC.Fun.Bot.Internal.Persist@@ -57,16 +58,20 @@ build-depends: aeson , auto-update , base >=4.7 && <5+ , case-insensitive >=1 , clock >=0.5 , containers >=0.5+ , data-default-class , fast-logger- , irc-fun-client >=0.4- , irc-fun-messages >=0.2+ , formatting >=6.2+ , irc-fun-client >=0.5+ , irc-fun-types , json-state+ , text , time , time-interval , time-units- , transformers >=0.4.3+ , transformers >=0.4.2 , unordered-containers hs-source-dirs: src default-language: Haskell2010
src/Network/IRC/Fun/Bot.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -17,8 +17,7 @@ -- just run event source and sink threads in your @main@ function and let them -- handle all the details. module Network.IRC.Fun.Bot- ( defConfig- , runBot+ ( runBot ) where @@ -27,59 +26,28 @@ import Control.Concurrent.MVar import Control.Monad (liftM, forever, void, when) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS (ask) import Data.List (transpose)-import Data.Maybe (fromMaybe, isJust, mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text) import Data.Time.Interval-import Data.Time.Units import Network.IRC.Fun.Bot.Internal.Chat (sendIO) import Network.IRC.Fun.Bot.Internal.Event import Network.IRC.Fun.Bot.Internal.History import Network.IRC.Fun.Bot.Internal.Logger+import Network.IRC.Fun.Bot.Internal.Monad (ask) import Network.IRC.Fun.Bot.Internal.MsgCount import Network.IRC.Fun.Bot.Internal.Types import Network.IRC.Fun.Bot.Chat (login, joinConfig, run)-import Network.IRC.Fun.Bot.Types (Connection (..))+import Network.IRC.Fun.Bot.State (askConfigS) import Network.IRC.Fun.Client.ChannelLogger (fromClientEvent)-import Network.IRC.Fun.Client.Events (hGetIrcEvents, hGetIrcEvents')-import Network.IRC.Fun.Client.IO (hPutIrc)-import Network.IRC.Fun.Messages.Types (Message (PingMessage))+import Network.IRC.Fun.Client.Events (hGetIrcEvents)+import Network.IRC.Fun.Client.IO (connServer, hPutIrc)+import Network.IRC.Fun.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- { cfgConnection = Connection- { connServer = "irc.freenode.net"- , connPort = 6667- , connTls = False -- not supported yet- , connNick = "bot_test_joe"- , connPassword = Nothing- }- , cfgChannels = ["#freepost-bot-test"]- , cfgLogDir = "state/chanlogs"- , cfgStateRepo = Nothing- , cfgStateFile = "state/state.json"- , cfgSaveInterval = time (3 :: Second)- , cfgBotEventLogFile = "state/bot.log"- , cfgIrcErrorLogFile = Nothing- , cfgMaxMsgChars = Nothing- , cfgLagCheck = Just $ time (1 :: Minute)- , cfgLagMax = time (5 :: Minute)- , cfgMaxMsgCount = 1000- , cfgMsgDelay = time (100 :: Millisecond)- }- -- Get the bot ready for listening to IRC messages. startBot :: Session e s () startBot = do@@ -88,12 +56,15 @@ liftIO $ putStrLn "Bot: Joining IRC channels" joinConfig --- Wait for an IRC event, then handle it according to bot behavior definition.+-- Wait for an event, then handle it according to bot behavior definition. -- 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 q handler = do+listenToEvent+ :: (Text -> Session e s ()) -- Log error+ -> (Text -> Session e s ()) -- Log event+ -> Chan (Msg a) -- Chan from which to read events+ -> EventHandler e s a -- Handler for external events+ -> Session e s Bool+listenToEvent elog dlog q handler = do m <- liftIO $ readChan q case m of MsgLogEvent event -> do@@ -118,7 +89,7 @@ handleEvent $ Right event return True MsgExtEvent event -> do- handler event+ handler elog dlog event return True MsgQuit -> return False @@ -128,28 +99,24 @@ -- 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 (Msg a)- -> MVar TimeSpec- -> IO ()+listenToIrc+ :: [EventMatcher e s]+ -> BotEnv e s+ -> Chan (Msg a)+ -> MVar TimeSpec+ -> IO () listenToIrc ms bot chan pongvar = do- logger <-- newLogger- (liftM snd $ beGetTime bot)- (cfgBotEventLogFile $ beConfig bot)- elogger <-- case cfgIrcErrorLogFile $ beConfig bot of- Just path -> fmap Just $ newLogger (liftM snd $ beGetTime bot) path- Nothing -> return Nothing+ let mlogger getfile =+ case getfile $ beConfig bot of+ Just path ->+ fmap Just $ newLogger (fmap snd $ beGetTime bot) path+ Nothing -> return Nothing+ dlogger <- mlogger cfgIrcEventLogFile+ elogger <- mlogger cfgIrcErrorLogFile putStrLn "Bot: IRC event source listening to IRC events" let match e = matchEvent ms e (beConfig bot) (commandSets $ beBehavior bot)- getEvents =- if isJust elogger- then hGetIrcEvents'- else \ h -> liftM (\ es -> ([], es)) $ hGetIrcEvents h loop = do- r <- tryIOError $ getEvents $ beHandle bot+ r <- tryIOError $ hGetIrcEvents $ beConn bot case r of Left e -> do putStrLn "Bot: IRC event listener hGetIrcEvents IO error"@@ -172,10 +139,12 @@ now <- getNow void $ tryTakeMVar pongvar putMVar pongvar now- mapM_ (logLine logger . show) botEvents+ case dlogger of+ Nothing -> return ()+ Just lg -> mapM_ (logLine lg . show) botEvents case elogger of Nothing -> return ()- Just lg -> mapM_ (logLine lg) errs+ Just lg -> mapM_ (logLine lg . show) errs writeList2Chan chan interleaved loop loop@@ -213,7 +182,7 @@ else do let serv = connServer $ cfgConnection $ beConfig bot- hPutIrc (beHandle bot) $ PingMessage serv Nothing+ hPutIrc (beConn bot) $ PingMessage serv Nothing threadDelay $ fromInteger $ microseconds iv loop pong loop =<< getNow@@ -224,13 +193,23 @@ sendMessages bot = do putStrLn "Bot: IRC message sending scheduler thread running" let q = beMsgQueue bot- h = beHandle bot+ c = beConn bot delay = fromInteger $ microseconds $ cfgMsgDelay $ beConfig bot forever $ do msg <- readChan q- sendIO h msg+ sendIO c msg threadDelay delay +-- Create a logging function from an optional log file path.+mkLog :: (Config -> Maybe FilePath) -> Session e s (Text -> Session e s ())+mkLog getfile = do+ mfile <- askConfigS getfile+ case mfile of+ Nothing -> return $ const $ return ()+ Just file -> do+ logger <- newLogger' file+ return $ liftIO . logLine logger+ -- Connect, login, join. Then listen to events and handle them, forever. botSession :: [EventMatcher e s] -> [EventSource e s a]@@ -242,6 +221,8 @@ chan <- liftIO newChan bot <- ask pongvar <- liftIO newEmptyMVar+ elog <- mkLog cfgExtErrorLogFile+ dlog <- mkLog cfgExtEventLogFile liftIO $ void $ forkIO $ sendMessages bot liftIO $ void $ forkIO $ listenToIrc matchers bot chan pongvar liftIO $ void $ forkIO $ manageLag bot chan pongvar@@ -253,8 +234,9 @@ liftIO $ mapM_ launch sources startBot liftIO $ putStrLn "Bot: Event sink listening to events"- let loop = do- proceed <- listenToEvent chan handler+ let listen = listenToEvent elog dlog+ loop = do+ proceed <- listen chan handler if proceed then loop else liftIO $ putStrLn "Bot: Event sink asked to stop"
src/Network/IRC/Fun/Bot/Behavior.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -18,48 +18,21 @@ -- commands and bot features may benefit from having this module available to -- them (e.g. a bot's help system). module Network.IRC.Fun.Bot.Behavior- ( -- * Defining- defaultBehavior- -- * Searching- , findCmdInSet+ ( -- * Searching+ findCmdInSet , findCmdInSets , findCmd , findSet , searchCmds- -- * Showing- , listNames- , listPrimaryNames ) where -import Data.Char (toLower)-import Data.List (find, isInfixOf)+import Data.List (find)+import Data.Text (Text) import Network.IRC.Fun.Bot.Types-import Network.IRC.Fun.Bot.Util (showNames) ----------------------------------------------------------------------------------- Defining------------------------------------------------------------------------------------ | A default behavior definition which be convenienty overridden and extended--- using record syntax. It currently simply doesn't do anything (pings do get--- handled behind the scenes), but things like default responses and logging--- could be added in the future.-defaultBehavior :: Behavior e s-defaultBehavior = Behavior- { handleJoin = \ _ _ -> return ()- , handlePart = \ _ _ _ -> return ()- , handleQuit = \ _ _ -> return ()- , handleMsg = \ _ _ _ _ -> return ()- , handleAction = \ _ _ _ _ -> return ()- , handleBotMsg = \ _ _ _ _ -> return ()- , commandSets = []- , handlePersonalMsg = \ _ _ -> return ()- , handlePersonalAction = \ _ _ -> return ()- , handleNickChange = \ _ _ -> return ()- , handleTopicChange = \ _ _ _ -> return ()- , handleNames = \ _ _ _ -> return ()- }+import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T ------------------------------------------------------------------------------- -- Searching@@ -68,13 +41,13 @@ -- | Take a command name (without prefix) and a command set, and return the -- (leftmost) command which has that name, or 'Nothing' if there is no such -- command.-findCmdInSet :: String -> CommandSet e s -> Maybe (Command e s)+findCmdInSet :: CommandName -> CommandSet e s -> Maybe (Command e s) 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 -- matched command set (for the cases you only need to find the command).-findCmdInSets :: Char -> String -> [CommandSet e s] -> Maybe (Command e s)+findCmdInSets :: Char -> CommandName -> [CommandSet e s] -> Maybe (Command e s) findCmdInSets cpref cname sets = case findCmd cpref cname sets of Just (Right cmd) -> Just cmd@@ -85,7 +58,7 @@ -- the prefix is matched but the command isn't, 'Just' 'Left' the command set -- is returned. Otherwise, 'Just' 'Right' the matched command is returned. findCmd :: Char -- ^ Command prefix to search for- -> String -- ^ Command name to search for+ -> CommandName -- ^ Command name to search for -> [CommandSet e s] -- ^ Command set in which to search -> Maybe (Either (CommandSet e s) (Command e s)) findCmd cpref cname sets =@@ -104,35 +77,13 @@ -- | Search for commands by testing a search string against their textual -- fields: Names and help strings. Each returned pair is a command and the -- prefix under which it was found.-searchCmds :: String -> [CommandSet e s] -> [(Char, Command e s)]-searchCmds search = concatMap (f $ lower search)+searchCmds :: Text -> [CommandSet e s] -> [(Char, Command e s)]+searchCmds search = concatMap (f $ T.toCaseFold search) where- lower = map toLower- match s cmd = any (s `isInfixOf`) (map lower $ cmdNames cmd)- || s `isInfixOf` (lower $ cmdHelp cmd)+ match t cmd =+ any+ (t `T.isInfixOf`)+ (map (CI.foldedCase . unCommandName) $ cmdNames cmd)+ ||+ t `T.isInfixOf` (T.toCaseFold $ cmdHelp cmd) f s cset = [(csetPrefix cset, cmd) | cmd <- csetCommands cset, match s cmd]------------------------------------------------------------------------------------ Showing------------------------------------------------------------------------------------ | Format a list of command names.-listNames :: Maybe Char -- ^ Optionally prepend the prefix char to names- -> Maybe Quotes -- ^ Optionally add quotes around the names- -> Bool -- ^ Whether to separate with commas (otherwise- -- spaces)- -> [String] -- ^ List of command names- -> String-listNames pref qs comma =- showNames qs (if comma then ", " else " ") . maybe id (map . (:)) pref---- | Format a list of the primary names of the given commands.-listPrimaryNames :: Maybe Char -- ^ Optionally prepend the prefix char to- -- names- -> Maybe Quotes -- ^ Optionally add quotes around the names- -> Bool -- ^ Whether to separate with commas- -- (otherwise spaces)- -> [Command e s] -- ^ List of commands- -> String-listPrimaryNames pref qs comma =- listNames pref qs comma . map (head . cmdNames)
src/Network/IRC/Fun/Bot/Chat.hs view
@@ -33,8 +33,13 @@ , partAll -- * Sending Messages , sendToChannel+ , sendToChannel'+ , sendToChannelNow , sendToUser+ , sendToUser'+ , sendToUserNow , sendBack+ , sendBackNow , failToChannel , failToUser , failBack
src/Network/IRC/Fun/Bot/EventMatch.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -
src/Network/IRC/Fun/Bot/Internal/Chat.hs view
@@ -28,8 +28,10 @@ , partAll , sendIO , sendToUser+ , sendToUser' , sendToUserNow , sendToChannel+ , sendToChannel' , sendToChannelNow , sendBack , sendBackNow@@ -41,10 +43,11 @@ import Control.Exception (bracket) import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS (asks, gets, runRWST) import Data.Char (isSpace) import Data.List (union)+import Data.Text (Text) import Network.IRC.Fun.Bot.Internal.History (rememberMsg)+import Network.IRC.Fun.Bot.Internal.Monad import Network.IRC.Fun.Bot.Internal.MsgCount (recordMsg) import Network.IRC.Fun.Bot.Internal.Persist import Network.IRC.Fun.Bot.Internal.State@@ -53,11 +56,12 @@ import Network.IRC.Fun.Client.Commands import Network.IRC.Fun.Client.IO import Network.IRC.Fun.Client.Time (currentTimeGetter)-import Network.IRC.Fun.Messages.Types (Message)+import Network.IRC.Fun.Types import System.Clock import qualified Data.HashMap.Lazy as M (lookup) import qualified Data.HashSet as S (toList)+import qualified Data.Text as T ------------------------------------------------------------------------------- -- Connection Management@@ -70,7 +74,7 @@ -- -- After disconnection, make sure not to send more IRC commands. disconnect :: Session e s ()-disconnect = askHandle >>= liftIO . ircDisconnect+disconnect = askConnection >>= liftIO . ircDisconnect -- Disconnect from the IRC server and connect again. This includes -- identifying with the bot's nickname and joining IRC channels.@@ -81,22 +85,16 @@ -- disconnect -- | Finish the IRC session, asking the server to close the connection.-quit :: Maybe String -- ^ Optional message, e.g. the reason for quitting+quit :: Maybe Comment -- ^ Optional message, e.g. the reason for quitting -> Session e s () quit reason = do- h <- askHandle- liftIO $ ircQuit h reason+ c <- askConnection+ liftIO $ ircQuit c reason ------------------------------------------------------------------------------- -- Session Management ------------------------------------------------------------------------------- --- Run a bot session computation-runSession :: BotEnv e s -> BotState s -> Session e s a -> IO a-runSession bot state session = do- (a, _, _) <- runRWST session bot state- return a- -- | Connect to an IRC server and run the bot session run :: Config -- ^ IRC configuration -> Behavior e s -- ^ Bot behavior definition@@ -109,12 +107,14 @@ save <- mkSaveBotState conf getMin <- mkAutoUpdate defaultUpdateSettings { updateFreq = 1000000 * 60 -- 60 seconds- , updateAction = liftM ((`div` 60) . sec) $ getTime Realtime+ , updateAction = fmap ((`div` 60) . sec) $ getTime Realtime } mq <- newChan putStrLn "Bot: Connecting to IRC server" bracket- (ircConnect $ cfgConnection conf)+ (do ctx <- initConnContext+ ircConnect ctx (cfgConnection conf)+ ) ircDisconnect (\ h -> do let botEnv = BotEnv conf beh h timeGetter getMin save mq env@@ -127,9 +127,9 @@ -- This is the first thing to do after 'botConnect'ing to the server. login :: Session e s () login = do- h <- askHandle- conn <- askConfigS cfgConnection- liftIO $ ircLogin h conn False False+ c <- askConnection+ cfg <- askConfigS cfgConnection+ liftIO $ ircLogin c cfg False False -- | IRC servers send PING messages at regular intervals to test the presence -- of an active client, at least if no other activity is detected on the@@ -139,31 +139,33 @@ -- 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- -> Maybe String -- ^ Optional server to forward to+pong :: Hostname -- ^ Server name+ -> Maybe Hostname -- ^ Optional server to forward to -> Session e s () pong server1 mserver2 = do- h <- askHandle- liftIO $ ircPong h server1 mserver2+ c <- askConnection+ liftIO $ ircPong c server1 mserver2 ------------------------------------------------------------------------------- -- Channels ------------------------------------------------------------------------------- -- | Join an IRC channel.-joinChannel :: String -- ^ Channel name- -> Maybe String -- ^ Optional channel key (password)- -> Session e s ()+joinChannel+ :: Channel -- ^ Channel name+ -> Maybe ChannelKey -- ^ Optional channel key (password)+ -> Session e s () joinChannel channel key = do- h <- askHandle- liftIO $ ircJoin h channel key+ c <- askConnection+ liftIO $ ircJoin c channel key -- | Join one or more IRC channels.-joinMulti :: [(String, Maybe String)] -- ^ List of channels and optional keys- -> Session e s ()+joinMulti+ :: [(Channel, Maybe ChannelKey)] -- ^ List of channels and optional keys+ -> Session e s () joinMulti channels = do- h <- askHandle- liftIO $ ircJoinMulti h channels+ c <- askConnection+ liftIO $ ircJoinMulti c channels -- | Join the IRC channels listed for joining in the persistent state and in -- the configuration, without leaving any other channels the bot already@@ -177,120 +179,135 @@ --TODO avoid unnecessary JOINs? -- | Leave an IRC channel.-partChannel :: String -- ^ Channel name- -> Maybe String -- ^ Optional part message, e.g. the reason for- -- leaving- -> Session e s ()+partChannel+ :: Channel -- ^ Channel name+ -> Maybe Comment -- ^ Optional part message, e.g. the reason for leaving+ -> Session e s () partChannel channel reason = do- h <- askHandle- liftIO $ ircPart h channel reason+ c <- askConnection+ liftIO $ ircPart c channel reason removeCurrChan channel -- | Leave one or more IRC channels.-partMulti :: [String] -- ^ List of channel names- -> Maybe String -- ^ Optional part message, e.g. the reason for- -- leaving- -> Session e s ()+partMulti+ :: [Channel] -- ^ List of channel names+ -> Maybe Comment -- ^ Optional part message, e.g. the reason for leaving+ -> Session e s () partMulti chans reason = do- h <- askHandle- liftIO $ ircPartMulti h chans reason+ c <- askConnection+ liftIO $ ircPartMulti c chans reason -- | Leave all IRC channels the bot joined. partAll :: Session e s () partAll = do- askHandle >>= liftIO . ircPartAll+ askConnection >>= 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 string into N-sized substrings, dropping surrounding whitespace. The+-- last substring may be shorter than N.+splitN :: Int -> Text -> [Text]+splitN n t =+ let (l, r) = T.splitAt n t+ in if T.null r+ then [l]+ else l : splitN n (T.dropWhile isSpace r) -- Split a message by newlines and possibly length.-makeLines :: String -> Session e s [String]+makeLines :: MsgContent -> Session e s [MsgContent] makeLines msg = do- let ls = lines msg+ let ls = T.lines $ unMsgContent msg maybelen <- askConfigS cfgMaxMsgChars- case maybelen of- Nothing -> return ls- Just maxlen -> return $ concatMap (splitN maxlen) ls+ return $ map MsgContent $ case maybelen of+ Nothing -> ls+ Just maxlen -> concatMap (splitN maxlen) ls -- Log a channel message event.-logChanMsg :: String -> String -> String -> Session e s ()+logChanMsg :: Nickname -> Channel -> MsgContent -> Session e s () logChanMsg nick chan msg = do cstates <- gets bsChannels case M.lookup chan cstates >>= csLogger of Nothing -> return () Just lg -> liftIO $ logEvent lg (MessageChan nick msg) -sendToChannelIO :: Handle -> String -> [String] -> IO ()-sendToChannelIO h chan = mapM_ $ ircSendToChannel h chan+sendC :: Bool -> Connection -> Channel -> MsgContent -> IO ()+sendC True = ircNoticeToChannel+sendC False = ircSendToChannel -sendToUserIO :: Handle -> String -> [String] -> IO ()-sendToUserIO h nick = mapM_ $ ircSendToUser h nick+sendU :: Bool -> Connection -> Nickname -> MsgContent -> IO ()+sendU True = ircNoticeToUser+sendU False = ircSendToUser -sendIO :: Handle -> IrcMsg -> IO ()-sendIO h msg =+sendToChannelIO :: Connection -> Bool -> Channel -> [MsgContent] -> IO ()+sendToChannelIO c notice chan = mapM_ $ (sendC notice) c chan++sendToUserIO :: Connection -> Bool -> Nickname -> [MsgContent] -> IO ()+sendToUserIO c notice nick = mapM_ $ (sendU notice) c nick++sendIO :: Connection -> IrcMsg -> IO ()+sendIO c msg = case msgRecip msg of- Left nick -> sendToUserIO h nick $ msgLines msg- Right chan -> sendToChannelIO h chan $ msgLines msg+ Left nick -> sendToUserIO c (msgNotice msg) nick $ msgLines msg+ Right chan -> sendToChannelIO c (msgNotice msg) chan $ msgLines msg -sendToChannelHere :: String -> [String] -> Session e s ()-sendToChannelHere chan lines = do- h <- askHandle- liftIO $ sendToChannelIO h chan lines+sendToChannelHere :: Bool -> Channel -> [MsgContent] -> Session e s ()+sendToChannelHere notice chan ls = do+ c <- askConnection+ liftIO $ sendToChannelIO c notice chan ls -sendToUserHere :: String -> [String] -> Session e s ()-sendToUserHere nick lines = do- h <- askHandle- liftIO $ sendToUserIO h nick lines+sendToUserHere :: Bool -> Nickname -> [MsgContent] -> Session e s ()+sendToUserHere notice nick ls = do+ c <- askConnection+ liftIO $ sendToUserIO c notice nick ls -sendToChannelDefer :: String -> [String] -> Session e s ()-sendToChannelDefer chan lines = do+sendToChannelDefer :: Bool -> Channel -> [MsgContent] -> Session e s ()+sendToChannelDefer notice chan ls = do q <- asks beMsgQueue let msg = IrcMsg- { msgRecip = Right chan- , msgLines = lines+ { msgRecip = Right chan+ , msgLines = ls+ , msgNotice = notice } liftIO $ writeChan q msg -sendToUserDefer :: String -> [String] -> Session e s ()-sendToUserDefer nick lines = do+sendToUserDefer :: Bool -> Nickname -> [MsgContent] -> Session e s ()+sendToUserDefer notice nick ls = do q <- asks beMsgQueue let msg = IrcMsg- { msgRecip = Left nick- , msgLines = lines+ { msgRecip = Left nick+ , msgLines = ls+ , msgNotice = notice } liftIO $ writeChan q msg -sendToChannelImpl :: (String -> [String] -> Session e s ())- -> String- -> String- -> Session e s ()-sendToChannelImpl send chan msg = do+sendToChannelImpl+ :: (Bool -> Channel -> [MsgContent] -> Session e s ())+ -> Bool+ -> Channel+ -> MsgContent+ -> Session e s ()+sendToChannelImpl send notice chan msg = do msgs <- makeLines msg- send chan msgs- self <- askConfigS $ connNick . cfgConnection+ send notice chan msgs+ self <- askConfigS $ connNickname . cfgConnection let remember s = do rememberMsg chan self s False recordMsg chan logChanMsg self chan s mapM_ remember msgs -sendToUserImpl :: (String -> [String] -> Session e s ())- -> String- -> String- -> Session e s ()-sendToUserImpl send nick msg = do+sendToUserImpl+ :: (Bool -> Nickname -> [MsgContent] -> Session e s ())+ -> Bool+ -> Nickname+ -> MsgContent+ -> Session e s ()+sendToUserImpl send notice nick msg = do msgs <- makeLines msg- send nick msgs+ send notice nick msgs -- | Send a message to an IRC channel. --@@ -302,60 +319,91 @@ -- sending by the sending scheduler thread, which adds delay to avoid flood. If -- you want to send instantly, see 'sendToChannelNow'. sendToChannel- :: String -- ^ The channel name- -> String -- ^ The message to send. It may contain newlines, in which case- -- it will be split into multiple messages and sent sequentially.+ :: Channel+ -- ^ The channel name+ -> MsgContent+ -- ^ The message to send. It may contain newlines, in which case it will be+ -- split into multiple messages and sent sequentially. -> Session e s ()-sendToChannel = sendToChannelImpl sendToChannelDefer+sendToChannel = sendToChannel' False +-- | Like 'sendToChannel', but lets you choose whether the message should be a+-- notice.+sendToChannel'+ :: Bool+ -> Channel+ -> MsgContent+ -> Session e s ()+sendToChannel' = sendToChannelImpl sendToChannelDefer+ -- | A variant of 'sendToChannel' which sends instantly, without any delay. sendToChannelNow- :: String -- ^ The channel name- -> String -- ^ The message to send. It may contain newlines, in which case- -- it will be split into multiple messages and sent sequentially.+ :: Channel+ -- ^ The channel name+ -> MsgContent+ -- ^ The message to send. It may contain newlines, in which case it will be+ -- split into multiple messages and sent sequentially. -> Session e s ()-sendToChannelNow = sendToChannelImpl sendToChannelHere+sendToChannelNow = sendToChannelImpl sendToChannelHere False -- | Send a private message to an IRC user. -- -- This function doesn't instantly send the message, but instead queues it for -- sending by the sending scheduler thread, which adds delay to avoid flood. If -- you want to send instantly, see 'sendToUserNow'.-sendToUser :: String -- ^ The user's nickname- -> String -- ^ The message to send. It may contain newlines, in- -- which case it will be split into multiple messages- -- and sent sequentially.- -> Session e s ()-sendToUser = sendToUserImpl sendToUserDefer+sendToUser+ :: Nickname+ -- ^ The user's nickname+ -> MsgContent+ -- ^ The message to send. It may contain newlines, in which case it will be+ -- split into multiple messages and sent sequentially.+ -> Session e s ()+sendToUser = sendToUser' False +-- | Like 'sendToUser', but lets you choose whether the message should be a+-- notice.+sendToUser'+ :: Bool+ -> Nickname+ -> MsgContent+ -> Session e s ()+sendToUser' = sendToUserImpl sendToUserDefer+ -- | A variant of 'sendToUser' which sends instantly, without any delay.-sendToUserNow :: String -- ^ The user's nickname- -> String -- ^ The message to send. It may contain newlines, in- -- which case it will be split into multiple messages- -- and sent sequentially.- -> Session e s ()-sendToUserNow = sendToUserImpl sendToUserHere+sendToUserNow+ :: Nickname+ -- ^ The user's nickname+ -> MsgContent+ -- ^ The message to send. It may contain newlines, in which case it will be+ -- split into multiple messages and sent sequentially.+ -> Session e s ()+sendToUserNow = sendToUserImpl sendToUserHere False -- | Send a message back to the sender. If a channel is specified, send to the -- channel. If not, send a private message.-sendBack :: Maybe String -- ^ Channel name, specify if replying to a message- -- sent in a channel. Otherwise pass 'Nothing'.- -> String -- ^ The sender user's nickname- -> String -- ^ The message to send. It may contain newlines, in- -- which case it will be split into multiple- -- messages and sent sequentially.- -> Session e s ()+sendBack+ :: Maybe Channel+ -- ^ Channel name, specify if replying to a message sent in a channel.+ -- Otherwise pass 'Nothing'.+ -> Nickname+ -- ^ The sender user's nickname+ -> MsgContent+ -- ^ The message to send. It may contain newlines, in which case it will be+ -- split into multiple messages and sent sequentially.+ -> Session e s () sendBack (Just chan) _nick msg = sendToChannel chan msg sendBack Nothing nick msg = sendToUser nick msg -- | A variant of 'sendBack' which sends instantly, without any delay. sendBackNow- :: Maybe String -- ^ Channel name, specify if replying to a message sent in- -- a channel. Otherwise pass 'Nothing'.- -> String -- ^ The sender user's nickname- -> String -- ^ The message to send. It may contain newlines, in which- -- case it will be split into multiple messages and sent- -- sequentially.+ :: Maybe Channel+ -- ^ Channel name, specify if replying to a message sent in a channel.+ -- Otherwise pass 'Nothing'.+ -> Nickname+ -- ^ The sender user's nickname+ -> MsgContent+ -- ^ The message to send. It may contain newlines, in which case it will be+ -- split into multiple messages and sent sequentially. -> Session e s () sendBackNow (Just chan) _nick msg = sendToChannelNow chan msg sendBackNow Nothing nick msg = sendToUserNow nick msg
src/Network/IRC/Fun/Bot/Internal/ChatExt.hs view
@@ -18,17 +18,16 @@ ) where - import Control.Monad.IO.Class (liftIO)-import Network.IRC.Fun.Bot.Internal.State (askHandle)+import Network.IRC.Fun.Bot.Internal.State (askConnection) import Network.IRC.Fun.Bot.Internal.Types (Session) import Network.IRC.Fun.Client.IO (hPutIrc)-import Network.IRC.Fun.Messages.Types (Message)+import Network.IRC.Fun.Types (Message) -- | Send an IRC message to the server. This should only be used if the other -- wrappers don't provide what you need. If that's the case, it may be a good -- idea for reusability to add a new wrapper. putIrc :: Message -> Session e s () putIrc msg = do- h <- askHandle- liftIO $ hPutIrc h msg+ c <- askConnection+ liftIO $ hPutIrc c msg
src/Network/IRC/Fun/Bot/Internal/Event.hs view
@@ -13,6 +13,8 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} +{-# LANGUAGE OverloadedStrings #-}+ module Network.IRC.Fun.Bot.Internal.Event ( modId , modPrefix@@ -38,21 +40,25 @@ import Control.Monad (when) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS-import Data.Char (isSpace, toLower)+import Data.Char (isSpace) import Data.Maybe-import Data.List (find, stripPrefix)+import Data.List (find)+import Data.Text (Text) import Network.IRC.Fun.Bot.Internal.Chat (pong, sendBack) import Network.IRC.Fun.Bot.Internal.Failure+import Network.IRC.Fun.Bot.Internal.Monad (gets) 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 (connNick)+import Network.IRC.Fun.Client.IO (connNickname) import Network.IRC.Fun.Client.Util (mentions)+import Network.IRC.Fun.Types hiding (Command) +import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Lazy as M+import qualified Data.Text as T import qualified Network.IRC.Fun.Client.ChannelLogger as L import qualified Network.IRC.Fun.Client.Events as C (Event (..)) @@ -60,118 +66,120 @@ -- Modifiers ------------------------------------------------------------------------------- -modId :: String -> String+modId :: Text -> Text modId = id -modPrefix :: String -> Bool -> String -> String+modPrefix :: Text -> Bool -> Text -> Text modPrefix p d s =- case stripPrefix p s of- Just s' -> if d then dropWhile isSpace s' else s'+ case T.stripPrefix p s of+ Just s' -> if d then T.stripStart s' else s' Nothing -> s -modPrefixes :: [String] -> Bool -> String -> String+modPrefixes :: [Text] -> Bool -> Text -> Text modPrefixes ps d s =- case listToMaybe $ mapMaybe (flip stripPrefix s) ps of- Just s' -> if d then dropWhile isSpace s' else s'+ case listToMaybe $ mapMaybe (flip T.stripPrefix s) ps of+ Just s' -> if d then T.stripStart 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+stripPrefixCI :: Text -> Text -> Maybe Text+stripPrefixCI pref t =+ let len = T.length pref+ (p, r) = T.splitAt len t+ in if T.toCaseFold p == T.toCaseFold pref+ then Just r+ else Nothing -modPrefixCI :: String -> Bool -> String -> String+modPrefixCI :: Text -> Bool -> Text -> Text modPrefixCI p d s = case stripPrefixCI p s of- Just s' -> if d then dropWhile isSpace s' else s'+ Just s' -> if d then T.stripStart s' else s' Nothing -> s -modPrefixesCI :: [String] -> Bool -> String -> String+modPrefixesCI :: [Text] -> Bool -> Text -> Text modPrefixesCI ps d s = case listToMaybe $ mapMaybe (flip stripPrefixCI s) ps of- Just s' -> if d then dropWhile isSpace s' else s'+ Just s' -> if d then T.stripStart s' else s' Nothing -> s -modPleasePrefix :: String -> String+modPleasePrefix :: Text -> Text modPleasePrefix = modPrefixCI "please" True -modPleasePrefix' :: String -> String+modPleasePrefix' :: Text -> Text modPleasePrefix' = modPrefixesCI ["please", "plz", "pls"] True ------------------------------------------------------------------------------- -- Make Events ------------------------------------------------------------------------------- -detectRef :: Config -> String -> Maybe String+detectRef :: Config -> MsgContent -> Maybe MsgContent detectRef conf msg =- let bnick = connNick (cfgConnection conf)- dw = Just . dropWhile isSpace- in case stripPrefix bnick msg of+ let bnick = unNickname $ connNickname (cfgConnection conf)+ dw = Just . MsgContent . T.stripStart+ in case T.stripPrefix bnick (unMsgContent msg) >>= T.uncons of Nothing -> Nothing- Just (',' : s) -> dw s- Just (':' : s) -> dw s- Just (';' : s) -> dw s- Just (c : s) -> if isSpace c then dw s else Nothing- Just s -> dw s+ Just (',', s) -> dw s+ Just (':', s) -> dw s+ Just (';', s) -> dw s+ Just (c, s) -> if isSpace c then dw s else Nothing -mkCmd :: String -> (String, [String])+mkCmd :: MsgContent -> (CommandName, [Text]) mkCmd message =- let w = words message- name = if null w then "" else head w+ let w = T.words $ unMsgContent message+ name = CommandName $ CI.mk $ if null w then T.empty else head w args = if null w then [] else tail w in (name, args) -expand :: [String] -> Maybe (CommandSet e s) -> [String]+expand :: [CommandName] -> Maybe (CommandSet e s) -> [CommandName] 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 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')+makePrefixedCommand+ :: Maybe Config+ -> [CommandSet e s]+ -> MessageSource+ -> Char+ -> MsgContent+ -> Maybe Event+makePrefixedCommand mconf csets src pref (MsgContent msg) =+ let (pref', msg') = fromMaybe (pref, msg) $ do+ conf <- mconf+ rest <- detectRef conf (MsgContent $ pref `T.cons` msg)+ T.uncons $ unMsgContent rest+ in if pref' `elem` map csetPrefix csets && not (T.null msg') then- let (name, args) = mkCmd msg'+ let (name, args) = mkCmd $ MsgContent msg' in Just $ BotCommand src (Just pref') name args else Nothing -makePrefixedCommandFromSet :: Maybe Config- -> CommandSet e s- -> MessageSource- -> Char- -> String- -> Maybe Event+makePrefixedCommandFromSet+ :: Maybe Config+ -> CommandSet e s+ -> MessageSource+ -> Char+ -> MsgContent+ -> 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')+makePrefixedCommandFromNames+ :: Maybe Config+ -> Either Char (CommandSet e s)+ -> [CommandName]+ -> MessageSource+ -> Char+ -> MsgContent+ -> Maybe Event+makePrefixedCommandFromNames mconf eith names src pref (MsgContent msg) =+ let (pref', msg') = fromMaybe (pref, msg) $ do+ conf <- mconf+ rest <- detectRef conf $ MsgContent $ pref `T.cons` msg+ T.uncons $ unMsgContent rest+ in if pref' == either id csetPrefix eith && not (T.null msg') then- let (name, args) = mkCmd msg'+ let (name, args) = mkCmd $ MsgContent msg' cset = either (const Nothing) Just eith in if name `elem` expand names cset then Just $ BotCommand src (Just pref') name args@@ -180,21 +188,21 @@ makeRefCommand :: Config -> MessageSource- -> (String -> String)- -> String+ -> (Text -> Text)+ -> MsgContent -> Maybe Event makeRefCommand conf src f msg = case detectRef conf msg of- Just s ->- let (name, args) = mkCmd $ f s+ Just (MsgContent s) ->+ let (name, args) = mkCmd $ MsgContent $ f s in Just $ BotCommand src Nothing name args Nothing -> Nothing makeRefCommandFromSet :: Config -> CommandSet e s -> MessageSource- -> (String -> String)- -> String+ -> (Text -> Text)+ -> MsgContent -> Maybe Event makeRefCommandFromSet conf cset = let names = concatMap cmdNames $ csetCommands cset@@ -202,34 +210,34 @@ makeRefCommandFromNames :: Config -> Maybe (CommandSet e s)- -> [String]+ -> [CommandName] -> MessageSource- -> (String -> String)- -> String+ -> (Text -> Text)+ -> MsgContent -> Maybe Event makeRefCommandFromNames conf cset names src f msg = case detectRef conf msg of- Just s ->- let (name, args) = mkCmd $ f s+ Just (MsgContent s) ->+ let (name, args) = mkCmd $ MsgContent $ f s in if name `elem` expand names cset then Just $ BotCommand src Nothing name args else Nothing Nothing -> Nothing makePlainCommand :: MessageSource- -> String+ -> MsgContent -> Maybe Event makePlainCommand src msg = let (name, args) = mkCmd msg in Just $ BotCommand src Nothing name args -makeRefC :: Config -> String -> String -> String -> Maybe Event+makeRefC :: Config -> Channel -> Nickname -> MsgContent -> Maybe Event makeRefC conf chan nick msg = case detectRef conf msg of Just s -> Just $ BotMessage chan nick s msg Nothing -> Nothing -makeRefP :: Config -> String -> String -> Maybe Event+makeRefP :: Config -> Nickname -> MsgContent -> Maybe Event makeRefP conf nick msg = case detectRef conf msg of Just s -> Just $ PersonalMessage nick s@@ -247,93 +255,104 @@ ifChan MatchInPrivate _ = Nothing ifChan _ e = e -matchPrefixedCommand :: EventMatchSpace- -> Bool- -> EventMatcher e s+unconsMsg :: MsgContent -> Maybe (Char, MsgContent)+unconsMsg msg =+ case T.uncons $ unMsgContent msg of+ Nothing -> Nothing+ Just (c, t) -> Just (c, MsgContent t)++matchPrefixedCommand+ :: EventMatchSpace+ -> Bool+ -> EventMatcher e s matchPrefixedCommand space ref event conf csets = case event of- C.ChannelMessage chan nick (c:cs) False ->- ifChan space $- makePrefixedCommand mconf csets (Channel chan nick) c cs- C.PrivateMessage nick (c:cs) False ->- ifPriv space $- makePrefixedCommand mconf csets (User nick) c cs+ C.ChannelMessage chan nick msg False -> ifChan space $ do+ (c, t) <- unconsMsg msg+ makePrefixedCommand mconf csets (SrcChannel chan nick) c t+ C.PrivateMessage nick msg False -> ifPriv space $ do+ (c, t) <- unconsMsg msg+ makePrefixedCommand mconf csets (SrcUser nick) c t _ -> Nothing where mconf = if ref then Just conf else Nothing -matchPrefixedCommandFromSet :: EventMatchSpace- -> Bool- -> Maybe (CommandSet e s)- -> EventMatcher e s+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 $+ C.ChannelMessage chan nick msg False -> ifChan space $ do+ (c, t) <- unconsMsg msg makePrefixedCommandFromSet- mconf cset (Channel chan nick) c cs- C.PrivateMessage nick (c:cs) False ->- ifPriv space $+ mconf cset (SrcChannel chan nick) c t+ C.PrivateMessage nick msg False -> ifPriv space $ do+ (c, t) <- unconsMsg msg makePrefixedCommandFromSet- mconf cset (User nick) c cs+ mconf cset (SrcUser nick) c t _ -> Nothing where mconf = if ref then Just conf else Nothing -matchPrefixedCommandFromNames :: EventMatchSpace- -> Bool- -> Either Char (CommandSet e s)- -> [String]- -> EventMatcher e s-matchPrefixedCommandFromNames space ref eith names event conf csets =+matchPrefixedCommandFromNames+ :: EventMatchSpace+ -> Bool+ -> Either Char (CommandSet e s)+ -> [CommandName]+ -> EventMatcher e s+matchPrefixedCommandFromNames space ref eith names event conf _csets = case event of- C.ChannelMessage chan nick (c:cs) False ->- ifChan space $+ C.ChannelMessage chan nick msg False -> ifChan space $ do+ (c, t) <- unconsMsg msg makePrefixedCommandFromNames- mconf eith names (Channel chan nick) c cs- C.PrivateMessage nick (c:cs) False ->- ifPriv space $+ mconf eith names (SrcChannel chan nick) c t+ C.PrivateMessage nick msg False -> ifPriv space $ do+ (c, t) <- unconsMsg msg makePrefixedCommandFromNames- mconf eith names (User nick) c cs+ mconf eith names (SrcUser nick) c t _ -> Nothing where mconf = if ref then Just conf else Nothing -matchRefCommand :: EventMatchSpace -> (String -> String) -> EventMatcher e s+matchRefCommand :: EventMatchSpace -> (Text -> Text) -> EventMatcher e s matchRefCommand space f event conf _csets = case event of C.ChannelMessage chan nick msg False ->- ifChan space $ makeRefCommand conf (Channel chan nick) f msg+ ifChan space $ makeRefCommand conf (SrcChannel chan nick) f msg C.PrivateMessage nick msg False ->- ifPriv space $ makeRefCommand conf (User nick) f msg+ ifPriv space $ makeRefCommand conf (SrcUser nick) f msg _ -> Nothing -matchRefCommandFromSet :: EventMatchSpace- -> (String -> String)- -> EventMatcher e s+matchRefCommandFromSet+ :: EventMatchSpace+ -> (Text -> Text)+ -> EventMatcher e s matchRefCommandFromSet _ _ _ _ [] = Nothing matchRefCommandFromSet space f event conf (cset:_) = case event of C.ChannelMessage chan nick msg False -> ifChan space $- makeRefCommandFromSet conf cset (Channel chan nick) f msg+ makeRefCommandFromSet conf cset (SrcChannel chan nick) f msg C.PrivateMessage nick msg False -> ifPriv space $- makeRefCommandFromSet conf cset (User nick) f msg+ makeRefCommandFromSet conf cset (SrcUser nick) f msg _ -> Nothing -matchRefCommandFromNames :: EventMatchSpace- -> (String -> String)- -> Bool- -> [String]- -> EventMatcher e s+matchRefCommandFromNames+ :: EventMatchSpace+ -> (Text -> Text)+ -> Bool+ -> [CommandName]+ -> EventMatcher e s matchRefCommandFromNames space f ex names event conf csets = case event of C.ChannelMessage chan nick msg False -> ifChan space $- makeRefCommandFromNames conf cset names (Channel chan nick) f msg+ makeRefCommandFromNames conf cset names (SrcChannel chan nick) f msg C.PrivateMessage nick msg False -> ifPriv space $- makeRefCommandFromNames conf cset names (User nick) f msg+ makeRefCommandFromNames conf cset names (SrcUser nick) f msg _ -> Nothing where cset = if ex then listToMaybe csets else Nothing@@ -342,7 +361,7 @@ matchPlainPrivateCommand event _conf _csets = case event of C.PrivateMessage nick msg False ->- makePlainCommand (User nick) msg+ makePlainCommand (SrcUser nick) msg _ -> Nothing matchNotice :: EventMatchSpace -> EventMatcher e s@@ -364,7 +383,7 @@ _ -> Nothing defaultMatch :: EventMatcher e s-defaultMatch event conf csets =+defaultMatch event conf _csets = case event of C.Ping server1 server2 -> Just $ Ping server1 server2 C.Kick channel nicks reason -> Just $ Kick channel nicks reason@@ -382,7 +401,7 @@ C.Names priv chan pnicks -> Just $ Names chan priv pnicks _ -> Nothing where- bnick = connNick (cfgConnection conf)+ bnick = connNickname (cfgConnection conf) combineMatchers :: [EventMatcher e s] -> EventMatcher e s combineMatchers [] _event _conf _csets = Nothing@@ -391,25 +410,29 @@ ev@(Just _) -> ev Nothing -> combineMatchers ms event conf csets -applyMatchers :: [EventMatcher e s]- -> C.Event- -> Config- -> [CommandSet e s]- -> Event+applyMatchers+ :: [EventMatcher e s]+ -> C.Event+ -> Config+ -> [CommandSet e s]+ -> Event applyMatchers ms event conf csets =- fromMaybe (OtherEvent $ show event) $ combineMatchers ms event conf csets+ fromMaybe (OtherEvent $ T.pack $ show event) $+ combineMatchers ms event conf csets -matchEvent :: [EventMatcher e s]- -> C.Event- -> Config- -> [CommandSet e s]- -> Event+matchEvent+ :: [EventMatcher e s]+ -> C.Event+ -> Config+ -> [CommandSet e s]+ -> Event matchEvent = applyMatchers -findCommand :: Maybe Char- -> String- -> [CommandSet e s]- -> Maybe (Either (CommandSet e s) (Command e s))+findCommand+ :: Maybe Char+ -> CommandName+ -> [CommandSet e s]+ -> Maybe (Either (CommandSet e s) (Command e s)) findCommand (Just cpref) cname csets = findCmd cpref cname csets findCommand Nothing _ [] = Nothing findCommand Nothing cname (cset:_) =@@ -418,24 +441,34 @@ -- Run the command with the given prefix character, command name and list of -- parameters. If a command with the given prefix and name isn't found, the bot -- sends a default friendly response.-runCommand :: Maybe Char -- Command prefix, 'Nothing' picks the default prefix- -> String -- Command name- -> [String] -- List of parameters- -> Maybe String -- Channel in which the command was triggered- -> String -- Nickname of user who triggered the command- -> Session e s ()+runCommand+ :: Maybe Char -- Command prefix, 'Nothing' picks the default prefix+ -> CommandName -- Command name+ -> [Text] -- List of parameters+ -> Maybe Channel -- Channel in which the command was triggered+ -> Nickname -- Nickname of user who triggered the command+ -> Session e s () runCommand cpref cname cparams mchan sender = do csets <- askBehaviorS commandSets+ chans <- getChans+ let defresp chan =+ fromMaybe True $ fmap csDefResponse $ M.lookup chan chans case findCommand cpref cname csets of Nothing -> case mchan of- Just chan -> defaultRespondToChan chan cpref cname Nothing+ Just chan ->+ when (defresp chan) $+ defaultRespondToChan chan cpref cname Nothing Nothing -> defaultRespondToUser sender cpref cname Nothing Just (Left cset) -> case mchan of Just chan ->+ when (defresp chan) $ defaultRespondToChan- chan (Just $ csetPrefix cset) cname (Just cset)+ chan+ (Just $ csetPrefix cset)+ cname+ (Just cset) Nothing -> defaultRespondToUser sender (Just $ csetPrefix cset) cname (Just cset)@@ -448,11 +481,11 @@ b <- askBehavior case event of Ping s1 s2 -> pong s1 s2- Kick chan users why -> return ()+ Kick _chan _users _why -> return () Join chan user -> do tracked <- channelIsTracked chan when tracked $ addMember chan user- self <- askConfigS $ connNick . cfgConnection+ self <- askConfigS $ connNickname . cfgConnection when (user == self) $ addCurrChan chan handleJoin b chan user Part chan nick why -> do@@ -466,11 +499,11 @@ handleMsg b chan sender msg mentioned Action chan sender msg mentioned -> handleAction b chan sender msg mentioned- Notice mchan sender msg -> return ()+ Notice _mchan _sender _msg -> return () BotMessage chan sender msg full -> handleBotMsg b chan sender msg full- BotCommand (Channel chan sender) cpref cname cargs ->+ BotCommand (SrcChannel chan sender) cpref cname cargs -> runCommand cpref cname cargs (Just chan) sender- BotCommand (User sender) cpref cname cargs ->+ BotCommand (SrcUser sender) cpref cname cargs -> runCommand cpref cname cargs Nothing sender PersonalMessage sender msg -> handlePersonalMsg b sender msg PersonalAction sender msg -> handlePersonalAction b sender msg@@ -483,7 +516,7 @@ let nicks = map snd pnicks when tracked $ addChannel chan nicks handleNames b chan priv pnicks- OtherEvent s -> return ()+ OtherEvent _t -> return () -- Using nick tracking and logging state, determine from a general log event a -- set of channel loggers and channel-specific log events to write into them.
src/Network/IRC/Fun/Bot/Internal/Failure.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -13,6 +13,8 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} +{-# LANGUAGE OverloadedStrings #-}+ module Network.IRC.Fun.Bot.Internal.Failure ( defaultRespondToChan , defaultRespondToUser@@ -23,44 +25,64 @@ where import Data.Char (toLower)-import Data.List (intercalate)+import Data.List (intersperse)+import Data.Monoid ((<>))+import Data.Text (Text)+import Formatting 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)+import Network.IRC.Fun.Types.Base +import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+ -- Get the default response string in case the command isn't found in the sets. -- This assumes the same response is set both to channels and to users in -- private conversations, which could change in the future. Right now only -- channel commands are supported by the bot anyway.-defaultResponse :: Maybe Char -- Command prefix that was triggered- -> String -- Command name that was triggered- -> [CommandSet e s] -- Available command sets- -> Maybe (CommandSet e s) -- The command set matching the- -- prefix, if one was found- -> String+defaultResponse+ :: Maybe Char -- Command prefix that was triggered+ -> CommandName -- Command name that was triggered+ -> [CommandSet e s] -- Available command sets+ -> Maybe (CommandSet e s) -- The command set matching the prefix, if one+ -- was found+ -> MsgContent defaultResponse Nothing _cname _csets _ =- "Expected to find a default command prefix, but there’s none."+ MsgContent "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 ((: []) . csetPrefix) csets+ MsgContent $+ sformat+ ( "Expected to find a command with prefix ‘"+ % char+ % "’, but there’s none. Available prefixes are: "+ % string+ )+ cpref+ (intersperse ' ' $ 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 . cmdNames) $ csetCommands cset+ MsgContent $+ sformat+ ( "The command ‘"+ % char % stext+ % "’ isn’t available. Available commands for prefix ‘"+ % char+ % "’ are: "+ % stext+ )+ cpref (CI.foldedCase $ unCommandName cname)+ cpref+ (T.unwords $ map cmdName $ csetCommands cset)+ where+ cmdName = CI.original . unCommandName . head . cmdNames -- | Send the default response to an IRC channel defaultRespondToChan- :: String -- Target channel- -> Maybe Char -- Command prefix that was triggered- -> String -- Command name that was triggered- -> Maybe (CommandSet e s) -- The command set matching the prefix, if one- -- was found+ :: Channel -- Target channel+ -> Maybe Char -- Command prefix that was triggered+ -> CommandName -- Command name that was triggered+ -> Maybe (CommandSet e s) -- The command set matching the prefix, if one+ -- was found -> Session e s () defaultRespondToChan chan cpref cname cset = do csets <- askBehaviorS commandSets@@ -68,9 +90,9 @@ -- | Send the default response to an IRC user defaultRespondToUser- :: String -- Recipient nickname+ :: Nickname -- Recipient nickname -> Maybe Char -- Command prefix that was triggered- -> String -- Command name that was triggered+ -> CommandName -- Command name that was triggered -> Maybe (CommandSet e s) -- The command set matching the prefix, is one -- was found -> Session e s ()@@ -78,62 +100,71 @@ csets <- askBehaviorS commandSets sendToUser nick $ defaultResponse cpref cname csets cset --- Determine number suffix when counting things-suffix :: Integral a => a -> String-suffix 1 = "st"-suffix 2 = "nd"-suffix 3 = "rd"-suffix _ = "th"- -- Response message to send on failure-failureDescription :: Failure -> String+failureDescription :: Failure -> Text failureDescription failure = case failure of- WrongNumArgs ->+ WrongNumArgs -> "Wrong number of arguments"- WrongNumArgsN Nothing Nothing ->+ WrongNumArgsN Nothing Nothing -> failureDescription WrongNumArgs- WrongNumArgsN (Just given) Nothing ->- printf "Wrong number of arguments: %v given" given- WrongNumArgsN Nothing (Just expected) ->- printf "Wrong number of arguments: %v expected" expected+ WrongNumArgsN (Just given) Nothing ->+ sformat ("Wrong number of arguments: " % int % " given") given+ WrongNumArgsN Nothing (Just expected) ->+ sformat+ ("Wrong number of arguments: " % int % " expected")+ expected WrongNumArgsN (Just given) (Just expected) ->- printf "Wrong number of arguments: %v given, %v expected"- given- expected- InvalidArgs -> "Invalid arguments"- InvalidArg Nothing Nothing -> "Invalid argument found"- InvalidArg (Just pos) Nothing ->- printf "The %v%v argument is invalid" pos (suffix pos)- InvalidArg Nothing (Just param) ->- printf "Invalid argument: ‘%v’" param- InvalidArg (Just pos) (Just param) ->- printf "The %v%v argument is invalid: ‘%v’" pos (suffix pos) param- OtherFail s -> "Command failed: " ++ s+ sformat+ ( "Wrong number of arguments: "+ % int+ % " given, "+ % int+ % " expected"+ )+ given+ expected+ InvalidArgs -> "Invalid arguments"+ InvalidArg Nothing Nothing -> "Invalid argument found"+ InvalidArg (Just pos) Nothing ->+ sformat ("The " % ords % " argument is invalid") pos+ InvalidArg Nothing (Just param) ->+ sformat ("Invalid argument: ‘" % stext % "’") param+ InvalidArg (Just pos) (Just param) ->+ sformat+ ("The " % ords % " argument is invalid: ‘" % stext % "’")+ pos+ param+ OtherFail t -> "Command failed: " <> t -- | Send message explaining a failure to an IRC channel.-failToChannel :: String -- ^ Target channel- -> String -- ^ User to whom to refer- -> Failure -- ^ Problem indication- -> Session e s ()+failToChannel+ :: Channel -- ^ Target channel+ -> Nickname -- ^ User to whom to refer+ -> Failure -- ^ Problem indication+ -> Session e s () failToChannel chan nick failure =- let lowerc [] = []- lowerc (c:cs) = toLower c : cs- in sendToChannel chan $- nick ++ ", " ++ lowerc (failureDescription failure)+ let lowerc t =+ case T.uncons t of+ Nothing -> t+ Just (c, r) -> toLower c `T.cons` r+ in sendToChannel chan $ MsgContent $+ unNickname nick <> ", " <> lowerc (failureDescription failure) -- | Send message explaining a failure to an IRC user.-failToUser :: String -- ^ Target user- -> Failure -- ^ Problem indication- -> Session e s ()+failToUser+ :: Nickname -- ^ Target user+ -> Failure -- ^ Problem indication+ -> Session e s () failToUser nick failure =- sendToUser nick $ failureDescription failure+ sendToUser nick $ MsgContent $ failureDescription failure -- | Send message explaining a failure back to the sender.-failBack :: Maybe String -- ^ Optional target channel, 'Nothing' means private- -- message- -> String -- ^ Target user nickname- -> Failure -- ^ Problem indication- -> Session e s ()+failBack+ :: Maybe Channel -- ^ Optional target channel, 'Nothing' means private+ -- message+ -> Nickname -- ^ Target user nickname+ -> Failure -- ^ Problem indication+ -> Session e s () failBack (Just chan) nick failure = failToChannel chan nick failure failBack Nothing nick failure = failToUser nick failure
src/Network/IRC/Fun/Bot/Internal/History.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -21,10 +21,11 @@ import Control.Monad (liftM, when) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS (modify)-import Data.Sequence ((|>), Seq, ViewL (..))+import Data.Sequence ((|>))+import Network.IRC.Fun.Bot.Internal.Monad (modify) import Network.IRC.Fun.Bot.Internal.State import Network.IRC.Fun.Bot.Internal.Types+import Network.IRC.Fun.Types import qualified Data.HashMap.Lazy as M import qualified Data.Sequence as Q@@ -32,11 +33,12 @@ import qualified Network.IRC.Fun.Client.Events as C (Event (..)) -- | Remember someone said something, for use later when quoting.-rememberMsg :: String -- ^ Channel- -> String -- ^ User nickname- -> String -- ^ Message- -> Bool -- ^ Whether a /me action (True) or regular message (False)- -> Session e s ()+rememberMsg+ :: Channel+ -> Nickname+ -> MsgContent+ -> Bool -- ^ Whether a /me action (True) or regular message (False)+ -> Session e s () rememberMsg chan nick msg action = do maxlines <- liftM (maybe 0 csHistoryLines . M.lookup chan) getChans when (maxlines > 0) $ do
+ src/Network/IRC/Fun/Bot/Internal/Instances.hs view
@@ -0,0 +1,26 @@+{- This file is part of irc-fun-bot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}++-- | This module exports some typeclasses instances for some of the newtypes+-- in "Network.IRC.Fun.Types".+module Network.IRC.Fun.Bot.Internal.Instances () where++import Data.Aeson (FromJSON, ToJSON)+import Network.IRC.Fun.Types.Base++deriving instance FromJSON Channel+deriving instance ToJSON Channel
src/Network/IRC/Fun/Bot/Internal/IrcLog.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -27,23 +27,25 @@ import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS (ask) import Data.Maybe (isJust)+import Data.Text (unpack) import Data.Traversable (traverse)+import Network.IRC.Fun.Bot.Internal.Monad (ask) import Network.IRC.Fun.Bot.Internal.State import Network.IRC.Fun.Bot.Internal.Types hiding (Logger) import Network.IRC.Fun.Client.ChannelLogger+import Network.IRC.Fun.Types (Channel (..)) import qualified Data.HashMap.Lazy as M -makeLogger :: BotEnv e s -> String -> IO Logger+makeLogger :: BotEnv e s -> Channel -> IO Logger makeLogger env chan = let timeGetter = beGetTime env logdir = cfgLogDir $ beConfig env- file = logFilePath logdir "server" chan+ file = logFilePath logdir "server" (unpack $ unChannel chan) in newLogger (liftM snd timeGetter) file -enable :: String -> ChanState -> Session e s ChanState+enable :: Channel -> ChanState -> Session e s ChanState enable chan cstate = if isJust $ csLogger cstate then return cstate@@ -61,7 +63,7 @@ Nothing -> return cstate -- | Check whether a given channel is being logged.-channelIsLogged :: String -> Session e s Bool+channelIsLogged :: Channel -> Session e s Bool channelIsLogged chan = do chans <- getChans return $ isJust $ M.lookup chan chans >>= csLogger@@ -75,7 +77,7 @@ putChans chanmapE -- | Start logging the given channel, if not being logged already.-startLoggingChannel :: String -> Session e s ()+startLoggingChannel :: Channel -> Session e s () startLoggingChannel chan = do chanmap <- getChans case M.lookup chan chanmap of@@ -85,7 +87,7 @@ Nothing -> return () -- | Start logging the channels not being logged, among the ones given.-startLoggingChannels :: [String] -> Session e s ()+startLoggingChannels :: [Channel] -> Session e s () startLoggingChannels chans = do chanmapAll <- getChans let given = M.fromList (zip chans (repeat ()))@@ -101,7 +103,7 @@ putChans chanmapE -- | Stop logging the given channel, if being logged.-stopLoggingChannel :: String -> Session e s ()+stopLoggingChannel :: Channel -> Session e s () stopLoggingChannel chan = do chanmap <- getChans case M.lookup chan chanmap of@@ -111,7 +113,7 @@ Nothing -> return () -- | Stop logging the channels being logged among the ones given.-stopLoggingChannels :: [String] -> Session e s ()+stopLoggingChannels :: [Channel] -> Session e s () stopLoggingChannels chans = do chanmapAll <- getChans let given = M.fromList (zip chans (repeat ()))
src/Network/IRC/Fun/Bot/Internal/Logger.hs view
@@ -23,13 +23,14 @@ import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS (asks) import Data.Monoid ((<>))+import Data.Text (Text)+import Network.IRC.Fun.Bot.Internal.Monad (asks) import Network.IRC.Fun.Bot.Internal.Types import System.Log.FastLogger -- | Create a logger in the 'IO' monad.-newLogger :: IO String -- ^ Action which returns a formatted time string. You+newLogger :: IO Text -- ^ Action which returns a formatted time string -> FilePath -- ^ Path of the log file -> IO Logger newLogger getTime path = do@@ -54,7 +55,7 @@ removeLogger :: Logger -> IO () removeLogger logger = rmLoggerSet $ loggerSet logger -formatLine :: ToLogStr s => IO String -> s -> IO LogStr+formatLine :: ToLogStr s => IO Text -> s -> IO LogStr formatLine getTime line = do t <- getTime return $ toLogStr t <> toLogStr " " <> toLogStr line
+ src/Network/IRC/Fun/Bot/Internal/Monad.hs view
@@ -0,0 +1,61 @@+{- This file is part of irc-fun-bot.+ -+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module Network.IRC.Fun.Bot.Internal.Monad+ ( runSession+ , ask+ , asks+ , get+ , gets+ , put+ , modify+ )+where++import Network.IRC.Fun.Bot.Internal.Types++import qualified Control.Monad.Trans.RWS as RWS++-- | Run a bot session computation.+runSession :: BotEnv e s -> BotState s -> Session e s a -> IO a+runSession bot state session = do+ (a, _, _) <- RWS.runRWST (unSession session) bot state+ return a++-- | Fetch the value of the environment.+ask :: Session e s (BotEnv e s)+ask = Session RWS.ask++-- | Retrieve a function of the current environment.+asks :: (BotEnv e s -> a) -> Session e s a+asks = Session . RWS.asks++-- | Fetch the current value of the state within the monad.+get :: Session e s (BotState s)+get = Session RWS.get++-- | Get a specific component of the state, using a projection function+-- supplied.+gets :: (BotState s -> a) -> Session e s a+gets = Session . RWS.gets++-- | @'put' s@ sets the state within the monad to @s@.+put :: BotState s -> Session e s ()+put = Session . RWS.put++-- | @'modify' f@ is an action that updates the state to the result of+-- applying @f@ to the current state.+modify :: (BotState s -> BotState s) -> Session e s ()+modify = Session . RWS.modify
src/Network/IRC/Fun/Bot/Internal/MsgCount.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -36,12 +36,14 @@ where import Control.Monad (liftM, when)-import Control.Monad.Trans.RWS (modify, gets)+import Control.Monad.IO.Class (liftIO) import Data.Foldable (any, foldl) import Data.Sequence (Seq, ViewR (..), (|>))+import Network.IRC.Fun.Bot.Internal.Monad (modify, gets) import Network.IRC.Fun.Bot.Internal.Nicks (presence) import Network.IRC.Fun.Bot.Internal.State import Network.IRC.Fun.Bot.Internal.Types+import Network.IRC.Fun.Types (Channel, Nickname) import Prelude hiding (any, foldl) import qualified Data.HashMap.Lazy as M@@ -64,11 +66,11 @@ startCountingAll = modifyChans $ M.map enable -- | Start counting in the given channel, if not counted already.-startCountingChan :: String -> Session e s ()+startCountingChan :: Channel -> Session e s () startCountingChan chan = modifyChans $ M.adjust enable chan -- | Start counting in the channels not counted, among the ones given.-startCountingChans :: [String] -> Session e s ()+startCountingChans :: [Channel] -> Session e s () startCountingChans chans = do chanmapAll <- getChans let given = M.fromList (zip chans (repeat ()))@@ -87,7 +89,7 @@ } -- | Stop counting in the given channel, if counted.-stopCountingChan :: String -> Session e s ()+stopCountingChan :: Channel -> Session e s () stopCountingChan chan = modify $ \ bstate -> bstate { bsMsgCountLog = M.delete chan $ bsMsgCountLog bstate@@ -95,7 +97,7 @@ } -- | Stop counting in the counted channels among the ones given.-stopCountingChans :: [String] -> Session e s ()+stopCountingChans :: [Channel] -> Session e s () stopCountingChans chans = modify $ \ bstate -> bstate { bsMsgCountLog =@@ -111,59 +113,60 @@ -- | Get a mapping between channel names and sequences of their message -- counting data.-getCountLogs :: Session e s (M.HashMap String (Seq MsgCountEntry))+getCountLogs :: Session e s (M.HashMap Channel (Seq MsgCountEntry)) getCountLogs = gets bsMsgCountLog -- | Get the count log for a specific channel. If there is none, an empty log -- is returned.-getCountLog :: String -> Session e s (Seq MsgCountEntry)+getCountLog :: Channel -> Session e s (Seq MsgCountEntry) getCountLog chan = liftM (M.lookupDefault Q.empty chan) getCountLogs -- | Check whether a given channel is being counted.-chanIsCounted :: String -> Session e s Bool+chanIsCounted :: Channel -> Session e s Bool chanIsCounted chan = liftM (maybe False csCounting . M.lookup chan) getChans -- | Check whether a given user ever parted the channel, as far as the count -- log remembers.-everParted :: String -> String -> Session e s Bool+everParted :: Nickname -> Channel -> Session e s Bool nick `everParted` chan =- let p (MsgCountPart n) = n == nick- p _ = False+ let p (MsgCountPart n _) = n == nick+ p _ = False in liftM (any p) $ getCountLog chan -- | Check whether a given user ever joined the channel, as far as the count -- log remembers.-everJoined :: String -> String -> Session e s Bool+everJoined :: Nickname -> Channel -> Session e s Bool nick `everJoined` chan =- let p (MsgCountJoin n) = n == nick- p _ = False+ let p (MsgCountJoin n _) = n == nick+ p _ = False in liftM (any p) $ getCountLog chan -- | Determine how many messages a log sequence has recorded. countMsgs :: Seq MsgCountEntry -> Int countMsgs =- let f n (MsgCountMsgs m) = n + m- f n (MsgCountJoin _) = n- f n (MsgCountPart _) = n+ let f n (MsgCountMsgs m) = n + m+ f n (MsgCountJoin _ _) = n+ f n (MsgCountPart _ _) = n in foldl f 0 -- | Find out how many messages the channel had since the given user parted it. -- On success, return 'Right' it. Otherwise, i.e. if no parting of the user is -- recorded, return 'Left' the total recorded messages.-msgsSinceParted :: String -> String -> Session e s (Either Int Int)+msgsSinceParted :: Nickname -> Channel -> Session e s (Either Int Int) msgsSinceParted nick chan = do cl <- getCountLog chan- let p (MsgCountPart n) = n == nick- p _ = False- (after, until) = Q.breakr p cl+ let p (MsgCountPart n _) = n == nick+ p _ = False+ (after, before) = Q.breakr p cl count = countMsgs after- return $ if Q.null until+ return $ if Q.null before then Left count else Right count -modifyLog :: String- -> (Seq MsgCountEntry -> Seq MsgCountEntry)- -> Session e s ()+modifyLog+ :: Channel+ -> (Seq MsgCountEntry -> Seq MsgCountEntry)+ -> Session e s () modifyLog chan f = do t <- chanIsCounted chan when t $ do@@ -178,7 +181,7 @@ } -- | Count a message in the channel's count log.-recordMsg :: String -> Session e s ()+recordMsg :: Channel -> Session e s () recordMsg chan = let f q = case Q.viewr q of@@ -188,19 +191,23 @@ in modifyLog chan f -- | Count a join in the channel's count log.-recordJoin :: String -> String -> Session e s ()-recordJoin nick chan =- let f = (|> (MsgCountJoin nick))- in modifyLog chan f+recordJoin :: Nickname -> Channel -> Session e s ()+recordJoin nick chan = do+ getTime <- askTimeGetter+ now <- liftIO $ fmap fst getTime+ let f = (|> (MsgCountJoin nick now))+ modifyLog chan f -- | Count a part (i.e. leave one channel) in the channel's count log.-recordPart :: String -> String -> Session e s ()-recordPart nick chan =- let f = (|> (MsgCountPart nick))- in modifyLog chan f+recordPart :: Nickname -> Channel -> Session e s ()+recordPart nick chan = do+ getTime <- askTimeGetter+ now <- liftIO $ fmap fst getTime+ let f = (|> (MsgCountPart nick now))+ modifyLog chan f -- | Count a quit (i.e. leave all channels) in the channel's count log.-recordQuit :: String -> Session e s ()+recordQuit :: Nickname -> Session e s () recordQuit nick = do chans <- presence nick let chansPresent = M.fromList $ zip chans (repeat ())@@ -209,15 +216,17 @@ logs <- getCountLogs let logsAct = logs `M.intersection` chansAct n <- askConfigS cfgMaxMsgCount+ getTime <- askTimeGetter+ now <- liftIO $ fmap fst getTime let f q =- let new = q |> MsgCountPart nick+ let new = q |> MsgCountPart nick now in if Q.length new > n then QU.tail new else new logsNew = M.map f logsAct modify $ \ bstate -> bstate { bsMsgCountLog = logsNew `M.union` bsMsgCountLog bstate } --- | If en event needs to be considered in message counting, handle it.+-- | If an event needs to be considered in message counting, handle it. countEvent :: C.Event -> Maybe (Msg a) countEvent (C.Join chan nick) = Just $ MsgCountLogJoin nick chan countEvent (C.Part chan nick _) = Just $ MsgCountLogPart nick chan
src/Network/IRC/Fun/Bot/Internal/Nicks.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -34,13 +34,12 @@ where import Control.Monad (unless)-import Control.Monad.Trans.RWS import Data.Maybe (fromMaybe) import Network.IRC.Fun.Bot.Internal.ChatExt (putIrc)+import Network.IRC.Fun.Bot.Internal.Monad 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 Network.IRC.Fun.Types import qualified Data.HashMap.Lazy as M import qualified Network.IRC.Fun.Client.NickTracker as NT@@ -52,7 +51,7 @@ disable cstate = cstate { csTracking = False } -- | Check whether a given channel is being tracked.-channelIsTracked :: String -> Session e s Bool+channelIsTracked :: Channel -> Session e s Bool channelIsTracked chan = do chans <- getChans return $ fromMaybe False $ fmap csTracking $ M.lookup chan chans@@ -62,13 +61,13 @@ startTrackingAll :: Session e s () startTrackingAll = do chans <- getChans- let chansD = [chan | (chan, ChanState False _ _ _) <- M.toList chans]+ let chansD = [chan | (chan, ChanState False _ _ _ _) <- M.toList chans] chansAllE = M.map enable chans putChans chansAllE unless (null chansD) $ putIrc $ NamesMessage chansD Nothing -- | Start tracking nicks in the given channel, if not tracked already.-startTrackingChannel :: String -> Session e s ()+startTrackingChannel :: Channel -> Session e s () startTrackingChannel chan = do chans <- getChans case M.lookup chan chans of@@ -79,7 +78,7 @@ Nothing -> return () -- | Start tracking nicks in the channels not tracked, among the ones given.-startTrackingChannels :: [String] -> Session e s ()+startTrackingChannels :: [Channel] -> Session e s () startTrackingChannels chans = do chanmapAll <- getChans let given = M.fromList (zip chans (repeat ()))@@ -100,7 +99,7 @@ } -- | Stop tracking nicks in the given channel, if tracked.-stopTrackingChannel :: String -> Session e s ()+stopTrackingChannel :: Channel -> Session e s () stopTrackingChannel chan = modify $ \ bstate -> bstate { bsTracker = NT.removeChannel chan $ bsTracker bstate@@ -108,7 +107,7 @@ } -- | Stop tracking nicks in the tracked channels among the ones given.-stopTrackingChannels :: [String] -> Session e s ()+stopTrackingChannels :: [Channel] -> Session e s () stopTrackingChannels chans = modify $ \ bstate -> bstate { bsTracker = NT.removeChannels chans $ bsTracker bstate@@ -120,56 +119,56 @@ } -- | Check whether a nickname is present in a channel.-isInChannel :: String -> String -> Session e s Bool+isInChannel :: Nickname -> Channel -> Session e s Bool nick `isInChannel` chan = do nt <- gets bsTracker return $ NT.isInChannel nick chan nt -- | Check in which channels a nickname is present.-presence :: String -> Session e s [ChannelName]+presence :: Nickname -> Session e s [Channel] presence nick = do nt <- gets bsTracker return $ NT.presence nick nt -- | Record a nickname being present in a channel.-addMember :: String -> String -> Session e s ()+addMember :: Channel -> Nickname -> Session e 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 :: Nickname -> Nickname -> Session e 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 :: Channel -> [Nickname] -> Session e 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 :: Channel -> Nickname -> Session e 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 :: Nickname -> Session e 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 :: Channel -> Session e 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 :: [Channel] -> Session e s () removeChannels chans = modify $ \ s -> s { bsTracker = f $ bsTracker s } where f = NT.removeChannels chans
src/Network/IRC/Fun/Bot/Internal/Persist.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -16,6 +16,9 @@ -- For JSON field names {-# LANGUAGE OverloadedStrings #-} +-- To allow 'Channel' as a JSON object key+{-# LANGUAGE FlexibleInstances #-}+ module Network.IRC.Fun.Bot.Internal.Persist ( loadBotState , mkSaveBotState@@ -29,21 +32,23 @@ 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.JsonState import Data.List (union) import Data.Time.Interval import Data.Time.Units (Microsecond)+import Network.IRC.Fun.Bot.Internal.Instances () import Network.IRC.Fun.Bot.Internal.IrcLog (makeLogger)+import Network.IRC.Fun.Bot.Internal.Monad import Network.IRC.Fun.Bot.Internal.State import Network.IRC.Fun.Bot.Internal.Types import Network.IRC.Fun.Client.NickTracker (newNetwork)+import Network.IRC.Fun.Types (Channel (..)) import qualified Data.HashMap.Lazy as M import qualified Data.HashSet as S -data BotStateJ = BotStateJ (M.HashMap String ChanInfo) (S.HashSet String)+data BotStateJ = BotStateJ (M.HashMap Channel ChanInfo) (S.HashSet Channel) toJ :: BotState s -> BotStateJ toJ bstate =@@ -51,34 +56,46 @@ fromJ :: BotEnv e s -> BotStateJ -> s -> IO (BotState s) fromJ env (BotStateJ stateJ selJ) pub = do- let f chan (ChanInfo tracking counting logging hls) = do+ let f chan (ChanInfo tracking counting logging hls defresp) = do mlogger <- if logging then fmap Just $ makeLogger env chan else return Nothing- return $ ChanState tracking counting mlogger hls- defstate = ChanInfo False False False 0+ return $ ChanState tracking counting mlogger hls defresp+ defstate = ChanInfo False False False 0 True chansConf = S.toList selJ `union` cfgChannels (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 M.empty M.empty pub +instance FromJSON a => FromJSON (M.HashMap Channel a) where+ parseJSON v =+ let f (c, x) = (Channel c, x)+ in M.fromList . map f . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap Channel a) where+ toJSON m =+ let f (Channel c, x) = (c, x)+ in toJSON $ M.fromList $ map f $ M.toList m+ instance FromJSON ChanInfo where parseJSON (Object o) = ChanInfo <$> o .: "track" <*> o .: "count" <*> o .: "log" <*>- o .: "history-lines"+ o .: "history-lines" <*>+ o .: "default-response" parseJSON _ = mzero instance ToJSON ChanInfo where- toJSON (ChanInfo tracking counting logging hls) = object- [ "track" .= tracking- , "count" .= counting- , "log" .= logging- , "history-lines" .= hls+ toJSON (ChanInfo tracking counting logging hls defresp) = object+ [ "track" .= tracking+ , "count" .= counting+ , "log" .= logging+ , "history-lines" .= hls+ , "default-response" .= defresp ] instance FromJSON BotStateJ where@@ -121,7 +138,7 @@ -- | 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 :: Channel -> Session e s () selectChannel chan = do chans <- gets bsSelChans unless (chan `S.member` chans) $ do@@ -132,7 +149,7 @@ -- 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 :: Channel -> Session e s () unselectChannel chan = do chans <- gets bsSelChans when (chan `S.member` chans) $ do@@ -141,9 +158,9 @@ -- | 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 :: Channel -> Session e s () addChannelState chan = do chans <- getChans unless (chan `M.member` chans) $ do- putChans $ M.insert chan (ChanState False False Nothing 0) chans+ putChans $ M.insert chan (ChanState False False Nothing 0 True) chans saveBotState
src/Network/IRC/Fun/Bot/Internal/State.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -20,7 +20,7 @@ , askBehaviorS , askEnv , askEnvS- , askHandle+ , askConnection , askTimeGetter , askMinuteGetter , getMinutes@@ -39,19 +39,23 @@ , clearCurrChans , channelSelected , botMemberOf+ , defRespEnabled+ , setDefResp ) where import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.RWS import Data.HashMap.Lazy (HashMap) import Data.Int (Int64)-import Data.Maybe (isJust)+import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq)+import Data.Text (Text) import Data.Time.Clock (UTCTime)+import Network.IRC.Fun.Bot.Internal.Monad import Network.IRC.Fun.Bot.Internal.Types-import Network.IRC.Fun.Client.IO (Handle)+import Network.IRC.Fun.Client.IO (Connection)+import Network.IRC.Fun.Types (Channel) import qualified Data.HashMap.Lazy as M import qualified Data.HashSet as S@@ -81,8 +85,8 @@ askEnvS f = asks $ f . beCustom -- | Fetch the bot session socket handle.-askHandle :: Session e s Handle-askHandle = asks beHandle+askConnection :: Session e s Connection+askConnection = asks beConn -- | 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@@ -90,7 +94,7 @@ -- -- 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 :: Session e s (IO (UTCTime, Text)) askTimeGetter = asks beGetTime -- | Fetch the minute getter. The actual data is cached and updated at most@@ -125,40 +129,40 @@ modify $ \ old@(BotState { bsPublic = st }) -> old { bsPublic = f st } -- | Get a mapping between channel names and sequences of their last messages.-getHistory :: Session e s (HashMap String (Seq HistoryLine))+getHistory :: Session e s (HashMap Channel (Seq HistoryLine)) getHistory = gets bsHistory -- Create channel info from its state stateToInfo :: ChanState -> ChanInfo-stateToInfo (ChanState track count mlogger hls) =- ChanInfo track count (isJust mlogger) hls+stateToInfo (ChanState track count mlogger hls dr) =+ ChanInfo track count (isJust mlogger) hls dr -- | Get channel state information, in the form of a mapping from channel names -- to their data.-getChanInfo :: Session e s (HashMap String ChanInfo)-getChanInfo = liftM (M.map stateToInfo) getChans+getChanInfo :: Session e s (HashMap Channel ChanInfo)+getChanInfo = fmap (M.map stateToInfo) getChans -- Get the channel state map.-getChans :: Session e s (HashMap String ChanState)+getChans :: Session e s (HashMap Channel ChanState) getChans = gets bsChannels -- Set a new value for the channel state map.-putChans :: HashMap String ChanState -> Session e s ()+putChans :: HashMap Channel ChanState -> Session e s () putChans chans = modify $ \ s -> s { bsChannels = chans } -- Update the channel state map value with the result of applying a function.-modifyChans :: (HashMap String ChanState -> HashMap String ChanState)+modifyChans :: (HashMap Channel ChanState -> HashMap Channel ChanState) -> Session e 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 :: Channel -> 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 :: Channel -> Session e s () removeCurrChan chan = let f = S.delete chan in modify $ \ s -> s { bsCurrChans = f $ bsCurrChans s }@@ -168,12 +172,35 @@ 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 :: Channel -> 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 :: Channel -> Session e s Bool botMemberOf chan = liftM (chan `S.member`) $ gets bsCurrChans++-- | Check whether a given channel has nonexistent command response enabled.+defRespEnabled :: Channel -> Session e s Bool+defRespEnabled chan = do+ chans <- getChans+ return $ fromMaybe False $ fmap csDefResponse $ M.lookup chan chans++-- | Enable or disable nonexistent command response for a channel. Return+-- whether the new state differs from the previous one. If no such channel+-- exists in the bot state, nothing changes.+setDefResp :: Channel -> Bool -> Session e s Bool+setDefResp chan yes = do+ chans <- getChans+ case M.lookup chan chans of+ Just cstate ->+ if csDefResponse cstate /= yes+ then do+ let cstate' = cstate { csDefResponse = yes }+ chans' = M.insert chan cstate' chans+ putChans chans'+ return True+ else return False+ Nothing -> return False
src/Network/IRC/Fun/Bot/Internal/Types.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -13,10 +13,28 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} +{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module Network.IRC.Fun.Bot.Internal.Types- ( Config (..)+ ( Config ()+ , cfgConnection+ , cfgChannels+ , cfgLogDir+ , cfgStateRepo+ , cfgStateFile+ , cfgSaveInterval+ , cfgIrcEventLogFile+ , cfgIrcErrorLogFile+ , cfgExtEventLogFile+ , cfgExtErrorLogFile+ , cfgMaxMsgChars+ , cfgLagCheck+ , cfgLagMax+ , cfgMaxMsgCount+ , cfgMsgDelay , MessageSource (..) , Failure (..)+ , CommandName (..) , Command (..) , CommandSet (..) , IrcMsg (..)@@ -26,7 +44,7 @@ , ChanInfo (..) , HistoryLine (..) , BotState (..)- , Session+ , Session (..) , ChannelPrivacy (..) , Privilege (..) , Event (..)@@ -37,38 +55,47 @@ , Msg (..) , EventSource , EventHandler- , Quotes (..) ) where +import Control.Applicative (Applicative) import Control.Concurrent.Chan (Chan)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.RWS (RWST)+import Data.CaseInsensitive (CI)+import Data.Default.Class import Data.HashMap.Lazy (HashMap) import Data.HashSet (HashSet) import Data.Int (Int64) import Data.Sequence (Seq)+import Data.Text (Text, pack) import Data.Time.Clock (UTCTime)-import Data.Time.Interval (TimeInterval)+import Data.Time.Interval (TimeInterval, time)+import Data.Time.Units import Network.IRC.Fun.Client.ChannelLogger (LogEvent)-import Network.IRC.Fun.Client.IO (Connection, Handle)-import Network.IRC.Fun.Client.Events (ChannelPrivacy (..), Privilege (..))+import Network.IRC.Fun.Client.IO (ConnConfig, Connection) import Network.IRC.Fun.Client.NickTracker (NetworkTracker)-import Network.IRC.Fun.Messages.TypeAliases (NickName, ChannelName)+import Network.IRC.Fun.Types hiding (Command) 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.+--+-- Get a default bot configuration using 'def', and use record syntax to+-- override just the fields you need. It allows adding a field without breaking+-- backwards compatibility. data Config = Config { -- | Connection details, including nickname and optional password- cfgConnection :: Connection+ cfgConnection :: ConnConfig -- | 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.- , cfgChannels :: [String]+ , cfgChannels :: [Channel] -- | Directory path under which IRC log files will be placed. Relative to -- the bot process working directory, or absolute. , cfgLogDir :: FilePath@@ -88,11 +115,16 @@ , cfgSaveInterval :: TimeInterval -- | Filename for the bot's main event log, i.e. produced by the IRC -- event source.- , cfgBotEventLogFile :: FilePath+ , cfgIrcEventLogFile :: Maybe FilePath -- | Filename for writing error messages generated by invalid IRC lines -- or errors in their analysis or in event detection. Useful for -- debugging. , cfgIrcErrorLogFile :: Maybe FilePath+ -- | Filename for the bot's external handler event log.+ , cfgExtEventLogFile :: Maybe FilePath+ -- | Filename for writing error messages generated by invalid external+ -- events or errors in their analysis or handling. Useful for debugging.+ , cfgExtErrorLogFile :: Maybe 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@@ -122,8 +154,30 @@ } deriving Show +instance Default Config where+ def = Config+ { cfgConnection = def+ , cfgChannels = [Channel $ pack "#freepost-bot-test"]+ , cfgLogDir = "state/chanlogs"+ , cfgStateRepo = Nothing+ , cfgStateFile = "state/state.json"+ , cfgSaveInterval = time (3 :: Second)+ , cfgIrcEventLogFile = Nothing+ , cfgIrcErrorLogFile = Nothing+ , cfgExtEventLogFile = Nothing+ , cfgExtErrorLogFile = Nothing+ , cfgMaxMsgChars = Nothing+ , cfgLagCheck = Just $ time (1 :: Minute)+ , cfgLagMax = time (5 :: Minute)+ , cfgMaxMsgCount = 1000+ , cfgMsgDelay = time (100 :: Millisecond)+ }+ -- | 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)+data MessageSource+ = SrcChannel Channel Nickname+ | SrcUser Nickname+ deriving (Eq, Show) -- | Describes wrong usage of a bot command. data Failure@@ -135,11 +189,15 @@ | InvalidArgs -- | Argument in position \<first-param\> and value \<second-param\> -- invalid- | InvalidArg (Maybe Int) (Maybe String)+ | InvalidArg (Maybe Int) (Maybe Text) -- | Some other error, with a given description- | OtherFail String+ | OtherFail Text deriving (Eq, Show) +-- | A bot command name.+newtype CommandName = CommandName { unCommandName :: CI Text }+ deriving (Eq, Show)+ -- | A bot command, triggered by a message sent to an IRC channel the bot has -- joined. --@@ -154,7 +212,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.- cmdNames :: [String]+ cmdNames :: [CommandName] -- | 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@@ -172,15 +230,21 @@ -- (3) Command parameters given -- (4) Action for sending a message back to the sender, same as using -- @sendBack@ with the channel and nickname- , cmdRespond :: Maybe String- -> String- -> [String]- -> (String -> Session e s ())- -> Session e s ()+ , cmdRespond :: Maybe Channel+ -> Nickname+ -> [Text]+ -> (MsgContent -> 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.- , cmdHelp :: String+ -- and its usage. May contain newlines.+ , cmdHelp :: Text++ -- | Usage examples. Each item should be a single command invocation,+ -- single line, no newlines, no command prefix. For instance,+ -- @\"tell joe How are you?\"@ is an example for a hypothetical @tell@+ -- command.+ , cmdExamples :: [Text] } -- | The bot recognizes commands by picking IRC channel messages which begin@@ -198,8 +262,9 @@ -- An IRC message to send to a user or a channel. data IrcMsg = IrcMsg- { msgRecip :: Either NickName ChannelName- , msgLines :: [String]+ { msgRecip :: Either Nickname Channel+ , msgLines :: [MsgContent]+ , msgNotice :: Bool } deriving (Show) @@ -217,8 +282,8 @@ data BotEnv e s = BotEnv { beConfig :: Config , beBehavior :: Behavior e s- , beHandle :: Handle- , beGetTime :: IO (UTCTime, String)+ , beConn :: Connection+ , beGetTime :: IO (UTCTime, Text) -- An 'IO' action which reads a periodically updated counter of the -- number of minutes since the epoch. , beGetMinute :: IO Int64@@ -232,9 +297,9 @@ -- | Number of messages sent in a channel = MsgCountMsgs Int -- | User joined the channel- | MsgCountJoin String+ | MsgCountJoin Nickname UTCTime -- | User left the channel- | MsgCountPart String+ | MsgCountPart Nickname UTCTime -- Per-channel modifiable state data ChanState = ChanState@@ -246,9 +311,12 @@ , csLogger :: Maybe L.Logger -- Maximal number of channel message history lines to remember , csHistoryLines :: Int+ -- Whether to send a response when an invalid command is attempted. If+ -- not, then simply ignore the attempt.+ , csDefResponse :: Bool } --- | Per-channel information to return to the API user+ data ChanInfo = ChanInfo { -- | Whether user-in-channel tracking is enabled for this channel ciTrack :: Bool@@ -258,13 +326,15 @@ , ciLog :: Bool -- | Maximal number of channel message history lines to remember , ciHistoryLines :: Int+ -- | Whether to respond to nonexistent command attempts+ , ciDefResponse :: Bool } -- | A message sent previously by an IRC user into a channel. data HistoryLine = HistoryLine- { hlTime :: String- , hlNick :: String- , hlMessage :: String+ { hlTime :: Text+ , hlNick :: Nickname+ , hlMessage :: MsgContent , hlAction :: Bool , hlMinute :: Int64 }@@ -275,74 +345,75 @@ { -- Keeps track of which users are in which channels bsTracker :: NetworkTracker -- Per-channel persistent state- , bsChannels :: HashMap String ChanState+ , bsChannels :: HashMap Channel ChanState -- Channels of which the bot is currently a member- , bsCurrChans :: HashSet String+ , bsCurrChans :: HashSet Channel -- Channels the bot should join when it launches- , bsSelChans :: HashSet String+ , bsSelChans :: HashSet Channel -- Per-channel last messages- , bsHistory :: HashMap String (Seq HistoryLine)+ , bsHistory :: HashMap Channel (Seq HistoryLine) -- Per-channel message counter log- , bsMsgCountLog :: HashMap String (Seq MsgCountEntry)+ , bsMsgCountLog :: HashMap Channel (Seq MsgCountEntry) -- Custom state , bsPublic :: s } --- | Bot monad. It provides read-only bot environment (e.g. the configuration),--- read-writable bot state (for use by bot commands) and IO.-type Session e s = RWST (BotEnv e s) () (BotState s) IO+-- | Bot monad.+newtype Session e s a+ = Session { unSession :: RWST (BotEnv e s) () (BotState s) IO a }+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO) -- An event triggered by an IRC message sent from the server. data Event -- | A ping was sent to the bot. The parameters contain the arguments -- passed, which should be passed in the Pong.- = Ping String (Maybe String)+ = Ping Hostname (Maybe Hostname) -- | Users (2nd parameter) have been kicked from a channel (1st parameter) -- for a given reason (3rd parameter).- | Kick String [String] (Maybe String)+ | Kick Channel [Nickname] (Maybe Comment) -- | A user (2nd parameter) joined a channel (1st parameter).- | Join String String+ | Join Channel Nickname -- | A user (2nd parameter) left a channel (1st parameter), 3rd=reason.- | Part String String (Maybe String)+ | Part Channel Nickname (Maybe Comment) -- | User, reason.- | Quit String (Maybe String)+ | Quit Nickname (Maybe Comment) -- | Message (3rd parameter) sent in a channel (1st parameter) by a user -- 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+ | Message Channel Nickname MsgContent Bool -- | Like 'Message', but it's a pseudo action (/me).- | Action String String String Bool+ | Action Channel Nickname MsgContent 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+ | Notice (Maybe Channel) Nickname MsgContent -- | 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+ | BotMessage Channel Nickname MsgContent MsgContent -- | 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.- | BotCommand MessageSource (Maybe Char) String [String]+ | BotCommand MessageSource (Maybe Char) CommandName [Text] -- | A private message sent specifically to the bot, from a user with the -- given nickname (1st parameter) and with the given content (2nd -- parameter).- | PersonalMessage String String+ | PersonalMessage Nickname MsgContent -- | Like 'PersonalMessage', but it's a pseudo action (/me).- | PersonalAction String String+ | PersonalAction Nickname MsgContent -- | Old nick, new nick.- | NickChange String String+ | NickChange Nickname Nickname -- | Channel, nickname, topic- | TopicChange String String String+ | TopicChange Channel Nickname ChannelTopic -- | The server sent a list of nicknames present in a channel. Parameters: -- Channel privacy mode, channel name, list of users. Each list item is a -- pair of a user privilege level in the channel, and the user's nickname.- | Names String ChannelPrivacy [(Privilege, String)]+ | Names Channel ChannelPrivacy [(Privilege, Nickname)] -- | Unrecognized or unimplemented event. The parameter contains (possibly -- empty) input.- | OtherEvent String+ | OtherEvent Text deriving Show -- | Tries to match a client event to a bot event.@@ -354,27 +425,27 @@ -- | Bot behavior definition. data Behavior e s = Behavior { handleJoin- :: String -> String -> Session e s ()+ :: Channel -> Nickname -> Session e s () , handlePart- :: String -> String -> Maybe String -> Session e s ()+ :: Channel -> Nickname -> Maybe Comment -> Session e s () , handleQuit- :: String -> Maybe String -> Session e s ()+ :: Nickname -> Maybe Comment -> Session e s () , handleMsg- :: String -> String -> String -> Bool -> Session e s ()+ :: Channel -> Nickname -> MsgContent -> Bool -> Session e s () , handleAction- :: String -> String -> String -> Bool -> Session e s ()+ :: Channel -> Nickname -> MsgContent -> Bool -> Session e s () , handleBotMsg- :: String -> String -> String -> String -> Session e s ()+ :: Channel -> Nickname -> MsgContent -> MsgContent -> Session e s () , commandSets :: [CommandSet e s] , handlePersonalMsg- :: String -> String -> Session e s ()+ :: Nickname -> MsgContent -> Session e s () , handlePersonalAction- :: String -> String -> Session e s ()+ :: Nickname -> MsgContent -> Session e s () , handleNickChange- :: String -> String -> Session e s ()+ :: Nickname -> Nickname -> Session e s () , handleTopicChange- :: String -> String -> String -> Session e s ()+ :: Channel -> Nickname -> ChannelTopic -> Session e s () -- | Handle a channel member list received. Parameters: -- -- (1) Channel name@@ -382,22 +453,41 @@ -- (3) List of channel members: their privilege level in the channel and -- their nicknames , handleNames- :: String -> ChannelPrivacy -> [(Privilege, String)] -> Session e s ()+ :: Channel+ -> ChannelPrivacy+ -> [(Privilege, Nickname)]+ -> Session e s () } +instance Default (Behavior e s) where+ def = Behavior+ { handleJoin = \ _ _ -> return ()+ , handlePart = \ _ _ _ -> return ()+ , handleQuit = \ _ _ -> return ()+ , handleMsg = \ _ _ _ _ -> return ()+ , handleAction = \ _ _ _ _ -> return ()+ , handleBotMsg = \ _ _ _ _ -> return ()+ , commandSets = []+ , handlePersonalMsg = \ _ _ -> return ()+ , handlePersonalAction = \ _ _ -> return ()+ , handleNickChange = \ _ _ -> return ()+ , handleTopicChange = \ _ _ _ -> return ()+ , handleNames = \ _ _ _ -> return ()+ }+ data Logger = Logger { loggerSet :: LoggerSet- , loggerGetTime :: IO String+ , loggerGetTime :: IO Text } -- An event passed to the main thread (event handler) from other threads. data Msg a = MsgLogEvent LogEvent- | MsgHistoryEvent String String String Bool- | MsgCountLogMsg String- | MsgCountLogJoin String String- | MsgCountLogPart String String- | MsgCountLogQuit String+ | MsgHistoryEvent Nickname Channel MsgContent Bool+ | MsgCountLogMsg Channel+ | MsgCountLogJoin Nickname Channel+ | MsgCountLogPart Nickname Channel+ | MsgCountLogQuit Nickname | MsgBotEvent Event | MsgExtEvent a | MsgQuit@@ -435,16 +525,18 @@ -- * @e@ - custom bot environment type -- * @s@ - custom bot state type -- * @a@ - event type-type EventHandler e s a = a -> Session e s ()---- | Quote types for string formatting.-data Quotes- -- | Single quote on each side of the formatted string. The parameter sets- -- whether to use Unicode (otherwise use ASCII fallback).- = SingleQuotes Bool- -- | Double quote on each side of the formatted string. The parameter sets- -- whether to use Unicode (otherwise use ASCII fallback).- | DoubleQuotes Bool- -- | Backtick on each side of the formatted string.- | BackTicks- deriving (Eq, Show)+--+-- Parameters:+--+-- (1) Error logging function+-- (2) Event logging function+-- (3) The event+--+-- Note that logging can be turned on and off using the bot config, i.e. the+-- handler function can safely use logging and the messages will simply and+-- safely be discarded when logging is off.+type EventHandler e s a+ = (Text -> Session e s ())+ -> (Text -> Session e s ())+ -> a+ -> Session e s ()
src/Network/IRC/Fun/Bot/State.hs view
@@ -35,6 +35,8 @@ , channelSelected , botMemberOf , addChannelState+ , defRespEnabled+ , setDefResp , saveBotState ) where
src/Network/IRC/Fun/Bot/Types.hs view
@@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>. - - ♡ Copying is an act of love. Please copy, reuse and share. -@@ -15,22 +15,47 @@ -- | This module provides the datatypes. module Network.IRC.Fun.Bot.Types- ( Connection (..)- , Config (..)+ ( Config ()+ , cfgConnection+ , cfgChannels+ , cfgLogDir+ , cfgStateRepo+ , cfgStateFile+ , cfgSaveInterval+ , cfgIrcEventLogFile+ , cfgIrcErrorLogFile+ , cfgExtEventLogFile+ , cfgExtErrorLogFile+ , cfgMaxMsgChars+ , cfgLagCheck+ , cfgLagMax+ , cfgMaxMsgCount+ , cfgMsgDelay , Failure (..)+ , CommandName (..) , Command (..) , CommandSet (..) , HistoryLine (..) , ChanInfo (..) , MsgCountEntry (..)- , Session+ , Session () , EventMatchSpace (..)- , Behavior (..)+ , Behavior ()+ , handleJoin+ , handlePart+ , handleQuit+ , handleMsg+ , handleAction+ , handleBotMsg+ , commandSets+ , handlePersonalMsg+ , handlePersonalAction+ , handleNickChange+ , handleTopicChange+ , handleNames , EventSource , EventHandler- , Quotes (..) ) where import Network.IRC.Fun.Bot.Internal.Types-import Network.IRC.Fun.Client.IO (Connection (..))
− src/Network/IRC/Fun/Bot/Util.hs
@@ -1,50 +0,0 @@-{- This file is part of irc-fun-bot.- -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.- -- - ♡ Copying is an act of love. Please copy, reuse and share.- -- - The author(s) have dedicated all copyright and related and neighboring- - rights to this software to the public domain worldwide. This software is- - distributed without any warranty.- -- - You should have received a copy of the CC0 Public Domain Dedication along- - with this software. If not, see- - <http://creativecommons.org/publicdomain/zero/1.0/>.- -}---- | This module collects smaller general purpose utilities which may be useful--- to bot authors.-module Network.IRC.Fun.Bot.Util- ( quote- , maybeQuote- , showNames- )-where--import Data.List (intercalate)-import Network.IRC.Fun.Bot.Types (Quotes (..))---- | Add quotes to a string.-quote :: Quotes -> String -> String-quote (SingleQuotes True) s = '‘' : s ++ "’"-quote (SingleQuotes False) s = '\'' : s ++ "'"-quote (DoubleQuotes True) s = '“' : s ++ "”"-quote (DoubleQuotes False) s = '"' : s ++ "\""-quote BackTicks s = '`' : s ++ "`"---- | Optionally add quotes to a string.-maybeQuote :: Maybe Quotes -> String -> String-maybeQuote = maybe id quote---- | Format a list of labels.------ >>> putStrLn $ showNames (Just $ SingleQuotes False)--- >>> ", "--- >>> ["one", "two", "three"]--- 'one', 'two', 'three'-showNames :: Maybe Quotes -- ^ Optionally wrap labels with quotes- -> String -- ^ Separate between labels, e.g. spaces or newline- -> [String] -- ^ List of labels- -> String-showNames qs sep = intercalate sep . map (maybeQuote qs)