module FeedGipeda.Master.CommitQueue
( CommitQueue
, new
, dequeue
, updateRepoBacklog
) where
import Control.Applicative
import Control.Concurrent.Event (Event)
import qualified Control.Concurrent.Event as Event
import Control.Concurrent.MVar
import qualified Control.Logging as Logging
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified FeedGipeda.Gipeda as Gipeda
import FeedGipeda.GitShell (SHA)
import qualified FeedGipeda.Master.File as File
import FeedGipeda.Prelude
import FeedGipeda.Repo (Repo)
import qualified FeedGipeda.Repo as Repo
data CommitQueue
= CommitQueue (MVar State) Event
data Backlog
= Backlog
{ queue :: [SHA]
, set :: Set SHA
, blacklist :: Set SHA
}
data State
= State
{ backlogs :: Map Repo Backlog
, lastRepo :: Maybe Repo
}
new :: IO CommitQueue
new = do
state <- newMVar (State Map.empty Nothing)
stateChangedEvt <- Event.new
return (CommitQueue state stateChangedEvt)
nextCommitView :: State -> Maybe ((Repo, SHA), State)
nextCommitView s = go traversal
where
traversal :: [Map Repo Backlog]
traversal =
maybe [backlogs s] (\repo -> toList (swap (splitLE repo (backlogs s)))) (lastRepo s)
splitLE :: Ord k => k -> Map k v -> (Map k v, Map k v)
splitLE k = readd . Map.splitLookup k
where
readd (le, Nothing, gr) = (le, gr)
readd (le, Just eq, gr) = (Map.insert k eq le, gr)
toList :: (a, a) -> [a]
toList (a, b) = [a, b]
swap :: (a, b) -> (b, a)
swap (a, b) = (b, a)
go :: [Map Repo Backlog] -> Maybe ((Repo, SHA), State)
go [] = Nothing
go (m : ms) =
case Map.minViewWithKey m of
Nothing -> go ms
Just ((repo, Backlog queue set blacklist), m') ->
case filter (not . flip Set.member blacklist) queue of
[] -> go (m' : ms)
commit : _ -> Just ((repo, commit), newState)
where
newState = State
{ lastRepo = Just repo
, backlogs = Map.insert repo newBacklog (backlogs s)
}
newBacklog = Backlog queue set (Set.insert commit blacklist)
dequeue :: CommitQueue -> IO (Repo, SHA)
dequeue cq@(CommitQueue stateVar stateChanged) = do
Event.wait stateChanged
maybePair <- modifyMVar stateVar $ \state ->
case nextCommitView state of
Nothing -> Event.clear stateChanged >> return (state, Nothing)
Just (pair, newState) -> return (newState, Just (pair, newState))
case maybePair of
Nothing -> dequeue cq
Just ((repo, commit), newState) -> do
logInfo (unlines ["Dequeue (" ++ Repo.shortName repo ++ ", " ++ take 7 commit ++ "). New state: ", showState newState])
return (repo, commit)
updateRepoBacklog :: CommitQueue -> Repo -> [SHA] -> IO Bool
updateRepoBacklog (CommitQueue stateVar stateChanged) repo backlog = do
let backlogSet = Set.fromList backlog
s <- backlogSet `seq` modifyMVar stateVar $ \s -> do
let alterBacklog bl =
if null backlog
then Nothing
else Just Backlog
{ queue = backlog
, set = backlogSet
, blacklist = Set.intersection backlogSet (maybe Set.empty blacklist bl)
}
newState = s { backlogs = Map.alter alterBacklog repo (backlogs s) }
Event.set stateChanged
return (newState, newState)
logInfo (unlines ["Updated the commit queue. New state:", showState s])
return (Map.null (backlogs s))
showState :: State -> String
showState (State backlogs lastRepo) =
unlines $
[ "lastRepo: " ++ show (Repo.shortName <$> lastRepo)
, "backlogs: "
] ++ if Map.null backlogs
then ["empty!"]
else Map.foldrWithKey mkEntry [] backlogs
where
mkEntry repo (Backlog queue set bl) rest =
(" "
++ Repo.shortName repo ++ " -- "
++ "next: " ++ (show . safeHead . map (take 7) . filter (not . (`Set.member` bl))) queue
++ queueMsg queue ++ (show . map (take 7) . take 3) queue) : rest
queueMsg queue =
if length queue < 3
then ", queue: "
else ", first 3 in queue (" ++ show (length queue - 3) ++ " more): "
safeHead [] = Nothing
safeHead (x:xs) = Just x