{- This file is part of funbot. - - Written in 2015, 2016 by fr33domlover . - - ♡ 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 - . -} {-# LANGUAGE OverloadedStrings #-} module FunBot.Settings.Sections.Repos ( hostSection , addRepoAnnSpec , deleteRepoAnnSpec , addRepo , deleteRepo ) where import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Sequence (Seq, (|>), (><), ViewL (..)) import Data.Settings.Section import Data.Settings.Types import FunBot.Settings.MkOption import FunBot.Settings.Persist import FunBot.Types import Network.IRC.Fun.Bot.State (modifyState) import Network.IRC.Fun.Types.Base (Channel (..)) import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Lazy as M import qualified Data.Sequence as Q import qualified Data.Text as T specSection :: DevHostLabel -> RepoSpace -> RepoName -> Int -> SettingsTree specSection host space repo pos = Section { secOpts = M.fromList [ ( "channel" , mkopt "set-channel-here" (unChannel . rasChannel) (\ chan spec -> spec { rasChannel = Channel chan }) ) , ( "branches" , mkopt [] (\ spec -> case rasBranches spec of Accept l -> map unBranchName l Reject l -> map unBranchName l ) (\ branches spec -> let bs = case rasBranches spec of Accept _ -> Accept $ map BranchName branches Reject _ -> Reject $ map BranchName branches in spec { rasBranches = bs } ) ) , ( "accept" , mkopt False (\ spec -> case rasBranches spec of Accept _ -> True Reject _ -> False ) (\ b spec -> let ctor = if b then Accept else Reject bs = case rasBranches spec of Accept l -> ctor l Reject l -> ctor l in spec { rasBranches = bs } ) ) , ( "all-commits" , mkopt False rasAllCommits (\ b spec -> spec { rasAllCommits = b }) ) , ( "commits" , mkopt True rasCommits (\ b spec -> spec { rasCommits = b }) ) , ( "issues" , mkopt True rasIssues (\ b spec -> spec { rasIssues = b }) ) , ( "merge-requests" , mkopt True rasMergeRequests (\ b spec -> spec { rasMergeRequests = b }) ) , ( "snippets" , mkopt True rasSnippets (\ b spec -> spec { rasSnippets = b }) ) , ( "notes" , mkopt True rasNotes (\ b spec -> spec { rasNotes = b }) ) , ( "new" , mkopt True rasNew (\ b spec -> spec { rasNew = b }) ) , ( "old" , mkopt True rasOld (\ b spec -> spec { rasOld = b }) ) , ( "untimed" , mkopt True rasUntimed (\ b spec -> spec { rasUntimed = b }) ) ] , secSubs = M.empty } where setSpecField f val sets = fromMaybe sets $ do let hosts = stGitAnnChans sets repos <- M.lookup host hosts specs <- M.lookup (space, repo) repos let specs' = Q.adjust (f val) pos specs repos' = M.insert (space, repo) specs' repos hosts' = M.insert host repos' hosts return sets { stGitAnnChans = hosts' } getSpecField defval f sets = fromMaybe defval $ do let hosts = stGitAnnChans sets repos <- M.lookup host hosts specs <- M.lookup (space, repo) repos spec <- if 0 <= pos && pos < Q.length specs then Just $ Q.index specs pos else Nothing return $ f spec mkopt defval get set = mkOptionF (getSpecField defval get) (setSpecField set) defval repoSection :: DevHostLabel -> RepoSpace -> RepoName -> Seq RepoAnnSpec -> (T.Text, SettingsTree) repoSection h s r specs = ( CI.original (unRepoSpace s) <> "/" <> CI.original (unRepoName r) , Section { secOpts = M.empty , secSubs = M.fromList $ map mksub [1 .. Q.length specs] } ) where mksub i = (T.pack $ show i, specSection h s r (i - 1)) hostSection :: DevHostLabel -> M.HashMap (RepoSpace, RepoName) (Seq RepoAnnSpec) -> SettingsTree hostSection host repos = Section { secOpts = M.empty , secSubs = M.fromList $ map (uncurry f) $ M.toList repos } where f (space, repo) specs = repoSection host space repo specs mkDefSpec :: Channel -> RepoAnnSpec mkDefSpec chan = RepoAnnSpec { rasChannel = chan , rasBranches = Reject [] , rasAllCommits = False , rasCommits = True , rasIssues = True , rasMergeRequests = True , rasSnippets = True , rasNotes = True , rasNew = True , rasOld = True , rasUntimed = True } -- | Append a new repo ann spec to the settings and a matching tree under the -- repo section. Return whether succeeded. addRepoAnnSpec :: DevHostLabel -> RepoSpace -> RepoName -> Channel -> BotSession Bool addRepoAnnSpec host space repo chan = do hosts <- fmap stGitAnnChans getSettings case M.lookup host hosts of Just repos -> case M.lookup (space, repo) repos of Just specs -> do let specs' = specs |> defSpec repos' = M.insert (space, repo) specs' repos hosts' = M.insert host repos' hosts modifySettings $ \ s -> s { stGitAnnChans = hosts' } saveBotSettings let (t, sec) = repoSection host space repo specs' ins = insertSub ["repos", unDevHostLabel host, t] sec modifyState $ \ s -> s { bsSTree = ins $ bsSTree s } return True Nothing -> return False Nothing -> return False where defSpec = mkDefSpec chan -- | 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. deleteRepoAnnSpec :: DevHostLabel -> RepoSpace -> RepoName -> Int -> BotSession (Maybe Bool) deleteRepoAnnSpec host space repo pos = do hosts <- fmap stGitAnnChans getSettings case M.lookup host hosts of Just repos -> case M.lookup (space, repo) repos of Just specs -> let (u, v) = Q.splitAt pos specs in case Q.viewl v of EmptyL -> return $ Just True s :< r -> do let specs' = u >< r repos' = M.insert (space, repo) specs' repos hosts' = M.insert host repos' hosts modifySettings $ \ s -> s { stGitAnnChans = hosts' } saveBotSettings let (t, sec) = repoSection host space repo specs' ins = insertSub ["repos", unDevHostLabel host, t] sec modifyState $ \ s -> s { bsSTree = ins $ bsSTree s } return Nothing Nothing -> return $ Just False Nothing -> return $ Just False -- | Add a new repo to settings and tree. Return 'Nothing' on success. -- Otherwise return whether the host doesn't exist ('False') or the repo -- already exists ('True'). addRepo :: DevHostLabel -> RepoSpace -> RepoName -> Channel -> BotSession (Maybe Bool) addRepo host space repo chan = do hosts <- fmap stGitAnnChans getSettings case M.lookup host hosts of Nothing -> return $ Just False Just repos -> case M.lookup (space, repo) repos of Just _ -> return $ Just True Nothing -> do let specs = Q.singleton defSpec repos' = M.insert (space, repo) specs repos hosts' = M.insert host repos' hosts modifySettings $ \ s -> s { stGitAnnChans = hosts' } saveBotSettings let (t, sec) = repoSection host space repo specs ins = insertSub ["repos", unDevHostLabel host, t] sec modifyState $ \ s -> s { bsSTree = ins $ bsSTree s } return Nothing where defSpec = mkDefSpec chan -- | Remove a repo from settings and tree. Return whether success, i.e. whether -- the repo did exist and indeed has been deleted. deleteRepo :: DevHostLabel -> RepoSpace -> RepoName -> BotSession Bool deleteRepo host space repo = do hosts <- fmap stGitAnnChans getSettings case M.lookup host hosts of Just repos -> if M.member (space, repo) repos then do let repos' = M.delete (space, repo) repos hosts' = M.insert host repos' hosts modifySettings $ \ s -> s { stGitAnnChans = hosts' } saveBotSettings let name = CI.original (unRepoSpace space) <> "/" <> CI.original (unRepoName repo) del = deleteSub ["repos", unDevHostLabel host, name] modifyState $ \ s -> s { bsSTree = del $ bsSTree s } return True else return False Nothing -> return False