Merge branch 'adjustedbranch'
This commit is contained in:
commit
ed3e8e1886
32 changed files with 1084 additions and 262 deletions
2
Annex.hs
2
Annex.hs
|
@ -136,6 +136,7 @@ data AnnexState = AnnexState
|
|||
, workers :: [Either AnnexState (Async AnnexState)]
|
||||
, concurrentjobs :: Maybe Int
|
||||
, keysdbhandle :: Maybe Keys.DbHandle
|
||||
, cachedcurrentbranch :: Maybe Git.Branch
|
||||
}
|
||||
|
||||
newState :: GitConfig -> Git.Repo -> AnnexState
|
||||
|
@ -182,6 +183,7 @@ newState c r = AnnexState
|
|||
, workers = []
|
||||
, concurrentjobs = Nothing
|
||||
, keysdbhandle = Nothing
|
||||
, cachedcurrentbranch = Nothing
|
||||
}
|
||||
|
||||
{- Makes an Annex state object for the specified git repo.
|
||||
|
|
419
Annex/AdjustedBranch.hs
Normal file
419
Annex/AdjustedBranch.hs
Normal file
|
@ -0,0 +1,419 @@
|
|||
{- adjusted branch
|
||||
-
|
||||
- Copyright 2016 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Annex.AdjustedBranch (
|
||||
Adjustment(..),
|
||||
OrigBranch,
|
||||
AdjBranch,
|
||||
originalToAdjusted,
|
||||
adjustedToOriginal,
|
||||
fromAdjustedBranch,
|
||||
getAdjustment,
|
||||
enterAdjustedBranch,
|
||||
adjustToCrippledFileSystem,
|
||||
updateAdjustedBranch,
|
||||
propigateAdjustedCommits,
|
||||
) where
|
||||
|
||||
import Annex.Common
|
||||
import qualified Annex
|
||||
import Git
|
||||
import Git.Types
|
||||
import qualified Git.Branch
|
||||
import qualified Git.Ref
|
||||
import qualified Git.Command
|
||||
import qualified Git.Tree
|
||||
import qualified Git.DiffTree
|
||||
import Git.Tree (TreeItem(..))
|
||||
import Git.Sha
|
||||
import Git.Env
|
||||
import Git.Index
|
||||
import Git.FilePath
|
||||
import qualified Git.LockFile
|
||||
import Annex.CatFile
|
||||
import Annex.Link
|
||||
import Annex.AutoMerge
|
||||
import Annex.Content
|
||||
import qualified Database.Keys
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
data Adjustment
|
||||
= UnlockAdjustment
|
||||
| LockAdjustment
|
||||
| HideMissingAdjustment
|
||||
| ShowMissingAdjustment
|
||||
deriving (Show, Eq)
|
||||
|
||||
reverseAdjustment :: Adjustment -> Adjustment
|
||||
reverseAdjustment UnlockAdjustment = LockAdjustment
|
||||
reverseAdjustment LockAdjustment = UnlockAdjustment
|
||||
reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment
|
||||
reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment
|
||||
|
||||
{- How to perform various adjustments to a TreeItem. -}
|
||||
adjustTreeItem :: Adjustment -> TreeItem -> Annex (Maybe TreeItem)
|
||||
adjustTreeItem UnlockAdjustment ti@(TreeItem f m s)
|
||||
| toBlobType m == Just SymlinkBlob = do
|
||||
mk <- catKey s
|
||||
case mk of
|
||||
Just k -> do
|
||||
Database.Keys.addAssociatedFile k f
|
||||
Just . TreeItem f (fromBlobType FileBlob)
|
||||
<$> hashPointerFile k
|
||||
Nothing -> return (Just ti)
|
||||
| otherwise = return (Just ti)
|
||||
adjustTreeItem LockAdjustment ti@(TreeItem f m s)
|
||||
| toBlobType m /= Just SymlinkBlob = do
|
||||
mk <- catKey s
|
||||
case mk of
|
||||
Just k -> do
|
||||
absf <- inRepo $ \r -> absPath $
|
||||
fromTopFilePath f r
|
||||
linktarget <- calcRepo $ gitAnnexLink absf k
|
||||
Just . TreeItem f (fromBlobType SymlinkBlob)
|
||||
<$> hashSymlink linktarget
|
||||
Nothing -> return (Just ti)
|
||||
| otherwise = return (Just ti)
|
||||
adjustTreeItem HideMissingAdjustment ti@(TreeItem _ _ s) = do
|
||||
mk <- catKey s
|
||||
case mk of
|
||||
Just k -> ifM (inAnnex k)
|
||||
( return (Just ti)
|
||||
, return Nothing
|
||||
)
|
||||
Nothing -> return (Just ti)
|
||||
adjustTreeItem ShowMissingAdjustment ti = return (Just ti)
|
||||
|
||||
type OrigBranch = Branch
|
||||
type AdjBranch = Branch
|
||||
|
||||
adjustedBranchPrefix :: String
|
||||
adjustedBranchPrefix = "refs/heads/adjusted/"
|
||||
|
||||
serialize :: Adjustment -> String
|
||||
serialize UnlockAdjustment = "unlocked"
|
||||
serialize LockAdjustment = "locked"
|
||||
serialize HideMissingAdjustment = "present"
|
||||
serialize ShowMissingAdjustment = "showmissing"
|
||||
|
||||
deserialize :: String -> Maybe Adjustment
|
||||
deserialize "unlocked" = Just UnlockAdjustment
|
||||
deserialize "locked" = Just UnlockAdjustment
|
||||
deserialize "present" = Just HideMissingAdjustment
|
||||
deserialize _ = Nothing
|
||||
|
||||
originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch
|
||||
originalToAdjusted orig adj = Ref $
|
||||
adjustedBranchPrefix ++ base ++ '(' : serialize adj ++ ")"
|
||||
where
|
||||
base = fromRef (Git.Ref.basename orig)
|
||||
|
||||
adjustedToOriginal :: AdjBranch -> Maybe (Adjustment, OrigBranch)
|
||||
adjustedToOriginal b
|
||||
| adjustedBranchPrefix `isPrefixOf` bs = do
|
||||
let (base, as) = separate (== '(') (drop prefixlen bs)
|
||||
adj <- deserialize (takeWhile (/= ')') as)
|
||||
Just (adj, Git.Ref.under "refs/heads" (Ref base))
|
||||
| otherwise = Nothing
|
||||
where
|
||||
bs = fromRef b
|
||||
prefixlen = length adjustedBranchPrefix
|
||||
|
||||
getAdjustment :: Branch -> Maybe Adjustment
|
||||
getAdjustment = fmap fst . adjustedToOriginal
|
||||
|
||||
fromAdjustedBranch :: Branch -> OrigBranch
|
||||
fromAdjustedBranch b = maybe b snd (adjustedToOriginal b)
|
||||
|
||||
originalBranch :: Annex (Maybe OrigBranch)
|
||||
originalBranch = fmap fromAdjustedBranch <$> inRepo Git.Branch.current
|
||||
|
||||
{- 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 <- preventCommits $ const $
|
||||
adjustBranch adj origbranch
|
||||
inRepo $ Git.Command.run
|
||||
[ Param "checkout"
|
||||
, Param $ fromRef $ Git.Ref.base $ adjbranch
|
||||
]
|
||||
go Nothing = error "not on any branch!"
|
||||
|
||||
adjustToCrippledFileSystem :: Annex ()
|
||||
adjustToCrippledFileSystem = do
|
||||
warning "Entering an adjusted branch where files are unlocked as this filesystem does not support locked files."
|
||||
whenM (isNothing <$> originalBranch) $
|
||||
void $ inRepo $ Git.Branch.commitCommand Git.Branch.AutomaticCommit
|
||||
[ Param "--quiet"
|
||||
, Param "--allow-empty"
|
||||
, Param "-m"
|
||||
, Param "commit before entering adjusted unlocked branch"
|
||||
]
|
||||
enterAdjustedBranch UnlockAdjustment
|
||||
|
||||
adjustBranch :: Adjustment -> OrigBranch -> Annex AdjBranch
|
||||
adjustBranch adj origbranch = do
|
||||
sha <- adjust adj origbranch
|
||||
inRepo $ Git.Branch.update "entering adjusted branch" adjbranch sha
|
||||
return adjbranch
|
||||
where
|
||||
adjbranch = originalToAdjusted origbranch adj
|
||||
|
||||
adjust :: Adjustment -> Ref -> Annex Sha
|
||||
adjust adj orig = do
|
||||
treesha <- adjustTree adj orig
|
||||
commitAdjustedTree treesha orig
|
||||
|
||||
adjustTree :: Adjustment -> Ref -> Annex Sha
|
||||
adjustTree adj orig = do
|
||||
let toadj = adjustTreeItem adj
|
||||
treesha <- Git.Tree.adjustTree toadj [] [] orig =<< Annex.gitRepo
|
||||
return treesha
|
||||
|
||||
type CommitsPrevented = Git.LockFile.LockHandle
|
||||
|
||||
{- Locks git's index file, preventing git from making a commit, merge,
|
||||
- or otherwise changing the HEAD ref while the action is run.
|
||||
-
|
||||
- Throws an IO exception if the index file is already locked.
|
||||
-}
|
||||
preventCommits :: (CommitsPrevented -> Annex a) -> Annex a
|
||||
preventCommits = bracket setup cleanup
|
||||
where
|
||||
setup = do
|
||||
lck <- fromRepo indexFileLock
|
||||
liftIO $ Git.LockFile.openLock lck
|
||||
cleanup = liftIO . Git.LockFile.closeLock
|
||||
|
||||
{- 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 = commitAdjustedTree' treesha parent [parent]
|
||||
|
||||
commitAdjustedTree' :: Sha -> Ref -> [Ref] -> Annex Sha
|
||||
commitAdjustedTree' treesha basis parents = go =<< catCommit basis
|
||||
where
|
||||
go Nothing = inRepo mkcommit
|
||||
go (Just basiscommit) = inRepo $ commitWithMetaData
|
||||
(commitAuthorMetaData basiscommit)
|
||||
(commitCommitterMetaData basiscommit)
|
||||
mkcommit
|
||||
mkcommit = Git.Branch.commitTree Git.Branch.AutomaticCommit
|
||||
adjustedBranchCommitMessage parents treesha
|
||||
|
||||
adjustedBranchCommitMessage :: String
|
||||
adjustedBranchCommitMessage = "git-annex adjusted branch"
|
||||
|
||||
{- Update the currently checked out adjusted branch, merging the provided
|
||||
- branch into it. -}
|
||||
updateAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Git.Branch.CommitMode -> Annex Bool
|
||||
updateAdjustedBranch tomerge (origbranch, adj) commitmode = catchBoolIO $
|
||||
join $ preventCommits $ \commitsprevented -> go commitsprevented =<< (,)
|
||||
<$> inRepo (Git.Ref.sha tomerge)
|
||||
<*> inRepo Git.Branch.current
|
||||
where
|
||||
go commitsprevented (Just mergesha, Just currbranch) =
|
||||
ifM (inRepo $ Git.Branch.changed currbranch mergesha)
|
||||
( do
|
||||
void $ propigateAdjustedCommits' origbranch (adj, currbranch) commitsprevented
|
||||
adjustedtomerge <- adjust adj mergesha
|
||||
ifM (inRepo $ Git.Branch.changed currbranch adjustedtomerge)
|
||||
( return $
|
||||
-- Run after commit lock is dropped.
|
||||
ifM (autoMergeFrom adjustedtomerge (Just currbranch) commitmode)
|
||||
( preventCommits $ \_ ->
|
||||
recommit currbranch mergesha =<< catCommit currbranch
|
||||
, return False
|
||||
)
|
||||
, nochangestomerge
|
||||
)
|
||||
, nochangestomerge
|
||||
)
|
||||
go _ _ = return $ return False
|
||||
nochangestomerge = return $ return True
|
||||
|
||||
{- A merge commit has been made on the adjusted branch.
|
||||
- Now, re-do it, removing the old version of the adjusted branch
|
||||
- from its history.
|
||||
-
|
||||
- There are two possible scenarios; either some commits
|
||||
- were made on top of the adjusted branch's adjusting commit,
|
||||
- or not. Those commits have already been propigated to the
|
||||
- orig branch, so we can just check if there are commits in the
|
||||
- orig branch that are not present in tomerge.
|
||||
-}
|
||||
recommit currbranch mergedsha (Just mergecommit) =
|
||||
ifM (inRepo $ Git.Branch.changed tomerge origbranch)
|
||||
( remerge currbranch mergedsha mergecommit
|
||||
=<< inRepo (Git.Ref.sha origbranch)
|
||||
, fastforward currbranch mergedsha mergecommit
|
||||
)
|
||||
recommit _ _ Nothing = return False
|
||||
|
||||
{- Fast-forward scenario. The mergecommit is changed to a non-merge
|
||||
- commit, with its parent being the mergedsha.
|
||||
- The orig branch can simply be pointed at the mergedsha.
|
||||
-}
|
||||
fastforward currbranch mergedsha mergecommit = do
|
||||
commitsha <- commitAdjustedTree (commitTree mergecommit) mergedsha
|
||||
inRepo $ Git.Branch.update "fast-forward update of adjusted branch" currbranch commitsha
|
||||
inRepo $ Git.Branch.update "updating original branch" origbranch mergedsha
|
||||
return True
|
||||
|
||||
{- True merge scenario. -}
|
||||
remerge currbranch mergedsha mergecommit (Just origsha) = do
|
||||
-- Update origbranch by reverse adjusting the mergecommit,
|
||||
-- yielding a merge between orig and tomerge.
|
||||
treesha <- reverseAdjustedTree origsha adj
|
||||
-- get 1-parent commit because
|
||||
-- reverseAdjustedTree does not support merges
|
||||
=<< commitAdjustedTree (commitTree mergecommit) origsha
|
||||
revadjcommit <- inRepo $
|
||||
Git.Branch.commitTree Git.Branch.AutomaticCommit
|
||||
("Merge branch " ++ fromRef tomerge) [origsha, mergedsha] treesha
|
||||
inRepo $ Git.Branch.update "updating original branch" origbranch revadjcommit
|
||||
-- Update currbranch, reusing mergedsha, but making its
|
||||
-- parent be the updated origbranch.
|
||||
adjcommit <- commitAdjustedTree' (commitTree mergecommit) revadjcommit [revadjcommit]
|
||||
inRepo $ Git.Branch.update rebaseOnTopMsg currbranch adjcommit
|
||||
return True
|
||||
remerge _ _ _ Nothing = return False
|
||||
|
||||
{- Check for any commits present on the adjusted branch that have not yet
|
||||
- been propigated to the orig branch, and propigate them.
|
||||
-
|
||||
- After propigating the commits back to the orig banch,
|
||||
- rebase the adjusted branch on top of the updated orig branch.
|
||||
-}
|
||||
propigateAdjustedCommits :: OrigBranch -> (Adjustment, AdjBranch) -> Annex ()
|
||||
propigateAdjustedCommits origbranch (adj, currbranch) =
|
||||
preventCommits $ \commitsprevented -> do
|
||||
join $ propigateAdjustedCommits' origbranch (adj, currbranch) commitsprevented
|
||||
|
||||
{- Returns action which will rebase the adjusted branch on top of the
|
||||
- updated orig branch. -}
|
||||
propigateAdjustedCommits'
|
||||
:: OrigBranch
|
||||
-> (Adjustment, AdjBranch)
|
||||
-> CommitsPrevented
|
||||
-> Annex (Annex ())
|
||||
propigateAdjustedCommits' origbranch (adj, currbranch) _commitsprevented = do
|
||||
ov <- inRepo $ Git.Ref.sha (Git.Ref.under "refs/heads" origbranch)
|
||||
case ov of
|
||||
Just origsha -> do
|
||||
cv <- catCommit currbranch
|
||||
case cv of
|
||||
Just currcommit -> do
|
||||
v <- newcommits >>= go origsha False
|
||||
case v of
|
||||
Left e -> do
|
||||
warning e
|
||||
return $ return ()
|
||||
Right newparent -> return $
|
||||
rebase currcommit newparent
|
||||
Nothing -> return $ return ()
|
||||
Nothing -> return $ return ()
|
||||
where
|
||||
newcommits = inRepo $ Git.Branch.changedCommits origbranch currbranch
|
||||
-- Get commits oldest first, so they can be processed
|
||||
-- in order made.
|
||||
[Param "--reverse"]
|
||||
go parent _ [] = do
|
||||
inRepo $ Git.Branch.update "updating adjusted branch" origbranch parent
|
||||
return (Right parent)
|
||||
go parent pastadjcommit (sha:l) = do
|
||||
mc <- catCommit sha
|
||||
case mc of
|
||||
Just c
|
||||
| commitMessage c == adjustedBranchCommitMessage ->
|
||||
go parent True l
|
||||
| pastadjcommit -> do
|
||||
v <- reverseAdjustedCommit parent adj (sha, c) origbranch
|
||||
case v of
|
||||
Left e -> return (Left e)
|
||||
Right commit -> go commit pastadjcommit l
|
||||
_ -> go parent pastadjcommit l
|
||||
rebase currcommit newparent = do
|
||||
-- Reuse the current adjusted tree,
|
||||
-- and reparent it on top of the new
|
||||
-- version of the origbranch.
|
||||
commitAdjustedTree (commitTree currcommit) newparent
|
||||
>>= inRepo . Git.Branch.update rebaseOnTopMsg currbranch
|
||||
|
||||
rebaseOnTopMsg :: String
|
||||
rebaseOnTopMsg = "rebasing adjusted branch on top of updated original branch"
|
||||
|
||||
{- Reverses an adjusted commit, and commit with provided commitparent,
|
||||
- yielding a commit sha.
|
||||
-
|
||||
- Adjusts the tree of the commitparent, changing only the files that the
|
||||
- commit changed, and reverse adjusting those changes.
|
||||
-
|
||||
- The commit message, and the author and committer metadata are
|
||||
- copied over from the basiscommit. However, any gpg signature
|
||||
- will be lost, and any other headers are not copied either. -}
|
||||
reverseAdjustedCommit :: Sha -> Adjustment -> (Sha, Commit) -> OrigBranch -> Annex (Either String Sha)
|
||||
reverseAdjustedCommit commitparent adj (csha, basiscommit) origbranch
|
||||
| length (commitParent basiscommit) > 1 = return $
|
||||
Left $ "unable to propigate merge commit " ++ show csha ++ " back to " ++ show origbranch
|
||||
| otherwise = do
|
||||
treesha <- reverseAdjustedTree commitparent adj csha
|
||||
revadjcommit <- inRepo $ commitWithMetaData
|
||||
(commitAuthorMetaData basiscommit)
|
||||
(commitCommitterMetaData basiscommit) $
|
||||
Git.Branch.commitTree Git.Branch.AutomaticCommit
|
||||
(commitMessage basiscommit) [commitparent] treesha
|
||||
return (Right revadjcommit)
|
||||
|
||||
{- Adjusts the tree of the basis, changing only the files that the
|
||||
- commit changed, and reverse adjusting those changes.
|
||||
-
|
||||
- commitDiff does not support merge commits, so the csha must not be a
|
||||
- merge commit. -}
|
||||
reverseAdjustedTree :: Sha -> Adjustment -> Sha -> Annex Sha
|
||||
reverseAdjustedTree basis adj csha = do
|
||||
(diff, cleanup) <- inRepo (Git.DiffTree.commitDiff csha)
|
||||
let (adds, others) = partition (\dti -> Git.DiffTree.srcsha dti == nullSha) diff
|
||||
let (removes, changes) = partition (\dti -> Git.DiffTree.dstsha dti == nullSha) others
|
||||
adds' <- catMaybes <$>
|
||||
mapM (adjustTreeItem reverseadj) (map diffTreeToTreeItem adds)
|
||||
treesha <- Git.Tree.adjustTree
|
||||
(propchanges changes)
|
||||
adds'
|
||||
(map Git.DiffTree.file removes)
|
||||
basis
|
||||
=<< Annex.gitRepo
|
||||
void $ liftIO cleanup
|
||||
return treesha
|
||||
where
|
||||
reverseadj = reverseAdjustment adj
|
||||
propchanges changes ti@(TreeItem f _ _) =
|
||||
case M.lookup f m of
|
||||
Nothing -> return (Just ti) -- not changed
|
||||
Just change -> adjustTreeItem reverseadj change
|
||||
where
|
||||
m = M.fromList $ map (\i@(TreeItem f' _ _) -> (f', i)) $
|
||||
map diffTreeToTreeItem changes
|
||||
|
||||
diffTreeToTreeItem :: Git.DiffTree.DiffTreeItem -> TreeItem
|
||||
diffTreeToTreeItem dti = TreeItem
|
||||
(Git.DiffTree.file dti)
|
||||
(Git.DiffTree.dstmode dti)
|
||||
(Git.DiffTree.dstsha dti)
|
|
@ -225,7 +225,7 @@ mergeDirectCommit allowff old branch commitmode = do
|
|||
let merge_msg = d </> "MERGE_MSG"
|
||||
let merge_mode = d </> "MERGE_MODE"
|
||||
ifM (pure allowff <&&> canff)
|
||||
( inRepo $ Git.Branch.update Git.Ref.headRef branch -- fast forward
|
||||
( inRepo $ Git.Branch.update "merge" Git.Ref.headRef branch -- fast forward
|
||||
, do
|
||||
msg <- liftIO $
|
||||
catchDefaultIO ("merge " ++ fromRef branch) $
|
||||
|
@ -462,7 +462,7 @@ switchHEAD = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
|
|||
where
|
||||
switch orighead = do
|
||||
let newhead = directBranch orighead
|
||||
maybe noop (inRepo . Git.Branch.update newhead)
|
||||
maybe noop (inRepo . Git.Branch.update "entering direct mode" newhead)
|
||||
=<< inRepo (Git.Ref.sha orighead)
|
||||
inRepo $ Git.Branch.checkout newhead
|
||||
|
||||
|
@ -475,7 +475,7 @@ switchHEADBack = maybe noop switch =<< inRepo Git.Branch.currentUnsafe
|
|||
case v of
|
||||
Just headsha
|
||||
| orighead /= currhead -> do
|
||||
inRepo $ Git.Branch.update orighead headsha
|
||||
inRepo $ Git.Branch.update "leaving direct mode" orighead headsha
|
||||
inRepo $ Git.Branch.checkout orighead
|
||||
inRepo $ Git.Branch.delete currhead
|
||||
_ -> inRepo $ Git.Branch.checkout orighead
|
||||
|
|
|
@ -35,6 +35,8 @@ import Logs.Location
|
|||
import qualified Annex
|
||||
import qualified Annex.Queue
|
||||
import qualified Database.Keys
|
||||
import qualified Git
|
||||
import qualified Git.Branch
|
||||
import Config
|
||||
import Utility.InodeCache
|
||||
import Annex.ReplaceFile
|
||||
|
@ -43,6 +45,7 @@ import Utility.CopyFile
|
|||
import Utility.Touch
|
||||
import Git.FilePath
|
||||
import Annex.InodeSentinal
|
||||
import Annex.AdjustedBranch
|
||||
|
||||
import Control.Exception (IOException)
|
||||
|
||||
|
@ -309,15 +312,32 @@ forceParams = ifM (Annex.getState Annex.force)
|
|||
)
|
||||
|
||||
{- Whether a file should be added unlocked or not. Default is to not,
|
||||
- unless symlinks are not supported. annex.addunlocked can override that. -}
|
||||
- unless symlinks are not supported. annex.addunlocked can override that.
|
||||
- Also, when in an adjusted unlocked branch, always add files unlocked.
|
||||
-}
|
||||
addUnlocked :: Annex Bool
|
||||
addUnlocked = isDirect <||>
|
||||
(versionSupportsUnlockedPointers <&&>
|
||||
((not . coreSymlinks <$> Annex.getGitConfig) <||>
|
||||
(annexAddUnlocked <$> Annex.getGitConfig)
|
||||
(annexAddUnlocked <$> Annex.getGitConfig) <||>
|
||||
(maybe False (\b -> getAdjustment b == Just UnlockAdjustment) <$> cachedCurrentBranch)
|
||||
)
|
||||
)
|
||||
|
||||
cachedCurrentBranch :: Annex (Maybe Git.Branch)
|
||||
cachedCurrentBranch = maybe cache (return . Just)
|
||||
=<< Annex.getState Annex.cachedcurrentbranch
|
||||
where
|
||||
cache :: Annex (Maybe Git.Branch)
|
||||
cache = do
|
||||
mb <- inRepo Git.Branch.currentUnsafe
|
||||
case mb of
|
||||
Nothing -> return Nothing
|
||||
Just b -> do
|
||||
Annex.changeState $ \s ->
|
||||
s { Annex.cachedcurrentbranch = Just b }
|
||||
return (Just b)
|
||||
|
||||
{- Adds a file to the work tree for the key, and stages it in the index.
|
||||
- The content of the key may be provided in a temp file, which will be
|
||||
- moved into place. -}
|
||||
|
|
|
@ -33,6 +33,7 @@ import Annex.UUID
|
|||
import Annex.Link
|
||||
import Config
|
||||
import Annex.Direct
|
||||
import Annex.AdjustedBranch
|
||||
import Annex.Environment
|
||||
import Annex.Hook
|
||||
import Annex.InodeSentinal
|
||||
|
@ -92,10 +93,13 @@ initialize' mversion = do
|
|||
whenM versionSupportsUnlockedPointers $ do
|
||||
configureSmudgeFilter
|
||||
Database.Keys.scanAssociatedFiles
|
||||
ifM (crippledFileSystem <&&> (not <$> isBare) <&&> (not <$> versionSupportsUnlockedPointers))
|
||||
( do
|
||||
enableDirectMode
|
||||
setDirect True
|
||||
ifM (crippledFileSystem <&&> (not <$> isBare))
|
||||
( ifM versionSupportsUnlockedPointers
|
||||
( adjustToCrippledFileSystem
|
||||
, do
|
||||
enableDirectMode
|
||||
setDirect True
|
||||
)
|
||||
-- Handle case where this repo was cloned from a
|
||||
-- direct mode repo
|
||||
, unlessM isBare
|
||||
|
|
|
@ -52,6 +52,9 @@ versionSupportsUnlockedPointers = go <$> getVersion
|
|||
go (Just "6") = True
|
||||
go _ = False
|
||||
|
||||
versionSupportsAdjustedBranch :: Annex Bool
|
||||
versionSupportsAdjustedBranch = versionSupportsUnlockedPointers
|
||||
|
||||
setVersion :: Version -> Annex ()
|
||||
setVersion = setConfig versionField
|
||||
|
||||
|
|
|
@ -19,7 +19,6 @@ import Assistant.RemoteControl
|
|||
import qualified Command.Sync
|
||||
import Utility.Parallel
|
||||
import qualified Git
|
||||
import qualified Git.Branch
|
||||
import qualified Git.Command
|
||||
import qualified Git.Ref
|
||||
import qualified Remote
|
||||
|
@ -79,16 +78,16 @@ reconnectRemotes notifypushes rs = void $ do
|
|||
| Git.repoIsLocal r = True
|
||||
| Git.repoIsLocalUnknown r = True
|
||||
| otherwise = False
|
||||
sync (Just branch) = do
|
||||
(failedpull, diverged) <- manualPull (Just branch) gitremotes
|
||||
sync currentbranch@(Just _, _) = do
|
||||
(failedpull, diverged) <- manualPull currentbranch gitremotes
|
||||
now <- liftIO getCurrentTime
|
||||
failedpush <- pushToRemotes' now notifypushes gitremotes
|
||||
return (nub $ failedpull ++ failedpush, diverged)
|
||||
{- No local branch exists yet, but we can try pulling. -}
|
||||
sync Nothing = manualPull Nothing gitremotes
|
||||
sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes
|
||||
go = do
|
||||
(failed, diverged) <- sync
|
||||
=<< liftAnnex (inRepo Git.Branch.current)
|
||||
=<< liftAnnex (join Command.Sync.getCurrBranch)
|
||||
addScanRemotes diverged $
|
||||
filter (not . remoteAnnexIgnore . Remote.gitconfig)
|
||||
nonxmppremotes
|
||||
|
@ -133,7 +132,7 @@ pushToRemotes' now notifypushes remotes = do
|
|||
Annex.Branch.commit "update"
|
||||
(,,)
|
||||
<$> gitRepo
|
||||
<*> inRepo Git.Branch.current
|
||||
<*> join Command.Sync.getCurrBranch
|
||||
<*> getUUID
|
||||
let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
|
||||
ret <- go True branch g u normalremotes
|
||||
|
@ -145,9 +144,9 @@ pushToRemotes' now notifypushes remotes = do
|
|||
Pushing (getXMPPClientID r) (CanPush u shas)
|
||||
return ret
|
||||
where
|
||||
go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
|
||||
go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
|
||||
go _ _ _ _ [] = return [] -- no remotes, so nothing to do
|
||||
go shouldretry (Just branch) g u rs = do
|
||||
go shouldretry currbranch@(Just branch, _) g u rs = do
|
||||
debug ["pushing to", show rs]
|
||||
(succeeded, failed) <- parallelPush g rs (push branch)
|
||||
updatemap succeeded []
|
||||
|
@ -158,7 +157,7 @@ pushToRemotes' now notifypushes remotes = do
|
|||
map Remote.uuid succeeded
|
||||
return failed
|
||||
else if shouldretry
|
||||
then retry branch g u failed
|
||||
then retry currbranch g u failed
|
||||
else fallback branch g u failed
|
||||
|
||||
updatemap succeeded failed = changeFailedPushMap $ \m ->
|
||||
|
@ -166,10 +165,10 @@ pushToRemotes' now notifypushes remotes = do
|
|||
M.difference m (makemap succeeded)
|
||||
makemap l = M.fromList $ zip l (repeat now)
|
||||
|
||||
retry branch g u rs = do
|
||||
retry currbranch g u rs = do
|
||||
debug ["trying manual pull to resolve failed pushes"]
|
||||
void $ manualPull (Just branch) rs
|
||||
go False (Just branch) g u rs
|
||||
void $ manualPull currbranch rs
|
||||
go False currbranch g u rs
|
||||
|
||||
fallback branch g u rs = do
|
||||
debug ["fallback pushing to", show rs]
|
||||
|
@ -227,7 +226,7 @@ syncAction rs a
|
|||
- XMPP remotes. However, those pushes will run asynchronously, so their
|
||||
- results are not included in the return data.
|
||||
-}
|
||||
manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool)
|
||||
manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
|
||||
manualPull currentbranch remotes = do
|
||||
g <- liftAnnex gitRepo
|
||||
let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
|
||||
|
|
|
@ -227,7 +227,7 @@ commitStaged msg = do
|
|||
Right _ -> do
|
||||
ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg
|
||||
when ok $
|
||||
Command.Sync.updateSyncBranch =<< inRepo Git.Branch.current
|
||||
Command.Sync.updateSyncBranch =<< join Command.Sync.getCurrBranch
|
||||
return ok
|
||||
|
||||
{- OSX needs a short delay after a file is added before locking it down,
|
||||
|
|
|
@ -17,7 +17,7 @@ import Utility.DirWatcher.Types
|
|||
import qualified Annex.Branch
|
||||
import qualified Git
|
||||
import qualified Git.Branch
|
||||
import Annex.AutoMerge
|
||||
import qualified Command.Sync
|
||||
import Annex.TaggedPush
|
||||
import Remote (remoteFromUUID)
|
||||
|
||||
|
@ -72,19 +72,21 @@ onChange file
|
|||
unlessM handleDesynced $
|
||||
queueDeferredDownloads "retrying deferred download" Later
|
||||
| "/synced/" `isInfixOf` file =
|
||||
mergecurrent =<< liftAnnex (inRepo Git.Branch.current)
|
||||
mergecurrent =<< liftAnnex (join Command.Sync.getCurrBranch)
|
||||
| otherwise = noop
|
||||
where
|
||||
changedbranch = fileToBranch file
|
||||
|
||||
mergecurrent (Just current)
|
||||
| equivBranches changedbranch current =
|
||||
whenM (liftAnnex $ inRepo $ Git.Branch.changed current changedbranch) $ do
|
||||
mergecurrent currbranch@(Just b, _)
|
||||
| equivBranches changedbranch b =
|
||||
whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do
|
||||
debug
|
||||
[ "merging", Git.fromRef changedbranch
|
||||
, "into", Git.fromRef current
|
||||
, "into", Git.fromRef b
|
||||
]
|
||||
void $ liftAnnex $ autoMergeFrom changedbranch (Just current) Git.Branch.AutomaticCommit
|
||||
void $ liftAnnex $ Command.Sync.merge
|
||||
currbranch Git.Branch.AutomaticCommit
|
||||
changedbranch
|
||||
mergecurrent _ = noop
|
||||
|
||||
handleDesynced = case fromTaggedBranch changedbranch of
|
||||
|
|
|
@ -25,6 +25,7 @@ import Assistant.Pairing
|
|||
import Assistant.XMPP.Git
|
||||
import Annex.UUID
|
||||
import Logs.UUID
|
||||
import qualified Command.Sync
|
||||
|
||||
import Network.Protocol.XMPP
|
||||
import Control.Concurrent
|
||||
|
@ -33,7 +34,6 @@ import Control.Concurrent.STM (atomically)
|
|||
import qualified Data.Text as T
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
import qualified Git.Branch
|
||||
import Data.Time.Clock
|
||||
import Control.Concurrent.Async
|
||||
|
||||
|
@ -306,7 +306,7 @@ pull [] = noop
|
|||
pull us = do
|
||||
rs <- filter matching . syncGitRemotes <$> getDaemonStatus
|
||||
debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
|
||||
pullone rs =<< liftAnnex (inRepo Git.Branch.current)
|
||||
pullone rs =<< liftAnnex (join Command.Sync.getCurrBranch)
|
||||
where
|
||||
matching r = Remote.uuid r `S.member` s
|
||||
s = S.fromList us
|
||||
|
|
|
@ -20,7 +20,7 @@ import qualified Annex
|
|||
import qualified Git
|
||||
import qualified Git.Config
|
||||
import qualified Git.Command
|
||||
import qualified Git.Branch
|
||||
import qualified Command.Sync
|
||||
import Config.Files
|
||||
import Utility.FreeDesktop
|
||||
import Utility.DiskFree
|
||||
|
@ -200,7 +200,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
|
|||
- immediately pulling from it. Also spawns a sync to push to it as well. -}
|
||||
immediateSyncRemote :: Remote -> Assistant ()
|
||||
immediateSyncRemote r = do
|
||||
currentbranch <- liftAnnex (inRepo Git.Branch.current)
|
||||
currentbranch <- liftAnnex $ join Command.Sync.getCurrBranch
|
||||
void $ manualPull currentbranch [r]
|
||||
syncRemote r
|
||||
|
||||
|
|
|
@ -27,7 +27,6 @@ import Annex.TaggedPush
|
|||
import Annex.CatFile
|
||||
import Config
|
||||
import Git
|
||||
import qualified Git.Branch
|
||||
import qualified Types.Remote as Remote
|
||||
import qualified Remote as Remote
|
||||
import Remote.List
|
||||
|
@ -292,16 +291,15 @@ xmppRemotes cid theiruuid = case baseJID <$> parseJID cid of
|
|||
{- Returns the ClientID that it pushed to. -}
|
||||
runPush :: (Remote -> Assistant ()) -> NetMessage -> Assistant (Maybe ClientID)
|
||||
runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
|
||||
go =<< liftAnnex (inRepo Git.Branch.current)
|
||||
go =<< liftAnnex (join Command.Sync.getCurrBranch)
|
||||
where
|
||||
go Nothing = return Nothing
|
||||
go (Just branch) = do
|
||||
go (Just branch, _) = do
|
||||
rs <- xmppRemotes cid theiruuid
|
||||
liftAnnex $ Annex.Branch.commit "update"
|
||||
(g, u) <- liftAnnex $ (,)
|
||||
<$> gitRepo
|
||||
<*> getUUID
|
||||
liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
|
||||
liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) branch g
|
||||
selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus
|
||||
if null rs
|
||||
then return Nothing
|
||||
|
@ -311,6 +309,7 @@ runPush checkcloudrepos (Pushing cid (PushRequest theiruuid)) =
|
|||
xmppPush cid (taggedPush u selfjid branch r)
|
||||
checkcloudrepos r
|
||||
return $ Just cid
|
||||
go _ = return Nothing
|
||||
runPush checkcloudrepos (Pushing cid (StartingPush theiruuid)) = do
|
||||
rs <- xmppRemotes cid theiruuid
|
||||
if null rs
|
||||
|
|
|
@ -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
|
||||
|
|
41
Command/Adjust.hs
Normal file
41
Command/Adjust.hs
Normal file
|
@ -0,0 +1,41 @@
|
|||
{- 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
|
||||
import Annex.Version
|
||||
|
||||
cmd :: Command
|
||||
cmd = notBareRepo $ notDirect $ noDaemonRunning $
|
||||
command "adjust" SectionSetup "enter adjusted branch"
|
||||
paramNothing (seek <$$> optParser)
|
||||
|
||||
optParser :: CmdParamsDesc -> Parser Adjustment
|
||||
optParser _ =
|
||||
flag' UnlockAdjustment
|
||||
( long "unlock"
|
||||
<> help "unlock annexed files"
|
||||
)
|
||||
{- Not ready yet
|
||||
<|> flag' HideMissingAdjustment
|
||||
( long "hide-missing"
|
||||
<> help "omit annexed files whose content is not present"
|
||||
)
|
||||
-}
|
||||
|
||||
seek :: Adjustment -> CommandSeek
|
||||
seek = commandAction . start
|
||||
|
||||
start :: Adjustment -> CommandStart
|
||||
start adj = do
|
||||
unlessM versionSupportsAdjustedBranch $
|
||||
error "Adjusted branches are only supported in v6 or newer repositories."
|
||||
showStart "adjust" ""
|
||||
enterAdjustedBranch adj
|
||||
next $ next $ return True
|
|
@ -9,8 +9,7 @@ module Command.Merge where
|
|||
|
||||
import Command
|
||||
import qualified Annex.Branch
|
||||
import qualified Git.Branch
|
||||
import Command.Sync (prepMerge, mergeLocal)
|
||||
import Command.Sync (prepMerge, mergeLocal, getCurrBranch)
|
||||
|
||||
cmd :: Command
|
||||
cmd = command "merge" SectionMaintenance
|
||||
|
@ -34,4 +33,4 @@ mergeBranch = do
|
|||
mergeSynced :: CommandStart
|
||||
mergeSynced = do
|
||||
prepMerge
|
||||
mergeLocal =<< inRepo Git.Branch.current
|
||||
mergeLocal =<< join getCurrBranch
|
||||
|
|
129
Command/Sync.hs
129
Command/Sync.hs
|
@ -1,13 +1,16 @@
|
|||
{- git-annex command
|
||||
-
|
||||
- Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>
|
||||
- Copyright 2011-2014 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2011-2016 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Command.Sync (
|
||||
cmd,
|
||||
CurrBranch,
|
||||
getCurrBranch,
|
||||
merge,
|
||||
prepMerge,
|
||||
mergeLocal,
|
||||
mergeRemote,
|
||||
|
@ -43,6 +46,7 @@ import Annex.Drop
|
|||
import Annex.UUID
|
||||
import Logs.UUID
|
||||
import Annex.AutoMerge
|
||||
import Annex.AdjustedBranch
|
||||
import Annex.Ssh
|
||||
import Annex.BloomFilter
|
||||
import Utility.Bloom
|
||||
|
@ -95,20 +99,7 @@ seek :: SyncOptions -> CommandSeek
|
|||
seek o = allowConcurrentOutput $ do
|
||||
prepMerge
|
||||
|
||||
-- There may not be a branch checked out until after the commit,
|
||||
-- or perhaps after it gets merged from the remote, or perhaps
|
||||
-- never.
|
||||
-- So only look it up once it's needed, and once there is a
|
||||
-- branch, cache it.
|
||||
mvar <- liftIO newEmptyMVar
|
||||
let getbranch = ifM (liftIO $ isEmptyMVar mvar)
|
||||
( do
|
||||
branch <- inRepo Git.Branch.current
|
||||
when (isJust branch) $
|
||||
liftIO $ putMVar mvar branch
|
||||
return branch
|
||||
, liftIO $ readMVar mvar
|
||||
)
|
||||
getbranch <- getCurrBranch
|
||||
let withbranch a = a =<< getbranch
|
||||
|
||||
remotes <- syncRemotes (syncWith o)
|
||||
|
@ -140,14 +131,49 @@ seek o = allowConcurrentOutput $ do
|
|||
-- Pushes to remotes can run concurrently.
|
||||
mapM_ (commandAction . withbranch . pushRemote o) gitremotes
|
||||
|
||||
type CurrBranch = (Maybe Git.Branch, Maybe Adjustment)
|
||||
|
||||
{- There may not be a branch checked out until after the commit,
|
||||
- or perhaps after it gets merged from the remote, or perhaps
|
||||
- never.
|
||||
-
|
||||
- So only look it up once it's needed, and once there is a
|
||||
- branch, cache it.
|
||||
-
|
||||
- When on an adjusted branch, gets the original branch, and the adjustment.
|
||||
-}
|
||||
getCurrBranch :: Annex (Annex CurrBranch)
|
||||
getCurrBranch = do
|
||||
mvar <- liftIO newEmptyMVar
|
||||
return $ ifM (liftIO $ isEmptyMVar mvar)
|
||||
( do
|
||||
currbranch <- inRepo Git.Branch.current
|
||||
case currbranch of
|
||||
Nothing -> return (Nothing, Nothing)
|
||||
Just b -> do
|
||||
let v = case adjustedToOriginal b of
|
||||
Nothing -> (Just b, Nothing)
|
||||
Just (adj, origbranch) ->
|
||||
(Just origbranch, Just adj)
|
||||
liftIO $ putMVar mvar v
|
||||
return v
|
||||
, liftIO $ readMVar mvar
|
||||
)
|
||||
|
||||
{- Merging may delete the current directory, so go to the top
|
||||
- of the repo. This also means that sync always acts on all files in the
|
||||
- repository, not just on a subdirectory. -}
|
||||
prepMerge :: Annex ()
|
||||
prepMerge = Annex.changeDirectory =<< fromRepo Git.repoPath
|
||||
|
||||
syncBranch :: Git.Ref -> Git.Ref
|
||||
syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch
|
||||
merge :: CurrBranch -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool
|
||||
merge (Just b, Just adj) commitmode tomerge =
|
||||
updateAdjustedBranch tomerge (b, adj) commitmode
|
||||
merge (b, _) commitmode tomerge =
|
||||
autoMergeFrom tomerge b commitmode
|
||||
|
||||
syncBranch :: Git.Branch -> Git.Branch
|
||||
syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch . fromAdjustedBranch
|
||||
|
||||
remoteBranch :: Remote -> Git.Ref -> Git.Ref
|
||||
remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote
|
||||
|
@ -216,50 +242,58 @@ commitStaged commitmode commitmessage = do
|
|||
void $ inRepo $ Git.Branch.commit commitmode False commitmessage branch parents
|
||||
return True
|
||||
|
||||
mergeLocal :: Maybe Git.Ref -> CommandStart
|
||||
mergeLocal Nothing = stop
|
||||
mergeLocal (Just branch) = go =<< needmerge
|
||||
mergeLocal :: CurrBranch -> CommandStart
|
||||
mergeLocal currbranch@(Just branch, madj) = go =<< needmerge
|
||||
where
|
||||
syncbranch = syncBranch branch
|
||||
needmerge = ifM isBareRepo
|
||||
( return False
|
||||
, ifM (inRepo $ Git.Ref.exists syncbranch)
|
||||
( inRepo $ Git.Branch.changed branch syncbranch
|
||||
( inRepo $ Git.Branch.changed branch' syncbranch
|
||||
, return False
|
||||
)
|
||||
)
|
||||
go False = stop
|
||||
go True = do
|
||||
showStart "merge" $ Git.Ref.describe syncbranch
|
||||
next $ next $ autoMergeFrom syncbranch (Just branch) Git.Branch.ManualCommit
|
||||
next $ next $ merge currbranch Git.Branch.ManualCommit syncbranch
|
||||
branch' = maybe branch (originalToAdjusted branch) madj
|
||||
mergeLocal (Nothing, _) = stop
|
||||
|
||||
pushLocal :: Maybe Git.Ref -> CommandStart
|
||||
pushLocal :: CurrBranch -> CommandStart
|
||||
pushLocal b = do
|
||||
updateSyncBranch b
|
||||
stop
|
||||
|
||||
updateSyncBranch :: Maybe Git.Ref -> Annex ()
|
||||
updateSyncBranch Nothing = noop
|
||||
updateSyncBranch (Just branch) = do
|
||||
updateSyncBranch :: CurrBranch -> Annex ()
|
||||
updateSyncBranch (Nothing, _) = noop
|
||||
updateSyncBranch (Just branch, madj) = do
|
||||
-- When in an adjusted branch, propigate any changes made to it
|
||||
-- back to the original branch.
|
||||
case madj of
|
||||
Just adj -> propigateAdjustedCommits branch
|
||||
(adj, originalToAdjusted branch adj)
|
||||
Nothing -> return ()
|
||||
-- Update the sync branch to match the new state of the branch
|
||||
inRepo $ updateBranch $ syncBranch branch
|
||||
inRepo $ updateBranch (syncBranch branch) branch
|
||||
-- In direct mode, we're operating on some special direct mode
|
||||
-- branch, rather than the intended branch, so update the indended
|
||||
-- branch, rather than the intended branch, so update the intended
|
||||
-- branch.
|
||||
whenM isDirect $
|
||||
inRepo $ updateBranch $ fromDirectBranch branch
|
||||
inRepo $ updateBranch (fromDirectBranch branch) branch
|
||||
|
||||
updateBranch :: Git.Ref -> Git.Repo -> IO ()
|
||||
updateBranch syncbranch g =
|
||||
updateBranch :: Git.Branch -> Git.Branch -> Git.Repo -> IO ()
|
||||
updateBranch syncbranch updateto g =
|
||||
unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch
|
||||
where
|
||||
go = Git.Command.runBool
|
||||
[ Param "branch"
|
||||
, Param "-f"
|
||||
, Param $ Git.fromRef $ Git.Ref.base syncbranch
|
||||
, Param $ Git.fromRef $ updateto
|
||||
] g
|
||||
|
||||
pullRemote :: SyncOptions -> Remote -> Maybe Git.Ref -> CommandStart
|
||||
pullRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart
|
||||
pullRemote o remote branch = stopUnless (pure $ pullOption o) $ do
|
||||
showStart "pull" (Remote.name remote)
|
||||
next $ do
|
||||
|
@ -276,26 +310,27 @@ pullRemote o remote branch = stopUnless (pure $ pullOption o) $ do
|
|||
- were committed (or pushed changes, if this is a bare remote),
|
||||
- while the synced/master may have changes that some
|
||||
- other remote synced to this remote. So, merge them both. -}
|
||||
mergeRemote :: Remote -> Maybe Git.Ref -> CommandCleanup
|
||||
mergeRemote remote b = ifM isBareRepo
|
||||
mergeRemote :: Remote -> CurrBranch -> CommandCleanup
|
||||
mergeRemote remote currbranch = ifM isBareRepo
|
||||
( return True
|
||||
, case b of
|
||||
Nothing -> do
|
||||
, case currbranch of
|
||||
(Nothing, _) -> do
|
||||
branch <- inRepo Git.Branch.currentUnsafe
|
||||
and <$> mapM (merge Nothing) (branchlist branch)
|
||||
Just thisbranch -> do
|
||||
inRepo $ updateBranch $ syncBranch thisbranch
|
||||
and <$> (mapM (merge (Just thisbranch)) =<< tomerge (branchlist b))
|
||||
mergelisted (pure (branchlist branch))
|
||||
(Just branch, _) -> do
|
||||
inRepo $ updateBranch (syncBranch branch) branch
|
||||
mergelisted (tomerge (branchlist (Just branch)))
|
||||
)
|
||||
where
|
||||
merge thisbranch br = autoMergeFrom (remoteBranch remote br) thisbranch Git.Branch.ManualCommit
|
||||
mergelisted getlist = and <$>
|
||||
(mapM (merge currbranch Git.Branch.ManualCommit . remoteBranch remote) =<< getlist)
|
||||
tomerge = filterM (changed remote)
|
||||
branchlist Nothing = []
|
||||
branchlist (Just branch) = [branch, syncBranch branch]
|
||||
|
||||
pushRemote :: SyncOptions -> Remote -> Maybe Git.Ref -> CommandStart
|
||||
pushRemote _o _remote Nothing = stop
|
||||
pushRemote o remote (Just branch) = stopUnless (pure (pushOption o) <&&> needpush) $ do
|
||||
pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart
|
||||
pushRemote _o _remote (Nothing, _) = stop
|
||||
pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do
|
||||
showStart "push" (Remote.name remote)
|
||||
next $ next $ do
|
||||
showOutput
|
||||
|
@ -339,16 +374,16 @@ pushRemote o remote (Just branch) = stopUnless (pure (pushOption o) <&&> needpus
|
|||
- The sync push will fail to overwrite if receive.denyNonFastforwards is
|
||||
- set on the remote.
|
||||
-}
|
||||
pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool
|
||||
pushBranch :: Remote -> Git.Branch -> Git.Repo -> IO Bool
|
||||
pushBranch remote branch g = tryIO (directpush g) `after` syncpush g
|
||||
where
|
||||
syncpush = Git.Command.runBool $ pushparams
|
||||
[ Git.Branch.forcePush $ refspec Annex.Branch.name
|
||||
, refspec branch
|
||||
, refspec $ fromAdjustedBranch branch
|
||||
]
|
||||
directpush = Git.Command.runQuiet $ pushparams
|
||||
[ Git.fromRef $ Git.Ref.base $ Annex.Branch.name
|
||||
, Git.fromRef $ Git.Ref.base $ fromDirectBranch branch
|
||||
, Git.fromRef $ Git.Ref.base $ fromDirectBranch $ fromAdjustedBranch branch
|
||||
]
|
||||
pushparams branches =
|
||||
[ Param "push"
|
||||
|
|
|
@ -9,6 +9,8 @@ module Command.Upgrade where
|
|||
|
||||
import Command
|
||||
import Upgrade
|
||||
import Annex.Version
|
||||
import Annex.Init
|
||||
|
||||
cmd :: Command
|
||||
cmd = dontCheck repoExists $ -- because an old version may not seem to exist
|
||||
|
@ -22,5 +24,7 @@ seek = withNothing start
|
|||
start :: CommandStart
|
||||
start = do
|
||||
showStart "upgrade" "."
|
||||
whenM (isNothing <$> getVersion) $ do
|
||||
initialize Nothing Nothing
|
||||
r <- upgrade False
|
||||
next $ next $ return r
|
||||
|
|
|
@ -48,15 +48,25 @@ currentUnsafe r = parse . firstLine
|
|||
changed :: Branch -> Branch -> Repo -> IO Bool
|
||||
changed origbranch newbranch repo
|
||||
| origbranch == newbranch = return False
|
||||
| otherwise = not . null <$> diffs
|
||||
| otherwise = not . null
|
||||
<$> changed' origbranch newbranch [Param "-n1"] repo
|
||||
where
|
||||
diffs = pipeReadStrict
|
||||
|
||||
changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String
|
||||
changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
|
||||
where
|
||||
ps =
|
||||
[ Param "log"
|
||||
, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
|
||||
, Param "-n1"
|
||||
, Param "--pretty=%H"
|
||||
] repo
|
||||
] ++ extraps
|
||||
|
||||
{- Lists commits that are in the second branch and not in the first branch. -}
|
||||
changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha]
|
||||
changedCommits origbranch newbranch extraps repo =
|
||||
catMaybes . map extractSha . lines
|
||||
<$> changed' origbranch newbranch extraps repo
|
||||
|
||||
{- Check if it's possible to fast-forward from the old
|
||||
- ref to the new ref.
|
||||
-
|
||||
|
@ -90,7 +100,7 @@ fastForward branch (first:rest) repo =
|
|||
where
|
||||
no_ff = return False
|
||||
do_ff to = do
|
||||
update branch to repo
|
||||
update' branch to repo
|
||||
return True
|
||||
findbest c [] = return $ Just c
|
||||
findbest c (r:rs)
|
||||
|
@ -145,7 +155,7 @@ commit commitmode allowempty message branch parentrefs repo = do
|
|||
ifM (cancommit tree)
|
||||
( do
|
||||
sha <- commitTree commitmode message parentrefs tree repo
|
||||
update branch sha repo
|
||||
update' branch sha repo
|
||||
return $ Just sha
|
||||
, return Nothing
|
||||
)
|
||||
|
@ -175,8 +185,17 @@ forcePush :: String -> String
|
|||
forcePush b = "+" ++ b
|
||||
|
||||
{- Updates a branch (or other ref) to a new Sha. -}
|
||||
update :: Branch -> Sha -> Repo -> IO ()
|
||||
update branch sha = run
|
||||
update :: String -> Branch -> Sha -> Repo -> IO ()
|
||||
update message branch sha = run
|
||||
[ Param "update-ref"
|
||||
, Param "-m"
|
||||
, Param message
|
||||
, Param $ fromRef branch
|
||||
, Param $ fromRef sha
|
||||
]
|
||||
|
||||
update' :: Branch -> Sha -> Repo -> IO ()
|
||||
update' branch sha = run
|
||||
[ Param "update-ref"
|
||||
, Param $ fromRef branch
|
||||
, Param $ fromRef sha
|
||||
|
|
|
@ -125,15 +125,17 @@ catCommit h commitref = go <$> catObjectDetails h commitref
|
|||
parseCommit :: L.ByteString -> Maybe Commit
|
||||
parseCommit b = Commit
|
||||
<$> (extractSha . L8.unpack =<< field "tree")
|
||||
<*> Just (maybe [] (mapMaybe (extractSha . L8.unpack)) (fields "parent"))
|
||||
<*> (parsemetadata <$> field "author")
|
||||
<*> (parsemetadata <$> field "committer")
|
||||
<*> Just (L8.unpack $ L.intercalate (L.singleton nl) message)
|
||||
where
|
||||
field n = M.lookup (fromString n) fields
|
||||
fields = M.fromList ((map breakfield) header)
|
||||
field n = headMaybe =<< fields n
|
||||
fields n = M.lookup (fromString n) fieldmap
|
||||
fieldmap = M.fromListWith (++) ((map breakfield) header)
|
||||
breakfield l =
|
||||
let (k, sp_v) = L.break (== sp) l
|
||||
in (k, L.drop 1 sp_v)
|
||||
in (k, [L.drop 1 sp_v])
|
||||
(header, message) = separate L.null ls
|
||||
ls = L.split nl b
|
||||
|
||||
|
|
|
@ -14,6 +14,7 @@ module Git.DiffTree (
|
|||
diffWorkTree,
|
||||
diffFiles,
|
||||
diffLog,
|
||||
commitDiff,
|
||||
) where
|
||||
|
||||
import Numeric
|
||||
|
@ -72,16 +73,23 @@ diffFiles :: [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
|
|||
diffFiles = getdiff (Param "diff-files")
|
||||
|
||||
{- Runs git log in --raw mode to get the changes that were made in
|
||||
- a particular commit. The output format is adjusted to be the same
|
||||
- as diff-tree --raw._-}
|
||||
- a particular commit to particular files. The output format
|
||||
- is adjusted to be the same as diff-tree --raw._-}
|
||||
diffLog :: [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
|
||||
diffLog params = getdiff (Param "log")
|
||||
(Param "-n1" : Param "--abbrev=40" : Param "--pretty=format:" : params)
|
||||
|
||||
{- Uses git show to get the changes made by a commit.
|
||||
-
|
||||
- Does not support merge commits, and will fail on them. -}
|
||||
commitDiff :: Sha -> Repo -> IO ([DiffTreeItem], IO Bool)
|
||||
commitDiff ref = getdiff (Param "show")
|
||||
[ Param "--abbrev=40", Param "--pretty=", Param "--raw", Param (fromRef ref) ]
|
||||
|
||||
getdiff :: CommandParam -> [CommandParam] -> Repo -> IO ([DiffTreeItem], IO Bool)
|
||||
getdiff command params repo = do
|
||||
(diff, cleanup) <- pipeNullSplit ps repo
|
||||
return (parseDiffRaw diff, cleanup)
|
||||
return (fromMaybe (error $ "git " ++ show (toCommand ps) ++ " parse failed") (parseDiffRaw diff), cleanup)
|
||||
where
|
||||
ps =
|
||||
command :
|
||||
|
@ -92,23 +100,24 @@ getdiff command params repo = do
|
|||
params
|
||||
|
||||
{- Parses --raw output used by diff-tree and git-log. -}
|
||||
parseDiffRaw :: [String] -> [DiffTreeItem]
|
||||
parseDiffRaw :: [String] -> Maybe [DiffTreeItem]
|
||||
parseDiffRaw l = go l []
|
||||
where
|
||||
go [] c = c
|
||||
go (info:f:rest) c = go rest (mk info f : c)
|
||||
go (s:[]) _ = error $ "diff-tree parse error " ++ s
|
||||
go [] c = Just c
|
||||
go (info:f:rest) c = case mk info f of
|
||||
Nothing -> Nothing
|
||||
Just i -> go rest (i:c)
|
||||
go (_:[]) _ = Nothing
|
||||
|
||||
mk info f = DiffTreeItem
|
||||
{ srcmode = readmode srcm
|
||||
, dstmode = readmode dstm
|
||||
, srcsha = fromMaybe (error "bad srcsha") $ extractSha ssha
|
||||
, dstsha = fromMaybe (error "bad dstsha") $ extractSha dsha
|
||||
, status = s
|
||||
, file = asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f
|
||||
}
|
||||
mk info f = DiffTreeItem
|
||||
<$> readmode srcm
|
||||
<*> readmode dstm
|
||||
<*> extractSha ssha
|
||||
<*> extractSha dsha
|
||||
<*> pure s
|
||||
<*> pure (asTopFilePath $ fromInternalGitPath $ Git.Filename.decode f)
|
||||
where
|
||||
readmode = fst . Prelude.head . readOct
|
||||
readmode = fst <$$> headMaybe . readOct
|
||||
|
||||
-- info = :<srcmode> SP <dstmode> SP <srcsha> SP <dstsha> SP <status>
|
||||
-- All fields are fixed, so we can pull them out of
|
||||
|
|
|
@ -31,7 +31,7 @@ import qualified System.FilePath.Posix
|
|||
|
||||
{- A FilePath, relative to the top of the git repository. -}
|
||||
newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath }
|
||||
deriving (Show, Eq)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
{- Path to a TopFilePath, within the provided git repo. -}
|
||||
fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
|
||||
|
|
78
Git/LockFile.hs
Normal file
78
Git/LockFile.hs
Normal file
|
@ -0,0 +1,78 @@
|
|||
{- git lock files
|
||||
-
|
||||
- Copyright 2016 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Git.LockFile where
|
||||
|
||||
import Common
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
import System.Posix.Types
|
||||
#else
|
||||
import System.Win32.Types
|
||||
import System.Win32.File
|
||||
#endif
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
data LockHandle = LockHandle FilePath Fd
|
||||
#else
|
||||
data LockHandle = LockHandle FilePath HANDLE
|
||||
#endif
|
||||
|
||||
{- Uses the same exclusive locking that git does.
|
||||
- Throws an IO exception if the file is already locked.
|
||||
-
|
||||
- Note that git's locking method suffers from the problem that
|
||||
- a dangling lock can be left if a process is terminated at the wrong
|
||||
- time.
|
||||
-}
|
||||
openLock :: FilePath -> IO LockHandle
|
||||
openLock lck = openLock' lck `catchNonAsync` lckerr
|
||||
where
|
||||
lckerr e = do
|
||||
-- Same error message displayed by git.
|
||||
whenM (doesFileExist lck) $
|
||||
hPutStrLn stderr $ unlines
|
||||
[ "fatal: Unable to create '" ++ lck ++ "': " ++ show e
|
||||
, ""
|
||||
, "If no other git process is currently running, this probably means a"
|
||||
, "git process crashed in this repository earlier. Make sure no other git"
|
||||
, "process is running and remove the file manually to continue."
|
||||
]
|
||||
throwM e
|
||||
|
||||
openLock' :: FilePath -> IO LockHandle
|
||||
openLock' lck = do
|
||||
#ifndef mingw32_HOST_OS
|
||||
-- On unix, git simply uses O_EXCL
|
||||
h <- openFd lck ReadWrite (Just 0O666)
|
||||
(defaultFileFlags { exclusive = True })
|
||||
setFdOption h CloseOnExec True
|
||||
#else
|
||||
-- It's not entirely clear how git manages locking on Windows,
|
||||
-- since it's buried in the portability layer, and different
|
||||
-- versions of git for windows use different portability layers.
|
||||
-- But, we can be fairly sure that holding the lock file open on
|
||||
-- windows is enough to prevent another process from opening it.
|
||||
--
|
||||
-- So, all that's needed is a way to open the file, that fails
|
||||
-- if the file already exists. Using CreateFile with CREATE_NEW
|
||||
-- accomplishes that.
|
||||
h <- createFile lck gENERIC_WRITE fILE_SHARE_NONE Nothing
|
||||
cREATE_NEW fILE_ATTRIBUTE_NORMAL Nothing
|
||||
#endif
|
||||
return (LockHandle lck h)
|
||||
|
||||
closeLock :: LockHandle -> IO ()
|
||||
closeLock (LockHandle lck h) = do
|
||||
#ifndef mingw32_HOST_OS
|
||||
closeFd h
|
||||
#else
|
||||
closeHandle h
|
||||
#endif
|
||||
removeFile lck
|
|
@ -31,11 +31,14 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
|
|||
| prefix `isPrefixOf` s = drop (length prefix) s
|
||||
| otherwise = s
|
||||
|
||||
{- Gets the basename of any qualified ref. -}
|
||||
basename :: Ref -> Ref
|
||||
basename = Ref . reverse . takeWhile (/= '/') . reverse . fromRef
|
||||
|
||||
{- Given a directory and any ref, takes the basename of the ref and puts
|
||||
- it under the directory. -}
|
||||
under :: String -> Ref -> Ref
|
||||
under dir r = Ref $ dir ++ "/" ++
|
||||
(reverse $ takeWhile (/= '/') $ reverse $ fromRef r)
|
||||
under dir r = Ref $ dir ++ "/" ++ fromRef (basename r)
|
||||
|
||||
{- Given a directory such as "refs/remotes/origin", and a ref such as
|
||||
- refs/heads/master, yields a version of that ref under the directory,
|
||||
|
|
182
Git/Tree.hs
182
Git/Tree.hs
|
@ -5,7 +5,7 @@
|
|||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}
|
||||
|
||||
module Git.Tree (
|
||||
Tree(..),
|
||||
|
@ -28,6 +28,8 @@ import qualified Utility.CoProcess as CoProcess
|
|||
import Numeric
|
||||
import System.Posix.Types
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
|
||||
newtype Tree = Tree [TreeContent]
|
||||
deriving (Show)
|
||||
|
@ -38,7 +40,7 @@ data TreeContent
|
|||
| RecordedSubTree TopFilePath Sha [TreeContent]
|
||||
-- A subtree that has not yet been recorded in git.
|
||||
| NewSubTree TopFilePath [TreeContent]
|
||||
deriving (Show)
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
{- Gets the Tree for a Ref. -}
|
||||
getTree :: Ref -> Repo -> IO Tree
|
||||
|
@ -107,74 +109,154 @@ mkTreeOutput fm ot s f = concat
|
|||
]
|
||||
|
||||
data TreeItem = TreeItem TopFilePath FileMode Sha
|
||||
deriving (Eq)
|
||||
deriving (Show, Eq)
|
||||
|
||||
treeItemToTreeContent :: TreeItem -> TreeContent
|
||||
treeItemToTreeContent (TreeItem f m s) = TreeBlob f m s
|
||||
|
||||
treeItemsToTree :: [TreeItem] -> Tree
|
||||
treeItemsToTree = go M.empty
|
||||
where
|
||||
go m [] = Tree $ filter (notElem '/' . gitPath) (M.elems m)
|
||||
go m (i:is)
|
||||
| '/' `notElem` p =
|
||||
go (M.insert p (treeItemToTreeContent i) m) is
|
||||
| otherwise = case M.lookup idir m of
|
||||
Just (NewSubTree d l) ->
|
||||
go (addsubtree idir m (NewSubTree d (c:l))) is
|
||||
_ ->
|
||||
go (addsubtree idir m (NewSubTree (asTopFilePath idir) [c])) is
|
||||
where
|
||||
p = gitPath i
|
||||
idir = takeDirectory p
|
||||
c = treeItemToTreeContent i
|
||||
|
||||
addsubtree d m t
|
||||
| elem '/' d =
|
||||
let m' = M.insert d t m
|
||||
in case M.lookup parent m' of
|
||||
Just (NewSubTree d' l) ->
|
||||
let l' = filter (\ti -> gitPath ti /= d) l
|
||||
in addsubtree parent m' (NewSubTree d' (t:l'))
|
||||
_ -> addsubtree parent m' (NewSubTree (asTopFilePath parent) [t])
|
||||
| otherwise = M.insert d t m
|
||||
where
|
||||
parent = takeDirectory d
|
||||
|
||||
{- Applies an adjustment to items in a tree.
|
||||
-
|
||||
- While less flexible than using getTree and recordTree, this avoids
|
||||
- buffering the whole tree in memory.
|
||||
- While less flexible than using getTree and recordTree,
|
||||
- this avoids buffering the whole tree in memory.
|
||||
-}
|
||||
adjustTree :: (MonadIO m, MonadMask m) => (TreeItem -> m (Maybe TreeItem)) -> Ref -> Repo -> m Sha
|
||||
adjustTree adjust r repo = withMkTreeHandle repo $ \h -> do
|
||||
(l, cleanup) <- liftIO $ lsTreeWithObjects r repo
|
||||
(l', _, _) <- go h False [] topTree l
|
||||
sha <- liftIO $ mkTree h l'
|
||||
void $ liftIO cleanup
|
||||
return sha
|
||||
adjustTree
|
||||
:: (MonadIO m, MonadMask m)
|
||||
=> (TreeItem -> m (Maybe TreeItem))
|
||||
-- ^ Adjust an item in the tree. Nothing deletes the item.
|
||||
-- Cannot move the item to a different tree.
|
||||
-> [TreeItem]
|
||||
-- ^ New items to add to the tree.
|
||||
-> [TopFilePath]
|
||||
-- ^ Files to remove from the tree.
|
||||
-> Ref
|
||||
-> Repo
|
||||
-> m Sha
|
||||
adjustTree adjusttreeitem addtreeitems removefiles r repo =
|
||||
withMkTreeHandle repo $ \h -> do
|
||||
(l, cleanup) <- liftIO $ lsTreeWithObjects r repo
|
||||
(l', _, _) <- go h False [] inTopTree l
|
||||
l'' <- adjustlist h inTopTree (const True) l'
|
||||
sha <- liftIO $ mkTree h l''
|
||||
void $ liftIO cleanup
|
||||
return sha
|
||||
where
|
||||
go _ wasmodified c _ [] = return (c, wasmodified, [])
|
||||
go h wasmodified c intree (i:is)
|
||||
| intree i =
|
||||
case readObjectType (LsTree.typeobj i) of
|
||||
Just BlobObject -> do
|
||||
let ti = TreeItem (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
|
||||
v <- adjust ti
|
||||
case v of
|
||||
Nothing -> go h True c intree is
|
||||
Just ti'@(TreeItem f m s) ->
|
||||
let !modified = wasmodified || ti' /= ti
|
||||
blob = TreeBlob f m s
|
||||
in go h modified (blob:c) intree is
|
||||
Just TreeObject -> do
|
||||
(sl, modified, is') <- go h False [] (subTree i) is
|
||||
subtree <- if modified
|
||||
then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl
|
||||
else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) []
|
||||
let !modified' = modified || wasmodified
|
||||
go h modified' (subtree : c) intree is'
|
||||
_ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
|
||||
| intree i = case readObjectType (LsTree.typeobj i) of
|
||||
Just BlobObject -> do
|
||||
let ti = TreeItem (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
|
||||
v <- adjusttreeitem ti
|
||||
case v of
|
||||
Nothing -> go h True c intree is
|
||||
Just ti'@(TreeItem f m s) ->
|
||||
let !modified = wasmodified || ti' /= ti
|
||||
blob = TreeBlob f m s
|
||||
in go h modified (blob:c) intree is
|
||||
Just TreeObject -> do
|
||||
(sl, modified, is') <- go h False [] (beneathSubTree i) is
|
||||
sl' <- adjustlist h (inTree i) (beneathSubTree i) sl
|
||||
subtree <- if modified || sl' /= sl
|
||||
then liftIO $ recordSubTree h $ NewSubTree (LsTree.file i) sl'
|
||||
else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) []
|
||||
let !modified' = modified || wasmodified
|
||||
go h modified' (subtree : c) intree is'
|
||||
_ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
|
||||
| otherwise = return (c, wasmodified, i:is)
|
||||
|
||||
adjustlist h ishere underhere l = do
|
||||
let (addhere, rest) = partition ishere addtreeitems
|
||||
let l' = filter (not . removed) $
|
||||
map treeItemToTreeContent addhere ++ l
|
||||
let inl i = any (\t -> beneathSubTree t i) l'
|
||||
let (Tree addunderhere) = treeItemsToTree $
|
||||
filter (\i -> underhere i && not (inl i)) rest
|
||||
addunderhere' <- liftIO $ mapM (recordSubTree h) addunderhere
|
||||
return (addunderhere'++l')
|
||||
|
||||
removeset = S.fromList removefiles
|
||||
removed (TreeBlob f _ _) = S.member f removeset
|
||||
removed _ = False
|
||||
|
||||
{- Assumes the list is ordered, with tree objects coming right before their
|
||||
- contents. -}
|
||||
extractTree :: [LsTree.TreeItem] -> Either String Tree
|
||||
extractTree l = case go [] topTree l of
|
||||
extractTree l = case go [] inTopTree l of
|
||||
Right (t, []) -> Right (Tree t)
|
||||
Right _ -> parseerr "unexpected tree form"
|
||||
Left e -> parseerr e
|
||||
where
|
||||
go t _ [] = Right (t, [])
|
||||
go t intree (i:is)
|
||||
| intree i =
|
||||
case readObjectType (LsTree.typeobj i) of
|
||||
Just BlobObject ->
|
||||
let b = TreeBlob (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
|
||||
in go (b:t) intree is
|
||||
Just TreeObject -> case go [] (subTree i) is of
|
||||
Right (subtree, is') ->
|
||||
let st = RecordedSubTree (LsTree.file i) (LsTree.sha i) subtree
|
||||
in go (st:t) intree is'
|
||||
Left e -> Left e
|
||||
_ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
|
||||
| intree i = case readObjectType (LsTree.typeobj i) of
|
||||
Just BlobObject ->
|
||||
let b = TreeBlob (LsTree.file i) (LsTree.mode i) (LsTree.sha i)
|
||||
in go (b:t) intree is
|
||||
Just TreeObject -> case go [] (beneathSubTree i) is of
|
||||
Right (subtree, is') ->
|
||||
let st = RecordedSubTree (LsTree.file i) (LsTree.sha i) subtree
|
||||
in go (st:t) intree is'
|
||||
Left e -> Left e
|
||||
_ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"")
|
||||
| otherwise = Right (t, i:is)
|
||||
parseerr = Left
|
||||
|
||||
type InTree = LsTree.TreeItem -> Bool
|
||||
class GitPath t where
|
||||
gitPath :: t -> FilePath
|
||||
|
||||
topTree :: InTree
|
||||
topTree = notElem '/' . getTopFilePath . LsTree.file
|
||||
instance GitPath FilePath where
|
||||
gitPath = id
|
||||
|
||||
subTree :: LsTree.TreeItem -> InTree
|
||||
subTree t =
|
||||
let prefix = getTopFilePath (LsTree.file t) ++ "/"
|
||||
in (\i -> prefix `isPrefixOf` getTopFilePath (LsTree.file i))
|
||||
instance GitPath TopFilePath where
|
||||
gitPath = getTopFilePath
|
||||
|
||||
instance GitPath TreeItem where
|
||||
gitPath (TreeItem f _ _) = gitPath f
|
||||
|
||||
instance GitPath LsTree.TreeItem where
|
||||
gitPath = gitPath . LsTree.file
|
||||
|
||||
instance GitPath TreeContent where
|
||||
gitPath (TreeBlob f _ _) = gitPath f
|
||||
gitPath (RecordedSubTree f _ _) = gitPath f
|
||||
gitPath (NewSubTree f _) = gitPath f
|
||||
|
||||
inTopTree :: GitPath t => t -> Bool
|
||||
inTopTree = inTree "."
|
||||
|
||||
inTree :: (GitPath t, GitPath f) => t -> f -> Bool
|
||||
inTree t f = gitPath t == takeDirectory (gitPath f)
|
||||
|
||||
beneathSubTree :: (GitPath t, GitPath f) => t -> f -> Bool
|
||||
beneathSubTree t f = prefix `isPrefixOf` gitPath f
|
||||
where
|
||||
tp = gitPath t
|
||||
prefix = if null tp then tp else tp ++ "/"
|
||||
|
|
|
@ -105,6 +105,7 @@ fromBlobType SymlinkBlob = 0o120000
|
|||
|
||||
data Commit = Commit
|
||||
{ commitTree :: Sha
|
||||
, commitParent :: [Sha]
|
||||
, commitAuthorMetaData :: CommitMetaData
|
||||
, commitCommitterMetaData :: CommitMetaData
|
||||
, commitMessage :: String
|
||||
|
|
4
debian/changelog
vendored
4
debian/changelog
vendored
|
@ -1,5 +1,9 @@
|
|||
git-annex (6.20160319) UNRELEASED; urgency=medium
|
||||
|
||||
* adjust --unlock: Enters an adjusted branch in which all annexed files
|
||||
are unlocked. The v6 equivilant of direct mode, but much cleaner!
|
||||
* init --version=6: Automatically enter the adjusted unlocked branch
|
||||
when filesystem doesn't support symlinks.
|
||||
* ddar remote: fix ssh calls
|
||||
Thanks, Robie Basak
|
||||
* log: Display time with time zone.
|
||||
|
|
|
@ -62,12 +62,9 @@ it, so C does not remain in the adjusted branch history either. This will
|
|||
make other checkouts that are in the same adjusted branch end up with the
|
||||
same B' commit when they pull B.
|
||||
|
||||
It might be useful to have a post-commit hook that generates B and B'
|
||||
and updates the branches. And/or `git-annex sync` could do it.
|
||||
|
||||
There may be multiple commits made to the adjusted branch before any get
|
||||
applied back to the original branch. This is handled by reverse filtering
|
||||
one at a time and rebasing the others on top.
|
||||
commits one at a time and rebasing the others on top.
|
||||
|
||||
master adjusted/master
|
||||
A
|
||||
|
@ -112,10 +109,10 @@ beginning the merge. There may be staged changes, or changes in the work tree.
|
|||
|
||||
First filter the new commit:
|
||||
|
||||
origin/master adjusted/master
|
||||
A
|
||||
|--------------->A'
|
||||
| |
|
||||
origin/master adjusted/master master
|
||||
A A
|
||||
|--------------->A' |
|
||||
| | |
|
||||
| |
|
||||
B
|
||||
|
|
||||
|
@ -123,10 +120,10 @@ First filter the new commit:
|
|||
|
||||
Then, merge that into adjusted/master:
|
||||
|
||||
origin/master adjusted/master
|
||||
A
|
||||
|--------------->A'
|
||||
| |
|
||||
origin/master adjusted/master master
|
||||
A A
|
||||
|--------------->A' |
|
||||
| | |
|
||||
| |
|
||||
B |
|
||||
| |
|
||||
|
@ -139,20 +136,30 @@ conflict should only affect the work tree/index, so can be resolved without
|
|||
making a commit, but B'' may end up being made to resolve a merge
|
||||
conflict.)
|
||||
|
||||
Once the merge is done, we have a commit B'' on adjusted/master. To finish,
|
||||
adjust that commit so it does not have adjusted/master as its parent.
|
||||
Once the merge is done, we have a merge commit B'' on adjusted/master.
|
||||
To finish, redo that commit so it does not have A' as its parent.
|
||||
|
||||
origin/master adjusted/master
|
||||
A
|
||||
|--------------->A'
|
||||
| |
|
||||
origin/master adjusted/master master
|
||||
A A
|
||||
|--------------->A' |
|
||||
| | |
|
||||
| |
|
||||
B
|
||||
|
|
||||
|--------------->B''
|
||||
| |
|
||||
|
||||
Finally, update master to point to B''.
|
||||
Finally, update master, by reverse filtering B''.
|
||||
|
||||
origin/master adjusted/master master
|
||||
A A
|
||||
|--------------->A' |
|
||||
| | |
|
||||
| | |
|
||||
B |
|
||||
| |
|
||||
|--------------->B'' - - - - - - -> B
|
||||
| |
|
||||
|
||||
Notice how similar this is to the commit graph. So, "fast-forward"
|
||||
merging the same B commit from origin/master will lead to an identical
|
||||
|
@ -172,48 +179,90 @@ between the adjusted work tree and pulled changes. A post-merge hook would
|
|||
be needed to re-adjust the work tree, and there would be a window where eg,
|
||||
not present files would appear in the work tree.]
|
||||
|
||||
## another merge scenario
|
||||
|
||||
Another merge scenario is when there's a new commit C on adjusted/master,
|
||||
and also a new commit B on origin/master.
|
||||
|
||||
Start by adjusting B':
|
||||
|
||||
origin/master adjusted/master master
|
||||
A A
|
||||
|--------------->A' |
|
||||
| | |
|
||||
| C'
|
||||
B
|
||||
|
|
||||
|---------->B'
|
||||
|
||||
Then, merge B' into adjusted/master:
|
||||
|
||||
origin/master adjusted/master master
|
||||
A A
|
||||
|--------------->A' |
|
||||
| | |
|
||||
| C'
|
||||
B |
|
||||
| |
|
||||
|----------->B'->M'
|
||||
|
||||
Here M' is the correct tree, but it has A' as its grandparent,
|
||||
which is the adjusted branch commit, so needs to be dropped in order to
|
||||
get a commit that can be put on master.
|
||||
|
||||
We don't want to lose commit C', but it's an adjusted
|
||||
commit, so needs to be de-adjusted.
|
||||
|
||||
origin/master adjusted/master master
|
||||
A A
|
||||
|--------------->A' |
|
||||
| | |
|
||||
| C'- - - - - - - - > C
|
||||
B |
|
||||
| |
|
||||
|----------->B'->M'
|
||||
|
|
||||
|
||||
Now, we generate a merge commit, between B and C, with known result M'
|
||||
(so no actual merging done here).
|
||||
|
||||
origin/master adjusted/master master
|
||||
A A
|
||||
|--------------->A' |
|
||||
| | |
|
||||
| C'- - - - - - - - > C
|
||||
B |
|
||||
| |
|
||||
|--------------->M'<-----------------|
|
||||
|
|
||||
|
||||
Finally, update master, by reverse filtering M'. The resulting commit
|
||||
on master will also be a merge between B and C.
|
||||
|
||||
## annex object add/remove
|
||||
|
||||
When objects are added/removed from the annex, the associated file has to
|
||||
be looked up, and the filter applied to it. So, dropping a file with the
|
||||
missing file filter would cause it to be removed from the adjusted branch,
|
||||
and receiving a file's content would cause it to appear in the adjusted
|
||||
branch.
|
||||
branch. TODO
|
||||
|
||||
These changes would need to be committed to the adjusted branch, otherwise
|
||||
`git diff` would show them.
|
||||
|
||||
[WORKTREE: Simply adjust the work tree (and index) per the filter.]
|
||||
|
||||
## reverse filtering
|
||||
## reverse filtering commits
|
||||
|
||||
Reversing filter #1 would mean only converting pointer files to
|
||||
symlinks when the file was originally a symlink. This is problimatic when a
|
||||
file is renamed. Would it be ok, if foo is renamed to bar and bar is
|
||||
committed, for it to be committed as an unlocked file, even if foo was
|
||||
originally locked? Probably.
|
||||
A user's commits on the adjusted branch have to be reverse filtered
|
||||
to get changes to apply to the master branch.
|
||||
|
||||
Reversing filter #2 would mean not deleting removed files whose content was
|
||||
not present. When the commit includes deletion of files that were removed
|
||||
due to their content not being present, those deletions are not propigated.
|
||||
When the user deletes an unlocked file, the content is still
|
||||
present in annex, so reversing the filter should propigate the file
|
||||
deletion.
|
||||
This reversal of one filter can be done as just another filter.
|
||||
Since only files touched by the commit will be reverse filtered, it doesn't
|
||||
need to reverse all changes made by the original filter.
|
||||
|
||||
What if an object was sent to the annex (or removed from the annex)
|
||||
after the commit and before the reverse filtering? This would cause the
|
||||
reverse filter to draw the wrong conclusion. Maybe look at a list of what
|
||||
objects were not present when applying the filter, and use that to decide
|
||||
which to not delete when reversing it?
|
||||
|
||||
So, a reverse filter may need some state that was collected when running
|
||||
the filter forwards, in order to decide what to do.
|
||||
|
||||
Alternatively, instead of reverse filtering the whole adjusted tree,
|
||||
look at just the new commit that's being propigated back from the
|
||||
adjusted to master branch. Get the diff from it to the previous
|
||||
commit; the changes that were made. Then de-adjust those changes,
|
||||
and apply the changes to the master branch.
|
||||
For example, reversing the unlock filter might lock the file. Or, it might
|
||||
do nothing, which would make all committed files remain unlocked.
|
||||
|
||||
## push
|
||||
|
||||
|
@ -254,8 +303,15 @@ index in that case.
|
|||
|
||||
Using `git checkout` when in an adjusted branch is problimatic, because a
|
||||
non-adjusted branch would then be checked out. But, we can just say, if
|
||||
you want to get into an adjusted branch, you have to run some command.
|
||||
Or, could make a post-checkout hook.
|
||||
you want to get into an adjusted branch, you have to run git annex adjust
|
||||
Or, could make a post-checkout hook. This is would mostly be confusing when
|
||||
git-annex init switched into the adjusted branch due to lack of symlink
|
||||
support.
|
||||
|
||||
After a commit to an adjusted branch, `git push` won't do anything. The
|
||||
user has to know to git-annex sync. (Even if a pre-commit hook propigated
|
||||
the commit back to the master branch, `git push` wouldn't push it with the
|
||||
default "matching" push strategy.)
|
||||
|
||||
Tags are bit of a problem. If the user tags an ajusted branch, the tag
|
||||
includes the local adjustments.
|
||||
|
@ -282,47 +338,23 @@ adjusting filter, albeit an extreme one. This might improve view branches.
|
|||
For example, it's not currently possible to update a view branch with
|
||||
changes fetched from a remote, and this could get us there.
|
||||
|
||||
This would need the reverse filter to be able to change metadata.
|
||||
This would need the reverse filter to be able to change metadata,
|
||||
so that a commit that moved files in the view updates their metadata.
|
||||
|
||||
[WORKTREE: Wouldn't be able to integrate, unless view branches are changed
|
||||
into adjusted view worktrees.]
|
||||
|
||||
## filter interface
|
||||
## TODOs
|
||||
|
||||
Distilling all of the above, the filter interface needs to be something
|
||||
like this, at its most simple:
|
||||
|
||||
data Filter = UnlockFilter | HideMissingFilter | UnlockHideMissingFilter
|
||||
|
||||
getFilter :: Annex Filter
|
||||
|
||||
setFilter :: Filter -> Annex ()
|
||||
|
||||
data FilterAction
|
||||
= UnchangedFile FilePath
|
||||
| UnlockFile FilePath
|
||||
| HideFile FilePath
|
||||
|
||||
data FileInfo = FileInfo
|
||||
{ originalBranchFile :: FileStatus
|
||||
, isContentPresent :: Bool
|
||||
}
|
||||
|
||||
data FileStatus = IsAnnexSymlink | IsAnnexPointer
|
||||
deriving (Eq)
|
||||
|
||||
filterAction :: Filter -> FilePath -> FileInfo -> FilterAction
|
||||
filterAction UnlockFilter f fi
|
||||
| originalBranchFile fi == IsAnnexSymlink = UnlockFile f
|
||||
filterAction HideMissingFilter f fi
|
||||
| not (isContentPresent fi) = HideFile f
|
||||
filterAction UnlockHideMissingFilter f fi
|
||||
| not (isContentPresent fi) = HideFile f
|
||||
| otherwise = filterAction UnlockFilter f fi
|
||||
filterAction _ f _ = UnchangedFile f
|
||||
|
||||
filteredCommit :: Filter -> Git.Commit -> Git.Commit
|
||||
|
||||
-- Generate a version of the commit made on the filter branch
|
||||
-- with the filtering of modified files reversed.
|
||||
unfilteredCommit :: Filter -> Git.Commit -> Git.Commit
|
||||
* Interface in webapp to enable adjustments.
|
||||
* Upgrade from direct mode to v6 in unlocked branch.
|
||||
* Honor annex.thin when entering an adjusted branch.
|
||||
* Cloning a repo that has an adjusted branch checked out gets into an ugly
|
||||
state.
|
||||
* There are potentially races in code that assumes a branch like
|
||||
master is not being changed by someone else. In particular,
|
||||
propigateAdjustedCommits rebases the adjusted branch on top of master.
|
||||
That is called by sync. The assumption is that any changes in master
|
||||
have already been handled by updateAdjustedBranch. But, if another remote
|
||||
pushed a new master at just the right time, the adjusted branch could be
|
||||
rebased on top of a master that it doesn't incorporate, which is wrong.
|
||||
|
|
50
doc/git-annex-adjust.mdwn
Normal file
50
doc/git-annex-adjust.mdwn
Normal file
|
@ -0,0 +1,50 @@
|
|||
# NAME
|
||||
|
||||
git-annex adjust - enter an adjusted branch
|
||||
|
||||
# SYNOPSIS
|
||||
|
||||
git annex adjust --unlock`
|
||||
|
||||
# DESCRIPTION
|
||||
|
||||
Enters an adjusted form of the current branch. The annexed files will
|
||||
be treated differently. For example with --unlock all annexed files will
|
||||
be unlocked.
|
||||
|
||||
The adjusted branch will have a name like "adjusted/master(unlocked)".
|
||||
Since it's a regular git branch, you can use `git checkout` to switch
|
||||
back to the original branch at any time.
|
||||
|
||||
While in the adjusted branch, you can use git-annex and git commands as
|
||||
usual. Any commits that you make will initially only be made to the
|
||||
adjusted branch.
|
||||
|
||||
To propigate changes from the adjusted branch back to the original branch,
|
||||
and to other repositories, as well as to merge in changes from other
|
||||
repositories, use `git annex sync`.
|
||||
|
||||
This command can only be used in a v6 git-annex repository.
|
||||
|
||||
# OPTIONS
|
||||
|
||||
* `--unlock`
|
||||
|
||||
Unlock all annexed files in the adjusted branch. This allows
|
||||
annexed files to be modified.
|
||||
|
||||
# SEE ALSO
|
||||
|
||||
[[git-annex]](1)
|
||||
|
||||
[[git-annex-unlock]](1)
|
||||
|
||||
[[git-annex-upgrade]](1)
|
||||
|
||||
[[git-annex-sync]](1)
|
||||
|
||||
# AUTHOR
|
||||
|
||||
Joey Hess <id@joeyh.name>
|
||||
|
||||
Warning: Automatically converted into a man page by mdwn2man. Edit with care.
|
|
@ -20,6 +20,8 @@ commands.
|
|||
Note that the direct mode/indirect mode distinction is removed in v6
|
||||
git-annex repositories. In such a repository, you can
|
||||
use [[git-annex-unlock]](1) to make a file's content be directly present.
|
||||
You can also use [[git-annex-adjust]](1) to enter a branch where all
|
||||
annexed files are unlocked, which is similar to the old direct mode.
|
||||
|
||||
# SEE ALSO
|
||||
|
||||
|
@ -29,6 +31,8 @@ use [[git-annex-unlock]](1) to make a file's content be directly present.
|
|||
|
||||
[[git-annex-unlock]](1)
|
||||
|
||||
[[git-annex-adjust]](1)
|
||||
|
||||
# AUTHOR
|
||||
|
||||
Joey Hess <id@joeyh.name>
|
||||
|
|
|
@ -295,6 +295,13 @@ subdirectories).
|
|||
|
||||
See [[git-annex-indirect]](1) for details.
|
||||
|
||||
* `adjust`
|
||||
|
||||
Switches a repository to use an adjusted branch, which can automatically
|
||||
unlock all files, etc.
|
||||
|
||||
See [[git-annex-adjust]](1) for details.
|
||||
|
||||
# REPOSITORY MAINTENANCE COMMANDS
|
||||
|
||||
* `fsck [path ...]`
|
||||
|
|
|
@ -95,6 +95,8 @@ mode is used. To make them always use unlocked mode, run:
|
|||
`git config annex.addunlocked true`
|
||||
"""]]
|
||||
|
||||
## mixing locked and unlocked files
|
||||
|
||||
A v6 repository can contain both locked and unlocked files. You can switch
|
||||
a file back and forth using the `git annex lock` and `git annex unlock`
|
||||
commands. This changes what's stored in git between a git-annex symlink
|
||||
|
@ -102,6 +104,12 @@ commands. This changes what's stored in git between a git-annex symlink
|
|||
the repository in locked mode, use `git annex add`; to add a file in
|
||||
unlocked mode, use `git add`.
|
||||
|
||||
If you want to mostly keep files locked, but be able to locally switch
|
||||
to having them all unlocked, you can do so using `git annex adjust
|
||||
--unlock`. See [[git-annex-adjust]] for details. This is particularly
|
||||
useful when using filesystems like FAT, and OS's like Windows that don't
|
||||
support symlinks.
|
||||
|
||||
## using less disk space
|
||||
|
||||
Unlocked files are handy, but they have one significant disadvantage
|
||||
|
|
|
@ -23,12 +23,6 @@ git-annex should use smudge/clean filters.
|
|||
(May need to use libgit2 to do this efficiently, cannot find
|
||||
any plumbing except git-update-index, which is very inneficient for
|
||||
smudged files.)
|
||||
* Crippled filesystem should cause all files to be transparently unlocked.
|
||||
Note that this presents problems when dealing with merge conflicts and
|
||||
when pushing changes committed in such a repo. Ideally, should avoid
|
||||
committing implicit unlocks, or should prevent such commits leaking out
|
||||
in pushes. See [[design/adjusted_branches]].
|
||||
|
||||
* Eventually (but not yet), make v6 the default for new repositories.
|
||||
Note that the assistant forces repos into direct mode; that will need to
|
||||
be changed then, and it should enable annex.thin instead.
|
||||
|
|
Loading…
Reference in a new issue