funbot-0.4: src/FunBot/Settings.hs
{- This file is part of funbot.
-
- Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- For the 'MonadSettings' instance
{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
-- For JSON field names and irc-fun-color StyledString
{-# LANGUAGE OverloadedStrings #-}
module FunBot.Settings
( respondGet'
, respondSet'
, respondReset'
, respondSettingsHelp
, initTree
, addPushAnnSpec
, deletePushAnnSpec
, addRepo
, deleteRepo
, addChannel
, addShortcut
, deleteShortcut
, addFeed
, deleteFeed
, loadBotSettings
, mkSaveBotSettings
)
where
import Control.Applicative
import Control.Monad (liftM, mzero, unless)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson hiding (encode)
import Data.Bool (bool)
import Data.Char (toLower)
import Data.Default.Class (def)
import Data.JsonState
import Data.List (intercalate, intersperse, isSuffixOf)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid
import Data.Settings.Interface
import Data.Settings.Option
import Data.Settings.Route
import Data.Settings.Section (deleteSub, insertSub, memberSub)
import Data.Settings.Types
import Data.Time.Units (Second)
import FunBot.Config (stateSaveInterval, configuration, settingsFilename)
import FunBot.Types
import FunBot.Util
import Network.IRC.Fun.Bot.Chat
import Network.IRC.Fun.Bot.IrcLog
import Network.IRC.Fun.Bot.MsgCount
import Network.IRC.Fun.Bot.Nicks
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Bot.Types (Config (cfgStateRepo))
import Network.IRC.Fun.Color
import Web.Feed.Collect hiding (addFeed)
import qualified Data.HashMap.Lazy as M
import qualified Web.Feed.Collect as F (addFeed)
instance MonadSettings BotSession Settings where
getSettings = getStateS bsSettings
putSettings s = modifyState $ \ st -> st { bsSettings = s }
modifySettings f =
modifyState $ \ st -> st { bsSettings = f $ bsSettings st }
getSTree = getStateS bsSTree
instance OptionValue Bool where
readOption s
| s' `elem` ["off", "false", "no", "n", "0", "[_]"] = Just False
| s' `elem` ["on", "true", "yes", "y", "1", "[x]"] = Just True
| otherwise = Nothing
where
s' = map toLower s
showOption = show
typeName = const "Boolean"
instance OptionValue String where
readOption = Just
showOption = id
typeName = const "String"
parseList :: String -> Maybe [String]
parseList s =
case break (== ',') s of
("", _) -> Nothing
(p, "") -> Just [p]
(p, (c:cs)) ->
case parseList cs of
Nothing -> Nothing
Just ps -> Just $ p : ps
instance OptionValue [String] where
readOption s = parseList s >>= mapM readOption
showOption = intercalate "," . map showOption
typeName = const "List"
instance FromJSON a => FromJSON (Filter a) where
parseJSON (Object o) =
Accept <$> o .: "accept" <|>
Reject <$> o .: "reject"
parseJSON _ = mzero
instance ToJSON a => ToJSON (Filter a) where
toJSON (Accept l) = object [ "accept" .= l ]
toJSON (Reject l) = object [ "reject" .= l ]
instance FromJSON PushAnnSpec where
parseJSON (Object o) =
PushAnnSpec <$>
o .: "channel" <*>
o .: "branches" <*>
o .: "all-commits"
parseJSON _ = mzero
instance ToJSON PushAnnSpec where
toJSON (PushAnnSpec chan branches allc) = object
[ "channel" .= chan
, "branches" .= branches
, "all-commits" .= allc
]
instance FromJSON NewsItemFields where
parseJSON (Object o) =
NewsItemFields <$>
o .: "show-feed-title" <*>
o .: "show-author" <*>
o .: "show-url"
parseJSON _ = mzero
instance ToJSON NewsItemFields where
toJSON (NewsItemFields ftitle author url) = object
[ "show-feed-title" .= ftitle
, "show-author" .= author
, "show-url" .= url
]
instance FromJSON NewsAnnSpec where
parseJSON (Object o) =
NewsAnnSpec <$>
o .: "channels" <*>
o .: "fields"
parseJSON _ = mzero
instance ToJSON NewsAnnSpec where
toJSON (NewsAnnSpec channels fields) = object
[ "channels" .= channels
, "fields" .= fields
]
instance FromJSON NewsFeed where
parseJSON (Object o) =
NewsFeed <$>
o .: "url" <*>
o .: "active" <*>
o .: "ann-spec"
parseJSON _ = mzero
instance ToJSON NewsFeed where
toJSON (NewsFeed url active spec) = object
[ "url" .= url
, "active" .= active
, "ann-spec" .= spec
]
instance FromJSON (M.HashMap (String, String) [PushAnnSpec]) where
parseJSON v =
let mkpair (s, l) =
case break (== '/') s of
(repo, _:owner) ->
if not (null repo || null owner) && '/' `notElem` owner
then Just ((repo, owner), l)
else Nothing
_ -> Nothing
in M.fromList . catMaybes . map mkpair . M.toList <$> parseJSON v
instance ToJSON (M.HashMap (String, String) [PushAnnSpec]) where
toJSON m =
let unpair ((repo, owner), l) = (repo ++ '/' : owner, l)
in toJSON $ M.fromList $ map unpair $ M.toList m
instance FromJSON Shortcut where
parseJSON (Object o) =
Shortcut <$>
o .: "prefix" <*>
o .: "before" <*>
o .: "after" <*>
o .: "channels"
parseJSON _ = mzero
instance ToJSON Shortcut where
toJSON (Shortcut prefix before after chans) = object
[ "prefix" .= prefix
, "before" .= before
, "after" .= after
, "channels" .= chans
]
instance FromJSON ChanSettings where
parseJSON (Object o) =
ChanSettings <$>
o .: "say-titles" <*>
o .: "welcome" <*>
o .: "folks" <*>
o .: "email"
parseJSON _ = mzero
instance ToJSON ChanSettings where
toJSON (ChanSettings sayTitles welcome folks email) = object
[ "say-titles" .= sayTitles
, "welcome" .= welcome
, "folks" .= folks
, "email" .= email
]
instance FromJSON Settings where
parseJSON (Object o) =
Settings <$>
o .: "repos" <*>
o .: "feeds" <*>
o .: "shortcuts" <*>
o .: "channels"
parseJSON _ = mzero
instance ToJSON Settings where
toJSON (Settings repos feeds shortcuts channels) = object
[ "repos" .= repos
, "feeds" .= feeds
, "shortcuts" .= shortcuts
, "channels" .= channels
]
-- An option whose value is held by funbot's 'Settings' and saved into its
-- settings file
mkOptionF :: OptionValue v
=> (Settings -> v) -- Get
-> (v -> Settings -> Settings) -- Set which never fails
-> v -- Default value for reset
-> SettingsOption
mkOptionF get set defval = mkOptionS get set' reset cb
where
set' v s = Just $ set v s
reset s = (Just defval, set defval s)
cb = const saveBotSettings
-- A variant of 'mkOptionF' which accepts a callback to run after the default
-- one.
mkOptionF' :: OptionValue v
=> (Settings -> v) -- Get
-> (v -> Settings -> Settings) -- Set which never fails
-> v -- Default value for reset
-> (v -> BotSession ()) -- Additional callback
-> SettingsOption
mkOptionF' get set defval cbx = mkOptionS get set' reset cb
where
set' v s = Just $ set v s
reset s = (Just defval, set defval s)
cb v = saveBotSettings >> cbx v
-- An option whose value is held by irc-fun-bot's 'BotState' and saved into its
-- state file
mkOptionB :: OptionValue v
=> BotSession v -- Get
-> (v -> BotSession ()) -- Set which never fails
-> v -- Default value for reset
-> SettingsOption
mkOptionB get set defval = mkOptionV get set' reset
where
setTo val = set val >> cb val
set' val = setTo val >> return True
reset = setTo defval
cb = const saveBotState
-- Create a setting section for a spec, given its position in the spec list and
-- repo/owner as matched by the web listener.
pushAnnSpecSec :: String -> String -> Int -> SettingsTree
pushAnnSpecSec repo owner pos = Section
{ secOpts = M.fromList
[ ( "channel"
, mkOptionF
getChan
(\ chan s ->
let chans = stGitAnnChans s
oldspecs = getSpecs s
oldspec = getSpec s
spec = oldspec { pAnnChannel = chan }
specs =
fromMaybe oldspecs $ replaceMaybe oldspecs pos spec
in s { stGitAnnChans =
M.insert (repo, owner) specs chans
}
)
defChan
)
, ( "branches"
, mkOptionF
getBranches
(\ branches s ->
let chans = stGitAnnChans s
oldspecs = getSpecs s
oldspec = getSpec s
bs = case pAnnBranches oldspec of
Accept _ -> Accept branches
Reject _ -> Reject branches
spec = oldspec { pAnnBranches = bs }
specs =
fromMaybe oldspecs $ replaceMaybe oldspecs pos spec
in s { stGitAnnChans =
M.insert (repo, owner) specs chans
}
)
defBranches
)
, ( "accept"
, mkOptionF
getAccept
(\ b s ->
let chans = stGitAnnChans s
oldspecs = getSpecs s
oldspec = getSpec s
ctor = filt b
bs = case pAnnBranches oldspec of
Accept l -> ctor l
Reject l -> ctor l
spec = oldspec { pAnnBranches = bs }
specs =
fromMaybe oldspecs $ replaceMaybe oldspecs pos spec
in s { stGitAnnChans =
M.insert (repo, owner) specs chans
}
)
defAccept
)
, ( "all-commits"
, mkOptionF
getAll
(\ b s ->
let chans = stGitAnnChans s
oldspecs = getSpecs s
oldspec = getSpec s
spec = oldspec { pAnnAllCommits = b }
specs =
fromMaybe oldspecs $ replaceMaybe oldspecs pos spec
in s { stGitAnnChans =
M.insert (repo, owner) specs chans
}
)
defAll
)
]
, secSubs = M.empty
}
where
defChan = "set-channel-here"
defBranches = []
defAccept = False
filt b = if b then Accept else Reject
defFilter = filt defAccept defBranches
defAll = False
defSpec = PushAnnSpec defChan defFilter defAll
getSpecs = M.lookupDefault [] (repo, owner) . stGitAnnChans
getSpec = fromMaybe defSpec . (!? pos) . getSpecs
getChan = pAnnChannel . getSpec
getFilter = pAnnBranches . getSpec
getBranches = f . getFilter
where
f (Accept l) = l
f (Reject l) = l
getAccept = f . getFilter
where
f (Accept _) = True
f (Reject _) = False
getAll = pAnnAllCommits . getSpec
-- Create a settings section for a git repo, given its name and owner as
-- matched with the details sent to the web listener.
repoSec :: (String, String) -> [PushAnnSpec] -> (String, SettingsTree)
repoSec (repo, owner) specs =
( repo ++ '/' : owner
, Section
{ secOpts = M.empty
, secSubs = M.fromList $ map mksub [1 .. length specs]
}
)
where
mksub i = (show i, pushAnnSpecSec repo owner (i - 1))
-- Create a settings section for a news feed, given its label string
feedSec :: String -> SettingsTree
feedSec label = Section
{ secOpts = M.fromList
[ ( "url"
, mkOptionF'
getUrl
(\ url s ->
let feeds = stWatchedFeeds s
feed = getFeed s
feed' = feed { nfUrl = url }
in s { stWatchedFeeds = M.insert label feed' feeds }
)
defUrl
(\ url -> do
cq <- askEnvS feedCmdQueue
active <- liftM getActive getSettings
liftIO $ do
sendCommand cq $ removeFeed label
sendCommand cq $ F.addFeed def
{ fcLabel = label
, fcUrl = url
, fcActive = active
}
)
)
, ( "active"
, mkOptionF'
getActive
(\ b s ->
let feeds = stWatchedFeeds s
feed = getFeed s
feed' = feed { nfActive = b }
in s { stWatchedFeeds = M.insert label feed' feeds }
)
defActive
(\ b -> do
cq <- askEnvS feedCmdQueue
liftIO $ sendCommand cq $ setFeedActive label b
)
)
, ( "channels"
, mkOptionF
getChans
(\ chans s ->
let feeds = stWatchedFeeds s
feed@NewsFeed { nfAnnSpec = spec } = getFeed s
feed' = feed
{ nfAnnSpec = spec
{ nAnnChannels = chans
}
}
in s { stWatchedFeeds = M.insert label feed' feeds }
)
defChans
)
]
, secSubs = M.fromList
[ ( "show"
, Section
{ secOpts = M.fromList
[ ( "feed-title"
, mkOptionF
(dispFeedTitle . getFields)
(\ b s ->
let feed@NewsFeed { nfAnnSpec = spec } =
getFeed s
fieldsOld = nAnnFields spec
fields = fieldsOld { dispFeedTitle = b }
feed' = feed
{ nfAnnSpec = spec
{ nAnnFields = fields
}
}
in s { stWatchedFeeds =
M.insert label feed' $
stWatchedFeeds s
}
)
(dispFeedTitle defFields)
)
, ( "author"
, mkOptionF
(dispAuthor . getFields)
(\ b s ->
let feed@NewsFeed { nfAnnSpec = spec } =
getFeed s
fieldsOld = nAnnFields spec
fields = fieldsOld { dispAuthor = b }
feed' = feed
{ nfAnnSpec = spec
{ nAnnFields = fields
}
}
in s { stWatchedFeeds =
M.insert label feed' $
stWatchedFeeds s
}
)
(dispAuthor defFields)
)
, ( "url"
, mkOptionF
(dispUrl . getFields)
(\ b s ->
let feed@NewsFeed { nfAnnSpec = spec } =
getFeed s
fieldsOld = nAnnFields spec
fields = fieldsOld { dispUrl = b }
feed' = feed
{ nfAnnSpec = spec
{ nAnnFields = fields
}
}
in s { stWatchedFeeds =
M.insert label feed' $
stWatchedFeeds s
}
)
(dispUrl defFields)
)
]
, secSubs = M.empty
}
)
]
}
where
defChans = []
defFields = NewsItemFields True True True
defSpec = NewsAnnSpec defChans defFields
defUrl = ""
defActive = False
defFeed = NewsFeed defUrl defActive defSpec
getFeed = M.lookupDefault defFeed label . stWatchedFeeds
getUrl = maybe defUrl nfUrl . M.lookup label . stWatchedFeeds
getActive = maybe defActive nfActive . M.lookup label . stWatchedFeeds
getSpec = maybe defSpec nfAnnSpec . M.lookup label . stWatchedFeeds
getChans = nAnnChannels . getSpec
getFields = nAnnFields . getSpec
-- Create a section for a channel
chanSec :: String -> SettingsTree
chanSec chan = Section
{ secOpts = M.fromList
[ ( "track"
, mkOptionB
(channelIsTracked chan)
(bool (stopTrackingChannel chan) (startTrackingChannel chan))
False
)
, ( "count"
, mkOptionB
(chanIsCounted chan)
(bool (stopCountingChan chan) (startCountingChan chan))
False
)
, ( "log"
, mkOptionB
(channelIsLogged chan)
(bool (stopLoggingChannel chan) (startLoggingChannel chan))
False
)
, ( "say-titles"
, mkOptionF
(getf True csSayTitles)
(setf $ \ cs say -> cs { csSayTitles = say })
True
)
, ( "welcome"
, mkOptionF
(getf False csWelcome)
(setf $ \ cs w -> cs { csWelcome = w })
False
)
, ( "folks"
, mkOptionF
(getf [] csFolks)
(setf $ \ cs fs -> cs { csFolks = fs })
[]
)
, ( "email"
, mkOptionF
(getf "(?)" csEmail)
(setf $ \ cs s -> cs { csEmail = s })
"(?)"
)
]
, secSubs = M.empty
}
where
defChan = ChanSettings True False [] "(?)"
getf e f = maybe e f . M.lookup chan . stChannels
setf f v s =
let chans = stChannels s
cs = M.lookupDefault defChan chan chans
cs' = f cs v
chans' = M.insert chan cs' chans
in s { stChannels = chans' }
-- Create a settings section for a shortcut, given its label string
shortcutSec :: String -> SettingsTree
shortcutSec label = Section
{ secOpts = M.fromList
[ ( "prefix"
, mkOptionF
(getf shPrefix)
(setf $ \ cut prefix -> cut { shPrefix = prefix })
""
)
, ( "before"
, mkOptionF
(getf shBefore)
(setf $ \ cut before -> cut { shBefore = before })
""
)
, ( "after"
, mkOptionF
(getf shAfter)
(setf $ \ cut after -> cut { shAfter = after })
""
)
, ( "channels"
, mkOptionF
(getl shChannels)
(setf $ \ cut chans -> cut { shChannels = chans })
[]
)
]
, secSubs = M.empty
}
where
err = "ERROR not found"
getf f = maybe err f . M.lookup label . stShortcuts
getl f = maybe [] f . M.lookup label . stShortcuts
setf f v s =
let cuts = stShortcuts s
in case M.lookup label cuts of
Nothing -> s
Just cut ->
let cut' = f cut v
cuts' = M.insert label cut' cuts
in s { stShortcuts = cuts' }
-- | Build initial settings tree, already inside the session
initTree :: BotSession ()
initTree = do
cstates <- getChanInfo
sets <- getSettings
let mapKey f = M.mapWithKey $ \ key _val -> f key
tree = Section
{ secOpts = M.empty
, secSubs = M.fromList
[ ( "channels"
, Section
{ secOpts = M.empty
, secSubs = mapKey chanSec cstates
}
)
, ( "repos"
, Section
{ secOpts = M.empty
, secSubs = M.fromList $ map (uncurry repoSec) $
M.toList $ stGitAnnChans sets
}
)
, ( "feeds"
, Section
{ secOpts = M.empty
, secSubs = mapKey feedSec $ stWatchedFeeds sets
}
)
, ( "shortcuts"
, Section
{ secOpts = M.empty
, secSubs = mapKey shortcutSec $ stShortcuts sets
}
)
]
}
modifyState $ \ s -> s { bsSTree = tree }
-- | Append a new push ann spec to the settings and a matching tree under the
-- repo section. Return whether succeeded.
addPushAnnSpec :: String -> String -> String -> BotSession Bool
addPushAnnSpec repo owner chan = do
repos <- liftM stGitAnnChans getSettings
case M.lookup (repo, owner) repos of
Just specs -> do
let specs' = specs ++ [defSpec]
repos' = M.insert (repo, owner) specs' repos
modifySettings $ \ s -> s { stGitAnnChans = repos' }
saveBotSettings
let (name, sec) = repoSec (repo, owner) specs'
ins = insertSub ["repos", name] sec
modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }
return True
Nothing -> return False
where
defSpec = PushAnnSpec chan (Reject []) False
-- | Remove a spec from a repo. Return 'Nothing' on success. Otherwise return
-- whether the error was repo not found ('False') or index too big ('True').
-- The position given is 0-based.
deletePushAnnSpec :: String -> String -> Int -> BotSession (Maybe Bool)
deletePushAnnSpec repo owner pos = do
repos <- liftM stGitAnnChans getSettings
case M.lookup (repo, owner) repos of
Just specs ->
case splitAt pos specs of
(l, []) -> return $ Just True
(l, s:r) -> do
let specs' = l ++ r
repos' = M.insert (repo, owner) specs' repos
modifySettings $ \ s -> s { stGitAnnChans = repos' }
saveBotSettings
let (name, sec) = repoSec (repo, owner) specs'
ins = insertSub ["repos", name] sec
modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }
return Nothing
Nothing -> return $ Just False
-- | Add a new repo to settings and tree. Return whether success, i.e. whether
-- the repo didn't exist and indeed a new one has been created.
addRepo :: String -> String -> String -> BotSession Bool
addRepo repo owner chan = do
repos <- liftM stGitAnnChans getSettings
case M.lookup (repo, owner) repos of
Just _ -> return False
Nothing -> do
let repos' = M.insert (repo, owner) [defSpec] repos
modifySettings $ \ s -> s { stGitAnnChans = repos' }
saveBotSettings
let (name, sec) = repoSec (repo, owner) [defSpec]
ins = insertSub ["repos", name] sec
modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }
return True
where
defSpec = PushAnnSpec chan (Reject []) False
-- | Remove a repo from settings and tree. Return whether success, i.e. whether
-- the repo did exist and indeed has been deleted.
deleteRepo :: String -> String -> BotSession Bool
deleteRepo repo owner = do
repos <- liftM stGitAnnChans getSettings
if M.member (repo, owner) repos
then do
let repos' = M.delete (repo, owner) repos
modifySettings $ \ s -> s { stGitAnnChans = repos' }
saveBotSettings
let name = repo ++ '/' : owner
del = deleteSub ["repos", name]
modifyState $ \ s -> s { bsSTree = del $ bsSTree s }
return True
else return False
-- | Add a new shortcut to settings and tree. Return whether success, i.e.
-- whether the shortcut didn't exist and indeed a new one has been created.
addShortcut :: String -> String -> BotSession Bool
addShortcut label chan = do
cuts <- liftM stShortcuts getSettings
case M.lookup label cuts of
Just _ -> return False
Nothing -> do
let cuts' = M.insert label defCut cuts
modifySettings $ \ s -> s { stShortcuts = cuts' }
saveBotSettings
let sec = shortcutSec label
ins = insertSub ["shortcuts", label] sec
modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }
return True
where
defCut = Shortcut "PrEfIx" "http://BeFoRe.org/" "/AfTeR.html" [chan]
-- | Remove a shortcut from settings and tree. Return whether success, i.e.
-- whether the shortcut did exist and indeed has been deleted.
deleteShortcut :: String -> BotSession Bool
deleteShortcut label = do
cuts <- liftM stShortcuts getSettings
if M.member label cuts
then do
let cuts' = M.delete label cuts
modifySettings $ \ s -> s { stShortcuts = cuts' }
saveBotSettings
let del = deleteSub ["shortcuts", label]
modifyState $ \ s -> s { bsSTree = del $ bsSTree s }
return True
else return False
-- | Add a new channel to state and tree and to be joined from now on. If
-- already exists, nothing happens.
addChannel :: String -> BotSession ()
addChannel chan = do
selectChannel chan
addChannelState chan
sets <- getSTree
let route = ["channels", chan]
unless (route `memberSub` sets) $ do
let sec = chanSec chan
ins = insertSub route sec
modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }
-- | Add a new feed to settings and tree. Return whether success, i.e. whether
-- the feed didn't exist and indeed a new one has been created.
addFeed :: String -> String -> BotSession Bool
addFeed label url = do
feeds <- liftM stWatchedFeeds getSettings
case M.lookup label feeds of
Just _ -> return False
Nothing -> do
-- Update and save settings
let feed = NewsFeed
{ nfUrl = url
, nfActive = True
, nfAnnSpec = defSpec
}
feeds' = M.insert label feed feeds
modifySettings $ \ s -> s { stWatchedFeeds = feeds' }
saveBotSettings
-- Update settings UI tree
let sec = feedSec label
ins = insertSub ["feeds", label] sec
modifyState $ \ s -> s { bsSTree = ins $ bsSTree s }
-- Send command to update the feed watcher
cq <- askEnvS feedCmdQueue
liftIO $ sendCommand cq $ F.addFeed $ mkFeed label url
return True
where
defChans = []
defFields = NewsItemFields True True True
defSpec = NewsAnnSpec defChans defFields
-- | Remove a feed from settings and tree. Return whether success, i.e. whether
-- the feed did exist and indeed has been deleted.
deleteFeed :: String -> BotSession Bool
deleteFeed label = do
feeds <- liftM stWatchedFeeds getSettings
if M.member label feeds
then do
-- Update and save settings
let feeds' = M.delete label feeds
modifySettings $ \ s -> s { stWatchedFeeds = feeds' }
saveBotSettings
-- Update settings UI tree
let del = deleteSub ["feeds", label]
modifyState $ \ s -> s { bsSTree = del $ bsSTree s }
-- Send command to update the feed watcher
cq <- askEnvS feedCmdQueue
liftIO $ sendCommand cq $ removeFeed label
return True
else return False
showError :: SettingsError -> String
showError (InvalidPath s) = s ++ " : Invalid path"
showError (NoSuchNode r) = showRoute r ++ " : No such option/section"
showError (NoSuchOption r) = showRoute r ++ " : No such option"
showError (NoSuchSection r) = showRoute r ++ " : No such section"
showError (InvalidValueForType s) = s ++ " : Invalid value for option type"
showError (InvalidValue s) = s ++ " : Invalid value"
showOptLine :: String -> String -> String -> String
showOptLine opt op val =
encode $ Yellow #> Pure opt <> Teal #> Pure op <> Maroon #> Pure val
showGet :: String -> String -> String
showGet opt val = showOptLine opt " = " val
showSec :: String -> [String] -> [String] -> String
showSec path subs opts =
let showSub = Pure . ('‣' :)
showOpt = Pure . ('•' :)
showList = mconcat . intersperse " "
pathF = Yellow #> Pure path
subsF = Green #> (showList $ map showSub subs)
optsF = Purple #> (showList $ map showOpt opts)
in encode $ case (null subs, null opts) of
(False, False) -> pathF <> " : " <> subsF <> " | " <> optsF
(False, True) -> pathF <> " : " <> subsF
(True, False) -> pathF <> " : " <> optsF
(True, True) -> pathF <> " : Empty section"
-- Remove user-friendliness parts and determine whether given string refers to
-- a potential section (otherwise it could also be an potential option).
stripPath :: String -> (String, Bool)
stripPath opt
| opt == "*" = ("", True)
| ".*" `isSuffixOf` opt = (take (length opt - 2) opt, True)
| otherwise = (opt, False)
respondGet' :: String -> (String -> BotSession ()) -> BotSession ()
respondGet' opt send = resp path
where
(path, sec) = stripPath opt
resp = if sec then respSec else respAny
respAny path = do
result <- query path
send $ case result of
Left err -> showError err
Right (Left (subs, opts)) -> showSec path subs opts
Right (Right val) -> showGet path val
respSec path = do
result <- querySection path
send $ case result of
Left err -> showError err
Right (subs, opts) -> showSec path subs opts
showSet :: String -> String -> String
showSet opt val = showOptLine opt " ← " val
respondSet' :: String -> String -> (String -> BotSession ()) -> BotSession ()
respondSet' opt val send = do
merr <- updateOption opt val
case merr of
Just err -> send $ showError err
Nothing -> send $ showSet opt val
showReset :: String -> String -> String
showReset opt val = showOptLine opt " ↩ " val
showResetStrange :: String -> String
showResetStrange opt = opt ++ " : got reset, but I can't find it now"
respondReset' :: String -> (String -> BotSession ()) -> BotSession ()
respondReset' opt send = do
merr <- resetOption opt
case merr of
Just err -> send $ showError err
Nothing -> do
me <- queryOption opt
send $ case me of
Left _ -> showResetStrange opt
Right val -> showReset opt val
help :: OptRoute -> String
help r = case r of
[] -> "Top level of the settings tree."
["channels"] -> "Basic per-channel settings."
["channels", _] -> "Basic settings for the channel."
["channels", _, "log"] ->
"Whether events in the channel are logged by the bot locally into a \
\log file. Currently nothing is done with these logs. In the future \
\they can be used to send people activity they missed (or selected \
\parts of it), generate public logs as web pages and record meetings."
["channels", _, "track"] ->
"Whether user joins and parts in the channel \
\are tracked internally. This is useful for various other features, \
\such as memos (see !tell) and listing these events in channel logs. \
\Tracking isn't enabled by default, to save bot server hardware \
\resources (in particular RAM), especially for cases of many, crowded \
\or busy channels."
["channels", _, "count"] ->
"Whether channel message logs are maintained (in memory) for this \
\channel. If yes, channel history reports (which you can get when you \
\join a channel) will also specify how many messages you missed. For \
\to work, you must also enable the 'track' option."
["channels", _, "say-titles"] ->
"Whether I should detect URLs sent into this channel and send their \
\titles."
["channels", _, "welcome"] ->
"Whether I should send a welcome message when a new nickname unknown \
\to me joins the channel, and the channel is quiet for some time."
["channels", _, "folks"] ->
"List of main people (nicknames) in the channel. This is used in the \
\welcome messages, and possibly other places."
["channels", _, "email"] ->
"Email address (possibly of a mailing list) for async discussions. If \
\you ask a question and nobody responds for a while, you can send \
\your question there. Also good for long, documented discussions and \
\generally the things email is better suited for than IRC."
["repos"] -> "Git repo event announcement details."
["repos", _] ->
"Event announcement details for a Git repo, specified by its name and \
\its \"owner\", (a username or an organization name). The name and \
\owner match the ones used by the dev platform which hosts the repo. \
\Announcment details are given as a set of specifications, one for \
\each IRC channel where you want the events to be announced."
["repos", _, _] ->
"A Git repo event announcement specification for a specific channel. \
\It specifies the channel and defines filters to determine which \
\events should be announced."
["repos", _, _, "branches"] ->
"A list of zero or more git branch names to filter by. If the \
\\"accept\" option is True, this is whitelist of branches whose \
\commits to announce (and the rest won't be announced). Otherwise, \
\it's a blacklist of branches not to announce (and all the rest will \
\be announced). By default the list is empty, and you can reset it to \
\empty using !reset."
["repos", _, _, "channel"] ->
"IRC channel into which to announce the repo events."
["repos", _, _, "all-commits"] ->
"Whether to announce all commits into the channel, or shorten long \
\pushes to avoid filling the channel with very long announcements. \
\For example, if you push 20 commits at once, you may prefer to see \
\just a summary or a partial report, and not have the channel filled \
\with a very long sequence of messages. The default is False, i.e. do \
\shorten long announcements."
["repos", _, _, "accept"] ->
"Whether the branch list specified by the \"branches\" option is a \
\whitelist of branches whose commits to announce (True), or a \
\blacklist of branches not to announce (False). By default it's \
\False, and the branch list is empty, which together mean \"reject no \
\branches\", or in other words announce commits of *all* branches."
["feeds"] -> "News feed item announcement details."
["feeds", _] -> "Details for announcing new feed items for this feed."
["feeds", _, "url"] -> "URL of the feed."
["feeds", _, "active"] -> "Whether the feed is being watched."
["feeds", _, "channels"] ->
"List of IRC channels into which to announce new items from the feed."
["feeds", _, "show"] ->
"Determines which information about the new feed items should be \
\specified in the announcements."
["feeds", _, "show", "author"] ->
"Whether to specify the news item author when announcing the new item."
["feeds", _, "show", "feed-title"] ->
"Whether to specify the feed title when announcing a new item."
["feeds", _, "show", "url"] ->
"Whether to specify the item URL when announcing the new item."
["shortcuts"] -> "List of available shortcuts."
["shortcuts", _] -> "Details of this shortcut."
["shortcuts", _, "prefix"] ->
"A string by which the shortcut is identified. For example, if you'd \
\like “TKT-258” to refer to ticket #258, set the prefix to “TKT-”."
["shortcuts", _, "before"] ->
"In the full form into which the shortcut is expanded, this is the \
\beginning of the string. For example, “http://funbot.org/tickets/”."
["shortcuts", _, "after"] ->
"In the full form into which the shortcut is expanded, this is the \
\end of the string. For example, “.html”."
["shortcuts", _, "channels"] ->
"List of IRC channels in which this shortcut applies."
_ -> "No help for this item."
respondSettingsHelp :: String -> (String -> BotSession ()) -> BotSession Bool
respondSettingsHelp path send =
let p = fst $ stripPath path
in case parseRoute p of
Just r -> do
send $ p ++ " : " ++ help r
return True
Nothing -> return False
saveInterval = 3 :: Second
loadBotSettings :: IO Settings
loadBotSettings = do
r <- loadState $
stateFilePath settingsFilename (cfgStateRepo configuration)
case r of
Left (False, e) -> error $ "Failed to read settings file: " ++ e
Left (True, e) -> error $ "Failed to parse settings file: " ++ e
Right s -> return s
mkSaveBotSettings :: IO (Settings -> IO ())
mkSaveBotSettings =
mkSaveStateChoose
stateSaveInterval
settingsFilename
(cfgStateRepo configuration)
"auto commit by funbot"
saveBotSettings :: BotSession ()
saveBotSettings = do
sets <- getSettings
save <- askEnvS saveSettings
liftIO $ save sets