2b97f5381a
tweak-fetch is a new git hook I have developed (not yet accepted into git, but looking bright). Amoung other things, the hook can be used to observe what is being fetched, notice remote git-annex branches that might be updated, and merge them into the git-annex branch. This will solve problems where users do a git pull, immediately followed by a push, and it refuses to push because their git-annex branch is diverged, and they neither ran git annex merge by hand, nor ran other git-annex commands that auto-merge. The tweak-fetch is written by git annex init. Of course, existing repositories won't have it, which is ok, because git-annex still automatically does a merge if changed branches have appeared. Indeed, it will always need to do that check, as long as it needs to support support git-annex branches that might be updated by other means. Eventually though, I will want to ensure all repositories have the tweak-fetch hook. Perhaps a minor verison upgrade to ensure it is added? A subtlety of the hook is that when it's run, the remote tracking refs have not yet been updated. So Annex.Branch.updateTo has to be careful to only use the sha1 that was fetched, not the branch name. The branch name is only used in the commit message. The other tricky thing is that git tweak-fetch hook should *only* output lines in a specific format, and git will be unhappy if it also outputs status messages, etc. So those messages are sent to stderr.
79 lines
2 KiB
Haskell
79 lines
2 KiB
Haskell
{- git tweak-fetch hook support
|
|
-
|
|
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.TweakFetch (runHook, FetchedRef(..)) where
|
|
|
|
import Data.Either (rights)
|
|
import System.Posix.IO
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Sha
|
|
|
|
data FetchedRef = FetchedRef
|
|
{ sha :: Sha
|
|
, merge :: Bool
|
|
, remote :: Ref
|
|
, local :: Ref
|
|
}
|
|
deriving (Show)
|
|
|
|
{- Each line fed to the tweak-fetch hook should represent a ref that is
|
|
- being updated. It's important that the hook always outputs every line
|
|
- that is fed into it (possibly modified), otherwise incoming refs will
|
|
- not be stored. So to avoid breaking if the format changes, unparsable
|
|
- lines are passed through unchanged. -}
|
|
type HookLine = Either String FetchedRef
|
|
|
|
{- Runs the hook, allowing lines to be mutated, but never be discarded.
|
|
- Returns same FetchedRefs that are output by the hook, for further use. -}
|
|
runHook :: (FetchedRef -> IO FetchedRef) -> IO [FetchedRef]
|
|
runHook mutate = do
|
|
ls <- mapM go =<< input
|
|
output ls
|
|
|
|
-- Nothing more should be output to stdout; only hook output
|
|
-- is accepted by git. Redirect stdout to stderr.
|
|
hFlush stdout
|
|
_ <- liftIO $ dupTo stdError stdOutput
|
|
|
|
return $ rights ls
|
|
where
|
|
go u@(Left _) = return u
|
|
go (Right r) = Right <$> catchDefaultIO (mutate r) r
|
|
|
|
input :: IO [HookLine]
|
|
input = map parseLine . lines <$> getContents
|
|
|
|
output :: [HookLine] -> IO ()
|
|
output = mapM_ $ putStrLn . genLine
|
|
|
|
parseLine :: String -> HookLine
|
|
parseLine line = go $ words line
|
|
where
|
|
go [s, m, r, l]
|
|
| not $ isSha s = Left line
|
|
| m == "merge" = parsed True
|
|
| m == "not-for-merge" = parsed False
|
|
| otherwise = Left line
|
|
where
|
|
parsed v = Right $ FetchedRef
|
|
{ sha = Ref s
|
|
, merge = v
|
|
, remote = Ref r
|
|
, local = Ref l
|
|
}
|
|
go _ = Left line
|
|
|
|
genLine :: HookLine -> String
|
|
genLine (Left l) = l
|
|
genLine (Right r) = unwords
|
|
[ show $ sha r
|
|
, if merge r then "merge" else "not-for-merge"
|
|
, show $ remote r
|
|
, show $ local r
|
|
]
|