98 lines
3.4 KiB
Haskell
98 lines
3.4 KiB
Haskell
{- 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.
|
|
-
|
|
- When a remote branch that has had an transition performed on it
|
|
- becomes available for merging into the local git-annex branch,
|
|
- the transition is first performed on the local branch.
|
|
-
|
|
- When merging a remote branch into the local git-annex branch,
|
|
- all transitions that have been performed on the local branch must also
|
|
- have been performed on the remote branch already. (Or it would be
|
|
- possible to perform the transitions on a fixup branch and merge it,
|
|
- but that would be expensive.)
|
|
-
|
|
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Logs.Transitions where
|
|
|
|
import Data.Time.Clock.POSIX
|
|
import Data.Time
|
|
import System.Locale
|
|
import qualified Data.Set as S
|
|
|
|
import Common.Annex
|
|
|
|
transitionsLog :: FilePath
|
|
transitionsLog = "transitions.log"
|
|
|
|
data Transition
|
|
= ForgetGitHistory
|
|
| ForgetDeadRemotes
|
|
deriving (Show, Ord, Eq, Read)
|
|
|
|
data TransitionLine = TransitionLine
|
|
{ transitionStarted :: POSIXTime
|
|
, transition :: Transition
|
|
} deriving (Show, Ord, Eq)
|
|
|
|
type Transitions = S.Set TransitionLine
|
|
|
|
describeTransition :: Transition -> String
|
|
describeTransition ForgetGitHistory = "forget git history"
|
|
describeTransition ForgetDeadRemotes = "forget dead remotes"
|
|
|
|
addTransition :: POSIXTime -> Transition -> Transitions -> Transitions
|
|
addTransition ts t = S.insert $ TransitionLine ts t
|
|
|
|
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 . lines
|
|
where
|
|
check l
|
|
| all isJust l = Just $ S.fromList $ catMaybes l
|
|
| otherwise = Nothing
|
|
|
|
parseTransitionsStrictly :: String -> String -> Transitions
|
|
parseTransitionsStrictly source = fromMaybe badsource . parseTransitions
|
|
where
|
|
badsource = error $ "unknown transitions listed in " ++ source ++ "; upgrade git-annex!"
|
|
|
|
showTransitionLine :: TransitionLine -> String
|
|
showTransitionLine (TransitionLine ts t) = unwords [show t, show ts]
|
|
|
|
parseTransitionLine :: String -> Maybe TransitionLine
|
|
parseTransitionLine s = TransitionLine <$> pdate ds <*> readish ts
|
|
where
|
|
ws = words s
|
|
ts = Prelude.head ws
|
|
ds = unwords $ Prelude.tail ws
|
|
pdate = parseTime defaultTimeLocale "%s%Qs" >=*> utcTimeToPOSIXSeconds
|
|
|
|
combineTransitions :: [Transitions] -> Transitions
|
|
combineTransitions = S.unions
|
|
|
|
inTransitions :: Transition -> Transitions -> Bool
|
|
inTransitions t = not . S.null . S.filter (\l -> transition l == t)
|
|
|
|
transitionList :: Transitions -> [Transition]
|
|
transitionList = map transition . S.elems
|
|
|
|
{- Typically ran with Annex.Branch.change, but we can't import Annex.Branch
|
|
- here since it depends on this module. -}
|
|
recordTransition :: (FilePath -> (String -> String) -> Annex ()) -> Transition -> Annex ()
|
|
recordTransition changer o = do
|
|
t <- liftIO getPOSIXTime
|
|
changer transitionsLog $
|
|
showTransitions . addTransition t o . parseTransitionsStrictly "local"
|