From 94df5fb8f2a1dacd1cf9c5d214e950af7418142f Mon Sep 17 00:00:00 2001 From: Joscha Date: Fri, 23 Feb 2018 20:23:14 +0000 Subject: [PATCH] Restructure modules This should hopefully make it easier to create bots. --- src/EuphApi.hs | 9 ++ src/EuphApi/Bot.hs | 22 ++-- src/EuphApi/Utils.hs | 209 +--------------------------------- src/EuphApi/Utils/Botrulez.hs | 28 ++--- src/EuphApi/Utils/Commands.hs | 119 +++++++++++++++++++ src/EuphApi/Utils/Misc.hs | 89 +++++++++++++++ test/bot_with_botrulez.hs | 34 +++--- 7 files changed, 265 insertions(+), 245 deletions(-) create mode 100644 src/EuphApi.hs create mode 100644 src/EuphApi/Utils/Commands.hs create mode 100644 src/EuphApi/Utils/Misc.hs diff --git a/src/EuphApi.hs b/src/EuphApi.hs new file mode 100644 index 0000000..8f4b603 --- /dev/null +++ b/src/EuphApi.hs @@ -0,0 +1,9 @@ +module EuphApi + ( module EuphApi.Bot + , module EuphApi.Types + , module EuphApi.Utils + ) where + +import EuphApi.Bot +import EuphApi.Types +import EuphApi.Utils diff --git a/src/EuphApi/Bot.hs b/src/EuphApi/Bot.hs index 5084d7b..f13af03 100644 --- a/src/EuphApi/Bot.hs +++ b/src/EuphApi/Bot.hs @@ -4,14 +4,8 @@ -- | This module lets you create bots, although it only contains the bare minimum necessary. -- It defines the 'Bot' monad which takes care of a few things common to most bots. -- --- The module is meant to be imported qualified, under a different name than all the --- other EuphApi modules. --- For example: --- --- > import qualified EuphApi.Bot as B --- > import qualified EuphApi.Connection as E --- > import qualified EuphApi.Types as E --- > import qualified EuphApi.Utils as E +-- The module exports some types from "EuphApi.Connection" for convenience. +-- Don't import both modules unless you know what you're doing. -- -- = The 'Bot' monad -- @@ -94,9 +88,17 @@ module EuphApi.Bot ( , who -- * Exceptions , BotException(..) + -- * Misc + , E.EventType(..) + , E.Event(..) ) where -- TODO: Add 'AuthenticationFailed' exception. +-- TODO: Reorganize library: +-- - export events from Bot module +-- - add EuphApi module to export Bot module and some other convenience modules, +-- and to introduce people to the different parts of the library +-- - maybe separate utils into more modules and have Utils import some of them import Control.Concurrent import Control.Exception @@ -276,8 +278,8 @@ runBot ioConfig = do config <- ioConfig result <- runBotOnce config case result of - Stopping -> void $ noticeM "Bot has stopped." - Restarting -> noticeM "Bot has restarted." >> runBot ioConfig + Stopping -> void $ noticeM "Bot has stopped." + Restarting -> noticeM "Bot has restarted." >> runBot ioConfig reconnect :: Integer -> Bot b c ExitState reconnect retries = do diff --git a/src/EuphApi/Utils.hs b/src/EuphApi/Utils.hs index cb40fcf..930ce56 100644 --- a/src/EuphApi/Utils.hs +++ b/src/EuphApi/Utils.hs @@ -1,206 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Some useful functions for bots. - -module EuphApi.Utils ( - -- * Nick manipulation - mention - , atMention - , mentionReduce - , similar - -- * Time manipulation - , printUTCTime - , printNominalDiffTime - , printUptime - -- * Commands - , Command - , CommandName - , runCommands - -- ** Creating commands - , command - , specificCommand - , commandFromParser - -- ** Useful parsers - , mentionParser - , atMentionParser - , commandParser - , specificCommandParser +module EuphApi.Utils + ( module EuphApi.Utils.Misc + , module EuphApi.Utils.Commands ) where -import Control.Monad -import Data.Char -import Data.Function -import Data.Void - -import qualified Data.Text as T -import Data.Time -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P - -import qualified EuphApi.Bot as B -import qualified EuphApi.Types as E - -{- - - Nick manipulation - -} - --- | Convert a nick to an @-mentionable version. --- Use this function when you want to @-mention somebody. --- --- This removes spaces and some extra characters, while trying to stay close to --- the original nick. -mention :: T.Text -> T.Text -mention = T.filter (\c -> not (isSpace c) && notElem c (".!?;&<'\"" :: String)) - --- | Same as 'atMention', but prepends an `@` character. -atMention :: T.Text -> T.Text -atMention = T.cons '@' . mention - --- | Reduces a nick to a normal form such that all nicks that get @-mentioned --- by the same @-mention are reduced to the same normal form. --- --- Use this function when you want to compare two nicks. -mentionReduce :: T.Text -> T.Text -mentionReduce = T.map toLower . mention - --- | Compare two nicks using 'mentionReduce'. -similar :: T.Text -> T.Text -> Bool -similar = (==) `on` mentionReduce - -{- - - Time manipulation - -} - --- | Convert a 'UTCTime' into a 'String' of the format: --- @yyyy-mm-dd HH:MM:SS UTC@. --- --- Example: @2018-02-13 20:43:33 UTC@ -printUTCTime :: UTCTime -> String -printUTCTime = formatTime defaultTimeLocale "%F %T %Z" - --- | Convert a 'NominalDiffTime' into a 'String' of the format: --- @[[[[w] d] h] m] s@ (weeks, days, hours, minutes, seconds) --- --- Examples: @3h 12m 55s@ and @4w 6d 1h 0m 0s@ -printNominalDiffTime :: NominalDiffTime -> String -printNominalDiffTime n = - let nr = abs $ round n :: Integer - (w, wr) = nr `quotRem` (60 * 60 * 24 * 7) - (d, dr) = wr `quotRem` (60 * 60 * 24 ) - (h, hr) = dr `quotRem` (60 * 60 ) - (m, s ) = hr `quotRem` 60 - ws = if w /= 0 then show w ++ "w " else "" - ds = if d /= 0 then show d ++ "d " else "" - hs = if h /= 0 then show h ++ "h " else "" - ms = if m /= 0 then show m ++ "m " else "" - ss = show s ++ "s" - sign = if n < 0 then "-" else "" - in sign ++ ws ++ ds ++ hs ++ ms ++ ss - --- | @printUptime start now@ converts the two times @start@ and @now@ --- into a string of the following format, according to the botrulez: --- --- @/me has been up since \ (\).@ --- --- Example: @/me has been up since 2018-02-13 20:43:33 UTC (3h 12m 55s).@ -printUptime :: UTCTime -> UTCTime -> String -printUptime start now = - let diff = diffUTCTime now start - upSince = printUTCTime start - upFor = printNominalDiffTime diff - in "/me has been up since " ++ upSince ++ " (" ++ upFor ++ ")." - -{- - - Commands - -} - --- | A simple function that is to be called with the content of received messages. --- --- If you just want to add a simple command, see 'command' and 'specificCommand'. --- For more flexibility/more regex-like functionality, see 'commandFromParser'. -type Command b c = E.Message -> B.Bot b c () - --- | Alias for the string after the @!@, for example: @\"help\"@ for the command: @!help@. -type CommandName = T.Text - --- | Runs a list of commands. -runCommands :: [Command b c] -> E.Message -> B.Bot b c () --- runCommands cs m = mapM_ B.fork $ map ($m) cs --- runCommands cs m = mapM_ B.fork $ cs <*> pure m --- runCommands cs = mapM_ B.fork . sequence cs -runCommands cs m = mapM_ (B.fork . ($m)) cs - -withNick :: (T.Text -> a) -> B.Bot b c a -withNick f = (f . E.sessName) <$> B.getOwnView - --- | Creates a 'Command' from a parser and a bot action. --- --- > commandFromParser parser action --- --- The parser is enclosed in a 'Bot' so that it may access the bot's current state, --- for example the bot's current nick. -commandFromParser :: (Ord e) - => B.Bot b c (P.Parsec e T.Text a) - -> (a -> E.Message -> B.Bot b c ()) - -> Command b c -commandFromParser p f m = do - let content = E.msgContent m - parser <- p - forM_ (P.parseMaybe parser content) (`f` m) - -type Parser = P.Parsec Void T.Text - --- | Creates a general command: @!command@ --- --- If you want to parse arguments too, use 'commandFromParser' --- and write your own parser using 'commandParser'. -command :: T.Text -> (E.Message -> B.Bot b c ()) -> Command b c -command c f = - commandFromParser (return (commandParser c :: Parser () )) - (const f) - --- | Creates a specific command: @!command \@botname@ --- --- If you want to parse arguments too, use 'commandFromParser' --- and write your own parser using 'specificCommandParser'. -specificCommand :: T.Text -> (E.Message -> B.Bot b c ()) -> Command b c -specificCommand c f = - commandFromParser (withNick (specificCommandParser c :: T.Text -> Parser () )) - (const f) - -{- - - Parsers - -} - --- | Parse a mention (without the @\@@). --- --- This parser basically parses all non-space characters until the next space --- or end of input: --- --- @'P.takeWhile1P' (Just \"non-space character\") (not . 'isSpace')@ -mentionParser :: (Ord e) => P.Parsec e T.Text T.Text -mentionParser = P.label "mention" - $ P.takeWhile1P (Just "non-space character") (not . isSpace) - --- | Similar to 'mentionParser', but includes the @\@@. -atMentionParser :: (Ord e) => P.Parsec e T.Text T.Text -atMentionParser = P.label "atMention" $ P.char '@' *> mentionParser - --- | Parse a general command: @!command@ -commandParser :: (Ord e) => T.Text -> P.Parsec e T.Text () -commandParser c = P.label "command" $ do - P.space - void $ P.char '!' >> P.string c -- command - P.space - P.eof - --- | Parse a specific command: @!command \@botname@ -specificCommandParser :: (Ord e) => T.Text -> T.Text -> P.Parsec e T.Text () -specificCommandParser c nick = P.label "specific command" $ do - P.space - void $ P.char '!' >> P.string c -- command - P.space1 -- separator - m <- atMentionParser -- @mention - guard $ m `similar` nick - P.space - P.eof +import EuphApi.Utils.Commands +import EuphApi.Utils.Misc diff --git a/src/EuphApi/Utils/Botrulez.hs b/src/EuphApi/Utils/Botrulez.hs index 0b338cb..a9c9336 100644 --- a/src/EuphApi/Utils/Botrulez.hs +++ b/src/EuphApi/Utils/Botrulez.hs @@ -22,7 +22,7 @@ import Control.Monad.IO.Class import qualified Data.Text as T import Data.Time -import qualified EuphApi.Bot as B +import qualified EuphApi.Bot as E import qualified EuphApi.Types as E import qualified EuphApi.Utils as E @@ -33,14 +33,14 @@ import qualified EuphApi.Utils as E -- Bots __should implement__ this command. pingCommand :: T.Text -> E.Command b c pingCommand pingText = E.specificCommand "ping" $ \msg -> - void $ B.reply (E.msgID msg) pingText + void $ E.reply (E.msgID msg) pingText -- | General version of 'pingCommand': @!ping@ -- -- Bots __should implement__ this command. generalPingCommand :: T.Text -> E.Command b c generalPingCommand pingText = E.command "ping" $ \msg -> - void $ B.reply (E.msgID msg) pingText + void $ E.reply (E.msgID msg) pingText -- | Specific help command: @!help \@botname@ -- @@ -49,7 +49,7 @@ generalPingCommand pingText = E.command "ping" $ \msg -> -- Bots __should implement__ this command. helpCommand :: T.Text -> E.Command b c helpCommand helpText = E.specificCommand "help" $ \msg -> - void $ B.reply (E.msgID msg) helpText + void $ E.reply (E.msgID msg) helpText -- | General version of 'helpCommand': @!help@ -- @@ -58,13 +58,13 @@ helpCommand helpText = E.specificCommand "help" $ \msg -> -- Bots __may implement__ this command. generalHelpCommand :: T.Text -> E.Command b c generalHelpCommand helpText = E.command "help" $ \msg -> - void $ B.reply (E.msgID msg) helpText + void $ E.reply (E.msgID msg) helpText -uptime :: E.Message -> B.Bot b c () +uptime :: E.Message -> E.Bot b c () uptime msg = do - startTime <- B.getStartTime + startTime <- E.getStartTime curTime <- liftIO getCurrentTime - void $ B.reply (E.msgID msg) (T.pack $ E.printUptime startTime curTime) + void $ E.reply (E.msgID msg) (T.pack $ E.printUptime startTime curTime) -- | Specific uptime command: @!uptime \@botname@ -- @@ -88,12 +88,12 @@ generalUptimeCommand = E.command "uptime" uptime -- Bots __may implement__ this command. killCommand :: T.Text -> E.Command b c killCommand t = E.specificCommand "kill" $ \msg -> do - void $ B.reply (E.msgID msg) t - B.stop + void $ E.reply (E.msgID msg) t + E.stop -- | Version of 'killCommand' where the bot does not reply to the message which kills it. killCommandSilent :: E.Command b c -killCommandSilent = E.specificCommand "kill" $ const B.stop +killCommandSilent = E.specificCommand "kill" $ const E.stop -- | Specific restart command: @!restart \@botname@ -- @@ -103,10 +103,10 @@ killCommandSilent = E.specificCommand "kill" $ const B.stop -- Bots __may implement__ this command. restartCommand :: T.Text -> E.Command b c restartCommand t = E.specificCommand "restart" $ \msg -> do - void $ B.reply (E.msgID msg) t - B.restart + void $ E.reply (E.msgID msg) t + E.restart -- | Version of 'restartCommand' where the bot does not reply to the message -- which restarts it. restartCommandSilent :: E.Command b c -restartCommandSilent = E.specificCommand "restart" $ const B.restart +restartCommandSilent = E.specificCommand "restart" $ const E.restart diff --git a/src/EuphApi/Utils/Commands.hs b/src/EuphApi/Utils/Commands.hs new file mode 100644 index 0000000..e2c25bb --- /dev/null +++ b/src/EuphApi/Utils/Commands.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} + +module EuphApi.Utils.Commands + ( Command + , CommandName + , runCommands + -- * Creating commands + , command + , specificCommand + , commandFromParser + -- * Useful parsers + , mentionParser + , atMentionParser + , commandParser + , specificCommandParser + ) where + +import Control.Monad +import Data.Char +import Data.Void + +import qualified Data.Text as T +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P + +import qualified EuphApi.Bot as E +import qualified EuphApi.Types as E +import qualified EuphApi.Utils.Misc as E + +-- | A simple function that is to be called with the content of received messages. +-- +-- If you just want to add a simple command, see 'command' and 'specificCommand'. +-- For more flexibility/more regex-like functionality, see 'commandFromParser'. +type Command b c = E.Message -> E.Bot b c () + +-- | Alias for the string after the @!@, for example: @\"help\"@ for the command: @!help@. +type CommandName = T.Text + +-- | Runs a list of commands. +runCommands :: [Command b c] -> E.Message -> E.Bot b c () +-- runCommands cs m = mapM_ E.fork $ map ($m) cs +-- runCommands cs m = mapM_ E.fork $ cs <*> pure m +-- runCommands cs = mapM_ E.fork . sequence cs +runCommands cs m = mapM_ (E.fork . ($m)) cs + +withNick :: (T.Text -> a) -> E.Bot b c a +withNick f = (f . E.sessName) <$> E.getOwnView + +-- | Creates a 'Command' from a parser and a bot action. +-- +-- > commandFromParser parser action +-- +-- The parser is enclosed in a 'E.Bot' so that it may access the bot's current state, +-- for example the bot's current nick. +commandFromParser :: (Ord e) + => E.Bot b c (P.Parsec e T.Text a) + -> (a -> E.Message -> E.Bot b c ()) + -> Command b c +commandFromParser p f m = do + let content = E.msgContent m + parser <- p + forM_ (P.parseMaybe parser content) (`f` m) + +type Parser = P.Parsec Void T.Text + +-- | Creates a general command: @!command@ +-- +-- If you want to parse arguments too, use 'commandFromParser' +-- and write your own parser using 'commandParser'. +command :: T.Text -> (E.Message -> E.Bot b c ()) -> Command b c +command c f = + commandFromParser (return (commandParser c :: Parser () )) + (const f) + +-- | Creates a specific command: @!command \@botname@ +-- +-- If you want to parse arguments too, use 'commandFromParser' +-- and write your own parser using 'specificCommandParser'. +specificCommand :: T.Text -> (E.Message -> E.Bot b c ()) -> Command b c +specificCommand c f = + commandFromParser (withNick (specificCommandParser c :: T.Text -> Parser () )) + (const f) + +{- + - Parsers + -} + +-- | Parse a mention (without the @\@@). +-- +-- This parser basically parses all non-space characters until the next space +-- or end of input: +-- +-- @'P.takeWhile1P' (Just \"non-space character\") (not . 'isSpace')@ +mentionParser :: (Ord e) => P.Parsec e T.Text T.Text +mentionParser = P.label "mention" + $ P.takeWhile1P (Just "non-space character") (not . isSpace) + +-- | Similar to 'mentionParser', but includes the @\@@. +atMentionParser :: (Ord e) => P.Parsec e T.Text T.Text +atMentionParser = P.label "atMention" $ P.char '@' *> mentionParser + +-- | Parse a general command: @!command@ +commandParser :: (Ord e) => T.Text -> P.Parsec e T.Text () +commandParser c = P.label "command" $ do + P.space + void $ P.char '!' >> P.string c -- command + P.space + P.eof + +-- | Parse a specific command: @!command \@botname@ +specificCommandParser :: (Ord e) => T.Text -> T.Text -> P.Parsec e T.Text () +specificCommandParser c nick = P.label "specific command" $ do + P.space + void $ P.char '!' >> P.string c -- command + P.space1 -- separator + m <- atMentionParser -- @mention + guard $ m `E.similar` nick + P.space + P.eof diff --git a/src/EuphApi/Utils/Misc.hs b/src/EuphApi/Utils/Misc.hs new file mode 100644 index 0000000..41c3e0c --- /dev/null +++ b/src/EuphApi/Utils/Misc.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} + +module EuphApi.Utils.Misc ( + -- * Nick manipulation + mention + , atMention + , mentionReduce + , similar + -- * Time manipulation + , printUTCTime + , printNominalDiffTime + , printUptime + ) where + +import Data.Char +import Data.Function + +import qualified Data.Text as T +import Data.Time + +{- + - Nick manipulation + -} + +-- | Convert a nick to an @-mentionable version. +-- Use this function when you want to @-mention somebody. +-- +-- This removes spaces and some extra characters, while trying to stay close to +-- the original nick. +mention :: T.Text -> T.Text +mention = T.filter (\c -> not (isSpace c) && notElem c (".!?;&<'\"" :: String)) + +-- | Same as 'atMention', but prepends an `@` character. +atMention :: T.Text -> T.Text +atMention = T.cons '@' . mention + +-- | Reduces a nick to a normal form such that all nicks that get @-mentioned +-- by the same @-mention are reduced to the same normal form. +-- +-- Use this function when you want to compare two nicks. +mentionReduce :: T.Text -> T.Text +mentionReduce = T.map toLower . mention + +-- | Compare two nicks using 'mentionReduce'. +similar :: T.Text -> T.Text -> Bool +similar = (==) `on` mentionReduce + +{- + - Time manipulation + -} + +-- | Convert a 'UTCTime' into a 'String' of the format: +-- @yyyy-mm-dd HH:MM:SS UTC@. +-- +-- Example: @2018-02-13 20:43:33 UTC@ +printUTCTime :: UTCTime -> String +printUTCTime = formatTime defaultTimeLocale "%F %T %Z" + +-- | Convert a 'NominalDiffTime' into a 'String' of the format: +-- @[[[[w] d] h] m] s@ (weeks, days, hours, minutes, seconds) +-- +-- Examples: @3h 12m 55s@ and @4w 6d 1h 0m 0s@ +printNominalDiffTime :: NominalDiffTime -> String +printNominalDiffTime n = + let nr = abs $ round n :: Integer + (w, wr) = nr `quotRem` (60 * 60 * 24 * 7) + (d, dr) = wr `quotRem` (60 * 60 * 24 ) + (h, hr) = dr `quotRem` (60 * 60 ) + (m, s ) = hr `quotRem` 60 + ws = if w /= 0 then show w ++ "w " else "" + ds = if d /= 0 then show d ++ "d " else "" + hs = if h /= 0 then show h ++ "h " else "" + ms = if m /= 0 then show m ++ "m " else "" + ss = show s ++ "s" + sign = if n < 0 then "-" else "" + in sign ++ ws ++ ds ++ hs ++ ms ++ ss + +-- | @printUptime start now@ converts the two times @start@ and @now@ +-- into a string of the following format, according to the botrulez: +-- +-- @/me has been up since \ (\).@ +-- +-- Example: @/me has been up since 2018-02-13 20:43:33 UTC (3h 12m 55s).@ +printUptime :: UTCTime -> UTCTime -> String +printUptime start now = + let diff = diffUTCTime now start + upSince = printUTCTime start + upFor = printNominalDiffTime diff + in "/me has been up since " ++ upSince ++ " (" ++ upFor ++ ")." diff --git a/test/bot_with_botrulez.hs b/test/bot_with_botrulez.hs index 7818db0..9b474a7 100644 --- a/test/bot_with_botrulez.hs +++ b/test/bot_with_botrulez.hs @@ -9,13 +9,13 @@ import qualified System.Log.Handler as LH import qualified System.Log.Handler.Simple as LH import qualified System.Log.Logger as L -import qualified EuphApi.Bot as B -import qualified EuphApi.Connection as E -import qualified EuphApi.Types as E -import qualified EuphApi.Utils as E +import qualified EuphApi as E import qualified EuphApi.Utils.Botrulez as E -myCommands :: [E.Command b c] +type Bot = E.Bot () () +type Command = E.Command () () + +myCommands :: [Command] myCommands = [ E.pingCommand "Pong!" , E.generalPingCommand "Pong!" @@ -27,20 +27,20 @@ myCommands = , E.restartCommand "brb" ] -myBotHandler :: E.EventType -> B.Bot b c () +myBotHandler :: E.EventType -> Bot () myBotHandler (E.EuphEvent (E.SendEvent msg)) = E.runCommands myCommands msg myBotHandler _ = return () -myBotConfig :: B.BotConfig () () -myBotConfig = B.BotConfig - { B.botAddress = "euphoria.io" - , B.botRoom = "test" - , B.botPassword = Nothing - , B.botNick = "EuphApi test bot" - , B.botHandler = myBotHandler - , B.botInfo = () - , B.botNewConnectionInfo = return () - , B.botReconnectPolicy = B.defaultReconnectPolicy +myBotConfig :: E.BotConfig () () +myBotConfig = E.BotConfig + { E.botAddress = "euphoria.io" + , E.botRoom = "test" + , E.botPassword = Nothing + , E.botNick = "EuphApi test bot" + , E.botHandler = myBotHandler + , E.botInfo = () + , E.botNewConnectionInfo = return () + , E.botReconnectPolicy = E.defaultReconnectPolicy } main = do @@ -49,4 +49,4 @@ main = do myFormattedHandler = LH.setFormatter myHandler myFormatter L.updateGlobalLogger L.rootLoggerName (L.setHandlers [myFormattedHandler]) L.updateGlobalLogger L.rootLoggerName (L.setLevel L.INFO) - B.runBot (return myBotConfig) + E.runBot (return myBotConfig)