diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -143,6 +143,7 @@ , sentinalstatus :: Maybe SentinalStatus , useragent :: Maybe String , errcounter :: Integer + , adjustedbranchrefreshcounter :: Integer , unusedkeys :: Maybe (S.Set Key) , tempurls :: M.Map Key URLString , existinghooks :: M.Map Git.Hook.Hook Bool @@ -203,6 +204,7 @@ , sentinalstatus = Nothing , useragent = Nothing , errcounter = 0 + , adjustedbranchrefreshcounter = 0 , unusedkeys = Nothing , tempurls = M.empty , existinghooks = M.empty @@ -399,8 +401,8 @@ incError :: Annex () incError = changeState $ \s -> - let ! c = errcounter s + 1 - ! s' = s { errcounter = c } + let !c = errcounter s + 1 + !s' = s { errcounter = c } in s' getGitRemotes :: Annex [Git.Repo] diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -11,7 +11,9 @@ Adjustment(..), LinkAdjustment(..), PresenceAdjustment(..), + LinkPresentAdjustment(..), adjustmentHidesFiles, + adjustmentIsStable, OrigBranch, AdjBranch(..), originalToAdjusted, @@ -19,11 +21,20 @@ fromAdjustedBranch, getAdjustment, enterAdjustedBranch, - updateAdjustedBranch, + adjustedBranchRefresh, + adjustedBranchRefreshFull, adjustBranch, + adjustTree, adjustToCrippledFileSystem, - mergeToAdjustedBranch, + commitForAdjustedBranch, propigateAdjustedCommits, + propigateAdjustedCommits', + commitAdjustedTree, + commitAdjustedTree', + BasisBranch(..), + basisBranch, + setBasisBranch, + preventCommits, AdjustedClone(..), checkAdjustedClone, checkVersionSupported, @@ -34,6 +45,7 @@ import Types.AdjustedBranch import Annex.AdjustedBranch.Name import qualified Annex +import qualified Annex.Queue import Git import Git.Types import qualified Git.Branch @@ -41,7 +53,6 @@ import qualified Git.Command import qualified Git.Tree import qualified Git.DiffTree -import qualified Git.Merge import Git.Tree (TreeItem(..)) import Git.Sha import Git.Env @@ -51,23 +62,19 @@ import qualified Git.Version import Annex.CatFile import Annex.Link -import Annex.AutoMerge -import Annex.Content -import Annex.Tmp -import Annex.GitOverlay -import Utility.Tmp.Dir -import Utility.CopyFile -import Utility.Directory.Create +import Annex.Content.Presence +import Annex.CurrentBranch +import Types.CleanupActions import qualified Database.Keys import Config import qualified Data.Map as M -import qualified Data.ByteString as S -import qualified System.FilePath.ByteString as P --- How to perform various adjustments to a TreeItem. class AdjustTreeItem t where + -- How to perform various adjustments to a TreeItem. adjustTreeItem :: t -> TreeItem -> Annex (Maybe TreeItem) + -- Will adjusting a given tree always yield the same adjusted tree? + adjustmentIsStable :: t -> Bool instance AdjustTreeItem Adjustment where adjustTreeItem (LinkAdjustment l) t = adjustTreeItem l t @@ -76,31 +83,72 @@ adjustTreeItem p t >>= \case Nothing -> return Nothing Just t' -> adjustTreeItem l t' + adjustTreeItem (LinkPresentAdjustment l) t = adjustTreeItem l t + adjustmentIsStable (LinkAdjustment l) = adjustmentIsStable l + adjustmentIsStable (PresenceAdjustment p _) = adjustmentIsStable p + adjustmentIsStable (LinkPresentAdjustment l) = adjustmentIsStable l + instance AdjustTreeItem LinkAdjustment where - adjustTreeItem UnlockAdjustment = ifSymlink adjustToPointer noAdjust - adjustTreeItem LockAdjustment = ifSymlink noAdjust adjustToSymlink - adjustTreeItem FixAdjustment = ifSymlink adjustToSymlink noAdjust - adjustTreeItem UnFixAdjustment = ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust + adjustTreeItem UnlockAdjustment = + ifSymlink adjustToPointer noAdjust + adjustTreeItem LockAdjustment = + ifSymlink noAdjust adjustToSymlink + adjustTreeItem FixAdjustment = + ifSymlink adjustToSymlink noAdjust + adjustTreeItem UnFixAdjustment = + ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust + + adjustmentIsStable _ = True instance AdjustTreeItem PresenceAdjustment where - adjustTreeItem HideMissingAdjustment = \ti@(TreeItem _ _ s) -> - catKey s >>= \case - Just k -> ifM (inAnnex k) - ( return (Just ti) - , return Nothing - ) - Nothing -> return (Just ti) - adjustTreeItem ShowMissingAdjustment = noAdjust + adjustTreeItem HideMissingAdjustment = + ifPresent noAdjust hideAdjust + adjustTreeItem ShowMissingAdjustment = + noAdjust -ifSymlink :: (TreeItem -> Annex a) -> (TreeItem -> Annex a) -> TreeItem -> Annex a + adjustmentIsStable HideMissingAdjustment = False + adjustmentIsStable ShowMissingAdjustment = True + +instance AdjustTreeItem LinkPresentAdjustment where + adjustTreeItem UnlockPresentAdjustment = + ifPresent adjustToPointer adjustToSymlink + adjustTreeItem LockPresentAdjustment = + -- Turn all pointers back to symlinks, whether the content + -- is present or not. This is done because the content + -- availability may have changed and the branch not been + -- re-adjusted to keep up, so there may be pointers whose + -- content is not present. + ifSymlink noAdjust adjustToSymlink + + adjustmentIsStable UnlockPresentAdjustment = False + adjustmentIsStable LockPresentAdjustment = True + +ifSymlink + :: (TreeItem -> Annex a) + -> (TreeItem -> Annex a) + -> TreeItem + -> Annex a ifSymlink issymlink notsymlink ti@(TreeItem _f m _s) | toTreeItemType m == Just TreeSymlink = issymlink ti | otherwise = notsymlink ti +ifPresent + :: (TreeItem -> Annex (Maybe TreeItem)) + -> (TreeItem -> Annex (Maybe TreeItem)) + -> TreeItem + -> Annex (Maybe TreeItem) +ifPresent ispresent notpresent ti@(TreeItem _ _ s) = + catKey s >>= \case + Just k -> ifM (inAnnex k) (ispresent ti, notpresent ti) + Nothing -> return (Just ti) + noAdjust :: TreeItem -> Annex (Maybe TreeItem) noAdjust = return . Just +hideAdjust :: TreeItem -> Annex (Maybe TreeItem) +hideAdjust _ = return Nothing + adjustToPointer :: TreeItem -> Annex (Maybe TreeItem) adjustToPointer ti@(TreeItem f _m s) = catKey s >>= \case Just k -> do @@ -177,70 +225,125 @@ , do b <- preventCommits $ const $ adjustBranch adj origbranch - checkoutAdjustedBranch b [] + checkoutAdjustedBranch b False ) -checkoutAdjustedBranch :: AdjBranch -> [CommandParam] -> Annex Bool -checkoutAdjustedBranch (AdjBranch b) checkoutparams = do - showOutput -- checkout can have output in large repos +checkoutAdjustedBranch :: AdjBranch -> Bool -> Annex Bool +checkoutAdjustedBranch (AdjBranch b) quietcheckout = do + -- checkout can have output in large repos + unless quietcheckout + showOutput inRepo $ Git.Command.runBool $ [ Param "checkout" , Param $ fromRef $ Git.Ref.base b - -- always show checkout progress, even if --quiet is used - -- to suppress other messages - , Param "--progress" - ] ++ checkoutparams + , if quietcheckout then Param "--quiet" else Param "--progress" + ] {- Already in a branch with this adjustment, but the user asked to enter it - - again. This should have the same result as checking out the original branch, - - deleting and rebuilding the adjusted branch, and then checking it out. + - again. This should have the same result as propagating any commits + - back to the original branch, checking out the original branch, deleting + - and rebuilding the adjusted branch, and then checking it out. - But, it can be implemented more efficiently than that. -} updateAdjustedBranch :: Adjustment -> AdjBranch -> OrigBranch -> Annex Bool -updateAdjustedBranch adj@(PresenceAdjustment _ _) (AdjBranch currbranch) origbranch = do - b <- preventCommits $ \commitlck -> do - -- Avoid losing any commits that the adjusted branch has that - -- have not yet been propigated back to the origbranch. - _ <- propigateAdjustedCommits' origbranch adj commitlck +updateAdjustedBranch adj (AdjBranch currbranch) origbranch + | not (adjustmentIsStable adj) = do + b <- preventCommits $ \commitlck -> do + -- Avoid losing any commits that the adjusted branch + -- has that have not yet been propigated back to the + -- origbranch. + _ <- propigateAdjustedCommits' origbranch adj commitlck - -- Git normally won't do anything when asked to check out the - -- currently checked out branch, even when its ref has - -- changed. Work around this by writing a raw sha to .git/HEAD. - inRepo (Git.Ref.sha currbranch) >>= \case - Just headsha -> inRepo $ \r -> - writeFile (Git.Ref.headFile r) (fromRef headsha) - _ -> noop + -- Git normally won't do anything when asked to check + -- out the currently checked out branch, even when its + -- ref has changed. Work around this by writing a raw + -- sha to .git/HEAD. + inRepo (Git.Ref.sha currbranch) >>= \case + Just headsha -> inRepo $ \r -> + writeFile (Git.Ref.headFile r) (fromRef headsha) + _ -> noop - adjustBranch adj origbranch + adjustBranch adj origbranch - -- Make git checkout quiet to avoid warnings about disconnected - -- branch tips being lost. - checkoutAdjustedBranch b [Param "--quiet"] -updateAdjustedBranch adj@(LinkAdjustment _) _ origbranch = preventCommits $ \commitlck -> do - -- Not really needed here, but done for consistency. - _ <- propigateAdjustedCommits' origbranch adj commitlck - -- No need to do anything else, because link adjustments are stable. - return True + -- Make git checkout quiet to avoid warnings about + -- disconnected branch tips being lost. + checkoutAdjustedBranch b True + | otherwise = preventCommits $ \commitlck -> do + -- Done for consistency. + _ <- propigateAdjustedCommits' origbranch adj commitlck + -- No need to actually update the branch because the + -- adjustment is stable. + return True +{- Passed an action that, if it succeeds may get or drop the Key associated + - with the file. When the adjusted branch needs to be refreshed to reflect + - those changes, it's handled here. + - + - Note that the AssociatedFile must be verified by this to point to the + - Key. In some cases, the value was provided by the user and might not + - really be an associated file. + -} +adjustedBranchRefresh :: AssociatedFile -> Annex a -> Annex a +adjustedBranchRefresh _af a = do + r <- a + annexAdjustedBranchRefresh <$> Annex.getGitConfig >>= \case + 0 -> return () + n -> go n + return r + where + go n = getCurrentBranch >>= \case + (Just origbranch, Just adj) -> + unless (adjustmentIsStable adj) $ + ifM (checkcounter n) + ( update adj origbranch + , Annex.addCleanup AdjustedBranchUpdate $ + adjustedBranchRefreshFull adj origbranch + ) + _ -> return () + + checkcounter n + -- Special case, 1 (or true) refreshes only at shutdown. + | n == 1 = pure False + | otherwise = Annex.withState $ \s -> + let !c = Annex.adjustedbranchrefreshcounter s + 1 + !enough = c >= pred n + !c' = if enough then 0 else c + !s' = s { Annex.adjustedbranchrefreshcounter = c' } + in pure (s', enough) + + update adj origbranch = do + -- Flush the queue, to make any pending changes be written + -- out to disk. But mostly so any pointer files + -- restagePointerFile was called on get updated so git + -- checkout won't fall over. + Annex.Queue.flush + -- This is slow, it would be better to incrementally + -- adjust the AssociatedFile, and only call this once + -- at shutdown to handle cases where not all + -- AssociatedFiles are known. + adjustedBranchRefreshFull adj origbranch + +{- Slow, but more dependable version of adjustedBranchRefresh that + - does not rely on all AssociatedFiles being known. -} +adjustedBranchRefreshFull :: Adjustment -> OrigBranch -> Annex () +adjustedBranchRefreshFull adj origbranch = do + let adjbranch = originalToAdjusted origbranch adj + unlessM (updateAdjustedBranch adj adjbranch origbranch) $ + warning $ unwords [ "Updating adjusted branch failed." ] + adjustToCrippledFileSystem :: Annex () adjustToCrippledFileSystem = do warning "Entering an adjusted branch where files are unlocked as this filesystem does not support locked files." checkVersionSupported - whenM (isNothing <$> inRepo Git.Branch.current) $ do - cmode <- annexCommitMode <$> Annex.getGitConfig - void $ inRepo $ Git.Branch.commitCommand cmode - [ Param "--quiet" - , Param "--allow-empty" - , Param "-m" - , Param "commit before entering adjusted unlocked branch" - ] + whenM (isNothing <$> inRepo Git.Branch.current) $ + commitForAdjustedBranch [] inRepo Git.Branch.current >>= \case Just currbranch -> case getAdjustment currbranch of Just curradj | curradj == adj -> return () _ -> do let adjbranch = originalToAdjusted currbranch adj ifM (inRepo (Git.Ref.exists $ adjBranch adjbranch)) - ( unlessM (checkoutAdjustedBranch adjbranch []) $ + ( unlessM (checkoutAdjustedBranch adjbranch False) $ failedenter , unlessM (enterAdjustedBranch adj) $ failedenter @@ -250,6 +353,22 @@ adj = LinkAdjustment UnlockAdjustment failedenter = warning "Failed to enter adjusted branch!" +{- Commit before entering adjusted branch. Only needs to be done + - when the current branch does not have any commits yet. + - + - If something is already staged, it will be committed, but otherwise + - an empty commit will be made. + -} +commitForAdjustedBranch :: [CommandParam] -> Annex () +commitForAdjustedBranch ps = do + cmode <- annexCommitMode <$> Annex.getGitConfig + void $ inRepo $ Git.Branch.commitCommand cmode $ + [ Param "--quiet" + , Param "--allow-empty" + , Param "-m" + , Param "commit before entering adjusted branch" + ] ++ ps + setBasisBranch :: BasisBranch -> Ref -> Annex () setBasisBranch (BasisBranch basis) new = inRepo $ Git.Branch.update' basis new @@ -338,137 +457,6 @@ | otherwise = case commitParent c of [p] -> go =<< catCommit p _ -> return Nothing - -{- Update the currently checked out adjusted branch, merging the provided - - branch into it. Note that the provided branch should be a non-adjusted - - branch. -} -mergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> [Git.Merge.MergeConfig] -> Bool -> Git.Branch.CommitMode -> Annex Bool -mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge commitmode = catchBoolIO $ - join $ preventCommits go - where - adjbranch@(AdjBranch currbranch) = originalToAdjusted origbranch adj - basis = basisBranch adjbranch - - go commitsprevented = - ifM (inRepo $ Git.Branch.changed currbranch tomerge) - ( do - (updatedorig, _) <- propigateAdjustedCommits' - origbranch adj commitsprevented - changestomerge updatedorig - , nochangestomerge - ) - - nochangestomerge = return $ return True - - {- Since the adjusted branch changes files, merging tomerge - - directly into it would likely result in unncessary merge - - conflicts. To avoid those conflicts, instead merge tomerge into - - updatedorig. The result of the merge can the be - - adjusted to yield the final adjusted branch. - - - - In order to do a merge into a ref that is not checked out, - - set the work tree to a temp directory, and set GIT_DIR - - to another temp directory, in which HEAD contains the - - updatedorig sha. GIT_COMMON_DIR is set to point to the real - - git directory, and so git can read and write objects from there, - - but will use GIT_DIR for HEAD and index. - - - - (Doing the merge this way also lets it run even though the main - - index file is currently locked.) - -} - changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do - git_dir <- fromRepo Git.localGitDir - let git_dir' = fromRawFilePath git_dir - tmpwt <- fromRepo gitAnnexMergeDir - withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ - withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do - liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) - -- Copy in refs and packed-refs, to work - -- around bug in git 2.13.0, which - -- causes it not to look in GIT_DIR for refs. - refs <- liftIO $ dirContentsRecursive $ - git_dir' "refs" - let refs' = (git_dir' "packed-refs") : refs - liftIO $ forM_ refs' $ \src -> - whenM (doesFileExist src) $ do - dest <- relPathDirToFile git_dir - (toRawFilePath src) - let dest' = toRawFilePath tmpgit P. dest - createDirectoryUnder git_dir - (P.takeDirectory dest') - void $ createLinkOrCopy src - (fromRawFilePath dest') - -- This reset makes git merge not care - -- that the work tree is empty; otherwise - -- it will think that all the files have - -- been staged for deletion, and sometimes - -- the merge includes these deletions - -- (for an unknown reason). - -- http://thread.gmane.org/gmane.comp.version-control.git/297237 - inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"] - showAction $ "Merging into " ++ fromRef (Git.Ref.base origbranch) - merged <- autoMergeFrom' tomerge Nothing mergeconfig commitmode True - (const $ resolveMerge (Just updatedorig) tomerge True) - if merged - then do - !mergecommit <- liftIO $ extractSha - <$> S.readFile (tmpgit "HEAD") - -- This is run after the commit lock is dropped. - return $ postmerge mergecommit - else return $ return False - changestomerge Nothing = return $ return False - - withemptydir git_dir d a = bracketIO setup cleanup (const a) - where - setup = do - whenM (doesDirectoryExist d) $ - removeDirectoryRecursive d - createDirectoryUnder git_dir (toRawFilePath d) - cleanup _ = removeDirectoryRecursive d - - {- A merge commit has been made between the basisbranch and - - tomerge. Update the basisbranch and origbranch to point - - to that commit, adjust it to get the new adjusted branch, - - and check it out. - - - - But, there may be unstaged work tree changes that conflict, - - so the check out is done by making a normal merge of - - the new adjusted branch. - -} - postmerge (Just mergecommit) = do - setBasisBranch basis mergecommit - inRepo $ Git.Branch.update' origbranch mergecommit - adjtree <- adjustTree adj (BasisBranch mergecommit) - adjmergecommit <- commitAdjustedTree adjtree (BasisBranch mergecommit) - -- Make currbranch be the parent, so that merging - -- this commit will be a fast-forward. - adjmergecommitff <- commitAdjustedTree' adjtree (BasisBranch mergecommit) [currbranch] - showAction "Merging into adjusted branch" - ifM (autoMergeFrom adjmergecommitff (Just currbranch) mergeconfig commitmode canresolvemerge) - ( reparent adjtree adjmergecommit =<< getcurrentcommit - , return False - ) - postmerge Nothing = return False - - -- Now that the merge into the adjusted branch is complete, - -- take the tree from that merge, and attach it on top of the - -- adjmergecommit, if it's different. - reparent adjtree adjmergecommit (Just currentcommit) = do - if (commitTree currentcommit /= adjtree) - then do - cmode <- annexCommitMode <$> Annex.getGitConfig - c <- inRepo $ Git.Branch.commitTree cmode - ("Merged " ++ fromRef tomerge) [adjmergecommit] - (commitTree currentcommit) - inRepo $ Git.Branch.update "updating adjusted branch" currbranch c - propigateAdjustedCommits origbranch adj - else inRepo $ Git.Branch.update "updating adjusted branch" currbranch adjmergecommit - return True - reparent _ _ Nothing = return False - - getcurrentcommit = inRepo Git.Branch.currentUnsafe >>= \case - Nothing -> return Nothing - Just c -> catCommit c {- Check for any commits present on the adjusted branch that have not yet - been propigated to the basis branch, and propigate them to the basis diff --git a/Annex/AdjustedBranch/Merge.hs b/Annex/AdjustedBranch/Merge.hs new file mode 100644 --- /dev/null +++ b/Annex/AdjustedBranch/Merge.hs @@ -0,0 +1,164 @@ +{- adjusted branch merging + - + - Copyright 2016-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +module Annex.AdjustedBranch.Merge ( + mergeToAdjustedBranch, +) where + +import Annex.Common +import Annex.AdjustedBranch +import qualified Annex +import Git +import Git.Types +import qualified Git.Branch +import qualified Git.Ref +import qualified Git.Command +import qualified Git.Merge +import Git.Sha +import Annex.CatFile +import Annex.AutoMerge +import Annex.Tmp +import Annex.GitOverlay +import Utility.Tmp.Dir +import Utility.CopyFile +import Utility.Directory.Create + +import qualified Data.ByteString as S +import qualified System.FilePath.ByteString as P + +{- Update the currently checked out adjusted branch, merging the provided + - branch into it. Note that the provided branch should be a non-adjusted + - branch. -} +mergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> [Git.Merge.MergeConfig] -> Bool -> Git.Branch.CommitMode -> Annex Bool +mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge commitmode = catchBoolIO $ + join $ preventCommits go + where + adjbranch@(AdjBranch currbranch) = originalToAdjusted origbranch adj + basis = basisBranch adjbranch + + go commitsprevented = + ifM (inRepo $ Git.Branch.changed currbranch tomerge) + ( do + (updatedorig, _) <- propigateAdjustedCommits' + origbranch adj commitsprevented + changestomerge updatedorig + , nochangestomerge + ) + + nochangestomerge = return $ return True + + {- Since the adjusted branch changes files, merging tomerge + - directly into it would likely result in unncessary merge + - conflicts. To avoid those conflicts, instead merge tomerge into + - updatedorig. The result of the merge can the be + - adjusted to yield the final adjusted branch. + - + - In order to do a merge into a ref that is not checked out, + - set the work tree to a temp directory, and set GIT_DIR + - to another temp directory, in which HEAD contains the + - updatedorig sha. GIT_COMMON_DIR is set to point to the real + - git directory, and so git can read and write objects from there, + - but will use GIT_DIR for HEAD and index. + - + - (Doing the merge this way also lets it run even though the main + - index file is currently locked.) + -} + changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do + git_dir <- fromRepo Git.localGitDir + let git_dir' = fromRawFilePath git_dir + tmpwt <- fromRepo gitAnnexMergeDir + withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $ + withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do + liftIO $ writeFile (tmpgit "HEAD") (fromRef updatedorig) + -- Copy in refs and packed-refs, to work + -- around bug in git 2.13.0, which + -- causes it not to look in GIT_DIR for refs. + refs <- liftIO $ dirContentsRecursive $ + git_dir' "refs" + let refs' = (git_dir' "packed-refs") : refs + liftIO $ forM_ refs' $ \src -> + whenM (doesFileExist src) $ do + dest <- relPathDirToFile git_dir + (toRawFilePath src) + let dest' = toRawFilePath tmpgit P. dest + createDirectoryUnder git_dir + (P.takeDirectory dest') + void $ createLinkOrCopy src + (fromRawFilePath dest') + -- This reset makes git merge not care + -- that the work tree is empty; otherwise + -- it will think that all the files have + -- been staged for deletion, and sometimes + -- the merge includes these deletions + -- (for an unknown reason). + -- http://thread.gmane.org/gmane.comp.version-control.git/297237 + inRepo $ Git.Command.run [Param "reset", Param "HEAD", Param "--quiet"] + showAction $ "Merging into " ++ fromRef (Git.Ref.base origbranch) + merged <- autoMergeFrom' tomerge Nothing mergeconfig commitmode True + (const $ resolveMerge (Just updatedorig) tomerge True) + if merged + then do + !mergecommit <- liftIO $ extractSha + <$> S.readFile (tmpgit "HEAD") + -- This is run after the commit lock is dropped. + return $ postmerge mergecommit + else return $ return False + changestomerge Nothing = return $ return False + + withemptydir git_dir d a = bracketIO setup cleanup (const a) + where + setup = do + whenM (doesDirectoryExist d) $ + removeDirectoryRecursive d + createDirectoryUnder git_dir (toRawFilePath d) + cleanup _ = removeDirectoryRecursive d + + {- A merge commit has been made between the basisbranch and + - tomerge. Update the basisbranch and origbranch to point + - to that commit, adjust it to get the new adjusted branch, + - and check it out. + - + - But, there may be unstaged work tree changes that conflict, + - so the check out is done by making a normal merge of + - the new adjusted branch. + -} + postmerge (Just mergecommit) = do + setBasisBranch basis mergecommit + inRepo $ Git.Branch.update' origbranch mergecommit + adjtree <- adjustTree adj (BasisBranch mergecommit) + adjmergecommit <- commitAdjustedTree adjtree (BasisBranch mergecommit) + -- Make currbranch be the parent, so that merging + -- this commit will be a fast-forward. + adjmergecommitff <- commitAdjustedTree' adjtree (BasisBranch mergecommit) [currbranch] + showAction "Merging into adjusted branch" + ifM (autoMergeFrom adjmergecommitff (Just currbranch) mergeconfig commitmode canresolvemerge) + ( reparent adjtree adjmergecommit =<< getcurrentcommit + , return False + ) + postmerge Nothing = return False + + -- Now that the merge into the adjusted branch is complete, + -- take the tree from that merge, and attach it on top of the + -- adjmergecommit, if it's different. + reparent adjtree adjmergecommit (Just currentcommit) = do + if (commitTree currentcommit /= adjtree) + then do + cmode <- annexCommitMode <$> Annex.getGitConfig + c <- inRepo $ Git.Branch.commitTree cmode + ("Merged " ++ fromRef tomerge) [adjmergecommit] + (commitTree currentcommit) + inRepo $ Git.Branch.update "updating adjusted branch" currbranch c + propigateAdjustedCommits origbranch adj + else inRepo $ Git.Branch.update "updating adjusted branch" currbranch adjmergecommit + return True + reparent _ _ Nothing = return False + + getcurrentcommit = inRepo Git.Branch.currentUnsafe >>= \case + Nothing -> return Nothing + Just c -> catCommit c diff --git a/Annex/AdjustedBranch/Name.hs b/Annex/AdjustedBranch/Name.hs --- a/Annex/AdjustedBranch/Name.hs +++ b/Annex/AdjustedBranch/Name.hs @@ -1,6 +1,6 @@ {- adjusted branch names - - - Copyright 2016-2018 Joey Hess + - Copyright 2016-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -37,12 +37,16 @@ serializeAdjustment p serializeAdjustment (PresenceAdjustment p (Just l)) = serializeAdjustment p <> "-" <> serializeAdjustment l + serializeAdjustment (LinkPresentAdjustment l) = + serializeAdjustment l deserializeAdjustment s = (LinkAdjustment <$> deserializeAdjustment s) <|> (PresenceAdjustment <$> deserializeAdjustment s1 <*> pure (deserializeAdjustment s2)) <|> (PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing) + <|> + (LinkPresentAdjustment <$> deserializeAdjustment s) where (s1, s2) = separate' (== (fromIntegral (ord '-'))) s @@ -62,6 +66,13 @@ serializeAdjustment ShowMissingAdjustment = "showmissing" deserializeAdjustment "hidemissing" = Just HideMissingAdjustment deserializeAdjustment "showmissing" = Just ShowMissingAdjustment + deserializeAdjustment _ = Nothing + +instance SerializeAdjustment LinkPresentAdjustment where + serializeAdjustment UnlockPresentAdjustment = "unlockpresent" + serializeAdjustment LockPresentAdjustment = "lockpresent" + deserializeAdjustment "unlockpresent" = Just UnlockPresentAdjustment + deserializeAdjustment "lockpresent" = Just LockPresentAdjustment deserializeAdjustment _ = Nothing newtype AdjBranch = AdjBranch { adjBranch :: Branch } diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs --- a/Annex/AutoMerge.hs +++ b/Annex/AutoMerge.hs @@ -34,11 +34,11 @@ import Annex.InodeSentinal import Utility.InodeCache import Utility.FileMode +import qualified Utility.RawFilePath as R import qualified Data.Set as S import qualified Data.Map as M import qualified Data.ByteString.Lazy as L -import qualified Utility.RawFilePath as R {- Merges from a branch into the current branch (which may not exist yet), - with automatic merge conflict resolution. @@ -176,7 +176,7 @@ -- files, so delete here. unless inoverlay $ unless (islocked LsFiles.valUs) $ - liftIO $ removeWhenExistsWith removeLink file + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath file) | otherwise -> do -- Only resolve using symlink when both -- were locked, otherwise use unlocked @@ -309,7 +309,7 @@ <$> mapM Database.Keys.getInodeCaches resolvedks forM_ (M.toList unstagedmap) $ \(i, f) -> whenM (matchesresolved is i f) $ - liftIO $ removeWhenExistsWith removeLink f + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) where fs = S.fromList resolvedfs ks = S.fromList resolvedks diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -535,7 +535,7 @@ stagedfs <- lines <$> hGetContents jlogh mapM_ (removeFile . (dir )) stagedfs hClose jlogh - removeWhenExistsWith removeLink jlogf + removeWhenExistsWith (R.removeLink) (toRawFilePath jlogf) openjlog tmpdir = liftIO $ openTempFile tmpdir "jlog" {- This is run after the refs have been merged into the index, diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -60,132 +60,37 @@ import qualified Data.Set as S import Annex.Common -import Logs.Location -import Types.Transfer -import Logs.Transfer +import Annex.Content.Presence +import Annex.Content.LowLevel +import Annex.Content.PointerFile import qualified Git import qualified Annex import qualified Annex.Queue import qualified Annex.Branch -import Utility.FileMode import qualified Annex.Url as Url -import Utility.CopyFile -import Utility.Metered +import qualified Backend +import qualified Database.Keys import Git.FilePath import Annex.Perms import Annex.Link import Annex.LockPool -import Annex.WorkerPool +import Annex.UUID +import Annex.InodeSentinal +import Annex.AdjustedBranch (adjustedBranchRefresh) import Messages.Progress -import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) -import qualified Types.Remote -import qualified Types.Backend -import qualified Backend -import qualified Database.Keys +import Types.Remote (RetrievalSecurityPolicy(..)) import Types.NumCopies import Types.Key -import Annex.UUID -import Annex.InodeSentinal +import Types.Transfer +import Logs.Transfer +import Logs.Location import Utility.InodeCache -import Annex.Content.LowLevel -import Annex.Content.PointerFile -import Types.WorkerPool +import Utility.CopyFile +import Utility.Metered import qualified Utility.RawFilePath as R import qualified System.FilePath.ByteString as P -{- Checks if a given key's content is currently present. -} -inAnnex :: Key -> Annex Bool -inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist - -{- Runs an arbitrary check on a key's content. -} -inAnnexCheck :: Key -> (RawFilePath -> Annex Bool) -> Annex Bool -inAnnexCheck key check = inAnnex' id False check key - -{- inAnnex that performs an arbitrary check of the key's content. -} -inAnnex' :: (a -> Bool) -> a -> (RawFilePath -> Annex a) -> Key -> Annex a -inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do - r <- check loc - if isgood r - then ifM (annexThin <$> Annex.getGitConfig) - -- When annex.thin is set, the object file - -- could be modified; make sure it's not. - -- (Suppress any messages about - -- checksumming, to avoid them cluttering - -- the display.) - ( ifM (doQuietAction $ isUnmodified key loc) - ( return r - , return bad - ) - , return r - ) - else return bad - -{- Like inAnnex, checks if the object file for a key exists, - - but there are no guarantees it has the right content. -} -objectFileExists :: Key -> Annex Bool -objectFileExists key = - calcRepo (gitAnnexLocation key) - >>= liftIO . R.doesPathExist - -{- A safer check; the key's content must not only be present, but - - is not in the process of being removed. -} -inAnnexSafe :: Key -> Annex (Maybe Bool) -inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key - where - is_locked = Nothing - is_unlocked = Just True - is_missing = Just False - - go contentfile = flip checklock contentfile =<< contentLockFile key - -#ifndef mingw32_HOST_OS - checklock Nothing contentfile = checkOr is_missing contentfile - {- The content file must exist, but the lock file generally - - won't exist unless a removal is in process. -} - checklock (Just lockfile) contentfile = - ifM (liftIO $ doesFileExist (fromRawFilePath contentfile)) - ( checkOr is_unlocked lockfile - , return is_missing - ) - checkOr d lockfile = checkLocked lockfile >>= return . \case - Nothing -> d - Just True -> is_locked - Just False -> is_unlocked -#else - checklock Nothing contentfile = liftIO $ ifM (doesFileExist (fromRawFilePath contentfile)) - ( lockShared contentfile >>= \case - Nothing -> return is_locked - Just lockhandle -> do - dropLock lockhandle - return is_unlocked - , return is_missing - ) - {- In Windows, see if we can take a shared lock. If so, - - remove the lock file to clean up after ourselves. -} - checklock (Just lockfile) contentfile = - ifM (liftIO $ doesFileExist (fromRawFilePath contentfile)) - ( modifyContent lockfile $ liftIO $ - lockShared lockfile >>= \case - Nothing -> return is_locked - Just lockhandle -> do - dropLock lockhandle - void $ tryIO $ removeWhenExistsWith removeLink lockfile - return is_unlocked - , return is_missing - ) -#endif - -{- Windows has to use a separate lock file from the content, since - - locking the actual content file would interfere with the user's - - use of it. -} -contentLockFile :: Key -> Annex (Maybe RawFilePath) -#ifndef mingw32_HOST_OS -contentLockFile _ = pure Nothing -#else -contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) -#endif - {- Prevents the content from being removed while the action is running. - Uses a shared lock. - @@ -249,7 +154,7 @@ winLocker takelock _ (Just lockfile) = do modifyContent lockfile $ void $ liftIO $ tryIO $ - writeFile lockfile "" + writeFile (fromRawFilePath lockfile) "" liftIO $ takelock lockfile -- never reached; windows always uses a separate lock file winLocker _ _ Nothing = return Nothing @@ -299,15 +204,15 @@ {- Runs an action, passing it the temp file to get, - and if the action succeeds, verifies the file matches - the key and moves the file into the annex as a key's content. -} -getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool -getViaTmp rsp v key action = checkDiskSpaceToGet key False $ - getViaTmpFromDisk rsp v key action +getViaTmp :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmp rsp v key af action = checkDiskSpaceToGet key False $ + getViaTmpFromDisk rsp v key af action {- Like getViaTmp, but does not check that there is enough disk space - for the incoming key. For use when the key content is already on disk - and not being copied into place. -} -getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool -getViaTmpFromDisk rsp v key action = checkallowed $ do +getViaTmpFromDisk :: RetrievalSecurityPolicy -> VerifyConfig -> Key -> AssociatedFile -> (RawFilePath -> Annex (Bool, Verification)) -> Annex Bool +getViaTmpFromDisk rsp v key af action = checkallowed $ do tmpfile <- prepTmp key resuming <- liftIO $ R.doesPathExist tmpfile (ok, verification) <- action tmpfile @@ -322,7 +227,7 @@ else verification if ok then ifM (verifyKeyContent rsp v verification' key tmpfile) - ( ifM (pruneTmpWorkDirBefore tmpfile (moveAnnex key)) + ( ifM (pruneTmpWorkDirBefore tmpfile (moveAnnex key af)) ( do logStatus key InfoPresent return True @@ -357,71 +262,6 @@ ) ) -{- Verifies that a file is the expected content of a key. - - - - Configuration can prevent verification, for either a - - particular remote or always, unless the RetrievalSecurityPolicy - - requires verification. - - - - Most keys have a known size, and if so, the file size is checked. - - - - When the key's backend allows verifying the content (via checksum), - - it is checked. - - - - If the RetrievalSecurityPolicy requires verification and the key's - - backend doesn't support it, the verification will fail. - -} -verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool -verifyKeyContent rsp v verification k f = case (rsp, verification) of - (_, Verified) -> return True - (RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k) - ( verify - , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) - ( verify - , warnUnverifiableInsecure k >> return False - ) - ) - (_, UnVerified) -> ifM (shouldVerify v) - ( verify - , return True - ) - (_, MustVerify) -> verify - where - verify = enteringStage VerifyStage $ verifysize <&&> verifycontent - verifysize = case fromKey keySize k of - Nothing -> return True - Just size -> do - size' <- liftIO $ catchDefaultIO 0 $ getFileSize f - return (size' == size) - verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case - Nothing -> return True - Just b -> case Types.Backend.verifyKeyContent b of - Nothing -> return True - Just verifier -> verifier k f - -warnUnverifiableInsecure :: Key -> Annex () -warnUnverifiableInsecure k = warning $ unwords - [ "Getting " ++ kv ++ " keys with this remote is not secure;" - , "the content cannot be verified to be correct." - , "(Use annex.security.allow-unverified-downloads to bypass" - , "this safety check.)" - ] - where - kv = decodeBS (formatKeyVariety (fromKey keyVariety k)) - -data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify - -shouldVerify :: VerifyConfig -> Annex Bool -shouldVerify AlwaysVerify = return True -shouldVerify NoVerify = return False -shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig -shouldVerify (RemoteVerify r) = - (shouldVerify DefaultVerify - <&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r))) - -- Export remotes are not key/value stores, so always verify - -- content from them even when verification is disabled. - <||> Types.Remote.isExportSupported r - {- Checks if there is enough free disk space to download a key - to its temp file. - @@ -490,8 +330,8 @@ - accepted into the repository. Will display a warning message in this - case. May also throw exceptions in some cases. -} -moveAnnex :: Key -> RawFilePath -> Annex Bool -moveAnnex key src = ifM (checkSecureHashes' key) +moveAnnex :: Key -> AssociatedFile -> RawFilePath -> Annex Bool +moveAnnex key af src = ifM (checkSecureHashes' key) ( do withObjectLoc key storeobject return True @@ -500,7 +340,7 @@ where storeobject dest = ifM (liftIO $ R.doesPathExist dest) ( alreadyhave - , modifyContent dest $ do + , adjustedBranchRefresh af $ modifyContent dest $ do freezeContent src liftIO $ moveFile (fromRawFilePath src) @@ -648,10 +488,6 @@ then Nothing else Just (fromRawFilePath f, sameInodeCache f cache') -{- Performs an action, passing it the location to use for a key's content. -} -withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a -withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) - cleanObjectLoc :: Key -> Annex () -> Annex () cleanObjectLoc key cleaner = do file <- calcRepo (gitAnnexLocation key) @@ -665,8 +501,7 @@ maybe noop (const $ removeparents dir (n-1)) <=< catchMaybeIO $ removeDirectory (fromRawFilePath dir) -{- Removes a key's file from .git/annex/objects/ - -} +{- Removes a key's file from .git/annex/objects/ -} removeAnnex :: ContentRemovalLock -> Annex () removeAnnex (ContentRemovalLock key) = withObjectLoc key $ \file -> cleanObjectLoc key $ do @@ -680,54 +515,14 @@ -- Check associated pointer file for modifications, and reset if -- it's unmodified. resetpointer file = ifM (isUnmodified key file) - ( depopulatePointerFile key file + ( adjustedBranchRefresh (AssociatedFile (Just file)) $ + depopulatePointerFile key file -- Modified file, so leave it alone. -- If it was a hard link to the annex object, -- that object might have been frozen as part of the -- removal process, so thaw it. , void $ tryIO $ thawContent file ) - -{- Check if a file contains the unmodified content of the key. - - - - The expensive way to tell is to do a verification of its content. - - The cheaper way is to see if the InodeCache for the key matches the - - file. -} -isUnmodified :: Key -> RawFilePath -> Annex Bool -isUnmodified key f = go =<< geti - where - go Nothing = return False - go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc - expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f) - ( do - -- The file could have been modified while it was - -- being verified. Detect that. - ifM (geti >>= maybe (return False) (compareInodeCaches fc)) - ( do - -- Update the InodeCache to avoid - -- performing this expensive check again. - Database.Keys.addInodeCaches key [fc] - return True - , return False - ) - , return False - ) - geti = withTSDelta (liftIO . genInodeCache f) - -{- Cheap check if a file contains the unmodified content of the key, - - only checking the InodeCache of the key. - - - - Note that, on systems not supporting high-resolution mtimes, - - this may report a false positive when repeated edits are made to a file - - within a small time window (eg 1 second). - -} -isUnmodifiedCheap :: Key -> RawFilePath -> Annex Bool -isUnmodifiedCheap key f = maybe (return False) (isUnmodifiedCheap' key) - =<< withTSDelta (liftIO . genInodeCache f) - -isUnmodifiedCheap' :: Key -> InodeCache -> Annex Bool -isUnmodifiedCheap' key fc = - anyM (compareInodeCaches fc) =<< Database.Keys.getInodeCaches key {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and - returns the file it was moved to. -} diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -18,7 +18,6 @@ import Utility.CopyFile import qualified Utility.RawFilePath as R -import System.PosixCompat.Files import qualified System.FilePath.ByteString as P {- Runs the secure erase command if set, otherwise does nothing. @@ -75,8 +74,9 @@ =<< liftIO (R.getFileStatus src) checkedCopyFile' :: Key -> RawFilePath -> RawFilePath -> Maybe FileMode -> FileStatus -> Annex Bool -checkedCopyFile' key src dest destmode s = catchBoolIO $ - ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ P.takeDirectory dest) key 0 True) +checkedCopyFile' key src dest destmode s = catchBoolIO $ do + sz <- liftIO $ getFileSize' src s + ifM (checkDiskSpace' sz (Just $ P.takeDirectory dest) key 0 True) ( liftIO $ copyFileExternal CopyAllMetaData (fromRawFilePath src) (fromRawFilePath dest) <&&> preserveGitMode dest destmode diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -9,12 +9,6 @@ module Annex.Content.PointerFile where -#if ! defined(mingw32_HOST_OS) -import System.Posix.Files -#else -import System.PosixCompat.Files -#endif - import Annex.Common import Annex.Perms import Annex.Link @@ -22,10 +16,11 @@ import Annex.InodeSentinal import Annex.Content.LowLevel import Utility.InodeCache +import qualified Utility.RawFilePath as R #if ! defined(mingw32_HOST_OS) import Utility.Touch +import System.Posix.Files (modificationTimeHiRes) #endif -import qualified Utility.RawFilePath as R {- Populates a pointer file with the content of a key. - diff --git a/Annex/Content/Presence.hs b/Annex/Content/Presence.hs new file mode 100644 --- /dev/null +++ b/Annex/Content/Presence.hs @@ -0,0 +1,246 @@ +{- git-annex object content presence + - + - Copyright 2010-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Content.Presence ( + inAnnex, + inAnnex', + inAnnexSafe, + inAnnexCheck, + objectFileExists, + withObjectLoc, + isUnmodified, + isUnmodifiedCheap, + verifyKeyContent, + VerifyConfig(..), + Verification(..), + unVerified, + warnUnverifiableInsecure, + contentLockFile, +) where + +import Annex.Common +import qualified Annex +import Annex.LockPool +import Annex.WorkerPool +import Types.Remote (unVerified, Verification(..), RetrievalSecurityPolicy(..)) +import qualified Types.Remote +import qualified Types.Backend +import qualified Backend +import qualified Database.Keys +import Types.Key +import Annex.InodeSentinal +import Utility.InodeCache +import Types.WorkerPool +import qualified Utility.RawFilePath as R + +#ifdef mingw32_HOST_OS +import Annex.Perms +#endif + +{- Checks if a given key's content is currently present. -} +inAnnex :: Key -> Annex Bool +inAnnex key = inAnnexCheck key $ liftIO . R.doesPathExist + +{- Runs an arbitrary check on a key's content. -} +inAnnexCheck :: Key -> (RawFilePath -> Annex Bool) -> Annex Bool +inAnnexCheck key check = inAnnex' id False check key + +{- inAnnex that performs an arbitrary check of the key's content. -} +inAnnex' :: (a -> Bool) -> a -> (RawFilePath -> Annex a) -> Key -> Annex a +inAnnex' isgood bad check key = withObjectLoc key $ \loc -> do + r <- check loc + if isgood r + then ifM (annexThin <$> Annex.getGitConfig) + -- When annex.thin is set, the object file + -- could be modified; make sure it's not. + -- (Suppress any messages about + -- checksumming, to avoid them cluttering + -- the display.) + ( ifM (doQuietAction $ isUnmodified key loc) + ( return r + , return bad + ) + , return r + ) + else return bad + +{- Like inAnnex, checks if the object file for a key exists, + - but there are no guarantees it has the right content. -} +objectFileExists :: Key -> Annex Bool +objectFileExists key = + calcRepo (gitAnnexLocation key) + >>= liftIO . R.doesPathExist + +{- A safer check; the key's content must not only be present, but + - is not in the process of being removed. -} +inAnnexSafe :: Key -> Annex (Maybe Bool) +inAnnexSafe key = inAnnex' (fromMaybe True) (Just False) go key + where + is_locked = Nothing + is_unlocked = Just True + is_missing = Just False + + go contentfile = flip checklock contentfile =<< contentLockFile key + +#ifndef mingw32_HOST_OS + checklock Nothing contentfile = checkOr is_missing contentfile + {- The content file must exist, but the lock file generally + - won't exist unless a removal is in process. -} + checklock (Just lockfile) contentfile = + ifM (liftIO $ doesFileExist (fromRawFilePath contentfile)) + ( checkOr is_unlocked lockfile + , return is_missing + ) + checkOr d lockfile = checkLocked lockfile >>= return . \case + Nothing -> d + Just True -> is_locked + Just False -> is_unlocked +#else + checklock Nothing contentfile = liftIO $ ifM (doesFileExist (fromRawFilePath contentfile)) + ( lockShared contentfile >>= \case + Nothing -> return is_locked + Just lockhandle -> do + dropLock lockhandle + return is_unlocked + , return is_missing + ) + {- In Windows, see if we can take a shared lock. If so, + - remove the lock file to clean up after ourselves. -} + checklock (Just lockfile) contentfile = + ifM (liftIO $ doesFileExist (fromRawFilePath contentfile)) + ( modifyContent lockfile $ liftIO $ + lockShared lockfile >>= \case + Nothing -> return is_locked + Just lockhandle -> do + dropLock lockhandle + void $ tryIO $ removeWhenExistsWith R.removeLink lockfile + return is_unlocked + , return is_missing + ) +#endif + +{- Windows has to use a separate lock file from the content, since + - locking the actual content file would interfere with the user's + - use of it. -} +contentLockFile :: Key -> Annex (Maybe RawFilePath) +#ifndef mingw32_HOST_OS +contentLockFile _ = pure Nothing +#else +contentLockFile key = Just <$> calcRepo (gitAnnexContentLock key) +#endif + +{- Performs an action, passing it the location to use for a key's content. -} +withObjectLoc :: Key -> (RawFilePath -> Annex a) -> Annex a +withObjectLoc key a = a =<< calcRepo (gitAnnexLocation key) + +{- Check if a file contains the unmodified content of the key. + - + - The expensive way to tell is to do a verification of its content. + - The cheaper way is to see if the InodeCache for the key matches the + - file. -} +isUnmodified :: Key -> RawFilePath -> Annex Bool +isUnmodified key f = go =<< geti + where + go Nothing = return False + go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc + expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f) + ( do + -- The file could have been modified while it was + -- being verified. Detect that. + ifM (geti >>= maybe (return False) (compareInodeCaches fc)) + ( do + -- Update the InodeCache to avoid + -- performing this expensive check again. + Database.Keys.addInodeCaches key [fc] + return True + , return False + ) + , return False + ) + geti = withTSDelta (liftIO . genInodeCache f) + +{- Cheap check if a file contains the unmodified content of the key, + - only checking the InodeCache of the key. + - + - Note that, on systems not supporting high-resolution mtimes, + - this may report a false positive when repeated edits are made to a file + - within a small time window (eg 1 second). + -} +isUnmodifiedCheap :: Key -> RawFilePath -> Annex Bool +isUnmodifiedCheap key f = maybe (return False) (isUnmodifiedCheap' key) + =<< withTSDelta (liftIO . genInodeCache f) + +isUnmodifiedCheap' :: Key -> InodeCache -> Annex Bool +isUnmodifiedCheap' key fc = + anyM (compareInodeCaches fc) =<< Database.Keys.getInodeCaches key + +{- Verifies that a file is the expected content of a key. + - + - Configuration can prevent verification, for either a + - particular remote or always, unless the RetrievalSecurityPolicy + - requires verification. + - + - Most keys have a known size, and if so, the file size is checked. + - + - When the key's backend allows verifying the content (via checksum), + - it is checked. + - + - If the RetrievalSecurityPolicy requires verification and the key's + - backend doesn't support it, the verification will fail. + -} +verifyKeyContent :: RetrievalSecurityPolicy -> VerifyConfig -> Verification -> Key -> RawFilePath -> Annex Bool +verifyKeyContent rsp v verification k f = case (rsp, verification) of + (_, Verified) -> return True + (RetrievalVerifiableKeysSecure, _) -> ifM (Backend.isVerifiable k) + ( verify + , ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) + ( verify + , warnUnverifiableInsecure k >> return False + ) + ) + (_, UnVerified) -> ifM (shouldVerify v) + ( verify + , return True + ) + (_, MustVerify) -> verify + where + verify = enteringStage VerifyStage $ verifysize <&&> verifycontent + verifysize = case fromKey keySize k of + Nothing -> return True + Just size -> do + size' <- liftIO $ catchDefaultIO 0 $ getFileSize f + return (size' == size) + verifycontent = Backend.maybeLookupBackendVariety (fromKey keyVariety k) >>= \case + Nothing -> return True + Just b -> case Types.Backend.verifyKeyContent b of + Nothing -> return True + Just verifier -> verifier k f + +warnUnverifiableInsecure :: Key -> Annex () +warnUnverifiableInsecure k = warning $ unwords + [ "Getting " ++ kv ++ " keys with this remote is not secure;" + , "the content cannot be verified to be correct." + , "(Use annex.security.allow-unverified-downloads to bypass" + , "this safety check.)" + ] + where + kv = decodeBS (formatKeyVariety (fromKey keyVariety k)) + +data VerifyConfig = AlwaysVerify | NoVerify | RemoteVerify Remote | DefaultVerify + +shouldVerify :: VerifyConfig -> Annex Bool +shouldVerify AlwaysVerify = return True +shouldVerify NoVerify = return False +shouldVerify DefaultVerify = annexVerify <$> Annex.getGitConfig +shouldVerify (RemoteVerify r) = + (shouldVerify DefaultVerify + <&&> pure (remoteAnnexVerify (Types.Remote.gitconfig r))) + -- Export remotes are not key/value stores, so always verify + -- content from them even when verification is disabled. + <||> Types.Remote.isExportSupported r diff --git a/Annex/ExternalAddonProcess.hs b/Annex/ExternalAddonProcess.hs --- a/Annex/ExternalAddonProcess.hs +++ b/Annex/ExternalAddonProcess.hs @@ -53,7 +53,7 @@ Left _ -> runerr cmdpath started cmd errrelayer pall@(Just hin, Just hout, Just herr, ph) = do - stderrelay <- async $ errrelayer herr + stderrelay <- async $ errrelayer ph herr let shutdown forcestop = do -- Close the process's stdin, to let it know there -- are no more requests, so it will exit. diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -460,7 +460,7 @@ ia loc cid (fromRawFilePath tmpfile) (pure k) (combineMeterUpdate p' p) - ok <- moveAnnex k' tmpfile + ok <- moveAnnex k' af tmpfile when ok $ logStatus k InfoPresent return (Just (k', ok)) @@ -503,7 +503,7 @@ p case keyGitSha k of Nothing -> do - ok <- moveAnnex k tmpfile + ok <- moveAnnex k af tmpfile when ok $ do recordcidkey cidmap db cid k logStatus k InfoPresent diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -49,9 +49,9 @@ import Annex.InodeSentinal import Annex.AdjustedBranch import Annex.FileMatcher +import qualified Utility.RawFilePath as R import Control.Exception (IOException) -import qualified Utility.RawFilePath as R data LockedDown = LockedDown { lockDownConfig :: LockDownConfig @@ -113,7 +113,7 @@ (tmpfile, h) <- openTempFile (fromRawFilePath tmpdir) $ relatedTemplate $ "ingest-" ++ takeFileName file hClose h - removeWhenExistsWith removeLink tmpfile + removeWhenExistsWith R.removeLink (toRawFilePath tmpfile) withhardlink' delta tmpfile `catchIO` const (nohardlink' delta) @@ -177,13 +177,19 @@ go _ _ Nothing = failure "failed to generate a key" golocked key mcache s = - tryNonAsync (moveAnnex key $ contentLocation source) >>= \case + tryNonAsync (moveAnnex key naf (contentLocation source)) >>= \case Right True -> do populateAssociatedFiles key source restage success key mcache s Right False -> giveup "failed to add content to annex" Left e -> restoreFile (keyFilename source) key e + -- moveAnnex uses the AssociatedFile provided to it to unlock + -- locked files when getting a file in an adjusted branch. + -- That case does not apply here, where we're adding an unlocked + -- file, so provide it nothing. + naf = AssociatedFile Nothing + gounlocked key (Just cache) s = do -- Remove temp directory hard link first because -- linkToAnnex falls back to copying if a file @@ -352,7 +358,7 @@ stagePointerFile file mode =<< hashPointerFile key Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) case mtmp of - Just tmp -> ifM (moveAnnex key tmp) + Just tmp -> ifM (moveAnnex key af tmp) ( linkunlocked mode >> return True , writepointer mode >> return False ) @@ -363,10 +369,11 @@ , do addLink ci file key Nothing case mtmp of - Just tmp -> moveAnnex key tmp + Just tmp -> moveAnnex key af tmp Nothing -> return True ) where + af = AssociatedFile (Just file) mi = case mtmp of Just tmp -> MatchingFile $ FileInfo { contentFile = Just tmp diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -49,19 +49,21 @@ import Upgrade import Annex.Tmp import Utility.UserInfo -import Utility.ThreadScheduler import qualified Utility.RawFilePath as R #ifndef mingw32_HOST_OS +import Utility.ThreadScheduler import Annex.Perms import Utility.FileMode import System.Posix.User import qualified Utility.LockFile.Posix as Posix -import Data.Either #endif import qualified Data.Map as M +#ifndef mingw32_HOST_OS +import Data.Either import qualified System.FilePath.ByteString as P import Control.Concurrent.Async +#endif checkCanInitialize :: Annex a -> Annex a checkCanInitialize a = canInitialize' >>= \case @@ -210,9 +212,9 @@ where probe f = catchDefaultIO (True, []) $ do let f2 = f ++ "2" - removeWhenExistsWith removeLink f2 + removeWhenExistsWith R.removeLink (toRawFilePath f2) createSymbolicLink f f2 - removeWhenExistsWith removeLink f2 + removeWhenExistsWith R.removeLink (toRawFilePath f2) preventWrite (toRawFilePath f) -- Should be unable to write to the file, unless -- running as root, but some crippled diff --git a/Annex/PidLock.hs b/Annex/PidLock.hs --- a/Annex/PidLock.hs +++ b/Annex/PidLock.hs @@ -10,10 +10,10 @@ module Annex.PidLock where import Annex.Common -import Annex.GitOverlay import Git -import Git.Env #ifndef mingw32_HOST_OS +import Git.Env +import Annex.GitOverlay import qualified Utility.LockFile.PidLock as PidF import qualified Utility.LockPool.PidLock as PidP import Utility.LockPool (dropLock) diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -337,7 +337,7 @@ } void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid -> forceSuccessProcess p pid - liftIO $ removeWhenExistsWith removeLink socketfile + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath socketfile) {- This needs to be as short as possible, due to limitations on the length - of the path to a socket file. At the same time, it needs to be unique diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -12,6 +12,7 @@ import Annex.LockFile import Annex.Perms import Types.CleanupActions +import qualified Utility.RawFilePath as R import Data.Time.Clock.POSIX @@ -67,5 +68,5 @@ let oldenough = now - (60 * 60 * 24 * 7) catchMaybeIO (modificationTime <$> getSymbolicLinkStatus f) >>= \case Just mtime | realToFrac mtime <= oldenough -> - void $ tryIO $ removeWhenExistsWith removeLink f + void $ tryIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) _ -> return () diff --git a/Annex/View/ViewedFile.hs b/Annex/View/ViewedFile.hs --- a/Annex/View/ViewedFile.hs +++ b/Annex/View/ViewedFile.hs @@ -83,7 +83,7 @@ prop_viewedFile_roundtrips tf -- Relative filenames wanted, not directories. | any (isPathSeparator) (end f ++ beginning f) = True - | isAbsolute f = True + | isAbsolute f || isDrive f = True | otherwise = dir == dirFromViewedFile (viewedFileFromReference f) where f = fromTestableFilePath tf diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -225,15 +225,18 @@ liftIO $ withCreateProcess p waitproc waitproc Nothing (Just o) (Just e) pid = do - output <- fmap fst $ - hGetContentsStrict o - `concurrently` - hGetContentsStrict e + errt <- async $ discardstderr pid e + output <- hGetContentsStrict o ok <- liftIO $ checkSuccessProcess pid + wait errt return $ case (ok, lines output) of (True, (f:_)) | not (null f) -> Right f _ -> nomedia waitproc _ _ _ _ = error "internal" + + discardstderr pid e = hGetLineUntilExitOrEOF pid e >>= \case + Nothing -> return () + Just _ -> discardstderr pid e nomedia = Left "no media in url" diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -102,7 +102,7 @@ createAnnexDirectory (parentDir logfile) ifM (liftIO $ isNothing <$> getEnv flag) ( liftIO $ withNullHandle $ \nullh -> do - loghandle <- openLog logfile + loghandle <- openLog (fromRawFilePath logfile) e <- getEnvironment cmd <- programPath ps <- getArgs @@ -115,7 +115,7 @@ exitcode <- withCreateProcess p $ \_ _ _ pid -> waitForProcess pid exitWith exitcode - , start (Utility.Daemon.foreground (Just pidfile)) $ + , start (Utility.Daemon.foreground (Just (fromRawFilePath pidfile))) $ case startbrowser of Nothing -> Nothing Just a -> Just $ a Nothing Nothing diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -30,6 +30,7 @@ #endif import qualified Utility.Lsof as Lsof import Utility.ThreadScheduler +import qualified Utility.RawFilePath as R import Control.Concurrent.Async @@ -149,7 +150,7 @@ waitforit "to check stale git lock file" l' <- getsizes if l' == l - then liftIO $ mapM_ (removeWhenExistsWith removeLink . fst) l + then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath . fst) l else go l' , do waitforit "for git lock file writer" diff --git a/Assistant/Threads/Upgrader.hs b/Assistant/Threads/Upgrader.hs --- a/Assistant/Threads/Upgrader.hs +++ b/Assistant/Threads/Upgrader.hs @@ -31,7 +31,7 @@ upgraderThread :: UrlRenderer -> NamedThread upgraderThread urlrenderer = namedThread "Upgrader" $ - when (isJust BuildInfo.upgradelocation) $ do + when upgradeSupported $ do {- Check for upgrade on startup, unless it was just - upgraded. -} unlessM (liftIO checkSuccessfulUpgrade) $ diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -41,6 +41,7 @@ import qualified Utility.Url as Url import qualified Annex.Url as Url hiding (download) import Utility.Tuple +import qualified Utility.RawFilePath as R import Data.Either import qualified Data.Map as M @@ -220,7 +221,7 @@ error $ "did not find " ++ dir ++ " in " ++ distributionfile makeorigsymlink olddir = do let origdir = fromRawFilePath (parentDir (toRawFilePath olddir)) installBase - removeWhenExistsWith removeLink origdir + removeWhenExistsWith R.removeLink (toRawFilePath origdir) createSymbolicLink newdir origdir {- Finds where the old version was installed. -} @@ -278,8 +279,8 @@ deleteFromManifest :: FilePath -> IO () deleteFromManifest dir = do fs <- map (dir ) . lines <$> catchDefaultIO "" (readFile manifest) - mapM_ (removeWhenExistsWith removeLink) fs - removeWhenExistsWith removeLink manifest + mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs + removeWhenExistsWith R.removeLink (toRawFilePath manifest) removeEmptyRecursive dir where manifest = dir "git-annex.MANIFEST" @@ -337,6 +338,18 @@ distributionInfoSigUrl :: String distributionInfoSigUrl = distributionInfoUrl ++ ".sig" + +{- Upgrade only supported on linux and OSX. -} +upgradeSupported :: Bool +#ifdef linux_HOST_OS +upgradeSupported = isJust BuildInfo.upgradelocation +#else +#ifdef darwin_HOST_OS +upgradeSupported = isJust BuildInfo.upgradelocation +#else +upgradeSupported = False +#endif +#endif {- Verifies that a file from the git-annex distribution has a valid - signature. Pass the detached .sig file; the file to be verified should diff --git a/Assistant/WebApp/Configurators/Preferences.hs b/Assistant/WebApp/Configurators/Preferences.hs --- a/Assistant/WebApp/Configurators/Preferences.hs +++ b/Assistant/WebApp/Configurators/Preferences.hs @@ -21,7 +21,7 @@ import Utility.DataUnits import Git.Config import Types.Distribution -import qualified BuildInfo +import Assistant.Upgrade import qualified Data.Text as T import qualified System.FilePath.ByteString as P @@ -59,7 +59,7 @@ , ("disabled", NoAutoUpgrade) ] autoUpgradeLabel - | isJust BuildInfo.upgradelocation = "Auto upgrade" + | upgradeSupported = "Auto upgrade" | otherwise = "Auto restart on upgrade" positiveIntField = check isPositive intField diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,32 @@ +git-annex (8.20201127) upstream; urgency=medium + + * adjust: New --unlock-present mode which locks files whose content is not + present (so the broken symlink is visible), while unlocking files whose + content is present. + * Added annex.adjustedbranchrefresh git config to update adjusted + branches set up by git-annex adjust --unlock-present/--hide-missing. + * Fix hang when an external special remote program exited but + the stderr pipe to it was left open, due to a daemon having inherited + the file descriptor. + * Fix a bug that could make resuming a download from the web fail + when the entire content of the file is actually already present + locally. + * examinekey: Added a "file" format variable for consistency with find, + and for easier scripting. + * init: When writing hook scripts, set all execute bits, not only + the user execute bit. + * upgrade: Support an edge case upgrading a v5 direct mode repo + where nothing had ever been committed to the head branch. + * Made the test suite significantly less noisy, only displaying command + output when something failed. + * Fix building without the torrent library. + Thanks, Kyle Meyer. + * Fix build on Windows. + * Prevent windows assistant from trying (and failing) to upgrade + itself, which has never been supported on windows. + + -- Joey Hess Fri, 27 Nov 2020 12:54:11 -0400 + git-annex (8.20201116) upstream; urgency=medium * move: Fix a regression in the last release that made move --to not diff --git a/Command/Adjust.hs b/Command/Adjust.hs --- a/Command/Adjust.hs +++ b/Command/Adjust.hs @@ -19,6 +19,7 @@ optParser _ = (LinkAdjustment <$> linkAdjustmentParser) <|> (PresenceAdjustment <$> presenceAdjustmentParser <*> maybeLinkAdjustmentParser) + <|> (LinkPresentAdjustment <$> linkPresentAdjustmentParser) linkAdjustmentParser :: Parser LinkAdjustment linkAdjustmentParser = @@ -43,6 +44,13 @@ flag' HideMissingAdjustment ( long "hide-missing" <> help "hide annexed files whose content is not present" + ) + +linkPresentAdjustmentParser :: Parser LinkPresentAdjustment +linkPresentAdjustmentParser = + flag' UnlockPresentAdjustment + ( long "unlock-present" + <> help "unlock files whose content is present; lock rest" ) seek :: Adjustment -> CommandSeek diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -9,7 +9,7 @@ import Command import qualified Utility.Format -import Command.Find (parseFormatOption, showFormatted, keyVars) +import Command.Find (parseFormatOption, showFormatted, formatVars) import Annex.Link import Backend import Types.Backend @@ -57,7 +57,7 @@ showFormatted (format o) (serializeKey' k) $ [ ("objectpath", fromRawFilePath objectpath) , ("objectpointer", fromRawFilePath objectpointer) - ] ++ keyVars k + ] ++ formatVars k af return True where -- Parse the input, which is either a key, or in batch mode diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -75,7 +75,8 @@ start :: FindOptions -> SeekInput -> RawFilePath -> Key -> CommandStart start o _ file key = startingCustomOutput key $ do - showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key + showFormatted (formatOption o) file + (formatVars key (AssociatedFile (Just file))) next $ return True startKeys :: FindOptions -> (SeekInput, Key, ActionItem) -> CommandStart @@ -92,8 +93,9 @@ Utility.Format.format formatter $ M.fromList vars -keyVars :: Key -> [(String, String)] -keyVars key = +formatVars :: Key -> AssociatedFile -> [(String, String)] +formatVars key (AssociatedFile af) = + (maybe id (\f l -> (("file", fromRawFilePath f) : l)) af) [ ("key", serializeKey key) , ("backend", decodeBS $ formatKeyVariety $ fromKey keyVariety key) , ("bytesize", size show) diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -17,6 +17,7 @@ import Utility.ThreadScheduler import Utility.DiskFree import Git.Types (fromConfigKey) +import qualified Utility.RawFilePath as R import Data.Time.Clock import System.Random (getStdRandom, random, randomR) @@ -178,7 +179,7 @@ n <- liftIO (getStdRandom random :: IO Int) liftIO $ writeFile f $ show n ++ "\n" runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ - removeWhenExistsWith removeLink f + removeWhenExistsWith R.removeLink (toRawFilePath f) runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ rename src dest runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -114,7 +114,7 @@ | Remote.hasKeyCheap r = either (const False) id <$> Remote.hasKey r key | otherwise = return True - docopy r witness = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key $ \dest -> + docopy r witness = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key afile $ \dest -> download (Remote.uuid r) key afile stdRetry (\p -> do showAction $ "from " ++ Remote.name r diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -225,7 +225,7 @@ where get = notifyTransfer Download afile $ download (Remote.uuid src) key afile stdRetry $ \p -> - getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key $ \t -> + getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key afile $ \t -> Remote.verifiedAction $ Remote.retrieveKeyFile src key afile (fromRawFilePath t) p dispatch _ _ False = stop -- failed diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -27,6 +27,7 @@ import Utility.Tmp import Utility.Tmp.Dir import Utility.Process.Transcript +import qualified Utility.RawFilePath as R import Data.Char import qualified Data.ByteString.Lazy.UTF8 as B8 @@ -84,7 +85,7 @@ KeyContainer s -> liftIO $ genkey (Param s) KeyFile f -> do createAnnexDirectory (toRawFilePath (takeDirectory f)) - liftIO $ removeWhenExistsWith removeLink f + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) liftIO $ protectedOutput $ genkey (File f) case (ok, parseFingerprint s) of (False, _) -> giveup $ "uftp_keymgt failed: " ++ s @@ -210,9 +211,9 @@ case deserializeKey (takeFileName f) of Nothing -> do warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." - liftIO $ removeWhenExistsWith removeLink f + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) Just k -> void $ - getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k $ \dest -> unVerified $ + getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $ liftIO $ catchBoolIO $ do rename f (fromRawFilePath dest) return True diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -24,6 +24,7 @@ import Utility.Tmp.Dir import Utility.FileMode import Utility.ThreadScheduler +import qualified Utility.RawFilePath as R import qualified Utility.MagicWormhole as Wormhole import Control.Concurrent.Async @@ -256,7 +257,7 @@ Wormhole.sendFile sendf observer wormholeparams `concurrently` Wormhole.receiveFile recvf producer wormholeparams - liftIO $ removeWhenExistsWith removeLink sendf + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath sendf) if sendres /= True then return SendFailed else if recvres /= True diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -90,7 +90,7 @@ - This avoids hard linking to content linked to an - unlocked file, which would leave the new key unlocked - and vulnerable to corruption. -} - ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do + ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey (AssociatedFile Nothing) $ \tmp -> unVerified $ do oldobj <- calcRepo (gitAnnexLocation oldkey) isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing , do diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -33,7 +33,7 @@ let verify = if fromunlocked then AlwaysVerify else DefaultVerify -- This matches the retrievalSecurityPolicy of Remote.Git let rsp = RetrievalAllKeysSecure - ifM (getViaTmp rsp verify key go) + ifM (getViaTmp rsp verify key (AssociatedFile Nothing) go) ( do -- forcibly quit after receiving one key, -- and shutdown cleanly diff --git a/Command/Reinject.hs b/Command/Reinject.hs --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -88,7 +88,7 @@ ) where move = checkDiskSpaceToGet key False $ - moveAnnex key src + moveAnnex key (AssociatedFile Nothing) src cleanup :: Key -> CommandCleanup cleanup key = do diff --git a/Command/SetKey.hs b/Command/SetKey.hs --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -35,7 +35,7 @@ -- the file might be on a different filesystem, so moveFile is used -- rather than simply calling moveAnnex; disk space is also -- checked this way. - ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key $ \dest -> unVerified $ + ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key (AssociatedFile Nothing) $ \dest -> unVerified $ if dest /= file then liftIO $ catchBoolIO $ do moveFile (fromRawFilePath file) (fromRawFilePath dest) diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -60,6 +60,7 @@ import Logs.PreferredContent import Annex.AutoMerge import Annex.AdjustedBranch +import Annex.AdjustedBranch.Merge import Annex.Ssh import Annex.BloomFilter import Annex.UpdateInstead @@ -406,17 +407,17 @@ updateBranches (Just branch, madj) = do -- When in an adjusted branch, propigate any changes made to it -- back to the original branch. The adjusted branch may also need - -- to be updated to hide/expose files. + -- to be updated, if the adjustment is not stable, and the usual + -- configuration does not update it. case madj of Nothing -> noop Just adj -> do let origbranch = branch propigateAdjustedCommits origbranch adj - when (adjustmentHidesFiles adj) $ do - showSideAction "updating adjusted branch" - let adjbranch = originalToAdjusted origbranch adj - unlessM (updateAdjustedBranch adj adjbranch origbranch) $ - warning $ unwords [ "Updating adjusted branch failed." ] + unless (adjustmentIsStable adj) $ + annexAdjustedBranchRefresh <$> Annex.getGitConfig >>= \case + 0 -> adjustedBranchRefreshFull adj origbranch + _ -> return () -- Update the sync branch to match the new state of the branch inRepo $ updateBranch (syncBranch branch) branch diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -294,7 +294,7 @@ Just b -> case Types.Backend.verifyKeyContent b of Nothing -> return True Just verifier -> verifier k (serializeKey' k) - get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> + get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) @@ -368,13 +368,13 @@ , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> - getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> + getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of Nothing -> return False - Just a -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> + Just a -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> unVerified $ isRight <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) ] @@ -436,7 +436,7 @@ k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of Just a -> a ks nullMeterUpdate Nothing -> giveup "failed to generate random key (backend problem)" - _ <- moveAnnex k (toRawFilePath f) + _ <- moveAnnex k (AssociatedFile Nothing) (toRawFilePath f) return k getReadonlyKey :: Remote -> FilePath -> Annex Key diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -63,7 +63,7 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $ download (uuid remote) key file stdRetry $ \p -> - getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> + getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Right v -> return (True, v) Left e -> do diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -47,7 +47,7 @@ return True | otherwise = notifyTransfer direction file $ download (Remote.uuid remote) key file stdRetry $ \p -> - getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> do + getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Left e -> do warning (show e) diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -32,6 +32,7 @@ import Types.NumCopies import Remote import Git.Types (fromConfigKey, fromConfigValue) +import qualified Utility.RawFilePath as R cmd :: Command cmd = command "vicfg" SectionSetup "edit configuration in git-annex branch" @@ -58,7 +59,7 @@ unlessM (liftIO $ boolSystem "sh" [Param "-c", Param $ unwords [vi, shellEscape f]]) $ giveup $ vi ++ " exited nonzero; aborting" r <- parseCfg (defCfg curcfg) <$> liftIO (readFileStrict f) - liftIO $ removeWhenExistsWith removeLink f + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) case r of Left s -> do liftIO $ writeFile f s diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -95,10 +95,8 @@ mapM_ (showRemoteUrls remotemap) urls Just formatter -> liftIO $ do - let vs = catMaybes - [ fmap (("file",) . fromRawFilePath) - (actionItemWorkTreeFile ai) - ] ++ Command.Find.keyVars key + let vs = Command.Find.formatVars key + (AssociatedFile (actionItemWorkTreeFile ai)) let showformatted muuid murl = putStr $ Utility.Format.format formatter $ M.fromList $ vs ++ catMaybes diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -13,7 +13,7 @@ import System.FilePath as X import System.IO as X hiding (FilePath) import System.Exit as X -import System.PosixCompat.Files as X hiding (fileSize) +import System.PosixCompat.Files as X hiding (fileSize, removeLink) import Utility.Misc as X import Utility.Exception as X diff --git a/Creds.hs b/Creds.hs --- a/Creds.hs +++ b/Creds.hs @@ -32,12 +32,13 @@ import Types.ProposedAccepted import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher) import Utility.Env (getEnv) +import Utility.Base64 +import qualified Utility.RawFilePath as R import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as S import qualified Data.Map as M import qualified System.FilePath.ByteString as P -import Utility.Base64 {- A CredPair can be stored in a file, or in the environment, or - in a remote's configuration. -} @@ -211,9 +212,8 @@ removeCreds :: FilePath -> Annex () removeCreds file = do - d <- fromRawFilePath <$> fromRepo gitAnnexCredsDir - let f = d file - liftIO $ removeWhenExistsWith removeLink f + d <- fromRepo gitAnnexCredsDir + liftIO $ removeWhenExistsWith R.removeLink (d P. toRawFilePath file) includeCredsInfo :: ParsedRemoteConfig -> CredPairStorage -> [(String, String)] -> Annex [(String, String)] includeCredsInfo pc@(ParsedRemoteConfig cm _) storage info = do diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -22,7 +22,6 @@ import qualified Git.Command import qualified Git.Construct import Utility.UserInfo -import Utility.ThreadScheduler {- Returns a single git config setting, or a fallback value if not set. -} get :: ConfigKey -> ConfigValue -> Repo -> ConfigValue @@ -186,6 +185,10 @@ | s' == "0" = Just False | s' == "" = Just False + -- Git treats any number other than 0 as true, + -- including negative numbers. + | S8.all (\c -> isDigit c || c == '-') s' = Just True + | otherwise = Nothing where s' = S8.map toLower s @@ -207,8 +210,8 @@ {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - - output and standard error of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) + - output and the standard error of the command. -} +fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, String)) fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go where p = (proc cmd $ toCommand params) @@ -216,24 +219,21 @@ , std_err = CreatePipe } go _ (Just hout) (Just herr) pid = - withAsync (S.hGetContents herr) $ \errreader -> do + withAsync (getstderr pid herr []) $ \errreader -> do val <- S.hGetContents hout - -- In case the process exits while something else, - -- like a background process, keeps the stderr handle - -- open, don't block forever waiting for stderr. - -- A few seconds after finishing reading stdout - -- should get any error message. - err <- either id id <$> - wait errreader - `race` (threadDelaySeconds (Seconds 2) >> return mempty) + err <- wait errreader forceSuccessProcess p pid r' <- store val st r return (r', val, err) go _ _ _ _ = error "internal" + getstderr pid herr c = hGetLineUntilExitOrEOF pid herr >>= \case + Just l -> getstderr pid herr (l:c) + Nothing -> return (unlines (reverse c)) + {- Reads git config from a specified file and returns the repo populated - with the configuration. -} -fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) +fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, String)) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -85,8 +85,8 @@ where go _ (Just outh) (Just errh) pid = do (o1, o2) <- concurrently - (parseFsckOutput maxobjs r outh) - (parseFsckOutput maxobjs r errh) + (parseFsckOutput maxobjs r outh pid) + (parseFsckOutput maxobjs r errh pid) fsckok <- checkSuccessProcess pid case mappend o1 o2 of FsckOutput badobjs truncated @@ -121,9 +121,9 @@ findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput -parseFsckOutput maxobjs r h = do - ls <- lines <$> hGetContents h +parseFsckOutput :: Int -> Repo -> Handle -> ProcessHandle -> IO FsckOutput +parseFsckOutput maxobjs r h pid = do + ls <- getlines [] if null ls then return NoFsckOutput else if all ("duplicateEntries" `isInfixOf`) ls @@ -133,6 +133,10 @@ let !truncated = length shas > maxobjs missingobjs <- findMissing (take maxobjs shas) r return $ FsckOutput missingobjs truncated + where + getlines c = hGetLineUntilExitOrEOF pid h >>= \case + Nothing -> return (reverse c) + Just l -> getlines (l:c) isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump diff --git a/Git/Hook.hs b/Git/Hook.hs --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -13,9 +13,7 @@ import Git import Utility.Tmp import Utility.Shell -#ifndef mingw32_HOST_OS import Utility.FileMode -#endif data Hook = Hook { hookName :: FilePath @@ -55,8 +53,9 @@ f = hookFile h r go = do viaTmp writeFile f (hookScript h) - p <- getPermissions f - void $ tryIO $ setPermissions f $ p {executable = True} + void $ tryIO $ modifyFileMode + (toRawFilePath f) + (addModes executeModes) return True {- Removes a hook. Returns False if the hook contained something else, and diff --git a/Git/Queue.hs b/Git/Queue.hs --- a/Git/Queue.hs +++ b/Git/Queue.hs @@ -207,11 +207,13 @@ where gitparams = gitCommandLine (Param (getSubcommand action):getParams action) repo +#ifndef mingw32_HOST_OS go p (Just h) _ _ pid = do hPutStr h $ intercalate "\0" $ toCommand $ getFiles action hClose h forceSuccessProcess p pid go _ _ _ _ _ = error "internal" +#endif runAction repo action@(InternalAction {}) = let InternalActionRunner _ runner = getRunner action in runner repo (getInternalFiles action) diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Repair ( runRepair, runRepairOf, @@ -243,11 +245,12 @@ explodePackedRefsFile :: Repo -> IO () explodePackedRefsFile r = do let f = packedRefsFile r + let f' = toRawFilePath f whenM (doesFileExist f) $ do rs <- mapMaybe parsePacked . lines - <$> catchDefaultIO "" (safeReadFile f) + <$> catchDefaultIO "" (safeReadFile f') forM_ rs makeref - removeWhenExistsWith removeLink f + removeWhenExistsWith R.removeLink f' where makeref (sha, ref) = do let gitd = localGitDir r @@ -444,13 +447,13 @@ preRepair :: Repo -> IO () preRepair g = do unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do - removeWhenExistsWith removeLink headfile - writeFile headfile "ref: refs/heads/master" + removeWhenExistsWith R.removeLink headfile + writeFile (fromRawFilePath headfile) "ref: refs/heads/master" explodePackedRefsFile g unless (repoIsLocalBare g) $ void $ tryIO $ allowWrite $ indexFile g where - headfile = fromRawFilePath (localGitDir g) "HEAD" + headfile = localGitDir g P. "HEAD" validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha (encodeBS' s)) @@ -616,7 +619,7 @@ successfulRepair :: (Bool, [Branch]) -> Bool successfulRepair = fst -safeReadFile :: FilePath -> IO String +safeReadFile :: RawFilePath -> IO String safeReadFile f = do - allowRead (toRawFilePath f) - readFileStrict f + allowRead f + readFileStrict (fromRawFilePath f) diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -131,7 +131,7 @@ v <- liftIO $ lockShared lck liftIO $ case v of Nothing -> catchDefaultIO Nothing $ - readTransferInfoFile Nothing tfile + readTransferInfoFile Nothing (fromRawFilePath tfile) Just lockhandle -> do dropLock lockhandle cleanstale diff --git a/Messages/Progress.hs b/Messages/Progress.hs --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -140,11 +140,11 @@ <$> pure True <*> mkStderrEmitter -mkStderrRelayer :: Annex (Handle -> IO ()) +mkStderrRelayer :: Annex (ProcessHandle -> Handle -> IO ()) mkStderrRelayer = do quiet <- commandProgressDisabled emitter <- mkStderrEmitter - return $ \h -> avoidProgress quiet h emitter + return $ \ph h -> avoidProgress quiet ph h emitter {- Generates an IO action that can be used to emit stderr. - diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -76,7 +76,7 @@ v <- tryNonAsync $ do let runtransfer ti = Right <$> transfer download k af (\p -> - getViaTmp rsp DefaultVerify k $ \tmp -> + getViaTmp rsp DefaultVerify k af $ \tmp -> storefile (fromRawFilePath tmp) o l getb validitycheck p ti) let fallback = return $ Left $ ProtoFailureMessage "transfer already in progress, or unable to take transfer lock" diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -37,6 +37,7 @@ import Utility.FileMode import Types.UUID import Annex.ChangedRefs +import qualified Utility.RawFilePath as R import Control.Monad.Free import Control.Monad.IO.Class @@ -124,7 +125,7 @@ -- the callback. serveUnixSocket :: FilePath -> (Handle -> IO ()) -> IO () serveUnixSocket unixsocket serveconn = do - removeWhenExistsWith removeLink unixsocket + removeWhenExistsWith R.removeLink (toRawFilePath unixsocket) soc <- S.socket S.AF_UNIX S.Stream S.defaultProtocol S.bind soc (S.SockAddrUnix unixsocket) -- Allow everyone to read and write to the socket, diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -382,7 +382,7 @@ (d:[]) -> return $ map (splitsize d) files _ -> parsefailed (show v) where - getfield = btshowmetainfo torrent + getfield = btshowmetainfo (fromRawFilePath torrent) parsefailed s = giveup $ "failed to parse btshowmetainfo output for torrent file: " ++ show s -- btshowmetainfo outputs a list of "filename (size)" diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -258,7 +258,7 @@ #ifdef mingw32_HOST_OS {- Windows needs the files inside the directory to be writable - before it can delete them. -} - void $ tryIO $ mapM_ allowWrite =<< dirContents dir + void $ tryIO $ mapM_ (allowWrite . toRawFilePath) =<< dirContents dir #endif tryNonAsync (removeDirectoryRecursive dir) >>= \case Right () -> return () @@ -301,10 +301,10 @@ removeExportM :: RawFilePath -> Key -> ExportLocation -> Annex () removeExportM d _k loc = liftIO $ do - removeWhenExistsWith removeLink src + removeWhenExistsWith R.removeLink src removeExportLocation d loc where - src = fromRawFilePath $ exportPath d loc + src = exportPath d loc checkPresentExportM :: RawFilePath -> Key -> ExportLocation -> Annex Bool checkPresentExportM d _k loc = @@ -446,7 +446,7 @@ #ifndef mingw32_HOST_OS =<< getFdStatus fd #else - =<< getFileStatus f + =<< R.getFileStatus f #endif guardSameContentIdentifiers cont cid currcid diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -22,6 +22,7 @@ import Annex.Tmp import Utility.Metered import Utility.Directory.Create +import qualified Utility.RawFilePath as R withCheckedFiles :: (FilePath -> IO Bool) -> FilePath -> (FilePath -> Key -> [FilePath]) -> Key -> ([FilePath] -> IO Bool) -> IO Bool withCheckedFiles _ [] _locations _ _ = return False @@ -98,15 +99,15 @@ retrieve :: (RawFilePath -> Key -> [RawFilePath]) -> RawFilePath -> Retriever retrieve locations d basek p c = withOtherTmp $ \tmpdir -> do showLongNote "This remote uses the deprecated chunksize setting. So this will be quite slow." - let tmp = fromRawFilePath $ - tmpdir P. keyFile basek <> ".directorylegacy.tmp" + let tmp = tmpdir P. keyFile basek <> ".directorylegacy.tmp" + let tmp' = fromRawFilePath tmp let go = \k sink -> do liftIO $ void $ withStoredFiles (fromRawFilePath d) (legacyLocations locations) k $ \fs -> do forM_ fs $ - S.appendFile tmp <=< S.readFile + S.appendFile tmp' <=< S.readFile return True - b <- liftIO $ L.readFile tmp - liftIO $ removeWhenExistsWith removeLink tmp + b <- liftIO $ L.readFile tmp' + liftIO $ removeWhenExistsWith R.removeLink tmp sink b byteRetriever go basek p c diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -487,7 +487,7 @@ extract Nothing = (Nothing, r) extract (Just r') = (fromConfigValue <$> Git.Config.getMaybe coreGCryptId r', r') -getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString, S.ByteString)) +getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString, String)) getConfigViaRsync r gc = do (rsynctransport, rsyncurl, _) <- rsyncTransport r gc opts <- rsynctransport diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -690,7 +690,7 @@ copier <- mkCopier hardlink st params let verify = Annex.Content.RemoteVerify r let rsp = RetrievalAllKeysSecure - res <- Annex.Content.getViaTmp rsp verify key $ \dest -> + res <- Annex.Content.getViaTmp rsp verify key file $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> copier object (fromRawFilePath dest) p' (liftIO checksuccessio) Annex.Content.saveState True diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -51,6 +51,7 @@ import qualified Git import qualified Git.Construct import Git.Types +import qualified Utility.RawFilePath as R import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -284,10 +285,10 @@ withBytes content $ \b -> decrypt cmd c cipher (feedBytes b) $ readBytes write - liftIO $ removeWhenExistsWith removeLink f + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) (Nothing, _, FileContent f) -> do withBytes content write - liftIO $ removeWhenExistsWith removeLink f + liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) (Nothing, _, ByteContent b) -> write b where write b = case mh of diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -28,7 +28,6 @@ import Control.Concurrent.STM import Control.Concurrent.Async -import qualified Data.ByteString as B toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam]) toRepo cs r gc remotecmd = do @@ -272,7 +271,7 @@ , P2P.connIdent = P2P.ConnIdent $ Just $ "ssh connection " ++ show pidnum } - stderrhandlerst <- newStderrHandler err + stderrhandlerst <- newStderrHandler err pid runst <- P2P.mkRunState P2P.Client let c = P2P.OpenConnection (runst, conn, pid, stderrhandlerst) -- When the connection is successful, the remote @@ -301,32 +300,24 @@ modifyTVar' connpool $ maybe (Just P2PSshUnsupported) Just -newStderrHandler :: Handle -> IO (TVar StderrHandlerState) -newStderrHandler errh = do +newStderrHandler :: Handle -> ProcessHandle -> IO (TVar StderrHandlerState) +newStderrHandler errh ph = do -- stderr from git-annex-shell p2pstdio is initially discarded -- because old versions don't support the command. Once it's known -- to be running, this is changed to DisplayStderr. v <- newTVarIO DiscardStderr - p <- async $ go v - void $ async $ ender p v + void $ async $ go v return v where go v = do - l <- B.hGetLine errh - atomically (readTVar v) >>= \case - DiscardStderr -> go v - DisplayStderr -> do - B.hPut stderr l - go v - EndStderrHandler -> return () - - ender p v = do - atomically $ do - readTVar v >>= \case - EndStderrHandler -> return () - _ -> retry - hClose errh - cancel p + hGetLineUntilExitOrEOF ph errh >>= \case + Nothing -> hClose errh + Just l -> atomically (readTVar v) >>= \case + DiscardStderr -> go v + DisplayStderr -> do + hPutStrLn stderr l + go v + EndStderrHandler -> hClose errh -- Runs a P2P Proto action on a remote when it supports that, -- otherwise the fallback action. diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -247,15 +247,14 @@ d <- newmainrepodir setmainrepodir d innewrepo $ do - git_annex "init" [reponame, "--quiet"] - @? "init failed" + git_annex "init" [reponame, "--quiet"] "init" preinitremote git_annex "initremote" ([ remotename , "type=" ++ remotetype , "--quiet" ] ++ config) - @? "init failed" + "init" r <- annexeval $ either error return =<< Remote.byName' remotename cache <- Command.TestRemote.newRemoteVariantCache @@ -368,7 +367,7 @@ test_init :: Assertion test_init = innewrepo $ do ver <- annexVersion <$> getTestMode - git_annex "init" [reponame, "--version", show (fromRepoVersion ver)] @? "init failed" + git_annex "init" [reponame, "--version", show (fromRepoVersion ver)] "init" setupTestMode where reponame = "test repo" @@ -378,62 +377,62 @@ test_add :: Assertion test_add = inmainrepo $ do writecontent annexedfile $ content annexedfile - add_annex annexedfile @? "add failed" + add_annex annexedfile "add" annexed_present annexedfile writecontent sha1annexedfile $ content sha1annexedfile - git_annex "add" [sha1annexedfile, "--backend=SHA1"] @? "add with SHA1 failed" + git_annex "add" [sha1annexedfile, "--backend=SHA1"] "add with SHA1" whenM (unlockedFiles <$> getTestMode) $ - git_annex "unlock" [sha1annexedfile] @? "unlock failed" + git_annex "unlock" [sha1annexedfile] "unlock" annexed_present sha1annexedfile checkbackend sha1annexedfile backendSHA1 writecontent ingitfile $ content ingitfile - boolSystem "git" [Param "add", File ingitfile] @? "git add failed" - boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "commit"] @? "git commit failed" - git_annex "add" [ingitfile] @? "add ingitfile should be no-op" + git "add" [ingitfile] "git add" + git "commit" ["-q", "-m", "commit"] "git commit" + git_annex "add" [ingitfile] "add ingitfile should be no-op" unannexed ingitfile test_add_dup :: Assertion test_add_dup = intmpclonerepo $ do writecontent annexedfiledup $ content annexedfiledup - add_annex annexedfiledup @? "add of second file with same content failed" + add_annex annexedfiledup "add of second file with same content failed" annexed_present annexedfiledup annexed_present annexedfile test_add_extras :: Assertion test_add_extras = intmpclonerepo $ do writecontent wormannexedfile $ content wormannexedfile - git_annex "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" + git_annex "add" [wormannexedfile, "--backend=WORM"] "add with WORM" whenM (unlockedFiles <$> getTestMode) $ - git_annex "unlock" [wormannexedfile] @? "unlock failed" + git_annex "unlock" [wormannexedfile] "unlock" annexed_present wormannexedfile checkbackend wormannexedfile backendWORM test_ignore_deleted_files :: Assertion test_ignore_deleted_files = intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" + git_annex "get" [annexedfile] "get" git_annex_expectoutput "find" [] [annexedfile] - removeWhenExistsWith removeLink annexedfile + removeWhenExistsWith R.removeLink (toRawFilePath annexedfile) -- A file that has been deleted, but the deletion not staged, -- is a special case; make sure git-annex skips these. git_annex_expectoutput "find" [] [] test_metadata :: Assertion test_metadata = intmpclonerepo $ do - git_annex "metadata" ["-s", "foo=bar", annexedfile] @? "set metadata" + git_annex "metadata" ["-s", "foo=bar", annexedfile] "set metadata" git_annex_expectoutput "find" ["--metadata", "foo=bar"] [annexedfile] git_annex_expectoutput "find" ["--metadata", "foo=other"] [] writecontent annexedfiledup $ content annexedfiledup - add_annex annexedfiledup @? "add of second file with same content failed" + add_annex annexedfiledup "add of second file with same content failed" annexed_present annexedfiledup git_annex_expectoutput "find" ["--metadata", "foo=bar"] [annexedfile, annexedfiledup] git_annex_shouldfail "metadata" ["--remove", "foo", "."] - @? "removing metadata from dir with multiple files failed to fail" + "removing metadata from dir with multiple files not allowed" git_annex "metadata" ["--remove", "foo", annexedfile] - @? "removing metadata failed" + "removing metadata" git_annex_expectoutput "find" ["--metadata", "foo=bar"] [] git_annex "metadata" ["--force", "-s", "foo=bar", "."] - @? "recursively set metadata force" + "recursively set metadata force" test_shared_clone :: Assertion test_shared_clone = intmpsharedclonerepo $ do @@ -448,30 +447,27 @@ test_log :: Assertion test_log = intmpclonerepo $ do - git_annex "log" [annexedfile] @? "log failed" + git_annex "log" [annexedfile] "log" test_view :: Assertion test_view = intmpclonerepo $ do - git_annex "metadata" ["-s", "test=test1", annexedfile] @? "metadata failed" - git_annex "metadata" ["-s", "test=test2", sha1annexedfile] @? "metadata failed" - git_annex "view" ["test=test1"] @? "entering view failed" + git_annex "metadata" ["-s", "test=test1", annexedfile] "metadata" + git_annex "metadata" ["-s", "test=test2", sha1annexedfile] "metadata" + git_annex "view" ["test=test1"] "entering view" checkexists annexedfile checkdoesnotexist sha1annexedfile test_magic :: Assertion test_magic = intmpclonerepo $ do #ifdef WITH_MAGICMIME - boolSystem "git" - [ Param "config" - , Param "annex.largefiles" - , Param "mimeencoding=binary" - ] @? "git config annex.largefiles failed" + git "config" ["annex.largefiles", "mimeencoding=binary"] + "git config annex.largefiles" writeFile "binary" "\127" writeFile "text" "test\n" git_annex "add" ["binary", "text"] - @? "git-annex add failed with mimeencoding in largefiles" + "git-annex add with mimeencoding in largefiles" git_annex "sync" [] - @? "git-annex sync failed" + "git-annex sync" (isJust <$> annexeval (Annex.CatFile.catKeyFile (encodeBS "binary"))) @? "binary file not added to annex despite mimeencoding config" (isNothing <$> annexeval (Annex.CatFile.catKeyFile (encodeBS "text"))) @@ -483,40 +479,40 @@ test_import :: Assertion test_import = intmpclonerepo $ Utility.Tmp.Dir.withTmpDir "importtest" $ \importdir -> do (toimport1, importf1, imported1) <- mktoimport importdir "import1" - git_annex "import" [toimport1] @? "import failed" + git_annex "import" [toimport1] "import" annexed_present_imported imported1 checkdoesnotexist importf1 (toimport2, importf2, imported2) <- mktoimport importdir "import2" - git_annex "import" [toimport2] @? "import of duplicate failed" + git_annex "import" [toimport2] "import of duplicate" annexed_present_imported imported2 checkdoesnotexist importf2 (toimport3, importf3, imported3) <- mktoimport importdir "import3" git_annex "import" ["--skip-duplicates", toimport3] - @? "import of duplicate with --skip-duplicates failed" + "import of duplicate with --skip-duplicates" checkdoesnotexist imported3 checkexists importf3 git_annex "import" ["--clean-duplicates", toimport3] - @? "import of duplicate with --clean-duplicates failed" + "import of duplicate with --clean-duplicates" checkdoesnotexist imported3 checkdoesnotexist importf3 (toimport4, importf4, imported4) <- mktoimport importdir "import4" - git_annex "import" ["--deduplicate", toimport4] @? "import --deduplicate failed" + git_annex "import" ["--deduplicate", toimport4] "import --deduplicate" checkdoesnotexist imported4 checkdoesnotexist importf4 (toimport5, importf5, imported5) <- mktoimport importdir "import5" - git_annex "import" ["--duplicate", toimport5] @? "import --duplicate failed" + git_annex "import" ["--duplicate", toimport5] "import --duplicate" annexed_present_imported imported5 checkexists importf5 - git_annex "drop" ["--force", imported1, imported2, imported5] @? "drop failed" + git_annex "drop" ["--force", imported1, imported2, imported5] "drop" annexed_notpresent_imported imported2 (toimportdup, importfdup, importeddup) <- mktoimport importdir "importdup" git_annex_shouldfail "import" ["--clean-duplicates", toimportdup] - @? "import of missing duplicate with --clean-duplicates failed to fail" + "import of missing duplicate with --clean-duplicates not allowed" checkdoesnotexist importeddup checkexists importfdup where @@ -528,16 +524,16 @@ test_reinject :: Assertion test_reinject = intmpclonerepo $ do - git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" + git_annex "drop" ["--force", sha1annexedfile] "drop" annexed_notpresent sha1annexedfile writecontent tmp $ content sha1annexedfile key <- Key.serializeKey <$> getKey backendSHA1 tmp - git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" + git_annex "reinject" [tmp, sha1annexedfile] "reinject" annexed_present sha1annexedfile -- fromkey can't be used on a crippled filesystem, since it makes a -- symlink unlessM (annexeval Config.crippledFileSystem) $ do - git_annex "fromkey" [key, sha1annexedfiledup] @? "fromkey failed for dup" + git_annex "fromkey" [key, sha1annexedfiledup] "fromkey for dup" annexed_present_locked sha1annexedfiledup where tmp = "tmpfile" @@ -545,41 +541,40 @@ test_unannex_nocopy :: Assertion test_unannex_nocopy = intmpclonerepo $ do annexed_notpresent annexedfile - git_annex "unannex" [annexedfile] @? "unannex failed with no copy" + git_annex "unannex" [annexedfile] "unannex with no copy" annexed_notpresent annexedfile test_unannex_withcopy :: Assertion test_unannex_withcopy = intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" + git_annex "get" [annexedfile] "get" annexed_present annexedfile - git_annex "unannex" [annexedfile, sha1annexedfile] @? "unannex failed" + git_annex "unannex" [annexedfile, sha1annexedfile] "unannex" unannexed annexedfile - git_annex "unannex" [annexedfile] @? "unannex failed on non-annexed file" + git_annex "unannex" [annexedfile] "unannex on non-annexed file" unannexed annexedfile - git_annex "unannex" [ingitfile] @? "unannex ingitfile should be no-op" + git_annex "unannex" [ingitfile] "unannex ingitfile should be no-op" unannexed ingitfile test_drop_noremote :: Assertion test_drop_noremote = intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" - boolSystem "git" [Param "remote", Param "rm", Param "origin"] - @? "git remote rm origin failed" - git_annex_shouldfail "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" + git_annex "get" [annexedfile] "get" + git "remote" ["rm", "origin"] "git remote rm origin" + git_annex_shouldfail "drop" [annexedfile] "drop with no known copy of file not allowed" annexed_present annexedfile - git_annex "drop" ["--force", annexedfile] @? "drop --force failed" + git_annex "drop" ["--force", annexedfile] "drop --force" annexed_notpresent annexedfile - git_annex "drop" [annexedfile] @? "drop of dropped file failed" - git_annex "drop" [ingitfile] @? "drop ingitfile should be no-op" + git_annex "drop" [annexedfile] "drop of dropped file" + git_annex "drop" [ingitfile] "drop ingitfile should be no-op" unannexed ingitfile test_drop_withremote :: Assertion test_drop_withremote = intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" + git_annex "get" [annexedfile] "get" annexed_present annexedfile - git_annex "numcopies" ["2"] @? "numcopies config failed" - git_annex_shouldfail "drop" [annexedfile] @? "drop succeeded although numcopies is not satisfied" - git_annex "numcopies" ["1"] @? "numcopies config failed" - git_annex "drop" [annexedfile] @? "drop failed though origin has copy" + git_annex "numcopies" ["2"] "numcopies config" + git_annex_shouldfail "drop" [annexedfile] "drop with numcopies not satisfied is not allowed" + git_annex "numcopies" ["1"] "numcopies config" + git_annex "drop" [annexedfile] "drop when origin has copy" annexed_notpresent annexedfile -- make sure that the correct symlink is staged for the file -- after drop @@ -588,10 +583,10 @@ test_drop_untrustedremote :: Assertion test_drop_untrustedremote = intmpclonerepo $ do - git_annex "untrust" ["origin"] @? "untrust of origin failed" - git_annex "get" [annexedfile] @? "get failed" + git_annex "untrust" ["origin"] "untrust of origin" + git_annex "get" [annexedfile] "get" annexed_present annexedfile - git_annex_shouldfail "drop" [annexedfile] @? "drop wrongly succeeded with only an untrusted copy of the file" + git_annex_shouldfail "drop" [annexedfile] "drop with only an untrusted copy of the file should fail" annexed_present annexedfile inmainrepo $ annexed_present annexedfile @@ -610,15 +605,15 @@ test_get' setup = setup $ do inmainrepo $ annexed_present annexedfile annexed_notpresent annexedfile - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "get" [annexedfile] "get of file" inmainrepo $ annexed_present annexedfile annexed_present annexedfile - git_annex "get" [annexedfile] @? "get of file already here failed" + git_annex "get" [annexedfile] "get of file already here" inmainrepo $ annexed_present annexedfile annexed_present annexedfile inmainrepo $ unannexed ingitfile unannexed ingitfile - git_annex "get" [ingitfile] @? "get ingitfile should be no-op" + git_annex "get" [ingitfile] "get ingitfile should be no-op" inmainrepo $ unannexed ingitfile unannexed ingitfile @@ -637,63 +632,63 @@ test_move' setup = setup $ do annexed_notpresent annexedfile inmainrepo $ annexed_present annexedfile - git_annex "move" ["--from", "origin", annexedfile] @? "move --from of file failed" + git_annex "move" ["--from", "origin", annexedfile] "move --from of file" annexed_present annexedfile inmainrepo $ annexed_notpresent annexedfile - git_annex "move" ["--from", "origin", annexedfile] @? "move --from of file already here failed" + git_annex "move" ["--from", "origin", annexedfile] "move --from of file already here" annexed_present annexedfile inmainrepo $ annexed_notpresent annexedfile - git_annex "move" ["--to", "origin", annexedfile] @? "move --to of file failed" + git_annex "move" ["--to", "origin", annexedfile] "move --to of file" inmainrepo $ annexed_present annexedfile annexed_notpresent annexedfile - git_annex "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" + git_annex "move" ["--to", "origin", annexedfile] "move --to of file already there" inmainrepo $ annexed_present annexedfile annexed_notpresent annexedfile unannexed ingitfile inmainrepo $ unannexed ingitfile - git_annex "move" ["--to", "origin", ingitfile] @? "move of ingitfile should be no-op" + git_annex "move" ["--to", "origin", ingitfile] "move of ingitfile should be no-op" unannexed ingitfile inmainrepo $ unannexed ingitfile - git_annex "move" ["--from", "origin", ingitfile] @? "move of ingitfile should be no-op" + git_annex "move" ["--from", "origin", ingitfile] "move of ingitfile should be no-op" unannexed ingitfile inmainrepo $ unannexed ingitfile test_move_numcopies :: Assertion test_move_numcopies = intmpclonerepo $ do inmainrepo $ annexed_present annexedfile - git_annex "numcopies" ["2"] @? "setting numcopies failed" - git_annex "move" ["--from", "origin", annexedfile] @? "move of file --from remote with numcopies unsatisfied but not made worse failed unexpectedly" + git_annex "numcopies" ["2"] "setting numcopies" + git_annex "move" ["--from", "origin", annexedfile] "move of file --from remote with numcopies unsatisfied but not made worse" annexed_present annexedfile inmainrepo $ annexed_notpresent annexedfile - git_annex "move" ["--to", "origin", annexedfile] @? "move of file --to remote with numcopies unsatisfied but not made worse failed unexpectedly" + git_annex "move" ["--to", "origin", annexedfile] "move of file --to remote with numcopies unsatisfied but not made worse" annexed_notpresent annexedfile inmainrepo $ annexed_present annexedfile - git_annex "get" [annexedfile] @? "get of file failed" - git_annex_shouldfail "move" ["--from", "origin", annexedfile] @? "move of file --from remote violated numcopies setting" - git_annex_shouldfail "move" ["--to", "origin", annexedfile] @? "move of file --to remote violated numcopies setting" + git_annex "get" [annexedfile] "get of file" + git_annex_shouldfail "move" ["--from", "origin", annexedfile] "move of file --from remote that violates numcopies setting not allowd" + git_annex_shouldfail "move" ["--to", "origin", annexedfile] "move of file --to remote that violates numcopies setting not allowed" test_copy :: Assertion test_copy = intmpclonerepo $ do annexed_notpresent annexedfile inmainrepo $ annexed_present annexedfile - git_annex "copy" ["--from", "origin", annexedfile] @? "copy --from of file failed" + git_annex "copy" ["--from", "origin", annexedfile] "copy --from of file" annexed_present annexedfile inmainrepo $ annexed_present annexedfile - git_annex "copy" ["--from", "origin", annexedfile] @? "copy --from of file already here failed" + git_annex "copy" ["--from", "origin", annexedfile] "copy --from of file already here" annexed_present annexedfile inmainrepo $ annexed_present annexedfile - git_annex "copy" ["--to", "origin", annexedfile] @? "copy --to of file already there failed" + git_annex "copy" ["--to", "origin", annexedfile] "copy --to of file already there" annexed_present annexedfile inmainrepo $ annexed_present annexedfile - git_annex "move" ["--to", "origin", annexedfile] @? "move --to of file already there failed" + git_annex "move" ["--to", "origin", annexedfile] "move --to of file already there" annexed_notpresent annexedfile inmainrepo $ annexed_present annexedfile unannexed ingitfile inmainrepo $ unannexed ingitfile - git_annex "copy" ["--to", "origin", ingitfile] @? "copy of ingitfile should be no-op" + git_annex "copy" ["--to", "origin", ingitfile] "copy of ingitfile should be no-op" unannexed ingitfile inmainrepo $ unannexed ingitfile - git_annex "copy" ["--from", "origin", ingitfile] @? "copy of ingitfile should be no-op" + git_annex "copy" ["--from", "origin", ingitfile] "copy of ingitfile should be no-op" checkregularfile ingitfile checkcontent ingitfile @@ -702,40 +697,40 @@ annexed_notpresent annexedfile -- get/copy --auto looks only at numcopies when preferred content is not -- set, and with 1 copy existing, does not get the file. - git_annex "get" ["--auto", annexedfile] @? "get --auto of file failed with default preferred content" + git_annex "get" ["--auto", annexedfile] "get --auto of file with default preferred content" annexed_notpresent annexedfile - git_annex "copy" ["--from", "origin", "--auto", annexedfile] @? "copy --auto --from of file failed with default preferred content" + git_annex "copy" ["--from", "origin", "--auto", annexedfile] "copy --auto --from of file with default preferred content" annexed_notpresent annexedfile - git_annex "wanted" [".", "standard"] @? "set expression to standard failed" - git_annex "group" [".", "client"] @? "set group to standard failed" - git_annex "get" ["--auto", annexedfile] @? "get --auto of file failed for client" + git_annex "wanted" [".", "standard"] "set expression to standard" + git_annex "group" [".", "client"] "set group to standard" + git_annex "get" ["--auto", annexedfile] "get --auto of file for client" annexed_present annexedfile - git_annex "drop" [annexedfile] @? "drop of file failed" - git_annex "copy" ["--from", "origin", "--auto", annexedfile] @? "copy --auto --from of file failed for client" + git_annex "drop" [annexedfile] "drop of file" + git_annex "copy" ["--from", "origin", "--auto", annexedfile] "copy --auto --from of file for client" annexed_present annexedfile - git_annex "ungroup" [".", "client"] @? "ungroup failed" + git_annex "ungroup" [".", "client"] "ungroup" - git_annex "wanted" [".", "standard"] @? "set expression to standard failed" - git_annex "group" [".", "manual"] @? "set group to manual failed" + git_annex "wanted" [".", "standard"] "set expression to standard" + git_annex "group" [".", "manual"] "set group to manual" -- drop --auto with manual leaves the file where it is - git_annex "drop" ["--auto", annexedfile] @? "drop --auto of file failed with manual preferred content" + git_annex "drop" ["--auto", annexedfile] "drop --auto of file with manual preferred content" annexed_present annexedfile - git_annex "drop" [annexedfile] @? "drop of file failed" + git_annex "drop" [annexedfile] "drop of file" annexed_notpresent annexedfile -- copy/get --auto with manual does not get the file - git_annex "get" ["--auto", annexedfile] @? "get --auto of file failed with manual preferred content" + git_annex "get" ["--auto", annexedfile] "get --auto of file with manual preferred content" annexed_notpresent annexedfile - git_annex "copy" ["--from", "origin", "--auto", annexedfile] @? "copy --auto --from of file failed with manual preferred content" + git_annex "copy" ["--from", "origin", "--auto", annexedfile] "copy --auto --from of file with manual preferred content" annexed_notpresent annexedfile - git_annex "ungroup" [".", "client"] @? "ungroup failed" + git_annex "ungroup" [".", "client"] "ungroup" - git_annex "wanted" [".", "exclude=*"] @? "set expression to exclude=* failed" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "wanted" [".", "exclude=*"] "set expression to exclude=*" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "drop" ["--auto", annexedfile] @? "drop --auto of file failed with exclude=*" + git_annex "drop" ["--auto", annexedfile] "drop --auto of file with exclude=*" annexed_notpresent annexedfile - git_annex "get" ["--auto", annexedfile] @? "get --auto of file failed with exclude=*" + git_annex "get" ["--auto", annexedfile] "get --auto of file with exclude=*" annexed_notpresent annexedfile test_lock :: Assertion @@ -745,41 +740,41 @@ -- regression test: unlock of newly added, not committed file -- should not fail. writecontent "newfile" "foo" - git_annex "add" ["newfile"] @? "add new file failed" - git_annex "unlock" ["newfile"] @? "unlock failed on newly added, never committed file" + git_annex "add" ["newfile"] "add new file" + git_annex "unlock" ["newfile"] "unlock on newly added, never committed file" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "unlock" [annexedfile] @? "unlock failed" + git_annex "unlock" [annexedfile] "unlock" unannexed annexedfile -- write different content, to verify that lock -- throws it away changecontent annexedfile writecontent annexedfile $ content annexedfile ++ "foo" - git_annex_shouldfail "lock" [annexedfile] @? "lock failed to fail without --force" - git_annex "lock" ["--force", annexedfile] @? "lock --force failed" + git_annex_shouldfail "lock" [annexedfile] "lock without --force should not be allowed" + git_annex "lock" ["--force", annexedfile] "lock --force" -- The original content of an unlocked file is not always -- preserved after modification, so re-get it. - git_annex "get" [annexedfile] @? "get of file failed after lock --force" + git_annex "get" [annexedfile] "get of file after lock --force" annexed_present_locked annexedfile - git_annex "unlock" [annexedfile] @? "unlock failed" + git_annex "unlock" [annexedfile] "unlock" unannexed annexedfile changecontent annexedfile - boolSystem "git" [Param "add", Param annexedfile] @? "add of modified file failed" + git "add" [annexedfile] "add of modified file" runchecks [checkregularfile, checkwritable] annexedfile c <- readFile annexedfile assertEqual "content of modified file" c (changedcontent annexedfile) - r' <- git_annex "drop" [annexedfile] - not r' @? "drop wrongly succeeded with no known copy of modified file" + git_annex_shouldfail "drop" [annexedfile] + "drop with no known copy of modified file should not be allowed" -- Regression test: lock --force when work tree file -- was modified lost the (unmodified) annex object. -- (Only occurred when the keys database was out of sync.) test_lock_force :: Assertion test_lock_force = intmpclonerepo $ do - git_annex "upgrade" [] @? "upgrade failed" - git_annex "get" [annexedfile] @? "get of file failed" - git_annex "unlock" [annexedfile] @? "unlock failed" + git_annex "upgrade" [] "upgrade" + git_annex "get" [annexedfile] "get of file" + git_annex "unlock" [annexedfile] "unlock" annexeval $ do Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) Database.Keys.removeInodeCaches k @@ -787,8 +782,8 @@ liftIO . removeWhenExistsWith R.removeLink =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache writecontent annexedfile "test_lock_force content" - git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail" - git_annex "lock" ["--force", annexedfile] @? "lock --force of modified file failed" + git_annex_shouldfail "lock" [annexedfile] "lock of modified file should not be allowed" + git_annex "lock" ["--force", annexedfile] "lock --force of modified file" annexed_present_locked annexedfile test_edit :: Assertion @@ -799,45 +794,41 @@ test_edit' :: Bool -> Assertion test_edit' precommit = intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "edit" [annexedfile] @? "edit failed" + git_annex "edit" [annexedfile] "edit" unannexed annexedfile changecontent annexedfile - boolSystem "git" [Param "add", File annexedfile] - @? "git add of edited file failed" + git "add" [annexedfile] "git add of edited file" if precommit - then git_annex "pre-commit" [] - @? "pre-commit failed" - else boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "contentchanged"] - @? "git commit of edited file failed" + then git_annex "pre-commit" [] "pre-commit" + else git "commit" ["-q", "-m", "contentchanged"] "git commit of edited file" runchecks [checkregularfile, checkwritable] annexedfile c <- readFile annexedfile assertEqual "content of modified file" c (changedcontent annexedfile) - git_annex_shouldfail "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file" + git_annex_shouldfail "drop" [annexedfile] "drop no known copy of modified file should not be allowed" test_partial_commit :: Assertion test_partial_commit = intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "unlock" [annexedfile] @? "unlock failed" + git_annex "unlock" [annexedfile] "unlock" changecontent annexedfile - boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "test", File annexedfile] - @? "partial commit of unlocked file should be allowed" + git "commit" ["-q", "-m", "test", annexedfile] + "partial commit of unlocked file should be allowed" test_fix :: Assertion test_fix = intmpclonerepo $ unlessM (hasUnlockedFiles <$> getTestMode) $ do annexed_notpresent annexedfile - git_annex "fix" [annexedfile] @? "fix of not present failed" + git_annex "fix" [annexedfile] "fix of not present" annexed_notpresent annexedfile - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "fix" [annexedfile] @? "fix of present file failed" + git_annex "fix" [annexedfile] "fix of present file" annexed_present annexedfile createDirectory subdir - boolSystem "git" [Param "mv", File annexedfile, File subdir] - @? "git mv failed" - git_annex "fix" [newfile] @? "fix of moved file failed" + git "mv" [annexedfile, subdir] "git mv" + git_annex "fix" [newfile] "fix of moved file" runchecks [checklink, checkunwritable] newfile c <- readFile newfile assertEqual "content of moved file" c (content annexedfile) @@ -847,21 +838,21 @@ test_trust :: Assertion test_trust = intmpclonerepo $ do - git_annex "trust" [repo] @? "trust failed" + git_annex "trust" [repo] "trust" trustcheck Logs.Trust.Trusted "trusted 1" - git_annex "trust" [repo] @? "trust of trusted failed" + git_annex "trust" [repo] "trust of trusted" trustcheck Logs.Trust.Trusted "trusted 2" - git_annex "untrust" [repo] @? "untrust failed" + git_annex "untrust" [repo] "untrust" trustcheck Logs.Trust.UnTrusted "untrusted 1" - git_annex "untrust" [repo] @? "untrust of untrusted failed" + git_annex "untrust" [repo] "untrust of untrusted" trustcheck Logs.Trust.UnTrusted "untrusted 2" - git_annex "dead" [repo] @? "dead failed" + git_annex "dead" [repo] "dead" trustcheck Logs.Trust.DeadTrusted "deadtrusted 1" - git_annex "dead" [repo] @? "dead of dead failed" + git_annex "dead" [repo] "dead of dead" trustcheck Logs.Trust.DeadTrusted "deadtrusted 2" - git_annex "semitrust" [repo] @? "semitrust failed" + git_annex "semitrust" [repo] "semitrust" trustcheck Logs.Trust.SemiTrusted "semitrusted 1" - git_annex "semitrust" [repo] @? "semitrust of semitrusted failed" + git_annex "semitrust" [repo] "semitrust of semitrusted" trustcheck Logs.Trust.SemiTrusted "semitrusted 2" where repo = "origin" @@ -874,52 +865,52 @@ test_fsck_basic :: Assertion test_fsck_basic = intmpclonerepo $ do - git_annex "fsck" [] @? "fsck failed" - git_annex "numcopies" ["2"] @? "numcopies config failed" + git_annex "fsck" [] "fsck" + git_annex "numcopies" ["2"] "numcopies config" fsck_should_fail "numcopies unsatisfied" - git_annex "numcopies" ["1"] @? "numcopies config failed" + git_annex "numcopies" ["1"] "numcopies config" corrupt annexedfile corrupt sha1annexedfile where corrupt f = do - git_annex "get" [f] @? "get of file failed" + git_annex "get" [f] "get of file" Utility.FileMode.allowWrite (toRawFilePath f) writecontent f (changedcontent f) ifM (hasUnlockedFiles <$> getTestMode) - ( git_annex "fsck" [] @? "fsck failed on unlocked file with changed file content" - , git_annex_shouldfail "fsck" [] @? "fsck failed to fail with corrupted file content" + ( git_annex "fsck" []"fsck on unlocked file with changed file content" + , git_annex_shouldfail "fsck" [] "fsck with corrupted file content should error" ) - git_annex "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f + git_annex "fsck" [] "second fsck, after first fsck should have fixed problem" test_fsck_bare :: Assertion test_fsck_bare = intmpbareclonerepo $ - git_annex "fsck" [] @? "fsck failed" + git_annex "fsck" [] "fsck" test_fsck_localuntrusted :: Assertion test_fsck_localuntrusted = intmpclonerepo $ do - git_annex "get" [annexedfile] @? "get failed" - git_annex "untrust" ["origin"] @? "untrust of origin repo failed" - git_annex "untrust" ["."] @? "untrust of current repo failed" + git_annex "get" [annexedfile] "get" + git_annex "untrust" ["origin"] "untrust of origin repo" + git_annex "untrust" ["."] "untrust of current repo" fsck_should_fail "content only available in untrusted (current) repository" - git_annex "trust" ["."] @? "trust of current repo failed" - git_annex "fsck" [annexedfile] @? "fsck failed on file present in trusted repo" + git_annex "trust" ["."] "trust of current repo" + git_annex "fsck" [annexedfile] "fsck on file present in trusted repo" test_fsck_remoteuntrusted :: Assertion test_fsck_remoteuntrusted = intmpclonerepo $ do - git_annex "numcopies" ["2"] @? "numcopies config failed" - git_annex "get" [annexedfile] @? "get failed" - git_annex "get" [sha1annexedfile] @? "get failed" - git_annex "fsck" [] @? "fsck failed with numcopies=2 and 2 copies" - git_annex "untrust" ["origin"] @? "untrust of origin failed" + git_annex "numcopies" ["2"] "numcopies config" + git_annex "get" [annexedfile] "get" + git_annex "get" [sha1annexedfile] "get" + git_annex "fsck" [] "fsck with numcopies=2 and 2 copies" + git_annex "untrust" ["origin"] "untrust of origin" fsck_should_fail "content not replicated to enough non-untrusted repositories" test_fsck_fromremote :: Assertion test_fsck_fromremote = intmpclonerepo $ do - git_annex "fsck" ["--from", "origin"] @? "fsck --from origin failed" + git_annex "fsck" ["--from", "origin"] "fsck --from origin" fsck_should_fail :: String -> Assertion fsck_should_fail m = git_annex_shouldfail "fsck" [] - @? "fsck failed to fail with " ++ m + ("fsck should not succeed with " ++ m) test_migrate :: Assertion test_migrate = test_migrate' False @@ -931,24 +922,24 @@ test_migrate' usegitattributes = intmpclonerepo $ do annexed_notpresent annexedfile annexed_notpresent sha1annexedfile - git_annex "migrate" [annexedfile] @? "migrate of not present failed" - git_annex "migrate" [sha1annexedfile] @? "migrate of not present failed" - git_annex "get" [annexedfile] @? "get of file failed" - git_annex "get" [sha1annexedfile] @? "get of file failed" + git_annex "migrate" [annexedfile] "migrate of not present" + git_annex "migrate" [sha1annexedfile] "migrate of not present" + git_annex "get" [annexedfile] "get of file" + git_annex "get" [sha1annexedfile] "get of file" annexed_present annexedfile annexed_present sha1annexedfile if usegitattributes then do writeFile ".gitattributes" "* annex.backend=SHA1" git_annex "migrate" [sha1annexedfile] - @? "migrate sha1annexedfile failed" + "migrate sha1annexedfile" git_annex "migrate" [annexedfile] - @? "migrate annexedfile failed" + "migrate annexedfile" else do git_annex "migrate" [sha1annexedfile, "--backend", "SHA1"] - @? "migrate sha1annexedfile failed" + "migrate sha1annexedfile" git_annex "migrate" [annexedfile, "--backend", "SHA1"] - @? "migrate annexedfile failed" + "migrate annexedfile" annexed_present annexedfile annexed_present sha1annexedfile checkbackend annexedfile backendSHA1 @@ -956,10 +947,8 @@ -- check that reversing a migration works writeFile ".gitattributes" "* annex.backend=SHA256" - git_annex "migrate" [sha1annexedfile] - @? "migrate sha1annexedfile failed" - git_annex "migrate" [annexedfile] - @? "migrate annexedfile failed" + git_annex "migrate" [sha1annexedfile] "migrate sha1annexedfile" + git_annex "migrate" [annexedfile] "migrate annexedfile" annexed_present annexedfile annexed_present sha1annexedfile checkbackend annexedfile backendSHA256 @@ -968,33 +957,32 @@ test_unused :: Assertion test_unused = intmpclonerepo $ do checkunused [] "in new clone" - git_annex "get" [annexedfile] @? "get of file failed" - git_annex "get" [sha1annexedfile] @? "get of file failed" + git_annex "get" [annexedfile] "get of file" + git_annex "get" [sha1annexedfile] "get of file" annexedfilekey <- getKey backendSHA256E annexedfile sha1annexedfilekey <- getKey backendSHA1 sha1annexedfile checkunused [] "after get" - boolSystem "git" [Param "rm", Param "-fq", File annexedfile] @? "git rm failed" + git "rm" ["-fq", annexedfile] "git rm" checkunused [] "after rm" -- commit the rm, and when on an adjusted branch, sync it back to -- the master branch - git_annex "sync" ["--no-push", "--no-pull"] @? "git-annex sync failed" + git_annex "sync" ["--no-push", "--no-pull"] "git-annex sync" checkunused [] "after commit" -- unused checks origin/master; once it's gone it is really unused - boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "git remote rm origin failed" + git "remote" ["rm", "origin"] "git remote rm origin" checkunused [annexedfilekey] "after origin branches are gone" - boolSystem "git" [Param "rm", Param "-fq", File sha1annexedfile] @? "git rm failed" - git_annex "sync" ["--no-push", "--no-pull"] @? "git-annex sync failed" + git "rm" ["-fq", sha1annexedfile] "git rm" + git_annex "sync" ["--no-push", "--no-pull"] "git-annex sync" checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile" -- good opportunity to test dropkey also - git_annex "dropkey" ["--force", Key.serializeKey annexedfilekey] - @? "dropkey failed" + git_annex "dropkey" ["--force", Key.serializeKey annexedfilekey] "dropkey" checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Key.serializeKey annexedfilekey) - git_annex_shouldfail "dropunused" ["1"] @? "dropunused failed to fail without --force" - git_annex "dropunused" ["--force", "1"] @? "dropunused failed" + git_annex_shouldfail "dropunused" ["1"] "dropunused should not be allowed without --force" + git_annex "dropunused" ["--force", "1"] "dropunused" checkunused [] "after dropunused" - git_annex_shouldfail "dropunused" ["--force", "10", "501"] @? "dropunused failed to fail on bogus numbers" + git_annex_shouldfail "dropunused" ["--force", "10", "501"] "dropunused on bogus numbers" -- Unused used to miss renamed symlinks that were not staged -- and pointed at annexed content, and think that content was unused. @@ -1003,10 +991,10 @@ -- to associate it with the key. unlessM (hasUnlockedFiles <$> getTestMode) $ do writecontent "unusedfile" "unusedcontent" - git_annex "add" ["unusedfile"] @? "add of unusedfile failed" + git_annex "add" ["unusedfile"] "add of unusedfile" unusedfilekey <- getKey backendSHA256E "unusedfile" renameFile "unusedfile" "unusedunstagedfile" - boolSystem "git" [Param "rm", Param "-qf", File "unusedfile"] @? "git rm failed" + git "rm" ["-qf", "unusedfile"] "git rm" checkunused [] "with unstaged link" removeFile "unusedunstagedfile" checkunused [unusedfilekey] "with renamed link deleted" @@ -1014,18 +1002,18 @@ -- unused used to miss symlinks that were deleted or modified -- manually writecontent "unusedfile" "unusedcontent" - git_annex "add" ["unusedfile"] @? "add of unusedfile failed" - boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" + git_annex "add" ["unusedfile"] "add of unusedfile" + git "add" ["unusedfile"] "git add" unusedfilekey' <- getKey backendSHA256E "unusedfile" checkunused [] "with staged deleted link" - boolSystem "git" [Param "rm", Param "-qf", File "unusedfile"] @? "git rm failed" + git "rm" ["-qf", "unusedfile"] "git rm" checkunused [unusedfilekey'] "with staged link deleted" -- unused used to false positive on symlinks that were -- deleted or modified manually, but not staged as such writecontent "unusedfile" "unusedcontent" - git_annex "add" ["unusedfile"] @? "add of unusedfile failed" - boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" + git_annex "add" ["unusedfile"] "add of unusedfile" + git "add" ["unusedfile"] "git add" checkunused [] "with staged file" removeFile "unusedfile" checkunused [] "with staged deleted file" @@ -1036,17 +1024,17 @@ whenM (hasUnlockedFiles <$> getTestMode) $ do let f = "unlockedfile" writecontent f "unlockedcontent1" - boolSystem "git" [Param "add", File "unlockedfile"] @? "git add failed" + git "add" ["unlockedfile"] "git add" checkunused [] "with unlocked file before modification" writecontent f "unlockedcontent2" checkunused [] "with unlocked file after modification" - not <$> boolSystem "git" [Param "diff", Param "--quiet", File f] @? "git diff did not show changes to unlocked file" + git_shouldfail "diff" ["--quiet", f] "git diff should exit nonzero when unlocked file is modified" -- still nothing unused because one version is in the index -- and the other is in the work tree checkunused [] "with unlocked file after git diff" where checkunused expectedkeys desc = do - git_annex "unused" [] @? "unused failed" + git_annex "unused" [] "unused" unusedmap <- annexeval $ Logs.Unused.readUnusedMap mempty let unusedkeys = M.elems unusedmap assertEqual ("unused keys differ " ++ desc) @@ -1054,14 +1042,14 @@ test_describe :: Assertion test_describe = intmpclonerepo $ do - git_annex "describe" [".", "this repo"] @? "describe 1 failed" - git_annex "describe" ["origin", "origin repo"] @? "describe 2 failed" + git_annex "describe" [".", "this repo"] "describe 1" + git_annex "describe" ["origin", "origin repo"] "describe 2" test_find :: Assertion test_find = intmpclonerepo $ do annexed_notpresent annexedfile git_annex_expectoutput "find" [] [] - git_annex "get" [annexedfile] @? "get failed" + git_annex "get" [annexedfile] "get" annexed_present annexedfile annexed_notpresent sha1annexedfile git_annex_expectoutput "find" [] [annexedfile] @@ -1076,13 +1064,13 @@ - and --exclude=* should exclude them. -} createDirectory "dir" writecontent "dir/subfile" "subfile" - git_annex "add" ["dir"] @? "add of subdir failed" + git_annex "add" ["dir"] "add of subdir" git_annex_expectoutput "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] git_annex_expectoutput "find" ["--exclude", "*"] [] test_merge :: Assertion test_merge = intmpclonerepo $ - git_annex "merge" [] @? "merge failed" + git_annex "merge" [] "merge" test_info :: Assertion test_info = intmpclonerepo $ do @@ -1093,22 +1081,22 @@ test_version :: Assertion test_version = intmpclonerepo $ - git_annex "version" [] @? "version failed" + git_annex "version" [] "version" test_sync :: Assertion test_sync = intmpclonerepo $ do - git_annex "sync" [] @? "sync failed" + git_annex "sync" [] "sync" {- Regression test for bug fixed in - 039e83ed5d1a11fd562cce55b8429c840d72443e, where a present - wanted file was dropped. -} - git_annex "get" [annexedfile] @? "get failed" + git_annex "get" [annexedfile] "get" git_annex_expectoutput "find" ["--in", "."] [annexedfile] - git_annex "wanted" [".", "present"] @? "wanted failed" - git_annex "sync" ["--content"] @? "sync failed" + git_annex "wanted" [".", "present"] "wanted" + git_annex "sync" ["--content"] "sync" git_annex_expectoutput "find" ["--in", "."] [annexedfile] - git_annex "drop" [annexedfile] @? "drop failed" + git_annex "drop" [annexedfile] "drop" git_annex_expectoutput "find" ["--in", "."] [] - git_annex "sync" ["--content"] @? "sync failed" + git_annex "sync" ["--content"] "sync" git_annex_expectoutput "find" ["--in", "."] [] {- Regression test for the concurrency bug fixed in @@ -1118,23 +1106,22 @@ makedup dupfile -- This was sufficient currency to trigger the bug. git_annex "get" ["-J1", annexedfile, dupfile] - @? "concurrent get -J1 with dup failed" + "concurrent get -J1 with dup" git_annex "drop" ["-J1"] - @? "drop with dup failed" + "drop with dup" -- With -J2, one more dup file was needed to trigger the bug. makedup dupfile2 git_annex "get" ["-J2", annexedfile, dupfile, dupfile2] - @? "concurrent get -J2 with dup failed" + "concurrent get -J2 with dup" git_annex "drop" ["-J2"] - @? "drop with dup failed" + "drop with dup" where dupfile = annexedfile ++ "2" dupfile2 = annexedfile ++ "3" makedup f = do Utility.CopyFile.copyFileExternal Utility.CopyFile.CopyAllMetaData annexedfile f @? "copying annexed file failed" - boolSystem "git" [Param "add", File f] - @? "git add failed" + git "add" [f] "git add" {- Regression test for union merge bug fixed in - 0214e0fb175a608a49b812d81b4632c081f63027 -} @@ -1146,19 +1133,19 @@ withtmpclonerepo $ \r3 -> do forM_ [r1, r2, r3] $ \r -> indir r $ do when (r /= r1) $ - boolSystem "git" [Param "remote", Param "add", Param "r1", File ("../../" ++ r1)] @? "remote add" + git "remote" ["add", "r1", "../../" ++ r1] "remote add" when (r /= r2) $ - boolSystem "git" [Param "remote", Param "add", Param "r2", File ("../../" ++ r2)] @? "remote add" + git "remote" ["add", "r2", "../../" ++ r2] "remote add" when (r /= r3) $ - boolSystem "git" [Param "remote", Param "add", Param "r3", File ("../../" ++ r3)] @? "remote add" - git_annex "get" [annexedfile] @? "get failed" - boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm" + git "remote" ["add", "r3", "../../" ++ r3] "remote add" + git_annex "get" [annexedfile] "get" + git "remote" ["rm", "origin"] "remote rm" forM_ [r3, r2, r1] $ \r -> indir r $ - git_annex "sync" [] @? ("sync failed in " ++ r) + git_annex "sync" [] ("sync in " ++ r) forM_ [r3, r2] $ \r -> indir r $ - git_annex "drop" ["--force", annexedfile] @? ("drop failed in " ++ r) + git_annex "drop" ["--force", annexedfile] ("drop in " ++ r) indir r1 $ do - git_annex "sync" [] @? "sync failed in r1" + git_annex "sync" [] "sync in r1" git_annex_expectoutput "find" ["--in", "r3"] [] {- This was the bug. The sync - mangled location log data and it @@ -1173,18 +1160,18 @@ let rname r = if r == r1 then "r1" else "r2" forM_ [r1, r2] $ \r -> indir r $ do {- Get all files, see check below. -} - git_annex "get" [] @? "get failed" + git_annex "get" [] "get" disconnectOrigin pair r1 r2 forM_ [r1, r2] $ \r -> indir r $ do {- Set up a conflict. -} let newcontent = content annexedfile ++ rname r - git_annex "unlock" [annexedfile] @? "unlock failed" + git_annex "unlock" [annexedfile] "unlock" writecontent annexedfile newcontent {- Sync twice in r1 so it gets the conflict resolution - update from r2 -} forM_ [r1, r2, r1] $ \r -> indir r $ - git_annex "sync" ["--force"] @? "sync failed in " ++ rname r + git_annex "sync" ["--force"] ("sync in " ++ rname r) {- After the sync, it should be possible to get all - files. This includes both sides of the conflict, - although the filenames are not easily predictable. @@ -1192,7 +1179,7 @@ - The bug caused one repo to be missing the content - of the file that had been put in it. -} forM_ [r1, r2] $ \r -> indir r $ do - git_annex "get" [] @? "unable to get all files after merge conflict resolution in " ++ rname r + git_annex "get" [] ("get all files after merge conflict resolution in " ++ rname r) {- Simple case of conflict resolution; 2 different versions of annexed - file. -} @@ -1203,16 +1190,16 @@ indir r1 $ do disconnectOrigin writecontent conflictor "conflictor1" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r1" indir r2 $ do disconnectOrigin writecontent conflictor "conflictor2" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r2" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r2" pair r1 r2 forM_ [r1,r2,r1] $ \r -> indir r $ - git_annex "sync" [] @? "sync failed" + git_annex "sync" [] "sync" checkmerge "r1" r1 checkmerge "r2" r2 where @@ -1225,7 +1212,7 @@ @? (what ++ " not exactly 2 variant files in: " ++ show l) conflictor `notElem` l @? ("conflictor still present after conflict resolution") indir d $ do - git_annex "get" v @? "get failed" + git_annex "get" v "get" git_annex_expectoutput "find" v v {- Conflict resolution while in an adjusted branch. -} @@ -1236,20 +1223,20 @@ indir r1 $ do disconnectOrigin writecontent conflictor "conflictor1" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r1" indir r2 $ do disconnectOrigin writecontent conflictor "conflictor2" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r2" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r2" -- We might be in an adjusted branch -- already, when eg on a crippled -- filesystem. So, --force it. - git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" + git_annex "adjust" ["--unlock", "--force"] "adjust" pair r1 r2 forM_ [r1,r2,r1] $ \r -> indir r $ - git_annex "sync" [] @? "sync failed" + git_annex "sync" [] "sync" checkmerge "r1" r1 checkmerge "r2" r2 where @@ -1262,7 +1249,7 @@ @? (what ++ " not exactly 2 variant files in: " ++ show l) conflictor `notElem` l @? ("conflictor still present after conflict resolution") indir d $ do - git_annex "get" v @? "get failed" + git_annex "get" v "get" git_annex_expectoutput "find" v v {- Check merge conflict resolution when one side is an annexed @@ -1277,25 +1264,26 @@ indir r1 $ do disconnectOrigin writecontent conflictor "conflictor" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r1" indir r2 $ do disconnectOrigin createDirectory conflictor writecontent subfile "subfile" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r2" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r2" pair r1 r2 let l = if inr1 then [r1, r2] else [r2, r1] forM_ l $ \r -> indir r $ - git_annex "sync" [] @? "sync failed in mixed conflict" + git_annex "sync" [] "sync in mixed conflict" checkmerge "r1" r1 checkmerge "r2" r2 conflictor = "conflictor" subfile = conflictor "subfile" variantprefix = conflictor ++ ".variant" checkmerge what d = do - doesDirectoryExist (d conflictor) @? (d ++ " conflictor directory missing") + doesDirectoryExist (d conflictor) + @? (d ++ " conflictor directory missing") l <- getDirectoryContents d let v = filter (variantprefix `isPrefixOf`) l not (null v) @@ -1303,7 +1291,7 @@ length v == 1 @? (what ++ " too many variant files in: " ++ show v) indir d $ do - git_annex "get" (conflictor:v) @? ("get failed in " ++ what) + git_annex "get" (conflictor:v) ("get in " ++ what) git_annex_expectoutput "find" [conflictor] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath subfile))] git_annex_expectoutput "find" v v @@ -1319,23 +1307,21 @@ indir r1 $ do disconnectOrigin writecontent conflictor "conflictor" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r1" indir r2 $ disconnectOrigin pair r1 r2 indir r2 $ do - git_annex "sync" [] @? "sync failed in r2" - git_annex "get" [conflictor] - @? "get conflictor failed" - git_annex "unlock" [conflictor] - @? "unlock conflictor failed" + git_annex "sync" [] "sync in r2" + git_annex "get" [conflictor] "get conflictor" + git_annex "unlock" [conflictor] "unlock conflictor" writecontent conflictor "newconflictor" indir r1 $ - removeWhenExistsWith removeLink conflictor + removeWhenExistsWith R.removeLink (toRawFilePath conflictor) let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] forM_ l $ \r -> indir r $ - git_annex "sync" [] @? "sync failed" + git_annex "sync" [] "sync" checkmerge "r1" r1 checkmerge "r2" r2 conflictor = "conflictor" @@ -1361,22 +1347,21 @@ indir r1 $ do disconnectOrigin writecontent conflictor "conflictor" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r1" indir r2 $ do disconnectOrigin writecontent conflictor nonannexed_content - boolSystem "git" - [ Param "config" - , Param "annex.largefiles" - , Param ("exclude=" ++ ingitfile ++ " and exclude=" ++ conflictor) - ] @? "git config annex.largefiles failed" - boolSystem "git" [Param "add", File conflictor] @? "git add conflictor failed" - git_annex "sync" [] @? "sync failed in r2" + git "config" + [ "annex.largefiles" + , "exclude=" ++ ingitfile ++ " and exclude=" ++ conflictor + ] "git config annex.largefiles" + git "add" [conflictor] "git add conflictor" + git_annex "sync" [] "sync in r2" pair r1 r2 let l = if inr1 then [r1, r2] else [r2, r1] forM_ l $ \r -> indir r $ - git_annex "sync" [] @? "sync failed" + git_annex "sync" [] "sync" checkmerge "r1" r1 checkmerge "r2" r2 conflictor = "conflictor" @@ -1412,17 +1397,17 @@ indir r1 $ do disconnectOrigin writecontent conflictor "conflictor" - add_annex conflictor @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + add_annex conflictor "add conflicter" + git_annex "sync" [] "sync in r1" indir r2 $ do disconnectOrigin createSymbolicLink symlinktarget "conflictor" - boolSystem "git" [Param "add", File conflictor] @? "git add conflictor failed" - git_annex "sync" [] @? "sync failed in r2" + git "add" [conflictor] "git add conflictor" + git_annex "sync" [] "sync in r2" pair r1 r2 let l = if inr1 then [r1, r2] else [r2, r1] forM_ l $ \r -> indir r $ - git_annex "sync" [] @? "sync failed" + git_annex "sync" [] "sync" checkmerge "r1" r1 checkmerge "r2" r2 conflictor = "conflictor" @@ -1460,16 +1445,15 @@ disconnectOrigin createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor))) writecontent remoteconflictor annexedcontent - add_annex conflictor @? "add remoteconflicter failed" - git_annex "sync" [] @? "sync failed in r1" + add_annex conflictor "add remoteconflicter" + git_annex "sync" [] "sync in r1" indir r2 $ do disconnectOrigin writecontent conflictor localcontent pair r1 r2 -- this case is intentionally not handled -- since the user can recover on their own easily - indir r2 $ git_annex_shouldfail "sync" [] - @? "sync failed to fail" + indir r2 $ git_annex_shouldfail "sync" [] "sync should not succeed" conflictor = "conflictor" localcontent = "local" annexedcontent = "annexed" @@ -1484,19 +1468,19 @@ withtmpclonerepo $ \r3 -> do indir r1 $ do writecontent conflictor "conflictor" - git_annex "add" [conflictor] @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + git_annex "add" [conflictor] "add conflicter" + git_annex "sync" [] "sync in r1" check_is_link conflictor "r1" indir r2 $ do createDirectory conflictor writecontent (conflictor "subfile") "subfile" - git_annex "add" [conflictor] @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r2" + git_annex "add" [conflictor] "add conflicter" + git_annex "sync" [] "sync in r2" check_is_link (conflictor "subfile") "r2" indir r3 $ do writecontent conflictor "conflictor" - git_annex "add" [conflictor] @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + git_annex "add" [conflictor] "add conflicter" + git_annex "sync" [] "sync in r1" check_is_link (conflictor "subfile") "r3" where conflictor = "conflictor" @@ -1516,17 +1500,17 @@ indir r1 $ do disconnectOrigin writecontent conflictor "conflictor" - git_annex "add" [conflictor] @? "add conflicter failed" - git_annex "sync" [] @? "sync failed in r1" + git_annex "add" [conflictor] "add conflicter" + git_annex "sync" [] "sync in r1" indir r2 $ do disconnectOrigin writecontent conflictor "conflictor" - git_annex "add" [conflictor] @? "add conflicter failed" - git_annex "unlock" [conflictor] @? "unlock conflicter failed" - git_annex "sync" [] @? "sync failed in r2" + git_annex "add" [conflictor] "add conflicter" + git_annex "unlock" [conflictor] "unlock conflicter" + git_annex "sync" [] "sync in r2" pair r1 r2 forM_ [r1,r2,r1] $ \r -> indir r $ - git_annex "sync" [] @? "sync failed" + git_annex "sync" [] "sync" checkmerge "r1" r1 checkmerge "r2" r2 where @@ -1538,7 +1522,7 @@ length v == 0 @? (what ++ " not exactly 0 variant files in: " ++ show l) conflictor `elem` l @? ("conflictor not present after conflict resolution") - git_annex "get" [conflictor] @? "get failed" + git_annex "get" [conflictor] "get" git_annex_expectoutput "find" [conflictor] [conflictor] -- regular file because it's unlocked checkregularfile conflictor @@ -1559,13 +1543,13 @@ conflictor = "conflictor" setup r = indir r $ whensupported $ do disconnectOrigin - git_annex "upgrade" [] @? "upgrade failed" - git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" + git_annex "upgrade" [] "upgrade" + git_annex "adjust" ["--unlock", "--force"] "adjust" writecontent conflictor "conflictor" - git_annex "add" [conflictor] @? "add conflicter failed" - git_annex "sync" [] @? "sync failed" + git_annex "add" [conflictor] "add conflicter" + git_annex "sync" [] "sync" checkmerge what d = indir d $ whensupported $ do - git_annex "sync" [] @? ("sync failed in " ++ what) + git_annex "sync" [] ("sync should not work in " ++ what) l <- getDirectoryContents "." conflictor `elem` l @? ("conflictor not present after merge in " ++ what) @@ -1581,66 +1565,67 @@ indir r $ do disconnectOrigin origbranch <- annexeval origBranch - git_annex "upgrade" [] @? "upgrade failed" - git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" + git_annex "upgrade" [] "upgrade" + git_annex "adjust" ["--unlock", "--force"] "adjust" createDirectoryIfMissing True "a/b/c" writecontent "a/b/c/d" "foo" - git_annex "add" ["a/b/c"] @? "add a/b/c failed" - git_annex "sync" [] @? "sync failed" + git_annex "add" ["a/b/c"] "add a/b/c" + git_annex "sync" [] "sync" createDirectoryIfMissing True "a/b/x" writecontent "a/b/x/y" "foo" - git_annex "add" ["a/b/x"] @? "add a/b/x failed" - git_annex "sync" [] @? "sync failed" - boolSystem "git" [Param "checkout", Param origbranch] @? "git checkout failed" + git_annex "add" ["a/b/x"] "add a/b/x" + git_annex "sync" [] "sync" + git "checkout" [origbranch] "git checkout" doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") {- Set up repos as remotes of each other. -} pair :: FilePath -> FilePath -> Assertion pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do when (r /= r1) $ - boolSystem "git" [Param "remote", Param "add", Param "r1", File ("../../" ++ r1)] @? "remote add" + git "remote" ["add", "r1", "../../" ++ r1] "remote add" when (r /= r2) $ - boolSystem "git" [Param "remote", Param "add", Param "r2", File ("../../" ++ r2)] @? "remote add" + git "remote" ["add", "r2", "../../" ++ r2] "remote add" test_map :: Assertion test_map = intmpclonerepo $ do -- set descriptions, that will be looked for in the map - git_annex "describe" [".", "this repo"] @? "describe 1 failed" - git_annex "describe" ["origin", "origin repo"] @? "describe 2 failed" + git_annex "describe" [".", "this repo"] "describe 1" + git_annex "describe" ["origin", "origin repo"] "describe 2" -- --fast avoids it running graphviz, not a build dependency - git_annex "map" ["--fast"] @? "map failed" + git_annex "map" ["--fast"] "map" test_uninit :: Assertion test_uninit = intmpclonerepo $ do - git_annex "get" [] @? "get failed" + git_annex "get" [] "get" annexed_present annexedfile - _ <- git_annex "uninit" [] -- exit status not checked; does abnormal exit + -- any exit status is accepted; does abnormal exit + git_annex' (const True) "uninit" [] "uninit" checkregularfile annexedfile doesDirectoryExist ".git" @? ".git vanished in uninit" test_uninit_inbranch :: Assertion test_uninit_inbranch = intmpclonerepo $ do - boolSystem "git" [Param "checkout", Param "git-annex"] @? "git checkout git-annex" - git_annex_shouldfail "uninit" [] @? "uninit failed to fail when git-annex branch was checked out" + git "checkout" ["git-annex"] "git checkout git-annex" + git_annex_shouldfail "uninit" [] "uninit should not succeed when git-annex branch is checked out" test_upgrade :: Assertion test_upgrade = intmpclonerepo $ - git_annex "upgrade" [] @? "upgrade failed" + git_annex "upgrade" [] "upgrade" test_whereis :: Assertion test_whereis = intmpclonerepo $ do annexed_notpresent annexedfile - git_annex "whereis" [annexedfile] @? "whereis on non-present file failed" - git_annex "untrust" ["origin"] @? "untrust failed" - git_annex_shouldfail "whereis" [annexedfile] @? "whereis on non-present file only present in untrusted repo failed to fail" - git_annex "get" [annexedfile] @? "get failed" + git_annex "whereis" [annexedfile] "whereis on non-present file" + git_annex "untrust" ["origin"] "untrust" + git_annex_shouldfail "whereis" [annexedfile] "whereis should exit nonzero on non-present file only present in untrusted repo" + git_annex "get" [annexedfile] "get" annexed_present annexedfile - git_annex "whereis" [annexedfile] @? "whereis on present file failed" + git_annex "whereis" [annexedfile] "whereis on present file" test_hook_remote :: Assertion test_hook_remote = intmpclonerepo $ do #ifndef mingw32_HOST_OS - git_annex "initremote" (words "foo type=hook encryption=none hooktype=foo") @? "initremote failed" + git_annex "initremote" (words "foo type=hook encryption=none hooktype=foo") "initremote" createDirectory dir git_config "annex.foo-store-hook" $ "cp $ANNEX_FILE " ++ loc @@ -1650,21 +1635,20 @@ "rm -f " ++ loc git_config "annex.foo-checkpresent-hook" $ "if [ -e " ++ loc ++ " ]; then echo $ANNEX_KEY; fi" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to hook remote failed" + git_annex "copy" [annexedfile, "--to", "foo"] "copy --to hook remote" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex "drop" [annexedfile, "--numcopies=2"] "drop" annexed_notpresent annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from hook remote failed" + git_annex "move" [annexedfile, "--from", "foo"] "move --from hook remote" annexed_present annexedfile - git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] "drop should not be allowed with numcopies=2" annexed_present annexedfile where dir = "dir" loc = dir ++ "/$ANNEX_KEY" - git_config k v = boolSystem "git" [Param "config", Param k, Param v] - @? "git config failed" + git_config k v = git "config" [k, v] "git config" #else -- this test doesn't work in Windows TODO noop @@ -1673,32 +1657,32 @@ test_directory_remote :: Assertion test_directory_remote = intmpclonerepo $ do createDirectory "dir" - git_annex "initremote" (words "foo type=directory encryption=none directory=dir") @? "initremote failed" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "initremote" (words "foo type=directory encryption=none directory=dir") "initremote" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to directory remote failed" + git_annex "copy" [annexedfile, "--to", "foo"] "copy --to directory remote" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex "drop" [annexedfile, "--numcopies=2"] "drop" annexed_notpresent annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from directory remote failed" + git_annex "move" [annexedfile, "--from", "foo"] "move --from directory remote" annexed_present annexedfile - git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] "drop should not be allowed with numcopies=2" annexed_present annexedfile test_rsync_remote :: Assertion test_rsync_remote = intmpclonerepo $ do #ifndef mingw32_HOST_OS createDirectory "dir" - git_annex "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") @? "initremote failed" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "initremote" (words "foo type=rsync encryption=none rsyncurl=dir") "initremote" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to rsync remote failed" + git_annex "copy" [annexedfile, "--to", "foo"] "copy --to rsync remote" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex "drop" [annexedfile, "--numcopies=2"] "drop" annexed_notpresent annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from rsync remote failed" + git_annex "move" [annexedfile, "--from", "foo"] "move --from rsync remote" annexed_present annexedfile - git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] "drop should not be allowed with numcopies=2" annexed_present annexedfile #else noop @@ -1709,16 +1693,16 @@ -- bup special remote needs an absolute path dir <- fromRawFilePath <$> absPath (toRawFilePath "dir") createDirectory dir - git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) @? "initremote failed" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "initremote" (words $ "foo type=bup encryption=none buprepo="++dir) "initremote" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to bup remote failed" + git_annex "copy" [annexedfile, "--to", "foo"] "copy --to bup remote" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex "drop" [annexedfile, "--numcopies=2"] "drop" annexed_notpresent annexedfile - git_annex "copy" [annexedfile, "--from", "foo"] @? "copy --from bup remote failed" + git_annex "copy" [annexedfile, "--from", "foo"] "copy --from bup remote" annexed_present annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from bup remote failed" + git_annex "move" [annexedfile, "--from", "foo"] "move --from bup remote" annexed_present annexedfile -- gpg is not a build dependency, so only test when it's available @@ -1741,7 +1725,7 @@ @? "test harness self-test failed" void $ Utility.Gpg.testHarness gpgtmp gpgcmd $ do createDirectory "dir" - let a cmd = git_annex cmd $ + let initps = [ "foo" , "type=directory" , "encryption=" ++ scheme @@ -1750,13 +1734,13 @@ ] ++ if scheme `elem` ["hybrid","pubkey"] then ["keyid=" ++ Utility.Gpg.testKeyId] else [] - a "initremote" @? "initremote failed" - not <$> a "initremote" @? "initremote failed to fail when run twice in a row" - a "enableremote" @? "enableremote failed" - a "enableremote" @? "enableremote failed when run twice in a row" - git_annex "get" [annexedfile] @? "get of file failed" + git_annex "initremote" initps "initremote" + git_annex_shouldfail "initremote" initps "initremote should not work when run twice in a row" + git_annex "enableremote" initps "enableremote" + git_annex "enableremote" initps "enableremote when run twice in a row" + git_annex "get" [annexedfile] "get of file" annexed_present annexedfile - git_annex "copy" [annexedfile, "--to", "foo"] @? "copy --to encrypted remote failed" + git_annex "copy" [annexedfile, "--to", "foo"] "copy --to encrypted remote" (c,k) <- annexeval $ do uuid <- Remote.nameToUUID "foo" rs <- Logs.Remote.readRemoteLog @@ -1768,11 +1752,11 @@ testEncryptedRemote scheme key c [k] @? "invalid crypto setup" annexed_present annexedfile - git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed" + git_annex "drop" [annexedfile, "--numcopies=2"] "drop" annexed_notpresent annexedfile - git_annex "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" + git_annex "move" [annexedfile, "--from", "foo"] "move --from encrypted remote" annexed_present annexedfile - git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" + git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] "drop should not be allowed with numcopies=2" annexed_present annexedfile {- Ensure the configuration complies with the encryption scheme, and - that all keys are encrypted properly for the given directory remote. -} @@ -1813,12 +1797,12 @@ test_add_subdirs = intmpclonerepo $ do createDirectory "dir" writecontent ("dir" "foo") $ "dir/" ++ content annexedfile - git_annex "add" ["dir"] @? "add of subdir failed" + git_annex "add" ["dir"] "add of subdir" {- Regression test for Windows bug where symlinks were not - calculated correctly for files in subdirs. -} unlessM (hasUnlockedFiles <$> getTestMode) $ do - git_annex "sync" [] @? "sync failed" + git_annex "sync" [] "sync" l <- annexeval $ Utility.FileSystemEncoding.decodeBL <$> Annex.CatFile.catObject (Git.Types.Ref (encodeBS "HEAD:dir/foo")) "../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l) @@ -1826,7 +1810,7 @@ createDirectory "dir2" writecontent ("dir2" "foo") $ content annexedfile setCurrentDirectory "dir" - git_annex "add" [".." "dir2"] @? "add of ../subdir failed" + git_annex "add" [".." "dir2"] "add of ../subdir" test_addurl :: Assertion test_addurl = intmpclonerepo $ do @@ -1835,17 +1819,17 @@ f <- fromRawFilePath <$> absPath (toRawFilePath "myurl") let url = replace "\\" "/" ("file:///" ++ dropDrive f) writecontent f "foo" - git_annex_shouldfail "addurl" [url] @? "addurl failed to fail on file url" - filecmd "addurl" [url] @? ("addurl failed on " ++ url) + git_annex_shouldfail "addurl" [url] "addurl should not work on file url" + filecmd "addurl" [url] ("addurl on " ++ url) let dest = "addurlurldest" - filecmd "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ " with --file") + filecmd "addurl" ["--file", dest, url] ("addurl on " ++ url ++ " with --file") doesFileExist dest @? (dest ++ " missing after addurl --file") test_export_import :: Assertion test_export_import = intmpclonerepo $ do createDirectory "dir" - git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") @? "initremote failed" - git_annex "get" [] @? "get of files failed" + git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") "initremote" + git_annex "get" [] "get of files" annexed_present annexedfile -- Nothing to commit, but this makes sure the master branch @@ -1853,38 +1837,38 @@ -- depending on how the repository was set up. commitchanges origbranch <- annexeval origBranch - git_annex "export" [origbranch, "--to", "foo"] @? "export to dir failed" + git_annex "export" [origbranch, "--to", "foo"] "export to dir" dircontains annexedfile (content annexedfile) writedir "import" (content "import") - git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed" - git_annex "merge" ["foo/" ++ origbranch] @? "git annex merge failed" + git_annex "import" [origbranch, "--from", "foo"] "import from dir" + git_annex "merge" ["foo/" ++ origbranch] "git annex merge" annexed_present_imported "import" - removeWhenExistsWith removeLink "import" + removeWhenExistsWith R.removeLink (toRawFilePath "import") writecontent "import" (content "newimport1") - git_annex "add" ["import"] @? "add of import failed" + git_annex "add" ["import"] "add of import" commitchanges - git_annex "export" [origbranch, "--to", "foo"] @? "export modified file to dir failed" + git_annex "export" [origbranch, "--to", "foo"] "export modified file to dir" dircontains "import" (content "newimport1") -- verify that export refuses to overwrite modified file writedir "import" (content "newimport2") - removeWhenExistsWith removeLink "import" + removeWhenExistsWith R.removeLink (toRawFilePath "import") writecontent "import" (content "newimport3") - git_annex "add" ["import"] @? "add of import failed" + git_annex "add" ["import"] "add of import" commitchanges - git_annex_shouldfail "export" [origbranch, "--to", "foo"] @? "export failed to fail in conflict" + git_annex_shouldfail "export" [origbranch, "--to", "foo"] "export should not work in conflict" dircontains "import" (content "newimport2") -- resolving import conflict - git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed" - not <$> boolSystem "git" [Param "merge", Param "foo/master", Param "-mmerge"] @? "git merge of conflict failed to exit nonzero" - removeWhenExistsWith removeLink "import" + git_annex "import" [origbranch, "--from", "foo"] "import from dir" + git_shouldfail "merge" ["foo/master", "-mmerge"] "git merge of conflict should exit nonzero" + removeWhenExistsWith R.removeLink (toRawFilePath "import") writecontent "import" (content "newimport3") - git_annex "add" ["import"] @? "add of import failed" + git_annex "add" ["import"] "add of import" commitchanges - git_annex "export" [origbranch, "--to", "foo"] @? "export failed after import conflict" + git_annex "export" [origbranch, "--to", "foo"] "export after import conflict" dircontains "import" (content "newimport3") where dircontains f v = @@ -1894,25 +1878,23 @@ -- When on an adjusted branch, this updates the master branch -- to match it, which is necessary since the master branch is going -- to be exported. - commitchanges = git_annex "sync" ["--no-pull", "--no-push"] @? "sync failed" + commitchanges = git_annex "sync" ["--no-pull", "--no-push"] "sync" test_export_import_subdir :: Assertion test_export_import_subdir = intmpclonerepo $ do createDirectory "dir" - git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") @? "initremote failed" - git_annex "get" [] @? "get of files failed" + git_annex "initremote" (words "foo type=directory encryption=none directory=dir exporttree=yes importtree=yes") "initremote" + git_annex "get" [] "get of files" annexed_present annexedfile createDirectory subdir - boolSystem "git" [Param "mv", File annexedfile, File subannexedfile] - @? "git mv failed" - boolSystem "git" [Param "commit", Param "-m", Param "moved"] - @? "git commit failed" + git "mv" [annexedfile, subannexedfile] "git mv" + git "commit" ["-m", "moved"] "git commit" -- When on an adjusted branch, this updates the master branch -- to match it, which is necessary since the master branch is going -- to be exported. - git_annex "sync" ["--no-pull", "--no-push"] @? "sync failed" + git_annex "sync" ["--no-pull", "--no-push"] "sync" -- Run three times because there was a bug that took a couple -- of runs to lead to the wrong tree being written to the remote @@ -1933,13 +1915,13 @@ testexport = do origbranch <- annexeval origBranch - git_annex "export" [origbranch++":"++subdir, "--to", "foo"] @? "export of subdir failed" + git_annex "export" [origbranch++":"++subdir, "--to", "foo"] "export of subdir" dircontains annexedfile (content annexedfile) testimport = do origbranch <- annexeval origBranch - git_annex "import" [origbranch++":"++subdir, "--from", "foo"] @? "import of subdir failed" - git_annex "merge" ["foo/master"] @? "git annex merge foo/master failed" + git_annex "import" [origbranch++":"++subdir, "--from", "foo"] "import of subdir" + git_annex "merge" ["foo/master"] "git annex merge foo/master" -- Make sure that import did not import the file to the top -- of the repo. diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -40,34 +40,51 @@ import qualified Annex.Action import qualified Annex.AdjustedBranch import qualified Utility.Process +import qualified Utility.Process.Transcript import qualified Utility.Env import qualified Utility.Env.Set import qualified Utility.Exception import qualified Utility.ThreadScheduler import qualified Utility.Tmp.Dir import qualified Utility.Metered -import qualified Utility.SafeCommand import qualified Command.Uninit +-- Run a process. The output and stderr is captured, and is only +-- displayed if the process does not return the expected value. +testProcess :: String -> [String] -> (Bool -> Bool) -> String -> Assertion +testProcess command params expectedret faildesc = do + (transcript, ret) <- Utility.Process.Transcript.processTranscript command params Nothing + (expectedret ret) @? (faildesc ++ " failed (transcript follows)\n" ++ transcript) + +-- Run git. (Do not use to run git-annex as the one being tested +-- may not be in path.) +git :: String -> [String] -> String -> Assertion +git command params = testProcess "git" (command:params) (== True) + +-- For when git is expected to fail. +git_shouldfail :: String -> [String] -> String -> Assertion +git_shouldfail command params = testProcess "git" (command:params) (== False) + -- Run git-annex. -git_annex :: String -> [String] -> IO Bool -git_annex command params = do - pp <- Annex.Path.programPath - Utility.SafeCommand.boolSystem pp $ - map Utility.SafeCommand.Param (command:params) +git_annex :: String -> [String] -> String -> Assertion +git_annex = git_annex' (== True) -- For when git-annex is expected to fail. --- Run with -q to squelch error. -git_annex_shouldfail :: String -> [String] -> IO Bool -git_annex_shouldfail command params = not <$> git_annex command ("-q":params) +git_annex_shouldfail :: String -> [String] -> String -> Assertion +git_annex_shouldfail = git_annex' (== False) -{- Runs git-annex and returns its output. -} +git_annex' :: (Bool -> Bool) -> String -> [String] -> String -> Assertion +git_annex' expectedret command params faildesc = do + pp <- Annex.Path.programPath + testProcess pp (command:params) expectedret faildesc + +{- Runs git-annex and returns its standard output. -} git_annex_output :: String -> [String] -> IO String git_annex_output command params = do pp <- Annex.Path.programPath Utility.Process.readProcess pp (command:params) -git_annex_expectoutput :: String -> [String] -> [String] -> IO () +git_annex_expectoutput :: String -> [String] -> [String] -> Assertion git_annex_expectoutput command params expected = do got <- lines <$> git_annex_output command params got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected) @@ -96,7 +113,7 @@ origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v) let originurl = "localhost:" ++ fromRawFilePath origindir - boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" + git "config" [config, originurl] "git config failed" a where config = "remote.origin.url" @@ -135,7 +152,7 @@ throwM e disconnectOrigin :: Assertion -disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm" +disconnectOrigin = git "remote" ["rm", "origin"] "remote rm" withgitrepo :: (FilePath -> Assertion) -> Assertion withgitrepo a = do @@ -163,7 +180,7 @@ setuprepo dir = do cleanup dir ensuretmpdir - boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed" + git "init" ["-q", dir] "git init" configrepo dir return dir @@ -184,18 +201,22 @@ cleanup new ensuretmpdir let cloneparams = catMaybes - [ Just $ Param "clone" - , Just $ Param "-q" - , if bareClone cfg then Just (Param "--bare") else Nothing - , if sharedClone cfg then Just (Param "--shared") else Nothing - , Just $ File old - , Just $ File new + [ Just "-q" + , if bareClone cfg then Just "--bare" else Nothing + , if sharedClone cfg then Just "--shared" else Nothing + , Just old + , Just new ] - boolSystem "git" cloneparams @? "git clone failed" + git "clone" cloneparams "git clone" configrepo new indir new $ do ver <- annexVersion <$> getTestMode - git_annex "init" ["-q", new, "--version", show (Types.RepoVersion.fromRepoVersion ver)] @? "git annex init failed" + git_annex "init" + [ "-q" + , new, "--version" + , show (Types.RepoVersion.fromRepoVersion ver) + ] + "git annex init" unless (bareClone cfg) $ indir new $ setupTestMode @@ -204,16 +225,16 @@ configrepo :: FilePath -> IO () configrepo dir = indir dir $ do -- ensure git is set up to let commits happen - boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed" - boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed" + git "config" ["user.name", "Test User"] + "git config" + git "config" ["user.email", "test@example.com"] + "git config" -- avoid signed commits by test suite - boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed" + git "config" ["commit.gpgsign", "false"] + "git config" -- tell git-annex to not annex the ingitfile - boolSystem "git" - [ Param "config" - , Param "annex.largefiles" - , Param ("exclude=" ++ ingitfile) - ] @? "git config annex.largefiles failed" + git "config" ["annex.largefiles", "exclude=" ++ ingitfile] + "git config annex.largefiles" ensuretmpdir :: IO () ensuretmpdir = do @@ -394,10 +415,10 @@ unannexed :: FilePath -> Assertion unannexed = runchecks [checkregularfile, checkcontent, checkwritable] -add_annex :: FilePath -> IO Bool -add_annex f = ifM (unlockedFiles <$> getTestMode) - ( boolSystem "git" [Param "add", File f] - , git_annex "add" [f] +add_annex :: FilePath -> String -> Assertion +add_annex f faildesc = ifM (unlockedFiles <$> getTestMode) + ( git "add" [f] faildesc + , git_annex "add" [f] faildesc ) data TestMode = TestMode @@ -471,8 +492,8 @@ setupTestMode = do testmode <- getTestMode when (adjustedUnlockedBranch testmode) $ do - boolSystem "git" [Param "commit", Param "--allow-empty", Param "-m", Param "empty"] @? "git commit failed" - git_annex "adjust" ["--unlock"] @? "git annex adjust failed" + git "commit" ["--allow-empty", "-m", "empty"] "git commit failed" + git_annex "adjust" ["--unlock"] "git annex adjust failed" changeToTmpDir :: FilePath -> IO () changeToTmpDir t = do diff --git a/Types/AdjustedBranch.hs b/Types/AdjustedBranch.hs --- a/Types/AdjustedBranch.hs +++ b/Types/AdjustedBranch.hs @@ -1,6 +1,6 @@ {- adjusted branch types - - - Copyright 2016-2018 Joey Hess + - Copyright 2016-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,9 +10,9 @@ data Adjustment = LinkAdjustment LinkAdjustment | PresenceAdjustment PresenceAdjustment (Maybe LinkAdjustment) + | LinkPresentAdjustment LinkPresentAdjustment deriving (Show, Eq) --- Doesn't make sense to combine unlock with fix. data LinkAdjustment = UnlockAdjustment | LockAdjustment @@ -25,6 +25,11 @@ | ShowMissingAdjustment deriving (Show, Eq) +data LinkPresentAdjustment + = UnlockPresentAdjustment + | LockPresentAdjustment + deriving (Show, Eq) + -- Adjustments have to be able to be reversed, so that commits made to the -- adjusted branch can be reversed to the commit that would have been made -- without the adjustment and applied to the original branch. @@ -36,6 +41,8 @@ LinkAdjustment (reverseAdjustment l) reverseAdjustment (PresenceAdjustment p ml) = PresenceAdjustment (reverseAdjustment p) (fmap reverseAdjustment ml) + reverseAdjustment (LinkPresentAdjustment l) = + LinkPresentAdjustment (reverseAdjustment l) instance ReversableAdjustment LinkAdjustment where reverseAdjustment UnlockAdjustment = LockAdjustment @@ -48,7 +55,10 @@ reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment +instance ReversableAdjustment LinkPresentAdjustment where + reverseAdjustment UnlockPresentAdjustment = LockPresentAdjustment + reverseAdjustment LockPresentAdjustment = UnlockPresentAdjustment + adjustmentHidesFiles :: Adjustment -> Bool adjustmentHidesFiles (PresenceAdjustment HideMissingAdjustment _) = True adjustmentHidesFiles _ = False - diff --git a/Types/CleanupActions.hs b/Types/CleanupActions.hs --- a/Types/CleanupActions.hs +++ b/Types/CleanupActions.hs @@ -16,6 +16,7 @@ | StopHook UUID | FsckCleanup | SshCachingCleanup + | AdjustedBranchUpdate | TorrentCleanup URLString | OtherTmpCleanup deriving (Eq, Ord) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -125,6 +125,7 @@ , annexAutoUpgradeRepository :: Bool , annexCommitMode :: CommitMode , annexSkipUnknown :: Bool + , annexAdjustedBranchRefresh :: Integer , coreSymlinks :: Bool , coreSharedRepository :: SharedRepository , receiveDenyCurrentBranch :: DenyCurrentBranch @@ -219,6 +220,10 @@ then ManualCommit else AutomaticCommit , annexSkipUnknown = getbool (annexConfig "skipunknown") True + , annexAdjustedBranchRefresh = fromMaybe + -- parse as bool if it's not a number + (if getbool "adjustedbranchrefresh" False then 1 else 0) + (getmayberead (annexConfig "adjustedbranchrefresh")) , coreSymlinks = getbool "core.symlinks" True , coreSharedRepository = getSharedRepository r , receiveDenyCurrentBranch = getDenyCurrentBranch r diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -19,7 +19,8 @@ olddir <- fromRawFilePath <$> fromRepo gitAnnexDir keys <- getKeysPresent0 olddir forM_ keys $ \k -> - moveAnnex k $ toRawFilePath $ olddir keyFile0 k + moveAnnex k (AssociatedFile Nothing) + (toRawFilePath $ olddir keyFile0 k) -- update the symlinks to the key files -- No longer needed here; V1.upgrade does the same thing diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -80,7 +80,7 @@ let d = parentDir f' liftIO $ allowWrite d liftIO $ allowWrite f' - _ <- moveAnnex k f' + _ <- moveAnnex k (AssociatedFile Nothing) f' liftIO $ removeDirectory (fromRawFilePath d) updateSymlinks :: Annex () diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -32,6 +32,7 @@ import Utility.InodeCache import Utility.DottedVersion import Annex.AdjustedBranch +import qualified Utility.RawFilePath as R import qualified Data.ByteString as S @@ -88,8 +89,13 @@ - as does annex.thin. -} setConfig (annexConfig "thin") (boolConfig True) Direct.setIndirect - cur <- fromMaybe (error "Somehow no branch is checked out") - <$> inRepo Git.Branch.current + cur <- inRepo Git.Branch.current >>= \case + Just cur -> return cur + Nothing -> do + -- Avoid running pre-commit hook. + commitForAdjustedBranch [Param "--no-verify"] + fromMaybe (giveup "Nothing is committed, and a commit failed; unable to proceed.") + <$> inRepo Git.Branch.current upgradeDirectWorkTree removeDirectCruft {- Create adjusted branch where all files are unlocked. @@ -151,7 +157,7 @@ ) writepointer f k = liftIO $ do - removeWhenExistsWith removeLink f + removeWhenExistsWith R.removeLink (toRawFilePath f) S.writeFile f (formatPointer k) {- Remove all direct mode bookkeeping files. -} diff --git a/Utility/Batch.hs b/Utility/Batch.hs --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -41,12 +41,10 @@ batchthread = asyncBound $ do setProcessPriority 0 maxNice a + maxNice = 19 #else batch a = a #endif - -maxNice :: Int -maxNice = 19 {- Makes a command be run by whichever of nice, ionice, and nocache - are available in the path. -} diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -112,7 +112,7 @@ pid <- getPID writeFile pidfile (show pid) lckfile <- winLockFile pid pidfile - writeFile lckfile "" + writeFile (fromRawFilePath lckfile) "" void $ lockExclusive lckfile #endif @@ -176,14 +176,14 @@ - when eg, restarting the daemon. -} #ifdef mingw32_HOST_OS -winLockFile :: PID -> FilePath -> IO FilePath +winLockFile :: PID -> FilePath -> IO RawFilePath winLockFile pid pidfile = do cleanstale - return $ prefix ++ show pid ++ suffix + return $ toRawFilePath $ prefix ++ show pid ++ suffix where prefix = pidfile ++ "." suffix = ".lck" cleanstale = mapM_ (void . tryIO . removeFile) =<< - (filter iswinlockfile <$> dirContents (parentDir pidfile)) + (filter iswinlockfile <$> dirContents (fromRawFilePath (parentDir (toRawFilePath pidfile)))) iswinlockfile f = suffix `isSuffixOf` f && prefix `isPrefixOf` f #endif diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,7 +16,7 @@ import Control.Monad import System.FilePath -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -16,7 +16,7 @@ import System.IO import Control.Monad import System.PosixCompat.Types -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) import Control.Monad.IO.Class import Foreign (complement) import Control.Monad.Catch diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -14,7 +14,7 @@ getFileSize', ) where -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS import Control.Exception (bracket) diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -36,17 +36,18 @@ import System.IO import System.IO.Unsafe import Data.Word -import Data.List +import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.UTF8 as S8 import qualified Data.ByteString.Lazy.UTF8 as L8 +#else +import Data.List +import Utility.Split #endif -import System.FilePath.ByteString (RawFilePath, encodeFilePath, decodeFilePath) import Utility.Exception -import Utility.Split {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current @@ -178,6 +179,7 @@ toRawFilePath :: FilePath -> RawFilePath toRawFilePath = encodeFilePath +#ifndef mingw32_HOST_OS {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - w82s produces a String, which may contain Chars that are invalid @@ -206,6 +208,7 @@ decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where nul = '\NUL' +#endif c2w8 :: Char -> Word8 c2w8 = fromIntegral . fromEnum diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -332,6 +332,7 @@ testKeyId :: String testKeyId = "129D6E0AC537B9C7" +#ifndef mingw32_HOST_OS testKey :: String testKey = keyBlock True [ "mI0ETvFAZgEEAKnqwWgZqznMhi1RQExem2H8t3OyKDxaNN3rBN8T6LWGGqAYV4wT" @@ -400,7 +401,6 @@ | public = "PUBLIC" | otherwise = "PRIVATE" -#ifndef mingw32_HOST_OS {- Runs an action using gpg in a test harness, in which gpg does - not use ~/.gpg/, but sets up the test key in a subdirectory of - the passed directory and uses it. diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -16,7 +16,6 @@ import System.Win32.Types import System.Win32.File import Control.Concurrent -import System.FilePath.ByteString (RawFilePath) import Utility.FileSystemEncoding diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs --- a/Utility/MagicWormhole.hs +++ b/Utility/MagicWormhole.hs @@ -113,23 +113,28 @@ -- Work around stupid stdout buffering behavior of python. -- See https://github.com/warner/magic-wormhole/issues/108 environ <- addEntry "PYTHONUNBUFFERED" "1" <$> getEnvironment - runWormHoleProcess p { env = Just environ} $ \_hin hout herr -> do - (inout, inerr) <- findcode hout `concurrently` findcode herr + runWormHoleProcess p { env = Just environ} $ \_hin hout herr ph -> do + (inout, inerr) <- concurrently + (findcode ph hout) + (findcode ph herr) return (inout || inerr) where p = wormHoleProcess (Param "send" : ps ++ [File f]) - findcode h = findcode' =<< words <$> hGetContents h + findcode ph h = findcode' =<< getwords ph h [] findcode' [] = return False findcode' (w:ws) = case mkCode w of Just code -> do _ <- tryPutMVar observer code return True Nothing -> findcode' ws + getwords ph h c = hGetLineUntilExitOrEOF ph h >>= \case + Nothing -> return $ concatMap words $ reverse c + Just l -> getwords ph h (l:c) -- | Receives a file. Once the receive is under way, the Code will be -- read from the CodeProducer, and fed to wormhole on stdin. receiveFile :: FilePath -> CodeProducer -> WormHoleParams -> IO Bool -receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _herr -> do +receiveFile f (CodeProducer producer) ps = runWormHoleProcess p $ \hin _hout _herr _ph -> do Code c <- readMVar producer hPutStrLn hin c hFlush hin @@ -145,7 +150,7 @@ wormHoleProcess :: WormHoleParams -> CreateProcess wormHoleProcess = proc "wormhole" . toCommand -runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> IO Bool) -> IO Bool +runWormHoleProcess :: CreateProcess -> (Handle -> Handle -> Handle -> ProcessHandle -> IO Bool) -> IO Bool runWormHoleProcess p consumer = withCreateProcess p' go `catchNonAsync` const (return False) where @@ -155,7 +160,7 @@ , std_err = CreatePipe } go (Just hin) (Just hout) (Just herr) pid = - consumer hin hout herr <&&> waitbool pid + consumer hin hout herr pid <&&> waitbool pid go _ _ _ _ = error "internal" waitbool pid = do r <- waitForProcess pid diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -49,7 +49,6 @@ import Utility.Percentage import Utility.DataUnits import Utility.HumanTime -import Utility.ThreadScheduler import Utility.SimpleProtocol as Proto import qualified Data.ByteString.Lazy as L @@ -266,7 +265,7 @@ commandMeterExitCode' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO (Maybe ExitCode) commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess = outputFilter cmd params mkprocess Nothing - (feedprogress mmeter zeroBytesProcessed []) + (const $ feedprogress mmeter zeroBytesProcessed []) handlestderr where feedprogress sendtotalsize prev buf h = do @@ -291,9 +290,11 @@ meterupdate bytes feedprogress sendtotalsize' bytes buf' h - handlestderr h = unlessM (hIsEOF h) $ do - stderrHandler oh =<< hGetLine h - handlestderr h + handlestderr ph h = hGetLineUntilExitOrEOF ph h >>= \case + Just l -> do + stderrHandler oh l + handlestderr ph h + Nothing -> return () {- Runs a command, that may display one or more progress meters on - either stdout or stderr, and prevents the meters from being displayed. @@ -306,8 +307,8 @@ demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool demeterCommandEnv oh cmd params environ = do ret <- outputFilter cmd params id environ - (\outh -> avoidProgress True outh stdouthandler) - (\errh -> avoidProgress True errh $ stderrHandler oh) + (\ph outh -> avoidProgress True ph outh stdouthandler) + (\ph errh -> avoidProgress True ph errh $ stderrHandler oh) return $ case ret of Just ExitSuccess -> True _ -> False @@ -320,44 +321,31 @@ - filter out lines that contain \r (typically used to reset to the - beginning of the line when updating a progress display). -} -avoidProgress :: Bool -> Handle -> (String -> IO ()) -> IO () -avoidProgress doavoid h emitter = unlessM (hIsEOF h) $ do - s <- hGetLine h - unless (doavoid && '\r' `elem` s) $ - emitter s - avoidProgress doavoid h emitter +avoidProgress :: Bool -> ProcessHandle -> Handle -> (String -> IO ()) -> IO () +avoidProgress doavoid ph h emitter = hGetLineUntilExitOrEOF ph h >>= \case + Just s -> do + unless (doavoid && '\r' `elem` s) $ + emitter s + avoidProgress doavoid ph h emitter + Nothing -> return () outputFilter :: FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> Maybe [(String, String)] - -> (Handle -> IO ()) - -> (Handle -> IO ()) + -> (ProcessHandle -> Handle -> IO ()) + -> (ProcessHandle -> Handle -> IO ()) -> IO (Maybe ExitCode) outputFilter cmd params mkprocess environ outfilter errfilter = catchMaybeIO $ withCreateProcess p go where - go _ (Just outh) (Just errh) pid = do - outt <- async $ tryIO (outfilter outh) >> hClose outh - errt <- async $ tryIO (errfilter errh) >> hClose errh - ret <- waitForProcess pid - - -- Normally, now that the process has exited, the threads - -- will finish processing its output and terminate. - -- But, just in case the process did something evil like - -- forking to the background while inheriting stderr, - -- it's possible that the threads will not finish, which - -- would result in a deadlock. So, wait a few seconds - -- maximum for them to finish and then cancel them. - -- (One program that has behaved this way in the past is - -- openssh.) - void $ tryNonAsync $ race_ - (wait outt >> wait errt) - (threadDelaySeconds (Seconds 2)) - cancel outt - cancel errt - + go _ (Just outh) (Just errh) ph = do + outt <- async $ tryIO (outfilter ph outh) >> hClose outh + errt <- async $ tryIO (errfilter ph errh) >> hClose errh + ret <- waitForProcess ph + wait outt + wait errt return ret go _ _ _ _ = error "internal" diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -15,12 +15,12 @@ import Control.Monad import System.FilePath -import System.PosixCompat.Files -import Control.Monad.IfElse +import System.PosixCompat.Files hiding (removeLink) import System.IO.Error import Prelude #ifndef mingw32_HOST_OS +import Control.Monad.IfElse import Utility.SafeCommand #endif diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -6,7 +6,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE CPP, Rank2Types #-} +{-# LANGUAGE CPP, Rank2Types, LambdaCase #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( @@ -24,6 +24,7 @@ withCreateProcess, waitForProcess, cleanupProcess, + hGetLineUntilExitOrEOF, startInteractiveProcess, stdinHandle, stdoutHandle, @@ -229,3 +230,92 @@ maybe (return ()) hClose mb_stderr void $ waitForProcess pid #endif + +{- | Like hGetLine, reads a line from the Handle. Returns Nothing if end of + - file is reached, or the handle is closed, or if the process has exited + - and there is nothing more buffered to read from the handle. + - + - This is useful to protect against situations where the process might + - have transferred the handle being read to another process, and so + - the handle could remain open after the process has exited. That is a rare + - situation, but can happen. Consider a the process that started up a + - daemon, and the daemon inherited stderr from it, rather than the more + - usual behavior of closing the file descriptor. Reading from stderr + - would block past the exit of the process. + - + - In that situation, this will detect when the process has exited, + - and avoid blocking forever. But will still return anything the process + - buffered to the handle before exiting. + - + - Note on newline mode: This ignores whatever newline mode is configured + - for the handle, because there is no way to query that. On Windows, + - it will remove any \r coming before the \n. On other platforms, + - it does not treat \r specially. + -} +hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String) +hGetLineUntilExitOrEOF ph h = go [] + where + go buf = do + ready <- waitforinputorerror smalldelay + if ready + then getloop buf go + else getProcessExitCode ph >>= \case + -- Process still running, wait longer. + Nothing -> go buf + -- Process is done. It's possible + -- that it output something and exited + -- since the prior hWaitForInput, + -- so check one more time for any buffered + -- output. + Just _ -> finalcheck buf + + finalcheck buf = do + ready <- waitforinputorerror 0 + if ready + then getloop buf finalcheck + -- No remaining buffered input, though the handle + -- may not be EOF if something else is keeping it + -- open. Treated the same as EOF. + else eofwithnolineend buf + + -- On exception, proceed as if there was input; + -- EOF and any encoding issues are dealt with + -- when reading from the handle. + waitforinputorerror t = hWaitForInput h t + `catchNonAsync` const (pure True) + + getchar = + catcherr EOF $ + -- If the handle is closed, reading from it is + -- an IllegalOperation. + catcherr IllegalOperation $ + Just <$> hGetChar h + where + catcherr t = catchIOErrorType t (const (pure Nothing)) + + getloop buf cont = + getchar >>= \case + Just c + | c == '\n' -> return (Just (gotline buf)) + | otherwise -> cont (c:buf) + Nothing -> eofwithnolineend buf + +#ifndef mingw32_HOST_OS + gotline buf = reverse buf +#else + gotline ('\r':buf) = reverse buf + gotline buf = reverse buf +#endif + + eofwithnolineend buf = return $ + if null buf + then Nothing -- no line read + else Just (reverse buf) + + -- Tenth of a second delay. If the process exits with the FD being + -- held open, will wait up to twice this long before returning. + -- This delay could be made smaller. However, that is an unusual + -- case, and making it too small would cause lots of wakeups while + -- waiting for output. Bearing in mind that this could be run on + -- many processes at the same time. + smalldelay = 100 -- milliseconds diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs --- a/Utility/Process/Transcript.hs +++ b/Utility/Process/Transcript.hs @@ -15,14 +15,13 @@ ) where import Utility.Process -import Utility.Misc import System.IO import System.Exit import Control.Concurrent.Async import Control.Monad -import Control.Exception #ifndef mingw32_HOST_OS +import Control.Exception import qualified System.Posix.IO #else import Control.Applicative @@ -63,10 +62,10 @@ , std_err = UseHandle writeh } withCreateProcess cp' $ \hin hout herr pid -> do - get <- asyncreader readh + get <- asyncreader pid readh writeinput input (hin, hout, herr, pid) - transcript <- wait get code <- waitForProcess pid + transcript <- wait get return (transcript, code) #else {- This implementation for Windows puts stderr after stdout. -} @@ -77,16 +76,18 @@ } withCreateProcess cp' $ \hin hout herr pid -> do let p = (hin, hout, herr, pid) - getout <- asyncreader (stdoutHandle p) - geterr <- asyncreader (stderrHandle p) + getout <- asyncreader pid (stdoutHandle p) + geterr <- asyncreader pid (stderrHandle p) writeinput input p - transcript <- (++) <$> wait getout <*> wait geterr code <- waitForProcess pid + transcript <- (++) <$> wait getout <*> wait geterr return (transcript, code) #endif where - asyncreader = async . hGetContentsStrict - + asyncreader pid h = async $ reader pid h [] + reader pid h c = hGetLineUntilExitOrEOF pid h >>= \case + Nothing -> return (concat (reverse c)) + Just l -> reader pid h (l:c) writeinput (Just s) p = do let inh = stdinHandle p unless (null s) $ do diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -46,7 +46,6 @@ createDirectory p = D.createDirectory p 0o777 #else -import qualified Data.ByteString as B import System.PosixCompat (FileStatus, FileMode) import qualified System.PosixCompat as P import qualified System.PosixCompat.Files as F @@ -66,8 +65,10 @@ (fromRawFilePath a) (fromRawFilePath b) +{- On windows, removeLink is not available, so only remove files, + - not symbolic links. -} removeLink :: RawFilePath -> IO () -removeLink = P.removeLink . fromRawFilePath +removeLink = D.removeFile . fromRawFilePath getFileStatus :: RawFilePath -> IO FileStatus getFileStatus = P.getFileStatus . fromRawFilePath diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -20,7 +20,7 @@ import System.FilePath import System.Directory import Control.Monad.IO.Class -import System.PosixCompat.Files +import System.PosixCompat.Files hiding (removeLink) import Utility.Exception import Utility.FileSystemEncoding diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -452,7 +452,12 @@ {- Download a perhaps large file using conduit, with auto-resume - of incomplete downloads. - - - Does not catch exceptions. + - A Request can be configured to throw exceptions for non-2xx http + - status codes, or not. That configuration is overridden by this, + - and if it is unable to download, it throws an exception containing + - a user-visible explanation of the problem. (However, exceptions + - thrown for reasons other than http status codes will still be thrown + - as usual.) -} downloadConduit :: MeterUpdate -> Request -> FilePath -> UrlOptions -> IO () downloadConduit meterupdate req file uo = @@ -480,28 +485,29 @@ filter ((/= hAcceptEncoding) . fst) (requestHeaders req) , decompress = const False + -- Avoid throwing exceptions non-2xx http status codes, + -- since we rely on parsing the Response to handle + -- several such codes. + , checkResponse = \_ _ -> return () } -- Resume download from where a previous download was interrupted, -- when supported by the http server. The server may also opt to -- send the whole file rather than resuming. - resumedownload sz = catchJust - (matchStatusCodeHeadersException (alreadydownloaded sz)) - dl - (const noop) - where - dl = join $ runResourceT $ do - let req'' = req' { requestHeaders = resumeFromHeader sz : requestHeaders req } - liftIO $ debugM "url" (show req'') - resp <- http req'' (httpManager uo) - if responseStatus resp == partialContent206 + resumedownload sz = join $ runResourceT $ do + let req'' = req' { requestHeaders = resumeFromHeader sz : requestHeaders req' } + liftIO $ debugM "url" (show req'') + resp <- http req'' (httpManager uo) + if responseStatus resp == partialContent206 + then do + store (toBytesProcessed sz) AppendMode resp + return (return ()) + else if responseStatus resp == ok200 then do - store (toBytesProcessed sz) AppendMode resp + store zeroBytesProcessed WriteMode resp return (return ()) - else if responseStatus resp == ok200 - then do - store zeroBytesProcessed WriteMode resp - return (return ()) + else if alreadydownloaded sz resp + then return (return ()) else do rf <- extractFromResourceT (respfailure resp) if responseStatus resp == unauthorized401 @@ -510,8 +516,9 @@ Just ba -> retryauthed ba else return $ giveup rf - alreadydownloaded sz s h = s == requestedRangeNotSatisfiable416 - && case lookup hContentRange h of + alreadydownloaded sz resp + | responseStatus resp /= requestedRangeNotSatisfiable416 = False + | otherwise = case lookup hContentRange (responseHeaders resp) of -- This could be improved by fixing -- https://github.com/aristidb/http-types/issues/87 Just crh -> crh == B8.fromString ("bytes */" ++ show sz) diff --git a/Utility/WebApp.hs b/Utility/WebApp.hs --- a/Utility/WebApp.hs +++ b/Utility/WebApp.hs @@ -36,9 +36,6 @@ import Control.Arrow ((***)) import Control.Concurrent -localhost :: HostName -localhost = "localhost" - {- Builds a command to use to start or open a web browser showing an url. -} browserProc :: String -> CreateProcess #ifdef darwin_HOST_OS @@ -105,6 +102,7 @@ _ -> error "unable to bind to a local socket" where hostname = fromMaybe localhost h + localhost = "localhost" hints = defaultHints { addrSocketType = Stream } {- Repeated attempts because bind sometimes fails for an - unknown reason on OSX. -} diff --git a/doc/git-annex-adjust.mdwn b/doc/git-annex-adjust.mdwn --- a/doc/git-annex-adjust.mdwn +++ b/doc/git-annex-adjust.mdwn @@ -4,7 +4,7 @@ # SYNOPSIS -git annex adjust `--unlock|--lock|--fix|--hide-missing [--unlock|--lock|--fix]` +git annex adjust `--unlock|--lock|--fix|--hide-missing [--unlock|--lock|--fix]|--unlock-present` # DESCRIPTION @@ -31,8 +31,8 @@ Re-running this command with the same options while inside the adjusted branch will update the adjusted branch -as necessary (eg for `--hide-missing`), and will also propagate commits -back to the original branch. +as necessary (eg for `--hide-missing` and `--unlock-present`), +and will also propagate commits back to the original branch. # OPTIONS @@ -82,13 +82,32 @@ branch. To update the adjusted branch to reflect changes to content availability, - run `git annex adjust --hide-missing` again. + run `git annex adjust --hide-missing` again. Or, to automate updates, + set the `annex.adjustedbranchrefresh` config. Despite missing files being hidden, `git annex sync --content` will still operate on them, and can be used to download missing - files from remotes. + files from remotes. It also updates the adjusted branch after + transferring content. This option can be combined with --unlock, --lock, or --fix. + +* `--unlock-present` + + Unlock files whose content is present, and lock files whose content is + missing. This provides the benefits of working with unlocked files, + but makes it easier to see when the content of a file is not missing, + since it will be a broken symlink. + + The adjusted branch is not immediately changed when content availability + changes, so when you `git annex get` files, they will remain locked. + And when you `git annex drop` files, they will remain locked and so will + not be broken symlinks. + + To update the adjusted branch to reflect changes to content availability, + run `git annex adjust --unlock-present` again. Or, to automate updates, + set the `annex.adjustedbranchrefresh` config. Or use `git-annex sync + --content`, which updates the branch after transferring content. # SEE ALSO diff --git a/doc/git-annex-examinekey.mdwn b/doc/git-annex-examinekey.mdwn --- a/doc/git-annex-examinekey.mdwn +++ b/doc/git-annex-examinekey.mdwn @@ -28,7 +28,8 @@ These variables are also available for use in formats: ${key}, ${backend}, ${bytesize}, ${humansize}, ${keyname}, ${hashdirlower}, ${hashdirmixed}, - ${mtime} (for the mtime field of a WORM key). + ${mtime} (for the mtime field of a WORM key), ${file} (when a filename is + provided to examinekey). Also, '\\n' is a newline, '\\000' is a NULL, etc. diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1016,6 +1016,23 @@ When the `--batch` option is used, this configuration is ignored. +* `annex.adjustedbranchrefresh` + + When [[git-annex-adjust]](1) is used to set up an adjusted branch + that needs to be refreshed after getting or dropping files, this config + controls how frequently the branch is refreshed. + + Refreshing the branch takes some time, so doing it after every file + can be too slow. (It also can generate a lot of dangling git objects.) + The default value is 0 (or false), which does not + refresh the branch. Setting 1 (or true) will refresh only once, + after git-annex has made other changes. Setting 2 refreshes after every + file, 3 after every other file, and so on; setting 100 refreshes after + every 99 files. + + (If git-annex gets faster in the future, refresh rates will increase + proportional to the speed improvements.) + * `annex.queuesize` git-annex builds a queue of git commands, in order to combine similar diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 8.20201116 +Version: 8.20201127 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -609,6 +609,7 @@ Annex Annex.Action Annex.AdjustedBranch + Annex.AdjustedBranch.Merge Annex.AdjustedBranch.Name Annex.AutoMerge Annex.BloomFilter @@ -623,6 +624,7 @@ Annex.Concurrent Annex.Concurrent.Utility Annex.Content + Annex.Content.Presence Annex.Content.LowLevel Annex.Content.PointerFile Annex.CurrentBranch