funbot 0.2 → 0.3
raw patch · 18 files changed
+1130/−169 lines, 18 filesdep +containersdep ~irc-fun-botdep ~settings
Dependencies added: containers
Dependency ranges changed: irc-fun-bot, settings
Files
- NEWS +33/−0
- default-memos.json +1/−0
- default-settings.json +4/−0
- default-state.json +4/−0
- default-user-options.json +1/−0
- funbot.cabal +17/−4
- src/FunBot/Commands.hs +443/−97
- src/FunBot/Config.hs +20/−1
- src/FunBot/ExtHandlers.hs +4/−4
- src/FunBot/History.hs +119/−0
- src/FunBot/IrcHandlers.hs +46/−11
- src/FunBot/Memos.hs +12/−13
- src/FunBot/Settings.hs +108/−12
- src/FunBot/Sources/FeedWatcher.hs +1/−1
- src/FunBot/Types.hs +41/−12
- src/FunBot/UserOptions.hs +224/−0
- src/FunBot/Util.hs +10/−0
- src/Main.hs +42/−14
NEWS view
@@ -3,6 +3,39 @@ +funbot 0.3 -- 2015-10-17+========================++General, build and documentation changes:++* User options JSON state file+* New !info topics++New UIs, features and enhancements:++* New repo event announcement controls: !add-repo, !delete-repo+* Channel commands: !visit, !leave, !join+* Support "please" prefix in bot references+* Minimal quoting feature, !quote command+* Channel history display and user option control commands+* Accept private prefixed and ref+prefix commands+* Respond to "thanks"+* Support /me++Bug fixes:++* Warn when sending a memo from an untracked channel++Dependency changes:++* Add containers >= 0.5+* Require irc-fun-bot >= 0.4+* Require settings >= 0.2.1+++++ funbot 0.2 -- 2015-09-22 ========================
+ default-memos.json view
@@ -0,0 +1,1 @@+{}
+ default-settings.json view
@@ -0,0 +1,4 @@+{+ "repos" : {},+ "feeds" : {}+}
+ default-state.json view
@@ -0,0 +1,4 @@+{+ "chan-state" : {},+ "chans-join" : []+}
+ default-user-options.json view
@@ -0,0 +1,1 @@+{}
funbot.cabal view
@@ -1,5 +1,5 @@ name: funbot-version: 0.2+version: 0.3 synopsis: IRC bot for fun, learning, creativity and collaboration. description: One day an idea came up on the #freepost IRC channel: We didn't need much of@@ -28,7 +28,17 @@ copyright: ♡ Copying is an act of love. Please copy, reuse and share. category: Network build-type: Simple-extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS README.md+extra-source-files:+ AUTHORS+ ChangeLog+ COPYING+ INSTALL+ NEWS+ README.md+ default-memos.json+ default-settings.json+ default-state.json+ default-user-options.json cabal-version: >=1.10 source-repository head@@ -40,6 +50,7 @@ other-modules: FunBot.Commands , FunBot.Config , FunBot.ExtHandlers+ , FunBot.History , FunBot.IrcHandlers , FunBot.Memos , FunBot.Settings@@ -50,11 +61,13 @@ , FunBot.Sources.WebListener.Gogs , FunBot.Sources.WebListener.GitLab , FunBot.Types+ , FunBot.UserOptions , FunBot.Util -- other-extensions: build-depends: aeson , base >=4.7 && <5 , bytestring+ , containers >=0.5 , feed , feed-collect , funbot-ext-events@@ -62,11 +75,11 @@ , http-client >=0.4.19 , http-client-tls >=0.2.2 , http-listen- , irc-fun-bot >=0.3 && <0.4+ , irc-fun-bot >=0.4 && <0.5 , irc-fun-color , json-state , network-uri- , settings+ , settings >=0.2.1 , tagsoup >=0.13 , text , time
src/FunBot/Commands.hs view
@@ -21,18 +21,22 @@ import Control.Monad (unless) import Data.List (find, intercalate) import Data.Settings.Types (showOption)+import FunBot.History (quote) import FunBot.Memos (submitMemo) import FunBot.Settings import FunBot.Types (BotSession)+import FunBot.UserOptions import Network.IRC.Fun.Bot.Behavior import Network.IRC.Fun.Bot.Chat+import Network.IRC.Fun.Bot.State import Network.IRC.Fun.Bot.Types import Text.Printf (printf)+import Text.Read (readMaybe) -- | The main command set, the only one currently commandSet = CommandSet- { prefix = '!'- , commands =+ { csetPrefix = '!'+ , csetCommands = [ makeCmdHelp commandSet , cmdInfo , cmdEcho@@ -43,6 +47,19 @@ , cmdReset , cmdEnable , cmdDisable+ , cmdAddSpec+ , cmdDeleteSpec+ , cmdAddRepo+ , cmdDeleteRepo+ , cmdVisit+ , cmdJoin+ , cmdLeave+ , cmdQuote+ , cmdShowOpts+ , cmdEnableHistory+ , cmdDisableHistory+ , cmdSetLines+ , cmdEraseOpts ] } @@ -56,10 +73,10 @@ respondEcho _mchan _nick params send = send $ unwords params cmdEcho = Command- { names = ["echo"]- , respond = respondEcho- , help = "‘echo <text>’ - display the given text. Probably not a \- \useful command. Exists as an example and for testing."+ { cmdNames = ["echo"]+ , cmdRespond = respondEcho+ , cmdHelp = "‘echo <text>’ - display the given text. Probably not a \+ \useful command. Exists as an example and for testing." } -------------------------------------------------------------------------------@@ -69,34 +86,38 @@ -- Return a response function given a CommandSet respondHelp cset _mchan _nick [cname] send =- case find ((cname' `elem`) . names) $ commands cset of- Just cmd -> send $ help cmd+ case find ((cname' `elem`) . cmdNames) $ csetCommands cset of+ Just cmd -> send $ cmdHelp cmd ++ "\nCommand names: "- ++ listNames Nothing Nothing True (names cmd)+ ++ listNames Nothing Nothing True (cmdNames cmd) Nothing -> do succ <- respondSettingsHelp cname send unless succ $ send $ printf "No such command, or invalid settings path. \ \Maybe try just ‘%vhelp’ without a parameter."- (prefix cset)+ (csetPrefix cset) where cname' = case cname of [] -> cname- (c:cs) -> if c == prefix cset then cs else cname+ (c:cs) -> if c == csetPrefix cset then cs else cname respondHelp cset _mchan _nick _params send =- send $ help (makeCmdHelp cset)+ send $ cmdHelp (makeCmdHelp cset) ++ "\nAvailable commands: "- ++ listPrimaryNames (Just $ prefix cset) Nothing False (commands cset)+ ++ listPrimaryNames+ (Just $ csetPrefix cset)+ Nothing False+ (csetCommands cset) makeCmdHelp cset = Command- { names = ["help", "Help", "h", "?"]- , respond = respondHelp cset- , help = "‘help [<command> | <setting>]’ - display help for the given \- \command or settings option/section.\n\- \FunBot intends to provide interactive help, but some topics \- \may be missing. If that's the case, check out the user \- \manual (call ‘!info links’ for the URL) or ask in #freepost."+ { cmdNames = ["help", "Help", "h", "?"]+ , cmdRespond = respondHelp cset+ , cmdHelp =+ "‘help [<command> | <setting>]’ - display help for the given \+ \command or settings option/section. Also see ‘info’.\n\+ \FunBot intends to provide interactive help, but some topics \+ \may be missing. If that's the case, check out the user \+ \manual (call ‘!info links’ for the URL) or ask in #freepost." } -------------------------------------------------------------------------------@@ -104,49 +125,115 @@ -- Ask the bot to display some information ------------------------------------------------------------------------------- -respondInfo _mchan _nick ["intro"] send = send $- "I’m fpbot. An instance of funbot, written in Haskell. I run in #freepost \- \(and some extra channels). Developed in the Freepost community, I exist \- \for fun, collaboration and learning. But I also aim to provide useful \- \tools, in particular to Freepost and related projects and communities.\n\- \You can start by trying ‘!help’."-respondInfo _mchan _nick ["features"] send = send $- "This is a high-level list of features and subsystems I provide. It will \- \hopefully be kept up-to-date by updating it every time new features are \- \added.\n\- \• Help and information system (!help, !info)\n\- \• A settings system (!get, !set, etc.)\n\- \• Announcing commits in Git repositories\n\- \• Announcing RSS/Atom feed items\n\- \• Leaving memos (requires enabling nick tracking for the channel)\n\- \There is also an overview of the bot API features, useful to \- \contributors/developers, in the guide at \- \<http://rel4tion.org/projects/funbot/guide>."-respondInfo _mchan _nick ["contrib"] send = send $- "Thinking about contributing to my development? Opening a ticket, fixing \- \a bug, implementing a feature? Check out the project page at \- \<http://rel4tion.org/projects/funbot>, which links to the contribution \- \guide, to the tickets page and more."-respondInfo _mchan _nick ["copying"] send = send $- "♡ Copying is an act of love. Please copy, reuse and share me! \- \Grab a copy of me from <https://notabug.org/fr33domlover/funbot>."-respondInfo _mchan _nick ["links"] send = send $- "Website: http://rel4tion.org/projects/funbot\n\- \Code: https://notabug.org/fr33domlover/funbot\n\- \Tickets: http://rel4tion.org/projects/funbot/tickets\n\- \Roadmap: http://rel4tion.org/projects/funbot/ideas\n\- \Dev guide: http://rel4tion.org/projects/funbot/guide\n\- \User manual: http://rel4tion.org/projects/funbot/manual"-respondInfo mchan nick [arg] _send =- failBack mchan nick $ InvalidArg (Just 1) (Just arg)+topics =+ [ ( "intro"+ , "I’m fpbot. An instance of funbot, written in Haskell. I run in \+ \#freepost (and some extra channels). Developed in the Freepost \+ \community, I exist for fun, collaboration and learning. But I also \+ \aim to provide useful tools, in particular to Freepost and related \+ \projects and communities.\n\+ \You can start by trying ‘!help’."+ )+ , ( "features"+ , "This is a high-level list of features and subsystems I provide. It \+ \will hopefully be kept up-to-date by updating it every time new \+ \features are added.\n\+ \• Help and information system (!help, !info)\n\+ \• A settings system (!get, !set, etc.)\n\+ \• Announcing commits, tags, merge requests, etc. in Git \+ \repositories\n\+ \• Announcing RSS/Atom feed items\n\+ \• Leaving memos (requires enabling nick tracking for the channel)\n\+ \• Announcing titles of URLs\n\+ \• Logging and reporting channel activity\n\+ \• Accepting events via an HTTP API, e.g. pastes added to a paste \+ \bin\n\+ \There is also an overview of the bot API features, useful to \+ \contributors/developers, in the guide at \+ \<http://rel4tion.org/projects/funbot/guide>."+ )+ , ( "contrib"+ , "Thinking about contributing to my development? Opening a ticket, \+ \fixing a bug, implementing a feature? Check out the project page at \+ \<http://rel4tion.org/projects/funbot>, which links to the \+ \contribution guide, to the tickets page and more."+ )+ , ( "copying"+ , "♡ Copying is an act of love. Please copy, reuse and share me! Grab a \+ \copy of me from <https://notabug.org/fr33domlover/funbot>."+ )+ , ( "links"+ , "Website: http://rel4tion.org/projects/funbot\n\+ \Code: https://notabug.org/fr33domlover/funbot\n\+ \Tickets: http://rel4tion.org/projects/funbot/tickets\n\+ \Roadmap: http://rel4tion.org/projects/funbot/ideas\n\+ \Dev guide: http://rel4tion.org/projects/funbot/guide\n\+ \User manual: http://rel4tion.org/projects/funbot/manual"+ )+ , ( "git-ann"+ , "I can announce development related events, such as git commits and \+ \merge requests. To see the list of repos being announced and their \+ \settings, run ‘!get repos’. Each repo has a list of specifications, \+ \one per target channel (most projects announce to a single channel, \+ \some announce to two). You can modify the spec details using the \+ \settings system (!get, !set, etc.). To add a new spec (channel) to \+ \an existing repo, use the !add-spec command. To remove a spec, use \+ \!delete-spec. To add and remove repos, use !add-repo and \+ \!delete-repo respectively."+ )+ , ( "feeds"+ , "TODO"+ )+ , ( "memos"+ , "TODO"+ )+ , ( "channels"+ , "Using bot commands, you can ask me to leave and join channels. The \+ \list of channels I'm present in can therefore be controlled \+ \dynamically. However, there is also an additional list of channels \+ \in my configuration (in the source). Using !visit, you can ask me to \+ \briefly join a channel. But I won't remember it next time. To make \+ \me a permanent member, use !join. You can ask me to leave a channel \+ \using !leave."+ )+ , ( "chan-history"+ , "When you join a channel, I can send you the last messages sent there \+ \so that you’ll know what was happenig before you came. You can \+ \enable this per channel, and set the number of last messages you’d \+ \like to see per channel. Note that the number of messages you’ll get \+ \also depends on how many messages I myself remember for this \+ \purpose (which is set in the Config.hs source file). See \+ \‘!info user-options’ for usage instructions."+ )+ , ( "user-options"+ , "I keep private per-user options which affect our interaction. These \+ \options are /separate/ from the public settings system. The commands \+ \for managing them are available only in private messages to me, and \+ \don't work in IRC channels. You can view your preferences using \+ \!show-opts. Edit them using !enable-history, !disable-history and \+ \!set-history-lines. Reset them to defaults using !erase-opts."+ )+ , ( "quotes"+ , "See the !quote command. It works, but quotes aren’t being \+ \automatically published, so perhaps it isn’t very useful at the \+ \moment. Perhaps unless you setup the publishing yourself."+ )+ ]++respondInfo _mchan _nick [] send =+ send $ "Topics: " ++ intercalate ", " (map fst topics)+respondInfo mchan nick [arg] send =+ case lookup arg topics of+ Just msg -> send msg+ Nothing -> failBack mchan nick $ InvalidArg (Just 1) (Just arg) respondInfo mchan nick args _send =- failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)+ failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing cmdInfo = Command- { names = ["info", "i"]- , respond = respondInfo- , help = "‘info ( intro | features | contrib | copying | links)’ - \- \display information."+ { cmdNames = ["info", "i"]+ , cmdRespond = respondInfo+ , cmdHelp = "‘info’ - list topics. Also see ‘help’.\n\+ \‘info <topic>’ - display topic information." } -------------------------------------------------------------------------------@@ -161,27 +248,29 @@ failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing cmdPTell = Command- { names = ["tell", "ptell"]- , respond = respondTell True- , help = "‘tell <nick> <text>’ - leave a memo for a user to see later. \- \Memos can be sent to the recipient privately, or publicly \- \in the channel in which they were submitted. With this \- \command, the memo will be sent privately. If that isn't your \- \intention, see the ctell command."+ { cmdNames = ["tell", "ptell"]+ , cmdRespond = respondTell True+ , cmdHelp =+ "‘tell <nick> <text>’ - leave a memo for a user to see later. \+ \Memos can be sent to the recipient privately, or publicly \+ \in the channel in which they were submitted. With this \+ \command, the memo will be sent privately. If that isn't your \+ \intention, see the ctell command." } cmdCTell = Command- { names = ["ctell"]- , respond = respondTell False- , help = "‘tell <nick> <text>’ - leave a memo for a user to see later. \- \Memos can be sent to the recipient privately, or publicly \- \in the channel in which they were submitted. With this \- \command, the memo will be sent in the same way it was \- \submitted: If you submit it in a channel, it will be sent to \- \the recipient in the same channel. If you submit using a \- \private message to me, I will also send it privately to the \- \recipient.\n\- \If that isn't your intention, see the tell command."+ { cmdNames = ["ctell"]+ , cmdRespond = respondTell False+ , cmdHelp =+ "‘tell <nick> <text>’ - leave a memo for a user to see later. \+ \Memos can be sent to the recipient privately, or publicly \+ \in the channel in which they were submitted. With this \+ \command, the memo will be sent in the same way it was \+ \submitted: If you submit it in a channel, it will be sent to \+ \the recipient in the same channel. If you submit using a \+ \private message to me, I will also send it privately to the \+ \recipient.\n\+ \If that isn't your intention, see the tell command." } -------------------------------------------------------------------------------@@ -213,36 +302,293 @@ respondDisable = respondBool False cmdGet = Command- { names = ["get"]- , respond = respondGet- , help = "‘get <option>’ - get the value of a settings option at the \+ { cmdNames = ["get"]+ , cmdRespond = respondGet+ , cmdHelp = "‘get <option>’ - get the value of a settings option at the \ \given path" } cmdSet = Command- { names = ["set"]- , respond = respondSet- , help = "‘set <option> <value>’ - set a settings option at the given \- \path to the given value"+ { cmdNames = ["set"]+ , cmdRespond = respondSet+ , cmdHelp = "‘set <option> <value>’ - set a settings option at the \+ \given path to the given value" } cmdReset = Command- { names = ["reset"]- , respond = respondReset- , help = "‘reset <option>’ - set a settings option at the given path to \- \its default value"+ { cmdNames = ["reset"]+ , cmdRespond = respondReset+ , cmdHelp = "‘reset <option>’ - set a settings option at the given \+ \path to its default value" } cmdEnable = Command- { names = ["enable"]- , respond = respondEnable- , help = "‘enable <option>’ - set a settings option at the given path \- \to True"+ { cmdNames = ["enable"]+ , cmdRespond = respondEnable+ , cmdHelp = "‘enable <option>’ - set a settings option at the given \+ \path to True" } cmdDisable = Command- { names = ["disable"]- , respond = respondDisable- , help = "‘disable <option>’ - set a settings option at the given path \- \to False"+ { cmdNames = ["disable"]+ , cmdRespond = respondDisable+ , cmdHelp = "‘disable <option>’ - set a settings option at the given \+ \path to False"+ }++-------------------------------------------------------------------------------+-- Add-spec, delete-spec, add-repo, delete-repo commands+-- Manage git repo event announcement details+-------------------------------------------------------------------------------++respondAddSpec mchan nick [repo, owner, chan] send = do+ succ <- addPushAnnSpec repo owner chan+ if succ+ then send "Git event announcement spec added."+ else failBack mchan nick $ OtherFail "No such repo/owner pair found."+respondAddSpec mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 3)++cmdAddSpec = Command+ { cmdNames = ["add-spec"]+ , cmdRespond = respondAddSpec+ , cmdHelp = "‘add-spec <repo> <owner> <channel>’ - add a channel to \+ \which git repo events will be announced, with default \+ \settings"+ }++respondDeleteSpec mchan nick [repo, owner, num] send =+ case readMaybe num of+ Nothing -> failBack mchan nick $ InvalidArg (Just 3) (Just num)+ Just pos ->+ if pos < 1+ then failBack mchan nick $ InvalidArg (Just 3) (Just num)+ else do+ res <- deletePushAnnSpec repo owner (pos - 1)+ case res of+ Nothing -> send $ "Git event announcement spec "+ ++ num+ ++ " removed."+ Just False -> failBack mchan nick $ OtherFail+ "No such repo/owner pair found."+ Just True -> failBack mchan nick $ OtherFail+ "Spec number out of range."+respondDeleteSpec mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 3)++cmdDeleteSpec = Command+ { cmdNames = ["delete-spec"]+ , cmdRespond = respondDeleteSpec+ , cmdHelp = "‘delete-spec <repo> <owner> <num>’ - remove a git event \+ \announcement specification with the given index number \+ \(as found in the settings tree, i.e. starting from 1) \+ \from the given repo."+ }++invalid s = null s || '/' `elem` s++respondAddRepo mchan nick [repo, owner, chan] send+ | invalid repo =+ failBack mchan nick $ InvalidArg (Just 1) (Just repo)+ | invalid owner =+ failBack mchan nick $ InvalidArg (Just 2) (Just owner)+ | otherwise = do+ succ <- addRepo repo owner chan+ if succ+ then send "Git repo added."+ else failBack mchan nick $ OtherFail+ "This repo is already registered."+respondAddRepo mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 3)++cmdAddRepo = Command+ { cmdNames = ["add-repo"]+ , cmdRespond = respondAddRepo+ , cmdHelp = "‘add-repo <repo> <owner> <channel>’ - add a repo to \+ \announce its events in the given channel, with default \+ \settings."+ }++respondDeleteRepo mchan nick [repo, owner] send = do+ succ <- deleteRepo repo owner+ if succ+ then send "Git repo removed."+ else failBack mchan nick $ OtherFail "No such repo/owner pair found."+respondDeleteRepo mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)++cmdDeleteRepo = Command+ { cmdNames = ["delete-repo"]+ , cmdRespond = respondDeleteRepo+ , cmdHelp = "‘delete-repo <repo> <owner>’ - stop announcing events for \+ \the given repo and remove its settings."+ }++-------------------------------------------------------------------------------+-- Visit, join, leave commands+-- Manage bot channels+-------------------------------------------------------------------------------++respondVisit _mchan _nick [chan] send = do+ memb <- botMemberOf chan+ send $ if memb+ then "I'm already a member of that channel. I think. Trying anyway."+ else "Visiting " ++ chan+ joinChannel chan Nothing+respondVisit mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdVisit = Command+ { cmdNames = ["visit"]+ , cmdRespond = respondVisit+ , cmdHelp =+ "‘visit <channel>’ - ask the bot to join a given channel, \+ \without storing state. So the bot won't remember to join it \+ \next time and default settings will be used. This is useful \+ \for short tests perhaps. If you'd like the bot to become a \+ \permanent member, use !join."+ }++respondJoin _mchan _nick [chan] send = do+ memb <- botMemberOf chan+ sel <- channelSelected chan+ send $ if memb && sel+ then "I'm already a member of that channel. I think. Trying anyway."+ else "Becoming a member of " ++ chan+ joinChannel chan Nothing+ addChannel chan+respondJoin mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdJoin = Command+ { cmdNames = ["join"]+ , cmdRespond = respondJoin+ , cmdHelp =+ "‘join <channel>’ - ask the bot to join a given channel, and \+ \make them a permanent member, automatically joining on bot \+ \restart. You can use !leave to make the bot leave. To invite \+ \the bot just for a temporary session, use !visit."+ }++respondLeave Nothing _nick [] send = send "This works only in a channel."+respondLeave (Just chan) nick [] send = do+ unselectChannel chan+ send $ "Leaving the channel for now. Bye! o/"+ partChannel chan $ Just $ "Asked by " ++ nick ++ " to leave"+respondLeave mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 0)++cmdLeave = Command+ { cmdNames = ["leave"]+ , cmdRespond = respondLeave+ , cmdHelp =+ "‘leave’ - ask the bot to leave the current channel, i.e. the \+ \one in which this command has been used. If the channel was \+ \selected for auto-joining, it is now unselected."+ }++-------------------------------------------------------------------------------+-- Quote command+-- Record something someone said+-------------------------------------------------------------------------------++respondQuote (Just chan) _nick [target] _send = quote chan target+respondQuote Nothing _nick [_] _send = return ()+respondQuote mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdQuote = Command+ { cmdNames = ["quote"]+ , cmdRespond = respondQuote+ , cmdHelp = "‘quote <nick>’ - record the last message sent by <nick> \+ \in the channel. The list of past quotes is publicly \+ \available."+ }++-------------------------------------------------------------------------------+-- Show-opts, enable-history, disable-history, set-history-lines,+-- set-history-lines, erase-opts commands+-- Manage user options+-------------------------------------------------------------------------------++priv = "That command works only in private conversation with me."++looksLikeChan [] = False+looksLikeChan (c:cs) = c `elem` "#+!&"++notchan chan = chan ++ " doesn't look like a channel name."++respondShowOpts (Just _chan) _nick _args send = send priv+respondShowOpts Nothing nick [] _send = sendChannels nick+respondShowOpts Nothing nick [chan] send =+ if looksLikeChan chan+ then sendHistoryOpts nick chan+ else send $ notchan chan+respondShowOpts Nothing nick args _send =+ failToUser nick $ WrongNumArgsN (Just $ length args) Nothing++cmdShowOpts = Command+ { cmdNames = ["show-opts", "show-options"]+ , cmdRespond = respondShowOpts+ , cmdHelp =+ "‘show-opts’ - list channels for which you set history \+ \display options.\n\+ \‘show-opts <channel>’ - show history display options for the given \+ \channel."+ }++respondHistory _enable (Just _chan) _nick _args send = send priv+respondHistory enable Nothing nick [chan] send =+ if looksLikeChan chan+ then setEnabled nick chan enable+ else send $ notchan chan+respondHistory _enable Nothing nick args _send =+ failToUser nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdEnableHistory = Command+ { cmdNames = ["enable-history"]+ , cmdRespond = respondHistory True+ , cmdHelp = "‘enable-history <channel>’ - enable automatic history \+ \private display for the given channel."+ }++cmdDisableHistory = Command+ { cmdNames = ["disable-history"]+ , cmdRespond = respondHistory False+ , cmdHelp = "‘disable-history <channel>’ - disable automatic history \+ \private display for the given channel."+ }++respondSetLines (Just _chan) _nick _args send = send priv+respondSetLines Nothing nick [chan, len] send =+ if looksLikeChan chan+ then+ case readMaybe len of+ Nothing -> badLen+ Just n ->+ if n < 0+ then badLen+ else setMaxLines nick chan n+ else send $ notchan chan+ where+ badLen = failToUser nick $ InvalidArg (Just 2) (Just len)+respondSetLines Nothing nick args _send =+ failToUser nick $ WrongNumArgsN (Just $ length args) (Just 2)++cmdSetLines = Command+ { cmdNames = ["set-history-lines"]+ , cmdRespond = respondSetLines+ , cmdHelp = "‘set-history-lines <channel> <num>’ - set the maximal \+ \number of channel history lines to display."+ }++respondEraseOpts (Just _chan) _nick _args send = send priv+respondEraseOpts Nothing nick [] _send = eraseOpts nick+respondEraseOpts Nothing nick args _send =+ failToUser nick $ WrongNumArgsN (Just $ length args) (Just 0)++cmdEraseOpts = Command+ { cmdNames = ["erase-opts", "erase-options"]+ , cmdRespond = respondEraseOpts+ , cmdHelp = "‘erase-opts’ - reset all your options back to defaults." }
src/FunBot/Config.hs view
@@ -21,16 +21,20 @@ , feedVisitInterval , settingsFilename , memosFilename+ , userOptsFilename+ , maxHistoryLines+ , quoteDir ) where import Data.Time.Interval (time) import Data.Time.Units+import Network.IRC.Fun.Bot (defConfig) import Network.IRC.Fun.Bot.Types (Connection (..), Config (..)) stateSaveInterval = 3 :: Second -configuration = Config+configuration = defConfig { connection = Connection { server = "irc.freenode.net" , port = 6667@@ -44,6 +48,7 @@ , stateFile = "state/state.json" , saveInterval = time stateSaveInterval , botEventLogFile = "state/bot.log"+ , maxMsgChars = Just 400 } webListenerPort = 8998 :: Int@@ -63,3 +68,17 @@ -- to Git. Otherwise, this path is relative to the bot process working dir (or -- absolute), and Git won't be used. memosFilename = "state/memos.json"++-- | If you set a repo path in the configuration above ('stateRepo' field),+-- then this path is relative to that repo and the user options file will be+-- commited to Git. Otherwise, this path is relative to the bot process working+-- dir (or absolute), and Git won't be used.+userOptsFilename = "state/user-options.json"++-- | For channel, the last messages sent in it are kept in bot state. Currently+-- the use of this data is for collecting quotes of people's messages. This+-- value sets the number of latest messages to remember for each channel.+maxHistoryLines = 20 :: Int++-- | Directory in which to place channel quotes.+quoteDir = "state/quotes"
src/FunBot/ExtHandlers.hs view
@@ -117,7 +117,7 @@ sendToChannel chan lastCommit handler (GitPushEvent (Push branch commits)) = do- chans <- getStateS $ gitAnnChans . settings+ chans <- getStateS $ gitAnnChans . bsSettings case M.lookup (keyb branch) chans of Just specs -> let fmt = formatCommit (branchName branch) (branchRepo branch)@@ -133,7 +133,7 @@ "Ext handler: Git push for unregistered repo: " ++ show (keyb branch) handler (GitTagEvent tag) = do- chans <- getStateS $ gitAnnChans . settings+ chans <- getStateS $ gitAnnChans . bsSettings case M.lookup (keyt tag) chans of Just specs -> let msg = formatTag tag@@ -144,7 +144,7 @@ "Ext handler: Tag for unregistered repo: " ++ show (keyt tag) handler (MergeRequestEvent mr) = do- chans <- getStateS $ gitAnnChans . settings+ chans <- getStateS $ gitAnnChans . bsSettings case M.lookup (keym mr) chans of Just specs -> let msg = formatMR mr@@ -155,7 +155,7 @@ "Ext handler: MR for unregistered repo: " ++ show (keym mr) handler (NewsEvent item) = do- feeds <- getStateS $ watchedFeeds . settings+ feeds <- getStateS $ watchedFeeds . bsSettings let label = itemFeedLabel item case M.lookup label feeds of Just (_url, spec) ->
+ src/FunBot/History.hs view
@@ -0,0 +1,119 @@+{- This file is part of funbot.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- For irc-fun-color StyledString+{-# LANGUAGE OverloadedStrings #-}++module FunBot.History+ ( remember+ , quote+ , reportHistory+ )+where++import Control.Monad (liftM, unless)+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (find, mapM_)+import Data.Monoid ((<>))+import Data.Sequence ((|>), Seq, ViewL (..))+import FunBot.Config (maxHistoryLines, quoteDir)+import FunBot.Types+import FunBot.Util (getTimeStr)+import Network.IRC.Fun.Bot.Chat+import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Color+import Prelude hiding (mapM_)+import System.IO+import Text.Printf (printf)++import qualified Data.HashMap.Lazy as M+import qualified Data.Sequence as Q++tailQ :: Seq a -> Seq a+tailQ s =+ case Q.viewl s of+ EmptyL -> s+ _ :< t -> t++findLast :: (a -> Bool) -> Seq a -> Maybe a+findLast p s = fmap (Q.index s) $ Q.findIndexR p s++formatLine :: HistoryLine -> String+formatLine hl =+ let time = Purple #> Pure (hlTime hl ++ " UTC")+ sender =+ if hlAction hl+ then+ "* " <> Green #> Pure (hlNick hl)+ else+ Gray #> "<" <> Green #> Pure (hlNick hl) <> Gray #> ">"+ content = Pure $ hlMessage hl+ in encode $ time <> " " <> sender <> " " <> content++-- | Remember someone said something, for use later when quoting.+remember :: String -- ^ Channel+ -> String -- ^ User nickname+ -> String -- ^ Message+ -> Bool -- ^ Whether a /me action (True) or regular message (False)+ -> BotSession ()+remember chan nick msg action = do+ h <- getStateS bsHistory+ t <- getTimeStr+ let hl = HistoryLine+ { hlTime = t+ , hlNick = nick+ , hlMessage = msg+ , hlAction = action+ }+ shorten s = if Q.length s > maxHistoryLines then tailQ s else s+ hls' = case M.lookup chan h of+ Just hls -> shorten $ hls |> hl+ Nothing -> Q.singleton hl+ modifyState $ \ s -> s { bsHistory = M.insert chan hls' h }++-- | Record someone's last message as a quote.+quote :: String --+ -> String --+ -> BotSession ()+quote chan nick = do+ history <- getStateS bsHistory+ let sameNick hl = hlNick hl == nick+ case M.lookup chan history >>= findLast sameNick of+ Just hl -> do+ let file = quoteDir ++ "/server." ++ chan+ liftIO $ withFile file AppendMode $ \ h -> do+ hPutChar h '\n'+ hPutStrLn h $ hlTime hl+ hPutStrLn h nick+ hPutStrLn h $ hlMessage hl+ sendToChannel chan "Quote logged."+ Nothing -> sendToChannel chan "No recent messages by that user."++-- Send last channel messages to a user, for a specific channel.+reportHistory :: String -- ^ User nickname+ -> String -- ^ Channel+ -> Int -- ^ Maximal number of messages to send+ -> BotSession ()+reportHistory recip chan maxlen = do+ mhls <- liftM (M.lookup chan) $ getStateS bsHistory+ case mhls of+ Nothing -> return ()+ Just hlsAll -> do+ let lAll = Q.length hlsAll+ hls = Q.drop (lAll - maxlen) hlsAll+ l = Q.length hls+ unless (Q.null hls) $ do+ sendToUser recip $ printf "Last %v messages in %v:" l chan+ mapM_ (sendToUser recip . formatLine) hls
src/FunBot/IrcHandlers.hs view
@@ -20,6 +20,7 @@ ( handleBotMsg , handleJoin , handleMsg+ , handleAction , handleNickChange ) where@@ -28,8 +29,11 @@ import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Data.Char (toLower)-import Data.List (isPrefixOf)+import Data.List (isPrefixOf, stripPrefix)+import FunBot.History (remember, reportHistory) import FunBot.Memos (reportMemos, reportMemosAll)+import FunBot.Types (HistoryDisplay (..))+import FunBot.UserOptions (getUserHistoryOpts) import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.IRC.Fun.Bot.Chat (sendToChannel)@@ -47,22 +51,47 @@ waveWordsR :: [String] waveWordsR = ["o/", "O/", "0/"] +lastChars :: String+lastChars = ".!?"+ isHello :: String -> Bool isHello s = let s' = map toLower s in null s || s' `elem` helloWords- || init s' `elem` helloWords && last s' `elem` ".!?"+ || init s' `elem` helloWords && last s' `elem` lastChars -handleBotMsg chan nick msg- | isHello msg = sendToChannel chan $ "Hello, " ++ nick- | map toLower msg == "ping" = sendToChannel chan $ nick ++ ", pong"- | msg `elem` waveWordsL = sendToChannel chan $ nick ++ ": o/"- | msg `elem` waveWordsR = sendToChannel chan $ nick ++ ": \\o"- | otherwise = return ()+isPing :: String -> Bool+isPing s =+ case stripPrefix "ping" $ map toLower s of+ Just [] -> True+ Just [c] -> c `elem` lastChars+ _ -> False -handleJoin chan nick = reportMemos nick chan+isThanks :: String -> Bool+isThanks s =+ let slow = map toLower s+ in case (stripPrefix "thanks" slow, stripPrefix "thank you" slow) of+ (Nothing, Nothing) -> False+ _ -> True +sayHello chan nick msg+ | isHello msg = sendToChannel chan $ "Hello, " ++ nick+ | isPing msg = sendToChannel chan $ nick ++ ", pong"+ | isThanks msg = sendToChannel chan $ nick ++ ", you’re welcome!"+ | msg `elem` waveWordsL = sendToChannel chan $ nick ++ ": o/"+ | msg `elem` waveWordsR = sendToChannel chan $ nick ++ ": \\o"+ | otherwise = return ()++handleBotMsg chan nick msg full = do+ sayHello chan nick msg+ remember chan nick full False++handleJoin chan nick = do+ hd <- getUserHistoryOpts nick chan+ when (hdEnabled hd) $ reportHistory nick chan (hdMaxLines hd)+ reportMemos nick chan+ goodHost h = let n = B.length h suffix6 = B.drop (n - 6) h@@ -78,7 +107,7 @@ text = unwords $ words $ innerText range in if null text then Nothing else Just text -handleMsg chan _nick msg _mention = when ("http" `isPrefixOf` msg) $ do+sayTitle chan msg = when ("http" `isPrefixOf` msg) $ do manager <- liftIO $ newManager tlsManagerSettings let action = do request <- parseUrl msg@@ -93,7 +122,13 @@ getTitle = action `catch` handler etitle <- liftIO getTitle case etitle of- Right (Just title) -> sendToChannel chan $ '"' : title ++ "\""+ Right (Just title) -> sendToChannel chan $ '“' : title ++ "”" _ -> return ()++handleMsg chan nick msg _mention = do+ sayTitle chan msg+ remember chan nick msg False++handleAction chan nick msg _mention = remember chan nick msg True handleNickChange _old new = reportMemosAll new
src/FunBot/Memos.hs view
@@ -37,9 +37,9 @@ import Data.Time.Units (Second) import FunBot.Config (stateSaveInterval, configuration, memosFilename) import FunBot.Types-import FunBot.Util ((!?))+import FunBot.Util ((!?), getTimeStr) import Network.IRC.Fun.Bot.Chat (sendToChannel, sendToUser)-import Network.IRC.Fun.Bot.Nicks (isInChannel, presence)+import Network.IRC.Fun.Bot.Nicks (channelIsTracked, isInChannel, presence) import Network.IRC.Fun.Bot.State import Network.IRC.Fun.Bot.Types (Config (stateRepo)) import Network.IRC.Fun.Color@@ -50,19 +50,14 @@ ------------------------------------------------------------------------------- getMemos :: BotSession (M.HashMap String [Memo])-getMemos = getStateS memos+getMemos = getStateS bsMemos putMemos :: M.HashMap String [Memo] -> BotSession ()-putMemos ms = modifyState $ \ s -> s { memos = ms }+putMemos ms = modifyState $ \ s -> s { bsMemos = ms } modifyMemos :: (M.HashMap String [Memo] -> M.HashMap String [Memo]) -> BotSession ()-modifyMemos f = modifyState $ \ s -> s { memos = f $ memos s }--getTimeStr :: BotSession String-getTimeStr = do- getTime <- askTimeGetter- liftIO $ liftM snd getTime+modifyMemos f = modifyState $ \ s -> s { bsMemos = f $ bsMemos s } -- | Get a list of the memos saved for a user, in the order they were sent. getUserMemos :: String -- ^ User nickname@@ -144,9 +139,13 @@ -> Maybe String -- ^ Whether sent 'Just' in channel or in PM. -> String -- ^ Recipient nickname -> BotSession ()-confirm sender (Just chan) recip =+confirm sender (Just chan) recip = do sendToChannel chan $- printf "%v, your memo for %v has been saved." sender recip+ printf "%v, your memo for %v has been saved." sender recip+ t <- channelIsTracked chan+ unless t $ sendToChannel chan+ "Note that tracking of user joins and quits for this channel is \+ \currently disabled in bot settings." confirm sender Nothing recip = sendToUser sender $ printf "Your memo for %v has been saved." recip@@ -332,6 +331,6 @@ saveBotMemos :: BotSession () saveBotMemos = do- ms <- getStateS memos+ ms <- getStateS bsMemos save <- askEnvS saveMemos liftIO $ save ms
src/FunBot/Settings.hs view
@@ -25,18 +25,22 @@ , respondReset' , respondSettingsHelp , initTree+ , addPushAnnSpec+ , deletePushAnnSpec+ , addRepo+ , deleteRepo+ , addChannel , loadBotSettings , mkSaveBotSettings ) where import Control.Applicative-import Control.Monad (mzero)+import Control.Monad (liftM, mzero, unless) import Control.Monad.IO.Class (liftIO) import Data.Aeson hiding (encode) import Data.Bool (bool) import Data.Char (toLower)-import qualified Data.HashMap.Lazy as M import Data.JsonState import Data.List (intercalate, intersperse, isSuffixOf) import Data.Maybe (catMaybes, fromMaybe)@@ -44,7 +48,7 @@ import Data.Settings.Interface import Data.Settings.Option import Data.Settings.Route-import Data.Settings.Section (insert)+import Data.Settings.Section (deleteSub, insertSub, memberSub) import Data.Settings.Types import Data.Time.Units (Second) import FunBot.Config (stateSaveInterval, configuration, settingsFilename)@@ -57,14 +61,17 @@ import Network.IRC.Fun.Bot.Types (Config (stateRepo)) import Network.IRC.Fun.Color +import qualified Data.HashMap.Lazy as M+ instance MonadSettings BotSession Settings where- getSettings = getStateS settings+ getSettings = getStateS bsSettings - putSettings s = modifyState $ \ st -> st { settings = s }+ putSettings s = modifyState $ \ st -> st { bsSettings = s } - modifySettings f = modifyState $ \ st -> st { settings = f $ settings st }+ modifySettings f =+ modifyState $ \ st -> st { bsSettings = f $ bsSettings st } - getSTree = getStateS stree+ getSTree = getStateS bsSTree instance OptionValue Bool where readOption s@@ -301,8 +308,8 @@ -- Create a settings section for a git repo, given its name and owner as -- matched with the details sent to the web listener.-repoSec :: ((String, String), [PushAnnSpec]) -> (String, SettingsTree)-repoSec ((repo, owner), specs) =+repoSec :: (String, String) -> [PushAnnSpec] -> (String, SettingsTree)+repoSec (repo, owner) specs = ( repo ++ '/' : owner , Section { secOpts = M.empty@@ -390,6 +397,7 @@ getChans = nAnnChannels . getSpec getFields = nAnnFields . getSpec +-- Create a section for a channel chanSec :: String -> SettingsTree chanSec chan = Section { secOpts = M.fromList@@ -409,6 +417,7 @@ , secSubs = M.empty } +-- | Build initial settings tree, already inside the session initTree :: BotSession () initTree = do cstates <- getChannelState@@ -426,8 +435,8 @@ , ( "repos" , Section { secOpts = M.empty- , secSubs = M.fromList $ map repoSec $ M.toList $- gitAnnChans sets+ , secSubs = M.fromList $ map (uncurry repoSec) $+ M.toList $ gitAnnChans sets } ) , ( "feeds"@@ -438,7 +447,94 @@ ) ] }- modifyState $ \ s -> s { stree = tree }+ modifyState $ \ s -> s { bsSTree = tree }++-- | Append a new push ann spec to the settings and a matching tree under the+-- repo section. Return whether succeeded.+addPushAnnSpec :: String -> String -> String -> BotSession Bool+addPushAnnSpec repo owner chan = do+ repos <- liftM gitAnnChans getSettings+ case M.lookup (repo, owner) repos of+ Just specs -> do+ let specs' = specs ++ [defSpec]+ repos' = M.insert (repo, owner) specs' repos+ modifySettings $ \ s -> s { gitAnnChans = repos' }+ saveBotSettings+ let (name, sec) = repoSec (repo, owner) specs'+ ins = insertSub ["repos", name] sec+ modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+ return True+ Nothing -> return False+ where+ defSpec = PushAnnSpec chan (Reject []) False++-- | Remove a spec from a repo. Return 'Nothing' on success. Otherwise return+-- whether the error was repo not found ('False') or index too big ('True').+-- The position given is 0-based.+deletePushAnnSpec :: String -> String -> Int -> BotSession (Maybe Bool)+deletePushAnnSpec repo owner pos = do+ repos <- liftM gitAnnChans getSettings+ case M.lookup (repo, owner) repos of+ Just specs ->+ case splitAt pos specs of+ (l, []) -> return $ Just True+ (l, s:r) -> do+ let specs' = l ++ r+ repos' = M.insert (repo, owner) specs' repos+ modifySettings $ \ s -> s { gitAnnChans = repos' }+ saveBotSettings+ let (name, sec) = repoSec (repo, owner) specs'+ ins = insertSub ["repos", name] sec+ modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+ return Nothing+ Nothing -> return $ Just False++-- | Add a new repo to settings and tree. Return whether success, i.e. whether+-- the repo didn't exist and indeed a new one has been created.+addRepo :: String -> String -> String -> BotSession Bool+addRepo repo owner chan = do+ repos <- liftM gitAnnChans getSettings+ case M.lookup (repo, owner) repos of+ Just _ -> return False+ Nothing -> do+ let repos' = M.insert (repo, owner) [defSpec] repos+ modifySettings $ \ s -> s { gitAnnChans = repos' }+ saveBotSettings+ let (name, sec) = repoSec (repo, owner) [defSpec]+ ins = insertSub ["repos", name] sec+ modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+ return True+ where+ defSpec = PushAnnSpec chan (Reject []) False++-- | Remove a repo from settings and tree. Return whether success, i.e. whether+-- the repo did exist and indeed has been deleted.+deleteRepo :: String -> String -> BotSession Bool+deleteRepo repo owner = do+ repos <- liftM gitAnnChans getSettings+ if M.member (repo, owner) repos+ then do+ let repos' = M.delete (repo, owner) repos+ modifySettings $ \ s -> s { gitAnnChans = repos' }+ saveBotSettings+ let name = repo ++ '/' : owner+ del = deleteSub ["repos", name]+ modifyState $ \ s -> s { bsSTree = del $ bsSTree s }+ return True+ else return False++-- | Add a new channel to state and tree and to be joined from now on. If+-- already exists, nothing happens.+addChannel :: String -> BotSession ()+addChannel chan = do+ selectChannel chan+ addChannelState chan+ sets <- getSTree+ let route = ["channels", chan]+ unless (route `memberSub` sets) $ do+ let sec = chanSec chan+ ins = insertSub route sec+ modifyState $ \ s -> s { bsSTree = ins $ bsSTree s } showError :: SettingsError -> String showError (InvalidPath s) = s ++ " : Invalid path"
src/FunBot/Sources/FeedWatcher.hs view
@@ -43,7 +43,7 @@ logError logger err = logLine logger $ show err feeds state =- let l = M.toList $ watchedFeeds $ settings state+ let l = M.toList $ watchedFeeds $ bsSettings state f (label, (url, _spec)) = (label, url) in map f l
src/FunBot/Types.hs view
@@ -24,6 +24,9 @@ , SettingsOption , SettingsTree , Memo (..)+ , HistoryLine (..)+ , HistoryDisplay (..)+ , UserOptions (..) , BotState (..) , BotSession , ExtEventSource@@ -31,14 +34,14 @@ ) where +import Data.HashMap.Lazy (HashMap)+import Data.HashSet (HashSet)+import Data.Sequence (Seq) import Data.Settings.Types (Section (..), Option (..)) import Data.Time.Clock (UTCTime) import FunBot.ExtEvents (ExtEvent) import Network.IRC.Fun.Bot.Types (Session, EventSource, EventHandler) -import qualified Data.HashMap.Lazy as M-import qualified Data.HashSet as S- -- | Generic item filter data Filter a = Accept [a] | Reject [a] @@ -79,10 +82,10 @@ -- wrapper in the 'Session' monad which uses this with the settings -- stored in bot state, so you probably don't need this field directly. , saveSettings :: Settings -> IO ()- -- | An 'IO' action which schedules saving memos to disk. There is a- -- wrapper in the 'Session' monad which uses this with the memos- -- stored in bot state, so you probably don't need this field directly.- , saveMemos :: M.HashMap String [Memo] -> IO ()+ -- | Similarly for memos.+ , saveMemos :: HashMap String [Memo] -> IO ()+ -- | Similarly for user options.+ , saveUserOpts :: HashMap String UserOptions -> IO () -- | Filename for logging feed listener errors , feedErrorLogFile :: FilePath }@@ -90,9 +93,9 @@ -- | User-modifiable bot behavior settings data Settings = Settings { -- | Maps a Git repo name+owner to annoucement details- gitAnnChans :: M.HashMap (String, String) [PushAnnSpec]+ gitAnnChans :: HashMap (String, String) [PushAnnSpec] , -- | Maps a feed label to its URL and announcement details- watchedFeeds :: M.HashMap String (String, NewsAnnSpec)+ watchedFeeds :: HashMap String (String, NewsAnnSpec) } -- | Alias for the settings option type@@ -110,14 +113,40 @@ , memoContent :: String } +-- | A message sent previously by an IRC user into a channel.+data HistoryLine = HistoryLine+ { hlTime :: String+ , hlNick :: String+ , hlMessage :: String+ , hlAction :: Bool+ }++-- | History display options per channel+data HistoryDisplay = HistoryDisplay+ { -- | Whether channel history should be displayed+ hdEnabled :: Bool+ -- | Maximal number of messages to show+ , hdMaxLines :: Int+ }++-- | Per-user options, consider private user info+data UserOptions = UserOptions+ { -- | History display options per channel+ uoHistoryDisplay :: HashMap String HistoryDisplay+ }+ -- | Read-write custom bot state data BotState = BotState { -- | User-modifiable bot behavior settings- settings :: Settings+ bsSettings :: Settings -- | Settings tree and access definition for UI- , stree :: SettingsTree+ , bsSTree :: SettingsTree -- | Memos waiting for users to connect.- , memos :: M.HashMap String [Memo]+ , bsMemos :: HashMap String [Memo]+ -- | Per-channel last messages+ , bsHistory :: HashMap String (Seq HistoryLine)+ -- | Per-user options+ , bsUserOptions :: HashMap String UserOptions } -- | Shortcut alias for bot session monad
+ src/FunBot/UserOptions.hs view
@@ -0,0 +1,224 @@+{- This file is part of funbot.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- For JSON field names+{-# LANGUAGE OverloadedStrings #-}++module FunBot.UserOptions+ ( getUserHistoryOpts+ , sendHistoryOpts+ , sendChannels+ , setEnabled+ , setMaxLines+ , eraseOpts+ , loadUserOptions+ , mkSaveUserOptions+ , saveUserOptions+ )+where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (liftM, mzero)+import Control.Monad.IO.Class (liftIO)+import Data.Aeson+import Data.JsonState+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import FunBot.Config (stateSaveInterval, configuration, userOptsFilename)+import FunBot.Types+import Network.IRC.Fun.Bot.Chat (sendToUser)+import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Bot.Types (Config (stateRepo))+import Text.Printf (printf)++import qualified Data.HashMap.Lazy as M++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++defaultEnabled :: Bool+defaultEnabled = False++defaultMaxLines :: Int+defaultMaxLines = 10++defHistoryDisplay :: HistoryDisplay+defHistoryDisplay = HistoryDisplay+ { hdEnabled = defaultEnabled+ , hdMaxLines = defaultMaxLines+ }++defUserOpts :: UserOptions+defUserOpts = UserOptions+ { uoHistoryDisplay = M.empty }++getUserHistoryOpts :: String -- ^ User nickname+ -> String -- ^ Channel+ -> BotSession HistoryDisplay+getUserHistoryOpts nick chan = do+ opts <- getStateS bsUserOptions+ let user = M.lookup nick opts+ hdmap = fmap uoHistoryDisplay user+ mhd = hdmap >>= M.lookup chan+ return $ fromMaybe defHistoryDisplay mhd++-------------------------------------------------------------------------------+-- Command Implementation+-------------------------------------------------------------------------------++showEnabled :: Bool -> String+showEnabled True = "Enabled"+showEnabled False = "Disabled"++showMaxLines :: Int -> String+showMaxLines n = show n ++ " lines"++formatHistoryOpts :: String -> String -> Maybe HistoryDisplay -> String+formatHistoryOpts nick chan mhd =+ let defSuffix = " [default]"+ (enabled, maxLines) =+ case mhd of+ Nothing ->+ ( showEnabled defaultEnabled ++ defSuffix+ , showMaxLines defaultMaxLines ++ defSuffix+ )+ Just hd ->+ ( showEnabled $ hdEnabled hd+ , showMaxLines $ hdMaxLines hd+ )+ in printf "History display of %v for %v: %v, %v"+ chan nick enabled maxLines++modifyOpts :: String -- ^ User nickname+ -> String -- ^ Channel+ -> (HistoryDisplay -> HistoryDisplay) -- ^ Modification+ -> BotSession ()+modifyOpts nick chan f = do+ opts <- getStateS bsUserOptions+ let userPrev = M.lookupDefault defUserOpts nick opts+ hdmapPrev = uoHistoryDisplay userPrev+ hdPrev = M.lookupDefault defHistoryDisplay chan hdmapPrev+ hdNew = f hdPrev+ hdmapNew = M.insert chan hdNew hdmapPrev+ userNew = userPrev { uoHistoryDisplay = hdmapNew }+ optsNew = M.insert nick userNew opts+ modifyState $ \ s -> s { bsUserOptions = optsNew }+ saveUserOptions++-------------------------------------------------------------------------------+-- Commands+-------------------------------------------------------------------------------++sendHistoryOpts :: String -- ^ User nickname+ -> String -- ^ Channel+ -> BotSession ()+sendHistoryOpts nick chan = do+ opts <- getStateS bsUserOptions+ let user = M.lookup nick opts+ hdmap = fmap uoHistoryDisplay user+ mhd = hdmap >>= M.lookup chan+ sendToUser nick $ formatHistoryOpts nick chan mhd++sendChannels :: String -- ^ User nickname+ -> BotSession ()+sendChannels nick = do+ muser <- liftM (M.lookup nick) $ getStateS bsUserOptions+ let mhdmap = fmap uoHistoryDisplay muser+ mkeys = fmap M.keys mhdmap+ keys = fromMaybe [] mkeys+ l = if null keys+ then "(none)"+ else intercalate ", " keys+ sendToUser nick $ "Options stored for channels: " ++ l++setEnabled :: String -- ^ User nickname+ -> String -- ^ Channel+ -> Bool -- ^ Whether to enable (or disable)+ -> BotSession ()+setEnabled nick chan enabled = do+ modifyOpts nick chan $ \ hd -> hd { hdEnabled = enabled }+ sendToUser nick $+ printf "History display of %v: %v" chan (showEnabled enabled)++setMaxLines :: String -- ^ User nickname+ -> String -- ^ Channel+ -> Int -- ^ Number of lines+ -> BotSession ()+setMaxLines nick chan maxLines = do+ modifyOpts nick chan $ \ hd -> hd { hdMaxLines = maxLines }+ sendToUser nick $+ printf "History display length for %v: %v" chan (showMaxLines maxLines)++eraseOpts :: String -- ^ User nickname+ -> BotSession ()+eraseOpts nick = do+ opts <- getStateS bsUserOptions+ case M.lookup nick opts of+ Nothing -> sendToUser nick "You don't have stored options."+ Just user -> do+ modifyState $ \ s -> s { bsUserOptions = M.delete nick opts }+ saveUserOptions+ sendToUser nick "All your options have been reset to defaults."++-------------------------------------------------------------------------------+-- Persistence+-------------------------------------------------------------------------------++instance FromJSON HistoryDisplay where+ parseJSON (Object o) =+ HistoryDisplay <$>+ o .: "enabled" <*>+ o .: "max-lines"+ parseJSON _ = mzero++instance ToJSON HistoryDisplay where+ toJSON (HistoryDisplay enabled maxLines) = object+ [ "enabled" .= enabled+ , "max-lines" .= maxLines+ ]++instance FromJSON UserOptions where+ parseJSON (Object o) =+ UserOptions <$>+ o .: "history-display"+ parseJSON _ = mzero++instance ToJSON UserOptions where+ toJSON (UserOptions hd) = object+ [ "history-display" .= hd+ ]++loadUserOptions :: IO (M.HashMap String UserOptions)+loadUserOptions = do+ r <- loadState $ stateFilePath userOptsFilename (stateRepo configuration)+ case r of+ Left (False, e) -> error $ "Failed to read user options file: " ++ e+ Left (True, e) -> error $ "Failed to parse user options file: " ++ e+ Right s -> return s++mkSaveUserOptions :: IO (M.HashMap String UserOptions -> IO ())+mkSaveUserOptions =+ mkSaveStateChoose+ stateSaveInterval+ userOptsFilename+ (stateRepo configuration)+ "auto commit by funbot"++saveUserOptions :: BotSession ()+saveUserOptions = do+ opts <- getStateS bsUserOptions+ save <- askEnvS saveUserOpts+ liftIO $ save opts
src/FunBot/Util.hs view
@@ -18,11 +18,15 @@ , replaceMaybe , passes , passesBy+ , getTimeStr ) where +import Control.Monad (liftM)+import Control.Monad.IO.Class (liftIO) import Data.Maybe (listToMaybe) import FunBot.Types+import Network.IRC.Fun.Bot.State (askTimeGetter) -- | List index operator, starting from 0. Like @!!@ but returns a 'Maybe' -- instead of throwing an exception. On success, returns 'Just' the item. On@@ -48,3 +52,9 @@ passesBy :: (a -> a -> Bool) -> a -> Filter a -> Bool passesBy p v (Accept l) = any (p v) l passesBy p v (Reject l) = all (not . p v) l++-- | Get a string specifying the current UTC time using the time getter.+getTimeStr :: BotSession String+getTimeStr = do+ getTime <- askTimeGetter+ liftIO $ liftM snd getTime
src/Main.hs view
@@ -16,49 +16,75 @@ module Main (main) where import Control.Monad.IO.Class (liftIO)-import qualified Data.HashMap.Lazy as M (empty) import Data.Settings.Section (empty) import FunBot.Commands (commandSet)-import qualified FunBot.Config as C import FunBot.ExtHandlers (handler)-import qualified FunBot.IrcHandlers as H import FunBot.Memos import FunBot.Settings import FunBot.Sources import FunBot.Types+import FunBot.UserOptions import Network.IRC.Fun.Bot (runBot) import Network.IRC.Fun.Bot.Behavior (defaultBehavior) import Network.IRC.Fun.Bot.EventMatch-import Network.IRC.Fun.Bot.Types (Behavior (..))+import Network.IRC.Fun.Bot.Types (Behavior (..), EventMatchSpace (..)) +import qualified Data.HashMap.Lazy as M (empty)+import qualified FunBot.Config as C+import qualified FunBot.IrcHandlers as H+ -- | Bot environment content-env saveS saveM = BotEnv+env saveS saveM saveUO = BotEnv { webHookSourcePort = C.webListenerPort , saveSettings = saveS , saveMemos = saveM+ , saveUserOpts = saveUO , feedErrorLogFile = C.feedErrorLogFile } -- | Initial content of the bot state-initialState sets ms = BotState- { settings = sets- , stree = empty- , memos = ms+initialState sets ms userOpts = BotState+ { bsSettings = sets+ , bsSTree = empty+ , bsMemos = ms+ , bsHistory = M.empty+ , bsUserOptions = userOpts } -- | Event detector specification matchers =- [ matchPrefixedCommandC- , matchRefCommandFromSetC- , matchRefCommandFromNamesP ["help", "info", "echo", "tell", "get"]+ [ matchPrefixedCommand+ MatchInChannel+ True+ , matchPrefixedCommandFromNames+ MatchInPrivate+ True+ (Right commandSet)+ privCmds+ , matchRefCommandFromSet+ MatchInChannel+ modPleasePrefix'+ , matchRefCommandFromNames+ MatchInPrivate+ modPleasePrefix'+ True+ privCmds , matchRef+ MatchInBoth , defaultMatch ]+ where+ privCmds =+ [ "help", "info", "echo", "tell", "get", "show-opts", "enable-history"+ , "disable-history", "set-history-lines", "erase-opts"+ ] + -- | Bot behavior definition behavior = defaultBehavior { handleJoin = H.handleJoin , handleMsg = H.handleMsg+ , handleAction = H.handleAction , handleBotMsg = H.handleBotMsg , commandSets = [commandSet] , handleNickChange = H.handleNickChange@@ -74,15 +100,17 @@ liftIO $ putStrLn "Loading bot settings" sets <- loadBotSettings ms <- loadBotMemos+ uos <- loadUserOptions saveS <- mkSaveBotSettings saveM <- mkSaveBotMemos- let state = initialState sets ms+ saveUO <- mkSaveUserOptions+ let state = initialState sets ms uos runBot C.configuration matchers behavior (mkSources state) handler- (env saveS saveM)+ (env saveS saveM saveUO) state initTree