Merge branch 'adjustedbranch'

This commit is contained in:
Joey Hess 2016-03-31 19:05:47 -04:00
commit ed3e8e1886
Failed to extract signature
32 changed files with 1084 additions and 262 deletions

View file

@ -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
View 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)

View file

@ -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

View file

@ -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. -}

View file

@ -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

View file

@ -52,6 +52,9 @@ versionSupportsUnlockedPointers = go <$> getVersion
go (Just "6") = True
go _ = False
versionSupportsAdjustedBranch :: Annex Bool
versionSupportsAdjustedBranch = versionSupportsUnlockedPointers
setVersion :: Version -> Annex ()
setVersion = setConfig versionField

View file

@ -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

View file

@ -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,

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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
View 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

View file

@ -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

View file

@ -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"

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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
View 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

View file

@ -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,

View file

@ -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 ++ "/"

View file

@ -105,6 +105,7 @@ fromBlobType SymlinkBlob = 0o120000
data Commit = Commit
{ commitTree :: Sha
, commitParent :: [Sha]
, commitAuthorMetaData :: CommitMetaData
, commitCommitterMetaData :: CommitMetaData
, commitMessage :: String

4
debian/changelog vendored
View file

@ -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.

View file

@ -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
View 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.

View file

@ -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>

View file

@ -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 ...]`

View file

@ -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

View file

@ -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.