diff options
| -rw-r--r-- | Annex/AdjustedBranch.hs | 102 | ||||
| -rw-r--r-- | Annex/Link.hs | 3 | ||||
| -rw-r--r-- | CmdLine/GitAnnex.hs | 2 | ||||
| -rw-r--r-- | Command/Adjust.hs | 25 |
4 files changed, 132 insertions, 0 deletions
diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs new file mode 100644 index 000000000..b80ade7c4 --- /dev/null +++ b/Annex/AdjustedBranch.hs @@ -0,0 +1,102 @@ +{- adjusted version of main branch + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.AdjustedBranch where + +import Annex.Common +import qualified Annex +import Git.Types +import qualified Git.Branch +import qualified Git.Ref +import qualified Git.Command +import Git.Tree +import Git.Env +import Annex.CatFile +import Annex.Link +import Git.HashObject + +data Adjustment = UnlockAdjustment + deriving (Show) + +adjustTreeItem :: Adjustment -> HashObjectHandle -> TreeItem -> Annex (Maybe TreeItem) +adjustTreeItem UnlockAdjustment h ti@(TreeItem f m s) + | toBlobType m == Just SymlinkBlob = do + mk <- catKey s + case mk of + Just k -> Just . TreeItem f (fromBlobType FileBlob) + <$> hashPointerFile' h k + Nothing -> return (Just ti) + | otherwise = return (Just ti) + +type OrigBranch = Branch +type AdjBranch = Branch + +adjustedBranchPrefix :: String +adjustedBranchPrefix = "refs/heads/adjusted/" + +originalToAdjusted :: OrigBranch -> AdjBranch +originalToAdjusted orig = Ref $ adjustedBranchPrefix ++ takeFileName (fromRef orig) + +adjustedToOriginal :: AdjBranch -> Maybe (OrigBranch) +adjustedToOriginal b + | adjustedBranchPrefix `isPrefixOf` bs = + Just $ Ref $ drop prefixlen bs + | otherwise = Nothing + where + bs = fromRef b + prefixlen = length adjustedBranchPrefix + +originalBranch :: Annex (Maybe OrigBranch) +originalBranch = fmap getorig <$> inRepo Git.Branch.current + where + getorig currbranch = fromMaybe currbranch (adjustedToOriginal currbranch) + +{- Enter an adjusted version of current branch (or, if already in an + - adjusted version of a branch, changes the adjustment of the original + - branch). + - + - Can fail, if no branch is checked out, or perhaps if staged changes + - conflict with the adjusted branch. + -} +enterAdjustedBranch :: Adjustment -> Annex () +enterAdjustedBranch adj = go =<< originalBranch + where + go (Just origbranch) = do + adjbranch <- adjustBranch adj origbranch + inRepo $ Git.Command.run + [ Param "checkout" + , Param $ fromRef $ Git.Ref.base $ adjbranch + ] + go Nothing = error "not on any branch!" + +adjustBranch :: Adjustment -> OrigBranch -> Annex AdjBranch +adjustBranch adj origbranch = do + h <- inRepo hashObjectStart + treesha <- adjustTree (adjustTreeItem adj h) origbranch =<< Annex.gitRepo + liftIO $ hashObjectStop h + commitsha <- commitAdjustedTree treesha origbranch + inRepo $ Git.Branch.update adjbranch commitsha + return adjbranch + where + adjbranch = originalToAdjusted origbranch + +{- Commits a given adjusted tree, with the provided parent ref. + - + - This should always yield the same value, even if performed in different + - clones of a repo, at different times. The commit message and other + - metadata is based on the parent. + -} +commitAdjustedTree :: Sha -> Ref -> Annex Sha +commitAdjustedTree treesha parent = go =<< catCommit parent + where + go Nothing = inRepo mkcommit + go (Just parentcommit) = inRepo $ commitWithMetaData + (commitAuthorMetaData parentcommit) + (commitCommitterMetaData parentcommit) + mkcommit + mkcommit = Git.Branch.commitTree + Git.Branch.AutomaticCommit "adjusted branch" [parent] treesha diff --git a/Annex/Link.hs b/Annex/Link.hs index 40e56f23e..1f2830c40 100644 --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -123,6 +123,9 @@ hashPointerFile :: Key -> Annex Sha hashPointerFile key = inRepo $ Git.HashObject.hashObject BlobObject $ formatPointer key +hashPointerFile' :: Git.HashObject.HashObjectHandle -> Key -> Annex Sha +hashPointerFile' h = liftIO . Git.HashObject.hashBlob h . formatPointer + {- Stages a pointer file, using a Sha of its content -} stagePointerFile :: FilePath -> Sha -> Annex () stagePointerFile file sha = diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs index 71a69e861..b8c97a30a 100644 --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -38,6 +38,7 @@ import qualified Command.SetPresentKey import qualified Command.ReadPresentKey import qualified Command.CheckPresentKey import qualified Command.ReKey +import qualified Command.Adjust import qualified Command.MetaData import qualified Command.View import qualified Command.VAdd @@ -174,6 +175,7 @@ cmds testoptparser testrunner = , Command.ReadPresentKey.cmd , Command.CheckPresentKey.cmd , Command.ReKey.cmd + , Command.Adjust.cmd , Command.MetaData.cmd , Command.View.cmd , Command.VAdd.cmd diff --git a/Command/Adjust.hs b/Command/Adjust.hs new file mode 100644 index 000000000..b52537a64 --- /dev/null +++ b/Command/Adjust.hs @@ -0,0 +1,25 @@ +{- git-annex command + - + - Copyright 2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Command.Adjust where + +import Command +import Annex.AdjustedBranch + +cmd :: Command +cmd = notBareRepo $ notDirect $ + command "adjust" SectionSetup "adjust branch" + paramNothing (withParams seek) + +seek :: CmdParams -> CommandSeek +seek = withWords start + +start :: [String] -> CommandStart +start [] = do + enterAdjustedBranch UnlockAdjustment + next $ next $ return True +start _ = error "Unknown parameter" |