git-annex/Logs/Transitions.hs

87 lines
2.7 KiB
Haskell
Raw Normal View History

2013-08-28 17:19:02 +00:00
{- git-annex transitions log
-
- This is used to record transitions that have been performed on the
- git-annex branch, and when the transition was first started.
-
- We can quickly detect when the local branch has already had an transition
- done that is listed in the remote branch by checking that the local
- branch contains the same transition, with the same or newer start time.
-
- Copyright 2013 Joey Hess <id@joeyh.name>
2013-08-28 17:19:02 +00:00
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Logs.Transitions where
import Annex.Common
import Annex.VectorClock
import Logs.Line
2013-08-28 17:19:02 +00:00
import qualified Data.Set as S
2013-08-28 17:19:02 +00:00
transitionsLog :: FilePath
transitionsLog = "transitions.log"
data Transition
= ForgetGitHistory
| ForgetDeadRemotes
deriving (Show, Ord, Eq, Read)
data TransitionLine = TransitionLine
{ transitionStarted :: VectorClock
2013-08-28 17:19:02 +00:00
, transition :: Transition
} deriving (Ord, Eq)
2013-08-28 17:19:02 +00:00
type Transitions = S.Set TransitionLine
describeTransition :: Transition -> String
describeTransition ForgetGitHistory = "forget git history"
describeTransition ForgetDeadRemotes = "forget dead remotes"
noTransitions :: Transitions
noTransitions = S.empty
addTransition :: VectorClock -> Transition -> Transitions -> Transitions
addTransition c t = S.insert $ TransitionLine c t
2013-08-28 17:19:02 +00:00
showTransitions :: Transitions -> String
showTransitions = unlines . map showTransitionLine . S.elems
{- If the log contains new transitions we don't support, returns Nothing. -}
parseTransitions :: String -> Maybe Transitions
parseTransitions = check . map parseTransitionLine . splitLines
2013-08-28 17:19:02 +00:00
where
check l
2013-08-28 17:19:02 +00:00
| all isJust l = Just $ S.fromList $ catMaybes l
| otherwise = Nothing
parseTransitionsStrictly :: String -> String -> Transitions
parseTransitionsStrictly source = fromMaybe badsource . parseTransitions
where
badsource = giveup $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!"
2013-08-28 17:19:02 +00:00
showTransitionLine :: TransitionLine -> String
showTransitionLine (TransitionLine c t) = unwords [show t, formatVectorClock c]
2013-08-28 17:19:02 +00:00
parseTransitionLine :: String -> Maybe TransitionLine
parseTransitionLine s = TransitionLine
<$> parseVectorClock cs
<*> readish ts
2013-08-28 17:19:02 +00:00
where
ws = words s
ts = Prelude.head ws
cs = unwords $ Prelude.tail ws
2013-08-28 17:19:02 +00:00
combineTransitions :: [Transitions] -> Transitions
combineTransitions = S.unions
transitionList :: Transitions -> [Transition]
transitionList = nub . map transition . S.elems
2013-08-28 17:19:02 +00:00
{- Typically ran with Annex.Branch.change, but we can't import Annex.Branch
- here since it depends on this module. -}
recordTransitions :: (FilePath -> (String -> String) -> Annex ()) -> Transitions -> Annex ()
2013-09-26 03:19:01 +00:00
recordTransitions changer t = changer transitionsLog $
showTransitions . S.union t . parseTransitionsStrictly "local"