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
    , 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.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.Nicks
import Network.IRC.Fun.Bot.State
import Network.IRC.Fun.Bot.Types (Config (stateRepo))
import Network.IRC.Fun.Color

import qualified Data.HashMap.Lazy as M

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 (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 repos feeds) = object
        [ "repos" .= repos
        , "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

-- 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
        [ ( "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

-- 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
          )
        , ( "log"
          , mkOptionB
                (channelIsLogged chan)
                (bool (stopLoggingChannel chan) (startLoggingChannel chan))
                False
          )
        ]
    , secSubs = M.empty
    }

-- | Build initial settings tree, already inside the session
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
                        }
                  )
                , ( "repos"
                  , Section
                        { secOpts = M.empty
                        , secSubs = M.fromList $ map (uncurry repoSec) $
                                    M.toList $ gitAnnChans sets
                        }
                  )
                , ( "feeds"
                  , Section
                        { secOpts = M.empty
                        , secSubs = mapKey feedSec $ watchedFeeds 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 gitAnnChans 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 { gitAnnChans = 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 gitAnnChans 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 { gitAnnChans = 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 gitAnnChans getSettings
    case M.lookup (repo, owner) repos of
        Just _  -> return False
        Nothing -> do
            let repos' = M.insert (repo, owner) [defSpec] repos
            modifySettings $ \ s -> s { gitAnnChans = 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 gitAnnChans getSettings
    if M.member (repo, owner) repos
        then do
            let repos' = M.delete (repo, owner) repos
            modifySettings $ \ s -> s { gitAnnChans = 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 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 }

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"

-- 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 = 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 = 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."
    ["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 <- 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 =
    mkSaveStateChoose
        stateSaveInterval
        settingsFilename
        (stateRepo configuration)
        "auto commit by funbot"

saveBotSettings :: BotSession ()
saveBotSettings = do
    sets <- getSettings
    save <- askEnvS saveSettings
    liftIO $ save sets