diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -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) diff --git a/funbot.cabal b/funbot.cabal --- a/funbot.cabal +++ b/funbot.cabal @@ -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 diff --git a/src/FunBot/Commands.hs b/src/FunBot/Commands.hs --- a/src/FunBot/Commands.hs +++ b/src/FunBot/Commands.hs @@ -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 []’ - display help for the given command. \ - \Passing no parameters, or passing 2 or more, displays the \ - \general help (i.e. this text)." + , help = "‘help [ | ]’ - 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 \ \." -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 \ \, 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 ." -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 ’ - leave a memo for a user to see later" +cmdPTell = Command + { names = ["tell", "ptell"] + , respond = respondTell True + , help = "‘tell ’ - 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 ’ - 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 diff --git a/src/FunBot/Config.hs b/src/FunBot/Config.hs --- a/src/FunBot/Config.hs +++ b/src/FunBot/Config.hs @@ -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" diff --git a/src/FunBot/ExtHandlers.hs b/src/FunBot/ExtHandlers.hs --- a/src/FunBot/ExtHandlers.hs +++ b/src/FunBot/ExtHandlers.hs @@ -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 diff --git a/src/FunBot/IrcHandlers.hs b/src/FunBot/IrcHandlers.hs --- a/src/FunBot/IrcHandlers.hs +++ b/src/FunBot/IrcHandlers.hs @@ -13,19 +13,31 @@ - . -} +-- 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 diff --git a/src/FunBot/Memos.hs b/src/FunBot/Memos.hs --- a/src/FunBot/Memos.hs +++ b/src/FunBot/Memos.hs @@ -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 diff --git a/src/FunBot/Settings.hs b/src/FunBot/Settings.hs --- a/src/FunBot/Settings.hs +++ b/src/FunBot/Settings.hs @@ -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 diff --git a/src/FunBot/Sources/FeedWatcher.hs b/src/FunBot/Sources/FeedWatcher.hs --- a/src/FunBot/Sources/FeedWatcher.hs +++ b/src/FunBot/Sources/FeedWatcher.hs @@ -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) diff --git a/src/FunBot/Sources/WebListener.hs b/src/FunBot/Sources/WebListener.hs --- a/src/FunBot/Sources/WebListener.hs +++ b/src/FunBot/Sources/WebListener.hs @@ -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 diff --git a/src/FunBot/Sources/WebListener/Client.hs b/src/FunBot/Sources/WebListener/Client.hs --- a/src/FunBot/Sources/WebListener/Client.hs +++ b/src/FunBot/Sources/WebListener/Client.hs @@ -13,155 +13,17 @@ - . -} -{-# 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 = diff --git a/src/FunBot/Sources/WebListener/GitLab.hs b/src/FunBot/Sources/WebListener/GitLab.hs --- a/src/FunBot/Sources/WebListener/GitLab.hs +++ b/src/FunBot/Sources/WebListener/GitLab.hs @@ -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 diff --git a/src/FunBot/Sources/WebListener/Gogs.hs b/src/FunBot/Sources/WebListener/Gogs.hs --- a/src/FunBot/Sources/WebListener/Gogs.hs +++ b/src/FunBot/Sources/WebListener/Gogs.hs @@ -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 diff --git a/src/FunBot/Types.hs b/src/FunBot/Types.hs --- a/src/FunBot/Types.hs +++ b/src/FunBot/Types.hs @@ -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 diff --git a/src/FunBot/Util.hs b/src/FunBot/Util.hs --- a/src/FunBot/Util.hs +++ b/src/FunBot/Util.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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