funbot 0.1.0.0 → 0.2
raw patch · 16 files changed
+623/−402 lines, 16 filesdep +funbot-ext-eventsdep +http-clientdep +http-client-tlsdep ~irc-fun-botdep ~settings
Dependencies added: funbot-ext-events, http-client, http-client-tls, json-state, tagsoup, utf8-string
Dependency ranges changed: irc-fun-bot, settings
Files
- NEWS +33/−3
- funbot.cabal +8/−2
- src/FunBot/Commands.hs +84/−59
- src/FunBot/Config.hs +26/−9
- src/FunBot/ExtHandlers.hs +27/−19
- src/FunBot/IrcHandlers.hs +49/−8
- src/FunBot/Memos.hs +61/−18
- src/FunBot/Settings.hs +269/−36
- src/FunBot/Sources/FeedWatcher.hs +11/−8
- src/FunBot/Sources/WebListener.hs +8/−8
- src/FunBot/Sources/WebListener/Client.hs +5/−143
- src/FunBot/Sources/WebListener/GitLab.hs +13/−8
- src/FunBot/Sources/WebListener/Gogs.hs +5/−4
- src/FunBot/Types.hs +7/−69
- src/FunBot/Util.hs +11/−1
- src/Main.hs +6/−7
NEWS view
@@ -3,14 +3,44 @@ -funbot 0.1.0.0 -- 0.1.0.0-=========================+funbot 0.2 -- 2015-09-22+======================== General, build and documentation changes: +* Some config values moved to Config.hs from other files+* Git repo details moved from Config.hs into JSON file++New UIs, features and enhancements:++* Git repo details have settings options and can be partially edited+* Help command now includes settings options+* New bot command !ctell+* Settings and memos JSON files support version control+* Report titles of URLs send into channels+* New external event type, paste++Bug fixes:++* Gitlab MR update events not announced to IRC, it's too much channel spam+* Memos are now reported if needed when a user changes their nickname++Dependency changes:++* Add funbot-ext-events+* Add json-state+* Require irc-fun-bot >= 0.3++++funbot 0.1 -- 2015-09-11+========================++General, build and documentation changes:+ * (This is the first release, so everything is new) -New APIs, features and enhancements:+New UIs, features and enhancements: * (This is the first release, so everything is a new feature)
funbot.cabal view
@@ -1,5 +1,5 @@ name: funbot-version: 0.1.0.0+version: 0.2 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@@ -57,18 +57,24 @@ , bytestring , feed , feed-collect+ , funbot-ext-events , HTTP+ , http-client >=0.4.19+ , http-client-tls >=0.2.2 , http-listen- , irc-fun-bot >=0.2+ , irc-fun-bot >=0.3 && <0.4 , irc-fun-color+ , json-state , network-uri , settings+ , tagsoup >=0.13 , text , time , time-interval , time-units , transformers , unordered-containers >=0.2.5+ , utf8-string >=1 , vcs-web-hook-parse hs-source-dirs: src default-language: Haskell2010
src/FunBot/Commands.hs view
@@ -18,6 +18,7 @@ ) where +import Control.Monad (unless) import Data.List (find, intercalate) import Data.Settings.Types (showOption) import FunBot.Memos (submitMemo)@@ -35,7 +36,8 @@ [ makeCmdHelp commandSet , cmdInfo , cmdEcho- , cmdTell+ , cmdPTell+ , cmdCTell , cmdGet , cmdSet , cmdReset@@ -49,10 +51,9 @@ -- Send the input back to the IRC channel ------------------------------------------------------------------------------- -respondEcho :: String -> String -> [String] -> BotSession ()-respondEcho chan _ [] = sendToChannel chan " "-respondEcho chan _ [param] = sendToChannel chan param-respondEcho chan _ params = sendToChannel chan $ unwords params+respondEcho _mchan _nick [] send = send " "+respondEcho _mchan _nick [param] send = send param+respondEcho _mchan _nick params send = send $ unwords params cmdEcho = Command { names = ["echo"]@@ -66,27 +67,36 @@ -- Show command help strings ------------------------------------------------------------------------------- -respondHelp :: CommandSet e s -> String -> String -> [String] -> BotSession ()-respondHelp cset chan _ [cname] =- case find (any (== cname) . names) $ commands cset of- Just cmd -> sendToChannel chan $- help cmd- ++ "\nCommand names: "- ++ listNames Nothing Nothing True (names cmd)- Nothing -> sendToChannel chan "No such command, try just ‘help’ \- \without a parameter."-respondHelp cset chan _ _ =- sendToChannel chan $- help (makeCmdHelp cset)- ++ "\nAvailable commands: "- ++ listPrimaryNames (Just $ prefix cset) Nothing False (commands cset)+-- Return a response function given a CommandSet+respondHelp cset _mchan _nick [cname] send =+ case find ((cname' `elem`) . names) $ commands cset of+ Just cmd -> send $ help cmd+ ++ "\nCommand names: "+ ++ listNames Nothing Nothing True (names cmd)+ Nothing -> do+ succ <- respondSettingsHelp cname send+ unless succ $ send $ printf+ "No such command, or invalid settings path. \+ \Maybe try just ‘%vhelp’ without a parameter."+ (prefix cset)+ where+ cname' = case cname of+ [] -> cname+ (c:cs) -> if c == prefix cset then cs else cname +respondHelp cset _mchan _nick _params send =+ send $ help (makeCmdHelp cset)+ ++ "\nAvailable commands: "+ ++ listPrimaryNames (Just $ prefix cset) Nothing False (commands cset)+ makeCmdHelp cset = Command- { names = ["help", "h", "?"]+ { names = ["help", "Help", "h", "?"] , respond = respondHelp cset- , help = "‘help [<command>]’ - display help for the given command. \- \Passing no parameters, or passing 2 or more, displays the \- \general help (i.e. this text)."+ , help = "‘help [<command> | <setting>]’ - display help for the given \+ \command or settings option/section.\n\+ \FunBot intends to provide interactive help, but some topics \+ \may be missing. If that's the case, check out the user \+ \manual (call ‘!info links’ for the URL) or ask in #freepost." } -------------------------------------------------------------------------------@@ -94,14 +104,13 @@ -- Ask the bot to display some information ------------------------------------------------------------------------------- -respondInfo :: String -> String -> [String] -> BotSession ()-respondInfo chan _ ["intro"] = sendToChannel chan $+respondInfo _mchan _nick ["intro"] send = send $ "I’m fpbot. An instance of funbot, written in Haskell. I run in #freepost \ \(and some extra channels). Developed in the Freepost community, I exist \ \for fun, collaboration and learning. But I also aim to provide useful \ \tools, in particular to Freepost and related projects and communities.\n\ \You can start by trying ‘!help’."-respondInfo chan _ ["features"] = sendToChannel chan $+respondInfo _mchan _nick ["features"] send = send $ "This is a high-level list of features and subsystems I provide. It will \ \hopefully be kept up-to-date by updating it every time new features are \ \added.\n\@@ -113,25 +122,25 @@ \There is also an overview of the bot API features, useful to \ \contributors/developers, in the guide at \ \<http://rel4tion.org/projects/funbot/guide>."-respondInfo chan _ ["contrib"] = sendToChannel chan $+respondInfo _mchan _nick ["contrib"] send = send $ "Thinking about contributing to my development? Opening a ticket, fixing \ \a bug, implementing a feature? Check out the project page at \ \<http://rel4tion.org/projects/funbot>, which links to the contribution \ \guide, to the tickets page and more."-respondInfo chan _ ["copying"] = sendToChannel chan $+respondInfo _mchan _nick ["copying"] send = send $ "♡ Copying is an act of love. Please copy, reuse and share me! \ \Grab a copy of me from <https://notabug.org/fr33domlover/funbot>."-respondInfo chan _ ["links"] = sendToChannel chan $+respondInfo _mchan _nick ["links"] send = send $ "Website: http://rel4tion.org/projects/funbot\n\ \Code: https://notabug.org/fr33domlover/funbot\n\ \Tickets: http://rel4tion.org/projects/funbot/tickets\n\ \Roadmap: http://rel4tion.org/projects/funbot/ideas\n\ \Dev guide: http://rel4tion.org/projects/funbot/guide\n\ \User manual: http://rel4tion.org/projects/funbot/manual"-respondInfo chan nick [arg] =- failToChannel chan nick $ InvalidArg (Just 1) (Just arg)-respondInfo chan nick args =- failToChannel chan nick $ WrongNumArgsN (Just $ length args) (Just 1)+respondInfo mchan nick [arg] _send =+ failBack mchan nick $ InvalidArg (Just 1) (Just arg)+respondInfo mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1) cmdInfo = Command { names = ["info", "i"]@@ -145,43 +154,59 @@ -- Tell something to some other user ------------------------------------------------------------------------------- -respondTell :: String -> String -> [String] -> BotSession ()-respondTell chan sender (recip:msghead:msgtail) =- submitMemo sender (Just chan) recip (unwords $ msghead : msgtail)-respondTell chan nick args =- failToChannel chan nick $ WrongNumArgsN (Just $ length args) Nothing+-- 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 -cmdTell = Command- { names = ["tell"]- , respond = respondTell- , help = "‘tell <nick> <text>’ - leave a memo for a user to see later"+cmdPTell = Command+ { names = ["tell", "ptell"]+ , respond = respondTell True+ , help = "‘tell <nick> <text>’ - leave a memo for a user to see later. \+ \Memos can be sent to the recipient privately, or publicly \+ \in the channel in which they were submitted. With this \+ \command, the memo will be sent privately. If that isn't your \+ \intention, see the ctell command." } +cmdCTell = Command+ { names = ["ctell"]+ , respond = respondTell False+ , help = "‘tell <nick> <text>’ - leave a memo for a user to see later. \+ \Memos can be sent to the recipient privately, or publicly \+ \in the channel in which they were submitted. With this \+ \command, the memo will be sent in the same way it was \+ \submitted: If you submit it in a channel, it will be sent to \+ \the recipient in the same channel. If you submit using a \+ \private message to me, I will also send it privately to the \+ \recipient.\n\+ \If that isn't your intention, see the tell command."+ }+ ------------------------------------------------------------------------------- -- Get, set, enable and disable commands -- Manage bot settings ------------------------------------------------------------------------------- -respondGet :: String -> String -> [String] -> BotSession ()-respondGet chan _ [] = respondGet' "" chan-respondGet chan _ [path] = respondGet' path chan-respondGet chan nick args =- failToChannel chan nick $ WrongNumArgsN (Just $ length args) (Just 1)+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 :: String -> String -> [String] -> BotSession ()-respondSet chan _ [name, val] = respondSet' name val chan-respondSet chan nick args =- failToChannel chan nick $ WrongNumArgsN (Just $ length args) (Just 2)+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 :: String -> String -> [String] -> BotSession ()-respondReset chan _ [name] = respondReset' name chan-respondReset chan nick args =- failToChannel chan nick $ WrongNumArgsN (Just $ length args) (Just 1)+respondReset _mchan _nick [name] send = respondReset' name send+respondReset mchan nick args _send =+ failBack mchan nick $ WrongNumArgsN (Just $ length args) (Just 1) -respondBool :: Bool -> String -> String -> [String] -> BotSession ()-respondBool val chan _ [name] = respondSet' name (showOption val) chan-respondBool _ chan nick args =- failToChannel chan 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
src/FunBot/Config.hs view
@@ -14,18 +14,22 @@ -} module FunBot.Config- ( configuration+ ( stateSaveInterval+ , configuration , webListenerPort- , devAnnChans , feedErrorLogFile+ , feedVisitInterval+ , settingsFilename+ , memosFilename ) where -import qualified Data.HashMap.Lazy as M-import Data.Time.Interval (time)-import Data.Time.Units-import Network.IRC.Fun.Bot.Types (Connection (..), Config (..))+import Data.Time.Interval (time)+import Data.Time.Units+import Network.IRC.Fun.Bot.Types (Connection (..), Config (..)) +stateSaveInterval = 3 :: Second+ configuration = Config { connection = Connection { server = "irc.freenode.net"@@ -36,13 +40,26 @@ } , channels = ["#freepost-bot-test"] , logDir = "state/chanlogs"+ , stateRepo = Nothing , stateFile = "state/state.json"- , saveInterval = time (3 :: Second)+ , saveInterval = time stateSaveInterval , botEventLogFile = "state/bot.log" } webListenerPort = 8998 :: Int -devAnnChans = M.empty- feedErrorLogFile = "state/feed-error.log"++feedVisitInterval = 5 :: Minute++-- | If you set a repo path in the configuration above ('stateRepo' field),+-- then this path is relative to that repo and the settings 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.+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.+memosFilename = "state/memos.json"
src/FunBot/ExtHandlers.hs view
@@ -20,19 +20,22 @@ ) where -import Control.Monad (forM_, when)-import Control.Monad.IO.Class (liftIO)-import Data.Char (toLower)+import Control.Monad (forM_, when)+import Control.Monad.IO.Class (liftIO)+import Data.Char (toLower)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import FunBot.ExtEvents+import FunBot.Types+import FunBot.Util (passes)+import Network.HTTP (Request (..), RequestMethod (..))+import Network.IRC.Fun.Bot.Chat (sendToChannel)+import Network.IRC.Fun.Bot.State (getStateS)+import Network.IRC.Fun.Color+import Text.Printf (printf)+ import qualified Data.HashMap.Lazy as M-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import qualified Data.Text as T-import FunBot.Types-import FunBot.Util (passes)-import Network.HTTP (Request (..), RequestMethod (..))-import Network.IRC.Fun.Bot.Chat (sendToChannel)-import Network.IRC.Fun.Bot.State (askEnvS, getStateS)-import Network.IRC.Fun.Color import qualified Web.Hook.GitLab as GitLab import qualified Web.Hook.Gogs as Gogs @@ -57,7 +60,7 @@ Purple #> Pure repo <> " " <> Teal #> Pure ref -formatMR (MR author iid _repo _owner title url action) =+formatMR (MergeRequest author iid _repo _owner title url action) = encode $ Green #> Pure author <> " " <> Maroon #> Pure action <> " " <>@@ -89,6 +92,9 @@ 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)@@ -110,8 +116,8 @@ sendToChannel chan ellip sendToChannel chan lastCommit -handler (GitPush (Push branch commits)) = do- chans <- askEnvS gitAnnChans+handler (GitPushEvent (Push branch commits)) = do+ chans <- getStateS $ gitAnnChans . settings case M.lookup (keyb branch) chans of Just specs -> let fmt = formatCommit (branchName branch) (branchRepo branch)@@ -126,8 +132,8 @@ liftIO $ putStrLn $ "Ext handler: Git push for unregistered repo: " ++ show (keyb branch)-handler (GitTag tag) = do- chans <- askEnvS gitAnnChans+handler (GitTagEvent tag) = do+ chans <- getStateS $ gitAnnChans . settings case M.lookup (keyt tag) chans of Just specs -> let msg = formatTag tag@@ -137,8 +143,8 @@ liftIO $ putStrLn $ "Ext handler: Tag for unregistered repo: " ++ show (keyt tag)-handler (MergeRequest mr) = do- chans <- askEnvS gitAnnChans+handler (MergeRequestEvent mr) = do+ chans <- getStateS $ gitAnnChans . settings case M.lookup (keym mr) chans of Just specs -> let msg = formatMR mr@@ -148,7 +154,7 @@ liftIO $ putStrLn $ "Ext handler: MR for unregistered repo: " ++ show (keym mr)-handler (NewsItem item) = do+handler (NewsEvent item) = do feeds <- getStateS $ watchedFeeds . settings let label = itemFeedLabel item case M.lookup label feeds of@@ -158,3 +164,5 @@ Nothing -> liftIO $ do putStrLn $ "Ext handler: Feed item with unknown label: " ++ label print item+handler (PasteEvent paste) =+ sendToChannel (pasteChannel paste) $ formatPaste paste
src/FunBot/IrcHandlers.hs view
@@ -13,19 +13,31 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} +-- For byte strings+{-# LANGUAGE OverloadedStrings #-}+ module FunBot.IrcHandlers ( handleBotMsg , handleJoin- --, handlePart- --, handleQuit- --, handleNames+ , handleMsg+ , handleNickChange ) where +import Control.Exception (catch)+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO) import Data.Char (toLower)-import FunBot.Memos (reportMemos)+import Data.List (isPrefixOf)+import FunBot.Memos (reportMemos, reportMemosAll)+import Network.HTTP.Client+import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.IRC.Fun.Bot.Chat (sendToChannel)+import Text.HTML.TagSoup +import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.UTF8 as BU+ helloWords :: [String] helloWords = ["hello", "hi", "hey", "yo"] @@ -49,10 +61,39 @@ | msg `elem` waveWordsR = sendToChannel chan $ nick ++ ": \\o" | otherwise = return () -handleJoin _chan nick = reportMemos nick+handleJoin chan nick = reportMemos nick chan ---handlePart chan nick _why = removeMemberOnce chan nick+goodHost h =+ let n = B.length h+ suffix6 = B.drop (n - 6) h+ suffix4 = B.drop 2 suffix6+ isCo = B.length suffix6 == 6 && ".co." `B.isPrefixOf` suffix6+ isCom = suffix4 == ".com"+ in not $ isCom || isCo ---handleQuit nick _why = removeMember nick+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 ---handleNames chan _priv pnicks = addChannel chan $ map snd pnicks+handleMsg chan _nick msg _mention = when ("http" `isPrefixOf` msg) $ do+ manager <- liftIO $ newManager tlsManagerSettings+ let action = do+ request <- parseUrl msg+ let h = host request+ if goodHost h+ then do+ response <- httpLbs request manager+ let page = BU.toString $ responseBody response+ return $ Right $ findTitle page+ else return $ Right Nothing+ handler e = return $ Left (e :: HttpException)+ getTitle = action `catch` handler+ etitle <- liftIO getTitle+ case etitle of+ Right (Just title) -> sendToChannel chan $ '"' : title ++ "\""+ _ -> return ()++handleNickChange _old new = reportMemosAll new
src/FunBot/Memos.hs view
@@ -19,9 +19,9 @@ module FunBot.Memos ( submitMemo , reportMemos+ , reportMemosAll , loadBotMemos , mkSaveBotMemos- --, saveBotMemos ) where @@ -30,14 +30,18 @@ import Control.Monad.IO.Class (liftIO) import Data.Aeson hiding (encode) import qualified Data.HashMap.Lazy as M+import Data.JsonState+import Data.List (partition)+import Data.Maybe (isJust) import Data.Monoid ((<>))-import Data.Settings.Persist import Data.Time.Units (Second)+import FunBot.Config (stateSaveInterval, configuration, memosFilename) import FunBot.Types import FunBot.Util ((!?)) import Network.IRC.Fun.Bot.Chat (sendToChannel, sendToUser) import Network.IRC.Fun.Bot.Nicks (isInChannel, presence) import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Bot.Types (Config (stateRepo)) import Network.IRC.Fun.Color import Text.Printf (printf) @@ -72,6 +76,14 @@ newList = oldList ++ [memo] putMemos $ M.insert recip newList ms +-- | 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 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 ()@@ -206,10 +218,13 @@ 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 sender source recip content = do- let instantToChan =+submitMemo sender source recip private content = do+ let send = if private then Nothing else source+ instantToChan = case source of Just chan -> do isin <- recip `isInChannel` chan@@ -227,7 +242,7 @@ return True else return False keepForLater = do- addMemo sender source Nothing recip content+ addMemo sender source send recip content saveBotMemos confirm sender source recip succ1 <- instantToChan@@ -235,18 +250,45 @@ succ2 <- instantToUser unless succ2 keepForLater +-- Send user memos. For a specific joined channels, or for all channels.+reportMemos' :: String -- ^ User nickname+ -> Maybe String -- ^ The channel the user joined+ -> BotSession ()+reportMemos' recip mchan = do+ ms <- getUserMemos recip+ let (msChan, msPriv) = partition (isJust . memoSendIn) ms+ (msChanSend, msChanOther) <- case mchan of+ Just chan ->+ let isThis Nothing = False+ isThis (Just channel) = channel == chan+ in return $ partition (isThis . memoSendIn) msChan+ Nothing -> do+ chans <- presence recip+ let isThese Nothing = False+ isThese (Just channel) = channel `elem` chans+ return $ partition (isThese . memoSendIn) msChan+ unless (null msPriv) $ do+ let n = length msPriv+ sendToUser recip $ "Hello! You have " ++ show n ++ " private memos:"+ sendMemoList recip 1 msPriv+ sendMemoList recip 1 msChanSend+ unless (null msPriv && null msChanSend) $ do+ setUserMemos recip msChanOther+ saveBotMemos+ -- | 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 recip = do- ms <- getUserMemos recip- unless (null ms) $ do- sendToUser recip $ "You have " ++ show (length ms) ++ " memos:"- sendMemoList recip 1 ms- deleteUserMemos recip- saveBotMemos+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 recip = reportMemos' recip Nothing+ ------------------------------------------------------------------------------- -- Persistence -------------------------------------------------------------------------------@@ -272,20 +314,21 @@ --, "read" .= rd ] -memosFilename = "state/memos.json"--saveInterval = 3 :: Second- loadBotMemos :: IO (M.HashMap String [Memo]) loadBotMemos = do- r <- loadSettings memosFilename+ r <- loadState $ stateFilePath memosFilename (stateRepo configuration) case r of Left (False, e) -> error $ "Failed to read memos file: " ++ e Left (True, e) -> error $ "Failed to parse memos file: " ++ e Right s -> return s mkSaveBotMemos :: IO (M.HashMap String [Memo] -> IO ())-mkSaveBotMemos = mkSaveSettings saveInterval memosFilename+mkSaveBotMemos =+ mkSaveStateChoose+ stateSaveInterval+ memosFilename+ (stateRepo configuration)+ "auto commit by funbot" saveBotMemos :: BotSession () saveBotMemos = do
src/FunBot/Settings.hs view
@@ -23,35 +23,38 @@ ( respondGet' , respondSet' , respondReset'+ , respondSettingsHelp , initTree- --, addChanLogOpt- --, addChanLogVal , loadBotSettings , mkSaveBotSettings ) where -import Control.Applicative ((<$>), (<*>))+import Control.Applicative import Control.Monad (mzero) import Control.Monad.IO.Class (liftIO) import Data.Aeson hiding (encode) import Data.Bool (bool) import Data.Char (toLower) import qualified Data.HashMap.Lazy as M+import Data.JsonState import Data.List (intercalate, intersperse, isSuffixOf)+import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid import Data.Settings.Interface import Data.Settings.Option-import Data.Settings.Route (showRoute)-import Data.Settings.Persist+import Data.Settings.Route import Data.Settings.Section (insert) 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.Nicks import Network.IRC.Fun.Bot.State+import Network.IRC.Fun.Bot.Types (Config (stateRepo)) import Network.IRC.Fun.Color instance MonadSettings BotSession Settings where@@ -93,6 +96,31 @@ 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 <$>@@ -121,15 +149,33 @@ , "fields" .= fields ] +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 Settings where parseJSON (Object o) = Settings <$>+ o .: "repos" <*> o .: "feeds" parseJSON _ = mzero instance ToJSON Settings where- toJSON (Settings feeds) = object- [ "feeds" .= feeds+ toJSON (Settings repos feeds) = object+ [ "repos" .= repos+ , "feeds" .= feeds ] -- An option whose value is held by funbot's 'Settings' and saved into its@@ -159,12 +205,114 @@ reset = setTo defval cb = const saveBotState -{-chanLogOpt chan =- mkOptionF- (M.lookupDefault False chan . chanLogging)- (\ b s -> s { chanLogging = M.insert chan b $ chanLogging s })- False-}+-- 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 = gitAnnChans s+ oldspecs = getSpecs s+ oldspec = getSpec s+ spec = oldspec { pAnnChannel = chan }+ specs =+ fromMaybe oldspecs $ replaceMaybe oldspecs pos spec+ in s { gitAnnChans = M.insert (repo, owner) specs chans }+ )+ defChan+ )+ , ( "branches"+ , mkOptionF+ getBranches+ (\ branches s ->+ let chans = gitAnnChans 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 { gitAnnChans = M.insert (repo, owner) specs chans }+ )+ defBranches+ )+ , ( "accept"+ , mkOptionF+ getAccept+ (\ b s ->+ let chans = gitAnnChans 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 { gitAnnChans = M.insert (repo, owner) specs chans }+ )+ defAccept+ )+ , ( "all-commits"+ , mkOptionF+ getAll+ (\ b s ->+ let chans = gitAnnChans s+ oldspecs = getSpecs s+ oldspec = getSpec s+ spec = oldspec { pAnnAllCommits = b }+ specs =+ fromMaybe oldspecs $ replaceMaybe oldspecs pos spec+ in s { gitAnnChans = M.insert (repo, owner) specs chans }+ )+ 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) . gitAnnChans+ 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@@ -275,6 +423,13 @@ , secSubs = mapKey chanSec cstates } )+ , ( "repos"+ , Section+ { secOpts = M.empty+ , secSubs = M.fromList $ map repoSec $ M.toList $+ gitAnnChans sets+ }+ ) , ( "feeds" , Section { secOpts = M.empty@@ -285,12 +440,6 @@ } modifyState $ \ s -> s { stree = tree } -{-addChanLogOpt :: String -> SettingsTree -> SettingsTree-addChanLogOpt chan = insert ["chanlog", chan] $ chanLogOpt chan--addChanLogVal :: String -> Bool -> Settings -> Settings-addChanLogVal chan b s = s { chanLogging = M.insert chan b $ chanLogging s }-}- showError :: SettingsError -> String showError (InvalidPath s) = s ++ " : Invalid path" showError (NoSuchNode r) = showRoute r ++ " : No such option/section"@@ -316,33 +465,40 @@ (True, False) -> pathF <> " : " <> optsF (True, True) -> pathF <> " : Empty section" -respondGet' :: String -> String -> BotSession ()-respondGet' opt chan- | opt == "*" = respSec ""- | ".*" `isSuffixOf` opt = respSec $ take (length opt - 2) opt- | otherwise = respAny opt+-- 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- sendToChannel chan $ case result of+ 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- sendToChannel chan $ case result of+ send $ case result of Left err -> showError err Right (subs, opts) -> showSec path subs opts showSet :: String -> String -> String showSet opt val = opt ++ " ← " ++ val -respondSet' :: String -> String -> String -> BotSession ()-respondSet' opt val chan = do+respondSet' :: String -> String -> (String -> BotSession ()) -> BotSession ()+respondSet' opt val send = do merr <- updateOption opt val case merr of- Just err -> sendToChannel chan (showError err)- Nothing -> sendToChannel chan (showSet opt val)+ Just err -> send $ showError err+ Nothing -> send $ showSet opt val showReset :: String -> String -> String showReset opt val = opt ++ " ↩ " ++ val@@ -350,31 +506,108 @@ showResetStrange :: String -> String showResetStrange opt = opt ++ " : got reset, but I can't find it now" -respondReset' :: String -> String -> BotSession ()-respondReset' opt chan = do+respondReset' :: String -> (String -> BotSession ()) -> BotSession ()+respondReset' opt send = do merr <- resetOption opt case merr of- Just err -> sendToChannel chan $ showError err+ Just err -> send $ showError err Nothing -> do me <- queryOption opt- sendToChannel chan $ case me of+ send $ case me of Left _ -> showResetStrange opt Right val -> showReset opt val -settingsFilename = "state/settings.json"+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."+ ["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", _, "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."+ _ -> "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 <- loadSettings settingsFilename+ r <- loadState $ stateFilePath settingsFilename (stateRepo 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 = mkSaveSettings saveInterval settingsFilename+mkSaveBotSettings =+ mkSaveStateChoose+ stateSaveInterval+ settingsFilename+ (stateRepo configuration)+ "auto commit by funbot" saveBotSettings :: BotSession () saveBotSettings = do
src/FunBot/Sources/FeedWatcher.hs view
@@ -18,15 +18,18 @@ ) where +import Data.Maybe (fromMaybe)+import Data.Time.Units+import FunBot.Config (feedVisitInterval)+import FunBot.ExtEvents (ExtEvent (NewsEvent), NewsItem (..))+import FunBot.Types+import Network.IRC.Fun.Bot.Logger+import Text.Feed.Query+import Web.Feed.Collect (run)+ import qualified Data.HashMap.Lazy as M-import Data.Maybe (fromMaybe)-import Data.Time.Units-import FunBot.Types-import Network.IRC.Fun.Bot.Logger-import Text.Feed.Query-import Web.Feed.Collect (run) -makeItem label ftitle item = NewsItem $ FeedItem+makeItem label ftitle item = NewsEvent $ NewsItem { itemFeedLabel = label , itemFeedTitle = Just ftitle , itemTitle = fromMaybe "(no title)" $ getItemTitle item@@ -53,6 +56,6 @@ Nothing (logError logger) Nothing- (1 :: Minute)+ feedVisitInterval 3 (feeds state)
src/FunBot/Sources/WebListener.hs view
@@ -18,14 +18,14 @@ ) where -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.Listen (run)-import Network.IRC.Fun.Bot.State (askEnvS)-import Network.URI (uriPath)+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.Listen (run)+import Network.IRC.Fun.Bot.State (askEnvS)+import Network.URI (uriPath) listener push pushMany request = do case (uriPath $ rqURI request, rqMethod request) of
src/FunBot/Sources/WebListener/Client.hs view
@@ -13,155 +13,17 @@ - <http://creativecommons.org/publicdomain/zero/1.0/>. -} -{-# LANGUAGE OverloadedStrings #-}- module FunBot.Sources.WebListener.Client ( dispatchClient ) where -import Control.Applicative-import Control.Monad (mzero)-import Data.Aeson-import Data.Aeson.Types (Parser)-import qualified Data.ByteString.Lazy as B-import qualified Data.Text as T-import FunBot.Types-import Network.HTTP (Request (..))--instance FromJSON Branch where- parseJSON (Object o) =- Branch <$>- o .: "name" <*>- o .: "repo" <*>- o .: "user"- parseJSON _ = mzero--instance ToJSON Branch where- toJSON (Branch name repo owner) = object- [ "name" .= name- , "repo" .= repo- , "user" .= owner- ]--instance FromJSON Commit where- parseJSON (Object o) =- Commit <$>- o .: "author" <*>- o .: "title" <*>- o .: "url"- parseJSON _ = mzero--instance ToJSON Commit where- toJSON (Commit author title url) = object- [ "author" .= author- , "title" .= title- , "url" .= url- ]--instance FromJSON Push where- parseJSON (Object o) =- Push <$>- o .: "branch" <*>- o .: "commits"- parseJSON _ = mzero--instance ToJSON Push where- toJSON (Push branch commits) = object- [ "branch" .= branch- , "commits" .= commits- ]--instance FromJSON Tag where- parseJSON (Object o) =- Tag <$>- o .: "author" <*>- o .: "ref" <*>- o .: "repo" <*>- o .: "user"- parseJSON _ = mzero--instance ToJSON Tag where- toJSON tag = object- [ "author" .= tagAuthor tag- , "ref" .= tagRef tag- , "repo" .= tagRepo tag- , "user" .= tagRepoOwner tag- ]--instance FromJSON MR where- parseJSON (Object o) =- MR <$>- o .: "author" <*>- o .: "id" <*>- o .: "repo" <*>- o .: "user" <*>- o .: "title" <*>- o .: "url" <*>- o .: "action"- parseJSON _ = mzero--instance ToJSON MR where- toJSON mr = object- [ "author" .= mrAuthor mr- , "id" .= mrId mr- , "repo" .= mrRepo mr- , "user" .= mrRepoOwner mr- , "title" .= mrTitle mr- , "url" .= mrUrl mr- , "action" .= mrAction mr- ]--instance FromJSON FeedItem where- parseJSON (Object o) =- FeedItem <$>- o .: "feed-label" <*>- o .: "feed-title" <*>- o .: "title" <*>- o .: "author" <*>- o .: "url"- parseJSON _ = mzero--instance ToJSON FeedItem where- toJSON (FeedItem fLabel fTitle title author url) = object- [ "feed-label" .= fLabel- , "feed-title" .= fTitle- , "title" .= title- , "author" .= author- , "url" .= url- ]--text :: Parser T.Text -> T.Text -> Parser T.Text-text parser expected = do- got <- parser- if got == expected- then return got- else mzero--instance FromJSON ExtEvent where- parseJSON (Object o) =- let kind = text $ o .: "type"- in kind "push" *> (GitPush <$> o .: "data") <|>- kind "tag" *> (GitTag <$> o .: "data") <|>- kind "mr" *> (MergeRequest <$> o .: "data") <|>- kind "news" *> (NewsItem <$> o .: "data")- parseJSON _ = mzero--instance ToJSON ExtEvent where- toJSON (GitPush commits) = object [ "type" .= ("push" :: T.Text)- , "data" .= commits- ]- toJSON (GitTag tag) = object [ "type" .= ("tag" :: T.Text)- , "data" .= tag- ]- toJSON (MergeRequest mr) = object [ "type" .= ("mr" :: T.Text)- , "data" .= mr- ]- toJSON (NewsItem item) = object [ "type" .= ("news" :: T.Text)- , "data" .= item- ]+import Data.Aeson (eitherDecode)+import Data.ByteString.Lazy (ByteString)+import FunBot.ExtEvents (ExtEvent)+import Network.HTTP (Request (..)) -parse :: B.ByteString -> Either String ExtEvent+parse :: ByteString -> Either String ExtEvent parse = eitherDecode dispatchClient push _pushMany request =
src/FunBot/Sources/WebListener/GitLab.hs view
@@ -20,12 +20,15 @@ ) where +import Control.Monad (when)+import Data.Maybe (fromMaybe)+import FunBot.ExtEvents+import Network.HTTP (Request (..))+import Network.URI++import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as BC-import Data.Maybe (fromMaybe) import qualified Data.Text as T-import FunBot.Types-import Network.HTTP (Request (..))-import Network.URI import qualified Web.Hook.GitLab as G refToBranch :: T.Text -> T.Text@@ -58,7 +61,7 @@ ref' = T.unpack $ refToTag ref repo' = T.unpack $ G.repoName repo owner = urlToOwner $ T.unpack $ G.repoHomepage repo- in GitTag $ Tag user' ref' repo' owner+ in GitTagEvent $ Tag user' ref' repo' owner makeMR mre = let mr = G.mreRequest mre@@ -69,17 +72,19 @@ 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 MergeRequest $ MR author iid repo owner title url action+ in MergeRequestEvent $ MergeRequest author iid repo owner title url action dispatchPush push _pushMany p = let commits = map makeCommit $ G.pushCommits p branch = makeBranch (G.pushRef p) (G.pushRepository p)- in push $ GitPush $ Push branch commits+ in push $ GitPushEvent $ Push branch commits dispatchTag push pushMany p = push $ makeTag (G.pushRef p) (G.pushRepository p) (G.pushUserName p) -dispatchMR push pushMany e = push $ makeMR e+dispatchMR push pushMany e = do+ let mre@(MergeRequestEvent mr) = makeMR e+ when (mrAction mr /= "update") $ push mre dispatchGitLab push pushMany request = case G.parse $ rqBody request of
src/FunBot/Sources/WebListener/Gogs.hs view
@@ -20,10 +20,11 @@ ) where -import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe)+import FunBot.ExtEvents+import Network.HTTP (Request (..))+ import qualified Data.Text as T-import FunBot.Types-import Network.HTTP (Request (..)) import qualified Web.Hook.Gogs as G refToBranch :: T.Text -> T.Text@@ -46,7 +47,7 @@ fromGogs push = let commits = map makeCommit $ G.pushCommits push branch = makeBranch (G.pushRef push) (G.pushRepository push)- in GitPush $ Push branch (reverse commits)+ in GitPushEvent $ Push branch (reverse commits) dispatchGogs push _pushMany request = case G.parse $ rqBody request of
src/FunBot/Types.hs view
@@ -25,25 +25,20 @@ , SettingsTree , Memo (..) , BotState (..)- , Branch (..)- , Commit (..)- , Push (..)- , Tag (..)- , MR (..)- , FeedItem (..)- , ExtEvent (..) , BotSession , ExtEventSource , ExtEventHandler ) where -import qualified Data.HashMap.Lazy as M-import qualified Data.HashSet as S import Data.Settings.Types (Section (..), Option (..)) import Data.Time.Clock (UTCTime)+import FunBot.ExtEvents (ExtEvent) import Network.IRC.Fun.Bot.Types (Session, EventSource, EventHandler) +import qualified Data.HashMap.Lazy as M+import qualified Data.HashSet as S+ -- | Generic item filter data Filter a = Accept [a] | Reject [a] @@ -80,8 +75,6 @@ data BotEnv = BotEnv { -- | Port on which the web hook event source will run webHookSourcePort :: Int- -- | Maps a Git repo name+owner to annoucement details- , gitAnnChans :: M.HashMap (String, String) [PushAnnSpec] -- | An 'IO' action which schedules saving settings to disk. There is a -- wrapper in the 'Session' monad which uses this with the settings -- stored in bot state, so you probably don't need this field directly.@@ -96,7 +89,9 @@ -- | User-modifiable bot behavior settings data Settings = Settings- { -- | Maps a feed label to its URL and announcement details+ { -- | Maps a Git repo name+owner to annoucement details+ gitAnnChans :: M.HashMap (String, String) [PushAnnSpec]+ , -- | Maps a feed label to its URL and announcement details watchedFeeds :: M.HashMap String (String, NewsAnnSpec) } @@ -113,7 +108,6 @@ , memoRecvIn :: Maybe String , memoSendIn :: Maybe String , memoContent :: String- --, memoRead :: Bool } -- | Read-write custom bot state@@ -125,62 +119,6 @@ -- | Memos waiting for users to connect. , memos :: M.HashMap String [Memo] }--data Branch = Branch- { branchName :: String- , branchRepo :: String- , branchRepoOwner :: String- }- deriving Show--data Commit = Commit- { commitAuthor :: String- , commitTitle :: String- , commitUrl :: String- }- deriving Show--data Push = Push- { pushBranch :: Branch- , pushCommits :: [Commit]- }- deriving Show--data Tag = Tag- { tagAuthor :: String- , tagRef :: String- , tagRepo :: String- , tagRepoOwner :: String- }- deriving Show--data MR = MR- { mrAuthor :: String- , mrId :: Int- , mrRepo :: String- , mrRepoOwner :: String- , mrTitle :: String- , mrUrl :: String- , mrAction :: String- }- deriving Show--data FeedItem = FeedItem- { itemFeedLabel :: String- , itemFeedTitle :: Maybe String- , itemTitle :: String- , itemAuthor :: Maybe String- , itemUrl :: Maybe String- }- deriving Show---- | An event coming from one of the extra event sources.-data ExtEvent- = GitPush Push- | GitTag Tag- | MergeRequest MR- | NewsItem FeedItem- deriving Show -- | Shortcut alias for bot session monad type BotSession = Session BotEnv BotState
src/FunBot/Util.hs view
@@ -15,6 +15,7 @@ module FunBot.Util ( (!?)+ , replaceMaybe , passes , passesBy )@@ -23,11 +24,20 @@ import Data.Maybe (listToMaybe) import FunBot.Types --- List index operator, starting from 0. Like @!!@ but returns a 'Maybe'+-- | List index operator, starting from 0. Like @!!@ but returns a 'Maybe' -- instead of throwing an exception. On success, returns 'Just' the item. On -- out-of-bounds index, returns 'Nothing'. (!?) :: [a] -> Int -> Maybe a l !? i = listToMaybe $ drop i l++-- | 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 -- | Check whether a value passes a given filter. passes :: Eq a => a -> Filter a -> Bool
src/Main.hs view
@@ -34,7 +34,6 @@ -- | Bot environment content env saveS saveM = BotEnv { webHookSourcePort = C.webListenerPort- , gitAnnChans = C.devAnnChans , saveSettings = saveS , saveMemos = saveM , feedErrorLogFile = C.feedErrorLogFile@@ -51,18 +50,18 @@ matchers = [ matchPrefixedCommandC , matchRefCommandFromSetC+ , matchRefCommandFromNamesP ["help", "info", "echo", "tell", "get"] , matchRef , defaultMatch ] -- | Bot behavior definition behavior = defaultBehavior- { handleBotMsg = H.handleBotMsg- , handleJoin = H.handleJoin- --, handlePart = H.handlePart- --, handleQuit = H.handleQuit- , commandSets = [commandSet]- --, handleNames = H.handleNames+ { handleJoin = H.handleJoin+ , handleMsg = H.handleMsg+ , handleBotMsg = H.handleBotMsg+ , commandSets = [commandSet]+ , handleNickChange = H.handleNickChange } -- | Additional events sources