funbot 0.3 → 0.4
raw patch · 29 files changed
+1557/−359 lines, 29 filesdep +auto-updatedep +clockdep +data-default-classdep ~feed-collectdep ~irc-fun-botdep ~settings
Dependencies added: auto-update, clock, data-default-class
Dependency ranges changed: feed-collect, irc-fun-bot, settings
Files
- INSTALL +0/−13
- INSTALL.md +273/−0
- NEWS +0/−86
- NEWS.md +121/−0
- README.md +7/−16
- default-memos.json +0/−1
- default-settings.json +0/−4
- default-state.json +0/−4
- default-user-options.json +0/−1
- funbot.cabal +18/−13
- src/FunBot/Commands.hs +211/−34
- src/FunBot/Config.hs +20/−18
- src/FunBot/ExtHandlers.hs +54/−9
- src/FunBot/History.hs +61/−35
- src/FunBot/IrcHandlers.hs +95/−23
- src/FunBot/KnownNicks.hs +103/−0
- src/FunBot/Memos.hs +4/−4
- src/FunBot/Settings.hs +410/−52
- src/FunBot/Sources.hs +2/−0
- src/FunBot/Sources/FeedWatcher.hs +22/−17
- src/FunBot/Sources/Loopback.hs +40/−0
- src/FunBot/Types.hs +64/−18
- src/FunBot/UserOptions.hs +10/−4
- src/FunBot/Util.hs +12/−1
- src/Main.hs +19/−6
- state-default/memos.json +1/−0
- state-default/settings.json +5/−0
- state-default/state.json +4/−0
- state-default/user-options.json +1/−0
− INSTALL
@@ -1,13 +0,0 @@-Install from Hackage:-- $ cabal install funbot--Install from unpacked release tarball or source repo:-- $ cd funbot- $ cabal install--Just play with it without installing:-- $ cabal build- $ cabal repl
+ INSTALL.md view
@@ -0,0 +1,273 @@+# Intro++This guide explains how to create a setup for running and developing the bot.+Whether you want to just run it, or also develop it and test your changes, this+guide lists the steps.++Since one of the bot's goals is provide an introductory space for Haskell, it+details all the steps of starting to work with Haskell and provides honts. Even+if you're just starting, this guide is friendly and useful to follow.++# Programming Interface++Here is a quick summary of what the bot API offers. It is being developed and+more components will probably be added.++- Bot commands with multiple prefixes and multiple names+- Reaction to various events: joins, parts, private messages, etc.+- Can run in multiple IRC channels (but on a single IRC server)+- Bot commands can run any I/O (network, files, terminal, etc.)+- Bot commands can run any IRC commands: Join, part, notice, etc.+- Persistent state can be managed by the bot commands while the bot runs+- The state includes a hierarchical central settings system+- Extra event sources: Web listener, newsfeed watcher++# Haskell++If you already have the Haskell tools installed, you can skip this section.++The bot is written in Haskell, a functional programming language. A good place+to start learning it is the+[Haskell Wikibook](https://wikibooks.org/wiki/Haskell). The definition of+Haskell is published in the form of reports, the latest being+the [Haskell 2010 Report](http://haskell.org/onlinereport/haskell2010/). While+learning, and actually in general, a very useful resource to keep open in a+browser tab is the API reference of the `base` package,+[here](http://hackage.haskell.org/package/base#module-list).++To work with Haskell you'll need 2 primary tools:++1. GHC - a compiler, interpreter, package manager and more+2. Cabal - project manager for installing packages and packaging your own++You'll need to install them both. Preferrably *GHC 7.8.4* and+*cabal-install 1.22*. If you use a Debian based distro, you can install them+easily from a [PPA](http://launchpad.net/%7Ehvr/+archive/ghc). Trisquel should+import them for you, so all you need to do is apt-get install.++For Parabola, check the versions supplied by the distro's packages.+Instructions for more distros can be found online.++Add `~/.cabal/bin:/opt/cabal/1.22/bin:/opt/ghc/7.8.4/bin` to your PATH. For+example, add this to the bottom of your `.bashrc`:++ # add haskell programs to PATH+ export PATH=~/.cabal/bin:/opt/cabal/1.22/bin:/opt/ghc/7.8.4/bin:$PATH++The Haskell community has:++- IRC channels on Freenode: `#haskell`, `#haskell-beginners`+- [Mailing lists](https://haskell.org/mailing-lists)+- A [wiki](https://wiki.haskell.org)+- [Hackage](https://hackage.haskell.org), where people upload package releases++There are 3 types of package repositories you can maintain using Cabal:++- Global repository for the system. Install there stable programs you are+ going to use. This is like like installing distro packages. What you install+ there will be available to all users on your system (if you update their+ PATH too), like with distro packages.+- User repository just for your system user. You can install there packages you+ want to experiment with, or run without installing system-wide. By default,+ this is where `cabal install`ed packages go.+- Sandbox for package development. When you use and develop various Haskell+ packages, eventually you'll encounter version conflicts. You can avoid the+ mess by installing packages into separate sandboxes. When working on several+ packages together/with consistent dependencies, they can share a sandbox.++Update your list of packages:++ $ cabal update++# Installation++You can either use a release version, or the latest development version.++Create a directory for the bot:++ $ mkdir /home/joe/bot+ $ cd /home/joe/bot++The development version many require recent dependency versions which aren't+available on Hackage yet. If building fails, it's probably because you need+those recent versions. These commands will download the dependencies most+likely to be needed. In the same way you can download more.++If you'll be using the release version, there is no need for this.++Install Darcs, a version control system. The bot itself is in a Git repository,+but some of these dependencies are in Darcs repositories. You can either+download their files using regular HTTP, e.g. with `wget`) or use Darcs. Since+Darcs is a popular version control system for Haskell projects (and is itself+written in Haskell), the latter option is demonstrated below (just change the+Darcs specific lines if you chose the former option).++If your distro has a recent enough version (preferrably 2.8.5, maybe 2.8.4 will+work too):++ $ sudo apt-get install darcs++Otherwise install Darcs from Hackage:++ $ cabal install darcs-2.8.5++Get dependency source repos if/as needed:++ $ darcs get http://hub.darcs.net/fr33domlover/irc-fun-messages/+ $ darcs get http://hub.darcs.net/fr33domlover/irc-fun-client/+ $ darcs get http://hub.darcs.net/fr33domlover/irc-fun-bot/+ $ darcs get http://hub.darcs.net/fr33domlover/settings/+ $ git clone https://notabug.org/fr33domlover/funbot-ext-events++Get the bot itself:++ $ git clone https://notabug.org/fr33domlover/funbot.git++You now have the latest development version. You can switch to the latest+release version (use `git tag --list` to find out its number), e.g.:++ $ git checkout 0.3++Now your bot directory should look like this:++ $ ls /home/joe/bot+ funbot+ funbot-ext-events+ irc-fun-bot+ irc-fun-client+ irc-fun-messages+ settings++Create a sandbox:++ $ cd funbot+ $ cabal sandbox init++In order for all the extra packages to work in the sandbox, add the local+dependencies you downloaded (if any) as sources:++ $ cabal sandbox add-source ../irc-fun-messages+ $ cabal sandbox add-source ../irc-fun-client+ $ cabal sandbox add-source ../irc-fun-bot+ $ cabal sandbox add-source ../settings+ $ cabal sandbox add-source ../funbot-ext-events++Run `cabal install --only-dependencies` and `cabal build` to build funbot and+its dependencies in the sandbox.++# Configuration++The bot has state data in JSON files and in a Haskell source file,+`src/FunBot/Config.hs`.++Create initial state data:++ $ cd funbot+ $ cp -r state-default state++In the `Config.hs` file there are safe defaults you can use as-is, but you+should probably at least change the bot's nickname. See+[here](http://hackage.haskell.org/package/irc-fun-bot/docs/Network-IRC-Fun-Bot-Types.html#t:Config)+for documentation of the config options.++ $ vim src/FunBot/Config.hs++You'll need to rebuild the bot for changes in that file to take effect.++You can also customize the event matching and behavior definitions in+`src/Main.hs`.++If you make a git commit, make sure you don't commit your personal changes to+the configuration. In particular if you set a nickname password there!++Rebuild the bot:++ $ cabal build++Some features (like channel logs and quotes) place files in separate+subdirectories.++ $ mkdir state/chanlogs state/quotes++# Running and Exploring++Now you can do things like running it, debugging it, exploring it in the REPL+(i.e. interpreter).++To run the bot:++ $ cabal run++You can also run the executable directly:++ $ dist/build/funbot/funbot++To load the source into the GHCi, the REPL, and play/explore it:++ $ cabal repl++For the explorers, there is an IRC server package in Haskell,+[hulk](http://hackage.haskell.org/package/hulk). You could run the bot against+a locally running instance of the server.++# Deployment++The Git repository contains a shell script `run.sh` you can run in a cron job.+There is also a `supervisord` configuration file. See these files for details.+If you want to run the bot as a separate system user (and not as your own+user), the steps are:++1. Create a Linux system user with its own home directory. For example,+ `/var/lib/ircbot`+2. Edit its PATH (e.g. by creating minimal `.profile` and `.bashrc`) and+ install the setup as described above. But you don't need:+ - a Cabal sandbox. You can install to the new user's user package+ repository. Simply skip the sandbox creation steps.+ - Write access to the git repo. Clone the repositories using read-only+ access. It's safer not to give this new user write access to its own code,+ just in case anything bad happens.+3. Switch to the system user in the terminal and run the bot. Edit the+ configuration source file (nickname, password, channels, etc.). Setup the+ cron job.+4. When there are updates to the bot or its dependencies, `darcs pull` or+ `git pull` them, build/install and relaunch (e.g.+ `pkill funbot && dist/build/funbot/funbot &`)++# Collaboration++There are basically 3 ways to contribute code:++- If you prefer to have your code checked by someone else for any reason, you+ can create a merge request (i.e. work in a clone or branch).+- Or create a patch with `git format-patch`+- Otherwise, this project just gives commit access to any interested community+ member / contributor.++The details follow.++## Merge Requests++The steps are:++1. Create a branch with your changes+2. Open an issue containing the URL of the branch++The branch can be in:++- The upstream funbot repository at NotABug. Feature/wip branches can be added+ as needed.+- A repository in NotABug (e.g. your personal clone of funbot) or some other+ free-software hosting platform instance online. Merge requests from+ proprietary ones, such as githu8, won't be accepted. Please use NotABug or+ GNU savannah or Rel4tion's server or your own server or some other+ free-as-in-freedom option.++## Direct Commits++This means access to pushing to the `master` branch of the upstream repository.+Ask fr33domlover.++## Patches++Open an issue in NotABugwith the patch file attached (or post a link to it, if+you host it somewhere else).
− NEWS
@@ -1,86 +0,0 @@-This file lists the user-visible interesting changes between releases. For a-full list of changes to the source, see the ChangeLog.----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-========================--General, build and documentation changes:--* Some config values moved to Config.hs from other files-* Git repo details moved from Config.hs into JSON file--New UIs, features and enhancements:--* Git repo details have settings options and can be partially edited-* Help command now includes settings options-* New bot command !ctell-* Settings and memos JSON files support version control-* Report titles of URLs send into channels-* New external event type, paste--Bug fixes:--* Gitlab MR update events not announced to IRC, it's too much channel spam-* Memos are now reported if needed when a user changes their nickname--Dependency changes:--* Add funbot-ext-events-* Add json-state-* Require irc-fun-bot >= 0.3----funbot 0.1 -- 2015-09-11-========================--General, build and documentation changes:--* (This is the first release, so everything is new)--New UIs, features and enhancements:--* (This is the first release, so everything is a new feature)--Bug fixes:--* (This is just the first release)--Dependency changes:--* (This is the first release)
+ NEWS.md view
@@ -0,0 +1,121 @@+This file lists the user-visible interesting changes between releases. For a+full list of changes to the source, see the ChangeLog.++++funbot 0.4 -- 2015-12-17+========================++General, build and documentation changes:++* (None)++New UIs, features and enhancements:++* IRC debug log+* In git push reports, align ellipsis pseudo-commits with real ones+* New feature: Recognize and expand shortcuts in IRC channel messages+* New command !show-history to see channel history any time+* Message counting control settings option+* Colors in settings command output messages+* !add-feed and !delete-feed new commands+* More settings options to control feeds+* Saying titles on/off switch per channel+* Welcome new nicks++Bug fixes:++* (None)++Dependency changes:++* Add auto-update+ clocks >= 0.5+ data-default-class+* Require feed-collect >= 0.2+ irc-fun-bot >= 0.5+ settings >= 0.2.2++++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+========================++General, build and documentation changes:++* Some config values moved to Config.hs from other files+* Git repo details moved from Config.hs into JSON file++New UIs, features and enhancements:++* Git repo details have settings options and can be partially edited+* Help command now includes settings options+* New bot command !ctell+* Settings and memos JSON files support version control+* Report titles of URLs send into channels+* New external event type, paste++Bug fixes:++* Gitlab MR update events not announced to IRC, it's too much channel spam+* Memos are now reported if needed when a user changes their nickname++Dependency changes:++* Add funbot-ext-events+* Add json-state+* Require irc-fun-bot >= 0.3++++funbot 0.1 -- 2015-09-11+========================++General, build and documentation changes:++* (This is the first release, so everything is new)++New UIs, features and enhancements:++* (This is the first release, so everything is a new feature)++Bug fixes:++* (This is just the first release)++Dependency changes:++* (This is the first release)
README.md view
@@ -22,11 +22,11 @@ This program is free software, and is committed to software freedom. It is released to the public domain using the CC0 Public Domain Dedication. For the-boring "legal" details see the file 'COPYING'.+boring "legal" details see the file `COPYING`. -See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains-how to see the history log of the changes done in the code. 'NEWS' provides a-friendly overview of the changes for each release.+See the file `INSTALL.md` for a detailed usage and deployment guide. The file+`ChangeLog` explains how to see the history log of the changes done in the+code. `NEWS.md` provides a friendly overview of the changes for each release. ## Reporting Bugs and Suggesting Features @@ -34,25 +34,16 @@ open a ticket for it! Even if you're goint to implement something or try to solve it. -This project uses [Rel4tion][rel4tion]'s [ticket system][rel4tkt]. See the-[project page][proj] for details.--You *can* open an issue in NotABug if you prefer, and it will then be moved to-Rel4tion's ticket system. But it is generally preferred you use that system-directly.+Use NotABug's issue system. ## User/Contributor Guide There is a detailed guide for running the bot and creating a development setup.-It's [here][guide]. If anything happens and it's unavailable, there is a-(maybe lagging 1-2 hours behind) mirror of the guide source [here][mirror].+It's in the `INSTALL.md` file. If you're going to implement some feature or fix some bug you found,-**start by opening a ticket** so that other people will know which features are+**start by opening an issue** so that other people will know which features are being developed and who does what. [proj]: http://rel4tion.org/projects/funbot/ [rel4tion]: http://rel4tion.org/-[rel4tkt]: http://rel4tion.org/tickets/-[guide]: http://rel4tion.org/projects/funbot/guide/-[mirror]: https://notabug.org/fr33domlover/Rel4tion-Wiki/src/master/projects/funbot.mdwn
− default-memos.json
@@ -1,1 +0,0 @@-{}
− default-settings.json
@@ -1,4 +0,0 @@-{- "repos" : {},- "feeds" : {}-}
− default-state.json
@@ -1,4 +0,0 @@-{- "chan-state" : {},- "chans-join" : []-}
− default-user-options.json
@@ -1,1 +0,0 @@-{}
funbot.cabal view
@@ -1,5 +1,5 @@ name: funbot-version: 0.3+version: 0.4 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@@ -19,26 +19,26 @@ Occasionally releases will be made to Hackage. If you want to be sure you have all the latest features, check out the git repository (and/or ask us to make a release if you think it's been long enough).-homepage: https://notabug.org/fr33domlover/funbot/-bug-reports: https://notabug.org/fr33domlover/funbot/issues/+homepage: https://notabug.org/fr33domlover/funbot+bug-reports: https://notabug.org/fr33domlover/funbot/issues license: PublicDomain license-file: COPYING author: The Freepost community, see AUTHORS file maintainer: fr33domlover@riseup.net copyright: ♡ Copying is an act of love. Please copy, reuse and share.-category: Network+category: Network, IRC build-type: Simple extra-source-files: AUTHORS ChangeLog COPYING- INSTALL- NEWS+ INSTALL.md+ NEWS.md README.md- default-memos.json- default-settings.json- default-state.json- default-user-options.json+ state-default/memos.json+ state-default/settings.json+ state-default/state.json+ state-default/user-options.json cabal-version: >=1.10 source-repository head@@ -52,10 +52,12 @@ , FunBot.ExtHandlers , FunBot.History , FunBot.IrcHandlers+ , FunBot.KnownNicks , FunBot.Memos , FunBot.Settings , FunBot.Sources , FunBot.Sources.FeedWatcher+ , FunBot.Sources.Loopback , FunBot.Sources.WebListener , FunBot.Sources.WebListener.Client , FunBot.Sources.WebListener.Gogs@@ -65,21 +67,24 @@ , FunBot.Util -- other-extensions: build-depends: aeson+ , auto-update , base >=4.7 && <5 , bytestring+ , clock >=0.5 , containers >=0.5+ , data-default-class , feed- , feed-collect+ , feed-collect >=0.2 , funbot-ext-events , HTTP , http-client >=0.4.19 , http-client-tls >=0.2.2 , http-listen- , irc-fun-bot >=0.4 && <0.5+ , irc-fun-bot >=0.5 && <0.6 , irc-fun-color , json-state , network-uri- , settings >=0.2.1+ , settings >=0.2.2 , tagsoup >=0.13 , text , time
src/FunBot/Commands.hs view
@@ -18,14 +18,15 @@ ) where -import Control.Monad (unless)+import Control.Monad (unless, when) import Data.List (find, intercalate) import Data.Settings.Types (showOption)-import FunBot.History (quote)+import FunBot.History (quote, reportHistory') import FunBot.Memos (submitMemo) import FunBot.Settings import FunBot.Types (BotSession) import FunBot.UserOptions+import FunBot.Util (getHistoryLines) import Network.IRC.Fun.Bot.Behavior import Network.IRC.Fun.Bot.Chat import Network.IRC.Fun.Bot.State@@ -37,7 +38,7 @@ commandSet = CommandSet { csetPrefix = '!' , csetCommands =- [ makeCmdHelp commandSet+ [ cmdHelp' , cmdInfo , cmdEcho , cmdPTell@@ -60,6 +61,11 @@ , cmdDisableHistory , cmdSetLines , cmdEraseOpts+ , cmdAddShortcut+ , cmdDeleteShortcut+ , cmdShowHistory+ , cmdAddFeed+ , cmdDeleteFeed ] } @@ -84,34 +90,31 @@ -- Show command help strings ------------------------------------------------------------------------------- --- Return a response function given a CommandSet-respondHelp cset _mchan _nick [cname] send =- case find ((cname' `elem`) . cmdNames) $ csetCommands cset of+respondHelp _mchan _nick [cname] send =+ case find ((cname' `elem`) . cmdNames) $ csetCommands commandSet of Just cmd -> send $ cmdHelp cmd ++ "\nCommand names: " ++ listNames Nothing Nothing True (cmdNames cmd) Nothing -> do succ <- respondSettingsHelp cname send- unless succ $ send $ printf+ unless succ $ send "No such command, or invalid settings path. \- \Maybe try just ‘%vhelp’ without a parameter."- (csetPrefix cset)+ \Maybe try just ‘!help’ without a parameter." where cname' = case cname of [] -> cname- (c:cs) -> if c == csetPrefix cset then cs else cname+ (c:cs) -> if c == csetPrefix commandSet then cs else cname -respondHelp cset _mchan _nick _params send =- send $ cmdHelp (makeCmdHelp cset)- ++ "\nAvailable commands: "- ++ listPrimaryNames- (Just $ csetPrefix cset)- Nothing False- (csetCommands cset)+respondHelp _mchan nick _params send =+ send "!info intro - about me\n\+ \!info commands - how to ask me to do things\n\+ \!info - list of help/information topics\n\+ \!help help - how to use this command\n\+ \All of these work both in channels and in private messages to me." -makeCmdHelp cset = Command+cmdHelp' = Command { cmdNames = ["help", "Help", "h", "?"]- , cmdRespond = respondHelp cset+ , cmdRespond = respondHelp , cmdHelp = "‘help [<command> | <setting>]’ - display help for the given \ \command or settings option/section. Also see ‘info’.\n\@@ -145,31 +148,49 @@ \• Announcing RSS/Atom feed items\n\ \• Leaving memos (requires enabling nick tracking for the channel)\n\ \• Announcing titles of URLs\n\+ \• Expanding shortcuts (e.g. easily get a bug URL by its ID)\n\ \• Logging and reporting channel activity\n\+ \• Welcoming new users\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>."+ \<https://notabug.org/fr33domlover/funbot/src/master/INSTALL.md>." ) , ( "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."+ \<https://notabug.org/fr33domlover/funbot>, which links to the \+ \contribution guide, to the issues 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\+ , "Website: https://notabug.org/fr33domlover/funbot\n\+ \Issues: https://notabug.org/fr33domlover/funbot/issues\n\+ \Dev guide: https://notabug.org/fr33domlover/funbot/src/master/INSTALL.md\n\ \User manual: http://rel4tion.org/projects/funbot/manual" )+ , ( "commands"+ , "A bot command is a specially formatted message sent either into an \+ \IRC channel, or privately to me. Such a message specifies at least \+ \the command name and a possibly empty list of whitespace-separated \+ \parameters. Commands may have more than one name, e.g. the ‘help’ \+ \command also has an alias ‘h’, among others. To see the details \+ \about which parameters a specific command takes, which name aliases \+ \it has and what it does, use ‘!help <command>’.\n\+ \A command can be sent to me using a message starting with a command \+ \prefix, e.g. ‘!echo hello’, or by starting a message with my \+ \nickname, e.g. ‘funbot: echo hello’. Some commands work only when \+ \used in a channel, some work only privately, some work in both \+ \cases.\n\+ \Use the ‘!info’ command to explore various aspects and features I \+ \provide. Both !help and !info can be used privately.\n\+ \Available commands: " +++ unwords (map (head . cmdNames) $ csetCommands commandSet)+ ) , ( "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 \@@ -182,10 +203,22 @@ \!delete-repo respectively." ) , ( "feeds"- , "TODO"+ , "I can periodically visit news feeds (Atom, RSS, etc.) and report new \+ \items to IRC channels. You can add and remove feeds using !add-feed \+ \and !delete-feed respectively. You can use the settings system \+ \(!get, !set, etc.) to control feed item display: activate and \+ \deactivate feeds, change feed URLs, choose IRC channels in which new \+ \items of a given feed are reported and control which information is \+ \shown about new feed items reported." ) , ( "memos"- , "TODO"+ , "You can leave a message for an offline user, and I will send them \+ \the message when they come back. I can send them the message \+ \privately or in the same channel you sent it to me. See the !tell \+ \and !ctell commands. If you leave a memo for an online user, I will \+ \send it to them instantly instead of storing it for later - but for \+ \that to work, channel user list tracking needs to be enabled in my \+ \settings for the relevant channel(s)." ) , ( "channels" , "Using bot commands, you can ask me to leave and join channels. The \@@ -198,12 +231,13 @@ ) , ( "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 \+ \so that you’ll know what was happening 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."+ \purpose (which is set in my data files). See ‘!info user-options’ \+ \for usage instructions. If you'd like to see channel history once, \+ \without enabling the automatic service, see ‘!help show-history’." ) , ( "user-options" , "I keep private per-user options which affect our interaction. These \@@ -218,6 +252,19 @@ \automatically published, so perhaps it isn’t very useful at the \ \moment. Perhaps unless you setup the publishing yourself." )+ , ( "shortcuts"+ , "I can detect special strings in your messages and send longer forms \+ \of them, allowing you to define shortcuts. For example, you can \+ \mention a bug ID and I will send a bug tracker URL for that bug. I \+ \detect shortcuts by their prefix: Once you define a <prefix> string, \+ \I find occurrences of <prefix><word> in channel messages, and resend \+ \<word> into the channel, with <before> and <after> strings \+ \surrounding it, thus expanding the shortcut. For example, if \+ \<prefix>=BUG <before>=http://bug.org/ <after>=.html, then if you \+ \send a message containing BUG142, I will send \+ \http://bug.org/142.html into the channel. See the !add-shortcut and \+ \!delete-shortcut commands, and relevant settings."+ ) ] respondInfo _mchan _nick [] send =@@ -507,7 +554,7 @@ ------------------------------------------------------------------------------- -- Show-opts, enable-history, disable-history, set-history-lines,--- set-history-lines, erase-opts commands+-- get-history-lines, erase-opts commands -- Manage user options ------------------------------------------------------------------------------- @@ -540,7 +587,14 @@ respondHistory _enable (Just _chan) _nick _args send = send priv respondHistory enable Nothing nick [chan] send = if looksLikeChan chan- then setEnabled nick chan enable+ then do+ setEnabled nick chan enable+ hls <- getHistoryLines chan+ when (enable && hls < 1) $ send+ "Note that while you enabled personal history display, \+ \history logging is disabled for that channel, therefore you \+ \won't be getting history messages. Ask the bot maintainer(s) \+ \to enable it." else send $ notchan chan respondHistory _enable Nothing nick args _send = failToUser nick $ WrongNumArgsN (Just $ length args) (Just 1)@@ -591,4 +645,127 @@ { cmdNames = ["erase-opts", "erase-options"] , cmdRespond = respondEraseOpts , cmdHelp = "‘erase-opts’ - reset all your options back to defaults."+ }++-------------------------------------------------------------------------------+-- Add-shortcut, delete-shortcut commands+-- Manage shortcuts+-------------------------------------------------------------------------------++respondAddShortcut mchan nick [label, chan] send =+ if looksLikeChan chan+ then do+ succ <- addShortcut label chan+ if succ+ then send "Shortcut added."+ else failBack mchan nick $ OtherFail+ "This shortcut is already registered."+ else send $ notchan chan+respondAddShortcut mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)++cmdAddShortcut = Command+ { cmdNames = ["add-shortcut"]+ , cmdRespond = respondAddShortcut+ , cmdHelp = "‘add-shortcut <label> <channel>’ - add a shortcut to \+ \apply in the given channel, with default dummy settings. \+ \The label is just for convenient reference; pick a short \+ \meaningful one."+ }++respondDeleteShortcut mchan nick [label] send = do+ succ <- deleteShortcut label+ if succ+ then send "Shortcut removed."+ else failBack mchan nick $ OtherFail "No such shortcut found."+respondDeleteShortcut mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdDeleteShortcut = Command+ { cmdNames = ["delete-shortcut"]+ , cmdRespond = respondDeleteShortcut+ , cmdHelp = "‘delete-shortcut <label>’ - remove the shortcut with the \+ \given label completely. If you just want to change the \+ \channels in which it applies, see the \+ \“shortcuts.<label>.channels” settings option."+ }++-------------------------------------------------------------------------------+-- Show-history command+-- Show channel history+-------------------------------------------------------------------------------++respondShowHistory (Just chan) nick [mins] _send =+ case readMaybe mins of+ Nothing -> badMins+ Just m ->+ if m < 0+ then badMins+ else reportHistory' nick chan m+ where+ badMins = failToChannel chan nick $ InvalidArg (Just 1) (Just mins)+respondShowHistory mchan nick [mins, chan] _send =+ case readMaybe mins of+ Nothing -> badMins+ Just m ->+ if m < 0+ then badMins+ else reportHistory' nick chan m+ where+ badMins = failBack mchan nick $ InvalidArg (Just 1) (Just mins)+respondShowHistory mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing++cmdShowHistory = Command+ { cmdNames = ["show-history"]+ , cmdRespond = respondShowHistory+ , cmdHelp =+ "‘show-history <mins>’ - Receive (privately) the channel \+ \history log for the last <mins> minutes, for the channel in which \+ \the command is used. The result may contain less than <mins> minutes \+ \because it also depends on the number of messages the bot \+ \remembers.\n\+ \‘show-history <mins> <channel>’ - The same, for the specified \+ \channel. Use this variant in a private message to the bot."+ }++-------------------------------------------------------------------------------+-- Add-feed and delete-feed commands+-- Add and remove news feeds to watch+-------------------------------------------------------------------------------++respondAddFeed mchan nick [label, url] send = do+ succ <- addFeed label url+ if succ+ then send "News feed added."+ else failBack mchan nick $ OtherFail "This label already exists."+respondAddFeed mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)++cmdAddFeed = Command+ { cmdNames = ["add-feed"]+ , cmdRespond = respondAddFeed+ , cmdHelp =+ "‘add-feed <label> <url>’ - add a news feed to watch and announce its \+ \new items to IRC channels. By default the list of IRC channels is \+ \empty; use the settings system (!set) to set one or more channels to \+ \which items will be announced."+ }++respondDeleteFeed mchan nick [label] send = do+ succ <- deleteFeed label+ if succ+ then send "News feed removed."+ else failBack mchan nick $ OtherFail "No such label found."+respondDeleteFeed mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdDeleteFeed = Command+ { cmdNames = ["delete-feed"]+ , cmdRespond = respondDeleteFeed+ , cmdHelp =+ "‘delete-feed <label>’ - stop announcing items of the given news feed \+ \and remove its settings. If you just want to disable the feed, \+ \without deleting the settings, use the settings system to deactivate \+ \it." }
src/FunBot/Config.hs view
@@ -22,7 +22,7 @@ , settingsFilename , memosFilename , userOptsFilename- , maxHistoryLines+ , nicksFilename , quoteDir ) where@@ -35,20 +35,21 @@ stateSaveInterval = 3 :: Second configuration = defConfig- { connection = Connection- { server = "irc.freenode.net"- , port = 6667- , tls = False -- not supported yet- , nick = "bot_test_joe"- , password = Nothing+ { cfgConnection = Connection+ { connServer = "irc.freenode.net"+ , connPort = 6667+ , connTls = False -- not supported yet+ , connNick = "bot_test_joe"+ , connPassword = Nothing }- , channels = ["#freepost-bot-test"]- , logDir = "state/chanlogs"- , stateRepo = Nothing- , stateFile = "state/state.json"- , saveInterval = time stateSaveInterval- , botEventLogFile = "state/bot.log"- , maxMsgChars = Just 400+ , cfgChannels = ["#freepost-bot-test"]+ , cfgLogDir = "state/chanlogs"+ , cfgStateRepo = Nothing+ , cfgStateFile = "state/state.json"+ , cfgSaveInterval = time stateSaveInterval+ , cfgBotEventLogFile = "state/bot.log"+ , cfgIrcErrorLogFile = Nothing+ , cfgMaxMsgChars = Just 400 } webListenerPort = 8998 :: Int@@ -75,10 +76,11 @@ -- 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+-- | If you set a repo path in the configuration above ('stateRepo' field),+-- then this path is relative to that repo and the nicks 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.+nicksFilename = "state/nicks.json" -- | Directory in which to place channel quotes. quoteDir = "state/quotes"
src/FunBot/ExtHandlers.hs view
@@ -20,17 +20,19 @@ ) where -import Control.Monad (forM_, when)+import Control.Monad (forM_, liftM, when) import Control.Monad.IO.Class (liftIO) import Data.Char (toLower) import Data.Maybe (fromMaybe) import Data.Monoid ((<>))+import Data.Time.Clock (diffUTCTime) import FunBot.ExtEvents import FunBot.Types import FunBot.Util (passes) import Network.HTTP (Request (..), RequestMethod (..)) import Network.IRC.Fun.Bot.Chat (sendToChannel)-import Network.IRC.Fun.Bot.State (getStateS)+import Network.IRC.Fun.Bot.Nicks (channelIsTracked, isInChannel)+import Network.IRC.Fun.Bot.State import Network.IRC.Fun.Color import Text.Printf (printf) @@ -39,6 +41,14 @@ import qualified Web.Hook.GitLab as GitLab import qualified Web.Hook.Gogs as Gogs +makeEllip len =+ let ellip = "..."+ n = (len - 1) `div` 2 - 1+ padl = replicate n ' '+ m = len - length padl - length ellip+ padr = replicate m ' '+ in padl ++ ellip ++ padr+ formatCommit branch repo (Commit author msg url) = encode $ Green #> Pure author <> " " <>@@ -47,9 +57,9 @@ Teal #> Pure msg <> " " <> Gray #> Pure url -formatEllipsis branch repo n =+formatEllipsis len branch repo n = encode $- Green #> "..." <> " " <>+ Green #> Pure (makeEllip len) <> " " <> Maroon #> Pure branch <> " " <> Purple #> Pure repo <> " | " <> Navy #> Pure ("... another " ++ show n ++ " commits ...")@@ -116,14 +126,23 @@ sendToChannel chan ellip sendToChannel chan lastCommit +makeVerbal [] = "... ummm... I don’t know, actually. How embarrassing"+makeVerbal [n] = n+makeVerbal [n, m] = n ++ " and " ++ m+makeVerbal (n:ns) = n ++ ", " ++ makeVerbal ns+ handler (GitPushEvent (Push branch commits)) = do- chans <- getStateS $ gitAnnChans . bsSettings+ chans <- getStateS $ stGitAnnChans . bsSettings case M.lookup (keyb branch) chans of Just specs -> let fmt = formatCommit (branchName branch) (branchRepo branch) msgs = map fmt commits+ len = case commits of+ [] -> 0+ cs -> length $ commitAuthor $ last cs ellip = formatEllipsis+ len (branchName branch) (branchRepo branch) (length msgs - 2)@@ -133,7 +152,7 @@ "Ext handler: Git push for unregistered repo: " ++ show (keyb branch) handler (GitTagEvent tag) = do- chans <- getStateS $ gitAnnChans . bsSettings+ chans <- getStateS $ stGitAnnChans . bsSettings case M.lookup (keyt tag) chans of Just specs -> let msg = formatTag tag@@ -144,7 +163,7 @@ "Ext handler: Tag for unregistered repo: " ++ show (keyt tag) handler (MergeRequestEvent mr) = do- chans <- getStateS $ gitAnnChans . bsSettings+ chans <- getStateS $ stGitAnnChans . bsSettings case M.lookup (keym mr) chans of Just specs -> let msg = formatMR mr@@ -155,10 +174,10 @@ "Ext handler: MR for unregistered repo: " ++ show (keym mr) handler (NewsEvent item) = do- feeds <- getStateS $ watchedFeeds . bsSettings+ feeds <- getStateS $ stWatchedFeeds . bsSettings let label = itemFeedLabel item case M.lookup label feeds of- Just (_url, spec) ->+ Just NewsFeed { nfAnnSpec = spec } -> let msg = formatNews item (nAnnFields spec) in mapM_ (\ chan -> sendToChannel chan msg) (nAnnChannels spec) Nothing -> liftIO $ do@@ -166,3 +185,29 @@ print item handler (PasteEvent paste) = sendToChannel (pasteChannel paste) $ formatPaste paste+handler (WelcomeEvent nick chan) = do+ getTime <- askTimeGetter+ now <- liftIO $ liftM fst getTime+ mt <- getStateS $ M.lookup chan . bsLastMsgTime+ let quiet =+ case mt of+ Nothing -> True+ Just t -> diffUTCTime t now >= 60 --seconds+ tracked <- channelIsTracked chan+ isHere <- nick `isInChannel` chan+ let assumeHere = tracked && isHere+ when (quiet && assumeHere) $ do+ chans <- getStateS $ stChannels . bsSettings+ case M.lookup chan chans of+ Nothing -> return ()+ Just cs ->+ sendToChannel chan $+ printf+ "Welcome, %v! The channel is pretty quiet right now, so I \+ \thought I’d say hello. For reference, the main people \+ \here to ping if you have questions are %v. Also, if no \+ \one responds for a while, try emailing us at %v, or just \+ \come back later."+ nick+ (makeVerbal $ csFolks cs)+ (csEmail cs)
src/FunBot/History.hs view
@@ -17,22 +17,24 @@ {-# LANGUAGE OverloadedStrings #-} module FunBot.History- ( remember- , quote+ ( quote , reportHistory+ , reportHistory' ) where -import Control.Monad (liftM, unless)+import Control.Monad (liftM, unless, when) import Control.Monad.IO.Class (liftIO) import Data.Foldable (find, mapM_)+import Data.Int (Int64) import Data.Monoid ((<>)) import Data.Sequence ((|>), Seq, ViewL (..))-import FunBot.Config (maxHistoryLines, quoteDir)+import FunBot.Config (quoteDir) import FunBot.Types-import FunBot.Util (getTimeStr) import Network.IRC.Fun.Bot.Chat+import Network.IRC.Fun.Bot.MsgCount import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Bot.Types (HistoryLine (..)) import Network.IRC.Fun.Color import Prelude hiding (mapM_) import System.IO@@ -41,12 +43,6 @@ 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 @@ -62,33 +58,12 @@ 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+ history <- getHistory let sameNick hl = hlNick hl == nick case M.lookup chan history >>= findLast sameNick of Just hl -> do@@ -107,13 +82,64 @@ -> Int -- ^ Maximal number of messages to send -> BotSession () reportHistory recip chan maxlen = do- mhls <- liftM (M.lookup chan) $ getStateS bsHistory+ c <- chanIsCounted chan+ missed <-+ if c+ then do+ res <- msgsSinceParted recip chan+ case res of+ Left n -> do+ sendToUser recip $+ printf+ "You missed at least %v messages in %v."+ n+ chan+ return Nothing+ Right n -> do+ sendToUser recip $+ if n == 0+ then printf+ "You didn't miss any messages in %v."+ chan+ else printf+ "You missed %v messages in %v."+ n+ chan+ return $ Just n+ else return Nothing+ mhls <- liftM (M.lookup chan) getHistory case mhls of Nothing -> return () Just hlsAll -> do let lAll = Q.length hlsAll- hls = Q.drop (lAll - maxlen) hlsAll+ maxlen' = maybe maxlen (min maxlen) missed+ 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++-- Send recent channel messages to a user, for a specific channel.+reportHistory' :: String -- ^ User nickname+ -> String -- ^ Channel+ -> Int64 -- ^ Minutes to go back in history+ -> BotSession ()+reportHistory' recip chan mins = do+ mhls <- liftM (M.lookup chan) getHistory+ case mhls of+ Nothing ->+ sendToUser recip "No history log found for that channel."+ Just hlsAll -> do+ now <- getMinutes+ let recent hl = now - hlMinute hl <= mins+ hls = Q.takeWhileR recent hlsAll+ if Q.null hls+ then sendToUser recip $+ printf "No messages in last %v minutes." mins+ else do+ sendToUser recip $+ printf+ "Messages I remember from last %v minutes in \+ \%v:"+ mins chan+ mapM_ (sendToUser recip . formatLine) hls
src/FunBot/IrcHandlers.hs view
@@ -22,25 +22,34 @@ , handleMsg , handleAction , handleNickChange+ , handleNames ) where +import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.Chan (writeChan) import Control.Exception (catch)-import Control.Monad (when)+import Control.Monad (liftM, when, void) import Control.Monad.IO.Class (liftIO)-import Data.Char (toLower)+import Data.Char (isAlphaNum, toLower)+import Data.Maybe (listToMaybe, mapMaybe) import Data.List (isPrefixOf, stripPrefix)-import FunBot.History (remember, reportHistory)+import Data.Time.Units+import FunBot.ExtEvents (ExtEvent (WelcomeEvent))+import FunBot.History (reportHistory)+import FunBot.KnownNicks import FunBot.Memos (reportMemos, reportMemosAll)-import FunBot.Types (HistoryDisplay (..))+import FunBot.Types import FunBot.UserOptions (getUserHistoryOpts) import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.IRC.Fun.Bot.Chat (sendToChannel)+import Network.IRC.Fun.Bot.State import Text.HTML.TagSoup import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.UTF8 as BU+import qualified Data.HashMap.Lazy as M helloWords :: [String] helloWords = ["hello", "hi", "hey", "yo"]@@ -83,11 +92,29 @@ | msg `elem` waveWordsR = sendToChannel chan $ nick ++ ": \\o" | otherwise = return () +recordTime chan = do+ getTime <- askTimeGetter+ now <- liftIO $ liftM fst getTime+ let update = M.insert chan now+ modifyState $ \ s -> s { bsLastMsgTime = update $ bsLastMsgTime s }+ handleBotMsg chan nick msg full = do sayHello chan nick msg- remember chan nick full False+ recordTime chan handleJoin chan nick = do+ sel <- channelSelected chan+ when sel $ do+ new <- rememberNick' nick chan+ when new $ do+ saveKnownNicks+ mcs <- getStateS $ M.lookup chan . stChannels . bsSettings+ let welcome = maybe False csWelcome mcs+ when welcome $ do+ q <- askEnvS loopbackQueue+ liftIO $ void $ forkIO $ do+ threadDelay $ fromInteger $ toMicroseconds (1 :: Minute)+ writeChan q $ WelcomeEvent nick chan hd <- getUserHistoryOpts nick chan when (hdEnabled hd) $ reportHistory nick chan (hdMaxLines hd) reportMemos nick chan@@ -108,27 +135,72 @@ in if null text then Nothing else Just text sayTitle chan msg = when ("http" `isPrefixOf` msg) $ do- manager <- liftIO $ newManager tlsManagerSettings- let action = do- request <- parseUrl msg- let h = host request- if goodHost h- then do- response <- httpLbs request manager- let page = BU.toString $ responseBody response- return $ Right $ findTitle page- else return $ Right Nothing- handler e = return $ Left (e :: HttpException)- getTitle = action `catch` handler- etitle <- liftIO getTitle- case etitle of- Right (Just title) -> sendToChannel chan $ '“' : title ++ "”"- _ -> return ()+ chans <- getStateS $ stChannels . bsSettings+ let say = maybe True csSayTitles $ M.lookup chan chans+ when say $ do+ manager <- liftIO $ newManager tlsManagerSettings+ let action = do+ request <- parseUrl msg+ let h = host request+ if goodHost h+ then do+ response <- httpLbs request manager+ let page = BU.toString $ responseBody response+ return $ Right $ findTitle page+ else return $ Right Nothing+ handler e = return $ Left (e :: HttpException)+ getTitle = action `catch` handler+ etitle <- liftIO getTitle+ case etitle of+ Right (Just title) -> sendToChannel chan $ '“' : title ++ "”"+ _ -> return () +search _ "" = Nothing+search msg pref = f msg False+ where+ skip = isAlphaNum+ pick = isAlphaNum+ f "" _ = Nothing+ f (c:cs) True = f cs (skip c)+ f s@(c:cs) False =+ let next = f cs (skip c)+ in case stripPrefix pref s of+ Nothing -> next+ Just r ->+ case span pick r of+ ("", _) -> next+ (p, "") -> Just p+ (p, (d:_)) ->+ if skip d+ then next+ else Just p++format cut s = shPrefix cut ++ s ++ " | " ++ shBefore cut ++ s ++ shAfter cut++sayTicket chan msg = do+ allCuts <- getStateS $ stShortcuts . bsSettings+ let applies cut = chan `elem` shChannels cut+ cuts = M.elems $ M.filter applies allCuts+ getres cut = fmap (\ s -> (cut, s)) $ search msg (shPrefix cut)+ results = mapMaybe getres cuts+ first = listToMaybe results+ case first of+ Nothing -> return ()+ Just (cut, s) -> sendToChannel chan $ format cut s+ handleMsg chan nick msg _mention = do sayTitle chan msg- remember chan nick msg False+ sayTicket chan msg+ recordTime chan -handleAction chan nick msg _mention = remember chan nick msg True+handleAction chan nick msg _mention = do+ sayTicket chan msg+ recordTime chan handleNickChange _old new = reportMemosAll new++handleNames chan _priv pairs = do+ sel <- channelSelected chan+ when sel $ do+ rememberNicks (map snd pairs) chan+ saveKnownNicks
+ src/FunBot/KnownNicks.hs view
@@ -0,0 +1,103 @@+{- 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/>.+ -}++module FunBot.KnownNicks+ ( rememberNick+ , rememberNick'+ , rememberNicks+ , nickIsKnown+ , loadKnownNicks+ , mkSaveKnownNicks+ , saveKnownNicks+ )+where++import Control.Monad.IO.Class (liftIO)+import Data.JsonState+import FunBot.Config (stateSaveInterval, configuration, nicksFilename)+import FunBot.Types+import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Bot.Types (Config (cfgStateRepo))++import qualified Data.HashMap.Lazy as M+import qualified Data.HashSet as S++-- | Consider this nick known in the given channel from now on.+rememberNick :: String -> String -> BotSession ()+rememberNick nick chan = do+ chans <- getStateS bsKnownNicks+ let nicks = M.lookup chan chans+ nicks' = maybe (S.singleton nick) (S.insert nick) nicks+ chans' = M.insert chan nicks' chans+ modifyState $ \ s -> s { bsKnownNicks = chans' }++-- | A variant of 'rememberNick' which returns whether the nick was indeed new.+-- If not, it means the nick was already known.+rememberNick' :: String -> String -> BotSession Bool+rememberNick' nick chan = do+ chans <- getStateS bsKnownNicks+ let ins ns = do+ let chans' = M.insert chan ns chans+ modifyState $ \ s -> s { bsKnownNicks = chans' }+ return True+ case M.lookup chan chans of+ Nothing -> ins $ S.singleton nick+ Just nicks ->+ if nick `S.member` nicks+ then return False+ else ins $ S.insert nick nicks++-- | Consider these nicks known in the given channel from now on.+rememberNicks :: [String] -> String -> BotSession ()+rememberNicks nicks chan = do+ chans <- getStateS bsKnownNicks+ let new = S.fromList nicks+ curr = M.lookup chan chans+ nicks' = maybe new (S.union new) curr+ chans' = M.insert chan nicks' chans+ modifyState $ \ s -> s { bsKnownNicks = chans' }++-- | Check whether the given nick is known in the given channel.+nickIsKnown :: String -> String -> BotSession Bool+nickIsKnown nick chan = do+ chans <- getStateS bsKnownNicks+ return $ case M.lookup chan chans of+ Nothing -> False+ Just nicks -> nick `S.member` nicks++-- | Load known nicks data from JSON file.+loadKnownNicks :: IO (M.HashMap String (S.HashSet String))+loadKnownNicks = do+ r <- loadState $ stateFilePath nicksFilename (cfgStateRepo configuration)+ case r of+ Left (False, e) -> error $ "Failed to read known nicks file: " ++ e+ Left (True, e) -> error $ "Failed to parse known nicks file: " ++ e+ Right s -> return s++-- | Create a safe async known nicks data saver action.+mkSaveKnownNicks :: IO (M.HashMap String (S.HashSet String) -> IO ())+mkSaveKnownNicks =+ mkSaveStateChoose+ stateSaveInterval+ nicksFilename+ (cfgStateRepo configuration)+ "auto commit by funbot"++-- | Schedule a save of the known nicks data into JSON file.+saveKnownNicks :: BotSession ()+saveKnownNicks = do+ nicks <- getStateS bsKnownNicks+ save <- askEnvS saveNicks+ liftIO $ save nicks
src/FunBot/Memos.hs view
@@ -41,7 +41,7 @@ import Network.IRC.Fun.Bot.Chat (sendToChannel, sendToUser) 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.Bot.Types (Config (cfgStateRepo)) import Network.IRC.Fun.Color import Text.Printf (printf) @@ -249,7 +249,7 @@ succ2 <- instantToUser unless succ2 keepForLater --- Send user memos. For a specific joined channels, or for all channels.+-- Send user memos. For a specific joined channel, or for all channels. reportMemos' :: String -- ^ User nickname -> Maybe String -- ^ The channel the user joined -> BotSession ()@@ -315,7 +315,7 @@ loadBotMemos :: IO (M.HashMap String [Memo]) loadBotMemos = do- r <- loadState $ stateFilePath memosFilename (stateRepo configuration)+ r <- loadState $ stateFilePath memosFilename (cfgStateRepo configuration) case r of Left (False, e) -> error $ "Failed to read memos file: " ++ e Left (True, e) -> error $ "Failed to parse memos file: " ++ e@@ -326,7 +326,7 @@ mkSaveStateChoose stateSaveInterval memosFilename- (stateRepo configuration)+ (cfgStateRepo configuration) "auto commit by funbot" saveBotMemos :: BotSession ()
src/FunBot/Settings.hs view
@@ -30,6 +30,10 @@ , addRepo , deleteRepo , addChannel+ , addShortcut+ , deleteShortcut+ , addFeed+ , deleteFeed , loadBotSettings , mkSaveBotSettings )@@ -41,6 +45,7 @@ import Data.Aeson hiding (encode) import Data.Bool (bool) import Data.Char (toLower)+import Data.Default.Class (def) import Data.JsonState import Data.List (intercalate, intersperse, isSuffixOf) import Data.Maybe (catMaybes, fromMaybe)@@ -56,12 +61,15 @@ import FunBot.Util import Network.IRC.Fun.Bot.Chat import Network.IRC.Fun.Bot.IrcLog+import Network.IRC.Fun.Bot.MsgCount import Network.IRC.Fun.Bot.Nicks import Network.IRC.Fun.Bot.State-import Network.IRC.Fun.Bot.Types (Config (stateRepo))+import Network.IRC.Fun.Bot.Types (Config (cfgStateRepo)) import Network.IRC.Fun.Color+import Web.Feed.Collect hiding (addFeed) import qualified Data.HashMap.Lazy as M+import qualified Web.Feed.Collect as F (addFeed) instance MonadSettings BotSession Settings where getSettings = getStateS bsSettings@@ -156,6 +164,21 @@ , "fields" .= fields ] +instance FromJSON NewsFeed where+ parseJSON (Object o) =+ NewsFeed <$>+ o .: "url" <*>+ o .: "active" <*>+ o .: "ann-spec"+ parseJSON _ = mzero++instance ToJSON NewsFeed where+ toJSON (NewsFeed url active spec) = object+ [ "url" .= url+ , "active" .= active+ , "ann-spec" .= spec+ ]+ instance FromJSON (M.HashMap (String, String) [PushAnnSpec]) where parseJSON v = let mkpair (s, l) =@@ -172,17 +195,55 @@ let unpair ((repo, owner), l) = (repo ++ '/' : owner, l) in toJSON $ M.fromList $ map unpair $ M.toList m +instance FromJSON Shortcut where+ parseJSON (Object o) =+ Shortcut <$>+ o .: "prefix" <*>+ o .: "before" <*>+ o .: "after" <*>+ o .: "channels"+ parseJSON _ = mzero++instance ToJSON Shortcut where+ toJSON (Shortcut prefix before after chans) = object+ [ "prefix" .= prefix+ , "before" .= before+ , "after" .= after+ , "channels" .= chans+ ]++instance FromJSON ChanSettings where+ parseJSON (Object o) =+ ChanSettings <$>+ o .: "say-titles" <*>+ o .: "welcome" <*>+ o .: "folks" <*>+ o .: "email"+ parseJSON _ = mzero++instance ToJSON ChanSettings where+ toJSON (ChanSettings sayTitles welcome folks email) = object+ [ "say-titles" .= sayTitles+ , "welcome" .= welcome+ , "folks" .= folks+ , "email" .= email+ ]+ instance FromJSON Settings where parseJSON (Object o) = Settings <$> o .: "repos" <*>- o .: "feeds"+ o .: "feeds" <*>+ o .: "shortcuts" <*>+ o .: "channels" parseJSON _ = mzero instance ToJSON Settings where- toJSON (Settings repos feeds) = object- [ "repos" .= repos- , "feeds" .= feeds+ toJSON (Settings repos feeds shortcuts channels) = object+ [ "repos" .= repos+ , "feeds" .= feeds+ , "shortcuts" .= shortcuts+ , "channels" .= channels ] -- An option whose value is held by funbot's 'Settings' and saved into its@@ -198,6 +259,20 @@ reset s = (Just defval, set defval s) cb = const saveBotSettings +-- A variant of 'mkOptionF' which accepts a callback to run after the default+-- one.+mkOptionF' :: OptionValue v+ => (Settings -> v) -- Get+ -> (v -> Settings -> Settings) -- Set which never fails+ -> v -- Default value for reset+ -> (v -> BotSession ()) -- Additional callback+ -> SettingsOption+mkOptionF' get set defval cbx = mkOptionS get set' reset cb+ where+ set' v s = Just $ set v s+ reset s = (Just defval, set defval s)+ cb v = saveBotSettings >> cbx v+ -- An option whose value is held by irc-fun-bot's 'BotState' and saved into its -- state file mkOptionB :: OptionValue v@@ -221,13 +296,15 @@ , mkOptionF getChan (\ chan s ->- let chans = gitAnnChans s+ let chans = stGitAnnChans s oldspecs = getSpecs s oldspec = getSpec s spec = oldspec { pAnnChannel = chan } specs = fromMaybe oldspecs $ replaceMaybe oldspecs pos spec- in s { gitAnnChans = M.insert (repo, owner) specs chans }+ in s { stGitAnnChans =+ M.insert (repo, owner) specs chans+ } ) defChan )@@ -235,7 +312,7 @@ , mkOptionF getBranches (\ branches s ->- let chans = gitAnnChans s+ let chans = stGitAnnChans s oldspecs = getSpecs s oldspec = getSpec s bs = case pAnnBranches oldspec of@@ -244,7 +321,9 @@ spec = oldspec { pAnnBranches = bs } specs = fromMaybe oldspecs $ replaceMaybe oldspecs pos spec- in s { gitAnnChans = M.insert (repo, owner) specs chans }+ in s { stGitAnnChans =+ M.insert (repo, owner) specs chans+ } ) defBranches )@@ -252,7 +331,7 @@ , mkOptionF getAccept (\ b s ->- let chans = gitAnnChans s+ let chans = stGitAnnChans s oldspecs = getSpecs s oldspec = getSpec s ctor = filt b@@ -262,7 +341,9 @@ spec = oldspec { pAnnBranches = bs } specs = fromMaybe oldspecs $ replaceMaybe oldspecs pos spec- in s { gitAnnChans = M.insert (repo, owner) specs chans }+ in s { stGitAnnChans =+ M.insert (repo, owner) specs chans+ } ) defAccept )@@ -270,13 +351,15 @@ , mkOptionF getAll (\ b s ->- let chans = gitAnnChans s+ let chans = stGitAnnChans s oldspecs = getSpecs s oldspec = getSpec s spec = oldspec { pAnnAllCommits = b } specs = fromMaybe oldspecs $ replaceMaybe oldspecs pos spec- in s { gitAnnChans = M.insert (repo, owner) specs chans }+ in s { stGitAnnChans =+ M.insert (repo, owner) specs chans+ } ) defAll )@@ -292,7 +375,7 @@ defAll = False defSpec = PushAnnSpec defChan defFilter defAll - getSpecs = M.lookupDefault [] (repo, owner) . gitAnnChans+ getSpecs = M.lookupDefault [] (repo, owner) . stGitAnnChans getSpec = fromMaybe defSpec . (!? pos) . getSpecs getChan = pAnnChannel . getSpec getFilter = pAnnBranches . getSpec@@ -323,14 +406,55 @@ feedSec :: String -> SettingsTree feedSec label = Section { secOpts = M.fromList- [ ( "channels"+ [ ( "url"+ , mkOptionF'+ getUrl+ (\ url s ->+ let feeds = stWatchedFeeds s+ feed = getFeed s+ feed' = feed { nfUrl = url }+ in s { stWatchedFeeds = M.insert label feed' feeds }+ )+ defUrl+ (\ url -> do+ cq <- askEnvS feedCmdQueue+ active <- liftM getActive getSettings+ liftIO $ do+ sendCommand cq $ removeFeed label+ sendCommand cq $ F.addFeed def+ { fcLabel = label+ , fcUrl = url+ , fcActive = active+ }+ )+ )+ , ( "active"+ , mkOptionF'+ getActive+ (\ b s ->+ let feeds = stWatchedFeeds s+ feed = getFeed s+ feed' = feed { nfActive = b }+ in s { stWatchedFeeds = M.insert label feed' feeds }+ )+ defActive+ (\ b -> do+ cq <- askEnvS feedCmdQueue+ liftIO $ sendCommand cq $ setFeedActive label b+ )+ )+ , ( "channels" , mkOptionF getChans (\ chans s ->- let feeds = watchedFeeds s- (url, spec) = getPair s- pair = (url, spec { nAnnChannels = chans })- in s { watchedFeeds = M.insert label pair feeds }+ let feeds = stWatchedFeeds s+ feed@NewsFeed { nfAnnSpec = spec } = getFeed s+ feed' = feed+ { nfAnnSpec = spec+ { nAnnChannels = chans+ }+ }+ in s { stWatchedFeeds = M.insert label feed' feeds } ) defChans )@@ -343,12 +467,19 @@ , mkOptionF (dispFeedTitle . getFields) (\ b s ->- let (url, spec) = getPair s+ let feed@NewsFeed { nfAnnSpec = spec } =+ getFeed s fieldsOld = nAnnFields spec fields = fieldsOld { dispFeedTitle = b }- pair = (url, spec { nAnnFields = fields })- in s { watchedFeeds = M.insert label pair $- watchedFeeds s }+ feed' = feed+ { nfAnnSpec = spec+ { nAnnFields = fields+ }+ }+ in s { stWatchedFeeds =+ M.insert label feed' $+ stWatchedFeeds s+ } ) (dispFeedTitle defFields) )@@ -356,12 +487,19 @@ , mkOptionF (dispAuthor . getFields) (\ b s ->- let (url, spec) = getPair s+ let feed@NewsFeed { nfAnnSpec = spec } =+ getFeed s fieldsOld = nAnnFields spec fields = fieldsOld { dispAuthor = b }- pair = (url, spec { nAnnFields = fields })- in s { watchedFeeds = M.insert label pair $- watchedFeeds s }+ feed' = feed+ { nfAnnSpec = spec+ { nAnnFields = fields+ }+ }+ in s { stWatchedFeeds =+ M.insert label feed' $+ stWatchedFeeds s+ } ) (dispAuthor defFields) )@@ -369,12 +507,19 @@ , mkOptionF (dispUrl . getFields) (\ b s ->- let (url, spec) = getPair s+ let feed@NewsFeed { nfAnnSpec = spec } =+ getFeed s fieldsOld = nAnnFields spec fields = fieldsOld { dispUrl = b }- pair = (url, spec { nAnnFields = fields })- in s { watchedFeeds = M.insert label pair $- watchedFeeds s }+ feed' = feed+ { nfAnnSpec = spec+ { nAnnFields = fields+ }+ }+ in s { stWatchedFeeds =+ M.insert label feed' $+ stWatchedFeeds s+ } ) (dispUrl defFields) )@@ -389,11 +534,13 @@ defFields = NewsItemFields True True True defSpec = NewsAnnSpec defChans defFields defUrl = ""- defPair = (defUrl, defSpec)+ defActive = False+ defFeed = NewsFeed defUrl defActive defSpec - getPair = M.lookupDefault defPair label . watchedFeeds- getUrl = maybe defUrl fst . M.lookup label . watchedFeeds- getSpec = maybe defSpec snd . M.lookup label . watchedFeeds+ getFeed = M.lookupDefault defFeed label . stWatchedFeeds+ getUrl = maybe defUrl nfUrl . M.lookup label . stWatchedFeeds+ getActive = maybe defActive nfActive . M.lookup label . stWatchedFeeds+ getSpec = maybe defSpec nfAnnSpec . M.lookup label . stWatchedFeeds getChans = nAnnChannels . getSpec getFields = nAnnFields . getSpec @@ -407,20 +554,103 @@ (bool (stopTrackingChannel chan) (startTrackingChannel chan)) False )+ , ( "count"+ , mkOptionB+ (chanIsCounted chan)+ (bool (stopCountingChan chan) (startCountingChan chan))+ False+ ) , ( "log" , mkOptionB (channelIsLogged chan) (bool (stopLoggingChannel chan) (startLoggingChannel chan)) False )+ , ( "say-titles"+ , mkOptionF+ (getf True csSayTitles)+ (setf $ \ cs say -> cs { csSayTitles = say })+ True+ )+ , ( "welcome"+ , mkOptionF+ (getf False csWelcome)+ (setf $ \ cs w -> cs { csWelcome = w })+ False+ )+ , ( "folks"+ , mkOptionF+ (getf [] csFolks)+ (setf $ \ cs fs -> cs { csFolks = fs })+ []+ )+ , ( "email"+ , mkOptionF+ (getf "(?)" csEmail)+ (setf $ \ cs s -> cs { csEmail = s })+ "(?)"+ ) ] , secSubs = M.empty }+ where+ defChan = ChanSettings True False [] "(?)"+ getf e f = maybe e f . M.lookup chan . stChannels+ setf f v s =+ let chans = stChannels s+ cs = M.lookupDefault defChan chan chans+ cs' = f cs v+ chans' = M.insert chan cs' chans+ in s { stChannels = chans' } +-- Create a settings section for a shortcut, given its label string+shortcutSec :: String -> SettingsTree+shortcutSec label = Section+ { secOpts = M.fromList+ [ ( "prefix"+ , mkOptionF+ (getf shPrefix)+ (setf $ \ cut prefix -> cut { shPrefix = prefix })+ ""+ )+ , ( "before"+ , mkOptionF+ (getf shBefore)+ (setf $ \ cut before -> cut { shBefore = before })+ ""+ )+ , ( "after"+ , mkOptionF+ (getf shAfter)+ (setf $ \ cut after -> cut { shAfter = after })+ ""+ )+ , ( "channels"+ , mkOptionF+ (getl shChannels)+ (setf $ \ cut chans -> cut { shChannels = chans })+ []+ )+ ]+ , secSubs = M.empty+ }+ where+ err = "ERROR not found"+ getf f = maybe err f . M.lookup label . stShortcuts+ getl f = maybe [] f . M.lookup label . stShortcuts+ setf f v s =+ let cuts = stShortcuts s+ in case M.lookup label cuts of+ Nothing -> s+ Just cut ->+ let cut' = f cut v+ cuts' = M.insert label cut' cuts+ in s { stShortcuts = cuts' }+ -- | Build initial settings tree, already inside the session initTree :: BotSession () initTree = do- cstates <- getChannelState+ cstates <- getChanInfo sets <- getSettings let mapKey f = M.mapWithKey $ \ key _val -> f key tree = Section@@ -436,15 +666,21 @@ , Section { secOpts = M.empty , secSubs = M.fromList $ map (uncurry repoSec) $- M.toList $ gitAnnChans sets+ M.toList $ stGitAnnChans sets } ) , ( "feeds" , Section { secOpts = M.empty- , secSubs = mapKey feedSec $ watchedFeeds sets+ , secSubs = mapKey feedSec $ stWatchedFeeds sets } )+ , ( "shortcuts"+ , Section+ { secOpts = M.empty+ , secSubs = mapKey shortcutSec $ stShortcuts sets+ }+ ) ] } modifyState $ \ s -> s { bsSTree = tree }@@ -453,12 +689,12 @@ -- repo section. Return whether succeeded. addPushAnnSpec :: String -> String -> String -> BotSession Bool addPushAnnSpec repo owner chan = do- repos <- liftM gitAnnChans getSettings+ repos <- liftM stGitAnnChans 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' }+ modifySettings $ \ s -> s { stGitAnnChans = repos' } saveBotSettings let (name, sec) = repoSec (repo, owner) specs' ins = insertSub ["repos", name] sec@@ -473,7 +709,7 @@ -- The position given is 0-based. deletePushAnnSpec :: String -> String -> Int -> BotSession (Maybe Bool) deletePushAnnSpec repo owner pos = do- repos <- liftM gitAnnChans getSettings+ repos <- liftM stGitAnnChans getSettings case M.lookup (repo, owner) repos of Just specs -> case splitAt pos specs of@@ -481,7 +717,7 @@ (l, s:r) -> do let specs' = l ++ r repos' = M.insert (repo, owner) specs' repos- modifySettings $ \ s -> s { gitAnnChans = repos' }+ modifySettings $ \ s -> s { stGitAnnChans = repos' } saveBotSettings let (name, sec) = repoSec (repo, owner) specs' ins = insertSub ["repos", name] sec@@ -493,12 +729,12 @@ -- 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+ repos <- liftM stGitAnnChans 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' }+ modifySettings $ \ s -> s { stGitAnnChans = repos' } saveBotSettings let (name, sec) = repoSec (repo, owner) [defSpec] ins = insertSub ["repos", name] sec@@ -511,11 +747,11 @@ -- the repo did exist and indeed has been deleted. deleteRepo :: String -> String -> BotSession Bool deleteRepo repo owner = do- repos <- liftM gitAnnChans getSettings+ repos <- liftM stGitAnnChans getSettings if M.member (repo, owner) repos then do let repos' = M.delete (repo, owner) repos- modifySettings $ \ s -> s { gitAnnChans = repos' }+ modifySettings $ \ s -> s { stGitAnnChans = repos' } saveBotSettings let name = repo ++ '/' : owner del = deleteSub ["repos", name]@@ -523,6 +759,39 @@ return True else return False +-- | Add a new shortcut to settings and tree. Return whether success, i.e.+-- whether the shortcut didn't exist and indeed a new one has been created.+addShortcut :: String -> String -> BotSession Bool+addShortcut label chan = do+ cuts <- liftM stShortcuts getSettings+ case M.lookup label cuts of+ Just _ -> return False+ Nothing -> do+ let cuts' = M.insert label defCut cuts+ modifySettings $ \ s -> s { stShortcuts = cuts' }+ saveBotSettings+ let sec = shortcutSec label+ ins = insertSub ["shortcuts", label] sec+ modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+ return True+ where+ defCut = Shortcut "PrEfIx" "http://BeFoRe.org/" "/AfTeR.html" [chan]++-- | Remove a shortcut from settings and tree. Return whether success, i.e.+-- whether the shortcut did exist and indeed has been deleted.+deleteShortcut :: String -> BotSession Bool+deleteShortcut label = do+ cuts <- liftM stShortcuts getSettings+ if M.member label cuts+ then do+ let cuts' = M.delete label cuts+ modifySettings $ \ s -> s { stShortcuts = cuts' }+ saveBotSettings+ let del = deleteSub ["shortcuts", label]+ 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 ()@@ -536,6 +805,56 @@ ins = insertSub route sec modifyState $ \ s -> s { bsSTree = ins $ bsSTree s } +-- | Add a new feed to settings and tree. Return whether success, i.e. whether+-- the feed didn't exist and indeed a new one has been created.+addFeed :: String -> String -> BotSession Bool+addFeed label url = do+ feeds <- liftM stWatchedFeeds getSettings+ case M.lookup label feeds of+ Just _ -> return False+ Nothing -> do+ -- Update and save settings+ let feed = NewsFeed+ { nfUrl = url+ , nfActive = True+ , nfAnnSpec = defSpec+ }+ feeds' = M.insert label feed feeds+ modifySettings $ \ s -> s { stWatchedFeeds = feeds' }+ saveBotSettings+ -- Update settings UI tree+ let sec = feedSec label+ ins = insertSub ["feeds", label] sec+ modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+ -- Send command to update the feed watcher+ cq <- askEnvS feedCmdQueue+ liftIO $ sendCommand cq $ F.addFeed $ mkFeed label url+ return True+ where+ defChans = []+ defFields = NewsItemFields True True True+ defSpec = NewsAnnSpec defChans defFields++-- | Remove a feed from settings and tree. Return whether success, i.e. whether+-- the feed did exist and indeed has been deleted.+deleteFeed :: String -> BotSession Bool+deleteFeed label = do+ feeds <- liftM stWatchedFeeds getSettings+ if M.member label feeds+ then do+ -- Update and save settings+ let feeds' = M.delete label feeds+ modifySettings $ \ s -> s { stWatchedFeeds = feeds' }+ saveBotSettings+ -- Update settings UI tree+ let del = deleteSub ["feeds", label]+ modifyState $ \ s -> s { bsSTree = del $ bsSTree s }+ -- Send command to update the feed watcher+ cq <- askEnvS feedCmdQueue+ liftIO $ sendCommand cq $ removeFeed label+ return True+ else return False+ showError :: SettingsError -> String showError (InvalidPath s) = s ++ " : Invalid path" showError (NoSuchNode r) = showRoute r ++ " : No such option/section"@@ -544,15 +863,19 @@ showError (InvalidValueForType s) = s ++ " : Invalid value for option type" showError (InvalidValue s) = s ++ " : Invalid value" +showOptLine :: String -> String -> String -> String+showOptLine opt op val =+ encode $ Yellow #> Pure opt <> Teal #> Pure op <> Maroon #> Pure val+ showGet :: String -> String -> String-showGet opt val = opt ++ " = " ++ val+showGet opt val = showOptLine opt " = " val showSec :: String -> [String] -> [String] -> String showSec path subs opts = let showSub = Pure . ('‣' :) showOpt = Pure . ('•' :) showList = mconcat . intersperse " "- pathF = Pure path+ pathF = Yellow #> Pure path subsF = Green #> (showList $ map showSub subs) optsF = Purple #> (showList $ map showOpt opts) in encode $ case (null subs, null opts) of@@ -587,7 +910,7 @@ Right (subs, opts) -> showSec path subs opts showSet :: String -> String -> String-showSet opt val = opt ++ " ← " ++ val+showSet opt val = showOptLine opt " ← " val respondSet' :: String -> String -> (String -> BotSession ()) -> BotSession () respondSet' opt val send = do@@ -597,7 +920,7 @@ Nothing -> send $ showSet opt val showReset :: String -> String -> String-showReset opt val = opt ++ " ↩ " ++ val+showReset opt val = showOptLine opt " ↩ " val showResetStrange :: String -> String showResetStrange opt = opt ++ " : got reset, but I can't find it now"@@ -630,6 +953,25 @@ \Tracking isn't enabled by default, to save bot server hardware \ \resources (in particular RAM), especially for cases of many, crowded \ \or busy channels."+ ["channels", _, "count"] ->+ "Whether channel message logs are maintained (in memory) for this \+ \channel. If yes, channel history reports (which you can get when you \+ \join a channel) will also specify how many messages you missed. For \+ \to work, you must also enable the 'track' option."+ ["channels", _, "say-titles"] ->+ "Whether I should detect URLs sent into this channel and send their \+ \titles."+ ["channels", _, "welcome"] ->+ "Whether I should send a welcome message when a new nickname unknown \+ \to me joins the channel, and the channel is quiet for some time."+ ["channels", _, "folks"] ->+ "List of main people (nicknames) in the channel. This is used in the \+ \welcome messages, and possibly other places."+ ["channels", _, "email"] ->+ "Email address (possibly of a mailing list) for async discussions. If \+ \you ask a question and nobody responds for a while, you can send \+ \your question there. Also good for long, documented discussions and \+ \generally the things email is better suited for than IRC." ["repos"] -> "Git repo event announcement details." ["repos", _] -> "Event announcement details for a Git repo, specified by its name and \@@ -665,6 +1007,8 @@ \branches\", or in other words announce commits of *all* branches." ["feeds"] -> "News feed item announcement details." ["feeds", _] -> "Details for announcing new feed items for this feed."+ ["feeds", _, "url"] -> "URL of the feed."+ ["feeds", _, "active"] -> "Whether the feed is being watched." ["feeds", _, "channels"] -> "List of IRC channels into which to announce new items from the feed." ["feeds", _, "show"] ->@@ -676,6 +1020,19 @@ "Whether to specify the feed title when announcing a new item." ["feeds", _, "show", "url"] -> "Whether to specify the item URL when announcing the new item."+ ["shortcuts"] -> "List of available shortcuts."+ ["shortcuts", _] -> "Details of this shortcut."+ ["shortcuts", _, "prefix"] ->+ "A string by which the shortcut is identified. For example, if you'd \+ \like “TKT-258” to refer to ticket #258, set the prefix to “TKT-”."+ ["shortcuts", _, "before"] ->+ "In the full form into which the shortcut is expanded, this is the \+ \beginning of the string. For example, “http://funbot.org/tickets/”."+ ["shortcuts", _, "after"] ->+ "In the full form into which the shortcut is expanded, this is the \+ \end of the string. For example, “.html”."+ ["shortcuts", _, "channels"] ->+ "List of IRC channels in which this shortcut applies." _ -> "No help for this item." respondSettingsHelp :: String -> (String -> BotSession ()) -> BotSession Bool@@ -691,7 +1048,8 @@ loadBotSettings :: IO Settings loadBotSettings = do- r <- loadState $ stateFilePath settingsFilename (stateRepo configuration)+ r <- loadState $+ stateFilePath settingsFilename (cfgStateRepo configuration) case r of Left (False, e) -> error $ "Failed to read settings file: " ++ e Left (True, e) -> error $ "Failed to parse settings file: " ++ e@@ -702,7 +1060,7 @@ mkSaveStateChoose stateSaveInterval settingsFilename- (stateRepo configuration)+ (cfgStateRepo configuration) "auto commit by funbot" saveBotSettings :: BotSession ()
src/FunBot/Sources.hs view
@@ -16,8 +16,10 @@ module FunBot.Sources ( feedWatcherSource , webListenerSource+ , loopbackSource ) where import FunBot.Sources.FeedWatcher (feedWatcherSource) import FunBot.Sources.WebListener (webListenerSource)+import FunBot.Sources.Loopback (loopbackSource)
src/FunBot/Sources/FeedWatcher.hs view
@@ -19,13 +19,15 @@ where import Data.Maybe (fromMaybe)-import Data.Time.Units+import Data.Default.Class (def)+import Data.Time.Interval (time)+--import Data.Time.Units import FunBot.Config (feedVisitInterval) import FunBot.ExtEvents (ExtEvent (NewsEvent), NewsItem (..)) import FunBot.Types import Network.IRC.Fun.Bot.Logger import Text.Feed.Query-import Web.Feed.Collect (run)+import Web.Feed.Collect import qualified Data.HashMap.Lazy as M @@ -40,22 +42,25 @@ collect push label _url feed item = push $ makeItem label (getFeedTitle feed) item -logError logger err = logLine logger $ show err--feeds state =- let l = M.toList $ watchedFeeds $ bsSettings state- f (label, (url, _spec)) = (label, url)- in map f l+logError logger label err = logLine logger $ label ++ " : " ++ show err feedWatcherSource :: FilePath -> BotState -> ExtEventSource-feedWatcherSource file state _config _env push _pushMany mkLogger = do+feedWatcherSource file state _config env push _pushMany mkLogger = do logger <- mkLogger file+ let cq = feedCmdQueue env+ pairs = M.toList $ stWatchedFeeds $ bsSettings state+ mkfeed (label, nf) = def+ { fcLabel = label+ , fcUrl = nfUrl nf+ , fcActive = nfActive nf+ }+ feeds = map mkfeed pairs putStrLn "Bot: Feed watcher source loop running"- run- (collect push)- Nothing- (logError logger)- Nothing- feedVisitInterval- 3- (feeds state)+ run def+ { wcCollect = collect push+ , wcLogError = logError logger+ , wcCommandQueue = Just cq+ , wcVisitInterval = time feedVisitInterval+ , wcMaxItems = 3+ , wcFeeds = feeds+ }
+ src/FunBot/Sources/Loopback.hs view
@@ -0,0 +1,40 @@+{- 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/>.+ -}++module FunBot.Sources.Loopback+ ( loopbackSource+ , insertEvent+ )+where++import Control.Concurrent.Chan+import Control.Monad (forever)+import Control.Monad.IO.Class (liftIO)+import FunBot.ExtEvents (ExtEvent)+import FunBot.Types+import Network.IRC.Fun.Bot.State (askEnvS)++loopbackSource :: ExtEventSource+loopbackSource _config env push _pushMany _mkLogger = do+ putStrLn "Bot: Loopback source running"+ let chan = loopbackQueue env+ forever $ do+ event <- readChan chan+ push event++insertEvent :: ExtEvent -> BotSession ()+insertEvent event = do+ chan <- askEnvS loopbackQueue+ liftIO $ writeChan chan event
src/FunBot/Types.hs view
@@ -19,12 +19,14 @@ , PushAnnSpec (..) , NewsItemFields (..) , NewsAnnSpec (..)+ , NewsFeed (..) , BotEnv (..)+ , ChanSettings (..) , Settings (..)+ , Shortcut (..) , SettingsOption , SettingsTree , Memo (..)- , HistoryLine (..) , HistoryDisplay (..) , UserOptions (..) , BotState (..)@@ -34,13 +36,14 @@ ) where +import Control.Concurrent.Chan (Chan) 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 Web.Feed.Collect (CommandQueue) -- | Generic item filter data Filter a = Accept [a] | Reject [a]@@ -74,6 +77,16 @@ , nAnnFields :: NewsItemFields } +-- | A web news feed from which the bot can read and announce new items+data NewsFeed = NewsFeed+ { -- | The feed URL+ nfUrl :: String+ -- | Whether the feed watcher is watching this feed+ , nfActive :: Bool+ -- | Item announcement details+ , nfAnnSpec :: NewsAnnSpec+ }+ -- | Read-only custom bot environment data BotEnv = BotEnv { -- | Port on which the web hook event source will run@@ -86,16 +99,55 @@ , saveMemos :: HashMap String [Memo] -> IO () -- | Similarly for user options. , saveUserOpts :: HashMap String UserOptions -> IO ()+ -- | Similarly for known nicks.+ , saveNicks :: HashMap String (HashSet String) -> IO () -- | Filename for logging feed listener errors , feedErrorLogFile :: FilePath+ -- | Command queue for controlling the news feed watcher source+ , feedCmdQueue :: CommandQueue+ -- | Ext event loopback queue for inserting ext events+ , loopbackQueue :: Chan ExtEvent } +-- | A special string which the bot can detect and translate into a longer+-- form, e.g. a full URL.+data Shortcut = Shortcut+ { -- | String by which the shortcut is detected. For example, if you'd like+ -- \"SD-258\" to refer to the URL of ticket #258, then you should set+ -- the prefix to \"SD-\".+ shPrefix :: String+ -- | The generated longer form is a concatenation of this field, the+ -- shortcut string (without the prefix) and 'shAfter'.+ , shBefore :: String+ -- | The generated longer form is a concatenation of 'shBefore', the+ -- shortcut string (without the prefix) and this field.+ , shAfter :: String+ -- | The channels in which this shortcut should be applied.+ , shChannels :: [String]+ }++-- | Per-channel settings+data ChanSettings = ChanSettings+ { -- | Whether to display URL titles (the default is yes).+ csSayTitles :: Bool+ -- | Whether to welcome new users when the channel is quiet.+ , csWelcome :: Bool+ -- | Nicks to mention in the welcome message.+ , csFolks :: [String]+ -- | Email address for async discussions.+ , csEmail :: String+ }+ -- | User-modifiable bot behavior settings data Settings = Settings { -- | Maps a Git repo name+owner to annoucement details- gitAnnChans :: HashMap (String, String) [PushAnnSpec]- , -- | Maps a feed label to its URL and announcement details- watchedFeeds :: HashMap String (String, NewsAnnSpec)+ stGitAnnChans :: HashMap (String, String) [PushAnnSpec]+ -- | Maps a feed label to its URL and announcement details+ , stWatchedFeeds :: HashMap String NewsFeed+ -- | Maps a shortcut label to its spec+ , stShortcuts :: HashMap String Shortcut+ -- | Per-channel settings+ , stChannels :: HashMap String ChanSettings } -- | Alias for the settings option type@@ -113,14 +165,6 @@ , 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@@ -138,15 +182,17 @@ -- | Read-write custom bot state data BotState = BotState { -- | User-modifiable bot behavior settings- bsSettings :: Settings+ bsSettings :: Settings -- | Settings tree and access definition for UI- , bsSTree :: SettingsTree+ , bsSTree :: SettingsTree -- | Memos waiting for users to connect.- , bsMemos :: HashMap String [Memo]- -- | Per-channel last messages- , bsHistory :: HashMap String (Seq HistoryLine)+ , bsMemos :: HashMap String [Memo] -- | Per-user options , bsUserOptions :: HashMap String UserOptions+ -- | Known nicks in channels+ , bsKnownNicks :: HashMap String (HashSet String)+ -- | Time of last message per channel.+ , bsLastMsgTime :: HashMap String UTCTime } -- | Shortcut alias for bot session monad
src/FunBot/UserOptions.hs view
@@ -38,9 +38,10 @@ import Data.Maybe (fromMaybe) import FunBot.Config (stateSaveInterval, configuration, userOptsFilename) import FunBot.Types+import FunBot.Util (getHistoryLines) import Network.IRC.Fun.Bot.Chat (sendToUser) import Network.IRC.Fun.Bot.State-import Network.IRC.Fun.Bot.Types (Config (stateRepo))+import Network.IRC.Fun.Bot.Types (Config (cfgStateRepo)) import Text.Printf (printf) import qualified Data.HashMap.Lazy as M@@ -159,8 +160,12 @@ -> BotSession () setMaxLines nick chan maxLines = do modifyOpts nick chan $ \ hd -> hd { hdMaxLines = maxLines }+ hls <- getHistoryLines chan sendToUser nick $- printf "History display length for %v: %v" chan (showMaxLines maxLines)+ printf+ "History display length for %v: %v\n\+ \(I keep in my logs up to %v for %v)"+ chan (showMaxLines maxLines) (showMaxLines hls) chan eraseOpts :: String -- ^ User nickname -> BotSession ()@@ -203,7 +208,8 @@ loadUserOptions :: IO (M.HashMap String UserOptions) loadUserOptions = do- r <- loadState $ stateFilePath userOptsFilename (stateRepo configuration)+ r <- loadState $+ stateFilePath userOptsFilename (cfgStateRepo 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@@ -214,7 +220,7 @@ mkSaveStateChoose stateSaveInterval userOptsFilename- (stateRepo configuration)+ (cfgStateRepo configuration) "auto commit by funbot" saveUserOptions :: BotSession ()
src/FunBot/Util.hs view
@@ -19,6 +19,7 @@ , passes , passesBy , getTimeStr+ , getHistoryLines ) where @@ -26,8 +27,11 @@ import Control.Monad.IO.Class (liftIO) import Data.Maybe (listToMaybe) import FunBot.Types-import Network.IRC.Fun.Bot.State (askTimeGetter)+import Network.IRC.Fun.Bot.State (askTimeGetter, getChanInfo)+import Network.IRC.Fun.Bot.Types (ChanInfo (ciHistoryLines)) +import qualified Data.HashMap.Lazy as M (lookup)+ -- | List index operator, starting from 0. Like @!!@ but returns a 'Maybe' -- instead of throwing an exception. On success, returns 'Just' the item. On -- out-of-bounds index, returns 'Nothing'.@@ -58,3 +62,10 @@ getTimeStr = do getTime <- askTimeGetter liftIO $ liftM snd getTime++-- | Get the number of history lines recorded in memory for a given channel. If+-- the channel doesn't have state held for it, 0 is returned.+getHistoryLines :: String -> BotSession Int+getHistoryLines chan = do+ cs <- getChanInfo+ return $ maybe 0 ciHistoryLines $ M.lookup chan cs
src/Main.hs view
@@ -15,10 +15,12 @@ module Main (main) where +import Control.Concurrent.Chan (newChan) import Control.Monad.IO.Class (liftIO) import Data.Settings.Section (empty) import FunBot.Commands (commandSet) import FunBot.ExtHandlers (handler)+import FunBot.KnownNicks import FunBot.Memos import FunBot.Settings import FunBot.Sources@@ -28,27 +30,32 @@ import Network.IRC.Fun.Bot.Behavior (defaultBehavior) import Network.IRC.Fun.Bot.EventMatch import Network.IRC.Fun.Bot.Types (Behavior (..), EventMatchSpace (..))+import Web.Feed.Collect (newCommandQueue) 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 saveUO = BotEnv+env saveS saveM saveUO saveKN cq lq = BotEnv { webHookSourcePort = C.webListenerPort , saveSettings = saveS , saveMemos = saveM , saveUserOpts = saveUO+ , saveNicks = saveKN , feedErrorLogFile = C.feedErrorLogFile+ , feedCmdQueue = cq+ , loopbackQueue = lq } -- | Initial content of the bot state-initialState sets ms userOpts = BotState+initialState sets ms userOpts nicks = BotState { bsSettings = sets , bsSTree = empty , bsMemos = ms- , bsHistory = M.empty , bsUserOptions = userOpts+ , bsKnownNicks = nicks+ , bsLastMsgTime = M.empty } -- | Event detector specification@@ -76,7 +83,7 @@ where privCmds = [ "help", "info", "echo", "tell", "get", "show-opts", "enable-history"- , "disable-history", "set-history-lines", "erase-opts"+ , "disable-history", "set-history-lines", "erase-opts", "show-history" ] @@ -88,12 +95,14 @@ , handleBotMsg = H.handleBotMsg , commandSets = [commandSet] , handleNickChange = H.handleNickChange+ , handleNames = H.handleNames } -- | Additional events sources mkSources state = [ webListenerSource , feedWatcherSource C.feedErrorLogFile state+ , loopbackSource ] main = do@@ -101,16 +110,20 @@ sets <- loadBotSettings ms <- loadBotMemos uos <- loadUserOptions+ nicks <- loadKnownNicks saveS <- mkSaveBotSettings saveM <- mkSaveBotMemos saveUO <- mkSaveUserOptions- let state = initialState sets ms uos+ saveKN <- mkSaveKnownNicks+ cq <- newCommandQueue+ lq <- newChan+ let state = initialState sets ms uos nicks runBot C.configuration matchers behavior (mkSources state) handler- (env saveS saveM saveUO)+ (env saveS saveM saveUO saveKN cq lq) state initTree
+ state-default/memos.json view
@@ -0,0 +1,1 @@+{}
+ state-default/settings.json view
@@ -0,0 +1,5 @@+{+ "repos" : {},+ "feeds" : {},+ "shortcuts" : {}+}
+ state-default/state.json view
@@ -0,0 +1,4 @@+{+ "chan-state" : {},+ "chans-join" : []+}
+ state-default/user-options.json view
@@ -0,0 +1,1 @@+{}