funbot-0.1.0.0: 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'
, initTree
--, addChanLogOpt
--, addChanLogVal
, loadBotSettings
, mkSaveBotSettings
)
where
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.List (intercalate, intersperse, isSuffixOf)
import Data.Monoid
import Data.Settings.Interface
import Data.Settings.Option
import Data.Settings.Route (showRoute)
import Data.Settings.Persist
import Data.Settings.Section (insert)
import Data.Settings.Types
import Data.Time.Units (Second)
import FunBot.Types
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.Color
instance MonadSettings BotSession Settings where
getSettings = getStateS settings
putSettings s = modifyState $ \ st -> st { settings = s }
modifySettings f = modifyState $ \ st -> st { settings = f $ settings st }
getSTree = getStateS stree
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 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 Settings where
parseJSON (Object o) =
Settings <$>
o .: "feeds"
parseJSON _ = mzero
instance ToJSON Settings where
toJSON (Settings feeds) = object
[ "feeds" .= feeds
]
-- 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
-- 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
{-chanLogOpt chan =
mkOptionF
(M.lookupDefault False chan . chanLogging)
(\ b s -> s { chanLogging = M.insert chan b $ chanLogging s })
False-}
feedSec :: String -> SettingsTree
feedSec label = Section
{ secOpts = M.fromList
[ ( "channels"
, mkOptionF
getChans
(\ chans s ->
let feeds = watchedFeeds s
(url, spec) = getPair s
pair = (url, spec { nAnnChannels = chans })
in s { watchedFeeds = M.insert label pair feeds }
)
defChans
)
]
, secSubs = M.fromList
[ ( "show"
, Section
{ secOpts = M.fromList
[ ( "feed-title"
, mkOptionF
(dispFeedTitle . getFields)
(\ b s ->
let (url, spec) = getPair s
fieldsOld = nAnnFields spec
fields = fieldsOld { dispFeedTitle = b }
pair = (url, spec { nAnnFields = fields })
in s { watchedFeeds = M.insert label pair $
watchedFeeds s }
)
(dispFeedTitle defFields)
)
, ( "author"
, mkOptionF
(dispAuthor . getFields)
(\ b s ->
let (url, spec) = getPair s
fieldsOld = nAnnFields spec
fields = fieldsOld { dispAuthor = b }
pair = (url, spec { nAnnFields = fields })
in s { watchedFeeds = M.insert label pair $
watchedFeeds s }
)
(dispAuthor defFields)
)
, ( "url"
, mkOptionF
(dispUrl . getFields)
(\ b s ->
let (url, spec) = getPair s
fieldsOld = nAnnFields spec
fields = fieldsOld { dispUrl = b }
pair = (url, spec { nAnnFields = fields })
in s { watchedFeeds = M.insert label pair $
watchedFeeds s }
)
(dispUrl defFields)
)
]
, secSubs = M.empty
}
)
]
}
where
defChans = []
defFields = NewsItemFields True True True
defSpec = NewsAnnSpec defChans defFields
defUrl = ""
defPair = (defUrl, defSpec)
getPair = M.lookupDefault defPair label . watchedFeeds
getUrl = maybe defUrl fst . M.lookup label . watchedFeeds
getSpec = maybe defSpec snd . M.lookup label . watchedFeeds
getChans = nAnnChannels . getSpec
getFields = nAnnFields . getSpec
chanSec :: String -> SettingsTree
chanSec chan = Section
{ secOpts = M.fromList
[ ( "track"
, mkOptionB
(channelIsTracked chan)
(bool (stopTrackingChannel chan) (startTrackingChannel chan))
False
)
, ( "log"
, mkOptionB
(channelIsLogged chan)
(bool (stopLoggingChannel chan) (startLoggingChannel chan))
False
)
]
, secSubs = M.empty
}
initTree :: BotSession ()
initTree = do
cstates <- getChannelState
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
}
)
, ( "feeds"
, Section
{ secOpts = M.empty
, secSubs = mapKey feedSec $ watchedFeeds sets
}
)
]
}
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"
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"
showGet :: String -> String -> String
showGet opt val = opt ++ " = " ++ val
showSec :: String -> [String] -> [String] -> String
showSec path subs opts =
let showSub = Pure . ('‣' :)
showOpt = Pure . ('•' :)
showList = mconcat . intersperse " "
pathF = 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"
respondGet' :: String -> String -> BotSession ()
respondGet' opt chan
| opt == "*" = respSec ""
| ".*" `isSuffixOf` opt = respSec $ take (length opt - 2) opt
| otherwise = respAny opt
where
respAny path = do
result <- query path
sendToChannel chan $ 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
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
merr <- updateOption opt val
case merr of
Just err -> sendToChannel chan (showError err)
Nothing -> sendToChannel chan (showSet opt val)
showReset :: String -> String -> String
showReset opt val = opt ++ " ↩ " ++ val
showResetStrange :: String -> String
showResetStrange opt = opt ++ " : got reset, but I can't find it now"
respondReset' :: String -> String -> BotSession ()
respondReset' opt chan = do
merr <- resetOption opt
case merr of
Just err -> sendToChannel chan $ showError err
Nothing -> do
me <- queryOption opt
sendToChannel chan $ case me of
Left _ -> showResetStrange opt
Right val -> showReset opt val
settingsFilename = "state/settings.json"
saveInterval = 3 :: Second
loadBotSettings :: IO Settings
loadBotSettings = do
r <- loadSettings settingsFilename
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
saveBotSettings :: BotSession ()
saveBotSettings = do
sets <- getSettings
save <- askEnvS saveSettings
liftIO $ save sets