funbot-0.5: src/FunBot/Settings/Sections/Repos.hs
{- This file is part of funbot.
-
- Written in 2015, 2016 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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/>.
-}
{-# 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