packages feed

funbot 0.4.0.1 → 0.5

raw patch · 45 files changed

+5528/−2330 lines, 45 filesdep +case-insensitivedep +formattingdep +hashabledep ~funbot-ext-eventsdep ~irc-fun-botdep ~irc-fun-color

Dependencies added: case-insensitive, formatting, hashable, irc-fun-client, irc-fun-types

Dependency ranges changed: funbot-ext-events, irc-fun-bot, irc-fun-color, settings, vcs-web-hook-parse

Files

NEWS.md view
@@ -3,6 +3,57 @@   +funbot 0.5 -- 2016-01-27+========================++General, build and documentation changes:++* Move the code from `String` everywhere into strict `Text`, often wrapped in+  dedicated semantic `newtype`s for more type safety (since so many values are+  just text otherwise) and for readability++New UIs, features and enhancements:++* Send history-on-join as a notice+* Log web source errors into a file instead of stdout+* Merge request announcements mention repo name+* Add issue ext event announcements+* Add note ext event announcements+* Return an HTTP response to gitlab web hook, it seems to want it+* TLS now implemented in `irc-fun-client`+* Key-URL map for which link references+* Puppet system for relaying arbitrary messages+* More goodies... :)++Bug fixes:++* Git repo names and usernames are now compared in a case-insensitive manner,+  which allows them to be specified in a human-friendly form while also+  accepting all-lowercase versions used in generated URLs. Previously this+  caused issues with !add-repo because of hacks made in an attempt to make+  hashmaps pseudo-ignore letter case.+* Display and store repo IDs as `user/repo` and not `repo/user`. The latter+  seems to be confusing since git repo URLs use the former.+* When `!get`ing a settings section, display the section and option lists in+  sorted order. It's consistent and easier to find items with the eyes.++Dependency changes:++* Add     case-insensitive   >= 1+          formatting         >= 6.2+          hashable+          irc-fun-client     >= 0.5+          irc-fun-types      <0.2+* Require funbot-ext-events  >= 0.3+          irc-fun-bot        >= 0.6+          irc-fun-color      >= 0.2+          settings           >= 0.3+          vcs-web-hook-parse >= 0.2+++++ funbot 0.4.0.1 -- 2015-12-17 ============================
funbot.cabal view
@@ -1,5 +1,5 @@ name:                funbot-version:             0.4.0.1+version:             0.5 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@@ -48,13 +48,38 @@ executable funbot   main-is:             Main.hs   other-modules:       FunBot.Commands+                     , FunBot.Commands.Channels+                     , FunBot.Commands.Feeds+                     , FunBot.Commands.History+                     , FunBot.Commands.Info+                     , FunBot.Commands.Locations+                     , FunBot.Commands.Memos+                     , FunBot.Commands.Misc+                     , FunBot.Commands.Puppet+                     , FunBot.Commands.Repos+                     , FunBot.Commands.Settings+                     , FunBot.Commands.Shortcuts+                     , FunBot.Commands.UserOptions                      , FunBot.Config                      , FunBot.ExtHandlers                      , FunBot.History                      , FunBot.IrcHandlers                      , FunBot.KnownNicks+                     , FunBot.Locations                      , FunBot.Memos+                     , FunBot.Puppet                      , FunBot.Settings+                     , FunBot.Settings.Help+                     , FunBot.Settings.Instances+                     , FunBot.Settings.MkOption+                     , FunBot.Settings.Sections+                     , FunBot.Settings.Sections.Channels+                     , FunBot.Settings.Sections.DevHosts+                     , FunBot.Settings.Sections.Feeds+                     , FunBot.Settings.Sections.Locations+                     , FunBot.Settings.Sections.Repos+                     , FunBot.Settings.Sections.Shortcuts+                     , FunBot.Settings.Persist                      , FunBot.Sources                      , FunBot.Sources.FeedWatcher                      , FunBot.Sources.Loopback@@ -62,6 +87,7 @@                      , FunBot.Sources.WebListener.Client                      , FunBot.Sources.WebListener.Gogs                      , FunBot.Sources.WebListener.GitLab+                     , FunBot.Sources.WebListener.Util                      , FunBot.Types                      , FunBot.UserOptions                      , FunBot.Util@@ -70,21 +96,26 @@                      , auto-update                      , base                 >=4.7 && <5                      , bytestring+                     , case-insensitive     >=1                      , clock                >=0.5                      , containers           >=0.5                      , data-default-class                      , feed                      , feed-collect         >=0.2-                     , funbot-ext-events    >=0.2+                     , formatting           >=6.2+                     , funbot-ext-events    >=0.3+                     , hashable                      , HTTP                      , http-client          >=0.4.19                      , http-client-tls      >=0.2.2                      , http-listen-                     , irc-fun-bot          >=0.5 && <0.6-                     , irc-fun-color+                     , irc-fun-bot          >=0.6 && <0.7+                     , irc-fun-client       >=0.5 && <0.6+                     , irc-fun-color        >=0.2 && <0.3+                     , irc-fun-types        <0.2                      , json-state                      , network-uri-                     , settings             >=0.2.2+                     , settings             >=0.3                      , tagsoup              >=0.13                      , text                      , time@@ -93,6 +124,6 @@                      , transformers                      , unordered-containers >=0.2.5                      , utf8-string          >=1-                     , vcs-web-hook-parse+                     , vcs-web-hook-parse   >=0.2   hs-source-dirs:      src   default-language:    Haskell2010
src/FunBot/Commands.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -13,26 +13,27 @@  - <http://creativecommons.org/publicdomain/zero/1.0/>.  -} +{-# LANGUAGE OverloadedStrings #-}+ module FunBot.Commands     ( commandSet     ) where -import Control.Monad (unless, when)-import Data.List (find, intercalate)-import Data.Settings.Types (showOption)-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+import FunBot.Commands.Channels+import FunBot.Commands.Feeds+import FunBot.Commands.History+import FunBot.Commands.Info+import FunBot.Commands.Locations+import FunBot.Commands.Memos+import FunBot.Commands.Misc+import FunBot.Commands.Puppet+import FunBot.Commands.Repos+import FunBot.Commands.Settings+import FunBot.Commands.Shortcuts+import FunBot.Commands.UserOptions+import FunBot.Types import Network.IRC.Fun.Bot.Types-import Text.Printf (printf)-import Text.Read (readMaybe)  -- | The main command set, the only one currently commandSet = CommandSet@@ -66,706 +67,16 @@         , cmdShowHistory         , cmdAddFeed         , cmdDeleteFeed+        , cmdWhere+        , cmdWhereLocal+        , cmdWhereGlobal+        , cmdAddWhereLocal+        , cmdRemoveWhereLocal+        , cmdAddWhereGlobal+        , cmdRemoveWhereGlobal+        , cmdPuppetStart+        , cmdPuppetEnd+        , cmdPuppetSay+        , cmdPuppetEcho         ]-    }------------------------------------------------------------------------------------ Echo command--- Send the input back to the IRC channel----------------------------------------------------------------------------------respondEcho _mchan _nick []      send = send " "-respondEcho _mchan _nick [param] send = send param-respondEcho _mchan _nick params  send = send $ unwords params--cmdEcho = Command-    { cmdNames   = ["echo"]-    , cmdRespond = respondEcho-    , cmdHelp    = "‘echo <text>’ - display the given text. Probably not a \-                   \useful command. Exists as an example and for testing."-    }------------------------------------------------------------------------------------ Help command--- Show command help strings----------------------------------------------------------------------------------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-                "No such command, or invalid settings path. \-                \Maybe try just ‘!help’ without a parameter."-    where-    cname' = case cname of-        []     -> cname-        (c:cs) -> if c == csetPrefix commandSet then cs else cname--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."--cmdHelp' = Command-    { cmdNames   = ["help", "Help", "h", "?"]-    , cmdRespond = respondHelp-    , 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."-    }------------------------------------------------------------------------------------ Info command--- Ask the bot to display some information----------------------------------------------------------------------------------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\-        \• 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 \-        \<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 \-        \<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:     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 \-        \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"-      , "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"-      , "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 \-        \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 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 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 \-        \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."-      )-    , ( "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 =-    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) Nothing--cmdInfo = Command-    { cmdNames   = ["info", "i"]-    , cmdRespond = respondInfo-    , cmdHelp    = "‘info’         - list topics. Also see ‘help’.\n\-                   \‘info <topic>’ - display topic information."-    }------------------------------------------------------------------------------------ Tell command--- Tell something to some other user------------------------------------------------------------------------------------ Given whether to always send privately, return a command response-respondTell priv mchan sender (recip:msghead:msgtail) _send =-    submitMemo sender mchan recip priv (unwords $ msghead : msgtail)-respondTell _priv mchan nick args _send =-    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing--cmdPTell = 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-    { 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."-    }------------------------------------------------------------------------------------ Get, set, enable and disable commands--- Manage bot settings----------------------------------------------------------------------------------respondGet _mchan _nick []     send  = respondGet' "" send-respondGet _mchan _nick [path] send  = respondGet' path send-respondGet mchan  nick  args   _send =-    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)--respondSet _mchan _nick [name, val] send  = respondSet' name val send-respondSet mchan  nick  args        _send =-    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)--respondReset _mchan _nick [name] send  = respondReset' name send-respondReset mchan  nick  args   _send =-    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)---- Given a boolean, create an enable/disable response accordingly-respondBool val  _mchan _nick [name] send  =-    respondSet' name (showOption val) send-respondBool _val mchan  nick  args   _send =-    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)--respondEnable = respondBool True--respondDisable = respondBool False--cmdGet = Command-    { cmdNames   = ["get"]-    , cmdRespond = respondGet-    , cmdHelp    = "‘get <option>’ - get the value of a settings option at the \-                \given path"-    }--cmdSet = Command-    { cmdNames   = ["set"]-    , cmdRespond = respondSet-    , cmdHelp    = "‘set <option> <value>’ - set a settings option at the \-                   \given path to the given value"-    }--cmdReset = Command-    { cmdNames   = ["reset"]-    , cmdRespond = respondReset-    , cmdHelp    = "‘reset <option>’ - set a settings option at the given \-                   \path to its default value"-    }--cmdEnable = Command-    { cmdNames   = ["enable"]-    , cmdRespond = respondEnable-    , cmdHelp    = "‘enable <option>’ - set a settings option at the given \-                   \path to True"-    }--cmdDisable = Command-    { 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,--- get-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 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)--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."-    }------------------------------------------------------------------------------------ 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/Commands/Channels.hs view
@@ -0,0 +1,145 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Visit, join, leave commands+--+-- Manage bot channels+module FunBot.Commands.Channels+    ( cmdVisit+    , cmdJoin+    , cmdLeave+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util (getHistoryLines, cmds, helps)+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++respondVisit+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondVisit _mchan _nick [chan] send = do+    memb <- botMemberOf $ Channel chan+    send $ MsgContent $ if memb+        then "I’m already a member of that channel. I think. Trying anyway."+        else "Visiting " <> chan+    joinChannel (Channel chan) Nothing+respondVisit mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdVisit = Command+    { cmdNames    = cmds ["visit"]+    , cmdRespond  = respondVisit+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "visit #freepost"+        ]+    }++respondJoin+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondJoin _mchan _nick [chan] send = do+    memb <- botMemberOf $ Channel chan+    sel <- channelSelected $ Channel chan+    send $ MsgContent $ if memb && sel+        then "I'm already a member of that channel. I think. Trying anyway."+        else "Becoming a member of " <> chan+    joinChannel (Channel chan) Nothing+    addChannel $ Channel chan+respondJoin mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdJoin = Command+    { cmdNames    = cmds ["join"]+    , cmdRespond  = respondJoin+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "join #freepost"+        ]+    }++respondLeave+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondLeave Nothing _nick [] send = send $ MsgContent "This works only in a channel."+respondLeave (Just chan) nick [] send = do+    unselectChannel chan+    send $ MsgContent $ "Leaving the channel for now. Bye! o/"+    partChannel chan $ Just $ Comment $ "Asked by " <> unNickname nick <> " to leave"+respondLeave mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 0)++cmdLeave = Command+    { cmdNames    = cmds ["leave"]+    , cmdRespond  = respondLeave+    , cmdHelp     = helps+        [ ( "leave"+          , "ask me 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."+          )+        ]+    , cmdExamples =+        [ "leave #freepost"+        ]+    }
+ src/FunBot/Commands/Feeds.hs view
@@ -0,0 +1,110 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Add-feed and delete-feed commands+--+-- Add and remove news feeds to watch+module FunBot.Commands.Feeds+    ( cmdAddFeed+    , cmdDeleteFeed+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util (getHistoryLines, cmds, helps)+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++respondAddFeed+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondAddFeed mchan nick [label, url] send = do+    succ <- addFeed (FeedLabel $ CI.mk label) url+    if succ+        then send $ MsgContent "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    = cmds ["feed+", "add-feed"]+    , cmdRespond  = respondAddFeed+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "feed+ freepost http://freepo.st/rss/freepost"+        ]+    }++respondDeleteFeed+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondDeleteFeed mchan nick [label] send = do+    succ <- deleteFeed $ FeedLabel $ CI.mk label+    if succ+        then send $ MsgContent "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    = cmds ["feed-", "delete-feed"]+    , cmdRespond  = respondDeleteFeed+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "feed- freepost"+        ]+    }
+ src/FunBot/Commands/History.hs view
@@ -0,0 +1,88 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Show-history command+--+-- Show channel history+module FunBot.Commands.History+    ( cmdShowHistory+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util (getHistoryLines, cmds, helps)+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++respondShowHistory+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondShowHistory (Just chan) nick [mins] _send =+    case TR.decimal mins of+        Right (m, "") -> reportHistory' nick chan m+        _ -> failToChannel chan nick $ InvalidArg (Just 1) (Just mins)+respondShowHistory mchan nick [mins, chan] _send =+    case TR.decimal mins of+        Right (m, "") -> reportHistory' nick (Channel chan) m+        _ -> failBack mchan nick $ InvalidArg (Just 1) (Just mins)+respondShowHistory mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing++cmdShowHistory = Command+    { cmdNames    = cmds ["show-history"]+    , cmdRespond  = respondShowHistory+    , cmdHelp     = helps+        [ ( "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."+          )+        , ( "show-history <mins> <channel>"+          , "the same, for the specified channel. Use this variant in a \+            \private message to the bot."+          )+        ]+    , cmdExamples =+        [ "show-history 5"+        , "show-history 5 #freepost"+        ]+    }
+ src/FunBot/Commands/Info.hs view
@@ -0,0 +1,306 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Help and info commands+--+-- Show command help, settings help, info topics+module FunBot.Commands.Info+    ( cmdHelp'+    , cmdInfo+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.Config (introInfo)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util+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 Network.IRC.Fun.Client.IO (connNickname)+import Text.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++respondHelp+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondHelp _mchan nick [cname] send = do+    cset <- askBehaviorS $ head . commandSets+    let prefix = csetPrefix cset+        cname' = CommandName $ CI.mk $ case T.uncons cname of+            Nothing     -> cname+            Just (c, r) -> if c == prefix then r else cname+    case find ((cname' `elem`) . cmdNames) $ csetCommands cset of+        Just cmd -> do+            bnick <- askConfigS $ unNickname . connNickname . cfgConnection+            let refs =+                    [ T.singleton prefix+                    , bnick <> ": "+                    , bnick <> ", "+                    ]+                refsC = cycle refs+                pseudoRandom = T.length (unNickname nick) `mod` length refs+                refsCR = drop pseudoRandom refsC+                exline p t = "\nExample: " <> p <> t+                examples = map (uncurry exline) $ zip refsCR (cmdExamples cmd)+                cmdnames = map (CI.original . unCommandName) $ cmdNames cmd+            send $ MsgContent $ T.concat $+                  cmdHelp cmd+                : "\nCommand names: "+                : T.intercalate ", " cmdnames+                : examples+        Nothing  -> do+            succ <- respondSettingsHelp cname send+            unless succ $ send $ MsgContent+                "No such command, or invalid settings path. \+                \Maybe try just ‘!help’ without a parameter."+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."+cmdHelp' = Command+    { cmdNames    = cmds ["help", "h", "?"]+    , cmdRespond  = respondHelp+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "help echo"+        , "help channels.#freepost.welcome"+        ]+    }++topics =+    [ ( "intro"+      , introInfo <> "\nYou 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, issues, 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\+        \• 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 \+        \<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 \+        \<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:     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: " <>+        -- T.unwords (map (CI.original . unCommandName . 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 \+        \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"+      , "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"+      , "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 \+        \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 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 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 \+        \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."+      )+    , ( "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."+      )+    , ( "locations"+      , "I maintain a simple key-value mapping, where both keys and values \+        \are text. The intended usage (but certainly not the only usage \+        \possible) is to map short labels to URLs, therefore I call this \+        \mapping the location map, or the Where map. There is a single \+        \“global” map and each channel has its own map too. When searching \+        \for a given label I go to the per-channel map, and if I can’t find \+        \the label there, then I check in the global map. The commands for \+        \querying the location map are !where, !lwhere and !gwhere. The \+        \commands for adding and removing locations are !lwhere+, !gwhere+, \+        \!lwhere- and !gwhere-. It’s also possible to view and modify the map \+        \values (the URLs) using the settings system (e.g. !get and !set)."+      )+    , ( "puppet"+      , "I have a puppet system which allows IRC users to send arbitrary \+        \messages through me. This can be useful for manually identifying me \+        \with NickServ and probably for various hacks. But this feature may \+        \also be dangerous, therefore it has some safety mechanisms and in \+        \general you should use it with care. It works as follows: There are \+        \lists of “puppeteers”, which are users who can use the puppet \+        \system. There’s one global list for users who can use the system in \+        \any channel, and there are per-channel lists, in which users can use \+        \the system only in the channel where they’re listed. The users in \+        \the global list can also use the system in private messages. Once \+        \you’re a puppeteer, you can start puppet mode using the \+        \!puppet-start command. Then you can use !puppet-say or !puppet-echo \+        \to ask me to send your message. Finally, use !puppet-end to turn off \+        \puppet mode. TODO at the time of writing there are no commands yet \+        \for private puppet mode. There are also no commands for managing the \+        \puppeteer lists: This requires access to my JSON state files."+      )+    ]++respondInfo+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondInfo _mchan _nick [] send =+    send $ MsgContent $ "Topics: " <> T.intercalate ", " (map fst topics)+respondInfo mchan nick [arg] send =+    case lookup arg topics of+        Just msg -> send $ MsgContent msg+        Nothing ->  failBack mchan nick $ InvalidArg (Just 1) (Just arg)+respondInfo mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing++cmdInfo = Command+    { cmdNames    = cmds ["info", "i"]+    , cmdRespond  = respondInfo+    , cmdHelp     = helps+        [ ("info"         , "list topics. Also see ‘help’.")+        , ("info <topic>" , "display topic information.")+        ]+    , cmdExamples =+        [ "info"+        , "info shortcuts"+        ]+    }
+ src/FunBot/Commands/Locations.hs view
@@ -0,0 +1,357 @@+{- This file is part of funbot.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Where, lwhere, gwhere, lwhere+, lwhere-, gwhere+, gwhere- commands+--+-- Manage and query locations+module FunBot.Commands.Locations+    ( cmdWhere+    , cmdWhereLocal+    , cmdWhereGlobal+    , cmdAddWhereLocal+    , cmdRemoveWhereLocal+    , cmdAddWhereGlobal+    , cmdRemoveWhereGlobal+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import Formatting ((%))+import FunBot.History (quote, reportHistory')+import FunBot.Locations+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels+import FunBot.Settings.Sections.Locations+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util+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 Network.IRC.Fun.Color.Format (formatMsg)+import Network.IRC.Fun.Color.Format.Long+import Network.IRC.Fun.Types.Base+import Text.Read (readMaybe)++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR+--import qualified Network.IRC.Fun.Color.Format.Short as F++respondLookup+    :: (LocationLabel -> BotSession (Maybe Location))+    -> Nickname+    -> Text+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondLookup flookup nick labelt send = do+    let label = LocationLabel $ CI.mk labelt+    mloc <- flookup label+    case mloc of+        Nothing  -> send $ formatMsg+            (nickname % ", location ‘" % text % "’ not found.")+            nick labelt+        Just loc -> send $ MsgContent $ labelt <> " : " <> unLocation loc++respondLookupBoth+    :: Channel+    -> Nickname+    -> Text+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondLookupBoth chan = respondLookup $ lookupBoth chan++respondLookupLocal+    :: Channel+    -> Nickname+    -> Text+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondLookupLocal chan = respondLookup $ lookupLocal chan++respondLookupGlobal+    :: Nickname+    -> Text+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondLookupGlobal = respondLookup lookupGlobal++respondWhere+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondWhere mchan nick [labelt] send =+    let respond = maybe respondLookupGlobal respondLookupBoth mchan+    in  respond nick labelt send+respondWhere mchan nick [labelt, chant] send =+    let chan = Channel chant+    in  if looksLikeChan chan+            then respondLookupBoth chan nick labelt send+            else send $ notchan chan+respondWhere mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing++cmdWhere = Command+    { cmdNames    = cmds ["where"]+    , cmdRespond  = respondWhere+    , cmdHelp     = +        "‘where <label>’           - get the location stored for the given \+        \label. This checks in the per-channel location map first. If the \+        \label isn’t found there, then the global map is checked. If used in \+        \private chat with me, only the global map is used.\n\+        \‘where <label> <channel>’ - the same idea, except now the \+        \per-channel map used isn’t picked by the channel in which the command \+        \was sent, but the channel is explicitly specified. This allows the \+        \per-channel maps to be used in privately sent commands too."+    , cmdExamples =+        [ "where code"+        , "where mumble #freepost"+        ]+    }++respondWhereLocal+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondWhereLocal (Just chan) nick [labelt] send =+    respondLookupLocal chan nick labelt send+respondWhereLocal Nothing nick [labelt] send =+    send $ MsgContent $+        unNickname nick <>+        ": please specify a channel, or use this command in a channel"+respondWhereLocal mchan nick [labelt, chant] send =+    let chan = Channel chant+    in  if looksLikeChan chan+            then respondLookupLocal chan nick labelt send+            else send $ notchan chan+respondWhereLocal mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing++cmdWhereLocal = Command+    { cmdNames    = cmds ["lwhere", "where-local"]+    , cmdRespond  = respondWhereLocal+    , cmdHelp     = helps+        [ ( "lwhere <label>"+          , "get the location stored for the given label. This checks only \+            \the per-channel location map, according to the channel in which \+            \the command is sent."+          )+        , ( "lwhere <label> <channel>"+          , "the same idea, except now the per-channel map of the specified \+            \channel is used. This allows the per-channel maps to be used in \+            \privately sent commands too."+          )+        ]+    , cmdExamples =+        [ "lwhere code"+        , "lwhere mumble #freepost"+        ]+    }++respondWhereGlobal+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondWhereGlobal _mchan nick [labelt] send =+    respondLookupGlobal nick labelt send+respondWhereGlobal mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdWhereGlobal = Command+    { cmdNames    = cmds ["gwhere", "where-global"]+    , cmdRespond  = respondWhereGlobal+    , cmdHelp     = helps+        [ ( "gwhere <label>"+          , "get the location stored for the given label. This checks only \+            \the global location map."+          )+        ]+    , cmdExamples =+        [ "gwhere issues"+        ]+    }++respondAddWhereLocal+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondAddWhereLocal Nothing nick (_labelt : _locw@(_:_)) send =+    send $ MsgContent $+    unNickname nick <> ", this command works only in a channel"+respondAddWhereLocal (Just chan) nick (labelt : locw@(_:_)) send = do+    let label = LocationLabel $ CI.mk labelt+        loc = Location $ T.unwords locw+    res <- addLocalLocation chan label loc+    case res of+        Nothing ->+            send $ formatMsg+                ("Location ‘" % text % "’ registered for " % channel)+                labelt chan+        Just False ->+            send $ formatMsg+                ( nickname % ", " % channel % " isn’t one of my autojoin \+                \channels. If you’d like to add it to my list, you should \+                \probably talk to my maintainer. Once added, you can define \+                \locations for this channel."+                )+                nick chan+        Just True -> send $ formatMsg+                ( nickname % ", location ‘" % text % "’ is already registered \+                \for " % channel % ". You can use ‘!set’ to modify it."+                )+                nick labelt chan+respondAddWhereLocal mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)++cmdAddWhereLocal = Command+    { cmdNames    =+        cmds ["lwhere+", "where-local+", "add-lwhere", "add-where-local"]+    , cmdRespond  = respondAddWhereLocal+    , cmdHelp     = helps+        [ ( "lwhere+ <label> <location>"+          , "add a new location with the given label to the per-channel \+            \location map of the channel in which the command is sent."+          )+        ]+    , cmdExamples =+        [ "lwhere+ fsf https://fsf.org"+        , "lwhere+ Jane Climbing a mountain, back next week"+        ]+    }++respondRemoveWhereLocal+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondRemoveWhereLocal Nothing nick [_labelt] send =+    send $ MsgContent $+    unNickname nick <> ", this command works only in a channel"+respondRemoveWhereLocal (Just chan) nick [labelt] send = do+    let label = LocationLabel $ CI.mk labelt+    succ <- removeLocalLocation chan label+    if succ+        then send $ formatMsg+                ("Location ‘" % text % "’ removed for " % channel)+                labelt chan+        else send $ formatMsg+                ( nickname % ", can’t delete: there is no location ‘" % text+                % "’ registered for " % channel+                )+                nick labelt chan+respondRemoveWhereLocal mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdRemoveWhereLocal = Command+    { cmdNames    =+        cmds ["lwhere-", "where-local-", "delete-lwhere", "delete-where-local"]+    , cmdRespond  = respondRemoveWhereLocal+    , cmdHelp     = helps+        [ ( "lwhere- <label>"+          , "remove the location with the given label from the per-channel \+            \location map of the channel in which the command is sent."+          )+        ]+    , cmdExamples =+        [ "lwhere- website"+        ]+    }++respondAddWhereGlobal+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondAddWhereGlobal _mchan nick (labelt : locw@(_:_)) send = do+    let label = LocationLabel $ CI.mk labelt+        loc = Location $ T.unwords locw+    success <- addLocation label loc+    send $ if success+        then MsgContent $ "Global location ‘" <> labelt <> "’ registered"+        else formatMsg+                ( nickname % ", global location ‘" % text % "’ is already \+                \registered. You can use ‘!set’ to modify it."+                )+                nick labelt+respondAddWhereGlobal mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)++cmdAddWhereGlobal = Command+    { cmdNames    =+        cmds ["gwhere+", "where-global+", "add-gwhere", "add-where-global"]+    , cmdRespond  = respondAddWhereGlobal+    , cmdHelp     = helps+        [ ( "gwhere+ <label> <location>"+          , "add a new location with the given label to the global location \+            \map."+          )+        ]+    , cmdExamples =+        [ "gwhere+ fsf https://fsf.org"+        , "gwhere+ John Took a flight to the moon, back next week"+        ]+    }++respondRemoveWhereGlobal+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondRemoveWhereGlobal _mchan nick [labelt] send = do+    let label = LocationLabel $ CI.mk labelt+    success <- removeLocation label+    send $ if success+        then MsgContent $ "Global location ‘" <> labelt <> "’ removed"+        else formatMsg+                ( nickname % ", can’t delete: there is no global location ‘"+                % text % "’ registered"+                )+                nick labelt+respondRemoveWhereGlobal mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdRemoveWhereGlobal = Command+    { cmdNames    = cmds+        ["gwhere-", "where-global-", "delete-gwhere", "delete-where-global"]+    , cmdRespond  = respondRemoveWhereGlobal+    , cmdHelp     = helps+        [ ( "gwhere- <label>"+          , "remove the location with the given label from the global \+            \location map."+          )+        ]+    , cmdExamples =+        [ "gwhere- githu8"+        ]+    }
+ src/FunBot/Commands/Memos.hs view
@@ -0,0 +1,116 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Tell command+--+-- Tell something to some other user+module FunBot.Commands.Memos+    ( cmdPTell+    , cmdCTell+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++-- Given whether to always send privately, return a command response+respondTell+    :: Bool+    -> Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondTell priv mchan sender (recip : ws@(_:_)) send =+    let unsnoc t =+            if T.null t+                then Nothing+                else Just (T.init t, T.last t)+        recip' =+            case unsnoc recip of+                Just (r, ':') -> r+                Just (r, ',') -> r+                _             -> recip+        msg = MsgContent $ T.unwords ws+    in  if looksLikeNick recip'+            then submitMemo sender mchan (Nickname recip') priv msg+            else send $ notnick recip'+respondTell _priv mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing++cmdPTell = Command+    { cmdNames    = cmds ["tell", "ptell"]+    , cmdRespond  = respondTell True+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "tell johndoe Hello! How are you?"+        , "tell johndoe, Hello! How are you?"+        , "tell johndoe: Hello! How are you?"+        ]+    }++cmdCTell = Command+    { cmdNames    = cmds ["ctell"]+    , cmdRespond  = respondTell False+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "ctell johndoe Hello! How are you?"+        , "ctell johndoe, Hello! How are you?"+        , "ctell johndoe: Hello! How are you?"+        ]+    }
+ src/FunBot/Commands/Misc.hs view
@@ -0,0 +1,107 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Commands.Misc+    ( cmdEcho+    , cmdQuote+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util (getHistoryLines, cmds, helps)+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++-------------------------------------------------------------------------------+-- Echo command+-- Send the input back to the IRC channel+-------------------------------------------------------------------------------++respondEcho+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondEcho _mchan _nick []      send = send $ MsgContent " "+respondEcho _mchan _nick [param] send = send $ MsgContent param+respondEcho _mchan _nick params  send = send $ MsgContent $ T.unwords params++cmdEcho = Command+    { cmdNames    = cmds ["echo"]+    , cmdRespond  = respondEcho+    , cmdHelp     = helps+        [ ( "echo <text>"+          , "display the given text. Probably not a useful command. Exists as \+            \an example and for testing."+          )+        ]+    , cmdExamples =+        [ "echo This is a test"+        ]+    }++-------------------------------------------------------------------------------+-- Quote command+-- Record something someone said+-------------------------------------------------------------------------------++respondQuote+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondQuote (Just chan) _nick [target] _send = quote chan $ Nickname target+respondQuote Nothing     _nick [_]      _send = return ()+respondQuote mchan       nick  args     _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdQuote = Command+    { cmdNames    = cmds ["quote"]+    , cmdRespond  = respondQuote+    , cmdHelp     = helps+        [ ( "quote <nick>"+          , "record the last message sent by <nick> in the channel. The list \+            \of past quotes is publicly available."+          )+        ]+    , cmdExamples =+        [ "quote johndoe"+        ]+    }
+ src/FunBot/Commands/Puppet.hs view
@@ -0,0 +1,200 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Commands.Puppet+    ( cmdPuppetStart+    , cmdPuppetEnd+    --, cmdPuppetStatus+    , cmdPuppetSay+    , cmdPuppetEcho+    )+where++import Formatting ((%))+import FunBot.Puppet+import FunBot.Types+import FunBot.Util+import Network.IRC.Fun.Bot.Chat+import Network.IRC.Fun.Bot.Types+import Network.IRC.Fun.Color.Format (formatMsg)+import Network.IRC.Fun.Color.Format.Long+import Network.IRC.Fun.Types.Base++import qualified Data.Text as T++start :: Channel -> Nickname -> (MsgContent -> BotSession ()) -> BotSession ()+start chan nick send = do+    result <- puppetStart chan nick+    send $ case result of+        Just False ->+            formatMsg+                (nickname % ", I already have " % channel % " in puppet mode.")+                nick chan+        Just True ->+            formatMsg+                ( nickname+                % ", you aren’t listed as a puppeteer for "+                % channel+                )+                nick chan+        Nothing   ->+            formatMsg+                (nickname % ", puppet mode started for " % channel)+                nick chan++respondPuppetStart :: Respond+respondPuppetStart Nothing _nick [] send =+    send "Please specify a channel, or use this command in a channel."+respondPuppetStart (Just chan) nick [] send = start chan nick send+respondPuppetStart _mchan nick [chant] send =+    let chan = Channel chant+    in  if looksLikeChan chan+            then start chan nick send+            else send $ notchan chan+respondPuppetStart mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing++cmdPuppetStart :: BotCmd+cmdPuppetStart = Command+    { cmdNames    = cmds ["puppet-start"]+    , cmdRespond  = respondPuppetStart+    , cmdHelp     = helps+        [ ( "puppet-start"+          , "enable puppet mode in the current channel"+          )+        , ( "puppet-start <channel>"+          , "enable puppet mode in the given channel"+          )+        ]+    , cmdExamples =+        [ "puppet-start"+        , "puppet-start #freepost-bot"+        ]+    }++end :: Channel -> Nickname -> (MsgContent -> BotSession ()) -> BotSession ()+end chan nick send = do+    result <- puppetEnd chan nick+    send $ case result of+        Just False ->+            formatMsg+                (nickname % ", I don’t have " % channel % " in puppet mode.")+                nick chan+        Just True ->+            formatMsg+                ( nickname+                % ", you aren’t listed as a puppeteer for "+                % channel+                )+                nick chan+        Nothing   ->+            formatMsg+                (nickname % ", puppet mode ended for " % channel)+                nick chan++respondPuppetEnd :: Respond+respondPuppetEnd Nothing _nick [] send =+    send "Please specify a channel, or use this command in a channel."+respondPuppetEnd (Just chan) nick [] send = end chan nick send+respondPuppetEnd _mchan nick [chant] send =+    let chan = Channel chant+    in  if looksLikeChan chan+            then end chan nick send+            else send $ notchan chan+respondPuppetEnd mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) Nothing++cmdPuppetEnd :: BotCmd+cmdPuppetEnd = Command+    { cmdNames    = cmds ["puppet-end"]+    , cmdRespond  = respondPuppetEnd+    , cmdHelp     = helps+        [ ( "puppet-end"+          , "stop puppet mode in the current channel"+          )+        , ( "puppet-end <channel>"+          , "stop puppet mode in the given channel"+          )+        ]+    , cmdExamples =+        [ "puppet-end"+        , "puppet-end #freepost-bot"+        ]+    }++respondPuppetSay :: Bool -> Respond+respondPuppetSay reveal _mchan nick (chant : ws@(_:_)) send =+    let chan = Channel chant+    in  if looksLikeChan chan+            then do+                let msg = MsgContent $ T.unwords ws+                result <- puppetSay chan nick msg reveal+                send $ case result of+                    Just False ->+                        formatMsg+                            ( nickname+                            % ", I don’t have "+                            % channel+                            % " in puppet mode."+                            )+                            nick chan+                    Just True ->+                        formatMsg+                            ( nickname+                            % ", you didn’t start puppet mode for "+                            % channel+                            )+                            nick chan+                    Nothing ->+                        formatMsg+                            (nickname % ", I sent the message to " % channel)+                            nick chan+            else send $ notchan chan+respondPuppetSay _reveal mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)++cmdPuppetSay :: BotCmd+cmdPuppetSay = Command+    { cmdNames    = cmds ["puppet-say"]+    , cmdRespond  = respondPuppetSay True+    , cmdHelp     = helps+        [ ( "puppet-say <channel> <message>"+          , "while in puppet mode, ask me to say something in the channel. I \+            \will reveal the message comes from you. If you don’t want that, \+            \see the puppet-echo command."+          )+        ]+    , cmdExamples =+        [ "puppet-say #freepost Hello world!"+        ]+    }++cmdPuppetEcho :: BotCmd+cmdPuppetEcho = Command+    { cmdNames    = cmds ["puppet-echo"]+    , cmdRespond  = respondPuppetSay False+    , cmdHelp     = helps+        [ ( "puppet-echo <channel> <message>"+          , "while in puppet mode, ask me to say something in the channel. I \+            \won’t reveal the message comes from you. Also see the puppet-say \+            \command."+          )+        ]+    , cmdExamples =+        [ "puppet-echo #freepost Hello world!"+        ]+    }
+ src/FunBot/Commands/Repos.hs view
@@ -0,0 +1,213 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Add-spec, delete-spec, add-repo, delete-repo commands+--+-- Manage git repo event announcement details+module FunBot.Commands.Repos+    ( cmdAddSpec+    , cmdDeleteSpec+    , cmdAddRepo+    , cmdDeleteRepo+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util (getHistoryLines, cmds, helps)+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++respondAddSpec+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondAddSpec mchan nick [host, space, repo, chan] send = do+    succ <-+        addRepoAnnSpec+            (DevHostLabel host)+            (RepoSpace $ CI.mk space)+            (RepoName $ CI.mk repo)+            (Channel chan)+    if succ+        then send $ MsgContent "Git event announcement spec added."+        else failBack mchan nick $ OtherFail "Repo not found."+respondAddSpec mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 4)++cmdAddSpec = Command+    { cmdNames    = cmds ["spec+", "add-spec"]+    , cmdRespond  = respondAddSpec+    , cmdHelp     = helps+        [ ( "spec+ <host> <space> <repo> <channel>"+          , "add a channel to which git repo events will be announced, with \+            \default settings"+          )+        ]+    , cmdExamples =+        [ "spec+ notabug SylvieLorxu CSSBox #freepost"+        ]+    }++respondDeleteSpec+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondDeleteSpec mchan nick [host, space, repo, num] send =+    case TR.signed TR.decimal num of+        Right (pos, "") ->+            if pos < 1+                then failBack mchan nick $ InvalidArg (Just 4) (Just num)+                else do+                    res <-+                        deleteRepoAnnSpec+                            (DevHostLabel host)+                            (RepoSpace $ CI.mk space)+                            (RepoName $ CI.mk repo)+                            (pos - 1)+                    case res of+                        Nothing ->+                            send $ MsgContent $+                                "Git event announcement spec " <>+                                num                            <>+                                " removed."+                        Just False ->+                            failBack mchan nick $+                            OtherFail "Repo not found."+                        Just True  ->+                            failBack mchan nick $+                            OtherFail "Spec number out of range."+        _ -> failBack mchan nick $ InvalidArg (Just 3) (Just num)+respondDeleteSpec mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 3)++cmdDeleteSpec = Command+    { cmdNames    = cmds ["spec-", "delete-spec"]+    , cmdRespond  = respondDeleteSpec+    , cmdHelp     = helps+        [ ( "spec- <host> <space> <repo> <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."+          )+        ]+    , cmdExamples =+        [ "spec- notabug fr33domlover oldstuff 1"+        ]+    }++invalid :: Text -> Bool+invalid t = T.null t || T.any (== '/') t++respondAddRepo+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondAddRepo mchan nick [host, space, repo, chan] send+    | invalid repo =+        failBack mchan nick $ InvalidArg (Just 3) (Just repo)+    | invalid space =+        failBack mchan nick $ InvalidArg (Just 2) (Just space)+    | otherwise = do+        res <-+            addRepo+                (DevHostLabel host)+                (RepoSpace $ CI.mk space)+                (RepoName $ CI.mk repo)+                (Channel chan)+        case res of+            Nothing -> send $ MsgContent "Git repo added."+            Just False ->+                failBack mchan nick $+                OtherFail "This host label isn’t registered."+            Just True ->+                failBack mchan nick $+                OtherFail "This repo is already registered."+respondAddRepo mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 4)++cmdAddRepo = Command+    { cmdNames    = cmds ["repo+", "add-repo"]+    , cmdRespond  = respondAddRepo+    , cmdHelp     = helps+        [ ( "repo+ <host> <space> <repo> <channel>"+          , "add a repo to announce its events in the given channel, with \+            \default settings."+          )+        ]+    , cmdExamples =+        [ "repo+ notabug Tsyesika Federated-MediaGoblin #mediagoblin"+        ]+    }++respondDeleteRepo+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondDeleteRepo mchan nick [host, space, repo] send = do+    succ <-+        deleteRepo+            (DevHostLabel host)+            (RepoSpace $ CI.mk space)+            (RepoName $ CI.mk repo)+    if succ+        then send $ MsgContent "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 3)++cmdDeleteRepo = Command+    { cmdNames    = cmds ["repo-", "delete-repo"]+    , cmdRespond  = respondDeleteRepo+    , cmdHelp     = helps+        [ ( "repo- <host> <space> <repo>"+          , "stop announcing events for the given repo and remove its \+            \settings."+          )+        ]+    , cmdExamples =+        [ "repo- notabug fr33domlover oldstuff"+        ]+    }
+ src/FunBot/Commands/Settings.hs view
@@ -0,0 +1,179 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Get, set, enable and disable commands+--+-- Manage bot settings+module FunBot.Commands.Settings+    ( cmdGet+    , cmdSet+    , cmdReset+    , cmdEnable+    , cmdDisable+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util (getHistoryLines, cmds, helps)+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++respondGet+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondGet _mchan _nick []     send  = respondGet' "" send+respondGet _mchan _nick [path] send  = respondGet' path send+respondGet mchan  nick  args   _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++respondSet+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondSet _mchan _nick [name, val] send  = respondSet' name val send+respondSet mchan  nick  args        _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)++respondReset+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondReset _mchan _nick [name] send  = respondReset' name send+respondReset mchan  nick  args   _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++-- Given a boolean, create an enable/disable response accordingly+respondBool+    :: Bool+    -> Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondBool val  _mchan _nick [name] send  =+    respondSet' name (showOption val) send+respondBool _val mchan  nick  args   _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1)++respondEnable+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondEnable = respondBool True++respondDisable+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondDisable = respondBool False++cmdGet = Command+    { cmdNames    = cmds ["get"]+    , cmdRespond  = respondGet+    , cmdHelp     = helps+        [ ( "get <option>"+          , "get the value of a settings option at the given path"+          )+        ]+    , cmdExamples =+        [ "get channels.#freepost.welcome"+        ]+    }++cmdSet = Command+    { cmdNames    = cmds ["set"]+    , cmdRespond  = respondSet+    , cmdHelp     = helps+        [ ( "set <option> <value>"+          , "set a settings option at the given path to the given value"+          )+        ]+    , cmdExamples =+        [ "set channels.#freepost.welcome yes"+        ]+    }++cmdReset = Command+    { cmdNames    = cmds ["reset"]+    , cmdRespond  = respondReset+    , cmdHelp     = helps+        [ ( "reset <option>"+          , "set a settings option at the given path to its default value"+          )+        ]+    , cmdExamples =+        [ "reset channels.#freepost.welcome"+        ]+    }++cmdEnable = Command+    { cmdNames    = cmds ["enable"]+    , cmdRespond  = respondEnable+    , cmdHelp     = helps+        [ ( "enable <option>"+          , "set a settings option at the given path to True"+          )+        ]+    , cmdExamples =+        [ "enable channels.#freepost.welcome"+        ]+    }++cmdDisable = Command+    { cmdNames    = cmds ["disable"]+    , cmdRespond  = respondDisable+    , cmdHelp     = helps+        [ ( "disable <option>"+          , "set a settings option at the given path to False"+          )+        ]+    , cmdExamples =+        [ "disable channels.#freepost.welcome"+        ]+    }
+ src/FunBot/Commands/Shortcuts.hs view
@@ -0,0 +1,113 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Add-shortcut, delete-shortcut commands+--+-- Manage shortcuts+module FunBot.Commands.Shortcuts+    ( cmdAddShortcut+    , cmdDeleteShortcut+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++respondAddShortcut+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondAddShortcut mchan nick [label, chan] send =+    if looksLikeChan $ Channel chan+        then do+            succ <- addShortcut (ShortcutLabel $ CI.mk label) (Channel chan)+            if succ+                then send $ MsgContent "Shortcut added."+                else failBack mchan nick $ OtherFail+                     "This shortcut is already registered."+        else send $ notchan $ Channel chan+respondAddShortcut mchan nick args _send =+    failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 2)++cmdAddShortcut = Command+    { cmdNames    = cmds ["shortcut+", "add-shortcut"]+    , cmdRespond  = respondAddShortcut+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "shortcut+ issue #snowdrift"+        ]+    }++respondDeleteShortcut+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondDeleteShortcut mchan nick [label] send = do+    succ <- deleteShortcut $ ShortcutLabel $ CI.mk label+    if succ+        then send $ MsgContent "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    = cmds ["shortcut-", "delete-shortcut"]+    , cmdRespond  = respondDeleteShortcut+    , cmdHelp     = helps+        [ ( "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."+          )+        ]+    , cmdExamples =+        [ "shortcut- issue"+        ]+    }
+ src/FunBot/Commands/UserOptions.hs view
@@ -0,0 +1,193 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++-- | Show-opts, enable-history, disable-history, set-history-lines,+-- get-history-lines, erase-opts commands+--+-- Manage user options+module FunBot.Commands.UserOptions+    ( cmdShowOpts+    , cmdEnableHistory+    , cmdDisableHistory+    , cmdSetLines+    , cmdEraseOpts+    )+where++import Control.Monad (unless, when)+import Data.List (find, intercalate)+import Data.Monoid ((<>))+import Data.Settings.Types (showOption)+import Data.Text (Text)+import FunBot.History (quote, reportHistory')+import FunBot.Memos (submitMemo)+import FunBot.Settings+import FunBot.Settings.Sections.Channels (addChannel)+import FunBot.Settings.Sections.Feeds (addFeed, deleteFeed)+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts (addShortcut, deleteShortcut)+import FunBot.Types+import FunBot.UserOptions+import FunBot.Util+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.Read (readMaybe)+import Network.IRC.Fun.Types.Base++import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import qualified Data.Text.Read as TR++priv = MsgContent "That command works only in private conversation with me."++respondShowOpts+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondShowOpts (Just _chan) _nick _args  send  = send priv+respondShowOpts Nothing      nick  []     _send = sendChannels nick+respondShowOpts Nothing      nick  [chan] send  =+    if looksLikeChan $ Channel chan+        then sendHistoryOpts nick $ Channel chan+        else send $ notchan $ Channel chan+respondShowOpts Nothing      nick  args   _send =+    failToUser nick $ WrongNumArgsN (Just $ length args) Nothing++cmdShowOpts = Command+    { cmdNames    = cmds ["show-opts", "show-options"]+    , cmdRespond  = respondShowOpts+    , cmdHelp     = helps+        [ ( "show-opts"+          , "list channels for which you set history display options."+          )+        , ( "show-opts <channel>"+          , "show history display options for the given channel."+          )+        ]+    , cmdExamples =+        [ "show-opts"+        , "show-opts #snowdrift"+        ]+    }++respondHistory+    :: Bool+    -> Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondHistory _enable (Just _chan) _nick _args  send  = send priv+respondHistory enable  Nothing      nick  [chan] send  =+    if looksLikeChan $ Channel chan+        then do+            setEnabled nick (Channel chan) enable+            hls <- getHistoryLines $ Channel chan+            when (enable && hls < 1) $ send $ MsgContent+                "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 $ Channel chan+respondHistory _enable Nothing      nick  args   _send =+    failToUser nick $ WrongNumArgsN (Just $ length args) (Just 1)++cmdEnableHistory = Command+    { cmdNames    = cmds ["history+", "enable-history"]+    , cmdRespond  = respondHistory True+    , cmdHelp     = helps+        [ ( "history+ <channel>"+          , "enable automatic history private display for the given channel."+          )+        ]+    , cmdExamples =+        [ "history+ #snowdrift"+        ]+    }++cmdDisableHistory = Command+    { cmdNames    = cmds ["history-", "disable-history"]+    , cmdRespond  = respondHistory False+    , cmdHelp     = helps+        [ ( "history- <channel>"+          , "disable automatic history private display for the given channel."+          )+        ]+    , cmdExamples =+        [ "history- #snowdrift-test"+        ]+    }++respondSetLines+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondSetLines (Just _chan) _nick _args       send  = send priv+respondSetLines Nothing      nick  [chan, len] send  =+    if looksLikeChan $ Channel chan+        then+            case TR.decimal len of+                Right (n, "") -> setMaxLines nick (Channel chan) n+                _             -> badLen+        else send $ notchan $ Channel 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    = cmds ["set-history-lines"]+    , cmdRespond  = respondSetLines+    , cmdHelp     = helps+        [ ( "set-history-lines <channel> <num>"+          , "set the maximal number of channel history lines to display."+          )+        ]+    , cmdExamples =+        [ "set-history-lines #snowdrift 10"+        ]+    }++respondEraseOpts+    :: Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()+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    = cmds ["erase-opts", "erase-options"]+    , cmdRespond  = respondEraseOpts+    , cmdHelp     = helps+        [ ( "erase-opts"+          , "reset all your options back to defaults."+          )+        ]+    , cmdExamples =+        [ "erase-opts"+        ]+    }
src/FunBot/Config.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -13,10 +13,13 @@  - <http://creativecommons.org/publicdomain/zero/1.0/>.  -} +{-# LANGUAGE OverloadedStrings #-}+ module FunBot.Config     ( stateSaveInterval     , configuration     , webListenerPort+    , webErrorLogFile     , feedErrorLogFile     , feedVisitInterval     , settingsFilename@@ -24,36 +27,41 @@     , userOptsFilename     , nicksFilename     , quoteDir+    , introInfo+    , welcomeDelay     ) where +import Data.Default.Class (def)+import Data.Text (Text) import Data.Time.Interval (time) import Data.Time.Units-import Network.IRC.Fun.Bot (defConfig)-import Network.IRC.Fun.Bot.Types (Connection (..), Config (..))+import Network.IRC.Fun.Bot.Types+import Network.IRC.Fun.Client.IO+import Network.IRC.Fun.Types.Base  stateSaveInterval = 3 :: Second -configuration = defConfig-    { cfgConnection = Connection-        { connServer   = "irc.freenode.net"-        , connPort     = 6667-        , connTls      = False -- not supported yet-        , connNick     = "bot_test_joe"+configuration = def+    { cfgConnection = def+        { connServer   = Hostname "irc.freenode.net"+        , connPort     = PortNumber 6667+        , connTls      = False+        , connNickname = Nickname "bot_test_joe"         , connPassword = Nothing         }-    , cfgChannels        = ["#freepost-bot-test"]+    , cfgChannels        = map Channel ["#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 +webErrorLogFile = "state/web-error.log"+ feedErrorLogFile = "state/feed-error.log"  feedVisitInterval = 5 :: Minute@@ -64,23 +72,24 @@ -- dir (or absolute), and Git won't be used. settingsFilename = "state/settings.json" --- | If you set a repo path in the configuration above ('stateRepo' field),--- then this path is relative to that repo and the memos 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.+-- | Same idea, for memos. 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.+-- | Same idea, for user options. userOptsFilename = "state/user-options.json" --- | 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.+-- | Same idea, for known nickname lists. nicksFilename = "state/nicks.json"  -- | Directory in which to place channel quotes. quoteDir = "state/quotes"++-- | Introductory information for use by the @!intro@ command.+introInfo :: Text+introInfo =+    "Hello. I’m an instance of FunBot, written in Haskell. No other info, \+    \sorry. Ask the bot maintainer to write something here."++-- | How much silent time the bot waits before it considers a channel quiet and+-- welcomes a new user. This is in seconds.+welcomeDelay = 60 :: Int
src/FunBot/ExtHandlers.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -24,8 +24,13 @@ import Control.Monad.IO.Class (liftIO) import Data.Char (toLower) import Data.Maybe (fromMaybe)+import Data.Foldable (mapM_) import Data.Monoid ((<>))+import Data.Sequence (Seq)+import Data.Text (Text) import Data.Time.Clock (diffUTCTime)+import Formatting hiding (text)+import FunBot.Config (welcomeDelay) import FunBot.ExtEvents import FunBot.Types import FunBot.Util (passes)@@ -34,50 +39,74 @@ import Network.IRC.Fun.Bot.Nicks (channelIsTracked, isInChannel) import Network.IRC.Fun.Bot.State import Network.IRC.Fun.Color-import Text.Printf (printf)+import Network.IRC.Fun.Types.Base+import Prelude hiding (mapM_) +import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Lazy as M import qualified Data.Text as T+import qualified Data.Text.IO as TIO 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+makeEllip :: Int -> Text+makeEllip len = T.center len ' ' "..." -formatCommit branch repo (Commit author msg url) =-    encode $-        Green #> Pure author <> " " <>-        Maroon #> Pure branch <> " " <>-        Purple #> Pure repo <> " | " <>-        Teal #> Pure msg <> " " <>-        Gray #> Pure url+formatCommit :: BranchName -> RepoName -> Commit -> MsgContent+formatCommit branch repo c =+    MsgContent $ encode $+        Green  #> plain (commitAuthor c)                <> " " <>+        Maroon #> plain (unBranchName branch)           <> " " <>+        Purple #> plain (CI.original $ unRepoName repo) <> " | " <>+        Teal   #> plain (commitTitle c)                 <> " " <>+        Gray   #> plain (commitUrl c) +formatEllipsis :: Int -> BranchName -> RepoName -> Int -> MsgContent formatEllipsis len branch repo n =-    encode $-        Green #> Pure (makeEllip len) <> " " <>-        Maroon #> Pure branch <> " " <>-        Purple #> Pure repo <> " | " <>-        Navy #> Pure ("... another " ++ show n ++ " commits ...")+    MsgContent $ encode $+        Green  #> plain (makeEllip len)                 <> " " <>+        Maroon #> plain (unBranchName branch)           <> " " <>+        Purple #> plain (CI.original $ unRepoName repo) <> " | " <>+        Navy   #> plain (sformat ("... another " % int % " commits ...") n) -formatTag (Tag author ref repo _owner) =-    encode $-        Green #> Pure author <> " " <>-        Purple #> Pure repo <> " " <>-        Teal #> Pure ref+formatTag :: ProjectObject Tag -> MsgContent+formatTag (ProjectObject repo tag) =+    MsgContent $ encode $+        Green  #> plain (tagAuthor tag) <> " " <>+        Purple #> plain (repoName repo) <> " " <>+        Teal   #> plain (tagRef tag) -formatMR (MergeRequest author iid _repo _owner title url action) =-    encode $-        Green #> Pure author <> " " <>-        Maroon #> Pure action <> " " <>-        Purple #> Pure ('#' : show iid) <> " | " <>-        Teal #> Pure title <> " " <>-        Gray #> Pure url+formatMR :: ProjectObject MergeRequest -> MsgContent+formatMR (ProjectObject repo mr) =+    MsgContent $ encode $+        Green  #> plain (mrAuthor mr)                   <> " " <>+        Maroon #> (plain $ mrAction mr <> " MR")        <> " " <>+        Orange #> plain (sformat ("#" % int) (mrId mr)) <> " " <>+        Purple #> plain (repoName repo)                 <> " | " <>+        Teal   #> plain (mrTitle mr)                    <> " " <>+        Gray   #> plain (mrUrl mr) +formatIssue :: ProjectObject Issue -> MsgContent+formatIssue (ProjectObject repo i) =+    MsgContent $ encode $+        Green  #> plain (issueAuthor i)                   <> " " <>+        Maroon #> (plain $ issueAction i <> " issue")     <> " " <>+        Orange #> plain (sformat ("#" % int) (issueId i)) <> " " <>+        Purple #> plain (repoName repo)                   <> " | " <>+        Teal   #> plain (issueTitle i)                    <> " " <>+        Gray   #> plain (issueUrl i)++formatNote :: ProjectObject Note -> MsgContent+formatNote (ProjectObject repo n) =+    MsgContent $ encode $+        Green  #> plain (noteAuthor n)  <>+        Maroon #> " commented on "     <>+        Orange #> plain (noteTarget n)  <> " " <>+        Purple #> plain (repoName repo) <> " | " <>+        Teal   #> plain (noteContent n) <> " " <>+        Gray   #> plain (noteUrl n)++formatNews :: NewsItem -> NewsItemFields -> MsgContent formatNews item fields =     let -- Filtered fields         filt pass val = if pass then val else Nothing@@ -85,10 +114,10 @@         fTitleF = filt (dispFeedTitle fields) (itemFeedTitle item)         urlF = filt (dispUrl fields) (itemUrl item)         -- Separate components-        author = fmap (\ a -> Green #> Pure a) authorF-        fTitle = fmap (\ ft -> Purple #> Pure ft) fTitleF-        iTitle = Teal #> Pure (itemTitle item)-        url = fmap (\ u -> Gray #> Pure u) urlF+        author = fmap (\ a -> Green #> plain a) authorF+        fTitle = fmap (\ ft -> Purple #> plain ft) fTitleF+        iTitle = Teal #> plain (itemTitle item)+        url = fmap (\ u -> Gray #> plain u) urlF         -- Now combine them         af = case (author, fTitle) of                 (Nothing,    Nothing)    -> Nothing@@ -98,25 +127,28 @@         iu = case url of                 Nothing -> iTitle                 Just u  -> iTitle <> " " <> u-    in  encode $ case af of+    in  MsgContent $ encode $ case af of             Nothing  -> iu             Just af' -> af' <> " | " <> iu -formatPaste (Paste author verb title url _chan) =-    printf "%v %v “%v” | %v" author verb title url--lower = map toLower--keyb b = (branchRepo b, lower $ branchRepoOwner b)--keyt t = (tagRepo t, lower $ tagRepoOwner t)--keym mr = (mrRepo mr, lower $ mrRepoOwner mr)+formatPaste :: Paste -> MsgContent+formatPaste p = MsgContent $ T.concat+    [ pasteAuthor p , " "+    , pasteVerb p   , " “"+    , pasteTitle p  , "” | "+    , pasteUrl p+    ] +annCommits+    :: BranchName+    -> [MsgContent]+    -> MsgContent+    -> RepoAnnSpec+    -> BotSession () annCommits branch msgs ellip spec =-    let chan = pAnnChannel spec-    in  when (branch `passes` pAnnBranches spec) $-        if pAnnAllCommits spec || length msgs <= 3+    let chan = rasChannel spec+    in  when (rasCommits spec && branch `passes` rasBranches spec) $+        if rasAllCommits spec || length msgs <= 3             then mapM_ (sendToChannel chan) msgs             else do                 let firstCommit = head msgs@@ -126,73 +158,128 @@                 sendToChannel chan ellip                 sendToChannel chan lastCommit +makeVerbal :: [Text] -> Text makeVerbal []     = "... ummm... I don’t know, actually. How embarrassing" makeVerbal [n]    = n-makeVerbal [n, m] = n ++ " and " ++ m-makeVerbal (n:ns) = n ++ ", " ++ makeVerbal ns+makeVerbal [n, m] = n <> " and " <> m+makeVerbal (n:ns) = n <> ", " <> makeVerbal ns -handler (GitPushEvent (Push branch commits)) = do-    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)-            in  mapM_ (annCommits (branchName branch) msgs ellip) specs-        Nothing ->-            liftIO $ putStrLn $-                "Ext handler: Git push for unregistered repo: " ++-                show (keyb branch)-handler (GitTagEvent tag) = do-    chans <- getStateS $ stGitAnnChans . bsSettings-    case M.lookup (keyt tag) chans of-        Just specs ->-            let msg = formatTag tag-                ann chan = sendToChannel chan msg-            in  mapM_ (ann . pAnnChannel) specs-        Nothing ->-            liftIO $ putStrLn $-                "Ext handler: Tag for unregistered repo: " ++-                show (keyt tag)-handler (MergeRequestEvent mr) = do-    chans <- getStateS $ stGitAnnChans . bsSettings-    case M.lookup (keym mr) chans of-        Just specs ->-            let msg = formatMR mr-                ann chan = sendToChannel chan msg-            in  mapM_ (ann . pAnnChannel) specs-        Nothing ->-            liftIO $ putStrLn $-                "Ext handler: MR for unregistered repo: " ++-                show (keym mr)-handler (NewsEvent item) = do+repoKey :: Repository -> (RepoSpace, RepoName)+repoKey repo =+    ( RepoSpace $ CI.mk $ repoSpace repo+    , RepoName $ CI.mk $ repoName repo+    )++handlePO+    :: (Text -> BotSession ())+    -> ProjectObject a+    -> Text+    -> (Seq RepoAnnSpec -> BotSession ())+    -> BotSession ()+handlePO elog (ProjectObject repo obj) desc act = do+    hosts <- getStateS $ stGitAnnChans . bsSettings+    sites <- getStateS $ stDevHosts . bsSettings+    case M.lookup (DevHost $ CI.mk $ repoHost repo) sites of+        Nothing -> elog $ sformat+            ( "Ext handler: "+            % stext+            % " for unregistered dev host: "+            % stext+            % " | "+            % shown+            )+            desc (repoHost repo) repo+        Just dhl -> case M.lookup dhl hosts of+            Nothing -> elog $ sformat+                ( "Ext handler: "+                % stext+                % " for unregistered dev host label section: "+                % stext+                % " | "+                % shown+                )+                desc (unDevHostLabel dhl) repo+            Just repos -> case M.lookup (repoKey repo) repos of+                Nothing -> elog $ sformat+                    ( "Ext handler: "+                    % stext+                    % " for unregistered repo under "+                    % stext+                    % ": "+                    % stext+                    % "/"+                    % stext+                    )+                    desc (unDevHostLabel dhl) (repoSpace repo) (repoName repo)+                Just specs -> act specs++handleSimple+    :: (Text -> BotSession ())+    -> ProjectObject a+    -> Text+    -> (RepoAnnSpec -> Bool)+    -> (ProjectObject a -> MsgContent)+    -> BotSession ()+handleSimple elog po desc enabled fmt =+    handlePO elog po desc $ \ specs ->+        let msg = fmt po+            ann spec =+                when (enabled spec) $ sendToChannel (rasChannel spec) msg+        in  mapM_ ann specs++handler'+    :: (Text -> BotSession ())+    -> (Text -> BotSession ())+    -> ExtEvent+    -> BotSession ()+handler' elog _dlog (GitPushEvent po) = handlePO elog po "Push" $ \ specs ->+    let repo = poRepo po+        push = poObj po+        branch = BranchName $ pushBranch push+        reponame = RepoName $ CI.mk $ repoName repo+        fmt = formatCommit branch reponame+        commits = pushCommits push+        msgs = map fmt commits+        len = case commits of+                [] -> 0+                cs -> T.length $ commitAuthor $ last cs+        ellip =+            formatEllipsis+                len+                branch+                reponame+                (length msgs - 2)+    in  mapM_ (annCommits branch msgs ellip) specs+handler' elog _dlog (GitTagEvent po) =+    handleSimple elog po "Tag" rasCommits formatTag+handler' elog _dlog (MergeRequestEvent po) =+    handleSimple elog po "MR" rasMergeRequests formatMR+handler' elog _dlog (IssueEvent po) =+    handleSimple elog po "Issue" rasIssues formatIssue+handler' elog _dlog (NoteEvent po) =+    handleSimple elog po "Note" rasNotes formatNote+handler' elog _dlog (NewsEvent item) = do     feeds <- getStateS $ stWatchedFeeds . bsSettings     let label = itemFeedLabel item-    case M.lookup label feeds of+    case M.lookup (FeedLabel $ CI.mk label) feeds of         Just NewsFeed { nfAnnSpec = spec } ->             let msg = formatNews item (nAnnFields spec)             in  mapM_ (\ chan -> sendToChannel chan msg) (nAnnChannels spec)-        Nothing -> liftIO $ do-            putStrLn $ "Ext handler: Feed item with unknown label: " ++ label-            print item-handler (PasteEvent paste) =-    sendToChannel (pasteChannel paste) $ formatPaste paste-handler (WelcomeEvent nick chan) = do+        Nothing -> do+            elog $ "Ext handler: Feed item with unknown label: " <> label+            elog $ T.pack $ show item+handler' _elog _dlog (PasteEvent paste) =+    sendToChannel (Channel $ pasteChannel paste) $ formatPaste paste+handler' _elog _dlog (WelcomeEvent nickt chant) = do     getTime <- askTimeGetter     now <- liftIO $ liftM fst getTime+    let chan = Channel chant+        nick = Nickname nickt     mt <- getStateS $ M.lookup chan . bsLastMsgTime     let quiet =             case mt of                 Nothing -> True-                Just t  -> diffUTCTime t now >= 60 --seconds+                Just t  -> diffUTCTime now t >= fromIntegral welcomeDelay     tracked <- channelIsTracked chan     isHere <- nick `isInChannel` chan     let assumeHere = tracked && isHere@@ -201,13 +288,23 @@         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)+                sendToChannel chan $ MsgContent $+                sformat+                    ( "Welcome, " % stext % "! 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 "+                    % stext % ". Also, if no one responds for a while, try \+                    \emailing us at " % stext % ", or just come back later."+                    )+                    nickt+                    (makeVerbal $ map unNickname $ csFolks cs)                     (csEmail cs)++handler+    :: (Text -> BotSession ())+    -> (Text -> BotSession ())+    -> ExtEvent+    -> BotSession ()+handler elog dlog event = do+    dlog $ T.pack $ show event+    handler' elog dlog event
src/FunBot/History.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@rel4tion.org>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -25,86 +25,126 @@  import Control.Monad (liftM, unless, when) import Control.Monad.IO.Class (liftIO)-import Data.Foldable (find, mapM_)+import Data.Foldable+import Data.Traversable (for) import Data.Int (Int64) import Data.Monoid ((<>))-import Data.Sequence ((|>), Seq, ViewL (..))+import Data.Sequence ((|>), Seq, ViewL (..), ViewR (..))+import Data.Text (Text)+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Formatting ((%), int) import FunBot.Config (quoteDir) import FunBot.Types 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.Bot.Types import Network.IRC.Fun.Color+import Network.IRC.Fun.Types.Base import Prelude hiding (mapM_) import System.IO import Text.Printf (printf)  import qualified Data.HashMap.Lazy as M import qualified Data.Sequence as Q+import qualified Data.Text as T+import qualified Data.Text.IO as TIO  findLast :: (a -> Bool) -> Seq a -> Maybe a findLast p s = fmap (Q.index s) $ Q.findIndexR p s -formatLine :: HistoryLine -> String+formatLine :: HistoryLine -> MsgContent formatLine hl =-    let time = Purple #> Pure (hlTime hl ++ " UTC")+    let time = Purple #> plain (hlTime hl <> " UTC")+        nick = unNickname $ hlNick hl         sender =             if hlAction hl                     then-                        "* " <> Green #> Pure (hlNick hl)+                        "* " <> Green #> plain nick                     else-                        Gray #> "<" <> Green #> Pure (hlNick hl) <> Gray #> ">"-        content = Pure $ hlMessage hl-    in  encode $ time <> " " <> sender <> " " <> content+                        Gray #> "<" <> Green #> plain nick <> Gray #> ">"+        content = plain $ unMsgContent $ hlMessage hl+    in  MsgContent $ encode $ time <> " " <> sender <> " " <> content +timeParted :: Channel -> Nickname -> BotSession (Maybe UTCTime)+timeParted chan nick = fmap f $ getCountLog chan+    where+    f q = case Q.viewr q of+            EmptyR                  -> Nothing+            r :> (MsgCountPart n t) -> if n == nick then Just t else f r+            r :> _                  -> f r++urlQuery :: UTCTime -> Text+urlQuery t =+    let stamp = floor $ utcTimeToPOSIXSeconds t+    in  format ("?timestamp=" % int % "#t" % int) stamp stamp++browseUrl :: Channel -> Nickname -> BotSession (Maybe Text)+browseUrl chan nick = do+    mcs <- getStateS $ M.lookup chan . stChannels . bsSettings+    let mbrowse = mcs >>= csBrowse+        getQuery = fmap urlQuery <$> timeParted chan nick+    for mbrowse $ \ b -> maybe b (b <>) <$> getQuery+ -- | Record someone's last message as a quote.-quote :: String ---      -> String ---      -> BotSession ()+quote :: Channel -> Nickname -> BotSession () quote chan nick = do     history <- getHistory     let sameNick hl = hlNick hl == nick     case M.lookup chan history >>= findLast sameNick of         Just hl -> do-            let file = quoteDir ++ "/server." ++ chan+            let file = quoteDir ++ "/server." ++ (T.unpack $ unChannel 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."+                TIO.hPutStrLn h $ hlTime hl+                TIO.hPutStrLn h $ unNickname nick+                TIO.hPutStrLn h $ unMsgContent $ hlMessage hl+            sendToChannel chan $ MsgContent "Quote logged."+        Nothing ->+            sendToChannel chan $ MsgContent "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+reportHistory+    :: Nickname -- ^ User nickname+    -> Channel  -- ^ Channel+    -> Int      -- ^ Maximal number of messages to send+    -> Bool     -- ^ Whether send notice instead of regular privmsg+    -> BotSession ()+reportHistory recip chan maxlen notice = do+    let send = sendToUser' notice     c <- chanIsCounted chan     missed <-         if c             then do                 res <- msgsSinceParted recip chan+                murl <- browseUrl chan recip                 case res of                     Left n  -> do-                        sendToUser recip $-                            printf-                                "You missed at least %v messages in %v."-                                n-                                chan+                        send recip $+                            formatMsg+                                ("You missed at least " % int % " messages in "+                                % channel % "."+                                )+                                n chan+                        for_ murl $ send recip . MsgContent                         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+                        if n == 0+                            then send recip $+                                    formatMsg+                                        ("You didn't miss any messages in "+                                        % channel % "."+                                        )                                         chan+                            else do+                                send recip $+                                    formatMsg+                                        ("You missed " % int % " messages in "+                                        % channel % "."+                                        )+                                        n chan+                                for_ murl $ send recip . MsgContent                         return $ Just n             else return Nothing     mhls <- liftM (M.lookup chan) getHistory@@ -116,30 +156,38 @@                 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 recip $+                    formatMsg+                        ("Last " % int % " messages in " % channel % ":")+                        l chan+                mapM_ (send 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'+    :: Nickname -- ^ User nickname+    -> Channel  -- ^ 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."+            sendToUser recip $ MsgContent+                "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+                            formatMsg+                                ("No messages in last " % int % " minutes.")+                                mins                     else do                         sendToUser recip $-                            printf-                                "Messages I remember from last %v minutes in \-                                \%v:"+                            formatMsg+                                ("Messages I remember from last " % int+                                % " minutes in " % channel % ":"+                                )                                 mins chan                         mapM_ (sendToUser recip . formatLine) hls
src/FunBot/IrcHandlers.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -29,96 +29,113 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Chan (writeChan) import Control.Exception (catch)-import Control.Monad (liftM, when, void)+import Control.Monad (liftM, unless, when, void) import Control.Monad.IO.Class (liftIO)-import Data.Char (isAlphaNum, toLower)+import Data.Char (isAlphaNum) import Data.Maybe (listToMaybe, mapMaybe)-import Data.List (isPrefixOf, stripPrefix)+import Data.Monoid ((<>))+import Data.Text (Text) import Data.Time.Units+import FunBot.Config (welcomeDelay) import FunBot.ExtEvents (ExtEvent (WelcomeEvent)) import FunBot.History (reportHistory) import FunBot.KnownNicks import FunBot.Memos (reportMemos, reportMemosAll) import FunBot.Types import FunBot.UserOptions (getUserHistoryOpts)+import FunBot.Util (unsnoc) import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.IRC.Fun.Bot.Chat (sendToChannel) import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Types.Base 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"]+import qualified Data.Text as T -waveWordsL :: [String]+waveWordsL :: [Text] waveWordsL = ["\\o", "\\O", "\\0"] -waveWordsR :: [String]+waveWordsR :: [Text] waveWordsR = ["o/", "O/", "0/"] -lastChars :: String+lastChars :: [Char] lastChars = ".!?" -isHello :: String -> Bool-isHello s =-    let s' = map toLower s-    in     null s-        || s' `elem` helloWords-        || init s' `elem` helloWords && last s' `elem` lastChars+isWord :: [Text] -> Maybe [Char] -> Text -> Bool+isWord ws mcs w =+    case listToMaybe $ mapMaybe (flip T.stripPrefix $ T.toLower w) ws of+        Nothing -> False+        Just r  ->+            case T.uncons $ T.stripStart r of+                Nothing     -> True+                Just (c, _) -> maybe True (c `elem`) mcs -isPing :: String -> Bool-isPing s =-    case stripPrefix "ping" $ map toLower s of-        Just []  -> True-        Just [c] -> c `elem` lastChars-        _        -> False+isHello :: Text -> Bool+isHello = isWord ["hello", "hi", "hey", "yo"] (Just lastChars) -isThanks :: String -> Bool-isThanks s =-    let slow = map toLower s-    in  case (stripPrefix "thanks" slow, stripPrefix "thank you" slow) of-            (Nothing, Nothing) -> False-            _                  -> True+isPing :: Text -> Bool+isPing = isWord ["ping"] (Just lastChars) -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"+isThanks :: Text -> Bool+isThanks = isWord ["thanks", "thank you"] Nothing++sayHello :: Channel -> Nickname -> MsgContent -> BotSession ()+sayHello chan (Nickname nick) (MsgContent msg)+    | isHello msg           = sendToChannel chan $ MsgContent $ "Hello, " <> nick+    | isPing msg            = sendToChannel chan $ MsgContent $ nick <> ", pong"+    | isThanks msg          = sendToChannel chan $ MsgContent $ nick <> ", you’re welcome!"+    | msg `elem` waveWordsL = sendToChannel chan $ MsgContent $ nick <> ": o/"+    | msg `elem` waveWordsR = sendToChannel chan $ MsgContent $ nick <> ": \\o"     | otherwise             = return () +recordTime :: Channel -> BotSession () recordTime chan = do     getTime <- askTimeGetter-    now <- liftIO $ liftM fst getTime+    now <- liftIO $ fmap fst getTime     let update = M.insert chan now     modifyState $ \ s -> s { bsLastMsgTime = update $ bsLastMsgTime s } -handleBotMsg chan nick msg full = do+handleBotMsg+    :: Channel+    -> Nickname+    -> MsgContent+    -> MsgContent+    -> BotSession ()+handleBotMsg chan nick msg _full = do     sayHello chan nick msg     recordTime chan +isUnderscored :: Nickname -> Channel -> BotSession Bool+isUnderscored nick chan =+    case unsnoc $ unNickname nick of+        Just (t, '_') -> nickIsKnown (Nickname t) chan+        _             -> return False++handleJoin :: Channel -> Nickname -> BotSession () 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+            ud <- isUnderscored nick chan+            unless ud $ do+                mcs <- getStateS $ M.lookup chan . stChannels . bsSettings+                let welcome = maybe False csWelcome mcs+                when welcome $ do+                    q <- askEnvS loopbackQueue+                    liftIO $ void $ forkIO $ do+                        threadDelay $ welcomeDelay * 1000 * 1000+                        writeChan q $ WelcomeEvent (unNickname nick) (unChannel chan)     hd <- getUserHistoryOpts nick chan-    when (hdEnabled hd) $ reportHistory nick chan (hdMaxLines hd)+    when (hdEnabled hd) $ reportHistory nick chan (hdMaxLines hd) True     reportMemos nick chan +goodHost :: B.ByteString -> Bool goodHost h =     let n = B.length h         suffix6 = B.drop (n - 6) h@@ -127,20 +144,22 @@         isCom = suffix4 == ".com"     in  not $ isCom || isCo +findTitle :: String -> Maybe Text findTitle page =     let tags = parseTags page         from = drop 1 $ dropWhile (not . isTagOpenName "title") tags         range = takeWhile (not . isTagCloseName "title") from         text = unwords $ words $ innerText range-    in  if null text then Nothing else Just text+    in  if null text then Nothing else Just $ T.pack text -sayTitle chan msg = when ("http" `isPrefixOf` msg) $ do+sayTitle :: Channel -> MsgContent -> BotSession ()+sayTitle chan (MsgContent msg) = when ("http" `T.isPrefixOf` msg) $ do     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+                request <- parseUrl $ T.unpack msg                 let h = host request                 if goodHost h                     then do@@ -152,32 +171,55 @@             getTitle = action `catch` handler         etitle <- liftIO getTitle         case etitle of-            Right (Just title) -> sendToChannel chan $ '“' : title ++ "”"+            Right (Just title) -> sendToChannel chan $ MsgContent $ "“" <> title <> "”"             _                  -> return () -search _   ""   = Nothing-search msg pref = f msg False+-- | Search for a shortcut prefix in the string, and return the word following+-- it (i.e. the argument) if found. Requirements and conditions:+--+-- * The prefix must come after a non-alphanum char (or beginning of message)+-- * The argument is the longest alphanum sequence following the prefix+--+-- (1) see if we have the prefix here+-- (2) if yes, take until non-alphanum and DONE+-- (3) if not, check if the first char is alphanum+-- (4) if yes, drop it and then all alphanum and repeat+-- (5) if not, drop it and repeat+search+    :: Text -- ^ Search in this+    -> Text -- ^ Search for this+    -> Maybe Text+search msg pref =+    if T.null pref+        then Nothing+        else f msg     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+    once t =+        case T.stripPrefix pref t of+            Just r  ->+                let a = T.takeWhile pick r+                in  if T.null a+                        then Nothing+                        else Just a+            Nothing -> Nothing+    f t =+        case once t of+            succ@(Just _) -> succ+            Nothing       ->+                case T.uncons t of+                    Nothing     -> Nothing+                    Just (c, r) ->+                        if skip c+                            then f $ T.dropWhile skip r+                            else f r -format cut s = shPrefix cut ++ s ++ " | " ++ shBefore cut ++ s ++ shAfter cut+format :: Shortcut -> Text -> Text+format cut t = T.concat [shPrefix cut, t, " | ", shBefore cut, t, shAfter cut] -sayTicket chan msg = do+sayTicket :: Channel -> MsgContent -> BotSession ()+sayTicket chan (MsgContent msg) = do     allCuts <- getStateS $ stShortcuts . bsSettings     let applies cut = chan `elem` shChannels cut         cuts = M.elems $ M.filter applies allCuts@@ -186,19 +228,27 @@         first = listToMaybe results     case first of         Nothing       -> return ()-        Just (cut, s) -> sendToChannel chan $ format cut s+        Just (cut, s) -> sendToChannel chan $ MsgContent $ format cut s +handleMsg :: Channel -> Nickname -> MsgContent -> Bool -> BotSession () handleMsg chan nick msg _mention = do     sayTitle chan msg     sayTicket chan msg     recordTime chan +handleAction :: Channel -> Nickname -> MsgContent -> Bool -> BotSession () handleAction chan nick msg _mention = do     sayTicket chan msg     recordTime chan +handleNickChange :: Nickname -> Nickname -> BotSession () handleNickChange _old new = reportMemosAll new +handleNames+    :: Channel+    -> ChannelPrivacy+    -> [(Privilege, Nickname)]+    -> BotSession () handleNames chan _priv pairs = do     sel <- channelSelected chan     when sel $ do
src/FunBot/KnownNicks.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -13,6 +13,8 @@  - <http://creativecommons.org/publicdomain/zero/1.0/>.  -} +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+ module FunBot.KnownNicks     ( rememberNick     , rememberNick'@@ -25,17 +27,19 @@ where  import Control.Monad.IO.Class (liftIO)+import Data.Aeson (FromJSON, ToJSON) 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 Network.IRC.Fun.Types.Base (Channel, Nickname (..))  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 :: Nickname -> Channel -> BotSession () rememberNick nick chan = do     chans <- getStateS bsKnownNicks     let nicks = M.lookup chan chans@@ -45,7 +49,7 @@  -- | 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' :: Nickname -> Channel -> BotSession Bool rememberNick' nick chan = do     chans <- getStateS bsKnownNicks     let ins ns = do@@ -60,7 +64,7 @@                 else ins $ S.insert nick nicks  -- | Consider these nicks known in the given channel from now on.-rememberNicks :: [String] -> String -> BotSession ()+rememberNicks :: [Nickname] -> Channel -> BotSession () rememberNicks nicks chan = do     chans <- getStateS bsKnownNicks     let new = S.fromList nicks@@ -70,24 +74,27 @@     modifyState $ \ s -> s { bsKnownNicks = chans' }  -- | Check whether the given nick is known in the given channel.-nickIsKnown :: String -> String -> BotSession Bool+nickIsKnown :: Nickname -> Channel -> BotSession Bool nickIsKnown nick chan = do     chans <- getStateS bsKnownNicks     return $ case M.lookup chan chans of         Nothing    -> False         Just nicks -> nick `S.member` nicks +deriving instance FromJSON Nickname+deriving instance ToJSON Nickname+ -- | Load known nicks data from JSON file.-loadKnownNicks :: IO (M.HashMap String (S.HashSet String))+loadKnownNicks :: IO (M.HashMap Channel (S.HashSet Nickname)) 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+        Right hm        -> return hm  -- | Create a safe async known nicks data saver action.-mkSaveKnownNicks :: IO (M.HashMap String (S.HashSet String) -> IO ())+mkSaveKnownNicks :: IO (M.HashMap Channel (S.HashSet Nickname) -> IO ()) mkSaveKnownNicks =     mkSaveStateChoose         stateSaveInterval
+ src/FunBot/Locations.hs view
@@ -0,0 +1,42 @@+{- This file is part of funbot.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module FunBot.Locations+    ( lookupLocal+    , lookupGlobal+    , lookupBoth+    )+where++import FunBot.Types+import Network.IRC.Fun.Bot.State (getStateS)+import Network.IRC.Fun.Types (Channel)++import qualified Data.HashMap.Lazy as M (lookup)++lookupLocal :: Channel -> LocationLabel -> BotSession (Maybe Location)+lookupLocal chan label = do+    chans <- getStateS $ stChannels . bsSettings+    return $ M.lookup chan chans >>= M.lookup label . csLocations++lookupGlobal :: LocationLabel -> BotSession (Maybe Location)+lookupGlobal label = do+    locs <- getStateS $ stLocations . bsSettings+    return $ M.lookup label locs++lookupBoth :: Channel -> LocationLabel -> BotSession (Maybe Location)+lookupBoth chan label = do+    mloc <- lookupLocal chan label+    maybe (lookupGlobal label) (return . Just) mloc
src/FunBot/Memos.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -29,13 +29,15 @@ import Control.Monad (liftM, mzero, unless) import Control.Monad.IO.Class (liftIO) import Data.Aeson hiding (encode)-import qualified Data.HashMap.Lazy as M+import Data.Aeson.Types (typeMismatch) import Data.JsonState import Data.List (partition) import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Time.Units (Second)+import Formatting hiding (text) import FunBot.Config (stateSaveInterval, configuration, memosFilename)+import FunBot.Settings.Instances import FunBot.Types import FunBot.Util ((!?), getTimeStr) import Network.IRC.Fun.Bot.Chat (sendToChannel, sendToUser)@@ -43,28 +45,31 @@ import Network.IRC.Fun.Bot.State import Network.IRC.Fun.Bot.Types (Config (cfgStateRepo)) import Network.IRC.Fun.Color-import Text.Printf (printf)+import Network.IRC.Fun.Types.Base +import qualified Data.HashMap.Lazy as M+import qualified Data.Text as T+ ------------------------------------------------------------------------------- -- Utilities ------------------------------------------------------------------------------- -getMemos :: BotSession (M.HashMap String [Memo])+getMemos :: BotSession (M.HashMap Nickname [Memo]) getMemos = getStateS bsMemos -putMemos :: M.HashMap String [Memo] -> BotSession ()+putMemos :: M.HashMap Nickname [Memo] -> BotSession () putMemos ms = modifyState $ \ s -> s { bsMemos = ms } -modifyMemos :: (M.HashMap String [Memo] -> M.HashMap String [Memo])+modifyMemos :: (M.HashMap Nickname [Memo] -> M.HashMap Nickname [Memo])             -> BotSession () 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+getUserMemos :: Nickname              -> BotSession [Memo]-getUserMemos recip = liftM (M.lookupDefault [] recip) getMemos+getUserMemos recip = fmap (M.lookupDefault [] recip) getMemos -insertMemo :: String -> Memo -> BotSession ()+insertMemo :: Nickname -> Memo -> BotSession () insertMemo recip memo = do     ms <- getMemos     let oldList = M.lookupDefault [] recip ms@@ -73,94 +78,117 @@  -- | Set (override) a user's memo list to the given list, discarding the memos -- previously stored there.-setUserMemos :: String -- ^ Recipient nickname-             -> [Memo] -- ^ New memo list to store-             -> BotSession ()+setUserMemos :: Nickname -> [Memo] -> BotSession () setUserMemos recip memos =     modifyMemos $ if null memos then M.delete recip else M.insert recip memos  -- | Delete all memos for a given recipient, if any exist.-deleteUserMemos :: String -- ^ Recipient nickname-                -> BotSession ()+deleteUserMemos :: Nickname -> BotSession () deleteUserMemos recip = modifyMemos $ M.delete recip  -- | Prepare an IRC message which displays a memo.-formatMemo :: Maybe String -- ^ Optional recipient nickname to mention-           -> Int          -- ^ Memo index to display-           -> Memo         -- ^ Memo to format-           -> String+formatMemo :: Maybe Nickname -- ^ Optional recipient nickname to mention+           -> Int               -- ^ Memo index to display+           -> Memo              -- ^ Memo to format+           -> MsgContent formatMemo (Just recip) _idx memo =-    printf "%v, %v said in %v UTC:\n\"%v\""-        recip-        (memoSender memo)+    MsgContent $ sformat+        ( stext+        % ", "+        % stext+        % " said in "+        % stext+        % " UTC:\n“"+        % stext+        % "”"+        )+        (unNickname recip)+        (unNickname $ memoSender memo)         (memoTime memo)-        (memoContent memo)+        (unMsgContent $ memoContent memo) formatMemo Nothing idx memo =-    let n = Maroon #> ("[" <> Pure (show idx) <> "]")-        time = Purple #> Pure (memoTime memo ++ " UTC")-        sender = Gray #> "<" <> Green #> Pure (memoSender memo) <> Gray #> ">"-        content = Pure $ memoContent memo-    in  encode $ n <> " " <> time <> " " <> sender <> " " <> content+    let n = Maroon #> plain (sformat ("[" % int % "]") idx)+        time = Purple #> plain (memoTime memo <> " UTC")+        sender = Gray #> "<" <> Green #> plain (unNickname $ memoSender memo) <> Gray #> ">"+        content = plain $ unMsgContent $ memoContent memo+    in  MsgContent $+        encode $ n <> " " <> time <> " " <> sender <> " " <> content  -- | Send a memo to its destination, nicely formatted.-sendMemo :: String -- ^ Recipient nickname-         -> Int    -- ^ Memo index number for display (i.e. 1-based)-         -> Memo   -- ^ Memo to display on IRC-         -> BotSession ()+sendMemo+    :: Nickname -- ^ Recipient nickname+    -> Int         -- ^ Memo index number for display (i.e. 1-based)+    -> Memo        -- ^ Memo to display on IRC+    -> BotSession () sendMemo recip idx memo =     case memoSendIn memo of         Just chan -> sendToChannel chan $ formatMemo (Just recip) idx memo         Nothing   -> sendToUser recip $ formatMemo Nothing idx memo  -- | Send a memo to its destination, nicely formatted.-sendMemoList :: String -- ^ Recipient nickname-             -> Int    -- ^ First memo's index number for display-             -> [Memo] -- ^ Memos to display on IRC-             -> BotSession ()+sendMemoList+    :: Nickname -- ^ Recipient nickname+    -> Int         -- ^ First memo's index number for display+    -> [Memo]      -- ^ Memos to display on IRC+    -> BotSession () sendMemoList recip idx ms =     let send (i, m) = sendMemo recip i m     in  mapM_ send $ zip [idx..] ms  -- | An instant memo response into the source channel or in PM.-sendInstant :: String       -- ^ Sender nickname-            -> Maybe String -- ^ Source channel-            -> String       -- ^ Recipient nickname-            -> String       -- ^ Message-            -> BotSession ()+sendInstant+    :: Nickname      -- ^ Sender nickname+    -> Maybe Channel -- ^ Source channel+    -> Nickname      -- ^ Recipient nickname+    -> MsgContent    -- ^ Message+    -> BotSession () sendInstant sender mchan recip content =     case mchan of         Just chan -> sendToChannel chan msg         Nothing   -> sendToUser recip msg     where-    msg = printf "%v, %v says: %v" recip sender content+    msg = MsgContent $+        unNickname recip  <>+        ", "              <>+        unNickname sender <>+        " says: "         <>+        unMsgContent content  -- | Report to sender than their memo has been saved.-confirm :: String       -- ^ Sender nickname-        -> Maybe String -- ^ Whether sent 'Just' in channel or in PM.-        -> String       -- ^ Recipient nickname-        -> BotSession ()+confirm+    :: Nickname       -- ^ Sender nickname+    -> Maybe Channel  -- ^ Whether sent 'Just' in channel or in PM.+    -> Nickname       -- ^ Recipient nickname+    -> BotSession () confirm sender (Just chan) recip = do-    sendToChannel chan $-        printf "%v, your memo for %v has been saved." sender recip+    sendToChannel chan $ MsgContent $ sformat+        ( stext+        % ", your memo for "+        % stext+        % " has been saved."+        )+        (unNickname sender)+        (unNickname recip)     t <- channelIsTracked chan-    unless t $ sendToChannel chan+    unless t $ sendToChannel chan $ MsgContent         "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+    sendToUser sender $ MsgContent $+        "Your memo for " <> unNickname recip <> " has been saved."  ------------------------------------------------------------------------------- -- Operations -------------------------------------------------------------------------------  -- | Record a new memo for a given user.-addMemo :: String       -- ^ Sender nickname-        -> Maybe String -- ^ Whether received in 'Just' a channel, or in PM-        -> Maybe String -- ^ Whether to send in 'Just' a channel, or in PM-        -> String       -- ^ Recipient nickname-        -> String       -- ^ Memo content-        -> BotSession ()+addMemo+    :: Nickname      -- ^ Sender nickname+    -> Maybe Channel -- ^ Whether received in 'Just' a channel, or in PM+    -> Maybe Channel -- ^ Whether to send in 'Just' a channel, or in PM+    -> Nickname      -- ^ Recipient nickname+    -> MsgContent    -- ^ Memo content+    -> BotSession () addMemo sender recv send recip content = do     time <- getTimeStr     let memo = Memo@@ -175,8 +203,8 @@ -- | Send a memo with the given index if exists. Return 'Nothing' on success, -- or 'Just' the number of saved memos for the nickname on failure (invalid -- index).-sendOneMemo :: String -- ^ Recipient nickname-            -> Int    -- ^ Memo number, 0-based+sendOneMemo :: Nickname -- ^ Recipient nickname+            -> Int         -- ^ Memo number, 0-based             -> BotSession (Maybe Int) sendOneMemo recip idx = do     ms <- getMemos@@ -189,9 +217,10 @@ -- | Delete a memo for a given recipient with the given index (position in the -- memo list). On success, return 'Nothing'. On error, return 'Just' the number -- of saved memos the receipient has.-deleteOneMemo :: String -- ^ Recipient nickname-              -> Int    -- ^ Memo index number, 0-based-              -> BotSession (Maybe Int)+deleteOneMemo+    :: Nickname -- ^ Recipient nickname+    -> Int         -- ^ Memo index number, 0-based+    -> BotSession (Maybe Int) deleteOneMemo recip idx = do     ms <- getMemos     case M.lookup recip ms of@@ -214,13 +243,19 @@ -- If user is online in same channel, send instantly to channel. -- If user is online in another channel, send in PM (and report to sender). -- If user not online, save memo and report to sender.-submitMemo :: String       -- ^ Sender nickname-           -> Maybe String -- ^ Whether sent in 'Just' a channel, or in PM-           -> String       -- ^ Recipient nickname-           -> Bool         -- ^ Whether to always send memo privately (True) or-                           --   the same as source (False)-           -> String       -- ^ Memo content-           -> BotSession ()+submitMemo+    :: Nickname+    -- ^ Sender nickname+    -> Maybe Channel+    -- ^ Whether sent in 'Just' a channel, or in PM+    -> Nickname+    -- ^ Recipient nickname+    -> Bool+    -- ^ Whether to always send memo privately (True) or the same as source+    -- (False)+    -> MsgContent+    -- ^ Memo content+    -> BotSession () submitMemo sender source recip private content = do     let send = if private then Nothing else source         instantToChan =@@ -250,9 +285,10 @@         unless succ2 keepForLater  -- Send user memos. For a specific joined channel, or for all channels.-reportMemos' :: String       -- ^ User nickname-             -> Maybe String -- ^ The channel the user joined-             -> BotSession ()+reportMemos'+    :: Nickname       -- ^ User nickname+    -> Maybe Channel -- ^ The channel the user joined+    -> BotSession () reportMemos' recip mchan = do     ms <- getUserMemos recip     let (msChan, msPriv) = partition (isJust . memoSendIn) ms@@ -268,7 +304,8 @@             return $ partition (isThese . memoSendIn) msChan     unless (null msPriv) $ do         let n = length msPriv-        sendToUser recip $ "Hello! You have " ++ show n ++ " private memos:"+        sendToUser recip $ MsgContent $+            sformat ("Hello! You have " % int % " private memos:") n         sendMemoList recip 1 msPriv     sendMemoList recip 1 msChanSend     unless (null msPriv && null msChanSend) $ do@@ -277,15 +314,15 @@  -- | When a user logs in, use this to send them a report of the memos saved for -- them, if any exist.-reportMemos :: String -- ^ User nickname-            -> String -- ^ The channel the user joined triggering the report-            -> BotSession ()+reportMemos+    :: Nickname -- ^ User nickname+    -> Channel -- ^ The channel the user joined triggering the report+    -> BotSession () reportMemos recip chan = reportMemos' recip (Just chan)  -- | Like 'reportMemos', but reports memos to all channels in which the user is -- present.-reportMemosAll :: String -- ^ User nickname-               -> BotSession ()+reportMemosAll :: Nickname -> BotSession () reportMemosAll recip = reportMemos' recip Nothing  -------------------------------------------------------------------------------@@ -296,24 +333,22 @@     parseJSON (Object o) =         Memo <$>         o .: "time" <*>-        o .: "sender" <*>+        (Nickname <$> o .: "sender") <*>         o .: "recv-in" <*>         o .: "send-in" <*>-        o .: "content" {-<*>-        o .: "read"-}-    parseJSON _          = mzero+        (MsgContent <$> o .: "content")+    parseJSON v          = typeMismatch "Memo" v  instance ToJSON Memo where-    toJSON (Memo time sender recvIn sendIn content {-rd-}) = object+    toJSON (Memo time sender recvIn sendIn content) = object         [ "time"    .= time-        , "sender"  .= sender+        , "sender"  .= unNickname sender         , "recv-in" .= recvIn         , "send-in" .= sendIn-        , "content" .= content-        --, "read"    .= rd+        , "content" .= unMsgContent content         ] -loadBotMemos :: IO (M.HashMap String [Memo])+loadBotMemos :: IO (M.HashMap Nickname [Memo]) loadBotMemos = do     r <- loadState $ stateFilePath memosFilename (cfgStateRepo configuration)     case r of@@ -321,7 +356,7 @@         Left (True, e)  -> error $ "Failed to parse memos file: " ++ e         Right s         -> return s -mkSaveBotMemos :: IO (M.HashMap String [Memo] -> IO ())+mkSaveBotMemos :: IO (M.HashMap Nickname [Memo] -> IO ()) mkSaveBotMemos =     mkSaveStateChoose         stateSaveInterval
+ src/FunBot/Puppet.hs view
@@ -0,0 +1,210 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Puppet+    ( puppetStart+    , puppetPrivateStart+    , puppetEnd+    , puppetPrivateEnd+    , puppetSay+    , puppetPrivateSay+    , puppetCheck+    , puppetCheckChannel+    )+where++import Control.Monad (when)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Foldable (traverse_)+import Formatting ((%))+import FunBot.Types+import Network.IRC.Fun.Bot.Chat+import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Color.Format (formatMsg)+import Network.IRC.Fun.Color.Format.Long+import Network.IRC.Fun.Types.Base++import qualified Data.HashMap.Lazy as M+import qualified Data.HashSet as S++-- | Start puppet mode in the given channel by the given nickname. Return+-- 'Nothing' on success. Otherwise 'False' means the channel is already in+-- puppet mode, and 'True' means it isn't but the user isn't a puppeteer for+-- that channel.+puppetStart :: Channel -> Nickname -> BotSession (Maybe Bool)+puppetStart chan nick = do+    puppet <- getStateS bsPuppet+    if isJust $ M.lookup chan puppet+        then return $ Just False+        else do+            gpts <- getStateS $ stPuppeteers . bsSettings+            mcs <- getStateS $ M.lookup chan . stChannels . bsSettings+            let lpts = fromMaybe S.empty $ fmap csPuppeteers mcs+            if nick `S.member` gpts || nick `S.member` lpts+                then do+                    let puppet' = M.insert chan nick puppet+                    modifyState $ \ s -> s { bsPuppet = puppet' }+                    return Nothing+                else return $ Just True++-- | Start private puppet mode by the given nickname. Return 'Nothing' on+-- success. Otherwise 'False' means private puppet mode is already on, and+-- 'True' means it isn't but the user isn't a global puppeteer.+puppetPrivateStart :: Nickname -> BotSession (Maybe Bool)+puppetPrivateStart nick = do+    mpteer <- getStateS bsPrivPuppet+    if isJust mpteer+        then return $ Just False+        else do+            gpts <- getStateS $ stPuppeteers . bsSettings+            if nick `S.member` gpts+                then do+                    modifyState $ \ s -> s { bsPrivPuppet = Just nick }+                    return Nothing+                else return $ Just True++-- | Stop puppet mode in a channel. Return 'Nothing' on success. Otherwise+-- 'False' means the channel isn't in puppet mode, and 'True' means it is, but+-- the user isn't a puppeteer there.+--+-- Note that any puppeteer can stop puppet mode, not necessarily the one who+-- started it. This can be useful in case the latter forgets to stop it or gets+-- disconnected from IRC, and then someone else can do it.+puppetEnd :: Channel -> Nickname -> BotSession (Maybe Bool)+puppetEnd chan nick = do+    puppet <- getStateS bsPuppet+    if isJust $ M.lookup chan puppet+        then do+            gpts <- getStateS $ stPuppeteers . bsSettings+            mcs <- getStateS $ M.lookup chan . stChannels . bsSettings+            let lpts = fromMaybe S.empty $ fmap csPuppeteers mcs+            if nick `S.member` gpts || nick `S.member` lpts+                then do+                    let puppet' = M.delete chan puppet+                    modifyState $ \ s -> s { bsPuppet = puppet' }+                    return Nothing+                else return $ Just True+        else return $ Just False++-- | Stop private puppet mode. Return 'Nothing' on success. Otherwise+-- 'False' means private puppet mode is off, and 'True' means it's on, but+-- the user isn't a global puppeteer.+--+-- Note that any global puppeteer can stop private puppet mode, not necessarily+-- the one who started it. This can be useful in case the latter forgets to+-- stop it or gets disconnected from IRC, and then someone else can do it.+puppetPrivateEnd :: Nickname -> BotSession (Maybe Bool)+puppetPrivateEnd nick = do+    mpteer <- getStateS bsPrivPuppet+    if isJust mpteer+        then do+            gpts <- getStateS $ stPuppeteers . bsSettings+            if nick `S.member` gpts+                then do+                    modifyState $ \ s -> s { bsPrivPuppet = Nothing }+                    return Nothing+                else return $ Just True+        else return $ Just False++-- | While in puppet mode, ask the bot to send a message into the channel.+-- Return 'Nothing' on success (i.e. the message is sent to the IRC server).+-- Otherwise, 'False' means the channel isn't in puppet mode, and 'True' means+-- it is, but the user isn't the one who started it.+puppetSay+    :: Channel+    -> Nickname+    -> MsgContent+    -> Bool -- ^ Whether to reveal the message comes from the puppeteer+    -> BotSession (Maybe Bool)+puppetSay chan nick msg reveal = do+    puppet <- getStateS bsPuppet+    case M.lookup chan puppet of+        Nothing    -> return $ Just False+        Just pteer ->+            if nick == pteer+                then do+                    let msg' =+                            if reveal+                                then formatMsg+                                        ("[" % nickname % "] " % message)+                                        nick msg+                                else msg+                    sendToChannel chan msg'+                    return Nothing+                else return $ Just True++-- | While in private puppet mode, ask the bot to send a message to a user.+-- Return 'Nothing' on success (i.e. the message is sent to the IRC server).+-- Otherwise, 'False' means private puppet mode is off, and 'True' means+-- it is, but the user isn't the one who started it.+puppetPrivateSay+    :: Nickname -- ^ Recipient+    -> Nickname -- ^ Puppeteer+    -> MsgContent+    -> Bool     -- ^ Whether to reveal the message comes from the puppeteer+    -> BotSession (Maybe Bool)+puppetPrivateSay recip nick msg reveal = do+    mpteer <- getStateS bsPrivPuppet+    case mpteer of+        Nothing    -> return $ Just False+        Just pteer ->+            if nick == pteer+                then do+                    let msg' =+                            if reveal+                                then formatMsg+                                        ("[" % nickname % "] " % message)+                                        nick msg'+                                else msg+                    sendToUser recip msg'+                    return Nothing+                else return $ Just True++-- | Finish puppet mode in all channels. This can be useful for emergency etc.+-- Return whether succeeded, i.e. whether user is a global puppeteer.+puppetReset+    :: Nickname -- ^ Must be a global puppeteer+    -> Bool     -- ^ Whether to announce end of puppet mode+    -> BotSession Bool+puppetReset nick ann = do+    gpteers <- getStateS $ stPuppeteers . bsSettings+    if nick `S.member` gpteers+        then do+            puppetChans <- getStateS $ M.keys . bsPuppet+            muser <- getStateS bsPrivPuppet+            modifyState $+                \ s -> s { bsPuppet = M.empty, bsPrivPuppet = Nothing }+            when ann $ do+                let msg =+                        MsgContent $ "Puppet mode reset by " <> unNickname nick+                traverse_ (flip sendToChannel msg) puppetChans+                traverse_ (flip sendToUser msg) muser+            return True+        else return False++-- | Check in which channels puppet mode is enabled, and whether private puppet+-- mode is enabled.+puppetCheck :: BotSession ([Channel], Bool)+puppetCheck = do+    chans <- getStateS $ M.keys . bsPuppet+    priv <- getStateS $ isJust . bsPrivPuppet+    return (chans, priv)++-- | Check whether puppet mode is enabled in a given channel.+puppetCheckChannel :: Channel -> BotSession Bool+puppetCheckChannel chan = getStateS $ (chan `M.member`) . bsPuppet
src/FunBot/Settings.hs view
@@ -1,1070 +1,160 @@ {- 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 the 'MonadSettings' instance-{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}---- For JSON field names and irc-fun-color StyledString-{-# LANGUAGE OverloadedStrings #-}--module FunBot.Settings-    ( respondGet'-    , respondSet'-    , respondReset'-    , respondSettingsHelp-    , initTree-    , addPushAnnSpec-    , deletePushAnnSpec-    , addRepo-    , deleteRepo-    , addChannel-    , addShortcut-    , deleteShortcut-    , addFeed-    , deleteFeed-    , loadBotSettings-    , mkSaveBotSettings-    )-where--import Control.Applicative-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 Data.Default.Class (def)-import Data.JsonState-import Data.List (intercalate, intersperse, isSuffixOf)-import Data.Maybe (catMaybes, fromMaybe)-import Data.Monoid-import Data.Settings.Interface-import Data.Settings.Option-import Data.Settings.Route-import Data.Settings.Section (deleteSub, insertSub, memberSub)-import Data.Settings.Types-import Data.Time.Units (Second)-import FunBot.Config (stateSaveInterval, configuration, settingsFilename)-import FunBot.Types-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 (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--    putSettings s    = modifyState $ \ st -> st { bsSettings = s }--    modifySettings f =-        modifyState $ \ st -> st { bsSettings = f $ bsSettings st }--    getSTree         = getStateS bsSTree--instance OptionValue Bool where-    readOption s-        | s' `elem` ["off", "false", "no",  "n", "0", "[_]"] = Just False-        | s' `elem` ["on",  "true",  "yes", "y", "1", "[x]"] = Just True-        | otherwise                                          = Nothing-        where-        s' = map toLower s-    showOption = show-    typeName = const "Boolean"--instance OptionValue String where-    readOption = Just-    showOption = id-    typeName = const "String"--parseList :: String -> Maybe [String]-parseList s  =-    case break (== ',') s of-        ("", _)     -> Nothing-        (p, "")     -> Just [p]-        (p, (c:cs)) ->-            case parseList cs of-                Nothing -> Nothing-                Just ps -> Just $ p : ps--instance OptionValue [String] where-    readOption s = parseList s >>= mapM readOption-    showOption   = intercalate "," . map showOption-    typeName     = const "List"--instance FromJSON a => FromJSON (Filter a) where-    parseJSON (Object o) =-        Accept <$> o .: "accept" <|>-        Reject <$> o .: "reject"-    parseJSON _          = mzero--instance ToJSON a => ToJSON (Filter a) where-    toJSON (Accept l) = object [ "accept" .= l ]-    toJSON (Reject l) = object [ "reject" .= l ]--instance FromJSON PushAnnSpec where-    parseJSON (Object o) =-        PushAnnSpec <$>-        o .: "channel" <*>-        o .: "branches" <*>-        o .: "all-commits"-    parseJSON _          = mzero--instance ToJSON PushAnnSpec where-    toJSON (PushAnnSpec chan branches allc) = object-        [ "channel"     .= chan-        , "branches"    .= branches-        , "all-commits" .= allc-        ]--instance FromJSON NewsItemFields where-    parseJSON (Object o) =-        NewsItemFields <$>-        o .: "show-feed-title" <*>-        o .: "show-author" <*>-        o .: "show-url"-    parseJSON _          = mzero--instance ToJSON NewsItemFields where-    toJSON (NewsItemFields ftitle author url) = object-        [ "show-feed-title" .= ftitle-        , "show-author"     .= author-        , "show-url"        .= url-        ]--instance FromJSON NewsAnnSpec where-    parseJSON (Object o) =-        NewsAnnSpec <$>-        o .: "channels" <*>-        o .: "fields"-    parseJSON _          = mzero--instance ToJSON NewsAnnSpec where-    toJSON (NewsAnnSpec channels fields) = object-        [ "channels" .= channels-        , "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) =-                case break (== '/') s of-                    (repo, _:owner) ->-                        if not (null repo || null owner) && '/' `notElem` owner-                            then Just ((repo, owner), l)-                            else Nothing-                    _               -> Nothing-        in  M.fromList . catMaybes . map mkpair . M.toList <$> parseJSON v--instance ToJSON (M.HashMap (String, String) [PushAnnSpec]) where-    toJSON m =-        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 .: "shortcuts" <*>-        o .: "channels"-    parseJSON _          = mzero--instance ToJSON Settings where-    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--- settings file-mkOptionF :: OptionValue v-          => (Settings -> v)             -- Get-          -> (v -> Settings -> Settings) -- Set which never fails-          -> v                           -- Default value for reset-          -> SettingsOption-mkOptionF get set defval = mkOptionS get set' reset cb-    where-    set' v s = Just $ set v s-    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-          => BotSession v         -- Get-          -> (v -> BotSession ()) -- Set which never fails-          -> v                    -- Default value for reset-          -> SettingsOption-mkOptionB get set defval = mkOptionV get set' reset-    where-    setTo val = set val >> cb val-    set' val = setTo val >> return True-    reset = setTo defval-    cb = const saveBotState---- Create a setting section for a spec, given its position in the spec list and--- repo/owner as matched by the web listener.-pushAnnSpecSec :: String -> String -> Int -> SettingsTree-pushAnnSpecSec repo owner pos = Section-    { secOpts = M.fromList-        [ ( "channel"-          , mkOptionF-                getChan-                (\ chan s ->-                    let chans = stGitAnnChans s-                        oldspecs = getSpecs s-                        oldspec = getSpec s-                        spec = oldspec { pAnnChannel = chan }-                        specs =-                            fromMaybe oldspecs $ replaceMaybe oldspecs pos spec-                    in  s   { stGitAnnChans =-                                M.insert (repo, owner) specs chans-                            }-                )-                defChan-          )-        , ( "branches"-          , mkOptionF-                getBranches-                (\ branches s ->-                    let chans = stGitAnnChans s-                        oldspecs = getSpecs s-                        oldspec = getSpec s-                        bs = case pAnnBranches oldspec of-                            Accept _ -> Accept branches-                            Reject _ -> Reject branches-                        spec = oldspec { pAnnBranches = bs }-                        specs =-                            fromMaybe oldspecs $ replaceMaybe oldspecs pos spec-                    in  s   { stGitAnnChans =-                                M.insert (repo, owner) specs chans-                            }-                )-                defBranches-          )-        , ( "accept"-          , mkOptionF-                getAccept-                (\ b s ->-                    let chans = stGitAnnChans s-                        oldspecs = getSpecs s-                        oldspec = getSpec s-                        ctor = filt b-                        bs = case pAnnBranches oldspec of-                            Accept l -> ctor l-                            Reject l -> ctor l-                        spec = oldspec { pAnnBranches = bs }-                        specs =-                            fromMaybe oldspecs $ replaceMaybe oldspecs pos spec-                    in  s   { stGitAnnChans =-                                M.insert (repo, owner) specs chans-                            }-                )-                defAccept-          )-        , ( "all-commits"-          , mkOptionF-                getAll-                (\ b s ->-                    let chans = stGitAnnChans s-                        oldspecs = getSpecs s-                        oldspec = getSpec s-                        spec = oldspec { pAnnAllCommits = b }-                        specs =-                            fromMaybe oldspecs $ replaceMaybe oldspecs pos spec-                    in  s   { stGitAnnChans =-                                M.insert (repo, owner) specs chans-                            }-                )-                defAll-          )-        ]-    , secSubs = M.empty-    }-    where-    defChan = "set-channel-here"-    defBranches = []-    defAccept = False-    filt b = if b then Accept else Reject-    defFilter = filt defAccept defBranches-    defAll = False-    defSpec = PushAnnSpec defChan defFilter defAll--    getSpecs = M.lookupDefault [] (repo, owner) . stGitAnnChans-    getSpec = fromMaybe defSpec . (!? pos) . getSpecs-    getChan = pAnnChannel . getSpec-    getFilter = pAnnBranches . getSpec-    getBranches = f . getFilter-        where-        f (Accept l) = l-        f (Reject l) = l-    getAccept = f . getFilter-        where-        f (Accept _) = True-        f (Reject _) = False-    getAll = pAnnAllCommits . getSpec---- 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 =-    ( repo ++ '/' : owner-    , Section-        { secOpts = M.empty-        , secSubs = M.fromList $ map mksub [1 .. length specs]-        }-    )-    where-    mksub i = (show i, pushAnnSpecSec repo owner (i - 1))---- Create a settings section for a news feed, given its label string-feedSec :: String -> SettingsTree-feedSec label = Section-    { secOpts = M.fromList-        [ ( "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 = stWatchedFeeds s-                        feed@NewsFeed { nfAnnSpec = spec } = getFeed s-                        feed' = feed-                            { nfAnnSpec = spec-                                { nAnnChannels = chans-                                }-                            }-                    in  s { stWatchedFeeds = M.insert label feed' feeds }-                )-                defChans-          )-        ]-    , secSubs = M.fromList-        [ ( "show"-          , Section-                { secOpts = M.fromList-                    [ ( "feed-title"-                      , mkOptionF-                            (dispFeedTitle . getFields)-                            (\ b s ->-                                let feed@NewsFeed { nfAnnSpec = spec } =-                                        getFeed s-                                    fieldsOld = nAnnFields spec-                                    fields = fieldsOld { dispFeedTitle = b }-                                    feed' = feed-                                        { nfAnnSpec = spec-                                            { nAnnFields = fields-                                            }-                                        }-                                in  s   { stWatchedFeeds =-                                            M.insert label feed' $-                                            stWatchedFeeds s-                                        }-                            )-                            (dispFeedTitle defFields)-                      )-                    , ( "author"-                      , mkOptionF-                            (dispAuthor . getFields)-                            (\ b s ->-                                let feed@NewsFeed { nfAnnSpec = spec } =-                                        getFeed s-                                    fieldsOld = nAnnFields spec-                                    fields = fieldsOld { dispAuthor = b }-                                    feed' = feed-                                        { nfAnnSpec = spec-                                            { nAnnFields = fields-                                            }-                                        }-                                in  s   { stWatchedFeeds =-                                            M.insert label feed' $-                                            stWatchedFeeds s-                                        }-                            )-                            (dispAuthor defFields)-                      )-                    , ( "url"-                      , mkOptionF-                            (dispUrl . getFields)-                            (\ b s ->-                                let feed@NewsFeed { nfAnnSpec = spec } =-                                        getFeed s-                                    fieldsOld = nAnnFields spec-                                    fields = fieldsOld { dispUrl = b }-                                    feed' = feed-                                        { nfAnnSpec = spec-                                            { nAnnFields = fields-                                            }-                                        }-                                in  s   { stWatchedFeeds =-                                            M.insert label feed' $-                                            stWatchedFeeds s-                                        }-                            )-                            (dispUrl defFields)-                      )-                    ]-                , secSubs = M.empty-                }-          )-        ]-    }-    where-    defChans = []-    defFields = NewsItemFields True True True-    defSpec = NewsAnnSpec defChans defFields-    defUrl = ""-    defActive = False-    defFeed = NewsFeed defUrl defActive defSpec--    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---- Create a section for a channel-chanSec :: String -> SettingsTree-chanSec chan = Section-    { secOpts = M.fromList-        [ ( "track"-          , mkOptionB-                (channelIsTracked chan)-                (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 <- getChanInfo-    sets <- getSettings-    let mapKey f = M.mapWithKey $ \ key _val -> f key-        tree = Section-            { secOpts = M.empty-            , secSubs = M.fromList-                [ ( "channels"-                  , Section-                        { secOpts = M.empty-                        , secSubs = mapKey chanSec cstates-                        }-                  )-                , ( "repos"-                  , Section-                        { secOpts = M.empty-                        , secSubs = M.fromList $ map (uncurry repoSec) $-                                    M.toList $ stGitAnnChans sets-                        }-                  )-                , ( "feeds"-                  , Section-                        { secOpts = M.empty-                        , secSubs = mapKey feedSec $ stWatchedFeeds sets-                        }-                  )-                , ( "shortcuts"-                  , Section-                        { secOpts = M.empty-                        , secSubs = mapKey shortcutSec $ stShortcuts sets-                        }-                  )-                ]-            }-    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 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 { stGitAnnChans = 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 stGitAnnChans 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 { stGitAnnChans = 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 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 { stGitAnnChans = 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 stGitAnnChans getSettings-    if M.member (repo, owner) repos-        then do-            let repos' = M.delete (repo, owner) repos-            modifySettings $ \ s -> s { stGitAnnChans = 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 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 ()-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 }---- | 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"-showError (NoSuchOption r)        = showRoute r ++ " : No such option"-showError (NoSuchSection r)       = showRoute r ++ " : No such section"-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 = showOptLine opt " = " val--showSec :: String -> [String] -> [String] -> String-showSec path subs opts =-    let showSub = Pure . ('‣' :)-        showOpt = Pure . ('•' :)-        showList = mconcat . intersperse " "-        pathF = Yellow #> Pure path-        subsF = Green #> (showList $ map showSub subs)-        optsF = Purple #> (showList $ map showOpt opts)-    in  encode $ case (null subs, null opts) of-            (False, False) -> pathF <> " : " <> subsF <> " | " <> optsF-            (False, True)  -> pathF <> " : " <> subsF-            (True, False)  -> pathF <> " : " <> optsF-            (True, True)   -> pathF <> " : Empty section"---- Remove user-friendliness parts and determine whether given string refers to--- a potential section (otherwise it could also be an potential option).-stripPath :: String -> (String, Bool)-stripPath opt-    | opt == "*"            = ("", True)-    | ".*" `isSuffixOf` opt = (take (length opt - 2) opt, True)-    | otherwise             = (opt, False)--respondGet' :: String -> (String -> BotSession ()) -> BotSession ()-respondGet' opt send = resp path-    where-    (path, sec) = stripPath opt-    resp = if sec then respSec else respAny-    respAny path = do-        result <- query path-        send $ case result of-            Left err                  -> showError err-            Right (Left (subs, opts)) -> showSec path subs opts-            Right (Right val)         -> showGet path val-    respSec path = do-        result <- querySection path-        send $ case result of-            Left err           -> showError err-            Right (subs, opts) -> showSec path subs opts--showSet :: String -> String -> String-showSet opt val = showOptLine opt " ← " val--respondSet' :: String -> String -> (String -> BotSession ()) -> BotSession ()-respondSet' opt val send = do-    merr <- updateOption opt val-    case merr of-        Just err -> send $ showError err-        Nothing  -> send $ showSet opt val--showReset :: String -> String -> String-showReset opt val = showOptLine opt " ↩ " val--showResetStrange :: String -> String-showResetStrange opt = opt ++ " : got reset, but I can't find it now"--respondReset' :: String -> (String -> BotSession ()) -> BotSession ()-respondReset' opt send = do-    merr <- resetOption opt-    case merr of-        Just err -> send $ showError err-        Nothing  -> do-            me <- queryOption opt-            send $ case me of-                Left _    -> showResetStrange opt-                Right val -> showReset opt val--help :: OptRoute -> String-help r = case r of-    [] -> "Top level of the settings tree."-    ["channels"] -> "Basic per-channel settings."-    ["channels", _] -> "Basic settings for the channel."-    ["channels", _, "log"] ->-        "Whether events in the channel are logged by the bot locally into a \-        \log file. Currently nothing is done with these logs. In the future \-        \they can be used to send people activity they missed (or selected \-        \parts of it), generate public logs as web pages and record meetings."-    ["channels", _, "track"] ->-        "Whether user joins and parts in the channel \-        \are tracked internally. This is useful for various other features, \-        \such as memos (see !tell) and listing these events in channel logs. \-        \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 \-        \its \"owner\", (a username or an organization name). The name and \-        \owner match the ones used by the dev platform which hosts the repo. \-        \Announcment details are given as a set of specifications, one for \-        \each IRC channel where you want the events to be announced."-    ["repos", _, _] ->-        "A Git repo event announcement specification for a specific channel. \-        \It specifies the channel and defines filters to determine which \-        \events should be announced."-    ["repos", _, _, "branches"] ->-        "A list of zero or more git branch names to filter by. If the \-        \\"accept\" option is True, this is whitelist of branches whose \-        \commits to announce (and the rest won't be announced). Otherwise, \-        \it's a blacklist of branches not to announce (and all the rest will \-        \be announced). By default the list is empty, and you can reset it to \-        \empty using !reset."-    ["repos", _, _, "channel"] ->-        "IRC channel into which to announce the repo events."-    ["repos", _, _, "all-commits"] ->-        "Whether to announce all commits into the channel, or shorten long \-        \pushes to avoid filling the channel with very long announcements. \-        \For example, if you push 20 commits at once, you may prefer to see \-        \just a summary or a partial report, and not have the channel filled \-        \with a very long sequence of messages. The default is False, i.e. do \-        \shorten long announcements."-    ["repos", _, _, "accept"] ->-        "Whether the branch list specified by the \"branches\" option is a \-        \whitelist of branches whose commits to announce (True), or a \-        \blacklist of branches not to announce (False). By default it's \-        \False, and the branch list is empty, which together mean \"reject no \-        \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"] ->-        "Determines which information about the new feed items should be \-        \specified in the announcements."-    ["feeds", _, "show", "author"] ->-        "Whether to specify the news item author when announcing the new item."-    ["feeds", _, "show", "feed-title"] ->-        "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-respondSettingsHelp path send =-    let p = fst $ stripPath path-    in  case parseRoute p of-            Just r -> do-                send $ p ++ " : " ++ help r-                return True-            Nothing -> return False--saveInterval = 3 :: Second--loadBotSettings :: IO Settings-loadBotSettings = do-    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-        Right s         -> return s--mkSaveBotSettings :: IO (Settings -> IO ())-mkSaveBotSettings =-    mkSaveStateChoose-        stateSaveInterval-        settingsFilename-        (cfgStateRepo configuration)-        "auto commit by funbot"--saveBotSettings :: BotSession ()-saveBotSettings = do-    sets <- getSettings-    save <- askEnvS saveSettings-    liftIO $ save sets+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- For irc-fun-color StyledString+{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings+    ( respondGet'+    , respondSet'+    , respondReset'+    , respondSettingsHelp+    )+where++import Control.Applicative+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 Data.Default.Class (def)+import Data.JsonState+import Data.List (intercalate, intersperse, isSuffixOf, sort)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid+import Data.Settings.Interface+import Data.Settings.Option+import Data.Settings.Route+import Data.Settings.Section (deleteSub, insertSub, memberSub)+import Data.Settings.Types+import Data.Text (Text)+import Data.Time.Units (Second)+import FunBot.Config (stateSaveInterval, configuration, settingsFilename)+import FunBot.Settings.Help+import FunBot.Settings.Instances ()+import FunBot.Types+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 (cfgStateRepo))+import Network.IRC.Fun.Color+import Network.IRC.Fun.Types.Base (MsgContent (..))+import Web.Feed.Collect hiding (addFeed)++import qualified Data.HashMap.Lazy as M+import qualified Data.Text as T+import qualified Web.Feed.Collect as F (addFeed)++showError :: SettingsError -> Text+showError (InvalidPath t)         = t <> " : Invalid path"+showError (NoSuchNode r)          = showRoute r <> " : No such option/section"+showError (NoSuchOption r)        = showRoute r <> " : No such option"+showError (NoSuchSection r)       = showRoute r <> " : No such section"+showError (InvalidValueForType t) = t <> " : Invalid value for option type"+showError (InvalidValue t)        = t <> " : Invalid value"++showOptLine :: Text -> Text -> Text -> Text+showOptLine opt op val =+    encode $ Yellow #> plain opt <> Teal #> plain op <> Maroon #> plain val++showGet :: Text -> Text -> Text+showGet opt val = showOptLine opt " = " val++showSec :: OptPath -> [Text] -> [Text] -> Text+showSec path subs opts =+    let showSub = ('‣' `T.cons`)+        showOpt = ('•' `T.cons`)+        showList = T.unwords . sort+        pathF = Yellow #> plain path+        subsF = Green #> plain (showList $ map showSub subs)+        optsF = Purple #> plain (showList $ map showOpt opts)+    in  encode $ case (null subs, null opts) of+            (False, False) -> pathF <> " : " <> subsF <> " | " <> optsF+            (False, True)  -> pathF <> " : " <> subsF+            (True, False)  -> pathF <> " : " <> optsF+            (True, True)   -> pathF <> " : Empty section"++-- Remove user-friendliness parts and determine whether given string refers to+-- a potential section (otherwise it could also be an potential option).+stripPath :: Text -> (Text, Bool)+stripPath opt+    | opt == "*"              = (T.empty, True)+    | ".*" `T.isSuffixOf` opt = (T.dropEnd 2 opt, True)+    | otherwise               = (opt, False)++respondGet' :: OptPath -> (MsgContent -> BotSession ()) -> BotSession ()+respondGet' opt send = resp path+    where+    (path, sec) = stripPath opt+    resp = if sec then respSec else respAny+    respAny path = do+        result <- query path+        send $ MsgContent $ case result of+            Left err                  -> showError err+            Right (Left (subs, opts)) -> showSec path subs opts+            Right (Right val)         -> showGet path val+    respSec path = do+        result <- querySection path+        send $ MsgContent $ case result of+            Left err           -> showError err+            Right (subs, opts) -> showSec path subs opts++showSet :: Text -> Text -> Text+showSet opt val = showOptLine opt " ← " val++respondSet'+    :: OptPath+    -> Text+    -> (MsgContent -> BotSession ())+    -> BotSession ()+respondSet' opt val send = do+    merr <- updateOption opt val+    case merr of+        Just err -> send $ MsgContent $ showError err+        Nothing  -> send $ MsgContent $ showSet opt val++showReset :: Text -> Text -> Text+showReset opt val = showOptLine opt " ↩ " val++showResetStrange :: Text -> Text+showResetStrange opt = opt <> " : got reset, but I can’t find it now"++respondReset' :: OptPath -> (MsgContent -> BotSession ()) -> BotSession ()+respondReset' opt send = do+    merr <- resetOption opt+    case merr of+        Just err -> send $ MsgContent $ showError err+        Nothing  -> do+            me <- queryOption opt+            send $ MsgContent $ case me of+                Left _    -> showResetStrange opt+                Right val -> showReset opt val++respondSettingsHelp+    :: OptPath+    -> (MsgContent -> BotSession ())+    -> BotSession Bool+respondSettingsHelp path send =+    let p = fst $ stripPath path+    in  case parseRoute p of+            Just r -> do+                send $ MsgContent $ p <> " : " <> help r+                return True+            Nothing -> return False+
+ src/FunBot/Settings/Help.hs view
@@ -0,0 +1,123 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Help+    ( help+    )+where++import Data.Settings.Types (OptRoute)+import Data.Text (Text)++help :: OptRoute -> Text+help r = case r of+    [] -> "Top level of the settings tree."+    ["channels"] -> "Basic per-channel settings."+    ["channels", _] -> "Basic settings for the channel."+    ["channels", _, "log"] ->+        "Whether events in the channel are logged by the bot locally into a \+        \log file. Currently nothing is done with these logs. In the future \+        \they can be used to send people activity they missed (or selected \+        \parts of it), generate public logs as web pages and record meetings."+    ["channels", _, "track"] ->+        "Whether user joins and parts in the channel \+        \are tracked internally. This is useful for various other features, \+        \such as memos (see !tell) and listing these events in channel logs. \+        \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 \+        \its \"owner\", (a username or an organization name). The name and \+        \owner match the ones used by the dev platform which hosts the repo. \+        \Announcment details are given as a set of specifications, one for \+        \each IRC channel where you want the events to be announced."+    ["repos", _, _] ->+        "A Git repo event announcement specification for a specific channel. \+        \It specifies the channel and defines filters to determine which \+        \events should be announced."+    ["repos", _, _, "branches"] ->+        "A list of zero or more git branch names to filter by. If the \+        \\"accept\" option is True, this is whitelist of branches whose \+        \commits to announce (and the rest won't be announced). Otherwise, \+        \it's a blacklist of branches not to announce (and all the rest will \+        \be announced). By default the list is empty, and you can reset it to \+        \empty using !reset."+    ["repos", _, _, "channel"] ->+        "IRC channel into which to announce the repo events."+    ["repos", _, _, "all-commits"] ->+        "Whether to announce all commits into the channel, or shorten long \+        \pushes to avoid filling the channel with very long announcements. \+        \For example, if you push 20 commits at once, you may prefer to see \+        \just a summary or a partial report, and not have the channel filled \+        \with a very long sequence of messages. The default is False, i.e. do \+        \shorten long announcements."+    ["repos", _, _, "accept"] ->+        "Whether the branch list specified by the \"branches\" option is a \+        \whitelist of branches whose commits to announce (True), or a \+        \blacklist of branches not to announce (False). By default it's \+        \False, and the branch list is empty, which together mean \"reject no \+        \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"] ->+        "Determines which information about the new feed items should be \+        \specified in the announcements."+    ["feeds", _, "show", "author"] ->+        "Whether to specify the news item author when announcing the new item."+    ["feeds", _, "show", "feed-title"] ->+        "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."
+ src/FunBot/Settings/Instances.hs view
@@ -0,0 +1,308 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++-- For the 'MonadSettings' instance+{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}++-- For JSON field names+{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Instances () where++import Control.Applicative+import Data.Aeson+import Data.Aeson.Types (typeMismatch)+import Data.Bool (bool)+import Data.CaseInsensitive (CI)+import Data.Hashable (Hashable)+import Data.Maybe (catMaybes)+import Data.Monoid ((<>))+import Data.Settings.Types+import FunBot.Types+import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Types.Base (Nickname (..))++import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Lazy as M+import qualified Data.HashSet as S+import qualified Data.Text as T++instance MonadSettings BotSession Settings where+    getSettings      = getStateS bsSettings++    putSettings s    = modifyState $ \ st -> st { bsSettings = s }++    modifySettings f =+        modifyState $ \ st -> st { bsSettings = f $ bsSettings st }++    getSTree         = getStateS bsSTree++instance OptionValue Bool where+    readOption s+        | s' `elem` ["off", "false", "no",  "n", "0", "[_]"] = Just False+        | s' `elem` ["on",  "true",  "yes", "y", "1", "[x]"] = Just True+        | otherwise                                          = Nothing+        where+        s' = T.toLower s+    showOption = bool "False" "True"+    typeName = const "Boolean"++instance OptionValue T.Text where+    readOption = Just+    showOption = id+    typeName = const "String"++instance OptionValue [T.Text] where+    readOption = mapM readOption . T.split (== ',')+    showOption = T.intercalate "," . map showOption+    typeName   = const "List"++instance FromJSON a => FromJSON (Filter a) where+    parseJSON (Object o) =+        Accept <$> o .: "accept" <|>+        Reject <$> o .: "reject"+    parseJSON v          = typeMismatch "Filter" v++instance ToJSON a => ToJSON (Filter a) where+    toJSON (Accept l) = object [ "accept" .= l ]+    toJSON (Reject l) = object [ "reject" .= l ]++instance FromJSON RepoAnnSpec where+    parseJSON (Object o) =+        RepoAnnSpec <$>+        o .: "channel" <*>+        o .: "branches" <*>+        o .: "all-commits" <*>+        o .: "commits" <*>+        o .: "issues" <*>+        o .: "merge-requests" <*>+        o .: "snippets" <*>+        o .: "notes" <*>+        o .: "new" <*>+        o .: "old" <*>+        o .: "untimed"+    parseJSON v          = typeMismatch "RepoAnnSpec" v++instance ToJSON RepoAnnSpec where+    toJSON ras = object+        [ "channel"        .= rasChannel ras+        , "branches"       .= rasBranches ras+        , "all-commits"    .= rasAllCommits ras+        , "commits"        .= rasCommits ras+        , "issues"         .= rasIssues ras+        , "merge-requests" .= rasMergeRequests ras+        , "snippets"       .= rasSnippets ras+        , "notes"          .= rasNotes ras+        , "new"            .= rasNew ras+        , "old"            .= rasOld ras+        , "untimed"        .= rasUntimed ras+        ]++instance FromJSON NewsItemFields where+    parseJSON (Object o) =+        NewsItemFields <$>+        o .: "show-feed-title" <*>+        o .: "show-author" <*>+        o .: "show-url"+    parseJSON v          = typeMismatch "NewsItemFields" v++instance ToJSON NewsItemFields where+    toJSON (NewsItemFields ftitle author url) = object+        [ "show-feed-title" .= ftitle+        , "show-author"     .= author+        , "show-url"        .= url+        ]++instance FromJSON NewsAnnSpec where+    parseJSON (Object o) =+        NewsAnnSpec <$>+        o .: "channels" <*>+        o .: "fields"+    parseJSON v          = typeMismatch "NewsAnnSpec" v++instance ToJSON NewsAnnSpec where+    toJSON (NewsAnnSpec channels fields) = object+        [ "channels" .= channels+        , "fields"   .= fields+        ]++instance FromJSON NewsFeed where+    parseJSON (Object o) =+        NewsFeed <$>+        o .: "url" <*>+        o .: "active" <*>+        o .: "ann-spec"+    parseJSON v          = typeMismatch "NewsFeed" v++instance ToJSON NewsFeed where+    toJSON (NewsFeed url active spec) = object+        [ "url"      .= url+        , "active"   .= active+        , "ann-spec" .= spec+        ]++instance FromJSON a => FromJSON (M.HashMap (CI T.Text) a) where+    parseJSON v =+        let f (t, x) = (CI.mk t, x)+        in  M.fromList . map f . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap (CI T.Text) a) where+    toJSON m =+        let f (t, x) = (CI.original t, x)+        in  toJSON $ M.fromList $ map f $ M.toList m++instance FromJSON a => FromJSON (M.HashMap (RepoSpace, RepoName) a) where+    parseJSON v =+        let mkpair (t, x) =+                case T.split (== '/') t of+                    [space, repo] ->+                        if T.null space || T.null repo+                            then Nothing+                            else Just+                                    ( ( RepoSpace $ CI.mk space+                                      , RepoName $ CI.mk repo+                                      )+                                    , x+                                    )+                    _ -> Nothing+        in  M.fromList . catMaybes . map mkpair . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap (RepoSpace, RepoName) a) where+    toJSON m =+        let unpair ((RepoSpace s, RepoName r), x) = (s <> "/" <> r, x)+        in  toJSON $ M.fromList $ map unpair $ M.toList m++instance FromJSON a => FromJSON (M.HashMap DevHostLabel a) where+    parseJSON v =+        let f (h, x) = (DevHostLabel h, x)+        in  M.fromList . map f . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap DevHostLabel a) where+    toJSON m =+        let f (DevHostLabel h, x) = (h, x)+        in  toJSON $ M.fromList $ map f $ M.toList m++instance FromJSON a => FromJSON (M.HashMap DevHost a) where+    parseJSON v =+        let f (h, x) = (DevHost h, x)+        in  M.fromList . map f . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap DevHost a) where+    toJSON m =+        let f (DevHost h, x) = (h, x)+        in  toJSON $ M.fromList $ map f $ M.toList m++instance FromJSON a => FromJSON (M.HashMap Nickname a) where+    parseJSON v =+        let f (n, x) = (Nickname n, x)+        in  M.fromList . map f . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap Nickname a) where+    toJSON m =+        let f (Nickname n, x) = (n, x)+        in  toJSON $ M.fromList $ map f $ M.toList m++instance FromJSON a => FromJSON (M.HashMap FeedLabel a) where+    parseJSON v =+        let f (l, x) = (FeedLabel l, x)+        in  M.fromList . map f . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap FeedLabel a) where+    toJSON m =+        let f (FeedLabel l, x) = (l, x)+        in  toJSON $ M.fromList $ map f $ M.toList m++instance FromJSON a => FromJSON (M.HashMap ShortcutLabel a) where+    parseJSON v =+        let f (l, x) = (ShortcutLabel l, x)+        in  M.fromList . map f . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap ShortcutLabel a) where+    toJSON m =+        let f (ShortcutLabel l, x) = (l, x)+        in  toJSON $ M.fromList $ map f $ M.toList m++instance FromJSON a => FromJSON (M.HashMap LocationLabel a) where+    parseJSON v =+        let f (l, x) = (LocationLabel l, x)+        in  M.fromList . map f . M.toList <$> parseJSON v++instance ToJSON a => ToJSON (M.HashMap LocationLabel a) where+    toJSON m =+        let f (LocationLabel l, x) = (l, x)+        in  toJSON $ M.fromList $ map f $ M.toList m++instance FromJSON Shortcut where+    parseJSON (Object o) =+        Shortcut <$>+        o .: "prefix" <*>+        o .: "before" <*>+        o .: "after" <*>+        o .: "channels"+    parseJSON v          = typeMismatch "Shortcut" v++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"                         <*>+        (map Nickname <$> o .: "folks")        <*>+        o .: "email"                           <*>+        (M.map Location <$> o .: "locations")  <*>+        (S.map Nickname <$> o .: "puppeteers") <*>+        o .: "browse"+    parseJSON v          = typeMismatch "ChanSettings" v++instance ToJSON ChanSettings where+    toJSON (ChanSettings sayTitles welcome folks email locs pts url) = object+        [ "say-titles" .= sayTitles+        , "welcome"    .= welcome+        , "folks"      .= map unNickname folks+        , "email"      .= email+        , "locations"  .= M.map unLocation locs+        , "puppeteers" .= S.map unNickname pts+        , "browse"     .= url+        ]++instance FromJSON Settings where+    parseJSON (Object o) =+        Settings <$>+        o .: "repos"                              <*>+        o .: "feeds"                              <*>+        o .: "shortcuts"                          <*>+        o .: "channels"                           <*>+        (M.map DevHostLabel <$> o .: "dev-hosts") <*>+        (M.map Location <$> o .: "locations")     <*>+        (S.map Nickname <$> o .: "puppeteers")+    parseJSON v          = typeMismatch "Settings" v++instance ToJSON Settings where+    toJSON (Settings repos feeds shortcuts channels hosts locs pts) = object+        [ "repos"      .= repos+        , "feeds"      .= feeds+        , "shortcuts"  .= shortcuts+        , "channels"   .= channels+        , "dev-hosts"  .= M.map unDevHostLabel hosts+        , "locations"  .= M.map unLocation locs+        , "puppeteers" .= S.map unNickname pts+        ]
+ src/FunBot/Settings/MkOption.hs view
@@ -0,0 +1,68 @@+{- This file is part of funbot.+ -+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module FunBot.Settings.MkOption+    ( mkOptionF+    , mkOptionF'+    , mkOptionB+    )+where++import Data.Settings.Option+import Data.Settings.Types+import FunBot.Settings.Persist+import FunBot.Types+import Network.IRC.Fun.Bot.State (saveBotState)++-- | An option whose value is held by funbot's 'Settings' and saved into its+-- settings file.+mkOptionF :: OptionValue v+          => (Settings -> v)             -- ^ Get+          -> (v -> Settings -> Settings) -- ^ Set which never fails+          -> v                           -- ^ Default value for reset+          -> SettingsOption+mkOptionF get set defval = mkOptionS get set' reset cb+    where+    set' v s = Just $ set v s+    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+          => BotSession v         -- ^ Get+          -> (v -> BotSession ()) -- ^ Set which never fails+          -> v                    -- ^ Default value for reset+          -> SettingsOption+mkOptionB get set defval = mkOptionV get set' reset+    where+    setTo val = set val >> cb val+    set' val = setTo val >> return True+    reset = setTo defval+    cb = const saveBotState
+ src/FunBot/Settings/Persist.hs view
@@ -0,0 +1,56 @@+{- This file is part of funbot.+ -+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++module FunBot.Settings.Persist+    ( loadBotSettings+    , mkSaveBotSettings+    , saveBotSettings+    )+where++import Control.Monad.IO.Class (liftIO)+import Data.JsonState+import Data.Settings.Types (getSettings)+import Data.Time.Units+import FunBot.Config (configuration, settingsFilename, stateSaveInterval)+import FunBot.Settings.Instances+import FunBot.Types+import Network.IRC.Fun.Bot.State (askEnvS)+import Network.IRC.Fun.Bot.Types++saveInterval = 3 :: Second++loadBotSettings :: IO Settings+loadBotSettings = do+    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+        Right s         -> return s++mkSaveBotSettings :: IO (Settings -> IO ())+mkSaveBotSettings =+    mkSaveStateChoose+        stateSaveInterval+        settingsFilename+        (cfgStateRepo configuration)+        "auto commit by funbot"++saveBotSettings :: BotSession ()+saveBotSettings = do+    sets <- getSettings+    save <- askEnvS saveSettings+    liftIO $ save sets
+ src/FunBot/Settings/Sections.hs view
@@ -0,0 +1,104 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Sections+    ( initTree+    )+where++import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Sequence (Seq, (|>), (><), ViewL (..))+import Data.Settings.Section+import Data.Settings.Types+import FunBot.Settings.MkOption+import FunBot.Settings.Persist+import FunBot.Settings.Sections.Channels+import FunBot.Settings.Sections.DevHosts+import FunBot.Settings.Sections.Feeds+import FunBot.Settings.Sections.Locations+import FunBot.Settings.Sections.Repos+import FunBot.Settings.Sections.Shortcuts+import FunBot.Types+import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Types.Base (Channel (..))++import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Lazy as M+import qualified Data.Sequence as Q+import qualified Data.Text as T++-- | Build initial settings tree, already inside the session+initTree :: BotSession ()+initTree = do+    cinfo <- getChanInfo+    sets <- getSettings+    let chans = stChannels sets+        locs = M.map (M.keys . csLocations) chans+        defs = M.map (const []) cinfo+        locs' = (locs `M.intersection` defs) `M.union` defs+        mapKey f g = M.fromList . map (\ k -> (f k, g k)) . M.keys+        mapBoth f g = M.fromList . map (\ (k, v) -> (f k, g k v)) . M.toList+        map' f = M.fromList . map f . M.keys+        tree = Section+            { secOpts = M.empty+            , secSubs = M.fromList+                [ ( "channels"+                  , Section+                        { secOpts = M.empty+                        , secSubs = mapBoth unChannel chanSec locs'+                        }+                  )+                , ( "repos"+                  , Section+                        { secOpts = M.empty+                        , secSubs =+                            mapBoth unDevHostLabel hostSection $+                            stGitAnnChans sets+                        }+                  )+                , ( "feeds"+                  , Section+                        { secOpts = M.empty+                        , secSubs =+                            mapKey (CI.original . unFeedLabel) feedSec $+                            stWatchedFeeds sets+                        }+                  )+                , ( "shortcuts"+                  , Section+                        { secOpts = M.empty+                        , secSubs =+                            mapKey (CI.original . unShortcutLabel) shortcutSec+                            $ stShortcuts sets+                        }+                  )+                , ( "dev-hosts"+                  , Section+                        { secOpts = map' devHostOption $ stDevHosts sets+                        , secSubs = M.empty+                        }+                  )+                , ( "locations"+                  , Section+                        { secOpts = map' locationOption $ stLocations sets+                        , secSubs = M.empty+                        }+                  )+                ]+            }+    modifyState $ \ s -> s { bsSTree = tree }
+ src/FunBot/Settings/Sections/Channels.hs view
@@ -0,0 +1,212 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Sections.Channels+    ( chanSec+    , addChannel+    , addLocalLocation+    , removeLocalLocation+    )+where++import Control.Monad (unless, void)+import Data.Bool (bool)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Sequence (Seq, (|>), (><), ViewL (..))+import Data.Settings.Section+import Data.Settings.Types+import FunBot.Settings.MkOption+import FunBot.Settings.Persist+import FunBot.Types+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.Types.Base (Channel (..), Nickname (..))++import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Lazy as M+import qualified Data.HashSet as S+import qualified Data.Sequence as Q+import qualified Data.Text as T++defChan = ChanSettings True False [] "(?)" M.empty S.empty Nothing++locationOption chan l@(LocationLabel t) =+                    let defl = "(?)"+                        getl l sets = fromMaybe defl $ do+                            cs <- M.lookup chan $ stChannels sets+                            loc <- M.lookup l $ csLocations cs+                            return $ unLocation loc+                        setl l v sets =+                            let chans = stChannels sets+                                cs = M.lookupDefault defChan chan chans+                                locs = csLocations cs+                                locs' = M.insert l (Location v) locs+                                cs' = cs { csLocations = locs' }+                                chans' = M.insert chan cs' chans+                            in  sets { stChannels = chans' }+                        f l = mkOptionF (getl l) (setl l) defl+                    in  (CI.original t, f l)++-- | Create a section for a channel.+chanSec :: Channel -> [LocationLabel] -> SettingsTree+chanSec chan lls = Section+    { secOpts = M.fromList+        [ ( "track"+          , mkOptionB+                (channelIsTracked chan)+                (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+          )+        , ( "def-response"+          , mkOptionB+                (defRespEnabled chan)+                (void . setDefResp chan)+                True+          )+        , ( "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 [] $ map unNickname . csFolks)+                (setf $ \ cs fs -> cs { csFolks = map Nickname fs })+                []+          )+        , ( "email"+          , mkOptionF+                (getf "(?)" csEmail)+                (setf $ \ cs s -> cs { csEmail = s })+                "(?)"+          )+        , ( "browse"+          , mkOptionF+                (getf "" $ fromMaybe "" . csBrowse)+                (setf $ \ cs url ->+                    if T.null url+                        then cs { csBrowse = Nothing }+                        else cs { csBrowse = Just url }+                )+                ""+          )+        ]+    , secSubs = M.fromList+        [ ( "locations"+          , Section+                { secOpts = M.fromList $ map (locationOption chan) lls+                , secSubs = M.empty+                }+          )+        ]+    }+    where+    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' }++-- | Add a new channel to state and tree and to be joined from now on. If+-- already exists, nothing happens.+addChannel :: Channel -> BotSession ()+addChannel chan = do+    selectChannel chan+    addChannelState chan+    sets <- getSTree+    let route = ["channels", unChannel chan]+    unless (route `memberSub` sets) $ do+        let sec = chanSec chan []+            ins = insertSub route sec+        modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }++-- | Add a new location item to a channel's settings and tree. Return 'Nothing'+-- on success. Otherwise return whether the channel isn't selected ('False') or+-- the location label already exists ('True').+addLocalLocation+    :: Channel+    -> LocationLabel+    -> Location+    -> BotSession (Maybe Bool)+addLocalLocation chan label location = do+    sel <- channelSelected chan+    if sel+        then do+            chans <- fmap stChannels getSettings+            let cs = M.lookupDefault defChan chan chans+                locs = csLocations cs+            case M.lookup label locs of+                Just _  -> return $ Just True+                Nothing -> do+                    let locs' = M.insert label location locs+                        cs' = cs { csLocations = locs' }+                        chans' = M.insert chan cs' chans+                    modifySettings $ \ s -> s { stChannels = chans' }+                    saveBotSettings+                    let (t, opt) = locationOption chan label+                        path = ["channels", unChannel chan, "locations", t]+                        ins = insertOpt path opt+                    modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+                    return Nothing+        else return $ Just False++-- | Remove a channel-specific location from settings and tree. Return whether+-- success, i.e. whether the location did exist and indeed has been deleted.+removeLocalLocation :: Channel -> LocationLabel -> BotSession Bool+removeLocalLocation chan label = do+    chans <- fmap stChannels getSettings+    case M.lookup chan chans of+        Nothing -> return False+        Just cs ->+            let locs = csLocations cs+            in  if M.member label locs+                    then do+                        let locs' = M.delete label locs+                            cs' = cs { csLocations = locs' }+                            chans' = M.insert chan cs' chans+                        modifySettings $ \ s -> s { stChannels = chans' }+                        saveBotSettings+                        let t = CI.original $ unLocationLabel label+                            path = ["channels", unChannel chan, "locations", t]+                            del = deleteOpt path+                        modifyState $ \ s -> s { bsSTree = del $ bsSTree s }+                        return True+                    else return False
+ src/FunBot/Settings/Sections/DevHosts.hs view
@@ -0,0 +1,85 @@+{- This file is part of funbot.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Sections.DevHosts+    ( devHostOption+    , addDevHost+    , removeDevHost+    )+where++import Control.Monad (unless, void)+import Data.Bool (bool)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Sequence (Seq, (|>), (><), ViewL (..))+import Data.Settings.Section+import Data.Settings.Types+import FunBot.Settings.MkOption+import FunBot.Settings.Persist+import FunBot.Types+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.Types.Base (Channel (..), Nickname (..))++import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Lazy as M+import qualified Data.Sequence as Q+import qualified Data.Text as T++devHostOption h@(DevHost t) =+                    let defl = "(?)"+                        getl = maybe defl unDevHostLabel . M.lookup h . stDevHosts+                        setl v sets =+                            let hosts = stDevHosts sets+                                hosts' = M.insert h (DevHostLabel v) hosts+                            in  sets { stDevHosts = hosts' }+                    in  (CI.original t, mkOptionF getl setl defl)++-- | Add a new dev host to settings and tree. Return whether success, i.e.+-- whether the dev host didn't exist and indeed a new one has been created.+addDevHost :: DevHost -> DevHostLabel -> BotSession Bool+addDevHost host label = do+    hosts <- fmap stDevHosts getSettings+    case M.lookup host hosts of+        Just _  -> return False+        Nothing -> do+            let hosts' = M.insert host label hosts+            modifySettings $ \ s -> s { stDevHosts = hosts' }+            saveBotSettings+            let (t, opt) = devHostOption host+                ins = insertOpt ["dev-hosts", t] opt+            modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+            return True++-- | Remove a dev host from settings and tree. Return whether success, i.e.+-- whether the dev host did exist and indeed has been deleted.+removeDevHost :: DevHost -> BotSession Bool+removeDevHost host = do+    hosts <- fmap stDevHosts getSettings+    if M.member host hosts+        then do+            let hosts' = M.delete host hosts+            modifySettings $ \ s -> s { stDevHosts = hosts' }+            saveBotSettings+            let path = ["dev-hosts", CI.original $ unDevHost host]+                del = deleteOpt path+            modifyState $ \ s -> s { bsSTree = del $ bsSTree s }+            return True+        else return False
+ src/FunBot/Settings/Sections/Feeds.hs view
@@ -0,0 +1,241 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Sections.Feeds+    ( feedSec+    , addFeed+    , deleteFeed+    )+where++import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Data.Bool (bool)+import Data.Default.Class (def)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Sequence (Seq, (|>), (><), ViewL (..))+import Data.Settings.Section+import Data.Settings.Types+import FunBot.Settings.MkOption+import FunBot.Settings.Persist+import FunBot.Types+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.Types.Base (Channel (..), Nickname (..))+import Web.Feed.Collect hiding (addFeed)++import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Lazy as M+import qualified Data.Sequence as Q+import qualified Data.Text as T+import qualified Web.Feed.Collect as F (addFeed)++-- | Create a settings section for a news feed, given its label string+feedSec :: FeedLabel -> SettingsTree+feedSec label = Section+    { secOpts = M.fromList+        [ ( "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 <- fmap getActive getSettings+                    liftIO $ do+                        sendCommand cq $ removeFeed labelt+                        sendCommand cq $ F.addFeed def+                            { fcLabel  = labelt+                            , fcUrl    = T.unpack 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 labelt b+                )+          )+        , ( "channels"+          , mkOptionF+                (map unChannel . getChans)+                (\ chans s ->+                    let feeds = stWatchedFeeds s+                        feed@NewsFeed { nfAnnSpec = spec } = getFeed s+                        feed' = feed+                            { nfAnnSpec = spec+                                { nAnnChannels = map Channel chans+                                }+                            }+                    in  s { stWatchedFeeds = M.insert label feed' feeds }+                )+                defChans+          )+        ]+    , secSubs = M.fromList+        [ ( "show"+          , Section+                { secOpts = M.fromList+                    [ ( "feed-title"+                      , mkOptionF+                            (dispFeedTitle . getFields)+                            (\ b s ->+                                let feed@NewsFeed { nfAnnSpec = spec } =+                                        getFeed s+                                    fieldsOld = nAnnFields spec+                                    fields = fieldsOld { dispFeedTitle = b }+                                    feed' = feed+                                        { nfAnnSpec = spec+                                            { nAnnFields = fields+                                            }+                                        }+                                in  s   { stWatchedFeeds =+                                            M.insert label feed' $+                                            stWatchedFeeds s+                                        }+                            )+                            (dispFeedTitle defFields)+                      )+                    , ( "author"+                      , mkOptionF+                            (dispAuthor . getFields)+                            (\ b s ->+                                let feed@NewsFeed { nfAnnSpec = spec } =+                                        getFeed s+                                    fieldsOld = nAnnFields spec+                                    fields = fieldsOld { dispAuthor = b }+                                    feed' = feed+                                        { nfAnnSpec = spec+                                            { nAnnFields = fields+                                            }+                                        }+                                in  s   { stWatchedFeeds =+                                            M.insert label feed' $+                                            stWatchedFeeds s+                                        }+                            )+                            (dispAuthor defFields)+                      )+                    , ( "url"+                      , mkOptionF+                            (dispUrl . getFields)+                            (\ b s ->+                                let feed@NewsFeed { nfAnnSpec = spec } =+                                        getFeed s+                                    fieldsOld = nAnnFields spec+                                    fields = fieldsOld { dispUrl = b }+                                    feed' = feed+                                        { nfAnnSpec = spec+                                            { nAnnFields = fields+                                            }+                                        }+                                in  s   { stWatchedFeeds =+                                            M.insert label feed' $+                                            stWatchedFeeds s+                                        }+                            )+                            (dispUrl defFields)+                      )+                    ]+                , secSubs = M.empty+                }+          )+        ]+    }+    where+    labelt = T.unpack $ CI.original $ unFeedLabel label+    defChans = []+    defFields = NewsItemFields True True True+    defSpec = NewsAnnSpec defChans defFields+    defUrl = ""+    defActive = False+    defFeed = NewsFeed defUrl defActive defSpec++    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++-- | 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 :: FeedLabel -> T.Text -> BotSession Bool+addFeed label url = do+    feeds <- fmap 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", CI.original $ unFeedLabel 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 (T.unpack $ CI.original $ unFeedLabel label) (T.unpack 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 :: FeedLabel -> BotSession Bool+deleteFeed label = do+    feeds <- fmap 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", CI.original $ unFeedLabel label]+            modifyState $ \ s -> s { bsSTree = del $ bsSTree s }+            -- Send command to update the feed watcher+            cq <- askEnvS feedCmdQueue+            liftIO $ sendCommand cq $ removeFeed $ T.unpack $ CI.original $ unFeedLabel label+            return True+        else return False
+ src/FunBot/Settings/Sections/Locations.hs view
@@ -0,0 +1,85 @@+{- This file is part of funbot.+ -+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Sections.Locations+    ( locationOption+    , addLocation+    , removeLocation+    )+where++import Control.Monad (unless, void)+import Data.Bool (bool)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Sequence (Seq, (|>), (><), ViewL (..))+import Data.Settings.Section+import Data.Settings.Types+import FunBot.Settings.MkOption+import FunBot.Settings.Persist+import FunBot.Types+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.Types.Base (Channel (..), Nickname (..))++import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Lazy as M+import qualified Data.Sequence as Q+import qualified Data.Text as T++locationOption l@(LocationLabel t) =+                    let defl = "(?)"+                        getl = maybe defl unLocation . M.lookup l . stLocations+                        setl v sets =+                            let locs = stLocations sets+                                locs' = M.insert l (Location v) locs+                            in  sets { stLocations = locs' }+                    in  (CI.original t, mkOptionF getl setl defl)++-- | Add a new location to settings and tree. Return whether success, i.e.+-- whether the location didn't exist and indeed a new one has been created.+addLocation :: LocationLabel -> Location -> BotSession Bool+addLocation label location = do+    locs <- fmap stLocations getSettings+    case M.lookup label locs of+        Just _  -> return False+        Nothing -> do+            let locs' = M.insert label location locs+            modifySettings $ \ s -> s { stLocations = locs' }+            saveBotSettings+            let (t, opt) = locationOption label+                ins = insertOpt ["locations", t] opt+            modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+            return True++-- | Remove a location from settings and tree. Return whether success, i.e.+-- whether the location did exist and indeed has been deleted.+removeLocation :: LocationLabel -> BotSession Bool+removeLocation label = do+    locs <- fmap stLocations getSettings+    if M.member label locs+        then do+            let locs' = M.delete label locs+            modifySettings $ \ s -> s { stLocations = locs' }+            saveBotSettings+            let path = ["locations", CI.original $ unLocationLabel label]+                del = deleteOpt path+            modifyState $ \ s -> s { bsSTree = del $ bsSTree s }+            return True+        else return False
+ src/FunBot/Settings/Sections/Repos.hs view
@@ -0,0 +1,319 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Sections.Repos+    ( hostSection+    , addRepoAnnSpec+    , deleteRepoAnnSpec+    , addRepo+    , deleteRepo+    )+where++import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Sequence (Seq, (|>), (><), ViewL (..))+import Data.Settings.Section+import Data.Settings.Types+import FunBot.Settings.MkOption+import FunBot.Settings.Persist+import FunBot.Types+import Network.IRC.Fun.Bot.State (modifyState)+import Network.IRC.Fun.Types.Base (Channel (..))++import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Lazy as M+import qualified Data.Sequence as Q+import qualified Data.Text as T++specSection :: DevHostLabel -> RepoSpace -> RepoName -> Int -> SettingsTree+specSection host space repo pos = Section+    { secOpts = M.fromList+        [ ( "channel"+          , mkopt+                "set-channel-here"+                (unChannel . rasChannel)+                (\ chan spec -> spec { rasChannel = Channel chan })+          )+        , ( "branches"+          , mkopt+                []+                (\ spec ->+                    case rasBranches spec of+                        Accept l -> map unBranchName l+                        Reject l -> map unBranchName l+                )+                (\ branches spec ->+                    let bs = case rasBranches spec of+                                Accept _ -> Accept $ map BranchName branches+                                Reject _ -> Reject $ map BranchName branches+                    in  spec { rasBranches = bs }+                )+          )+        , ( "accept"+          , mkopt+                False+                (\ spec ->+                    case rasBranches spec of+                        Accept _ -> True+                        Reject _ -> False+                )+                (\ b spec ->+                    let ctor = if b then Accept else Reject+                        bs = case rasBranches spec of+                                Accept l -> ctor l+                                Reject l -> ctor l+                    in  spec { rasBranches = bs }+                )+          )+        , ( "all-commits"+          , mkopt+                False+                rasAllCommits+                (\ b spec -> spec { rasAllCommits = b })+          )+        , ( "commits"+          , mkopt+                True+                rasCommits+                (\ b spec -> spec { rasCommits = b })+          )+        , ( "issues"+          , mkopt+                True+                rasIssues+                (\ b spec -> spec { rasIssues = b })+          )+        , ( "merge-requests"+          , mkopt+                True+                rasMergeRequests+                (\ b spec -> spec { rasMergeRequests = b })+          )+        , ( "snippets"+          , mkopt+                True+                rasSnippets+                (\ b spec -> spec { rasSnippets = b })+          )+        , ( "notes"+          , mkopt+                True+                rasNotes+                (\ b spec -> spec { rasNotes = b })+          )+        , ( "new"+          , mkopt+                True+                rasNew+                (\ b spec -> spec { rasNew = b })+          )+        , ( "old"+          , mkopt+                True+                rasOld+                (\ b spec -> spec { rasOld = b })+          )+        , ( "untimed"+          , mkopt+                True+                rasUntimed+                (\ b spec -> spec { rasUntimed = b })+          )+        ]+    , secSubs = M.empty+    }+    where+    setSpecField f val sets = fromMaybe sets $ do+        let hosts = stGitAnnChans sets+        repos <- M.lookup host hosts+        specs <- M.lookup (space, repo) repos+        let specs' = Q.adjust (f val) pos specs+            repos' = M.insert (space, repo) specs' repos+            hosts' = M.insert host repos' hosts+        return sets { stGitAnnChans = hosts' }+    getSpecField defval f sets = fromMaybe defval $ do+        let hosts = stGitAnnChans sets+        repos <- M.lookup host hosts+        specs <- M.lookup (space, repo) repos+        spec <- if 0 <= pos && pos < Q.length specs+                    then Just $ Q.index specs pos+                    else Nothing+        return $ f spec+    mkopt defval get set =+        mkOptionF (getSpecField defval get) (setSpecField set) defval++repoSection+    :: DevHostLabel+    -> RepoSpace+    -> RepoName+    -> Seq RepoAnnSpec+    -> (T.Text, SettingsTree)+repoSection h s r specs =+    ( CI.original (unRepoSpace s) <> "/" <> CI.original (unRepoName r)+    , Section+        { secOpts = M.empty+        , secSubs = M.fromList $ map mksub [1 .. Q.length specs]+        }+    )+    where+    mksub i = (T.pack $ show i, specSection h s r (i - 1))++hostSection+    :: DevHostLabel+    -> M.HashMap (RepoSpace, RepoName) (Seq RepoAnnSpec)+    -> SettingsTree+hostSection host repos = Section+    { secOpts = M.empty+    , secSubs = M.fromList $ map (uncurry f) $ M.toList repos+    }+    where+    f (space, repo) specs = repoSection host space repo specs++mkDefSpec :: Channel -> RepoAnnSpec+mkDefSpec chan = RepoAnnSpec+    { rasChannel       = chan+    , rasBranches      = Reject []+    , rasAllCommits    = False+    , rasCommits       = True+    , rasIssues        = True+    , rasMergeRequests = True+    , rasSnippets      = True+    , rasNotes         = True+    , rasNew           = True+    , rasOld           = True+    , rasUntimed       = True+    }++-- | Append a new repo ann spec to the settings and a matching tree under the+-- repo section. Return whether succeeded.+addRepoAnnSpec+    :: DevHostLabel+    -> RepoSpace+    -> RepoName+    -> Channel+    -> BotSession Bool+addRepoAnnSpec host space repo chan = do+    hosts <- fmap stGitAnnChans getSettings+    case M.lookup host hosts of+        Just repos ->+            case M.lookup (space, repo) repos of+                Just specs -> do+                    let specs' = specs |> defSpec+                        repos' = M.insert (space, repo) specs' repos+                        hosts' = M.insert host repos' hosts+                    modifySettings $ \ s -> s { stGitAnnChans = hosts' }+                    saveBotSettings+                    let (t, sec) = repoSection host space repo specs'+                        ins = insertSub ["repos", unDevHostLabel host, t] sec+                    modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+                    return True+                Nothing -> return False+        Nothing -> return False+    where+    defSpec = mkDefSpec chan++-- | 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.+deleteRepoAnnSpec+    :: DevHostLabel+    -> RepoSpace+    -> RepoName+    -> Int+    -> BotSession (Maybe Bool)+deleteRepoAnnSpec host space repo pos = do+    hosts <- fmap stGitAnnChans getSettings+    case M.lookup host hosts of+        Just repos ->+            case M.lookup (space, repo) repos of+                Just specs ->+                    let (u, v) = Q.splitAt pos specs+                    in  case Q.viewl v of+                            EmptyL -> return $ Just True+                            s :< r -> do+                                let specs' = u >< r+                                    repos' =+                                        M.insert (space, repo) specs' repos+                                    hosts' = M.insert host repos' hosts+                                modifySettings $+                                    \ s -> s { stGitAnnChans = hosts' }+                                saveBotSettings+                                let (t, sec) =+                                        repoSection host space repo specs'+                                    ins =+                                        insertSub+                                            ["repos", unDevHostLabel host, t]+                                            sec+                                modifyState $+                                    \ s -> s { bsSTree = ins $ bsSTree s }+                                return Nothing+                Nothing -> return $ Just False+        Nothing -> return $ Just False++-- | Add a new repo to settings and tree. Return 'Nothing' on success.+-- Otherwise return whether the host doesn't exist ('False') or the repo+-- already exists ('True').+addRepo+    :: DevHostLabel+    -> RepoSpace+    -> RepoName+    -> Channel+    -> BotSession (Maybe Bool)+addRepo host space repo chan = do+    hosts <- fmap stGitAnnChans getSettings+    case M.lookup host hosts of+        Nothing    -> return $ Just False+        Just repos ->+            case M.lookup (space, repo) repos of+                Just _  -> return $ Just True+                Nothing -> do+                    let specs = Q.singleton defSpec+                        repos' =+                            M.insert (space, repo) specs repos+                        hosts' = M.insert host repos' hosts+                    modifySettings $ \ s -> s { stGitAnnChans = hosts' }+                    saveBotSettings+                    let (t, sec) = repoSection host space repo specs+                        ins = insertSub ["repos", unDevHostLabel host, t] sec+                    modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }+                    return Nothing+    where+    defSpec = mkDefSpec chan++-- | Remove a repo from settings and tree. Return whether success, i.e. whether+-- the repo did exist and indeed has been deleted.+deleteRepo :: DevHostLabel -> RepoSpace -> RepoName -> BotSession Bool+deleteRepo host space repo = do+    hosts <- fmap stGitAnnChans getSettings+    case M.lookup host hosts of+        Just repos ->+            if M.member (space, repo) repos+                then do+                    let repos' = M.delete (space, repo) repos+                        hosts' = M.insert host repos' hosts+                    modifySettings $ \ s -> s { stGitAnnChans = hosts' }+                    saveBotSettings+                    let name =+                            CI.original (unRepoSpace space) <>+                            "/" <>+                            CI.original (unRepoName repo)+                        del = deleteSub ["repos", unDevHostLabel host, name]+                    modifyState $ \ s -> s { bsSTree = del $ bsSTree s }+                    return True+                else return False+        Nothing    -> return False
+ src/FunBot/Settings/Sections/Shortcuts.hs view
@@ -0,0 +1,121 @@+{- This file is part of funbot.+ -+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Settings.Sections.Shortcuts+    ( shortcutSec+    , addShortcut+    , deleteShortcut+    )+where++import Control.Monad (unless)+import Data.Bool (bool)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Sequence (Seq, (|>), (><), ViewL (..))+import Data.Settings.Section+import Data.Settings.Types+import FunBot.Settings.MkOption+import FunBot.Settings.Persist+import FunBot.Types+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.Types.Base (Channel (..), Nickname (..))++import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Lazy as M+import qualified Data.Sequence as Q+import qualified Data.Text as T++-- | Create a settings section for a shortcut, given its label string+shortcutSec :: ShortcutLabel -> 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 $ map unChannel . shChannels)+                (setf $ \ cut chans -> cut { shChannels = map Channel 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' }++-- | 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 :: ShortcutLabel -> Channel -> BotSession Bool+addShortcut label chan = do+    cuts <- fmap 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", CI.foldedCase $ unShortcutLabel 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 :: ShortcutLabel -> BotSession Bool+deleteShortcut label = do+    cuts <- fmap 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", CI.foldedCase $ unShortcutLabel label]+            modifyState $ \ s -> s { bsSTree = del $ bsSTree s }+            return True+        else return False
src/FunBot/Sources/FeedWatcher.hs view
@@ -13,6 +13,8 @@  - <http://creativecommons.org/publicdomain/zero/1.0/>.  -} +{-# LANGUAGE OverloadedStrings #-}+ module FunBot.Sources.FeedWatcher     ( feedWatcherSource     )@@ -21,27 +23,32 @@ import Data.Maybe (fromMaybe) 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 Text.Feed.Types (Feed, Item) import Web.Feed.Collect +import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T import qualified Data.HashMap.Lazy as M -makeItem label ftitle item = NewsEvent $ NewsItem-    { itemFeedLabel = label-    , itemFeedTitle = Just ftitle-    , itemTitle     = fromMaybe "(no title)" $ getItemTitle item-    , itemAuthor    = getItemAuthor item-    , itemUrl       = getItemLink item+makeItem :: Label -> String -> Item -> ExtEvent+makeItem label ftitle item = NewsEvent NewsItem+    { itemFeedLabel = T.pack label+    , itemFeedTitle = Just $ T.pack ftitle+    , itemTitle     = fromMaybe "(no title)" $ fmap T.pack $ getItemTitle item+    , itemAuthor    = fmap T.pack $ getItemAuthor item+    , itemUrl       = fmap T.pack $ getItemLink item     } +collect :: (ExtEvent -> IO ()) -> Label -> Url -> Feed -> Item -> IO () collect push label _url feed item =     push $ makeItem label (getFeedTitle feed) item +logError :: Logger -> Label -> Error -> IO () logError logger label err = logLine logger $ label ++ " : " ++ show err  feedWatcherSource :: FilePath -> BotState -> ExtEventSource@@ -50,8 +57,8 @@     let cq = feedCmdQueue env         pairs = M.toList $ stWatchedFeeds $ bsSettings state         mkfeed (label, nf) = def-            { fcLabel  = label-            , fcUrl    = nfUrl nf+            { fcLabel  = T.unpack $ CI.original$ unFeedLabel $ label+            , fcUrl    = T.unpack $ nfUrl nf             , fcActive = nfActive nf             }         feeds = map mkfeed pairs
src/FunBot/Sources/WebListener.hs view
@@ -18,25 +18,46 @@     ) where +import Data.ByteString.Lazy (empty) import FunBot.Sources.WebListener.Client (dispatchClient) import FunBot.Sources.WebListener.GitLab (dispatchGitLab) import FunBot.Sources.WebListener.Gogs (dispatchGogs) import FunBot.Types-import Network.HTTP (Request (..), RequestMethod (..))+import Network.HTTP (Request (..), RequestMethod (..), Response (..)) import Network.HTTP.Listen (run)+import Network.IRC.Fun.Bot.Logger import Network.IRC.Fun.Bot.State (askEnvS) import Network.URI (uriPath) -listener push pushMany request = do+resp = Response+    { rspCode    = (2, 0, 0)+    , rspReason  = "OK"+    , rspHeaders = []+    , rspBody    = empty+    }++listener dlogger elogger push pushMany request = do+    logLine dlogger $ show request+    logLine dlogger $ show $ rqBody request     case (uriPath $ rqURI request, rqMethod request) of-        ("/gogs", POST)   -> dispatchGogs push pushMany request-        ("/gitlab", POST) -> dispatchGitLab push pushMany request-        ("/client", POST) -> dispatchClient push pushMany request+        ("/gogs", POST)   -> do+            dispatchGogs push pushMany request+            return Nothing+        ("/gitlab", POST) -> do+            dispatchGitLab push pushMany request+            return $ Just resp+        ("/client", POST) -> do+            dispatchClient push pushMany request+            return Nothing         _ -> do-            putStrLn "Web listener source: Unrecognized request received:"-            print request-    return Nothing+            logLine elogger "Web listener source: \+                            \Unrecognized request received:"+            logLine elogger $ show request+            return Nothing -webListenerSource _config env push pushMany _mkLogger = do+webListenerSource :: FilePath -> ExtEventSource+webListenerSource elogfile _config env push pushMany mkLogger = do+    elogger <- mkLogger elogfile+    dlogger <- mkLogger "state/web-access.log"     putStrLn "Bot: Web listener source listening to HTTP requests"-    run (webHookSourcePort env) $ listener push pushMany+    run (webHookSourcePort env) $ listener dlogger elogger push pushMany
src/FunBot/Sources/WebListener/GitLab.hs view
@@ -22,7 +22,10 @@  import Control.Monad (when) import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) import FunBot.ExtEvents+import Formatting+import FunBot.Sources.WebListener.Util import Network.HTTP (Request (..)) import Network.URI @@ -31,68 +34,123 @@ import qualified Data.Text as T import qualified Web.Hook.GitLab as G -refToBranch :: T.Text -> T.Text-refToBranch ref = fromMaybe ref $ T.stripPrefix "refs/heads/" ref--refToTag :: T.Text -> T.Text-refToTag ref = fromMaybe ref $ T.stripPrefix "refs/tags/" ref--nl c = c == '\n' || c == '\r'+makeCommit :: G.Commit -> Commit+makeCommit commit = Commit+    { commitAuthor   = G.authorName $ G.commitAuthor commit+    , commitTitle    = takeLine $ G.commitMessage commit+    , commitUrl      = G.commitUrl commit+    , commitAdded    = G.commitAdded commit+    , commitModified = G.commitModified commit+    , commitRemoved  = G.commitRemoved commit+    } -urlToOwner url =-    case parseAbsoluteURI url of-        Just (URI { uriPath = _ : p }) -> takeWhile (/= '/') p-        _                              -> ""+makeRepo :: G.Repository -> Repository+makeRepo repo = Repository+    { repoName  = G.repoName repo+    , repoSpace = uriSpace uri+    , repoHost  = uriHost uri+    }+    where+    uri = parseURI $ T.unpack $ G.repoHomepage repo -makeCommit commit =-    let author = T.unpack $ G.authorName $ G.commitAuthor commit-        msg    = T.unpack $ T.takeWhile (not . nl) $ G.commitMessage commit-        url    = T.unpack $ G.commitUrl commit-    in  Commit author msg url+makePush :: G.Push -> ExtEvent+makePush push = GitPushEvent ProjectObject+    { poRepo = makeRepo $ G.pushRepository push+    , poObj  = Push+        { pushBranch  = refToBranch $ G.pushRef push+        , pushCommits = map makeCommit $ G.pushCommits push+        }+    } -makeBranch ref repo =-    let branch = T.unpack $ refToBranch ref-        repo'  = T.unpack $ G.repoName repo-        owner  = urlToOwner $ T.unpack $ G.repoHomepage repo-    in  Branch branch repo' owner+makeTag :: T.Text -> G.Repository -> T.Text -> ExtEvent+makeTag ref repo user = GitTagEvent $ ProjectObject+    { poRepo = makeRepo repo+    , poObj  = Tag+        { tagAuthor = user+        , tagRef    = refToTag ref+        }+    } -makeTag ref repo user =-    let user'  = T.unpack user-        ref'   = T.unpack $ refToTag ref-        repo'  = T.unpack $ G.repoName repo-        owner  = urlToOwner $ T.unpack $ G.repoHomepage repo-    in  GitTagEvent $ Tag user' ref' repo' owner+makeIssue :: G.IssueEvent -> ExtEvent+makeIssue ie = IssueEvent ProjectObject+    { poRepo = makeRepo $ G.ieRepo ie+    , poObj  = Issue+        { issueAuthor = G.userName $ G.ieUser ie+        , issueId     = G.issueId i+        , issueTitle  = takeLine $ G.issueTitle i+        , issueUrl    = G.issueUrl i+        , issueAction = G.ieAction ie+        }+    }+    where+    i = G.ieIssue ie -makeMR mre =-    let mr     = G.mreRequest mre-        author = T.unpack $ G.userName $ G.mreUser mre-        iid    = G.mrId mr-        repo   = T.unpack $ G.mepName $ G.mrTarget mr-        owner  = T.unpack $ G.mepNamespace $ G.mrTarget mr-        title  = T.unpack $ T.takeWhile (not . nl) $ G.mrTitle mr -- to be safe-        url    = T.unpack $ G.mrUrl mr-        action = T.unpack $ G.mreAction mre-    in  MergeRequestEvent $ MergeRequest author iid repo owner title url action+makeMR :: G.MergeRequestEvent -> ExtEvent+makeMR mre = MergeRequestEvent ProjectObject+    { poRepo = Repository+        { repoName  = G.mepName $ G.mrTarget mr+        , repoSpace = G.mepNamespace $ G.mrTarget mr+        , repoHost  = uriHost $ parseURI $ T.unpack $ G.mepWebUrl target+        }+    , poObj  = MergeRequest+        { mrAuthor = G.userName $ G.mreUser mre+        , mrId     = G.mrId mr+        , mrTitle  = takeLine $ G.mrTitle mr+        , mrUrl    = G.mrUrl mr+        , mrAction = G.mreAction mre+        }+    }+    where+    mr     = G.mreRequest mre+    target = G.mrTarget mr -dispatchPush push _pushMany p =-    let commits = map makeCommit $ G.pushCommits p-        branch = makeBranch (G.pushRef p) (G.pushRepository p)-    in  push $ GitPushEvent $ Push branch commits+shorten n t =+    if t `T.compareLength` n == GT+        then T.take n t <> "[…]"+        else t -dispatchTag push pushMany p =-    push $ makeTag (G.pushRef p) (G.pushRepository p) (G.pushUserName p)+showNoteTarget :: G.NoteTarget -> T.Text+showNoteTarget (G.NTCommit c) =+    sformat+        ("commit " % stext % " (“" % stext % "”)")+        (T.take 8 $ G.commitId c)+        (shorten 40 $ takeLine $ G.commitMessage c)+showNoteTarget (G.NTIssue i) =+    sformat ("issue #" % int) (G.issueId i)+showNoteTarget (G.NTMergeRequest mr) =+    sformat ("MR #" % int) (G.mrId mr)+showNoteTarget (G.NTSnippet s) =+    sformat ("snippet #" % int) (G.snippetId s) -dispatchMR push pushMany e = do-    let mre@(MergeRequestEvent mr) = makeMR e-    when (mrAction mr /= "update") $ push mre+makeNote :: G.NoteEvent -> ExtEvent+makeNote ne = NoteEvent ProjectObject+    { poRepo = makeRepo $ G.neRepo ne+    , poObj  = Note+        { noteAuthor  = G.userName $ G.neUser ne+        , noteContent = shorten 200 $ takeLine $ G.noteNote n+        , noteTarget  = showNoteTarget $ G.neTarget ne+        , noteUrl     = G.noteUrl n+        }+    }+    where+    n = G.neNote ne+    maxlen = 200 -dispatchGitLab push pushMany request =+dispatchGitLab push _pushMany request =     case G.parse $ rqBody request of         Left e -> do             putStr "Web hook source: GitLab: "             print e             BC.putStrLn $ rqBody request-        Right (G.EventPush e)         -> dispatchPush push pushMany e-        Right (G.EventPushTag e)      -> dispatchTag push pushMany e-        Right (G.EventIssue e)        -> putStrLn ">>> GitLab Issue"-        Right (G.EventMergeRequest e) -> dispatchMR push pushMany e+        Right (G.EventPush e) ->+            push $ makePush e+        Right (G.EventPushTag e) ->+            push $+            makeTag (G.pushRef e) (G.pushRepository e) (G.pushUserName e)+        Right (G.EventIssue e) ->+            push $ makeIssue e+        Right (G.EventMergeRequest e) -> do+            let mre@(MergeRequestEvent (ProjectObject _ mr)) = makeMR e+            when (mrAction mr /= "update") $ push mre+        Right (G.EventNote e) ->+            push $ makeNote e
src/FunBot/Sources/WebListener/Gogs.hs view
@@ -22,32 +22,41 @@  import Data.Maybe (fromMaybe) import FunBot.ExtEvents+import FunBot.Sources.WebListener.Util import Network.HTTP (Request (..))+import Network.URI  import qualified Data.Text as T import qualified Web.Hook.Gogs as G -refToBranch :: T.Text -> T.Text-refToBranch ref = fromMaybe ref $ T.stripPrefix "refs/heads/" ref--nl c = c == '\n' || c == '\r'--makeCommit commit =-    let author = T.unpack $ G.userName $ G.commitAuthor commit-        msg    = T.unpack $ T.takeWhile (not . nl) $ G.commitMessage commit-        url    = T.unpack $ G.commitUrl commit-    in  Commit author msg url+makeCommit :: G.Commit -> Commit+makeCommit commit = Commit+    { commitAuthor   = G.userName $ G.commitAuthor commit+    , commitTitle    = takeLine $ G.commitMessage commit+    , commitUrl      = G.commitUrl commit+    , commitAdded    = []+    , commitModified = []+    , commitRemoved  = []+    } -makeBranch ref repo =-    let branch = T.unpack $ refToBranch ref-        repo'  = T.unpack $ G.repoName repo-        owner  = T.unpack $ G.userUsername $ G.repoOwner repo-    in  Branch branch repo' owner+makeRepo :: G.Repository -> Repository+makeRepo repo = Repository+    { repoName  = G.repoName repo+    , repoSpace = G.userUsername $ G.repoOwner repo+    , repoHost  = fromMaybe "UNKNOWN" $ do+        uri <- parseURI $ T.unpack $ G.repoUrl repo+        auth <- uriAuthority uri+        return $ T.pack $ uriRegName auth+    } -fromGogs push =-    let commits = map makeCommit $ G.pushCommits push-        branch = makeBranch (G.pushRef push) (G.pushRepository push)-    in  GitPushEvent $ Push branch (reverse commits)+fromGogs :: G.Push -> ExtEvent+fromGogs push = GitPushEvent ProjectObject+    { poRepo = makeRepo $ G.pushRepository push+    , poObj  = Push+        { pushBranch  = refToBranch $ G.pushRef push+        , pushCommits = reverse $ map makeCommit $ G.pushCommits push+        }+    }  dispatchGogs push _pushMany request =     case G.parse $ rqBody request of
+ src/FunBot/Sources/WebListener/Util.hs view
@@ -0,0 +1,53 @@+{- This file is part of funbot.+ -+ - Written in 2015 by fr33domlover <fr33domlover@riseup.net>.+ -+ - ♡ Copying is an act of love. Please copy, reuse and share.+ -+ - The author(s) have dedicated all copyright and related and neighboring+ - rights to this software to the public domain worldwide. This software is+ - distributed without any warranty.+ -+ - You should have received a copy of the CC0 Public Domain Dedication along+ - with this software. If not, see+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++{-# LANGUAGE OverloadedStrings #-}++module FunBot.Sources.WebListener.Util+    ( refToBranch+    , refToTag+    , nl+    , takeLine+    , uriSpace+    , uriHost+    )+where++import Data.Maybe (fromMaybe)+import Network.URI++import qualified Data.Text as T++refToBranch :: T.Text -> T.Text+refToBranch ref = fromMaybe ref $ T.stripPrefix "refs/heads/" ref++refToTag :: T.Text -> T.Text+refToTag ref = fromMaybe ref $ T.stripPrefix "refs/tags/" ref++nl :: Char -> Bool+nl c = c == '\n' || c == '\r'++takeLine :: T.Text -> T.Text+takeLine = T.takeWhile $ not . nl++uriSpace :: Maybe URI -> T.Text+uriSpace (Just URI { uriPath = _ : p }) = T.pack $ takeWhile (/= '/') p+uriSpace _                              = "UNKNOWN"++uriHost :: Maybe URI -> T.Text+uriHost mu = fromMaybe "UNKNOWN" $ do+    uri <- mu+    auth <- uriAuthority uri+    return $ T.pack $ uriRegName auth
src/FunBot/Types.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -13,10 +13,22 @@  - <http://creativecommons.org/publicdomain/zero/1.0/>.  -} +-- For deriving trivial no-op Hashable instances for newtypes+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module FunBot.Types-    ( Filter (..)+    ( RepoName (..)+    , RepoSpace (..)+    , BranchName (..)+    , DevHostLabel (..)+    , DevHost (..)+    , FeedLabel (..)+    , ShortcutLabel (..)+    , LocationLabel (..)+    , Location (..)+    , Filter (..)     , BranchFilter-    , PushAnnSpec (..)+    , RepoAnnSpec (..)     , NewsItemFields (..)     , NewsAnnSpec (..)     , NewsFeed (..)@@ -33,33 +45,100 @@     , BotSession     , ExtEventSource     , ExtEventHandler+    , Respond+    , BotCmd     ) where  import Control.Concurrent.Chan (Chan)+import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.CaseInsensitive (CI)+import Data.Functor ((<$>))+import Data.Hashable (Hashable) import Data.HashMap.Lazy (HashMap) import Data.HashSet (HashSet)+import Data.Sequence (Seq) import Data.Settings.Types (Section (..), Option (..))+import Data.Text (Text) import Data.Time.Clock (UTCTime) import FunBot.ExtEvents (ExtEvent)-import Network.IRC.Fun.Bot.Types (Session, EventSource, EventHandler)+import Network.IRC.Fun.Bot.Types (Session, EventSource, EventHandler, Command)+import Network.IRC.Fun.Types.Base (Nickname, Channel, MsgContent) import Web.Feed.Collect (CommandQueue) +import qualified Data.CaseInsensitive as CI++instance (FromJSON s, CI.FoldCase s) => FromJSON (CI s) where+    parseJSON v = CI.mk <$> parseJSON v++instance ToJSON s => ToJSON (CI s) where+    toJSON = toJSON . CI.original++-- | A version control repository name+newtype RepoName = RepoName { unRepoName :: CI Text }+    deriving (Eq, Hashable)++-- | A repo hosting service repo namespace, e.g. user or team name+newtype RepoSpace = RepoSpace { unRepoSpace :: CI Text }+    deriving (Eq, Hashable)++-- | A version control repository branch name+newtype BranchName = BranchName { unBranchName :: Text }+    deriving (Eq, FromJSON, ToJSON)++-- | A repo hosting service host label+newtype DevHostLabel = DevHostLabel { unDevHostLabel :: Text }+    deriving (Eq, Hashable)++-- | A repo hosting service DNS name+newtype DevHost = DevHost { unDevHost :: CI Text } deriving (Eq, Hashable)++-- | TODO+newtype FeedLabel = FeedLabel { unFeedLabel :: CI Text }+    deriving (Eq, Hashable)++-- | TODO+newtype ShortcutLabel = ShortcutLabel { unShortcutLabel :: CI Text }+    deriving (Eq, Hashable)++-- | TODO+newtype LocationLabel = LocationLabel { unLocationLabel :: CI Text }+    deriving (Eq, Hashable)++-- | TODO+newtype Location = Location { unLocation :: Text }+ -- | Generic item filter data Filter a = Accept [a] | Reject [a]  -- | Chooser for repo branches whose commits should be announced to IRC-type BranchFilter = Filter String+type BranchFilter = Filter BranchName --- | Configuration for announcing a git repo's commits to a specific channel-data PushAnnSpec = PushAnnSpec+-- | Configuration for announcing a git repo's events to a specific channel+data RepoAnnSpec = RepoAnnSpec     { -- | IRC channel into which to announce-      pAnnChannel    :: String-      -- Branch filter to choose which branches to announce-    , pAnnBranches   :: BranchFilter-      -- Whether to report all commits in a push ('True') or shorten long+      rasChannel       :: Channel+      -- | Branch filter to choose which branches to announce+    , rasBranches      :: BranchFilter+      -- | Whether to report all commits in a push ('True') or shorten long       -- pushes to avoid channel spam ('False').-    , pAnnAllCommits :: Bool+    , rasAllCommits    :: Bool+      -- | Whether to announce commits and tags.+    , rasCommits       :: Bool+      -- | Whether to announce issues.+    , rasIssues        :: Bool+      -- | Whether to announce merge requests.+    , rasMergeRequests :: Bool+      -- | Whether to announce snippets.+    , rasSnippets      :: Bool+      -- | Whether to announce notes (comments).+    , rasNotes         :: Bool+      -- | Whether to announce recent fresh events.+    , rasNew           :: Bool+      -- | Whether to announce older events sent retroactively.+    , rasOld           :: Bool+      -- | Wherher to announce events whose time isn't specified.+    , rasUntimed       :: Bool     }  -- | Pick news item fields to display@@ -72,7 +151,7 @@ -- | Configuration for announcing news items data NewsAnnSpec = NewsAnnSpec     { -- | IRC channels into which to announce-      nAnnChannels :: [String]+      nAnnChannels :: [Channel]       -- | Filter for picking news item fields to display or hide     , nAnnFields   :: NewsItemFields     }@@ -80,7 +159,7 @@ -- | A web news feed from which the bot can read and announce new items data NewsFeed = NewsFeed     { -- | The feed URL-      nfUrl     :: String+      nfUrl     :: Text       -- | Whether the feed watcher is watching this feed     , nfActive  :: Bool       -- | Item announcement details@@ -96,11 +175,11 @@       -- stored in bot state, so you probably don't need this field directly.     , saveSettings      :: Settings -> IO ()       -- | Similarly for memos.-    , saveMemos         :: HashMap String [Memo] -> IO ()+    , saveMemos         :: HashMap Nickname [Memo] -> IO ()       -- | Similarly for user options.-    , saveUserOpts      :: HashMap String UserOptions -> IO ()+    , saveUserOpts      :: HashMap Nickname UserOptions -> IO ()       -- | Similarly for known nicks.-    , saveNicks         :: HashMap String (HashSet String) -> IO ()+    , saveNicks         :: HashMap Channel (HashSet Nickname) -> IO ()       -- | Filename for logging feed listener errors     , feedErrorLogFile  :: FilePath       -- | Command queue for controlling the news feed watcher source@@ -115,39 +194,59 @@     { -- | 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+      shPrefix   :: Text       -- | The generated longer form is a concatenation of this field, the       -- shortcut string (without the prefix) and 'shAfter'.-    , shBefore   :: String+    , shBefore   :: Text       -- | The generated longer form is a concatenation of 'shBefore', the       -- shortcut string (without the prefix) and this field.-    , shAfter    :: String+    , shAfter    :: Text       -- | The channels in which this shortcut should be applied.-    , shChannels :: [String]+    , shChannels :: [Channel]     }  -- | Per-channel settings data ChanSettings = ChanSettings     { -- | Whether to display URL titles (the default is yes).-      csSayTitles :: Bool+      csSayTitles  :: Bool       -- | Whether to welcome new users when the channel is quiet.-    , csWelcome   :: Bool+    , csWelcome    :: Bool       -- | Nicks to mention in the welcome message.-    , csFolks     :: [String]+    , csFolks      :: [Nickname]       -- | Email address for async discussions.-    , csEmail     :: String+    , csEmail      :: Text+      -- | Generic key-value mapping intended to refer to URLs by short labels.+    , csLocations  :: HashMap LocationLabel Location+      -- | Users who can ask the bot to send an arbitrary message in the+      -- channel. Can be useful but also dangerous, manage with care.+    , csPuppeteers :: HashSet Nickname+      -- | URL of an IRCBrowse instance for the specific channel.+    , csBrowse     :: Maybe Text     }  -- | User-modifiable bot behavior settings data Settings = Settings-    { -- | Maps a Git repo name+owner to annoucement details-      stGitAnnChans  :: HashMap (String, String) [PushAnnSpec]+    { -- | Maps a host label to Git repo space+name to annoucement details+      stGitAnnChans  :: HashMap+                            DevHostLabel+                            (HashMap (RepoSpace, RepoName) (Seq RepoAnnSpec))       -- | Maps a feed label to its URL and announcement details-    , stWatchedFeeds :: HashMap String NewsFeed+    , stWatchedFeeds :: HashMap FeedLabel NewsFeed       -- | Maps a shortcut label to its spec-    , stShortcuts    :: HashMap String Shortcut+    , stShortcuts    :: HashMap ShortcutLabel Shortcut       -- | Per-channel settings-    , stChannels     :: HashMap String ChanSettings+    , stChannels     :: HashMap Channel ChanSettings+      -- | Maps host names to host labels+    , stDevHosts     :: HashMap DevHost DevHostLabel+      -- | A generic key-value mapping intended to refer to URLs by short+      -- labels. This is a global mapping, and there are also per-channel+      -- mappings in 'ChanSettings'.+    , stLocations    :: HashMap LocationLabel Location+      -- | Users who can ask the bot to send an arbitrary message in an+      -- arbitrary channel. This gives a lot of power but is also dangerous,+      -- use with care. There are also per-channel puppeteers, see+      -- 'ChanSettings'.+    , stPuppeteers   :: HashSet Nickname     }  -- | Alias for the settings option type@@ -158,11 +257,11 @@  -- | A message left to an offline user, for them to read later. data Memo = Memo-    { memoTime    :: String-    , memoSender  :: String-    , memoRecvIn  :: Maybe String-    , memoSendIn  :: Maybe String-    , memoContent :: String+    { memoTime    :: Text+    , memoSender  :: Nickname+    , memoRecvIn  :: Maybe Channel+    , memoSendIn  :: Maybe Channel+    , memoContent :: MsgContent     }  -- | History display options per channel@@ -176,7 +275,7 @@ -- | Per-user options, consider private user info data UserOptions = UserOptions     { -- | History display options per channel-      uoHistoryDisplay :: HashMap String HistoryDisplay+      uoHistoryDisplay :: HashMap Channel HistoryDisplay     }  -- | Read-write custom bot state@@ -186,13 +285,18 @@       -- | Settings tree and access definition for UI     , bsSTree       :: SettingsTree       -- | Memos waiting for users to connect.-    , bsMemos       :: HashMap String [Memo]+    , bsMemos       :: HashMap Nickname [Memo]       -- | Per-user options-    , bsUserOptions :: HashMap String UserOptions+    , bsUserOptions :: HashMap Nickname UserOptions       -- | Known nicks in channels-    , bsKnownNicks  :: HashMap String (HashSet String)+    , bsKnownNicks  :: HashMap Channel (HashSet Nickname)       -- | Time of last message per channel.-    , bsLastMsgTime :: HashMap String UTCTime+    , bsLastMsgTime :: HashMap Channel UTCTime+      -- | Channels for which puppet mode is enabled, and by which user.+    , bsPuppet      :: HashMap Channel Nickname+      -- | Whether private puppet mode is enabled, and by which user. It allows+      -- the user to ask the bot to send a private message to another user.+    , bsPrivPuppet  :: Maybe Nickname     }  -- | Shortcut alias for bot session monad@@ -203,3 +307,14 @@  -- | Shortcut alias for event handler function type type ExtEventHandler = EventHandler BotEnv BotState ExtEvent++-- | The type of command response functions+type Respond+    =  Maybe Channel+    -> Nickname+    -> [Text]+    -> (MsgContent -> BotSession ())+    -> BotSession ()++-- | Bot command type+type BotCmd = Command BotEnv BotState
src/FunBot/UserOptions.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -34,15 +34,18 @@ import Control.Monad.IO.Class (liftIO) import Data.Aeson import Data.JsonState-import Data.List (intercalate) import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text, intercalate)+import Formatting import FunBot.Config (stateSaveInterval, configuration, userOptsFilename)+import FunBot.Settings.Instances () 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 (cfgStateRepo))-import Text.Printf (printf)+import Network.IRC.Fun.Types.Base  import qualified Data.HashMap.Lazy as M @@ -66,9 +69,7 @@ defUserOpts = UserOptions     { uoHistoryDisplay = M.empty } -getUserHistoryOpts :: String -- ^ User nickname-                   -> String -- ^ Channel-                   -> BotSession HistoryDisplay+getUserHistoryOpts :: Nickname -> Channel -> BotSession HistoryDisplay getUserHistoryOpts nick chan = do     opts <- getStateS bsUserOptions     let user = M.lookup nick opts@@ -80,33 +81,47 @@ -- Command Implementation ------------------------------------------------------------------------------- -showEnabled :: Bool -> String+showEnabled :: Bool -> Text showEnabled True  = "Enabled" showEnabled False = "Disabled" -showMaxLines :: Int -> String-showMaxLines n = show n ++ " lines"+showMaxLines :: Int -> Text+showMaxLines n = sformat (int % " lines") n -formatHistoryOpts :: String -> String -> Maybe HistoryDisplay -> String+formatHistoryOpts :: Nickname -> Channel -> Maybe HistoryDisplay -> MsgContent formatHistoryOpts nick chan mhd =     let defSuffix = " [default]"         (enabled, maxLines) =             case mhd of                 Nothing ->-                    ( showEnabled defaultEnabled ++ defSuffix-                    , showMaxLines defaultMaxLines ++ defSuffix+                    ( 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+    in  MsgContent $+        sformat+            ( "History display of "+            % stext+            % " for "+            % stext+            % ": "+            % stext+            % ", "+            % stext+            )+            (unChannel chan)+            (unNickname nick)+            enabled+            maxLines -modifyOpts :: String                             -- ^ User nickname-           -> String                             -- ^ Channel-           -> (HistoryDisplay -> HistoryDisplay) -- ^ Modification-           -> BotSession ()+modifyOpts+    :: Nickname+    -> Channel+    -> (HistoryDisplay -> HistoryDisplay)+    -> BotSession () modifyOpts nick chan f = do     opts <- getStateS bsUserOptions     let userPrev = M.lookupDefault defUserOpts nick opts@@ -123,9 +138,7 @@ -- Commands ------------------------------------------------------------------------------- -sendHistoryOpts :: String -- ^ User nickname-                -> String -- ^ Channel-                -> BotSession ()+sendHistoryOpts :: Nickname -> Channel -> BotSession () sendHistoryOpts nick chan = do     opts <- getStateS bsUserOptions     let user = M.lookup nick opts@@ -133,50 +146,62 @@         mhd = hdmap >>= M.lookup chan     sendToUser nick $ formatHistoryOpts nick chan mhd -sendChannels :: String -- ^ User nickname-             -> BotSession ()+sendChannels :: Nickname -> BotSession () sendChannels nick = do-    muser <- liftM (M.lookup nick) $ getStateS bsUserOptions+    muser <- fmap (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+                else intercalate ", " $ map unChannel keys+    sendToUser nick $ MsgContent $ "Options stored for channels: " <> l -setEnabled :: String -- ^ User nickname-           -> String -- ^ Channel-           -> Bool   -- ^ Whether to enable (or disable)-           -> BotSession ()+setEnabled :: Nickname -> Channel -> Bool -> BotSession () setEnabled nick chan enabled = do     modifyOpts nick chan $ \ hd -> hd { hdEnabled = enabled }-    sendToUser nick $-        printf "History display of %v: %v" chan (showEnabled enabled)+    sendToUser nick $ MsgContent $+        sformat+            ( "History display of "+            % stext+            % ": "+            % stext+            )+            (unChannel chan)+            (showEnabled enabled) -setMaxLines :: String -- ^ User nickname-            -> String -- ^ Channel-            -> Int    -- ^ Number of lines-            -> BotSession ()+setMaxLines :: Nickname -> Channel -> Int -> 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\n\-            \(I keep in my logs up to %v for %v)"-            chan (showMaxLines maxLines) (showMaxLines hls) chan+    sendToUser nick $ MsgContent $+        sformat+            ( "History display length for "+            % stext+            % ": "+            % stext+            % "\n(I keep in my logs up to "+            % stext+            % " for "+            % stext+            % ")"+            )+            (unChannel chan)+            (showMaxLines maxLines)+            (showMaxLines hls)+            (unChannel chan) -eraseOpts :: String -- ^ User nickname-          -> BotSession ()+eraseOpts :: Nickname -> BotSession () eraseOpts nick = do     opts <- getStateS bsUserOptions     case M.lookup nick opts of-        Nothing   -> sendToUser nick "You don't have stored options."+        Nothing   ->+            sendToUser nick $ MsgContent "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."+            sendToUser nick $+                MsgContent "All your options have been reset to defaults."  ------------------------------------------------------------------------------- -- Persistence@@ -206,7 +231,7 @@         [ "history-display" .= hd         ] -loadUserOptions :: IO (M.HashMap String UserOptions)+loadUserOptions :: IO (M.HashMap Nickname UserOptions) loadUserOptions = do     r <- loadState $          stateFilePath userOptsFilename (cfgStateRepo configuration)@@ -215,7 +240,7 @@         Left (True, e)  -> error $ "Failed to parse user options file: " ++ e         Right s         -> return s -mkSaveUserOptions :: IO (M.HashMap String UserOptions -> IO ())+mkSaveUserOptions :: IO (M.HashMap Nickname UserOptions -> IO ()) mkSaveUserOptions =     mkSaveStateChoose         stateSaveInterval
src/FunBot/Util.hs view
@@ -13,24 +13,40 @@  - <http://creativecommons.org/publicdomain/zero/1.0/>.  -} +{-# LANGUAGE OverloadedStrings #-}+ module FunBot.Util     ( (!?)-    , replaceMaybe+      --, replaceMaybe     , passes     , passesBy     , getTimeStr     , getHistoryLines+    , cmds+    , helps+    , looksLikeChan+    , notchan+    , looksLikeNick+    , notnick+    , unsnoc     ) where  import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO)+import Data.Char import Data.Maybe (listToMaybe)+import Data.Monoid ((<>))+import Data.Text (Text) import FunBot.Types import Network.IRC.Fun.Bot.State (askTimeGetter, getChanInfo)-import Network.IRC.Fun.Bot.Types (ChanInfo (ciHistoryLines))+import Network.IRC.Fun.Bot.Types (ChanInfo (ciHistoryLines), CommandName (..))+import Network.IRC.Fun.Color.Style+import Network.IRC.Fun.Types.Base +import qualified Data.CaseInsensitive as CI (mk) import qualified Data.HashMap.Lazy as M (lookup)+import qualified Data.Text as T  -- | List index operator, starting from 0. Like @!!@ but returns a 'Maybe' -- instead of throwing an exception. On success, returns 'Just' the item. On@@ -41,12 +57,16 @@ -- | Replace the list item at the given position, with the given new item. -- Return the resulting list. If the position is out of range, return -- 'Nothing'.-replaceMaybe :: [a] -> Int -> a -> Maybe [a]-replaceMaybe l i y =-    case splitAt i l of-        (_, [])   -> Nothing-        (b, x:xs) -> Just $ b ++ y : xs+--replaceMaybe :: [a] -> Int -> a -> Maybe [a]+--replaceMaybe l i y = setMaybe l i (const y) +-- | Like 'replaceMaybe', but takes a function and applies to the item.+--setMaybe :: [a] -> Int -> (a -> a) -> Maybe [a]+--setMaybe l i f =+--    case splitAt i l of+--        (_, [])   -> Nothing+--        (b, x:xs) -> Just $ b ++ f x : xs+ -- | Check whether a value passes a given filter. passes :: Eq a => a -> Filter a -> Bool v `passes` (Accept l) = v `elem` l@@ -58,14 +78,60 @@ 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 :: BotSession Text getTimeStr = do     getTime <- askTimeGetter-    liftIO $ liftM snd getTime+    liftIO $ fmap 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 :: Channel -> BotSession Int getHistoryLines chan = do     cs <- getChanInfo     return $ maybe 0 ciHistoryLines $ M.lookup chan cs++-- | Helper for specifying command names+cmds :: [Text] -> [CommandName]+cmds = map $ CommandName . CI.mk++-- | Helper for specifying command help+helps :: [(Text, Text)] -> Text+helps l = T.intercalate "\n" $ map (uncurry f) l+    where+    maxlen = maximum $ map (T.length . fst) l+    nspaces spec = maxlen - T.length spec+    spaces spec = T.replicate (nspaces spec) " "+    f spec desc = T.concat+        [ "‘"+        , encode $ Bold #> plain spec+        , "’"+        , spaces spec+        , " - "+        , desc+        ]++looksLikeChan (Channel chan) =+    case T.uncons chan of+        Nothing     -> False+        Just (c, _) -> c `elem` ("#+!&" :: String)++notchan chan = MsgContent $ unChannel chan <> " doesn’t look like a channel name."++looksLikeNick nick =+    case T.uncons nick of+        Nothing     -> False+        Just (c, r) -> first c && T.all rest r+    where+    isAsciiLetter c = isAsciiLower c || isAsciiUpper c+    isSpecial = (`elem` ("[]\\`_^{|}" :: String))+    first c = isAsciiLetter c || isSpecial c+    rest c = isAsciiLetter c || isDigit c || isSpecial c || c == '-'++notnick nick = MsgContent $ nick <> " doesn’t look like a nickname."++-- | Trivial @unsnoc@ for Text.+unsnoc :: Text -> Maybe (Text, Char)+unsnoc t =+    if T.null t+        then Nothing+        else Just (T.init t, T.last t)
src/Main.hs view
@@ -1,6 +1,6 @@ {- This file is part of funbot.  -- - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ - Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.  -  - ♡ Copying is an act of love. Please copy, reuse and share.  -@@ -13,21 +13,26 @@  - <http://creativecommons.org/publicdomain/zero/1.0/>.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Main (main) where  import Control.Concurrent.Chan (newChan) import Control.Monad.IO.Class (liftIO)+import Data.Default.Class (def) import Data.Settings.Section (empty)-import FunBot.Commands (commandSet)+import FunBot.Commands import FunBot.ExtHandlers (handler) import FunBot.KnownNicks import FunBot.Memos import FunBot.Settings+import FunBot.Settings.Persist+import FunBot.Settings.Sections import FunBot.Sources import FunBot.Types import FunBot.UserOptions+import FunBot.Util (cmds) 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 (..), EventMatchSpace (..)) import Web.Feed.Collect (newCommandQueue)@@ -56,6 +61,8 @@     , bsUserOptions = userOpts     , bsKnownNicks  = nicks     , bsLastMsgTime = M.empty+    , bsPuppet      = M.empty+    , bsPrivPuppet  = Nothing     }  -- | Event detector specification@@ -81,14 +88,16 @@     , defaultMatch     ]     where-    privCmds =+    privCmds = cmds         [ "help", "info", "echo", "tell", "get", "show-opts", "enable-history"         , "disable-history", "set-history-lines", "erase-opts", "show-history"+        , "where", "lwhere", "gwhere"         ]   -- | Bot behavior definition-behavior = defaultBehavior+behavior :: Behavior BotEnv BotState+behavior = def     { handleJoin       = H.handleJoin     , handleMsg        = H.handleMsg     , handleAction     = H.handleAction@@ -100,11 +109,12 @@  -- | Additional events sources mkSources state =-    [ webListenerSource+    [ webListenerSource C.webErrorLogFile     , feedWatcherSource C.feedErrorLogFile state     , loopbackSource     ] +main :: IO () main = do     liftIO $ putStrLn "Loading bot settings"     sets <- loadBotSettings
state-default/settings.json view
@@ -1,5 +1,9 @@ {     "repos"     : {},     "feeds"     : {},-    "shortcuts" : {}+    "shortcuts" : {},+    "channels"  : {},+    "dev-hosts" : {},+    "locations" : {},+    "puppeteers" : {} }