diff --git a/NEWS b/NEWS deleted file mode 100644 --- a/NEWS +++ /dev/null @@ -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) diff --git a/NEWS.md b/NEWS.md new file mode 100644 --- /dev/null +++ b/NEWS.md @@ -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) diff --git a/irc-fun-bot.cabal b/irc-fun-bot.cabal --- a/irc-fun-bot.cabal +++ b/irc-fun-bot.cabal @@ -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 diff --git a/src/Network/IRC/Fun/Bot.hs b/src/Network/IRC/Fun/Bot.hs --- a/src/Network/IRC/Fun/Bot.hs +++ b/src/Network/IRC/Fun/Bot.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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" diff --git a/src/Network/IRC/Fun/Bot/Behavior.hs b/src/Network/IRC/Fun/Bot/Behavior.hs --- a/src/Network/IRC/Fun/Bot/Behavior.hs +++ b/src/Network/IRC/Fun/Bot/Behavior.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015 by fr33domlover . - - ♡ 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) diff --git a/src/Network/IRC/Fun/Bot/Chat.hs b/src/Network/IRC/Fun/Bot/Chat.hs --- a/src/Network/IRC/Fun/Bot/Chat.hs +++ b/src/Network/IRC/Fun/Bot/Chat.hs @@ -33,8 +33,13 @@ , partAll -- * Sending Messages , sendToChannel + , sendToChannel' + , sendToChannelNow , sendToUser + , sendToUser' + , sendToUserNow , sendBack + , sendBackNow , failToChannel , failToUser , failBack diff --git a/src/Network/IRC/Fun/Bot/EventMatch.hs b/src/Network/IRC/Fun/Bot/EventMatch.hs --- a/src/Network/IRC/Fun/Bot/EventMatch.hs +++ b/src/Network/IRC/Fun/Bot/EventMatch.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - diff --git a/src/Network/IRC/Fun/Bot/Internal/Chat.hs b/src/Network/IRC/Fun/Bot/Internal/Chat.hs --- a/src/Network/IRC/Fun/Bot/Internal/Chat.hs +++ b/src/Network/IRC/Fun/Bot/Internal/Chat.hs @@ -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 diff --git a/src/Network/IRC/Fun/Bot/Internal/ChatExt.hs b/src/Network/IRC/Fun/Bot/Internal/ChatExt.hs --- a/src/Network/IRC/Fun/Bot/Internal/ChatExt.hs +++ b/src/Network/IRC/Fun/Bot/Internal/ChatExt.hs @@ -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 diff --git a/src/Network/IRC/Fun/Bot/Internal/Event.hs b/src/Network/IRC/Fun/Bot/Internal/Event.hs --- a/src/Network/IRC/Fun/Bot/Internal/Event.hs +++ b/src/Network/IRC/Fun/Bot/Internal/Event.hs @@ -13,6 +13,8 @@ - . -} +{-# 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. diff --git a/src/Network/IRC/Fun/Bot/Internal/Failure.hs b/src/Network/IRC/Fun/Bot/Internal/Failure.hs --- a/src/Network/IRC/Fun/Bot/Internal/Failure.hs +++ b/src/Network/IRC/Fun/Bot/Internal/Failure.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -13,6 +13,8 @@ - . -} +{-# 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 diff --git a/src/Network/IRC/Fun/Bot/Internal/History.hs b/src/Network/IRC/Fun/Bot/Internal/History.hs --- a/src/Network/IRC/Fun/Bot/Internal/History.hs +++ b/src/Network/IRC/Fun/Bot/Internal/History.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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 diff --git a/src/Network/IRC/Fun/Bot/Internal/Instances.hs b/src/Network/IRC/Fun/Bot/Internal/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Bot/Internal/Instances.hs @@ -0,0 +1,26 @@ +{- This file is part of irc-fun-bot. + - + - Written in 2015, 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +{-# 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 diff --git a/src/Network/IRC/Fun/Bot/Internal/IrcLog.hs b/src/Network/IRC/Fun/Bot/Internal/IrcLog.hs --- a/src/Network/IRC/Fun/Bot/Internal/IrcLog.hs +++ b/src/Network/IRC/Fun/Bot/Internal/IrcLog.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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 ())) diff --git a/src/Network/IRC/Fun/Bot/Internal/Logger.hs b/src/Network/IRC/Fun/Bot/Internal/Logger.hs --- a/src/Network/IRC/Fun/Bot/Internal/Logger.hs +++ b/src/Network/IRC/Fun/Bot/Internal/Logger.hs @@ -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 diff --git a/src/Network/IRC/Fun/Bot/Internal/Monad.hs b/src/Network/IRC/Fun/Bot/Internal/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Network/IRC/Fun/Bot/Internal/Monad.hs @@ -0,0 +1,61 @@ +{- This file is part of irc-fun-bot. + - + - Written in 2015 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Network/IRC/Fun/Bot/Internal/MsgCount.hs b/src/Network/IRC/Fun/Bot/Internal/MsgCount.hs --- a/src/Network/IRC/Fun/Bot/Internal/MsgCount.hs +++ b/src/Network/IRC/Fun/Bot/Internal/MsgCount.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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 diff --git a/src/Network/IRC/Fun/Bot/Internal/Nicks.hs b/src/Network/IRC/Fun/Bot/Internal/Nicks.hs --- a/src/Network/IRC/Fun/Bot/Internal/Nicks.hs +++ b/src/Network/IRC/Fun/Bot/Internal/Nicks.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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 diff --git a/src/Network/IRC/Fun/Bot/Internal/Persist.hs b/src/Network/IRC/Fun/Bot/Internal/Persist.hs --- a/src/Network/IRC/Fun/Bot/Internal/Persist.hs +++ b/src/Network/IRC/Fun/Bot/Internal/Persist.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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 diff --git a/src/Network/IRC/Fun/Bot/Internal/State.hs b/src/Network/IRC/Fun/Bot/Internal/State.hs --- a/src/Network/IRC/Fun/Bot/Internal/State.hs +++ b/src/Network/IRC/Fun/Bot/Internal/State.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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 diff --git a/src/Network/IRC/Fun/Bot/Internal/Types.hs b/src/Network/IRC/Fun/Bot/Internal/Types.hs --- a/src/Network/IRC/Fun/Bot/Internal/Types.hs +++ b/src/Network/IRC/Fun/Bot/Internal/Types.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -13,10 +13,28 @@ - . -} +{-# 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 \ and value \ -- 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 () diff --git a/src/Network/IRC/Fun/Bot/State.hs b/src/Network/IRC/Fun/Bot/State.hs --- a/src/Network/IRC/Fun/Bot/State.hs +++ b/src/Network/IRC/Fun/Bot/State.hs @@ -35,6 +35,8 @@ , channelSelected , botMemberOf , addChannelState + , defRespEnabled + , setDefResp , saveBotState ) where diff --git a/src/Network/IRC/Fun/Bot/Types.hs b/src/Network/IRC/Fun/Bot/Types.hs --- a/src/Network/IRC/Fun/Bot/Types.hs +++ b/src/Network/IRC/Fun/Bot/Types.hs @@ -1,6 +1,6 @@ {- This file is part of irc-fun-bot. - - - Written in 2015 by fr33domlover . + - Written in 2015, 2016 by fr33domlover . - - ♡ 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 (..)) diff --git a/src/Network/IRC/Fun/Bot/Util.hs b/src/Network/IRC/Fun/Bot/Util.hs deleted file mode 100644 --- a/src/Network/IRC/Fun/Bot/Util.hs +++ /dev/null @@ -1,50 +0,0 @@ -{- This file is part of irc-fun-bot. - - - - Written in 2015 by fr33domlover . - - - - ♡ 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 - - . - -} - --- | 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)