git-annex 6.20181011 → 7.20181031

raw patch · 114 files changed

+1504/−1230 lines, 114 filesdep +microlensdep −data-endiandep ~basedep ~containersdep ~path-pieces

Dependencies added: microlens

Dependencies removed: data-endian

Dependency ranges changed: base, containers, path-pieces, persistent-sqlite, shakespeare, unix, warp, warp-tls, yesod, yesod-core, yesod-form, yesod-static

Files

• Annex.hs +2/−1
• Annex/AdjustedBranch.hs +102/−92
• Annex/AdjustedBranch/Name.hs +83/−0
• Annex/CatFile.hs +19/−2
• Annex/Content.hs +45/−22
• Annex/Content/LowLevel.hs +0/−1
• Annex/CurrentBranch.hs +41/−0
• Annex/Environment.hs +0/−8
• Annex/GitOverlay.hs +4/−3
• Annex/Hook.hs +12/−1
• Annex/Ingest.hs +6/−15
• Annex/Init.hs +8/−20
• Annex/Locations.hs +10/−0
• Annex/NumCopies.hs +1/−3
• Annex/VectorClock.hs +1/−1
• Annex/Version.hs +26/−21
• Annex/WorkTree.hs +8/−6
• Assistant/DaemonStatus.hs +1/−1
• Assistant/Install.hs +3/−3
• Assistant/Pairing.hs +0/−6
• Assistant/Ssh.hs +1/−1
• Assistant/Sync.hs +3/−3
• Assistant/Threads/Committer.hs +2/−1
• Assistant/Threads/Exporter.hs +2/−1
• Assistant/Threads/Merger.hs +2/−1
• Assistant/Threads/WebApp.hs +0/−6
• Assistant/WebApp/Configurators/Local.hs +2/−15
• Assistant/WebApp/Configurators/Ssh.hs +0/−5
• Assistant/WebApp/Configurators/Upgrade.hs +2/−13
• Assistant/WebApp/Page.hs +1/−8
• BuildFlags.hs +0/−5
• CHANGELOG +61/−0
• COPYRIGHT +1/−1
• CmdLine/Action.hs +0/−7
• CmdLine/Seek.hs +19/−2
• Command/AddUrl.hs +13/−9
• Command/Adjust.hs +15/−6
• Command/EnableTor.hs +1/−0
• Command/Find.hs +1/−1
• Command/Fix.hs +6/−4
• Command/Fsck.hs +1/−1
• Command/Info.hs +7/−17
• Command/Init.hs +13/−6
• Command/Merge.hs +3/−2
• Command/Migrate.hs +14/−14
• Command/PostReceive.hs +3/−2
• Command/PreCommit.hs +16/−5
• Command/ReKey.hs +12/−12
• Command/Smudge.hs +72/−43
• Command/Sync.hs +55/−53
• Command/Version.hs +9/−3
• Command/WebApp.hs +1/−30
• Database/Handle.hs +65/−33
• Database/Init.hs +14/−15
• Database/Keys.hs +3/−1
• Git/Env.hs +1/−20
• Git/Fsck.hs +1/−8
• Git/LsFiles.hs +13/−4
• Logs/File.hs +41/−8
• Logs/MetaData.hs +1/−1
• Logs/Smudge.hs +40/−0
• Logs/TimeStamp.hs +0/−39
• Logs/Transfer.hs +1/−1
• Logs/Unused.hs +1/−1
• Messages.hs +21/−4
• Messages/Concurrent.hs +0/−24
• Messages/Progress.hs +4/−13
• NEWS +18/−0
• P2P/IO.hs +18/−5
• Remote/External.hs +0/−4
• Remote/Helper/Export.hs +18/−9
• Remote/Helper/Ssh.hs +6/−0
• Remote/List.hs +1/−0
• RemoteDaemon/Transport/Tor.hs +1/−0
• Test.hs +91/−89
• Test/Framework.hs +42/−9
• Types/AdjustedBranch.hs +53/−0
• Types/DesktopNotify.hs +3/−13
• Types/Difference.hs +1/−8
• Types/GitConfig.hs +3/−2
• Types/Messages.hs +0/−8
• Types/RepoVersion.hs +11/−0
• Types/Test.hs +6/−16
• Upgrade.hs +37/−20
• Upgrade/V5.hs +1/−1
• Upgrade/V6.hs +21/−0
• Utility/Batch.hs +2/−6
• Utility/CopyFile.hs +0/−6
• Utility/DiskFree.hs +0/−14
• Utility/Exception.hs +1/−17
• Utility/InodeCache.hs +93/−27
• Utility/Lsof.hs +2/−22
• Utility/Mounts.hs +0/−5
• Utility/PartialPrelude.hs +3/−2
• Utility/QuickCheck.hs +1/−1
• Utility/Shell.hs +4/−14
• Utility/ThreadScheduler.hs +0/−4
• Utility/TimeStamp.hs +45/−0
• Utility/Touch.hs +15/−24
• Utility/Touch/Old.hsc +0/−123
• Utility/UserInfo.hs +2/−2
• Utility/WebApp.hs +1/−18
• Utility/Yesod.hs +1/−19
• doc/git-annex-add.mdwn +1/−1
• doc/git-annex-adjust.mdwn +28/−3
• doc/git-annex-pre-commit.mdwn +1/−1
• doc/git-annex-smudge.mdwn +14/−2
• doc/git-annex-sync.mdwn +5/−5
• doc/git-annex-unlock.mdwn +4/−4
• doc/git-annex.mdwn +6/−8
• git-annex.cabal +26/−47
• stack.yaml +0/−3
• templates/configurators/upgrade/android.hamlet +0/−10
• templates/page.hamlet +2/−3

@@ -65,6 +65,7 @@ import Types.LockCache import Types.DesktopNotify import Types.CleanupActions+import Types.AdjustedBranch import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url@@ -144,7 +145,7 @@ 	, activekeys :: TVar (M.Map Key ThreadId) 	, activeremotes :: MVar (M.Map (Types.Remote.RemoteA Annex) Integer) 	, keysdbhandle :: Maybe Keys.DbHandle-	, cachedcurrentbranch :: Maybe Git.Branch+	, cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment)) 	, cachedgitenv :: Maybe [(String, String)] 	, urloptions :: Maybe UrlOptions 	}

@@ -1,14 +1,17 @@ {- adjusted branch  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2018 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE BangPatterns #-}  module Annex.AdjustedBranch ( 	Adjustment(..),+	LinkAdjustment(..),+	PresenceAdjustment(..),+	adjustmentHidesFiles, 	OrigBranch, 	AdjBranch(..), 	originalToAdjusted,@@ -16,17 +19,20 @@ 	fromAdjustedBranch, 	getAdjustment, 	enterAdjustedBranch,+	updateAdjustedBranch, 	adjustBranch, 	adjustToCrippledFileSystem,-	updateAdjustedBranch,+	mergeToAdjustedBranch, 	propigateAdjustedCommits, 	AdjustedClone(..), 	checkAdjustedClone,-	isGitVersionSupported,+	isSupported, 	checkVersionSupported, ) where  import Annex.Common+import Types.AdjustedBranch+import Annex.AdjustedBranch.Name import qualified Annex import Git import Git.Types@@ -57,38 +63,34 @@  import qualified Data.Map as M -data Adjustment-	= UnlockAdjustment-	| LockAdjustment-	| FixAdjustment-	| UnFixAdjustment-	| HideMissingAdjustment-	| ShowMissingAdjustment-	deriving (Show, Eq)+-- How to perform various adjustments to a TreeItem.+class AdjustTreeItem t where+	adjustTreeItem :: t -> TreeItem -> Annex (Maybe TreeItem) -reverseAdjustment :: Adjustment -> Adjustment-reverseAdjustment UnlockAdjustment = LockAdjustment-reverseAdjustment LockAdjustment = UnlockAdjustment-reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment-reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment-reverseAdjustment FixAdjustment = UnFixAdjustment-reverseAdjustment UnFixAdjustment = FixAdjustment+instance AdjustTreeItem Adjustment where+	adjustTreeItem (LinkAdjustment l) t = adjustTreeItem l t+	adjustTreeItem (PresenceAdjustment p Nothing) t = adjustTreeItem p t+	adjustTreeItem (PresenceAdjustment p (Just l)) t =+		adjustTreeItem p t >>= \case+			Nothing -> return Nothing+			Just t' -> adjustTreeItem l t' -{- How to perform various adjustments to a TreeItem. -}-adjustTreeItem :: Adjustment -> TreeItem -> Annex (Maybe TreeItem)-adjustTreeItem UnlockAdjustment = ifSymlink adjustToPointer noAdjust-adjustTreeItem LockAdjustment = ifSymlink noAdjust adjustToSymlink-adjustTreeItem FixAdjustment = ifSymlink adjustToSymlink noAdjust-adjustTreeItem UnFixAdjustment = ifSymlink (adjustToSymlink' gitAnnexLinkCanonical) noAdjust-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+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 +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+ ifSymlink :: (TreeItem -> Annex a) -> (TreeItem -> Annex a) -> TreeItem -> Annex a ifSymlink issymlink notsymlink ti@(TreeItem _f m _s) 	| toTreeItemType m == Just TreeSymlink = issymlink ti@@ -118,9 +120,6 @@ 			<$> hashSymlink linktarget 	Nothing -> return (Just ti) -type OrigBranch = Branch-newtype AdjBranch = AdjBranch { adjBranch :: Branch }- -- This is a hidden branch ref, that's used as the basis for the AdjBranch, -- since pushes can overwrite the OrigBranch at any time. So, changes -- are propigated from the AdjBranch to the head of the BasisBranch.@@ -132,42 +131,6 @@ basisBranch (AdjBranch adjbranch) = BasisBranch $ 	Ref ("refs/basis/" ++ fromRef (Git.Ref.base adjbranch)) -adjustedBranchPrefix :: String-adjustedBranchPrefix = "refs/heads/adjusted/"--serialize :: Adjustment -> String-serialize UnlockAdjustment = "unlocked"-serialize LockAdjustment = "locked"-serialize HideMissingAdjustment = "present"-serialize ShowMissingAdjustment = "showmissing"-serialize FixAdjustment = "fixed"-serialize UnFixAdjustment = "unfixed"--deserialize :: String -> Maybe Adjustment-deserialize "unlocked" = Just UnlockAdjustment-deserialize "locked" = Just UnlockAdjustment-deserialize "present" = Just HideMissingAdjustment-deserialize "fixed" = Just FixAdjustment-deserialize "unfixed" = Just UnFixAdjustment-deserialize _ = Nothing--originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch-originalToAdjusted orig adj = AdjBranch $ Ref $-	adjustedBranchPrefix ++ base ++ '(' : serialize adj ++ ")"-  where-	base = fromRef (Git.Ref.base orig)--adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch)-adjustedToOriginal b-	| adjustedBranchPrefix `isPrefixOf` bs = do-		let (base, as) = separate (== '(') (drop prefixlen bs)-		adj <- deserialize (takeWhile (/= ')') as)-		Just (adj, Git.Ref.branchRef (Ref base))-	| otherwise = Nothing-  where-	bs = fromRef b-	prefixlen = length adjustedBranchPrefix- getAdjustment :: Branch -> Maybe Adjustment getAdjustment = fmap fst . adjustedToOriginal @@ -182,12 +145,21 @@  - branch).  -  - Can fail, if no branch is checked out, or if the adjusted branch already- - exists, or perhaps if staged changes conflict with the adjusted branch.+ - exists, or if staged changes prevent a checkout.  -} enterAdjustedBranch :: Adjustment -> Annex Bool-enterAdjustedBranch adj = go =<< originalBranch+enterAdjustedBranch adj = inRepo Git.Branch.current >>= \case+	Just currbranch -> case getAdjustment currbranch of+		Just curradj | curradj == adj ->+			updateAdjustedBranch adj (AdjBranch currbranch)+				(fromAdjustedBranch currbranch)+		_ -> go currbranch+	Nothing -> do+		warning "not on any branch!"+		return False   where-	go (Just origbranch) = do+	go currbranch = do+		let origbranch = fromAdjustedBranch currbranch 		let adjbranch = adjBranch $ originalToAdjusted origbranch adj 		ifM (inRepo (Git.Ref.exists adjbranch) <&&> (not <$> Annex.getState Annex.force)) 			( do@@ -200,23 +172,58 @@ 					  , Git.Ref.describe origbranch 					  ] 					, [ "You can check out the adjusted branch manually to enter it,"-					  , "or delete the adjusted branch and re-run this command."+					  , "or add the --force option to overwrite the old branch." 					  ] 					] 				return False 			, do-				AdjBranch b <- preventCommits $ const $ +				b <- preventCommits $ const $  					adjustBranch adj origbranch-				showOutput -- checkout can have output in large repos-				inRepo $ Git.Command.runBool-					[ Param "checkout"-					, Param $ fromRef $ Git.Ref.base b-					]+				checkoutAdjustedBranch b [] 			)-	go Nothing = do-		warning "not on any branch!"-		return False +checkoutAdjustedBranch :: AdjBranch -> [CommandParam] -> Annex Bool+checkoutAdjustedBranch (AdjBranch b) checkoutparams = do+	showOutput -- checkout can have output in large repos+	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++{- 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.+ - 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++		-- 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+	+	-- 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+ adjustToCrippledFileSystem :: Annex () adjustToCrippledFileSystem = do 	warning "Entering an adjusted branch where files are unlocked as this filesystem does not support locked files."@@ -227,7 +234,7 @@ 			, Param "-m" 			, Param "commit before entering adjusted unlocked branch" 			]-	unlessM (enterAdjustedBranch UnlockAdjustment) $+	unlessM (enterAdjustedBranch (LinkAdjustment UnlockAdjustment)) $ 		warning "Failed to enter adjusted branch!"  setBasisBranch :: BasisBranch -> Ref -> Annex ()@@ -313,8 +320,8 @@ {- Update the currently checked out adjusted branch, merging the provided  - branch into it. Note that the provided branch should be a non-adjusted  - branch. -}-updateAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool-updateAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge commitmode = catchBoolIO $+mergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> [Git.Merge.MergeConfig] -> Annex Bool -> Git.Branch.CommitMode -> Annex Bool+mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge commitmode = catchBoolIO $ 	join $ preventCommits go   where 	adjbranch@(AdjBranch currbranch) = originalToAdjusted origbranch adj@@ -603,10 +610,8 @@ 				, return NeedUpgradeForAdjustedClone 				) --- git 2.2.0 needed for GIT_COMMON_DIR which is needed--- by updateAdjustedBranch to use withWorkTreeRelated.-isGitVersionSupported :: IO Bool-isGitVersionSupported = not <$> Git.Version.older "2.2.0"+isSupported :: Annex Bool+isSupported = versionSupportsAdjustedBranch <&&> liftIO isGitVersionSupported  checkVersionSupported :: Annex () checkVersionSupported = do@@ -614,3 +619,8 @@ 		giveup "Adjusted branches are only supported in v6 or newer repositories." 	unlessM (liftIO isGitVersionSupported) $ 		giveup "Your version of git is too old; upgrade it to 2.2.0 or newer to use adjusted branches."++-- git 2.2.0 needed for GIT_COMMON_DIR which is needed+-- by updateAdjustedBranch to use withWorkTreeRelated.+isGitVersionSupported :: IO Bool+isGitVersionSupported = not <$> Git.Version.older "2.2.0"

@@ -0,0 +1,83 @@+{- adjusted branch names+ -+ - Copyright 2016-2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.AdjustedBranch.Name (+	originalToAdjusted,+	adjustedToOriginal,+	AdjBranch(..),+	OrigBranch,+) where++import Types.AdjustedBranch+import Git+import qualified Git.Ref+import Utility.Misc++import Control.Applicative+import Data.List++adjustedBranchPrefix :: String+adjustedBranchPrefix = "refs/heads/adjusted/"++class SerializeAdjustment t where+	serializeAdjustment :: t -> String+	deserializeAdjustment :: String -> Maybe t++instance SerializeAdjustment Adjustment where+	serializeAdjustment (LinkAdjustment l) =+		serializeAdjustment l+	serializeAdjustment (PresenceAdjustment p Nothing) =+		serializeAdjustment p+	serializeAdjustment (PresenceAdjustment p (Just l)) = +		serializeAdjustment p ++ "-" ++ serializeAdjustment l+	deserializeAdjustment s = +		(LinkAdjustment <$> deserializeAdjustment s)+			<|>+		(PresenceAdjustment <$> deserializeAdjustment s1 <*> pure (deserializeAdjustment s2))+			<|>+		(PresenceAdjustment <$> deserializeAdjustment s <*> pure Nothing)+	  where+		(s1, s2) = separate (== '-') s++instance SerializeAdjustment LinkAdjustment where+	serializeAdjustment UnlockAdjustment = "unlocked"+	serializeAdjustment LockAdjustment = "locked"+	serializeAdjustment FixAdjustment = "fixed"+	serializeAdjustment UnFixAdjustment = "unfixed"+	deserializeAdjustment "unlocked" = Just UnlockAdjustment+	deserializeAdjustment "locked" = Just UnlockAdjustment+	deserializeAdjustment "fixed" = Just FixAdjustment+	deserializeAdjustment "unfixed" = Just UnFixAdjustment+	deserializeAdjustment _ = Nothing++instance SerializeAdjustment PresenceAdjustment where+	serializeAdjustment HideMissingAdjustment = "hidemissing"+	serializeAdjustment ShowMissingAdjustment = "showmissing"+	deserializeAdjustment "hidemissing" = Just HideMissingAdjustment+	deserializeAdjustment "showmissing" = Just ShowMissingAdjustment+	deserializeAdjustment _ = Nothing++newtype AdjBranch = AdjBranch { adjBranch :: Branch }++originalToAdjusted :: OrigBranch -> Adjustment -> AdjBranch+originalToAdjusted orig adj = AdjBranch $ Ref $+	adjustedBranchPrefix ++ base ++ '(' : serializeAdjustment adj ++ ")"+  where+	base = fromRef (Git.Ref.base orig)++type OrigBranch = Branch++adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch)+adjustedToOriginal b+	| adjustedBranchPrefix `isPrefixOf` bs = do+		let (base, as) = separate (== '(') (drop prefixlen bs)+		adj <- deserializeAdjustment (takeWhile (/= ')') as)+		Just (adj, Git.Ref.branchRef (Ref base))+	| otherwise = Nothing+  where+	bs = fromRef b+	prefixlen = length adjustedBranchPrefix

@@ -1,6 +1,6 @@ {- git cat-file interface, with handle automatically stored in the Annex monad  -- - Copyright 2011-2015 Joey Hess <id@joeyh.name>+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,9 +16,11 @@ 	catObjectMetaData, 	catFileStop, 	catKey,+	catSymLinkTarget, 	catKeyFile, 	catKeyFileHEAD,-	catSymLinkTarget,+	catKeyFileHidden,+	catObjectMetaDataHidden, ) where  import qualified Data.ByteString.Lazy as L@@ -34,6 +36,8 @@ import Git.Index import qualified Git.Ref import Annex.Link+import Annex.CurrentBranch+import Types.AdjustedBranch import Utility.FileSystemEncoding  catFile :: Git.Branch -> FilePath -> Annex L.ByteString@@ -142,3 +146,16 @@  catKeyFileHEAD :: FilePath -> Annex (Maybe Key) catKeyFileHEAD f = catKey $ Git.Ref.fileFromRef Git.Ref.headRef f++{- Look in the original branch from whence an adjusted branch is based+ - to find the file. But only when the adjustment hides some files. -}+catKeyFileHidden :: FilePath -> CurrBranch -> Annex (Maybe Key) +catKeyFileHidden = hiddenCat catKey++catObjectMetaDataHidden :: FilePath -> CurrBranch -> Annex (Maybe (Integer, ObjectType))+catObjectMetaDataHidden = hiddenCat catObjectMetaData++hiddenCat :: (Ref -> Annex (Maybe a)) -> FilePath -> CurrBranch -> Annex (Maybe a)+hiddenCat a f (Just origbranch, Just adj)+	| adjustmentHidesFiles adj = a (Git.Ref.fileFromRef origbranch f)+hiddenCat _ _ _ = return Nothing

@@ -46,6 +46,7 @@ 	staleKeysPrune, 	pruneTmpWorkDirBefore, 	isUnmodified,+	isUnmodifiedCheap, 	verifyKeyContent, 	VerifyConfig(..), 	Verification(..),@@ -97,29 +98,29 @@ inAnnexCheck :: Key -> (FilePath -> Annex Bool) -> Annex Bool inAnnexCheck key check = inAnnex' id False check key -{- inAnnex that performs an arbitrary check of the key's content.- -- - When the content is unlocked, it must also be unmodified, or the bad- - value will be returned.- -- - In direct mode, at least one of the associated files must pass the- - check. Additionally, the file must be unmodified.- -}+{- inAnnex that performs an arbitrary check of the key's content. -} inAnnex' :: (a -> Bool) -> a -> (FilePath -> Annex a) -> Key -> Annex a inAnnex' isgood bad check key = withObjectLoc key checkindirect checkdirect   where 	checkindirect loc = do 		r <- check loc 		if isgood r-			then do-				cache <- Database.Keys.getInodeCaches key-				if null cache-					then return r-					else ifM (sameInodeCache loc cache)-						( return r-						, return bad-						)+			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+ +	-- In direct mode, at least one of the associated files must pass the+	-- check. Additionally, the file must be unmodified. 	checkdirect [] = return bad 	checkdirect (loc:locs) = do 		r <- check loc@@ -746,17 +747,38 @@ isUnmodified key f = go =<< geti   where 	go Nothing = return False-	go (Just fc) = cheapcheck fc <||> expensivecheck fc-	cheapcheck fc = anyM (compareInodeCaches fc)-		=<< Database.Keys.getInodeCaches key+	go (Just fc) = isUnmodifiedCheap' key fc <||> expensivecheck fc 	expensivecheck fc = ifM (verifyKeyContent RetrievalAllKeysSecure AlwaysVerify UnVerified key f)-		-- The file could have been modified while it was-		-- being verified. Detect that.-		( geti >>= maybe (return False) (compareInodeCaches fc)+		( 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 -> FilePath -> 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. -} moveBad :: Key -> Annex FilePath@@ -845,6 +867,7 @@ saveState :: Bool -> Annex () saveState nocommit = doSideAction $ do 	Annex.Queue.flush+	Database.Keys.closeDb 	unless nocommit $ 		whenM (annexAlwaysCommit <$> Annex.getGitConfig) $ 			Annex.Branch.commit =<< Annex.Branch.commitMessage

@@ -49,7 +49,6 @@  linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied) linkOrCopy' canhardlink key src dest destmode-	| maybe False isExecutable destmode = copy =<< getstat 	| otherwise = catchDefaultIO Nothing $ 		ifM canhardlink 			( hardlink

@@ -0,0 +1,41 @@+{- currently checked out branch+ -+ - Copyright 2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Annex.CurrentBranch where++import Annex.Common+import Types.AdjustedBranch+import Annex.AdjustedBranch.Name+import qualified Annex+import qualified Git+import qualified Git.Branch++type CurrBranch = (Maybe Git.Branch, Maybe Adjustment)++{- Gets the currently checked out branch.+ - When on an adjusted branch, gets the original branch, and the adjustment.+ -+ - Cached for speed.+ -+ - Until a commit is made in a new repository, no branch is checked out.+ - Since git-annex may make the first commit, this does not cache+ - the absence of a branch.+ -}+getCurrentBranch :: Annex CurrBranch+getCurrentBranch = maybe cache return+	=<< Annex.getState Annex.cachedcurrentbranch+  where+	cache = inRepo Git.Branch.current >>= \case+		Just b -> do+			let v = case adjustedToOriginal b of +                        	Nothing -> (Just b, Nothing) +                                Just (adj, origbranch) -> +                                	(Just origbranch, Just adj)+			Annex.changeState $ \s ->+				s { Annex.cachedcurrentbranch = Just v }+			return v+		Nothing -> return (Nothing, Nothing)

@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Annex.Environment where  import Annex.Common@@ -37,14 +35,8 @@ 	ensureEnv "GIT_AUTHOR_NAME" username 	ensureEnv "GIT_COMMITTER_NAME" username   where-#ifndef __ANDROID__ 	-- existing environment is not overwritten 	ensureEnv var val = setEnv var val False-#else-	-- Environment setting is broken on Android, so this is dealt with-	-- in runshell instead.-	ensureEnv _ _ = noop-#endif  {- Runs an action that commits to the repository, and if it fails,   - sets user.email and user.name to a dummy value and tries the action again. -}

@@ -14,6 +14,7 @@ import Git.Types import Git.Index import Git.Env+import Utility.Env import qualified Annex import qualified Annex.Queue @@ -27,8 +28,8 @@ 		a   where 	-- This is an optimisation. Since withIndexFile is run repeatedly,-	-- and addGitEnv uses the slow copyGitEnv when gitEnv is Nothing, -	-- we cache the copied environment the first time, and reuse it in+	-- and addGitEnv uses the slow getEnvironment when gitEnv is Nothing, +	-- we cache the environment the first time, and reuse it in 	-- subsequent calls. 	-- 	-- (This could be done at another level; eg when creating the@@ -40,7 +41,7 @@ 		Nothing -> do 			e <- Annex.withState $ \s -> case Annex.cachedgitenv s of 				Nothing -> do-					e <- copyGitEnv+					e <- getEnvironment 					return (s { Annex.cachedgitenv = Just e }, e) 				Just e -> return (s, e) 			m (g { gitEnv = Just e })

@@ -32,6 +32,17 @@ 	[ mkHookScript "git annex post-receive" 	] +postCheckoutHook :: Git.Hook+postCheckoutHook = Git.Hook "post-checkout" smudgeHook []++postMergeHook :: Git.Hook+postMergeHook = Git.Hook "post-merge" smudgeHook []++-- Older versions of git-annex didn't support this command, but neither did+-- they support v7 repositories.+smudgeHook :: String+smudgeHook = mkHookScript "git annex smudge --update"+ preCommitAnnexHook :: Git.Hook preCommitAnnexHook = Git.Hook "pre-commit-annex" "" [] @@ -40,7 +51,7 @@  mkHookScript :: String -> String mkHookScript s = unlines-	[ shebang_local+	[ shebang 	, "# automatically configured by git-annex" 	, s 	]

@@ -32,13 +32,12 @@ import Annex.Perms import Annex.Link import Annex.MetaData+import Annex.CurrentBranch import Annex.Version import Logs.Location import qualified Annex import qualified Annex.Queue import qualified Database.Keys-import qualified Git-import qualified Git.Branch import Config import Utility.InodeCache import Annex.ReplaceFile@@ -288,7 +287,7 @@ 	-- touch symlink to have same time as the original file, 	-- as provided in the InodeCache 	case mcache of-		Just c -> liftIO $ touch file (TimeSpec $ inodeCacheToMtime c) False+		Just c -> liftIO $ touch file (inodeCacheToMtime c) False 		Nothing -> noop  	return l@@ -329,21 +328,13 @@ 	(versionSupportsUnlockedPointers <&&> 	 ((not . coreSymlinks <$> Annex.getGitConfig) <||> 	  (annexAddUnlocked <$> Annex.getGitConfig) <||>-	  (maybe False (\b -> getAdjustment b == Just UnlockAdjustment) <$> cachedCurrentBranch)+	  (maybe False isadjustedunlocked . snd <$> getCurrentBranch) 	 ) 	)--cachedCurrentBranch :: Annex (Maybe Git.Branch)-cachedCurrentBranch = maybe cache (return . Just)-	=<< Annex.getState Annex.cachedcurrentbranch   where-	cache :: Annex (Maybe Git.Branch)-	cache = inRepo Git.Branch.currentUnsafe >>= \case-		Nothing -> return Nothing-		Just b -> do-			Annex.changeState $ \s ->-				s { Annex.cachedcurrentbranch = Just b }-			return (Just b)+	isadjustedunlocked (LinkAdjustment UnlockAdjustment) = True+	isadjustedunlocked (PresenceAdjustment _ (Just UnlockAdjustment)) = True+	isadjustedunlocked _ = False  {- Adds a file to the work tree for the key, and stages it in the index.  - The content of the key may be provided in a temp file, which will be

@@ -21,7 +21,6 @@ import Annex.Common import qualified Annex import qualified Git-import qualified Git.LsFiles import qualified Git.Config import qualified Git.Objects import qualified Annex.Branch@@ -29,10 +28,10 @@ import Logs.Trust.Basic import Logs.Config import Types.TrustLevel+import Types.RepoVersion import Annex.Version import Annex.Difference import Annex.UUID-import Annex.Link import Annex.WorkTree import Config import Config.Smudge@@ -78,7 +77,7 @@ 		Right username -> [username, at, hostname, ":", reldir] 		Left _ -> [hostname, ":", reldir] -initialize :: AutoInit -> Maybe String -> Maybe Version -> Annex ()+initialize :: AutoInit -> Maybe String -> Maybe RepoVersion -> Annex () initialize ai mdescription mversion = checkCanInitialize ai $ do 	{- Has to come before any commits are made as the shared 	 - clone heuristic expects no local objects. -}@@ -98,7 +97,7 @@  -- Everything except for uuid setup, shared clone setup, and initial -- description.-initialize' :: AutoInit -> Maybe Version -> Annex ()+initialize' :: AutoInit -> Maybe RepoVersion -> Annex () initialize' ai mversion = checkCanInitialize ai $ do 	checkLockSupport 	checkFifoSupport@@ -112,18 +111,16 @@ 	whenM versionSupportsUnlockedPointers $ do 		configureSmudgeFilter 		scanUnlockedFiles+		unlessM isBareRepo $ do+			hookWrite postCheckoutHook+			hookWrite postMergeHook 	checkAdjustedClone >>= \case 		NeedUpgradeForAdjustedClone -> -			void $ upgrade True  versionForAdjustedClone+			void $ upgrade True versionForAdjustedClone 		InAdjustedClone -> return () 		NotInAdjustedClone -> 			ifM (crippledFileSystem <&&> (not <$> isBareRepo))-				( ifM versionSupportsUnlockedPointers-					( adjustToCrippledFileSystem-					, do-						enableDirectMode-						setDirect True-					)+				( adjustToCrippledFileSystem 				-- Handle case where this repo was cloned from a 				-- direct mode repo 				, unlessM isBareRepo@@ -265,15 +262,6 @@ 	warning "Detected a filesystem without fifo support." 	warning "Disabling ssh connection caching." 	setConfig (annexConfig "sshcaching") (Git.Config.boolConfig False)--enableDirectMode :: Annex ()-enableDirectMode = unlessM isDirect $ do-	warning "Enabling direct mode."-	top <- fromRepo Git.repoPath-	(l, clean) <- inRepo $ Git.LsFiles.inRepo [top]-	forM_ l $ \f ->-		maybe noop (`toDirect` f) =<< isAnnexLink f-	void $ liftIO clean  checkSharedClone :: Annex Bool checkSharedClone = inRepo Git.Objects.isSharedClone

@@ -38,6 +38,8 @@ 	gitAnnexFsckDbDir, 	gitAnnexFsckDbLock, 	gitAnnexFsckResultsLog,+	gitAnnexSmudgeLog,+	gitAnnexSmudgeLock, 	gitAnnexExportDbDir, 	gitAnnexExportLock, 	gitAnnexScheduleState,@@ -311,6 +313,14 @@ {- .git/annex/fsckresults/uuid is used to store results of git fscks -} gitAnnexFsckResultsLog :: UUID -> Git.Repo -> FilePath gitAnnexFsckResultsLog u r = gitAnnexDir r </> "fsckresults" </> fromUUID u++{- .git/annex/smudge.log is used to log smudges worktree files that need to+ - be updated. -}+gitAnnexSmudgeLog :: Git.Repo -> FilePath+gitAnnexSmudgeLog r = gitAnnexDir r </> "smudge.log"++gitAnnexSmudgeLock :: Git.Repo -> FilePath+gitAnnexSmudgeLock r = gitAnnexDir r </> "smudge.lck"  {- .git/annex/export/uuid/ is used to store information about  - exports to special remotes. -}

@@ -5,7 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}  module Annex.NumCopies ( 	module Types.NumCopies,@@ -165,9 +165,7 @@ 				cont v `catchNonAsync` (throw . DropException) 			a `M.catches` 				[ M.Handler (\ (e :: AsyncException) -> throwM e)-#if MIN_VERSION_base(4,7,0) 				, M.Handler (\ (e :: SomeAsyncException) -> throwM e)-#endif 				, M.Handler (\ (DropException e') -> throwM e') 				, M.Handler (\ (_e :: SomeException) -> fallback) 				]

@@ -15,7 +15,7 @@ import Prelude  import Utility.Env-import Logs.TimeStamp+import Utility.TimeStamp import Utility.QuickCheck  -- | Some very old logs did not have any time stamp at all;

@@ -1,8 +1,8 @@ {- git-annex repository versioning  -- - Copyright 2010,2013 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -}  {-# LANGUAGE CPP #-}@@ -11,48 +11,53 @@  import Annex.Common import Config+import Types.RepoVersion import qualified Annex -type Version = String+import qualified Data.Map as M -defaultVersion :: Version-defaultVersion = "5"+defaultVersion :: RepoVersion+defaultVersion = RepoVersion 5 -latestVersion :: Version-latestVersion = "6"+latestVersion :: RepoVersion+latestVersion = RepoVersion 7 -supportedVersions :: [Version]-supportedVersions = ["3", "5", "6"]+supportedVersions :: [RepoVersion]+supportedVersions = map RepoVersion [5, 7] -versionForAdjustedClone :: Version-versionForAdjustedClone = "6"+versionForAdjustedClone :: RepoVersion+versionForAdjustedClone = RepoVersion 7 -upgradableVersions :: [Version]+upgradableVersions :: [RepoVersion] #ifndef mingw32_HOST_OS-upgradableVersions = ["0", "1", "2", "3", "4", "5"]+upgradableVersions = map RepoVersion [0..6] #else-upgradableVersions = ["2", "3", "4", "5"]+upgradableVersions = map RepoVersion [2..6] #endif -autoUpgradeableVersions :: [Version]-autoUpgradeableVersions = ["3", "4"]+autoUpgradeableVersions :: M.Map RepoVersion RepoVersion+autoUpgradeableVersions = M.fromList+	[ (RepoVersion 3, RepoVersion 5)+	, (RepoVersion 4, RepoVersion 5)+	, (RepoVersion 6, RepoVersion 7)+	]  versionField :: ConfigKey versionField = annexConfig "version" -getVersion :: Annex (Maybe Version)+getVersion :: Annex (Maybe RepoVersion) getVersion = annexVersion <$> Annex.getGitConfig  versionSupportsDirectMode :: Annex Bool versionSupportsDirectMode = go <$> getVersion   where-	go (Just "6") = False+	go (Just v) | v >= RepoVersion 6 = False 	go _ = True  versionSupportsUnlockedPointers :: Annex Bool versionSupportsUnlockedPointers = go <$> getVersion   where-	go (Just "6") = True+	go (Just v) | v >= RepoVersion 6 = True 	go _ = False  versionSupportsAdjustedBranch :: Annex Bool@@ -61,8 +66,8 @@ versionUsesKeysDatabase :: Annex Bool versionUsesKeysDatabase = versionSupportsUnlockedPointers -setVersion :: Version -> Annex ()-setVersion = setConfig versionField+setVersion :: RepoVersion -> Annex ()+setVersion (RepoVersion v) = setConfig versionField (show v)  removeVersion :: Annex () removeVersion = unsetConfig versionField

@@ -1,6 +1,6 @@ {- git-annex worktree files  -- - Copyright 2013-2016 Joey Hess <id@joeyh.name>+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -13,6 +13,7 @@ import Annex.Version import Annex.Content import Annex.ReplaceFile+import Annex.CurrentBranch import Config import Git.FilePath import qualified Git.Ref@@ -28,19 +29,20 @@  -  - An unlocked file will not have a link on disk, so fall back to  - looking for a pointer to a key in git.+ -+ - When in an adjusted branch that may have hidden the file, looks for a+ - pointer to a key in the original branch.  -} lookupFile :: FilePath -> Annex (Maybe Key) lookupFile file = isAnnexLink file >>= \case-	Just key -> makeret key+	Just key -> return (Just key) 	Nothing -> ifM (versionSupportsUnlockedPointers <||> isDirect) 		( ifM (liftIO $ doesFileExist file)-			( maybe (return Nothing) makeret =<< catKeyFile file-			, return Nothing+			( catKeyFile file+			, catKeyFileHidden file =<< getCurrentBranch 			) 		, return Nothing  		)-  where-	makeret = return . Just  {- Modifies an action to only act on files that are already annexed,  - and passes the key on to it. -}

@@ -16,7 +16,7 @@ import Types.Transfer import Logs.Transfer import Logs.Trust-import Logs.TimeStamp+import Utility.TimeStamp import qualified Remote import qualified Types.Remote as Remote import Config.DynamicConfig

@@ -80,7 +80,7 @@ 		let rungitannexshell var = runshell $ "git-annex-shell -c \"" ++ var ++ "\""  		installWrapper (sshdir </> "git-annex-shell") $ unlines-			[ shebang_local+			[ shebang 			, "set -e" 			, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" 			,   rungitannexshell "$SSH_ORIGINAL_COMMAND"@@ -89,7 +89,7 @@ 			, "fi" 			] 		installWrapper (sshdir </> "git-annex-wrapper") $ unlines-			[ shebang_local+			[ shebang 			, "set -e" 			, runshell "\"$@\"" 			]@@ -124,7 +124,7 @@   where 	genNautilusScript scriptdir action = 		installscript (scriptdir </> scriptname action) $ unlines-			[ shebang_local+			[ shebang 			, autoaddedcomment 			, "exec " ++ program ++ " " ++ action ++ " --notify-start --notify-finish -- \"$@\"" 			]

@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Assistant.Pairing where  import Annex.Common@@ -84,11 +82,7 @@ data AddrClass = IPv4AddrClass | IPv6AddrClass  data SomeAddr = IPv4Addr HostAddress-{- My Android build of the Network library does not currently have IPV6- - support. -}-#ifndef __ANDROID__ 	| IPv6Addr HostAddress6-#endif 	deriving (Ord, Eq, Read, Show)  {- This contains the whole secret, just lightly obfuscated to make it not

@@ -189,7 +189,7 @@ 	echoval v = "echo " ++ shellEscape v 	wrapper = "~/.ssh/git-annex-shell" 	script =-		[ shebang_portable+		[ shebang 		, "set -e" 		, "if [ \"x$SSH_ORIGINAL_COMMAND\" != \"x\" ]; then" 		,   runshell "$SSH_ORIGINAL_COMMAND"

@@ -25,6 +25,7 @@ import Annex.UUID import Annex.TaggedPush import Annex.Ssh+import Annex.CurrentBranch import qualified Config import Git.Config import Config.DynamicConfig@@ -79,8 +80,7 @@ 	{- No local branch exists yet, but we can try pulling. -} 	sync (Nothing, _) = manualPull (Nothing, Nothing) =<< gitremotes 	go = do-		(failed, diverged) <- sync-			=<< liftAnnex (join Command.Sync.getCurrBranch)+		(failed, diverged) <- sync =<< liftAnnex getCurrentBranch 		addScanRemotes diverged =<< 			filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) rs 		return failed@@ -127,7 +127,7 @@ 		Annex.Branch.commit =<< Annex.Branch.commitMessage 		(,,) 			<$> gitRepo-			<*> join Command.Sync.getCurrBranch+			<*> getCurrentBranch 			<*> getUUID 	ret <- go True branch g u remotes 	return ret

@@ -32,6 +32,7 @@ import Annex.CatFile import Annex.InodeSentinal import Annex.Version+import Annex.CurrentBranch import qualified Annex import Utility.InodeCache import Annex.Content.Direct@@ -228,7 +229,7 @@ 		Right _ -> do 			ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg 			when ok $-				Command.Sync.updateSyncBranch =<< join Command.Sync.getCurrBranch+				Command.Sync.updateBranches =<< getCurrentBranch 			return ok  {- OSX needs a short delay after a file is added before locking it down,

@@ -12,6 +12,7 @@ import Assistant.Pushes import Assistant.DaemonStatus import Annex.Concurrent+import Annex.CurrentBranch import Utility.ThreadScheduler import qualified Annex import qualified Remote@@ -64,7 +65,7 @@ 			Annex.changeState $ \st -> st { Annex.errcounter = 0 } 			start <- liftIO getCurrentTime 			void $ Command.Sync.seekExportContent rs-				=<< join Command.Sync.getCurrBranch+				=<< getCurrentBranch 			-- Look at command error counter to see if the export 			-- didn't work. 			failed <- (> 0) <$> Annex.getState Annex.errcounter

@@ -13,6 +13,7 @@ import Assistant.Sync import Utility.DirWatcher import Utility.DirWatcher.Types+import Annex.CurrentBranch import qualified Annex.Branch import qualified Git import qualified Git.Branch@@ -71,7 +72,7 @@ 	changedbranch = fileToBranch file  	mergecurrent =-		mergecurrent' =<< liftAnnex (join Command.Sync.getCurrBranch)+		mergecurrent' =<< liftAnnex getCurrentBranch 	mergecurrent' currbranch@(Just b, _) 		| changedbranch `isRelatedTo` b = 			whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do

@@ -7,7 +7,6 @@  {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE ViewPatterns, OverloadedStrings #-}-{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Assistant.Threads.WebApp where@@ -69,11 +68,6 @@ 		then pure listenhost 		else getAnnex $ annexListen <$> Annex.getGitConfig 	tlssettings <- getAnnex getTlsSettings-#ifdef __ANDROID__-	when (isJust listenhost') $-		-- See Utility.WebApp-		giveup "Sorry, --listen is not currently supported on Android"-#endif 	webapp <- WebApp 		<$> pure assistantdata 		<*> genAuthToken 128

@@ -20,7 +20,6 @@ import qualified Git import qualified Git.Config import qualified Git.Command-import qualified Command.Sync import Config.Files import Utility.FreeDesktop import Utility.DiskFree@@ -30,6 +29,7 @@ import Utility.DataUnits import Remote (prettyUUID) import Annex.UUID+import Annex.CurrentBranch import Types.StandardGroups import Logs.PreferredContent import Logs.UUID@@ -165,13 +165,8 @@ postFirstRepositoryR = page "Getting started" (Just Configuration) $ do 	unlessM (liftIO $ inPath "git") $ 		giveup "You need to install git in order to use git-annex!"-#ifdef __ANDROID__-	androidspecial <- liftIO $ doesDirectoryExist "/sdcard/DCIM"-	let path = "/sdcard/annex"-#else 	androidspecial <- liftIO osAndroid 	path <- liftIO . defaultRepositoryPath =<< liftH inFirstRun-#endif 	((res, form), enctype) <- liftH $ runFormPostNoToken $ newRepositoryForm path 	case res of 		FormSuccess (RepositoryPath p) -> liftH $@@ -180,12 +175,8 @@  getAndroidCameraRepositoryR :: Handler () getAndroidCameraRepositoryR = do-#ifdef __ANDROID__-	let dcim = "/sdcard/DCIM"-#else 	home <- liftIO myHomeDir 	let dcim = home </> "storage" </> "dcim"-#endif 	startFullAssistant dcim SourceGroup $ Just addignore	   where 	addignore = do@@ -221,7 +212,7 @@  - immediately pulling from it. Also spawns a sync to push to it as well. -} immediateSyncRemote :: Remote -> Assistant () immediateSyncRemote r = do-	currentbranch <- liftAnnex $ join Command.Sync.getCurrBranch+	currentbranch <- liftAnnex $ getCurrentBranch 	void $ manualPull currentbranch [r] 	syncRemote r @@ -392,10 +383,6 @@ 		| dir == "/tmp" = False 		| dir == "/run/shm" = False 		| dir == "/run/lock" = False-#ifdef __ANDROID__-		| dir == "/mnt/sdcard" = False-		| dir == "/sdcard" = False-#endif 		| otherwise = True #endif 

@@ -116,7 +116,6 @@ 		bad_username textField  	bad_username = "bad user name" :: Text-#ifndef __ANDROID__ 	bad_hostname = "cannot resolve host name" :: Text  	check_hostname = checkM (liftIO . checkdns) hostnamefield@@ -131,10 +130,6 @@ 				| otherwise -> Right $ T.pack fullname 			Just [] -> Right t 			Nothing -> Left bad_hostname-#else-	-- getAddrInfo currently broken on Android-	check_hostname = hostnamefield -- unchecked-#endif  	-- The directory is implicitly in home, so remove any leading ~/ 	normalize i = i { inputDirectory = normalizedir <$> inputDirectory i }

@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}  module Assistant.WebApp.Configurators.Upgrade where @@ -15,22 +15,11 @@ import Assistant.Restart import Config -{- On Android, just point the user at the apk file to download.- - Installation will be handled by selecting the downloaded file.- -- - Otherwise, start the upgrade process, which will run fully- - noninteractively.- - -}+{- Start the upgrade process. -} getConfigStartUpgradeR :: GitAnnexDistribution -> Handler Html getConfigStartUpgradeR d = do-#ifdef ANDROID_SPLICES-	let url = distributionUrl d-	page "Upgrade" (Just Configuration) $-		$(widgetFile "configurators/upgrade/android")-#else 	liftAssistant $ startDistributionDownload d 	redirect DashboardR-#endif  {- Finish upgrade by starting the new assistant in the same repository this  - one is running in, and redirecting to it. -}

@@ -5,7 +5,7 @@  - Licensed under the GNU AGPL version 3 or higher.  -} -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes, CPP #-}+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}  module Assistant.WebApp.Page where @@ -70,13 +70,6 @@ 		Just msg -> error msg   where 	navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)--hasFileBrowser :: Bool-#ifdef ANDROID_SPLICES-hasFileBrowser = False-#else-hasFileBrowser = True-#endif  controlMenu :: Widget controlMenu = $(widgetFile "controlmenu")

@@ -62,11 +62,6 @@ #ifdef WITH_DESKTOP_NOTIFY 	, "DesktopNotify" #endif-#ifdef WITH_CONCURRENTOUTPUT-	, "ConcurrentOutput"-#else-#warning Building without ConcurrentOutput-#endif #ifdef WITH_TORRENTPARSER 	, "TorrentParser" #endif

@@ -1,3 +1,64 @@+git-annex (7.20181031) upstream; urgency=medium++  * Added v7 repository mode. v6 upgrades automatically to v7, but+    v5 is still the default for now. While v6 was always experimental+    to some degree, its successor v7 is ready for production use!+    http://git-annex.branchable.com/tips/unlocked_files/+  * Direct mode repositories are deprecated; they have many problems+    that v7 fixes, so upgrading them now is recommended (but not yet+    required): git annex upgrade --version=7+  * init: When in a crippled filesystem, initialize a v7 repository+    using an adjusted unlocked branch, instead of a direct mode repository.+  * At long last there's a way to hide annexed files whose content+    is missing from the working tree: git-annex adjust --hide-missing+    See https://git-annex.branchable.com/tips/hiding_missing_files/+  * When already in an adjusted branch, running git-annex adjust+    again will update the branch as needed. This is mostly+    useful with --hide-missing to hide/unhide files after their content+    has been dropped or received.+  * git-annex sync --content supports --hide-missing; it can+    be used to get the content of hidden files, and it updates the+    adjusted branch to hide/unhide files as necessary.+  * smudge: The smudge filter no longer provides git with annexed+    file content, to avoid a git memory leak, and because that did not+    honor annex.thin. Now git annex smudge --update has to be run+    after a checkout to update unlocked files in the working tree +    with annexed file contents.+  * v7 init, upgrade: Install git post-checkout and post-merge hooks that run +    git annex smudge --update.+  * precommit: Run git annex smudge --update, because the post-merge+    hook is not run when there is a merge conflict. So the work tree will+    be updated when a commit is made to resolve the merge conflict.+  * Note that git has no hooks run after git stash or git cherry-pick,+    so the user will have to manually run git annex smudge --update+    after such commands.+  * Removed the old Android app.+  * Removed support for building with very old ghc < 8.0.1,+    and with yesod < 1.4.3, and without concurrent-output,+    which were only being used for the Android cross build.+  * Webapp: Fix termux detection.+  * runshell: Use system locales when built with +    GIT_ANNEX_PACKAGE_INSTALL set. (For Neurodebian packages.)+  * Fix database inconsistency that could cause git-annex to+    get confused about whether a locked file's content was present.+  * Fix concurrency bug that occurred on the first download from an+    exporttree remote.+  * init --version=6 will still work, but the repository is auto-upgraded+    immediately to v7.+  * When annex.thin is set, allow hard links to be made between executable+    work tree files and annex objects.+  * addurl: Removed undocumented special case in handling of a CHECKURL-MULTI+    response with only a single file listed. Rather than ignoring the url that+    was in the response, use it.+  * webapp: Fixed a crash when adding a git remote.+    (Reversion introduced in version 6.20180112)+  * migrate: Fix failure to migrate from URL keys.+    (Reversion introduced in version 6.20180926)+  * Cache high-resolution mtimes for improved detection of modified files+    in v7 (and direct mode).++ -- Joey Hess <id@joeyh.name>  Wed, 31 Oct 2018 09:21:50 -0400+ git-annex (6.20181011) upstream; urgency=medium    * sync: Warn when a remote's export is not updated to the current

@@ -33,7 +33,7 @@ Copyright: 2012-2018 Joey Hess <id@joeyh.name> License: BSD-2-clause -Files: doc/logo* */favicon.ico standalone/osx/git-annex.app/Contents/Resources/git-annex.icns standalone/android/icons/*+Files: doc/logo* */favicon.ico standalone/osx/git-annex.app/Contents/Resources/git-annex.icns Copyright: 2007 Henrik Nyh <http://henrik.nyh.se/>            2010 Joey Hess <id@joeyh.name> 	   2013 John Lawrence

@@ -24,10 +24,7 @@ import Control.Exception (throwIO) import Data.Either import qualified Data.Map.Strict as M--#ifdef WITH_CONCURRENTOUTPUT import qualified System.Console.Regions as Regions-#endif  {- Runs a command, starting with the check stage, and then  - the seek stage. Finishes by running the continutation, and @@ -169,7 +166,6 @@  {- Do concurrent output when that has been requested. -} allowConcurrentOutput :: Annex a -> Annex a-#ifdef WITH_CONCURRENTOUTPUT allowConcurrentOutput a = do 	fromcmdline <- Annex.getState Annex.concurrency 	fromgitcfg <- annexJobs <$> Annex.getGitConfig@@ -197,9 +193,6 @@ 		setconcurrentoutputenabled False 	setconcurrentoutputenabled b = Annex.changeState $ \s -> 		s { Annex.output = (Annex.output s) { concurrentOutputEnabled = b } }-#else-allowConcurrentOutput = id-#endif  {- Ensures that only one thread processes a key at a time.  - Other threads will block until it's done. -}

@@ -29,6 +29,7 @@ import Remote.List import qualified Remote import Annex.CatFile+import Annex.CurrentBranch import Annex.Content import Annex.InodeSentinal import qualified Database.Keys@@ -270,17 +271,33 @@ -- An item in the work tree, which may be a file or a directory. newtype WorkTreeItem = WorkTreeItem FilePath +-- When in an adjusted branch that hides some files, it may not exist+-- in the current work tree, but in the original branch. This allows+-- seeking for such files.+newtype AllowHidden = AllowHidden Bool+ -- Many git commands seek work tree items matching some criteria, -- and silently skip over anything that does not exist. But users expect -- an error message when one of the files they provided as a command-line -- parameter doesn't exist, so this checks that each exists. workTreeItems :: CmdParams -> Annex [WorkTreeItem]-workTreeItems ps = do+workTreeItems = workTreeItems' (AllowHidden False)++workTreeItems' :: AllowHidden -> CmdParams -> Annex [WorkTreeItem]+workTreeItems' (AllowHidden allowhidden) ps = do+	currbranch <- getCurrentBranch 	forM_ ps $ \p ->-		unlessM (isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)) $ do+		unlessM (exists p <||> hidden currbranch p) $ do 			toplevelWarning False (p ++ " not found") 			Annex.incError 	return (map WorkTreeItem ps)+  where+	exists p = isJust <$> liftIO (catchMaybeIO $ getSymbolicLinkStatus p)+	hidden currbranch p+		| allowhidden = do+			f <- liftIO $ relPathCwdToFile p+			isJust <$> catObjectMetaDataHidden f currbranch+		| otherwise = return False  notSymlink :: FilePath -> IO Bool notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f

@@ -132,17 +132,21 @@ 	go deffile (Right (UrlContents sz mf)) = do 		let f = adjustFile o (fromMaybe (maybe deffile fromSafeFilePath mf) (fileOption (downloadOptions o))) 		void $ commandAction $ startRemote r o f u sz-	go deffile (Right (UrlMulti l))-		| isNothing (fileOption (downloadOptions o)) =+	go deffile (Right (UrlMulti l)) = case fileOption (downloadOptions o) of+		Nothing -> 			forM_ l $ \(u', sz, f) -> do 				let f' = adjustFile o (deffile </> fromSafeFilePath f)-				void $ commandAction $-					startRemote r o f' u' sz-		| otherwise = giveup $ unwords-			[ "That url contains multiple files according to the"-			, Remote.name r-			, " remote; cannot add it to a single file."-			]+				void $ commandAction $ startRemote r o f' u' sz+		Just f -> case l of+			[] -> noop+			((u',sz,_):[]) -> do+				let f' = adjustFile o f+				void $ commandAction $ startRemote r o f' u' sz+			_ -> giveup $ unwords+				[ "That url contains multiple files according to the"+				, Remote.name r+				, " remote; cannot add it to a single file."+				]  startRemote :: Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer -> CommandStart startRemote r o file uri sz = do

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2016 Joey Hess <id@joeyh.name>+ - Copyright 2016-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,7 +16,12 @@ 		paramNothing (seek <$$> optParser)  optParser :: CmdParamsDesc -> Parser Adjustment-optParser _ = +optParser _ =+	(LinkAdjustment <$> linkAdjustmentParser)+	<|> (PresenceAdjustment <$> presenceAdjustmentParser <*> maybeLinkAdjustmentParser)++linkAdjustmentParser :: Parser LinkAdjustment+linkAdjustmentParser = 	flag' UnlockAdjustment 		( long "unlock" 		<> help "unlock annexed files"@@ -25,12 +30,16 @@ 		( long "fix" 		<> help "fix symlinks to annnexed files" 		)-	{- Not ready yet-	<|> flag' HideMissingAdjustment++maybeLinkAdjustmentParser :: Parser (Maybe LinkAdjustment)+maybeLinkAdjustmentParser = Just <$> linkAdjustmentParser <|> pure Nothing++presenceAdjustmentParser :: Parser PresenceAdjustment+presenceAdjustmentParser =+	flag' HideMissingAdjustment 		( long "hide-missing"-		<> help "omit annexed files whose content is not present"+		<> help "hide annexed files whose content is not present" 		)-	-}  seek :: Adjustment -> CommandSeek seek = commandAction . start

@@ -122,6 +122,7 @@ 			, connCheckAuth = const False 			, connIhdl = h 			, connOhdl = h+			, connIdent = ConnIdent Nothing 			} 		runst <- mkRunState Client 		void $ runNetProto runst conn $ P2P.serveAuth u

@@ -18,7 +18,7 @@ import Utility.DataUnits  cmd :: Command-cmd = withGlobalOptions [annexedMatchingOptions] $ mkCommand $+cmd = notBareRepo $ withGlobalOptions [annexedMatchingOptions] $ mkCommand $ 	command "find" SectionQuery "lists available files" 		paramPaths (seek <$$> optParser) 

@@ -18,8 +18,10 @@ import Annex.Perms import qualified Annex.Queue import qualified Database.Keys-#if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)++#if ! defined(mingw32_HOST_OS) import Utility.Touch+import System.Posix.Files #endif  cmd :: Command@@ -91,15 +93,15 @@ fixSymlink :: FilePath -> FilePath -> CommandPerform fixSymlink file link = do 	liftIO $ do-#if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)+#if ! defined(mingw32_HOST_OS) 		-- preserve mtime of symlink-		mtime <- catchMaybeIO $ TimeSpec . modificationTime+		mtime <- catchMaybeIO $ modificationTimeHiRes 			<$> getSymbolicLinkStatus file #endif 		createDirectoryIfMissing True (parentDir file) 		removeFile file 		createSymbolicLink link file-#if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)+#if ! defined(mingw32_HOST_OS) 		maybe noop (\t -> touch file t False) mtime #endif 	next $ cleanupSymlink file

@@ -22,7 +22,7 @@ import Logs.Location import Logs.Trust import Logs.Activity-import Logs.TimeStamp+import Utility.TimeStamp import Logs.PreferredContent import Annex.NumCopies import Annex.UUID

@@ -13,9 +13,7 @@ import qualified Data.Map.Strict as M import qualified Data.Vector as V import Data.Ord-#if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Sem-#endif import Prelude  import Command@@ -60,26 +58,18 @@ 	, backendsKeys :: M.Map KeyVariety Integer 	} 	-appendKeyData :: KeyData -> KeyData -> KeyData-appendKeyData a b = KeyData-	{ countKeys = countKeys a + countKeys b-	, sizeKeys = sizeKeys a + sizeKeys b-	, unknownSizeKeys = unknownSizeKeys a + unknownSizeKeys b-	, backendsKeys = backendsKeys a <> backendsKeys b-	}-	-#if MIN_VERSION_base(4,9,0) instance Sem.Semigroup KeyData where-	(<>) = appendKeyData-#endif+	a <> b = KeyData+		{ countKeys = countKeys a + countKeys b+		, sizeKeys = sizeKeys a + sizeKeys b+		, unknownSizeKeys = unknownSizeKeys a + unknownSizeKeys b+		, backendsKeys = backendsKeys a <> backendsKeys b+		}  instance Monoid KeyData where 	mempty = KeyData 0 0 0 M.empty-#if MIN_VERSION_base(4,11,0)-#elif MIN_VERSION_base(4,9,0)+#if ! MIN_VERSION_base(4,11,0) 	mappend = (Sem.<>)-#else-	mappend = appendKeyData #endif  data NumCopiesStats = NumCopiesStats

@@ -10,7 +10,10 @@ import Command import Annex.Init import Annex.Version+import Types.RepoVersion import qualified Annex.SpecialRemote++import qualified Data.Map as M 	 cmd :: Command cmd = dontCheck repoExists $@@ -19,21 +22,25 @@  data InitOptions = InitOptions 	{ initDesc :: String-	, initVersion :: Maybe Version+	, initVersion :: Maybe RepoVersion 	}  optParser :: CmdParamsDesc -> Parser InitOptions optParser desc = InitOptions 	<$> (unwords <$> cmdParams desc)-	<*> optional (option (str >>= parseVersion)+	<*> optional (option (str >>= parseRepoVersion) 		( long "version" <> metavar paramValue 		<> help "Override default annex.version" 		)) -parseVersion :: Monad m => String -> m Version-parseVersion v-	| v `elem` supportedVersions = return v-	| otherwise = fail $ v ++ " is not a currently supported repository version"+parseRepoVersion :: Monad m => String -> m RepoVersion+parseRepoVersion s = case RepoVersion <$> readish s of+	Nothing -> fail $ "version parse error"+	Just v+		| v `elem` supportedVersions -> return v+		| otherwise -> case M.lookup v autoUpgradeableVersions of+			Just v' -> return v'+			Nothing -> fail $ s ++ " is not a currently supported repository version"  seek :: InitOptions -> CommandSeek seek = commandAction . start

@@ -9,7 +9,8 @@  import Command import qualified Annex.Branch-import Command.Sync (prepMerge, mergeLocal, getCurrBranch, mergeConfig)+import Annex.CurrentBranch+import Command.Sync (prepMerge, mergeLocal, mergeConfig)  cmd :: Command cmd = command "merge" SectionMaintenance@@ -33,4 +34,4 @@ mergeSynced :: CommandStart mergeSynced = do 	prepMerge-	mergeLocal mergeConfig def =<< join getCurrBranch+	mergeLocal mergeConfig def =<< getCurrentBranch

@@ -80,20 +80,20 @@ 			forM_ urls $ \url -> 				setUrlPresent newkey url 			next $ Command.ReKey.cleanup file oldkey newkey-		, error "failed"+		, giveup "failed creating link from old to new key" 		)-	genkey Nothing = return Nothing+	genkey Nothing = do+		content <- calcRepo $ gitAnnexLocation oldkey+		let source = KeySource+			{ keyFilename = file+			, contentLocation = content+			, inodeCache = Nothing+			}+		v <- genKey source (Just newbackend)+		return $ case v of+			Just (newkey, _) -> Just (newkey, False)+			_ -> Nothing 	genkey (Just fm) = fm oldkey newbackend afile >>= \case-		Just newkey -> return $ Just (newkey, True)-		Nothing -> do-			content <- calcRepo $ gitAnnexLocation oldkey-			let source = KeySource-				{ keyFilename = file-				, contentLocation = content-				, inodeCache = Nothing-				}-			v <- genKey source (Just newbackend)-			return $ case v of-				Just (newkey, _) -> Just (newkey, False)-				_ -> Nothing+		Just newkey -> return (Just (newkey, True))+		Nothing -> genkey Nothing 	afile = AssociatedFile (Just file)

@@ -11,7 +11,8 @@ import qualified Annex import Git.Types import Annex.UpdateInstead-import Command.Sync (mergeLocal, prepMerge, mergeConfig, getCurrBranch)+import Annex.CurrentBranch+import Command.Sync (mergeLocal, prepMerge, mergeConfig)  -- This does not need to modify the git-annex branch to update the  -- work tree, but auto-initialization might change the git-annex branch.@@ -48,4 +49,4 @@ updateInsteadEmulation :: CommandStart updateInsteadEmulation = do 	prepMerge-	mergeLocal mergeConfig def =<< join getCurrBranch+	mergeLocal mergeConfig def =<< getCurrentBranch

@@ -13,6 +13,7 @@ import Config import qualified Command.Add import qualified Command.Fix+import qualified Command.Smudge import Annex.Direct import Annex.Hook import Annex.Link@@ -54,11 +55,21 @@ 				flip withFilesToBeCommitted l $ \f -> commandAction $ 					maybe stop (Command.Fix.start Command.Fix.FixSymlinks f) 						=<< isAnnexLink f-				-- inject unlocked files into the annex-				-- (not needed when repo version uses-				-- unlocked pointer files)-				unlessM versionSupportsUnlockedPointers $-					withFilesOldUnlockedToBeCommitted (commandAction . startInjectUnlocked) l+				ifM versionSupportsUnlockedPointers+					-- after a merge conflict or git+					-- cherry-pick or stash, pointer+					-- files in the worktree won't+					-- be populated, so populate them+					-- here+					( Command.Smudge.updateSmudged +						-- When there's a false index,+						-- restaging the files won't work.+						. Restage =<< liftIO Git.haveFalseIndex+					-- inject unlocked files into the annex+					-- (not needed when repo version uses+					-- unlocked pointer files)+					, withFilesOldUnlockedToBeCommitted (commandAction . startInjectUnlocked) l+					) 			) 		runAnnexHook preCommitAnnexHook 		-- committing changes to a view updates metadata

@@ -68,7 +68,7 @@ perform file oldkey newkey = do 	ifM (inAnnex oldkey)  		( unlessM (linkKey file oldkey newkey) $-			giveup "failed"+			giveup "failed creating link from old to new key" 		, unlessM (Annex.getState Annex.force) $ 			giveup $ file ++ " is not available (use --force to override)" 		)@@ -87,18 +87,18 @@ 		oldobj <- calcRepo (gitAnnexLocation oldkey) 		isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing 	, do-		ic <- withTSDelta (liftIO . genInodeCache file)-	 	{- The file being rekeyed is itself an unlocked file, so if-		 - it's linked to the old key, that link must be broken. -}+	 	{- The file being rekeyed is itself an unlocked file; if+		 - it's hard linked to the old key, that link must be broken. -} 		oldobj <- calcRepo (gitAnnexLocation oldkey)-		v <- tryNonAsync $ modifyContent oldobj $ do-			replaceFile oldobj $ \tmp ->-				unlessM (checkedCopyFile oldkey file tmp Nothing) $-					error "can't lock old key"-			freezeContent oldobj-			oldic <- withTSDelta (liftIO . genInodeCache oldobj)-			whenM (isUnmodified oldkey oldobj) $-				Database.Keys.addInodeCaches oldkey (catMaybes [oldic])+		v <- tryNonAsync $ do+			st <- liftIO $ getFileStatus file+			when (linkCount st > 1) $ do+				freezeContent oldobj+				replaceFile file $ \tmp -> do+					unlessM (checkedCopyFile oldkey oldobj tmp Nothing) $+						error "can't lock old key"+					thawContent tmp+		ic <- withTSDelta (liftIO . genInodeCache file) 		case v of 			Left e -> do 				warning (show e)

@@ -8,12 +8,12 @@ module Command.Smudge where  import Command-import qualified Annex import Annex.Content import Annex.Link import Annex.FileMatcher import Annex.Ingest import Annex.CatFile+import Logs.Smudge import Logs.Location import qualified Database.Keys import qualified Git.BuildVersion@@ -29,43 +29,46 @@ 		"git smudge filter" 		paramFile (seek <$$> optParser) -data SmudgeOptions = SmudgeOptions+data SmudgeOptions = UpdateOption | SmudgeOptions 	{ smudgeFile :: FilePath 	, cleanOption :: Bool 	}  optParser :: CmdParamsDesc -> Parser SmudgeOptions-optParser desc = SmudgeOptions-	<$> argument str ( metavar desc )-	<*> switch ( long "clean" <> help "clean filter" )+optParser desc = smudgeoptions <|> updateoption+  where+	smudgeoptions = SmudgeOptions+		<$> argument str ( metavar desc )+		<*> switch ( long "clean" <> help "clean filter" )+	updateoption = flag' UpdateOption+		( long "update" <> help "populate annexed worktree files" )  seek :: SmudgeOptions -> CommandSeek-seek o = commandAction $-	(if cleanOption o then clean else smudge) (smudgeFile o)+seek (SmudgeOptions f False) = commandAction (smudge f)+seek (SmudgeOptions f True) = commandAction (clean f)+seek UpdateOption = commandAction update  -- Smudge filter is fed git file content, and if it's a pointer to an--- available annex object, should output its content.+-- available annex object, git expects it to output its content.+--+-- However, this does not do that. It outputs the pointer, and records+-- the filename in the smudge log. Git hooks run after commands like checkout+-- then run git annex smudge --update which populates the work tree files+-- with annex content. This is done for several reasons:+--+-- * To support annex.thin+-- * Because git currently buffers the whole object received from the+--   smudge filter in memory, which is a problem with large files. smudge :: FilePath -> CommandStart smudge file = do 	b <- liftIO $ B.hGetContents stdin 	case parseLinkOrPointer b of-		Nothing -> liftIO $ B.putStr b+		Nothing -> noop 		Just k -> do-			Database.Keys.addAssociatedFile k =<< inRepo (toTopFilePath file)-			-- A previous unlocked checkout of the file may have-			-- led to the annex object getting modified;-			-- don't provide such modified content as it-			-- will be confusing. inAnnex will detect such-			-- modifications.-			ifM (inAnnex k)-				( do-					content <- calcRepo (gitAnnexLocation k)-					whenM (annexThin <$> Annex.getGitConfig) $-						warning $ "Not able to honor annex.thin when git is checking out " ++ file ++ " (run git annex fix to re-thin files)"-					liftIO $ B.putStr . fromMaybe b-						=<< catchMaybeIO (B.readFile content)-				, liftIO $ B.putStr b-				)+			topfile <- inRepo (toTopFilePath file)+			Database.Keys.addAssociatedFile k topfile+			void $ smudgeLog k topfile+	liftIO $ B.putStr b 	stop  -- Clean filter is fed file content on stdin, decides if a file@@ -92,19 +95,30 @@ 			if Git.BuildVersion.older "2.5" 				then B.length b `seq` return () 				else liftIO $ hClose stdin-			-- Look up the backend that was used for this file-			-- before, so that when git re-cleans a file its-			-- backend does not change.-			let oldbackend = maybe Nothing (maybeLookupBackendVariety . keyVariety) oldkey-			-- Can't restage associated files because git add-			-- runs this and has the index locked.-			let norestage = Restage False-			liftIO . emitPointer-				=<< postingest-				=<< (\ld -> ingest' oldbackend ld Nothing norestage)-				=<< lockDown cfg file++			-- Optimization for the case when the file is already+			-- annexed and is unmodified.+			case oldkey of+				Nothing -> doingest oldkey+				Just ko -> ifM (isUnmodifiedCheap ko file)+					( liftIO $ emitPointer ko+					, doingest oldkey+					) 		, liftIO $ B.hPut stdout b 		)+	+	doingest oldkey = do+		-- Look up the backend that was used for this file+		-- before, so that when git re-cleans a file its+		-- backend does not change.+		let oldbackend = maybe Nothing (maybeLookupBackendVariety . keyVariety) oldkey+		-- Can't restage associated files because git add+		-- runs this and has the index locked.+		let norestage = Restage False+		liftIO . emitPointer+			=<< postingest+			=<< (\ld -> ingest' oldbackend ld Nothing norestage)+			=<< lockDown cfg file  	postingest (Just k, _) = do 		logStatus k InfoPresent@@ -144,11 +158,26 @@ -- the pointer copy. It will then be populated with the content. getMoveRaceRecovery :: Key -> FilePath -> Annex () getMoveRaceRecovery k file = void $ tryNonAsync $-	liftIO (isPointerFile file) >>= \k' -> when (Just k == k') $-		whenM (inAnnex k) $ do-			obj <- calcRepo (gitAnnexLocation k)-			-- Cannot restage because git add is running and has-			-- the index locked.-			populatePointerFile (Restage False) k obj file >>= \case-				Nothing -> return ()-				Just ic -> Database.Keys.addInodeCaches k [ic]+	whenM (inAnnex k) $ do+		obj <- calcRepo (gitAnnexLocation k)+		-- Cannot restage because git add is running and has+		-- the index locked.+		populatePointerFile (Restage False) k obj file >>= \case+			Nothing -> return ()+			Just ic -> Database.Keys.addInodeCaches k [ic]++update :: CommandStart+update = do+	updateSmudged (Restage True)+	stop++updateSmudged :: Restage -> Annex ()+updateSmudged restage = streamSmudged $ \k topf -> do+	f <- fromRepo $ fromTopFilePath topf+	whenM (inAnnex k) $ do+		obj <- calcRepo (gitAnnexLocation k)+		unlessM (isJust <$> populatePointerFile restage k obj f) $+			liftIO (isPointerFile f) >>= \case+				Just k' | k' == k -> toplevelWarning False $+					"unable to populate worktree file " ++ f+				_ -> noop

@@ -9,7 +9,6 @@ module Command.Sync ( 	cmd, 	CurrBranch,-	getCurrBranch, 	mergeConfig, 	merge, 	prepMerge,@@ -20,7 +19,7 @@ 	pushBranch, 	updateBranch, 	syncBranch,-	updateSyncBranch,+	updateBranches, 	seekExportContent, ) where @@ -60,6 +59,7 @@ import Annex.Export import Annex.LockFile import Annex.TaggedPush+import Annex.CurrentBranch import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse@@ -162,8 +162,7 @@ seek o = allowConcurrentOutput $ do 	prepMerge -	getbranch <- getCurrBranch -	let withbranch a = a =<< getbranch+	let withbranch a = a =<< getCurrentBranch  	remotes <- syncRemotes (syncWith o) 	let gitremotes = filter Remote.gitSyncableRemote remotes@@ -188,7 +187,7 @@ 				] 			 			whenM shouldsynccontent $ do-				syncedcontent <- seekSyncContent o dataremotes+				syncedcontent <- withbranch $ seekSyncContent o dataremotes 				exportedcontent <- withbranch $ seekExportContent exportremotes 				-- Transferring content can take a while, 				-- and other changes can be pushed to the@@ -209,35 +208,6 @@ 		<||> pure (not (null (contentOfOption o))) 		<||> (pure (not (noContentOption o)) <&&> getGitConfigVal annexSyncContent) -type CurrBranch = (Maybe Git.Branch, Maybe Adjustment)--{- There may not be a branch checked out until after the commit,- - or perhaps after it gets merged from the remote, or perhaps- - never.- -- - So only look it up once it's needed, and once there is a- - branch, cache it.- -- - When on an adjusted branch, gets the original branch, and the adjustment.- -}-getCurrBranch :: Annex (Annex CurrBranch)-getCurrBranch = do-	mvar <- liftIO newEmptyMVar-	return $ ifM (liftIO $ isEmptyMVar mvar)-		( do-			currbranch <- inRepo Git.Branch.current-			case currbranch of-				Nothing -> return (Nothing, Nothing)-				Just b -> do-					let v = case adjustedToOriginal b of-						Nothing -> (Just b, Nothing)-						Just (adj, origbranch) ->-							(Just origbranch, Just adj)-					liftIO $ putMVar mvar v-					return v-		, liftIO $ readMVar mvar-		)- {- Merging may delete the current directory, so go to the top  - of the repo. This also means that sync always acts on all files in the  - repository, not just on a subdirectory. -}@@ -257,7 +227,7 @@  merge :: CurrBranch -> [Git.Merge.MergeConfig] -> ResolveMergeOverride -> Git.Branch.CommitMode -> Git.Branch -> Annex Bool merge currbranch mergeconfig resolvemergeoverride commitmode tomerge = case currbranch of-	(Just b, Just adj) -> updateAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode+	(Just b, Just adj) -> mergeToAdjustedBranch tomerge (b, adj) mergeconfig canresolvemerge commitmode 	(b, _) -> autoMergeFrom tomerge b mergeconfig canresolvemerge commitmode   where 	canresolvemerge = case resolvemergeoverride of@@ -372,17 +342,29 @@  pushLocal :: CurrBranch -> CommandStart pushLocal b = do-	updateSyncBranch b+	updateBranches b 	stop -updateSyncBranch :: CurrBranch -> Annex ()-updateSyncBranch (Nothing, _) = noop-updateSyncBranch (Just branch, madj) = do+updateBranches :: CurrBranch -> Annex ()+updateBranches (Nothing, _) = noop+updateBranches (Just branch, madj) = do 	-- When in an adjusted branch, propigate any changes made to it-	-- back to the original branch.-	maybe noop (propigateAdjustedCommits branch) madj+	-- back to the original branch. The adjusted branch may also need+	-- to be updated to hide/expose files.+	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." ]+					 	-- Update the sync branch to match the new state of the branch 	inRepo $ updateBranch (syncBranch branch) branch+ 	-- In direct mode, we're operating on some special direct mode 	-- branch, rather than the intended branch, so update the intended 	-- branch.@@ -568,8 +550,11 @@ 		, return True 		) -{- Without --all, only looks at files in the work tree. With --all,- - makes 2 passes, first looking at the work tree and then all keys.+{- Without --all, only looks at files in the work tree.+ - (Or, when in an ajusted branch where some files are hidden, at files in+ - the original branch.)+ -+ - With --all, makes a second pass over all keys.  - This ensures that preferred content expressions that match on  - filenames work, even when in --all mode.  -@@ -577,25 +562,42 @@  -  - When concurrency is enabled, files are processed concurrently.  -}-seekSyncContent :: SyncOptions -> [Remote] -> Annex Bool-seekSyncContent o rs = do+seekSyncContent :: SyncOptions -> [Remote] -> CurrBranch -> Annex Bool+seekSyncContent o rs currbranch = do 	mvar <- liftIO newEmptyMVar 	bloom <- case keyOptions o of 		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar [])-		_ -> do-			l <- workTreeItems (contentOfOption o)-			seekworktree mvar l (const noop)-			pure Nothing+		_ -> case currbranch of+                	(Just origbranch, Just adj) | adjustmentHidesFiles adj -> do+				l <- workTreeItems' (AllowHidden True) (contentOfOption o)+				seekincludinghidden origbranch mvar l (const noop)+				pure Nothing+			_ -> do+				l <- workTreeItems (contentOfOption o)+				seekworktree mvar l (const noop)+				pure Nothing 	withKeyOptions' (keyOptions o) False-		(return (seekkeys mvar bloom))+		(return (gokey mvar bloom)) 		(const noop) 		[] 	finishCommandActions 	liftIO $ not <$> isEmptyMVar mvar   where-	seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>=-		mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (AssociatedFile (Just f))) noop)-	seekkeys mvar bloom (k, _) = go (Left bloom) mvar (AssociatedFile Nothing) k+	seekworktree mvar l bloomfeeder = +		seekHelper LsFiles.inRepo l+			>>= gofiles bloomfeeder mvar++	seekincludinghidden origbranch mvar l bloomfeeder = +		seekHelper (LsFiles.inRepoOrBranch origbranch) l +			>>= gofiles bloomfeeder mvar++	gofiles bloomfeeder mvar = mapM_ $ \f ->+		ifAnnexed f+			(go (Right bloomfeeder) mvar (AssociatedFile (Just f)))+			noop+	+	gokey mvar bloom (k, _) = go (Left bloom) mvar (AssociatedFile Nothing) k+ 	go ebloom mvar af k = commandAction $ do 		whenM (syncFile ebloom rs af k) $ 			void $ liftIO $ tryPutMVar mvar ()

@@ -12,6 +12,7 @@ import BuildInfo import BuildFlags import Types.Key+import Types.RepoVersion import qualified Types.Backend as B import qualified Types.Remote as R import qualified Remote@@ -49,7 +50,7 @@ showVersion :: Annex () showVersion = do 	liftIO showPackageVersion-	maybe noop (liftIO . vinfo "local repository version")+	maybe noop (liftIO . vinfo "local repository version" . showRepoVersion) 		=<< getVersion  showPackageVersion :: IO ()@@ -62,9 +63,14 @@ 	vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes 	vinfo "operating system" $ unwords [os, arch] 	vinfo "supported repository versions" $-		unwords supportedVersions+		verlist supportedVersions 	vinfo "upgrade supported from repository versions" $-		unwords upgradableVersions+		verlist upgradableVersions+  where+	verlist = unwords . map showRepoVersion++showRepoVersion :: RepoVersion -> String+showRepoVersion = show  . fromRepoVersion  showRawVersion :: IO () showRawVersion = do

@@ -19,9 +19,6 @@ import Annex.Environment import Utility.WebApp import Utility.Daemon (checkDaemon)-#ifdef __ANDROID__-import Utility.Env-#endif import Utility.UserInfo import Annex.Init import qualified Git@@ -188,18 +185,7 @@ 			Annex.eval state $ 				startDaemon True True Nothing Nothing (listenAddress o) $ Just $ 					sendurlback v-	sendurlback v _origout _origerr url _htmlshim = do-		recordUrl url-		putMVar v url--recordUrl :: String -> IO ()-#ifdef __ANDROID__-{- The Android app has a menu item that opens the url recorded- - in this file. -}-recordUrl url = writeFile "/sdcard/git-annex.home/.git-annex-url" url-#else-recordUrl _ = noop-#endif+	sendurlback v _origout _origerr url _htmlshim = putMVar v url  openBrowser :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO () openBrowser mcmd htmlshim realurl outh errh = do@@ -207,7 +193,6 @@ 	openBrowser' mcmd htmlshim' realurl outh errh  openBrowser' :: Maybe FilePath -> FilePath -> String -> Maybe Handle -> Maybe Handle -> IO ()-#ifndef __ANDROID__ openBrowser' mcmd htmlshim realurl outh errh = 	ifM osAndroid 		{- Android does not support file:// urls well, but neither@@ -216,20 +201,6 @@ 		( runbrowser realurl 		, runbrowser (fileUrl htmlshim) 		)-#else-openBrowser' mcmd htmlshim realurl outh errh = do-	recordUrl realurl-	{- Android's `am` command does not work reliably across the-	 - wide range of Android devices. Intead, FIFO should be set to -	 - the filename of a fifo that we can write the URL to. -}-	v <- getEnv "FIFO"-	case v of-		Nothing -> runbrowser realurl-		Just f -> void $ forkIO $ do-			fd <- openFd f WriteOnly Nothing defaultFileFlags-			void $ fdWrite fd realurl-			closeFd fd-#endif   where 	runbrowser url = do 		let p = case mcmd of

@@ -1,6 +1,6 @@ {- Persistent sqlite database handles.  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -31,7 +31,6 @@ import qualified Data.Text as T import Control.Monad.Trans.Resource (runResourceT) import Control.Monad.Logger (runNoLoggingT)-import Data.List import System.IO  {- A DbHandle is a reference to a worker thread that communicates with@@ -43,12 +42,8 @@  {- Sqlite only allows a single write to a database at a time; a concurrent  - write will crash. - -- - While a DbHandle serializes concurrent writes from- - multiple threads. But, when a database can be written to by- - multiple processes concurrently, use MultiWriter to make writes- - to the database be done robustly.  - + - MultiWrter works around this limitation.  - The downside of using MultiWriter is that after writing a change to the  - database, the a query using the same DbHandle will not immediately see  - the change! This is because the change is actually written using a@@ -57,9 +52,10 @@  - you can't rely on seeing values you've just written anyway, as another  - process may change them.  -- - When a database can only be written to by a single process, use- - SingleWriter. Changes written to the database will always be immediately- - visible then.+ - When a database can only be written to by a single process (enforced by+ - a lock file), use SingleWriter. Changes written to the database will+ - always be immediately visible then. Multiple threads can write; their+ - writes will be serialized.  -} data DbConcurrency = SingleWriter | MultiWriter @@ -105,9 +101,10 @@  {- Writes a change to the database.  -- - In MultiWriter mode, catches failure to write to the database,- - and retries repeatedly for up to 10 seconds,  which should avoid- - all but the most exceptional problems.+ - In MultiWriter mode, writes can fail if another write is happening+ - concurrently. So write failures are caught and retried repeatedly+ - for up to 10 seconds, which should avoid all but the most exceptional+ - problems.  -} commitDb :: DbHandle -> SqlPersistM () -> IO () commitDb h wa = robustly Nothing 100 (commitDb' h wa)@@ -177,33 +174,68 @@ 				liftIO (a (runSqliteRobustly tablename db)) 				loop 	--- like runSqlite, but calls settle on the raw sql Connection.+-- Like runSqlite, but more robust.+--+-- New database connections can sometimes take a while to become usable.+-- This may be due to WAL mode recovering after a crash, or perhaps a bug+-- like described in blob 500f777a6ab6c45ca5f9790e0a63575f8e3cb88f.+-- So, loop until a select succeeds; once one succeeds the connection will+-- stay usable.+--+-- And sqlite sometimes throws ErrorIO when there's not really an IO problem,+-- but perhaps just a short read(). That's caught and retried several times. runSqliteRobustly :: TableName -> T.Text -> (SqlPersistM a) -> IO a runSqliteRobustly tablename db a = do-	conn <- Sqlite.open db-	settle conn-	runResourceT $ runNoLoggingT $-		withSqlConn (wrapConnection conn) $-			runSqlConn a+	conn <- opensettle maxretries+	go conn maxretries   where-	-- Work around a bug in sqlite: New database connections can-	-- sometimes take a while to become usable; select statements will-	-- fail with ErrorBusy for some time. So, loop until a select-	-- succeeds; once one succeeds the connection will stay usable.-	-- <http://thread.gmane.org/gmane.comp.db.sqlite.general/93116>-	settle conn = do-		r <- tryNonAsync $ do+	maxretries = 100 :: Int+	+	rethrow msg e = throwIO $ userError $ show e ++ "(" ++ msg ++ ")"+	+	go conn retries = do+		r <- try $ runResourceT $ runNoLoggingT $+			withSqlConn (wrapConnection conn) $+				runSqlConn a+		case r of+			Right v -> return v+			Left ex@(Sqlite.SqliteException { Sqlite.seError = e })+				| e == Sqlite.ErrorIO ->+					let retries' = retries - 1+					in if retries' < 1+						then rethrow "after successful open" ex+						else go conn retries'+				| otherwise -> rethrow "after successful open" ex+	+	opensettle retries = do+		conn <- Sqlite.open db+		settle conn retries++	settle conn retries = do+		r <- try $ do 			stmt <- Sqlite.prepare conn nullselect 			void $ Sqlite.step stmt 			void $ Sqlite.finalize stmt 		case r of-			Right _ -> return ()-			Left e -> do-				if "ErrorBusy" `isInfixOf` show e-					then do-						threadDelay 1000 -- 1/1000th second-						settle conn-					else throwIO e+			Right _ -> return conn+			Left ex@(Sqlite.SqliteException { Sqlite.seError = e })+				| e == Sqlite.ErrorBusy -> do+					-- Wait and retry any number of times; it +					-- will stop being busy eventually.+					briefdelay+					settle conn retries+				| e == Sqlite.ErrorIO -> do+					-- Could be a real IO error,+					-- so don't retry indefinitely.+					Sqlite.close conn+					briefdelay+					let retries' = retries - 1+					if retries' < 1+						then rethrow "while opening database connection" ex+						else opensettle retries'+				| otherwise -> rethrow "while opening database connection" ex 	 	-- This should succeed for any table. 	nullselect = T.pack $ "SELECT null from " ++ tablename ++ " limit 1"++	briefdelay = threadDelay 1000 -- 1/1000th second

@@ -1,6 +1,6 @@ {- Persistent sqlite database initialization  -- - Copyright 2015-2017 Joey Hess <id@joeyh.name>+ - Copyright 2015-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -12,16 +12,13 @@ import Utility.FileMode  import Database.Persist.Sqlite-import qualified Database.Sqlite as Sqlite import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T+import Lens.Micro  {- Ensures that the database is freshly initialized. Deletes any  - existing database. Pass the migration action for the database.  -- - The database is initialized using WAL mode, to prevent readers- - from blocking writers, and prevent a writer from blocking readers.- -  - The permissions of the database are set based on the  - core.sharedRepository setting. Setting these permissions on the main db  - file causes Sqlite to always use the same permissions for additional@@ -34,9 +31,7 @@ 	let tmpdb = tmpdbdir </> "db" 	liftIO $ do 		createDirectoryIfMissing True tmpdbdir-		let tdb = T.pack tmpdb-		enableWAL tdb-		runSqlite tdb migration+		runSqliteInfo (mkConnInfo tmpdb) migration 	setAnnexDirPerm tmpdbdir 	-- Work around sqlite bug that prevents it from honoring 	-- less restrictive umasks.@@ -46,10 +41,14 @@ 		void $ tryIO $ removeDirectoryRecursive dbdir 		rename tmpdbdir dbdir -enableWAL :: T.Text -> IO ()-enableWAL db = do-	conn <- Sqlite.open db-	stmt <- Sqlite.prepare conn (T.pack "PRAGMA journal_mode=WAL;")-	void $ Sqlite.step stmt-	void $ Sqlite.finalize stmt-	Sqlite.close conn+{- Make sure that the database uses WAL mode, to prevent readers+ - from blocking writers, and prevent a writer from blocking readers.+ -+ - This is the default in persistent-sqlite currently, but force it on just+ - in case. + -+ - Note that once WAL mode is enabled, it will persist whenever the+ - database is opened. -}+mkConnInfo :: FilePath -> SqliteConnectionInfo+mkConnInfo db = over walEnabled (const True) $ +	mkSqliteConnectionInfo (T.pack db)

@@ -151,7 +151,9 @@  - data to it.  -} closeDb :: Annex ()-closeDb = liftIO . closeDbHandle =<< getDbHandle+closeDb = Annex.getState Annex.keysdbhandle >>= \case+	Nothing -> return ()+	Just h -> liftIO (closeDbHandle h)  addAssociatedFile :: Key -> TopFilePath -> Annex () addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile (toIKey k) f

@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Git.Env where  import Common@@ -18,27 +16,10 @@  - does not have any gitEnv yet. -} adjustGitEnv :: Repo -> ([(String, String)] -> [(String, String)]) -> IO Repo adjustGitEnv g adj = do-	e <- maybe copyGitEnv return (gitEnv g)+	e <- maybe getEnvironment return (gitEnv g) 	let e' = adj e 	return $ g { gitEnv = Just e' }   where--{- Copies the current environment, so it can be adjusted when running a git- - command. -}-copyGitEnv :: IO [(String, String)]-copyGitEnv = do-#ifdef __ANDROID__-	{- This should not be necessary on Android, but there is some-	 - weird getEnvironment breakage. See-	 - https://github.com/neurocyte/ghc-android/issues/7-	 - Use getEnv to get some key environment variables that-	 - git expects to have. -}-	let keyenv = words "USER PATH GIT_EXEC_PATH HOSTNAME HOME"-	let getEnvPair k = maybe Nothing (\v -> Just (k, v)) <$> getEnv k-	catMaybes <$> forM keyenv getEnvPair-#else-	getEnvironment-#endif  addGitEnv :: Repo -> String -> String -> IO Repo addGitEnv g var val = adjustGitEnv g (addEntry var val)

@@ -26,9 +26,7 @@  import qualified Data.Set as S import Control.Concurrent.Async-#if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Sem-#endif import Prelude  data FsckResults @@ -58,18 +56,13 @@ appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning -#if MIN_VERSION_base(4,9,0) instance Sem.Semigroup FsckOutput where 	(<>) = appendFsckOutput-#endif  instance Monoid FsckOutput where 	mempty = NoFsckOutput-#if MIN_VERSION_base(4,11,0)-#elif MIN_VERSION_base(4,9,0)+#if ! MIN_VERSION_base(4,11,0) 	mappend = (Sem.<>)-#else-	mappend = appendFsckOutput #endif  {- Runs fsck to find some of the broken objects in the repository.

@@ -7,6 +7,7 @@  module Git.LsFiles ( 	inRepo,+	inRepoOrBranch, 	notInRepo, 	notInRepoIncludingEmptyDirectories, 	allFiles,@@ -34,14 +35,22 @@ import Numeric import System.Posix.Types -{- Scans for files that are checked into git at the specified locations. -}+{- Scans for files that are checked into git's index at the specified locations. -} inRepo :: [FilePath] -> Repo -> IO ([FilePath], IO Bool)-inRepo l = pipeNullSplit $ +inRepo = inRepo' [] ++inRepo' :: [CommandParam] -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)+inRepo' ps l = pipeNullSplit $  	Param "ls-files" : 	Param "--cached" : 	Param "-z" :-	Param "--" :-	map File l+	ps +++	(Param "--" : map File l)++{- Files that are checked into the index or have been committed to a+ - branch. -}+inRepoOrBranch :: Branch -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)+inRepoOrBranch (Ref b) = inRepo' [Param $ "--with-tree=" ++ b]  {- Scans for files at the specified locations that are not checked into git. -} notInRepo :: Bool -> [FilePath] -> Repo -> IO ([FilePath], IO Bool)

@@ -2,26 +2,59 @@  -  - Copyright 2018 Joey Hess <id@joeyh.name>  -- - Licensed under the GNU GPL version 3 or higher.+ - Licensed under the GNU AGPL version 3 or higher.  -} -module Logs.File where+module Logs.File (writeLogFile, appendLogFile, streamLogFile) where  import Annex.Common import Annex.Perms+import Annex.LockFile+import qualified Git import Utility.Tmp  -- | Writes content to a file, replacing the file atomically, and -- making the new file have whatever permissions the git repository is -- configured to use. Creates the parent directory when necessary. writeLogFile :: FilePath -> String -> Annex ()-writeLogFile f c = go `catchNonAsync` \_e -> do-	-- Most of the time, the directory will exist, so this is only-	-- done if writing the file fails.-	createAnnexDirectory (parentDir f)-	go+writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c   where-	go = viaTmp writelog f c 	writelog f' c' = do 		liftIO $ writeFile f' c' 		setAnnexFilePerm f'++-- | Appends a line to a log file, first locking it to prevent+-- concurrent writers.+appendLogFile :: FilePath -> (Git.Repo -> FilePath) -> String -> Annex ()+appendLogFile f lck c = createDirWhenNeeded f $ withExclusiveLock lck $ do+	liftIO $ withFile f AppendMode $ \h -> hPutStrLn h c+	setAnnexFilePerm f++-- | Streams lines from a log file, and then empties the file at the end.+--+-- If the action is interrupted or throws an exception, the log file is+-- left unchanged.+--+-- Does nothing if the log file does not exist.+-- +-- Locking is used to prevent writes to to the log file while this+-- is running.+streamLogFile :: FilePath -> (Git.Repo -> FilePath) -> (String -> Annex ()) -> Annex ()+streamLogFile f lck a = withExclusiveLock lck $ bracketOnError setup cleanup go+  where+	setup = liftIO $ tryWhenExists $ openFile f ReadMode +	cleanup Nothing = noop+	cleanup (Just h) = liftIO $ hClose h+	go Nothing = noop+	go (Just h) = do+		mapM_ a =<< liftIO (lines <$> hGetContents h)+		liftIO $ hClose h+		liftIO $ writeFile f ""+		setAnnexFilePerm f++createDirWhenNeeded :: FilePath -> Annex () -> Annex ()+createDirWhenNeeded f a = a `catchNonAsync` \_e -> do+	-- Most of the time, the directory will exist, so this is only+	-- done if writing the file fails.+	createAnnexDirectory (parentDir f)+	a

@@ -40,7 +40,7 @@ import qualified Annex.Branch import qualified Annex import Logs-import Logs.TimeStamp+import Utility.TimeStamp import Logs.MetaData.Pure  import qualified Data.Set as S

@@ -0,0 +1,40 @@+{- git-annex smudge log file+ -+ - Copyright 2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Logs.Smudge where++import Annex.Common+import Git.FilePath+import Logs.File++-- | Log a smudged file.+smudgeLog :: Key -> TopFilePath -> Annex ()+smudgeLog k f = do+	logf <- fromRepo gitAnnexSmudgeLog+	appendLogFile logf gitAnnexSmudgeLock $ +		key2file k ++ " " ++ getTopFilePath f++-- | Streams all smudged files, and then empties the log at the end.+--+-- If the action is interrupted or throws an exception, the log file is+-- left unchanged.+--+-- Locking is used to prevent new items being added to the log while this+-- is running.+streamSmudged :: (Key -> TopFilePath -> Annex ()) -> Annex ()+streamSmudged a = do+	logf <- fromRepo gitAnnexSmudgeLog+	streamLogFile logf gitAnnexSmudgeLock $ \l -> +		case parse l of+			Nothing -> noop+			Just (k, f) -> a k f+  where+	parse l = +		let (ks, f) = separate (== ' ') l+		in do+			k <- file2key ks+			return (k, asTopFilePath f)

@@ -1,39 +0,0 @@-{- log timestamp parsing- -- - Copyright 2015-2016 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--{-# LANGUAGE CPP #-}--module Logs.TimeStamp where--import Utility.PartialPrelude-import Utility.Misc--import Data.Time.Clock.POSIX-import Data.Time-import Data.Ratio-#if ! MIN_VERSION_time(1,5,0)-import System.Locale-#endif--{- Parses how POSIXTime shows itself: "1431286201.113452s"- - Also handles the format with no fractional seconds. -}-parsePOSIXTime :: String -> Maybe POSIXTime-parsePOSIXTime s = do-	let (sn, sd) = separate (== '.') s-	n <- readi sn-	if null sd -		then return (fromIntegral n)-		else do-			d <- readi sd-			let r = d % (10 ^ (length sd - 1))-			return (fromIntegral n + fromRational r)-  where-	readi :: String -> Maybe Integer-	readi = readish--formatPOSIXTime :: String -> POSIXTime -> String-formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)

@@ -18,7 +18,7 @@ import Utility.Percentage import Utility.PID import Annex.LockPool-import Logs.TimeStamp+import Utility.TimeStamp import Logs.File  import Data.Time.Clock

@@ -33,7 +33,7 @@  import Annex.Common import qualified Annex-import Logs.TimeStamp+import Utility.TimeStamp import Logs.File  -- everything that is stored in the unused log

@@ -16,6 +16,7 @@ 	showSideAction, 	doSideAction, 	doQuietSideAction,+	doQuietAction, 	showStoringStateAction, 	showOutput, 	showLongNote,@@ -111,11 +112,27 @@ doSideAction = doSideAction' StartBlock  doSideAction' :: SideActionBlock -> Annex a -> Annex a-doSideAction' b a = do-	o <- Annex.getState Annex.output-	set $ o { sideActionBlock = b }-	set o `after` a+doSideAction' b = bracket setup cleanup . const   where+	setup = do+		o <- Annex.getState Annex.output+		set $ o { sideActionBlock = b }+		return o+	cleanup = set+	set o = Annex.changeState $ \s -> s { Annex.output = o }++{- Performs an action, suppressing all normal standard output,+ - but not json output. -}+doQuietAction :: Annex a -> Annex a+doQuietAction = bracket setup cleanup . const+  where+	setup = do+		o <- Annex.getState Annex.output+		case outputType o of+			NormalOutput -> set $ o { outputType = QuietOutput }+			_ -> noop+		return o+	cleanup = set 	set o = Annex.changeState $ \s -> s {  Annex.output = o }  {- Make way for subsequent output of a command. -}

@@ -14,7 +14,6 @@ import Types.Messages import qualified Annex -#ifdef WITH_CONCURRENTOUTPUT import Common import qualified System.Console.Concurrent as Console import qualified System.Console.Regions as Regions@@ -23,7 +22,6 @@ #ifndef mingw32_HOST_OS import GHC.IO.Encoding #endif-#endif  {- Outputs a message in a concurrency safe way.  -@@ -33,15 +31,10 @@  - instead.  -} concurrentMessage :: MessageState -> Bool -> String -> Annex () -> Annex ()-#ifdef WITH_CONCURRENTOUTPUT concurrentMessage s iserror msg fallback  	| concurrentOutputEnabled s = 		go =<< consoleRegion <$> Annex.getState Annex.output-#else-concurrentMessage _s _iserror _msg fallback -#endif 	| otherwise = fallback-#ifdef WITH_CONCURRENTOUTPUT   where 	go Nothing 		| iserror = liftIO $ Console.errorConcurrent msg@@ -58,7 +51,6 @@ 			rl <- takeTMVar Regions.regionList 			putTMVar Regions.regionList 				(if r `elem` rl then rl else r:rl)-#endif  {- Runs an action in its own dedicated region of the console.  -@@ -70,7 +62,6 @@  - complete.  -} inOwnConsoleRegion :: MessageState -> Annex a -> Annex a-#ifdef WITH_CONCURRENTOUTPUT inOwnConsoleRegion s a 	| concurrentOutputEnabled s = do 		r <- mkregion@@ -85,11 +76,7 @@ 			Right ret -> do 				rmregion r 				return ret-#else-inOwnConsoleRegion _s a-#endif 	| otherwise = a-#ifdef WITH_CONCURRENTOUTPUT   where 	-- The region is allocated here, but not displayed until  	-- a message is added to it. This avoids unnecessary screen@@ -108,10 +95,8 @@ 			unless (T.null t) $ 				Console.bufferOutputSTM h t 			Regions.closeConsoleRegion r-#endif  {- The progress region is displayed inline with the current console region. -}-#ifdef WITH_CONCURRENTOUTPUT withProgressRegion :: (Regions.ConsoleRegion -> Annex a) -> Annex a withProgressRegion a = do 	parent <- consoleRegion <$> Annex.getState Annex.output@@ -119,14 +104,12 @@  instance Regions.LiftRegion Annex where 	liftRegion = liftIO . atomically-#endif  {- The concurrent-output library uses Text, which bypasses the normal use  - of the fileSystemEncoding to roundtrip invalid characters, when in a  - non-unicode locale. Work around that problem by avoiding using  - concurrent output when not in a unicode locale. -} concurrentOutputSupported :: IO Bool-#ifdef WITH_CONCURRENTOUTPUT #ifndef mingw32_HOST_OS concurrentOutputSupported = do 	enc <- getLocaleEncoding@@ -134,9 +117,6 @@ #else concurrentOutputSupported = return True -- Windows is always unicode #endif-#else-concurrentOutputSupported = return False-#endif  {- Hide any currently displayed console regions while running the action,  - so that the action can use the console itself.@@ -144,7 +124,6 @@  - the regions will not be hidden, but the action still runs, garbling the  - display. -} hideRegionsWhile :: Annex a -> Annex a-#ifdef WITH_CONCURRENTOUTPUT #if MIN_VERSION_concurrent_output(1,9,0) hideRegionsWhile a = bracketIO setup cleanup go   where@@ -153,9 +132,6 @@ 	go _ = do 		liftIO $ hFlush stdout 		a-#else-hideRegionsWhile = id-#endif #else hideRegionsWhile = id #endif

@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Messages.Progress where  import Common@@ -16,12 +14,10 @@ import Types.Messages import Types.Key import qualified Messages.JSON as JSON--#ifdef WITH_CONCURRENTOUTPUT import Messages.Concurrent+ import qualified System.Console.Regions as Regions import qualified System.Console.Concurrent as Console-#endif  {- Shows a progress meter while performing a transfer of a key.  - The action is passed the meter and a callback to use to update the meter.@@ -45,7 +41,6 @@ 		liftIO $ clearMeterHandle meter stdout 		return r 	go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) =-#if WITH_CONCURRENTOUTPUT 		withProgressRegion $ \r -> do 			meter <- liftIO $ mkMeter msize $ \_ msize' old new -> 				let s = bandwidthMeter msize' old new@@ -53,9 +48,6 @@ 			m <- liftIO $ rateLimitMeterUpdate 0.2 meter $ 				updateMeter meter 			a meter (combinemeter m)-#else-		nometer-#endif 	go msize (MessageState { outputType = JSONOutput jsonoptions }) 		| jsonProgress jsonoptions = do 			buf <- withMessageState $ return . jsonBuffer@@ -133,7 +125,6 @@ mkStderrEmitter :: Annex (String -> IO ()) mkStderrEmitter = withMessageState go   where-#ifdef WITH_CONCURRENTOUTPUT-	go s | concurrentOutputEnabled s = return Console.errorConcurrent-#endif-	go _ = return (hPutStrLn stderr)+	go s+		| concurrentOutputEnabled s = return Console.errorConcurrent+		| otherwise = return (hPutStrLn stderr)

@@ -1,3 +1,21 @@+git-annex (7.20181031) upstream; urgency=medium++  Repository version 7 is now available. v6 repositories will automatically+  upgrade to v7. v5 repositories are still supported and will not be+  automatically upgraded yet.++  Direct mode is deprecated, and upgrading direct mode repositories to v7 is+  encouraged, unless they need to remain usable by older versions of git-annex.+  Just run `git annex upgrade`.++  git-annex will no longer initialize new repositories on crippled filesystems+  using direct mode, instead it uses v7.++  The git-annex Android app is no longer being updated. Users of the app+  should remove it and install using the new Termux based installation method.++ -- Joey Hess <id@joeyh.name>  Wed, 31 Oct 2018 13:05:48 -0400+ git-annex (6.20180626) upstream; urgency=high    A security fix has changed git-annex to refuse to download content from

@@ -12,6 +12,7 @@ 	, RunState(..) 	, mkRunState 	, P2PConnection(..)+	, ConnIdent(..) 	, ClosableConnection(..) 	, stdioP2PConnection 	, connectPeer@@ -77,8 +78,12 @@ 	, connCheckAuth :: (AuthToken -> Bool) 	, connIhdl :: Handle 	, connOhdl :: Handle+	, connIdent :: ConnIdent 	} +-- Identifier for a connection, only used for debugging.+newtype ConnIdent = ConnIdent (Maybe String)+ data ClosableConnection conn 	= OpenConnection conn 	| ClosedConnection@@ -90,6 +95,7 @@ 	, connCheckAuth = const False 	, connIhdl = stdin 	, connOhdl = stdout+	, connIdent = ConnIdent Nothing 	}  -- Opens a connection to a peer. Does not authenticate with it.@@ -101,6 +107,7 @@ 		, connCheckAuth = const False 		, connIhdl = h 		, connOhdl = h+		, connIdent = ConnIdent Nothing 		}  closeConnection :: P2PConnection -> IO ()@@ -166,7 +173,7 @@ 	SendMessage m next -> do 		v <- liftIO $ tryNonAsync $ do 			let l = unwords (formatMessage m)-			debugMessage "P2P >" m+			debugMessage conn "P2P >" m 			hPutStrLn (connOhdl conn) l 			hFlush (connOhdl conn) 		case v of@@ -180,7 +187,7 @@ 				ProtoFailureMessage "protocol error" 			Right (Just l) -> case parseMessage l of 				Just m -> do-					liftIO $ debugMessage "P2P <" m+					liftIO $ debugMessage conn "P2P <" m 					runner (next (Just m)) 				Nothing -> runner (next Nothing) 	SendBytes len b p next -> do@@ -225,13 +232,19 @@ 		Serving _ _ tv -> tv 		Client tv -> tv -debugMessage :: String -> Message -> IO ()-debugMessage prefix m = debugM "p2p" $-	prefix ++ " " ++ unwords (formatMessage safem)+debugMessage :: P2PConnection -> String -> Message -> IO ()+debugMessage conn prefix m = do+	tid <- myThreadId	+	debugM "p2p" $ concat $ catMaybes $+		[ (\ident -> "[" ++ ident ++ "] ") <$> mident+		, Just $ "[" ++ show tid ++ "] "+		, Just $ prefix ++ " " ++ unwords (formatMessage safem)+		]   where 	safem = case m of 		AUTH u _ -> AUTH u nullAuthToken 		_ -> m+	ConnIdent mident = connIdent conn  -- Send exactly the specified number of bytes or returns False. --

@@ -689,10 +689,6 @@ 	handleRequest external (CHECKURL url) Nothing $ \req -> case req of 		CHECKURL_CONTENTS sz f -> result $ UrlContents sz $ 			if null f then Nothing else Just $ mkSafeFilePath f-		-- Treat a single item multi response specially to-		-- simplify the external remote implementation.-		CHECKURL_MULTI ((_, sz, f):[]) ->-			result $ UrlContents sz $ Just $ mkSafeFilePath f 		CHECKURL_MULTI l -> result $ UrlMulti $ map mkmulti l 		CHECKURL_FAILURE errmsg -> Just $ giveup errmsg 		UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote"

@@ -89,23 +89,32 @@ 		} 	isexport = do 		db <- openDb (uuid r)+		updateflag <- liftIO $ newTVarIO Nothing -		updateflag <- liftIO newEmptyTMVarIO-		let updateonce = liftIO $ atomically $-			ifM (isEmptyTMVar updateflag)-				( do-					putTMVar updateflag ()+		-- When multiple threads run this, all except the first+		-- will block until the first runs doneupdateonce.+		-- Returns True when an update should be done and False+		-- when the update has already been done.+		let startupdateonce = liftIO $ atomically $+			readTVar updateflag >>= \case+				Nothing -> do+					writeTVar updateflag (Just True) 					return True-				, return False-				)+				Just True -> retry+				Just False -> return False+		let doneupdateonce = \updated ->+			when updated $+				liftIO $ atomically $+					writeTVar updateflag (Just False) 		 		-- Get export locations for a key. Checks once 		-- if the export log is different than the database and 		-- updates the database, to notice when an export has been 		-- updated from another repository. 		let getexportlocs = \k -> do-			whenM updateonce $-				updateExportTreeFromLog db+			bracket startupdateonce doneupdateonce $ \updatenow ->+				when updatenow $+					updateExportTreeFromLog db 			liftIO $ getExportTree db k  		return $ r

@@ -29,6 +29,7 @@ import Control.Concurrent.STM import Control.Concurrent.Async import qualified Data.ByteString as B+import Data.Unique  toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> SshCommand -> Annex (FilePath, [CommandParam]) toRepo cs r gc remotecmd = do@@ -257,11 +258,16 @@ 				, std_out = CreatePipe 				, std_err = CreatePipe 				}+		-- Could use getPid, but need to build with older versions+		-- of process, so instead a unique connection number.+		connnum <- hashUnique <$> newUnique 		let conn = P2P.P2PConnection 			{ P2P.connRepo = repo 			, P2P.connCheckAuth = const False 			, P2P.connIhdl = to 			, P2P.connOhdl = from+			, P2P.connIdent = P2P.ConnIdent $+				Just $ "ssh connection " ++ show connnum 			} 		stderrhandlerst <- newStderrHandler err 		runst <- P2P.mkRunState P2P.Client

@@ -93,6 +93,7 @@ 	newg <- inRepo Git.Config.reRead 	Annex.changeState $ \s -> s  		{ Annex.remotes = []+		, Annex.gitremotes = Nothing 		, Annex.repo = newg 		} 	remoteList

@@ -114,6 +114,7 @@ 				, connCheckAuth = (`isAllowedAuthToken` allowed) 				, connIhdl = h 				, connOhdl = h+				, connIdent = ConnIdent $ Just "tor remotedaemon" 				} 			-- not really Client, but we don't know their uuid yet 			runstauth <- liftIO $ mkRunState Client

@@ -1,6 +1,6 @@ {- git-annex test suite  -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,6 +10,7 @@ module Test where  import Types.Test+import Types.RepoVersion import Test.Framework import Options.Applicative.Types @@ -148,10 +149,10 @@ 	map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes   where 	testmodes = catMaybes-		[ Just ("v6 unlocked", (testMode opts "6") { unlockedFiles = True })-		, unlesscrippled ("v5", testMode opts "5")-		, unlesscrippled ("v6 locked", testMode opts "6")-		, Just ("v5 direct", (testMode opts "5") { forceDirect = True })+		[ Just ("v7 unlocked", (testMode opts (RepoVersion 7)) { unlockedFiles = True })+		, unlesscrippled ("v5", testMode opts (RepoVersion 5))+		, unlesscrippled ("v7 locked", testMode opts (RepoVersion 7))+		, Just ("v5 direct", (testMode opts (RepoVersion 5)) { forceDirect = True }) 		] 	unlesscrippled v 		| crippledfilesystem = Nothing@@ -225,7 +226,7 @@ 	, testCase "move (ssh remote)" test_move_ssh_remote 	, testCase "copy" test_copy 	, testCase "lock" test_lock-	, testCase "lock (v6 --force)" test_lock_v6_force+	, testCase "lock (v7 --force)" test_lock_v7_force 	, testCase "edit (no pre-commit)" test_edit 	, testCase "edit (pre-commit)" test_edit_precommit 	, testCase "partial commit" test_partial_commit@@ -280,7 +281,7 @@ 	ver <- annexVersion <$> getTestMode 	if ver == Annex.Version.defaultVersion 		then git_annex "init" [reponame] @? "init failed"-		else git_annex "init" [reponame, "--version", ver] @? "init failed"+		else git_annex "init" [reponame, "--version", show (fromRepoVersion ver)] @? "init failed" 	setupTestMode   where 	reponame = "test repo"@@ -289,10 +290,10 @@ -- annexed file that later tests will use test_add :: Assertion test_add = inmainrepo $ do-	writeFile annexedfile $ content annexedfile+	writecontent annexedfile $ content annexedfile 	add_annex annexedfile @? "add failed" 	annexed_present annexedfile-	writeFile sha1annexedfile $ content sha1annexedfile+	writecontent sha1annexedfile $ content sha1annexedfile 	git_annex "add" [sha1annexedfile, "--backend=SHA1"] @? "add with SHA1 failed" 	whenM (unlockedFiles <$> getTestMode) $ 		git_annex "unlock" [sha1annexedfile] @? "unlock failed"@@ -300,12 +301,12 @@ 	checkbackend sha1annexedfile backendSHA1 	ifM (annexeval Config.isDirect) 		( do-			writeFile ingitfile $ content ingitfile+			writecontent ingitfile $ content ingitfile 			not <$> boolSystem "git" [Param "add", File ingitfile] @? "git add failed to fail in direct mode" 			nukeFile ingitfile 			git_annex "sync" [] @? "sync failed" 		, do-			writeFile ingitfile $ content ingitfile+			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"@@ -314,14 +315,14 @@  test_add_dup :: Assertion test_add_dup = intmpclonerepo $ do-	writeFile annexedfiledup $ content annexedfiledup+	writecontent annexedfiledup $ content annexedfiledup 	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-	writeFile wormannexedfile $ content wormannexedfile+	writecontent wormannexedfile $ content wormannexedfile 	git_annex "add" [wormannexedfile, "--backend=WORM"] @? "add with WORM failed" 	whenM (unlockedFiles <$> getTestMode) $ 		git_annex "unlock" [wormannexedfile] @? "unlock failed"@@ -378,7 +379,7 @@ 	git_annex "drop" ["--force", imported1, imported2, imported5] @? "drop failed" 	annexed_notpresent_imported imported2 	(toimportdup, importfdup, importeddup) <- mktoimport importdir "importdup"-	not <$> git_annex "import" ["--clean-duplicates", toimportdup] +	git_annex_shouldfail "import" ["--clean-duplicates", toimportdup]  		@? "import of missing duplicate with --clean-duplicates failed to fail" 	checkdoesnotexist importeddup 	checkexists importfdup@@ -386,7 +387,7 @@ 	mktoimport importdir subdir = do 		createDirectory (importdir </> subdir) 		let importf = subdir </> "f"-		writeFile (importdir </> importf) (content importf)+		writecontent (importdir </> importf) (content importf) 		return (importdir </> subdir, importdir </> importf, importf) 	annexed_present_imported f = ifM (annexeval Config.crippledFileSystem) 		( annexed_present_unlocked f@@ -401,7 +402,7 @@ test_reinject = intmpclonerepoInDirect $ do 	git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" 	annexed_notpresent sha1annexedfile-	writeFile tmp $ content sha1annexedfile+	writecontent tmp $ content sha1annexedfile 	key <- Key.key2file <$> getKey backendSHA1 tmp 	git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" 	annexed_present sha1annexedfile@@ -436,7 +437,7 @@ 	git_annex "get" [annexedfile] @? "get failed" 	boolSystem "git" [Param "remote", Param "rm", Param "origin"] 		@? "git remote rm origin failed"-	not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file"+	git_annex_shouldfail "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of file" 	annexed_present annexedfile 	git_annex "drop" ["--force", annexedfile] @? "drop --force failed" 	annexed_notpresent annexedfile@@ -450,7 +451,7 @@ 	git_annex "get" [annexedfile] @? "get failed" 	annexed_present annexedfile 	git_annex "numcopies" ["2"] @? "numcopies config failed"-	not <$> git_annex "drop" [annexedfile] @? "drop succeeded although numcopies is not satisfied"+	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" 	annexed_notpresent annexedfile@@ -464,7 +465,7 @@ 	git_annex "untrust" ["origin"] @? "untrust of origin failed" 	git_annex "get" [annexedfile] @? "get failed" 	annexed_present annexedfile-	not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with only an untrusted copy of the file"+	git_annex_shouldfail "drop" [annexedfile] @? "drop wrongly succeeded with only an untrusted copy of the file" 	annexed_present annexedfile 	inmainrepo $ annexed_present annexedfile @@ -595,18 +596,18 @@ 	annexed_notpresent annexedfile 	unlessM (annexeval Annex.Version.versionSupportsUnlockedPointers) $ 		ifM (unlockedFiles <$> getTestMode)-			( not <$> git_annex "lock" [annexedfile] @? "lock failed to fail with not present file"-			, not <$> git_annex "unlock" [annexedfile] @? "unlock failed to fail with not present file"+			( git_annex_shouldfail "lock" [annexedfile] @? "lock failed to fail with not present file"+			, git_annex_shouldfail "unlock" [annexedfile] @? "unlock failed to fail with not present file" 			) 	annexed_notpresent annexedfile  	-- regression test: unlock of newly added, not committed file-	-- should fail in v5 mode. In v6 mode, this is allowed.-	writeFile "newfile" "foo"+	-- should fail in v5 mode. In v7 mode, this is allowed.+	writecontent "newfile" "foo" 	git_annex "add" ["newfile"] @? "add new file failed" 	ifM (annexeval Annex.Version.versionSupportsUnlockedPointers)-		( git_annex "unlock" ["newfile"] @? "unlock failed on newly added, never committed file in v6 repository"-		, not <$> git_annex "unlock" ["newfile"] @? "unlock failed to fail on newly added, never committed file in v5 repository"+		( git_annex "unlock" ["newfile"] @? "unlock failed on newly added, never committed file in v7 repository"+		, git_annex_shouldfail "unlock" ["newfile"] @? "unlock failed to fail on newly added, never committed file in v5 repository" 		)  	git_annex "get" [annexedfile] @? "get of file failed"@@ -616,10 +617,10 @@ 	-- write different content, to verify that lock 	-- throws it away 	changecontent annexedfile-	writeFile annexedfile $ content annexedfile ++ "foo"-	not <$> git_annex "lock" [annexedfile] @? "lock failed to fail without --force"+	writecontent annexedfile $ content annexedfile ++ "foo"+	git_annex_shouldfail "lock" [annexedfile] @? "lock failed to fail without --force" 	git_annex "lock" ["--force", annexedfile] @? "lock --force failed"-	-- In v6 mode, the original content of the file is not always+	-- In v7 mode, the original content of the file is not always 	-- preserved after modification, so re-get it. 	git_annex "get" [annexedfile] @? "get of file failed after lock --force" 	annexed_present_locked annexedfile@@ -642,19 +643,20 @@ -- 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_v6_force :: Assertion-test_lock_v6_force = intmpclonerepoInDirect $ do+test_lock_v7_force :: Assertion+test_lock_v7_force = intmpclonerepoInDirect $ do 	git_annex "upgrade" [] @? "upgrade failed" 	whenM (annexeval Annex.Version.versionSupportsUnlockedPointers) $ do 		git_annex "get" [annexedfile] @? "get of file failed"-		git_annex "unlock" [annexedfile] @? "unlock failed in v6 mode"+		git_annex "unlock" [annexedfile] @? "unlock failed in v7 mode" 		annexeval $ do+			Just k <- Annex.WorkTree.lookupFile annexedfile+			Database.Keys.removeInodeCaches k 			Database.Keys.closeDb-			dbdir <- Annex.fromRepo Annex.Locations.gitAnnexKeysDb-			liftIO $ renameDirectory dbdir (dbdir ++ ".old")-		writeFile annexedfile "test_lock_v6_force content"-		not <$> git_annex "lock" [annexedfile] @? "lock of modified file failed to fail in v6 mode"-		git_annex "lock" ["--force", annexedfile] @? "lock --force of modified file failed in v6 mode"+			liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache+		writecontent annexedfile "test_lock_v7_force content"+		git_annex_shouldfail "lock" [annexedfile] @? "lock of modified file failed to fail in v7 mode"+		git_annex "lock" ["--force", annexedfile] @? "lock --force of modified file failed in v7 mode" 		annexed_present_locked annexedfile  test_edit :: Assertion@@ -683,7 +685,7 @@ 		) 	c <- readFile annexedfile 	assertEqual "content of modified file" c (changedcontent annexedfile)-	not <$> git_annex "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file"+	git_annex_shouldfail "drop" [annexedfile] @? "drop wrongly succeeded with no known copy of modified file"  test_partial_commit :: Assertion test_partial_commit = intmpclonerepoInDirect $ do@@ -693,7 +695,7 @@ 	changecontent annexedfile 	ifM (annexeval Annex.Version.versionSupportsUnlockedPointers) 		( boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "test", File annexedfile]-			@? "partial commit of unlocked file should be allowed in v6 repository"+			@? "partial commit of unlocked file should be allowed in v7 repository" 		, not <$> boolSystem "git" [Param "commit", Param "-q", Param "-m", Param "test", File annexedfile] 			@? "partial commit of unlocked file not blocked by pre-commit hook" 		)@@ -723,7 +725,7 @@ 	git_annex "get" [annexedfile] @? "get of file failed" 	annexed_present annexedfile 	ifM (annexeval Annex.Version.versionSupportsUnlockedPointers)-		( not <$> git_annex "direct" [] @? "switch to direct mode failed to fail in v6 repository"+		( git_annex_shouldfail "direct" [] @? "switch to direct mode failed to fail in v7 repository" 		, do 			git_annex "direct" [] @? "switch to direct mode failed" 			annexed_present annexedfile@@ -769,10 +771,10 @@ 	corrupt f = do 		git_annex "get" [f] @? "get of file failed" 		Utility.FileMode.allowWrite f-		writeFile f (changedcontent f)+		writecontent f (changedcontent f) 		ifM (annexeval Config.isDirect <||> unlockedFiles <$> getTestMode) 			( git_annex "fsck" [] @? "fsck failed on unlocked file with changed file content"-			, not <$> git_annex "fsck" [] @? "fsck failed to fail with corrupted file content"+			, git_annex_shouldfail "fsck" [] @? "fsck failed to fail with corrupted file content" 			) 		git_annex "fsck" [] @? "fsck unexpectedly failed again; previous one did not fix problem with " ++ f @@ -803,7 +805,7 @@ 	git_annex "fsck" ["--from", "origin"] @? "fsck --from origin failed"  fsck_should_fail :: String -> Assertion-fsck_should_fail m = not <$> git_annex "fsck" []+fsck_should_fail m = git_annex_shouldfail "fsck" [] 	@? "fsck failed to fail with " ++ m  test_migrate :: Assertion@@ -875,10 +877,10 @@ 		@? "dropkey failed" 	checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Key.key2file annexedfilekey) -	not <$> git_annex "dropunused" ["1"] @? "dropunused failed to fail without --force"+	git_annex_shouldfail "dropunused" ["1"] @? "dropunused failed to fail without --force" 	git_annex "dropunused" ["--force", "1"] @? "dropunused failed" 	checkunused [] "after dropunused"-	not <$> git_annex "dropunused" ["--force", "10", "501"] @? "dropunused failed to fail on bogus numbers"+	git_annex_shouldfail "dropunused" ["--force", "10", "501"] @? "dropunused failed to fail on bogus numbers"  	-- Unused used to miss renamed symlinks that were not staged 	-- and pointed at annexed content, and think that content was unused.@@ -886,7 +888,7 @@ 	-- unlocked, the work tree file has the content, and there's no way 	-- to associate it with the key. 	unlessM (unlockedFiles <$> getTestMode) $ do-		writeFile "unusedfile" "unusedcontent"+		writecontent "unusedfile" "unusedcontent" 		git_annex "add" ["unusedfile"] @? "add of unusedfile failed" 		unusedfilekey <- getKey backendSHA256E "unusedfile" 		renameFile "unusedfile" "unusedunstagedfile"@@ -897,7 +899,7 @@  	-- unused used to miss symlinks that were deleted or modified 	-- manually-	writeFile "unusedfile" "unusedcontent"+	writecontent "unusedfile" "unusedcontent" 	git_annex "add" ["unusedfile"] @? "add of unusedfile failed" 	boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" 	unusedfilekey' <- getKey backendSHA256E "unusedfile"@@ -907,7 +909,7 @@  	-- unused used to false positive on symlinks that were 	-- deleted or modified manually, but not staged as such-	writeFile "unusedfile" "unusedcontent"+	writecontent "unusedfile" "unusedcontent" 	git_annex "add" ["unusedfile"] @? "add of unusedfile failed" 	boolSystem "git" [Param "add", File "unusedfile"] @? "git add failed" 	checkunused [] "with staged file"@@ -919,10 +921,10 @@ 	-- found as unused. 	whenM (unlockedFiles <$> getTestMode) $ do 		let f = "unlockedfile"-		writeFile f "unlockedcontent1"+		writecontent f "unlockedcontent1" 		boolSystem "git" [Param "add", File "unlockedfile"] @? "git add failed" 		checkunused [] "with unlocked file before modification"-		writeFile f "unlockedcontent2"+		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" 		-- still nothing unused because one version is in the index@@ -959,7 +961,7 @@ 	{- --include=* should match files in subdirectories too, 	 - and --exclude=* should exclude them. -} 	createDirectory "dir"-	writeFile "dir/subfile" "subfile"+	writecontent "dir/subfile" "subfile" 	git_annex "add" ["dir"] @? "add of subdir failed" 	git_annex_expectoutput "find" ["--include", "*", "--exclude", annexedfile, "--exclude", sha1annexedfile] ["dir/subfile"] 	git_annex_expectoutput "find" ["--exclude", "*"] []@@ -1043,10 +1045,10 @@ 			{- Set up a conflict. -} 			let newcontent = content annexedfile ++ rname r 			ifM (annexeval Config.isDirect)-				( writeFile annexedfile newcontent+				( writecontent annexedfile newcontent 				, do 					git_annex "unlock" [annexedfile] @? "unlock failed"		-					writeFile annexedfile newcontent+					writecontent annexedfile newcontent 				) 		{- Sync twice in r1 so it gets the conflict resolution 		 - update from r2 -}@@ -1070,12 +1072,12 @@ 		withtmpclonerepo $ \r2 -> do 			indir r1 $ do 				disconnectOrigin-				writeFile conflictor "conflictor1"+				writecontent conflictor "conflictor1" 				add_annex conflictor @? "add conflicter failed" 				git_annex "sync" [] @? "sync failed in r1" 			indir r2 $ do 				disconnectOrigin-				writeFile conflictor "conflictor2"+				writecontent conflictor "conflictor2" 				add_annex conflictor @? "add conflicter failed" 				git_annex "sync" [] @? "sync failed in r2" 			pair r1 r2@@ -1098,20 +1100,20 @@  {- Conflict resolution while in an adjusted branch. -} test_conflict_resolution_adjusted_branch :: Assertion-test_conflict_resolution_adjusted_branch = whenM Annex.AdjustedBranch.isGitVersionSupported $+test_conflict_resolution_adjusted_branch = whenM (annexeval Annex.AdjustedBranch.isSupported) $ 	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do 			indir r1 $ do 				disconnectOrigin-				writeFile conflictor "conflictor1"+				writecontent conflictor "conflictor1" 				add_annex conflictor @? "add conflicter failed" 				git_annex "sync" [] @? "sync failed in r1" 			indir r2 $ do 				disconnectOrigin-				writeFile conflictor "conflictor2"+				writecontent conflictor "conflictor2" 				add_annex conflictor @? "add conflicter failed" 				git_annex "sync" [] @? "sync failed in r2"-				-- need v6 to use adjust+				-- need v7 to use adjust 				git_annex "upgrade" [] @? "upgrade failed" 				-- We might be in an adjusted branch 				-- already, when eg on a crippled@@ -1146,13 +1148,13 @@ 		withtmpclonerepo $ \r2 -> do 			indir r1 $ do 				disconnectOrigin-				writeFile conflictor "conflictor"+				writecontent conflictor "conflictor" 				add_annex conflictor @? "add conflicter failed" 				git_annex "sync" [] @? "sync failed in r1" 			indir r2 $ do 				disconnectOrigin 				createDirectory conflictor-				writeFile subfile "subfile"+				writecontent subfile "subfile" 				add_annex conflictor @? "add conflicter failed" 				git_annex "sync" [] @? "sync failed in r2" 			pair r1 r2@@ -1188,7 +1190,7 @@ 		withtmpclonerepo $ \r2 -> do 			indir r1 $ do 				disconnectOrigin-				writeFile conflictor "conflictor"+				writecontent conflictor "conflictor" 				add_annex conflictor @? "add conflicter failed" 				git_annex "sync" [] @? "sync failed in r1" 			indir r2 $@@ -1201,7 +1203,7 @@ 				unlessM (annexeval Config.isDirect) $ do 					git_annex "unlock" [conflictor] 						@? "unlock conflictor failed"-				writeFile conflictor "newconflictor"+				writecontent conflictor "newconflictor" 			indir r1 $ 				nukeFile conflictor 			let l = if inr1 then [r1, r2, r1] else [r2, r1, r2]@@ -1237,12 +1239,12 @@ 			whenM (isInDirect r1 <&&> isInDirect r2) $ do 				indir r1 $ do 					disconnectOrigin-					writeFile conflictor "conflictor"+					writecontent conflictor "conflictor" 					add_annex conflictor @? "add conflicter failed" 					git_annex "sync" [] @? "sync failed in r1" 				indir r2 $ do 					disconnectOrigin-					writeFile conflictor nonannexed_content+					writecontent conflictor nonannexed_content 					boolSystem "git" 						[ Param "config" 						, Param "annex.largefiles"@@ -1294,7 +1296,7 @@ 			       <&&> isInDirect r1 <&&> isInDirect r2) $ do 				indir r1 $ do 					disconnectOrigin-					writeFile conflictor "conflictor"+					writecontent conflictor "conflictor" 					add_annex conflictor @? "add conflicter failed" 					git_annex "sync" [] @? "sync failed in r1" 				indir r2 $ do@@ -1345,12 +1347,12 @@ 			indir r1 $ do 				disconnectOrigin 				createDirectoryIfMissing True (parentDir remoteconflictor)-				writeFile remoteconflictor annexedcontent+				writecontent remoteconflictor annexedcontent 				add_annex conflictor @? "add remoteconflicter failed" 				git_annex "sync" [] @? "sync failed in r1" 			indir r2 $ do 				disconnectOrigin-				writeFile conflictor localcontent+				writecontent conflictor localcontent 			pair r1 r2 			indir r2 $ ifM (annexeval Config.isDirect) 				( do@@ -1366,7 +1368,7 @@ 				-- this case is intentionally not handled 				-- in indirect mode, since the user 				-- can recover on their own easily-				, not <$> git_annex "sync" [] @? "sync failed to fail"+				, git_annex_shouldfail "sync" [] @? "sync failed to fail" 				) 	conflictor = "conflictor" 	localprefix = ".variant-local"@@ -1382,18 +1384,18 @@ 		withtmpclonerepo $ \r2 -> 			withtmpclonerepo $ \r3 -> do 				indir r1 $ do-					writeFile conflictor "conflictor"+					writecontent conflictor "conflictor" 					git_annex "add" [conflictor] @? "add conflicter failed" 					git_annex "sync" [] @? "sync failed in r1" 					check_is_link conflictor "r1" 				indir r2 $ do 					createDirectory conflictor-					writeFile (conflictor </> "subfile") "subfile"+					writecontent (conflictor </> "subfile") "subfile" 					git_annex "add" [conflictor] @? "add conflicter failed" 					git_annex "sync" [] @? "sync failed in r2" 					check_is_link (conflictor </> "subfile") "r2" 				indir r3 $ do-					writeFile conflictor "conflictor"+					writecontent conflictor "conflictor" 					git_annex "add" [conflictor] @? "add conflicter failed" 					git_annex "sync" [] @? "sync failed in r1" 					check_is_link (conflictor </> "subfile") "r3"@@ -1405,7 +1407,7 @@ 		all (\i -> Git.Types.toTreeItemType (Git.LsTree.mode i) == Just Git.Types.TreeSymlink) l 			@? (what ++ " " ++ f ++ " lost symlink bit after merge: " ++ show l) -{- A v6 unlocked file that conflicts with a locked file should be resolved+{- A v7 unlocked file that conflicts with a locked file should be resolved  - in favor of the unlocked file, with no variant files, as long as they  - both point to the same key. -} test_mixed_lock_conflict_resolution :: Assertion@@ -1414,12 +1416,12 @@ 		withtmpclonerepo $ \r2 -> do 			indir r1 $ whenM shouldtest $ do 				disconnectOrigin-				writeFile conflictor "conflictor"+				writecontent conflictor "conflictor" 				git_annex "add" [conflictor] @? "add conflicter failed" 				git_annex "sync" [] @? "sync failed in r1" 			indir r2 $ whenM shouldtest $ do 				disconnectOrigin-				writeFile conflictor "conflictor"+				writecontent conflictor "conflictor" 				git_annex "add" [conflictor] @? "add conflicter failed" 				git_annex "unlock" [conflictor] @? "unlock conflicter failed" 				git_annex "sync" [] @? "sync failed in r2"@@ -1447,7 +1449,7 @@  - where the same file is added to both independently. The bad merge  - emptied the whole tree. -} test_adjusted_branch_merge_regression :: Assertion-test_adjusted_branch_merge_regression = whenM Annex.AdjustedBranch.isGitVersionSupported $+test_adjusted_branch_merge_regression = whenM (annexeval Annex.AdjustedBranch.isSupported) $ 	withtmpclonerepo $ \r1 -> 		withtmpclonerepo $ \r2 -> do 			pair r1 r2@@ -1461,7 +1463,7 @@ 		disconnectOrigin 		git_annex "upgrade" [] @? "upgrade failed" 		git_annex "adjust" ["--unlock", "--force"] @? "adjust failed"-		writeFile conflictor "conflictor"+		writecontent conflictor "conflictor" 		git_annex "add" [conflictor] @? "add conflicter failed" 		git_annex "sync" [] @? "sync failed" 	checkmerge what d = indir d $ do@@ -1474,18 +1476,18 @@  - a subtree to an existing tree lost files. -} test_adjusted_branch_subtree_regression :: Assertion test_adjusted_branch_subtree_regression = -	whenM Annex.AdjustedBranch.isGitVersionSupported $ +	whenM (annexeval Annex.AdjustedBranch.isSupported) $  		withtmpclonerepo $ \r -> do 			indir r $ do 				disconnectOrigin 				git_annex "upgrade" [] @? "upgrade failed" 				git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" 				createDirectoryIfMissing True "a/b/c"-				writeFile "a/b/c/d" "foo"+				writecontent "a/b/c/d" "foo" 				git_annex "add" ["a/b/c"] @? "add a/b/c failed" 				git_annex "sync" [] @? "sync failed" 				createDirectoryIfMissing True "a/b/x"-				writeFile "a/b/x/y" "foo"+				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 "master"] @? "git checkout master failed"@@ -1518,7 +1520,7 @@ test_uninit_inbranch :: Assertion test_uninit_inbranch = intmpclonerepoInDirect $ do 	boolSystem "git" [Param "checkout", Param "git-annex"] @? "git checkout git-annex"-	not <$> git_annex "uninit" [] @? "uninit failed to fail when git-annex branch was checked out"+	git_annex_shouldfail "uninit" [] @? "uninit failed to fail when git-annex branch was checked out"  test_upgrade :: Assertion test_upgrade = intmpclonerepo $@@ -1529,7 +1531,7 @@ 	annexed_notpresent annexedfile 	git_annex "whereis" [annexedfile] @? "whereis on non-present file failed" 	git_annex "untrust" ["origin"] @? "untrust failed"-	not <$> git_annex "whereis" [annexedfile] @? "whereis on non-present file only present in untrusted repo failed to fail"+	git_annex_shouldfail "whereis" [annexedfile] @? "whereis on non-present file only present in untrusted repo failed to fail" 	git_annex "get" [annexedfile] @? "get failed" 	annexed_present annexedfile 	git_annex "whereis" [annexedfile] @? "whereis on present file failed"@@ -1555,7 +1557,7 @@ 	annexed_notpresent annexedfile 	git_annex "move" [annexedfile, "--from", "foo"] @? "move --from hook remote failed" 	annexed_present annexedfile-	not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail"+	git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" 	annexed_present annexedfile   where 	dir = "dir"@@ -1579,7 +1581,7 @@ 	annexed_notpresent annexedfile 	git_annex "move" [annexedfile, "--from", "foo"] @? "move --from directory remote failed" 	annexed_present annexedfile-	not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail"+	git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" 	annexed_present annexedfile  test_rsync_remote :: Assertion@@ -1594,7 +1596,7 @@ 	annexed_notpresent annexedfile 	git_annex "move" [annexedfile, "--from", "foo"] @? "move --from rsync remote failed" 	annexed_present annexedfile-	not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail"+	git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" 	annexed_present annexedfile  test_bup_remote :: Assertion@@ -1658,7 +1660,7 @@ 			annexed_notpresent annexedfile 			git_annex "move" [annexedfile, "--from", "foo"] @? "move --from encrypted remote failed" 			annexed_present annexedfile-			not <$> git_annex "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail"+			git_annex_shouldfail "drop" [annexedfile, "--numcopies=2"] @? "drop failed to fail" 			annexed_present annexedfile 	{- Ensure the configuration complies with the encryption scheme, and 	 - that all keys are encrypted properly for the given directory remote. -}@@ -1695,7 +1697,7 @@ test_add_subdirs :: Assertion test_add_subdirs = intmpclonerepo $ do 	createDirectory "dir"-	writeFile ("dir" </> "foo") $ "dir/" ++ content annexedfile+	writecontent ("dir" </> "foo") $ "dir/" ++ content annexedfile 	git_annex "add" ["dir"] @? "add of subdir failed"  	{- Regression test for Windows bug where symlinks were not@@ -1707,7 +1709,7 @@ 		"../.git/annex/" `isPrefixOf` l @? ("symlink from subdir to .git/annex is wrong: " ++ l)  	createDirectory "dir2"-	writeFile ("dir2" </> "foo") $ content annexedfile+	writecontent ("dir2" </> "foo") $ content annexedfile 	setCurrentDirectory "dir" 	git_annex "add" [".." </> "dir2"] @? "add of ../subdir failed" @@ -1717,8 +1719,8 @@ 	let filecmd c ps = git_annex c ("-cannex.security.allowed-url-schemes=file" : ps) 	f <- absPath "myurl" 	let url = replace "\\" "/" ("file:///" ++ dropDrive f)-	writeFile f "foo"-	not <$> git_annex "addurl" [url] @? "addurl failed to fail on file url"+	writecontent f "foo"+	git_annex_shouldfail "addurl" [url] @? "addurl failed to fail on file url" 	filecmd "addurl" [url] @? ("addurl failed on " ++ url) 	let dest = "addurlurldest" 	filecmd "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ "  with --file")

@@ -10,6 +10,7 @@ import Test.Tasty import Test.Tasty.Runners import Test.Tasty.HUnit+import Control.Concurrent  import Common import Types.Test@@ -17,6 +18,7 @@ import qualified Annex import qualified Annex.UUID import qualified Annex.Version+import qualified Types.RepoVersion import qualified Backend import qualified Git.CurrentRepo import qualified Git.Construct@@ -45,12 +47,22 @@ -- This is equivilant to running git-annex, but it's all run in-process -- so test coverage collection works. git_annex :: String -> [String] -> IO Bool-git_annex command params = do+git_annex command params = git_annex' command params >>= \case+	Right () -> return True+	Left e -> do+		hPutStrLn stderr (show e)+		return False++-- For when git-annex is expected to fail.+git_annex_shouldfail :: String -> [String] -> IO Bool+git_annex_shouldfail command params = git_annex' command params >>= \case+	Right () -> return False+	Left _ -> return True++git_annex' :: String -> [String] -> IO (Either SomeException ())+git_annex' command params = do 	-- catch all errors, including normally fatal errors-	r <- try run ::IO (Either SomeException ())-	case r of-		Right _ -> return True-		Left _ -> return False+	try run ::IO (Either SomeException ())   where 	run = GitAnnex.run dummyTestOptParser Nothing (command:"-q":params) 	dummyTestOptParser = pure mempty@@ -198,7 +210,7 @@ 		ver <- annexVersion <$> getTestMode 		if ver == Annex.Version.defaultVersion 			then git_annex "init" ["-q", new] @? "git annex init failed"-			else git_annex "init" ["-q", new, "--version", ver] @? "git annex init failed"+			else git_annex "init" ["-q", new, "--version", show (Types.RepoVersion.fromRepoVersion ver)] @? "git annex init failed" 	unless (bareClone cfg) $ 		indir new $ 			setupTestMode@@ -387,11 +399,11 @@ data TestMode = TestMode 	{ forceDirect :: Bool 	, unlockedFiles :: Bool-	, annexVersion :: Annex.Version.Version+	, annexVersion :: Types.RepoVersion.RepoVersion 	, keepFailures :: Bool 	} deriving (Read, Show) -testMode :: TestOptions -> Annex.Version.Version -> TestMode+testMode :: TestOptions -> Types.RepoVersion.RepoVersion -> TestMode testMode opts v = TestMode 	{ forceDirect = False 	, unlockedFiles = False@@ -502,8 +514,29 @@ 	| "import" `isPrefixOf` f = "imported content" 	| otherwise = "unknown file " ++ f +-- Writes new content to a file, and makes sure that it has a different+-- mtime than it did before+writecontent :: FilePath -> String -> IO ()+writecontent f c = go (10000000 :: Integer)+  where+	go ticsleft = do+		oldmtime <- catchMaybeIO $ getModificationTime f+		writeFile f c+		newmtime <- getModificationTime f+		if Just newmtime == oldmtime+			then do+				threadDelay 100000+				let ticsleft' = ticsleft - 100000+				if ticsleft' > 0+					then go ticsleft'+					else do+						hPutStrLn stderr "file mtimes do not seem to be changing (tried for 10 seconds)"+						hFlush stderr+						return ()+			else return ()+ changecontent :: FilePath -> IO ()-changecontent f = writeFile f $ changedcontent f+changecontent f = writecontent f $ changedcontent f  changedcontent :: FilePath -> String changedcontent f = content f ++ " (modified)"

@@ -0,0 +1,53 @@+{- adjusted branch types+ -+ - Copyright 2016-2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.AdjustedBranch where++data Adjustment+	= LinkAdjustment LinkAdjustment+	| PresenceAdjustment PresenceAdjustment (Maybe LinkAdjustment)+	deriving (Show, Eq)++-- Doesn't make sense to combine unlock with fix.+data LinkAdjustment+	= UnlockAdjustment+	| LockAdjustment+	| FixAdjustment+	| UnFixAdjustment+	deriving (Show, Eq)++data PresenceAdjustment+	= HideMissingAdjustment+	| ShowMissingAdjustment+	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.+class ReversableAdjustment t where+	reverseAdjustment :: t -> t++instance ReversableAdjustment Adjustment where+	reverseAdjustment (LinkAdjustment l) = +		LinkAdjustment (reverseAdjustment l)+	reverseAdjustment (PresenceAdjustment p ml) =+		PresenceAdjustment (reverseAdjustment p) (fmap reverseAdjustment ml)++instance ReversableAdjustment LinkAdjustment where+	reverseAdjustment UnlockAdjustment = LockAdjustment+	reverseAdjustment LockAdjustment = UnlockAdjustment+	reverseAdjustment FixAdjustment = UnFixAdjustment+	reverseAdjustment UnFixAdjustment = FixAdjustment++instance ReversableAdjustment PresenceAdjustment where+	reverseAdjustment HideMissingAdjustment = ShowMissingAdjustment+	reverseAdjustment ShowMissingAdjustment = HideMissingAdjustment++adjustmentHidesFiles :: Adjustment -> Bool+adjustmentHidesFiles (PresenceAdjustment HideMissingAdjustment _) = True+adjustmentHidesFiles _ = False+

@@ -10,9 +10,7 @@ module Types.DesktopNotify where  import Data.Monoid-#if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Sem-#endif import Prelude  data DesktopNotify = DesktopNotify@@ -21,22 +19,14 @@ 	} 	deriving (Show) -appendDesktopNotify :: DesktopNotify -> DesktopNotify -> DesktopNotify-appendDesktopNotify (DesktopNotify s1 f1) (DesktopNotify s2 f2) =-	DesktopNotify (s1 || s2) (f1 || f2)--#if MIN_VERSION_base(4,9,0) instance Sem.Semigroup DesktopNotify where-	(<>) = appendDesktopNotify-#endif+	(DesktopNotify s1 f1) <> (DesktopNotify s2 f2) =+		DesktopNotify (s1 || s2) (f1 || f2)  instance Monoid DesktopNotify where 	mempty = DesktopNotify False False-#if MIN_VERSION_base(4,11,0)-#elif MIN_VERSION_base(4,9,0)+#if ! MIN_VERSION_base(4,11,0) 	mappend = (Sem.<>)-#else-	mappend = appendDesktopNotify #endif  mkNotifyStart :: DesktopNotify

@@ -26,9 +26,7 @@ import Data.Maybe import Data.Monoid import qualified Data.Set as S-#if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Sem-#endif import Prelude  -- Describes differences from the v5 repository format.@@ -80,18 +78,13 @@ 	} appendDifferences _ _ = UnknownDifferences -#if MIN_VERSION_base(4,9,0) instance Sem.Semigroup Differences where 	(<>) = appendDifferences-#endif  instance Monoid Differences where 	mempty = Differences False False False-#if MIN_VERSION_base(4,11,0)-#elif MIN_VERSION_base(4,9,0)+#if ! MIN_VERSION_base(4,11,0) 	mappend = (Sem.<>)-#else-	mappend = appendDifferences #endif  readDifferences :: String -> Differences

@@ -30,6 +30,7 @@ import Types.NumCopies import Types.Difference import Types.RefSpec+import Types.RepoVersion import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd)@@ -52,7 +53,7 @@ {- Main git-annex settings. Each setting corresponds to a git-config key  - such as annex.foo -} data GitConfig = GitConfig-	{ annexVersion :: Maybe String+	{ annexVersion :: Maybe RepoVersion 	, annexUUID :: UUID 	, annexNumCopies :: Maybe NumCopies 	, annexDiskReserve :: Integer@@ -110,7 +111,7 @@  extractGitConfig :: Git.Repo -> GitConfig extractGitConfig r = GitConfig-	{ annexVersion = notempty $ getmaybe (annex "version")+	{ annexVersion = RepoVersion <$> getmayberead (annex "version") 	, annexUUID = maybe NoUUID toUUID $ getmaybe (annex "uuid") 	, annexNumCopies = NumCopies <$> getmayberead (annex "numcopies") 	, annexDiskReserve = fromMaybe onemegabyte $

@@ -5,16 +5,12 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Types.Messages where  import qualified Utility.Aeson as Aeson  import Control.Concurrent-#ifdef WITH_CONCURRENTOUTPUT import System.Console.Regions (ConsoleRegion)-#endif  data OutputType = NormalOutput | QuietOutput | JSONOutput JSONOptions 	deriving (Show)@@ -40,10 +36,8 @@ 	, concurrentOutputEnabled :: Bool 	, sideActionBlock :: SideActionBlock 	, implicitMessages :: Bool-#ifdef WITH_CONCURRENTOUTPUT 	, consoleRegion :: Maybe ConsoleRegion 	, consoleRegionErrFlag :: Bool-#endif 	, jsonBuffer :: Maybe Aeson.Object 	, promptLock :: MVar () -- left full when not prompting 	}@@ -56,10 +50,8 @@ 		, concurrentOutputEnabled = False 		, sideActionBlock = NoBlock 		, implicitMessages = True -#ifdef WITH_CONCURRENTOUTPUT 		, consoleRegion = Nothing 		, consoleRegionErrFlag = False-#endif 		, jsonBuffer = Nothing 		, promptLock = promptlock 		}

@@ -0,0 +1,11 @@+{- git-annex repository versioning+ -+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.RepoVersion where++newtype RepoVersion = RepoVersion { fromRepoVersion :: Int }+	deriving (Eq, Ord, Read, Show)

@@ -11,9 +11,7 @@  import Test.Tasty.Options import Data.Monoid-#if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Sem-#endif import Prelude  import Types.Command@@ -25,25 +23,17 @@ 	, internalData :: CmdParams 	} -appendTestOptions :: TestOptions -> TestOptions -> TestOptions-appendTestOptions a b = TestOptions-	(tastyOptionSet a <> tastyOptionSet b)-	(keepFailuresOption a || keepFailuresOption b)-	(fakeSsh a || fakeSsh b)-	(internalData a <> internalData b)--#if MIN_VERSION_base(4,9,0) instance Sem.Semigroup TestOptions where-	(<>) = appendTestOptions-#endif+	a <> b = TestOptions+		(tastyOptionSet a <> tastyOptionSet b)+		(keepFailuresOption a || keepFailuresOption b)+		(fakeSsh a || fakeSsh b)+		(internalData a <> internalData b)  instance Monoid TestOptions where 	mempty = TestOptions mempty False False mempty-#if MIN_VERSION_base(4,11,0)-#elif MIN_VERSION_base(4,9,0)+#if ! MIN_VERSION_base(4,11,0) 	mappend = (Sem.<>)-#else-	mappend = appendTestOptions #endif  type TestRunner = TestOptions -> IO ()

@@ -11,6 +11,7 @@  import Annex.Common import Annex.Version+import Types.RepoVersion #ifndef mingw32_HOST_OS import qualified Upgrade.V0 import qualified Upgrade.V1@@ -19,41 +20,57 @@ import qualified Upgrade.V3 import qualified Upgrade.V4 import qualified Upgrade.V5+import qualified Upgrade.V6 -checkUpgrade :: Version -> Annex ()+import qualified Data.Map as M++checkUpgrade :: RepoVersion -> Annex () checkUpgrade = maybe noop giveup <=< needsUpgrade -needsUpgrade :: Version -> Annex (Maybe String)+needsUpgrade :: RepoVersion -> Annex (Maybe String) needsUpgrade v 	| v `elem` supportedVersions = ok-	| v `elem` autoUpgradeableVersions = ifM (upgrade True defaultVersion)-		( ok-		, err "Automatic upgrade failed!"-		)-	| v `elem` upgradableVersions = err "Upgrade this repository: git-annex upgrade"-	| otherwise = err "Upgrade git-annex."+	| otherwise = case M.lookup v autoUpgradeableVersions of+		Nothing+			| v `elem` upgradableVersions ->+				err "Upgrade this repository: git-annex upgrade"+			| otherwise ->+				err "Upgrade git-annex."+		Just newv -> ifM (upgrade True newv)+			( ok+			, err "Automatic upgrade failed!"+			)   where-	err msg = return $ Just $ "Repository version " ++ v +++	err msg = return $ Just $ "Repository version " +++		show (fromRepoVersion v) ++ 		" is not supported. " ++ msg 	ok = return Nothing -upgrade :: Bool -> Version -> Annex Bool+upgrade :: Bool -> RepoVersion -> Annex Bool upgrade automatic destversion = do 	upgraded <- go =<< getVersion 	when upgraded $ 		setVersion destversion 	return upgraded   where-	go (Just v) | v >= destversion = return True+	go (Just v)+		| v >= destversion = return True+		| otherwise = ifM (up v)+			( go (Just (RepoVersion (fromRepoVersion v + 1)))+			, return False+			)+	go _ = return True+ #ifndef mingw32_HOST_OS-	go (Just "0") = Upgrade.V0.upgrade-	go (Just "1") = Upgrade.V1.upgrade+	up (RepoVersion 0) = Upgrade.V0.upgrade+	up (RepoVersion 1) = Upgrade.V1.upgrade #else-	go (Just "0") = giveup "upgrade from v0 on Windows not supported"-	go (Just "1") = giveup "upgrade from v1 on Windows not supported"+	up (RepoVersion 0) = giveup "upgrade from v0 on Windows not supported"+	up (RepoVersion 1) = giveup "upgrade from v1 on Windows not supported" #endif-	go (Just "2") = Upgrade.V2.upgrade-	go (Just "3") = Upgrade.V3.upgrade automatic-	go (Just "4") = Upgrade.V4.upgrade automatic-	go (Just "5") = Upgrade.V5.upgrade automatic-	go _ = return True+	up (RepoVersion 2) = Upgrade.V2.upgrade+	up (RepoVersion 3) = Upgrade.V3.upgrade automatic+	up (RepoVersion 4) = Upgrade.V4.upgrade automatic+	up (RepoVersion 5) = Upgrade.V5.upgrade automatic+	up (RepoVersion 6) = Upgrade.V6.upgrade automatic+	up _ = return True

@@ -56,7 +56,7 @@ 		{- Create adjusted branch where all files are unlocked. 		 - This should have the same content for each file as 		 - have been staged in upgradeDirectWorkTree. -}-		AdjBranch b <- adjustBranch UnlockAdjustment cur+		AdjBranch b <- adjustBranch (LinkAdjustment UnlockAdjustment) cur 		{- Since the work tree was already set up by 		 - upgradeDirectWorkTree, and contains unlocked file 		 - contents too, don't use git checkout to check out the

@@ -0,0 +1,21 @@+{- git-annex v6 -> v7 upgrade support+ -+ - Copyright 2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Upgrade.V6 where++import Annex.Common+import Config+import Annex.Hook++upgrade :: Bool -> Annex Bool+upgrade automatic = do+	unless automatic $+		showAction "v6 to v7"+	unlessM isBareRepo $ do+		hookWrite postCheckoutHook+		hookWrite postMergeHook+	return True

@@ -11,7 +11,7 @@  import Common -#if defined(linux_HOST_OS) || defined(__ANDROID__)+#if defined(linux_HOST_OS) import Control.Concurrent.Async import System.Posix.Process #endif@@ -29,7 +29,7 @@  - systems, the action is simply ran.  -} batch :: IO a -> IO a-#if defined(linux_HOST_OS) || defined(__ANDROID__)+#if defined(linux_HOST_OS) batch a = wait =<< batchthread   where 	batchthread = asyncBound $ do@@ -51,11 +51,7 @@ #ifndef mingw32_HOST_OS 	nicers <- filterM (inPath . fst) 		[ ("nice", [])-#ifndef __ANDROID__-		-- Android's ionice does not allow specifying a command,-		-- so don't use it. 		, ("ionice", ["-c3"])-#endif 		, ("nocache", []) 		] 	return $ \(command, params) ->

@@ -5,8 +5,6 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP #-}- module Utility.CopyFile ( 	copyFileExternal, 	createLinkOrCopy,@@ -32,7 +30,6 @@ 		removeFile dest 	boolSystem "cp" $ params ++ [File src, File dest]   where-#ifndef __ANDROID__ 	params = map snd $ filter fst 		[ (BuildInfo.cp_reflink_auto, Param "--reflink=auto") 		, (allmeta && BuildInfo.cp_a, Param "-a")@@ -41,9 +38,6 @@ 		, (not allmeta && BuildInfo.cp_preserve_timestamps 			, Param "--preserve=timestamps") 		]-#else-	params = if allmeta then [] else []-#endif 	allmeta = meta == CopyAllMetaData  {- Create a hard link if the filesystem allows it, and fall back to copying

@@ -13,8 +13,6 @@ 	getDiskSize ) where -#ifndef __ANDROID__- import System.DiskSpace import Utility.Applicative import Utility.Exception@@ -24,15 +22,3 @@  getDiskSize :: FilePath -> IO (Maybe Integer) getDiskSize = fmap diskTotal <$$> catchMaybeIO . getDiskUsage--#else--#warning Building without disk free space checking support--getDiskFree :: FilePath -> IO (Maybe Integer)-getDiskFree _ = return Nothing--getDiskSize :: FilePath -> IO (Maybe Integer)-getDiskSize _ = return Nothing--#endif

@@ -5,7 +5,7 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Exception (@@ -29,11 +29,7 @@ import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException)-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) import Control.Exception (SomeAsyncException)-#endif-#endif import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType)@@ -46,15 +42,7 @@  - where there's a problem that the user is excpected to see in some  - circumstances. -} giveup :: [Char] -> a-#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,9,0) giveup = errorWithoutStackTrace-#else-giveup = error-#endif-#else-giveup = error-#endif  {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool@@ -95,11 +83,7 @@ catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` 	[ M.Handler (\ (e :: AsyncException) -> throwM e)-#ifdef MIN_VERSION_GLASGOW_HASKELL-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0) 	, M.Handler (\ (e :: SomeAsyncException) -> throwM e)-#endif-#endif 	, M.Handler (\ (e :: SomeException) -> onerr e) 	] 

@@ -1,12 +1,13 @@ {- Caching a file's inode, size, and modification time  - to see when it's changed.  -- - Copyright 2013-2014 Joey Hess <id@joeyh.name>+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Utility.InodeCache (@@ -38,14 +39,20 @@ ) where  import Common-import System.PosixCompat.Types+import Utility.TimeStamp import Utility.QuickCheck +import System.PosixCompat.Types+import Data.Time.Clock.POSIX+ #ifdef mingw32_HOST_OS import Data.Word (Word64)+import System.Directory+#else+import System.Posix.Files #endif -data InodeCachePrim = InodeCachePrim FileID Integer EpochTime+data InodeCachePrim = InodeCachePrim FileID FileSize MTime 	deriving (Show, Eq, Ord)  newtype InodeCache = InodeCache InodeCachePrim@@ -65,14 +72,14 @@  - due to some filesystems being remounted.  -  - The weak mtime comparison treats any mtimes that are within 2 seconds- - of one-anther as the same. This is because FAT has only a 2 second+ - of one-another as the same. This is because FAT has only a 2 second  - resolution. When a FAT filesystem is used on Linux, higher resolution- - timestamps are cached and used by Linux, but this is lost on unmount,- - so after a remount, the timestamp can appear to have changed.+ - timestamps maybe be are cached and used by Linux, but they are lost+ - on unmount, so after a remount, the timestamp can appear to have changed.  -} compareWeak :: InodeCache -> InodeCache -> Bool compareWeak (InodeCache (InodeCachePrim _ size1 mtime1)) (InodeCache (InodeCachePrim _ size2 mtime2)) =-	size1 == size2 && (abs (mtime1 - mtime2) < 2)+	size1 == size2 && (abs (lowResTime mtime1 - lowResTime mtime2) < 2)  compareBy :: InodeComparisonType -> InodeCache -> InodeCache -> Bool compareBy Strongly = compareStrong@@ -90,24 +97,67 @@ inodeCacheToKey :: InodeComparisonType -> InodeCache -> InodeCacheKey  inodeCacheToKey ct (InodeCache prim) = InodeCacheKey ct prim -inodeCacheToMtime :: InodeCache -> EpochTime-inodeCacheToMtime (InodeCache (InodeCachePrim _ _ mtime)) = mtime+inodeCacheToMtime :: InodeCache -> POSIXTime+inodeCacheToMtime (InodeCache (InodeCachePrim _ _ mtime)) = highResTime mtime +{- For backwards compatability, support low-res mtime with no+ - fractional seconds. -}+data MTime = MTimeLowRes EpochTime | MTimeHighRes POSIXTime+	deriving (Show, Ord)++{- A low-res time compares equal to any high-res time in the same second. -}+instance Eq MTime where+	MTimeLowRes a == MTimeLowRes b = a == b+	MTimeHighRes a == MTimeHighRes b = a == b+	MTimeHighRes a == MTimeLowRes b = lowResTime a == b+	MTimeLowRes a == MTimeHighRes b = a == lowResTime b++class MultiResTime t where+	lowResTime :: t -> EpochTime+	highResTime :: t -> POSIXTime++instance MultiResTime EpochTime where+	lowResTime = id+	highResTime = realToFrac++instance MultiResTime POSIXTime where+	lowResTime = fromInteger . floor+	highResTime = id++instance MultiResTime MTime where+	lowResTime (MTimeLowRes t) = t+	lowResTime (MTimeHighRes t) = lowResTime t+	highResTime (MTimeLowRes t) = highResTime t+	highResTime (MTimeHighRes t) = t+ showInodeCache :: InodeCache -> String-showInodeCache (InodeCache (InodeCachePrim inode size mtime)) = unwords-	[ show inode-	, show size-	, show mtime-	]+showInodeCache (InodeCache (InodeCachePrim inode size (MTimeHighRes mtime))) = +	let (t, d) = separate (== '.') (takeWhile (/= 's') (show mtime))+	in unwords+		[ show inode+		, show size+		, t+		, d+		]+showInodeCache (InodeCache (InodeCachePrim inode size (MTimeLowRes mtime))) =+	unwords+		[ show inode+		, show size+		, show mtime+		]  readInodeCache :: String -> Maybe InodeCache readInodeCache s = case words s of-	(inode:size:mtime:_) ->-		let prim = InodeCachePrim-			<$> readish inode-			<*> readish size-			<*> readish mtime-		in InodeCache <$> prim+	(inode:size:mtime:[]) -> do+		i <- readish inode+		sz <- readish size+		t <- readish mtime+		return $ InodeCache $ InodeCachePrim i sz (MTimeLowRes t)+	(inode:size:mtime:mtimedecimal:_) -> do+		i <- readish inode+		sz <- readish size+		t <- parsePOSIXTime' mtime mtimedecimal+		return $ InodeCache $ InodeCachePrim i sz (MTimeHighRes t) 	_ -> Nothing  genInodeCache :: FilePath -> TSDelta -> IO (Maybe InodeCache)@@ -119,10 +169,12 @@ 	| isRegularFile s = do 		delta <- getdelta 		sz <- getFileSize' f s-		return $ Just $ InodeCache $ InodeCachePrim-			(fileID s)-			sz-			(modificationTime s + delta)+#ifdef mingw32_HOST_OS+		mtime <- MTimeHighRes . utcTimeToPOSIXSeconds <$> getModificationTime f+#else+ 		let mtime = (MTimeHighRes (modificationTimeHiRes s + highResTime delta))+#endif+		return $ Just $ InodeCache $ InodeCachePrim (fileID s) sz mtime 	| otherwise = pure Nothing  {- Some filesystem get new random inodes each time they are mounted.@@ -194,7 +246,7 @@ 			mnew <- gennewcache 			return $ case mnew of 				Just (InodeCache (InodeCachePrim _ _ currmtime)) ->-					oldmtime - currmtime+					lowResTime oldmtime - lowResTime currmtime 				Nothing -> 0 #else 		unchanged = oldinode == newinode && oldsize == newsize && oldmtime == newmtime@@ -210,9 +262,23 @@ 		let prim = InodeCachePrim 			<$> arbitrary 			<*> arbitrary-			-- timestamp cannot be negative-			<*> (abs . fromInteger <$> arbitrary)+			<*> arbitrary 		in InodeCache <$> prim++instance Arbitrary MTime where+	arbitrary = frequency+		-- timestamp is not usually negative+                [ (50, MTimeLowRes <$> (abs . fromInteger <$> arbitrary))+                , (50, MTimeHighRes <$> (abs <$> arbposixtime))+		]+	  where+		-- include fractional part, which the usual instance does not+		arbposixtime = do+			t <- arbitrary+			f <- arbitrary+			return $ if f == 0+				then t+				else t + recip f  #ifdef mingw32_HOST_OS instance Arbitrary FileID where

@@ -5,8 +5,6 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP #-}- module Utility.Lsof where  import Common@@ -54,13 +52,6 @@  type LsofParser = String -> [(FilePath, LsofOpenMode, ProcessInfo)] -parse :: LsofParser-#ifdef __ANDROID__-parse = parseDefault-#else-parse = parseFormatted-#endif- {- Parsing null-delimited output like:  -  - pPID\0cCMDLINE\0@@ -71,8 +62,8 @@  - Where each new process block is started by a pid, and a process can  - have multiple files open.  -}-parseFormatted :: LsofParser-parseFormatted s = bundle $ go [] $ lines s+parse :: LsofParser+parse s = bundle $ go [] $ lines s   where 	bundle = concatMap (\(fs, p) -> map (\(f, m) -> (f, m, p)) fs) @@ -110,14 +101,3 @@ 	splitnull = splitc '\0'  	parsefail = error $ "failed to parse lsof output: " ++ show s--{- Parses lsof's default output format. -}-parseDefault :: LsofParser-parseDefault = mapMaybe parseline . drop 1 . lines-  where-	parseline l = case words l of-		(command : spid : _user : _fd : _type : _device : _size : _node : rest) -> -			case readish spid of-				Nothing -> Nothing-				Just pid -> Just (unwords rest, OpenUnknown, ProcessInfo pid command)-		_ -> Nothing

@@ -5,7 +5,6 @@  - License: BSD-2-clause  -} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-}  module Utility.Mounts (getMounts, Mntent(..)) where@@ -16,11 +15,7 @@ import Utility.Exception  getMounts :: IO [Mntent] -#ifndef __ANDROID__ getMounts = System.MountPoints.getMounts 	-- That will crash when the linux build is running on Android, 	-- so fall back to this. 	`catchNonAsync` const System.MountPoints.getProcMounts-#else-getMounts = System.MountPoints.getProcMounts-#endif

@@ -38,8 +38,9 @@  {- Attempts to read a value from a String.  -- - Unlike Text.Read.readMaybe, this ignores leading/trailing whitespace,- - and throws away any trailing text after the part that can be read.+ - Unlike Text.Read.readMaybe, this ignores some trailing text+ - after the part that can be read. However, if the trailing text looks+ - like another readable value, it fails.  -} readish :: Read a => String -> Maybe a readish s = case reads s of

@@ -31,7 +31,7 @@ 	arbitrary = S.fromList <$> arbitrary #endif -{- Times before the epoch are excluded. -}+{- Times before the epoch are excluded, and no fraction is included. -} instance Arbitrary POSIXTime where 	arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral 

@@ -20,21 +20,11 @@ import System.FilePath #endif -shellPath_portable :: FilePath-shellPath_portable = "/bin/sh"--shellPath_local :: FilePath-#ifndef __ANDROID__-shellPath_local = shellPath_portable-#else-shellPath_local = "/system/bin/sh"-#endif--shebang_portable :: String-shebang_portable = "#!" ++ shellPath_portable+shellPath :: FilePath+shellPath = "/bin/sh" -shebang_local :: String-shebang_local = "#!" ++ shellPath_local+shebang :: String+shebang = "#!" ++ shellPath  -- | On Windows, shebang is not handled by the kernel, so to support -- shell scripts etc, have to look at the program being run and

@@ -18,10 +18,8 @@ #endif #ifndef mingw32_HOST_OS import System.Posix.Signals-#ifndef __ANDROID__ import System.Posix.Terminal #endif-#endif  newtype Seconds = Seconds { fromSeconds :: Int } 	deriving (Eq, Ord, Show)@@ -63,10 +61,8 @@ 	let check sig = void $ 		installHandler sig (CatchOnce $ putMVar lock ()) Nothing 	check softwareTermination-#ifndef __ANDROID__ 	whenM (queryTerminal stdInput) $ 		check keyboardSignal-#endif 	takeMVar lock #endif 

@@ -0,0 +1,45 @@+{- timestamp parsing and formatting+ -+ - Copyright 2015-2016 Joey Hess <id@joeyh.name>+ -+ - License: BSD-2-clause+ -}++{-# LANGUAGE CPP #-}++module Utility.TimeStamp where++import Utility.PartialPrelude+import Utility.Misc++import Data.Time.Clock.POSIX+import Data.Time+import Data.Ratio+#if ! MIN_VERSION_time(1,5,0)+import System.Locale+#endif++{- Parses how POSIXTime shows itself: "1431286201.113452s"+ - Also handles the format with no fractional seconds. -}+parsePOSIXTime :: String -> Maybe POSIXTime+parsePOSIXTime = uncurry parsePOSIXTime' . separate (== '.')++{- Parses the integral and decimal part of a POSIXTime -}+parsePOSIXTime' :: String -> String -> Maybe POSIXTime+parsePOSIXTime' sn sd = do+	n <- fromIntegral <$> readi sn+	let sd' = takeWhile (/= 's') sd+	if null sd'+		then return n+		else do+			d <- readi sd'+			let r = d % (10 ^ (length sd'))+			return $ if n < 0+				then n - fromRational r+				else n + fromRational r+  where+	readi :: String -> Maybe Integer+	readi = readish++formatPOSIXTime :: String -> POSIXTime -> String+formatPOSIXTime fmt t = formatTime defaultTimeLocale fmt (posixSecondsToUTCTime t)

@@ -1,6 +1,6 @@-{- More control over touching a file.+{- Portability shim for touching a file.  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -8,45 +8,36 @@ {-# LANGUAGE CPP #-}  module Utility.Touch (-	TimeSpec(..), 	touchBoth, 	touch ) where -#if ! defined(mingw32_HOST_OS) && ! defined(__ANDROID__)--#if MIN_VERSION_unix(2,7,0)+#if ! defined(mingw32_HOST_OS)  import System.Posix.Files-import System.Posix.Types--newtype TimeSpec = TimeSpec EpochTime+import Data.Time.Clock.POSIX  {- Changes the access and modification times of an existing file.-   Can follow symlinks, or not. Throws IO error on failure. -}-touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()-touchBoth file (TimeSpec atime) (TimeSpec mtime) follow-	| follow = setFileTimes file atime mtime-	| otherwise = setSymbolicLinkTimesHiRes file (realToFrac atime) (realToFrac mtime)+   Can follow symlinks, or not. -}+touchBoth :: FilePath -> POSIXTime -> POSIXTime -> Bool -> IO ()+touchBoth file atime mtime follow+	| follow = setFileTimesHiRes file atime mtime+	| otherwise = setSymbolicLinkTimesHiRes file atime mtime -touch :: FilePath -> TimeSpec -> Bool -> IO ()+{- Changes the access and modification times of an existing file+ - to the same value. Can follow symlinks, or not. -}+touch :: FilePath -> POSIXTime -> Bool -> IO () touch file mtime = touchBoth file mtime mtime  #else-import Utility.Touch.Old-#endif -#else--import System.PosixCompat--newtype TimeSpec = TimeSpec EpochTime+import Data.Time.Clock.POSIX  {- Noop for Windows -}-touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()+touchBoth :: FilePath -> POSIXTime -> POSIXTime -> Bool -> IO () touchBoth _ _ _ _ = return () -touch :: FilePath -> TimeSpec -> Bool -> IO ()+touch :: FilePath -> POSIXTime -> Bool -> IO () touch _ _ _ = return ()  #endif

@@ -1,123 +0,0 @@-{- Compatability interface for old version of unix, to be removed eventally.- -- - Copyright 2011 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--{-# LANGUAGE ForeignFunctionInterface, CPP #-}--module Utility.Touch.Old (-	TimeSpec(..),-	touchBoth,-	touch-) where--#include <sys/types.h>-#include <sys/stat.h>-#include <fcntl.h>-#include <sys/time.h>--#ifndef _BSD_SOURCE-#define _BSD_SOURCE-#endif--#if (defined UTIME_OMIT && defined UTIME_NOW && defined AT_FDCWD && defined AT_SYMLINK_NOFOLLOW)-#define use_utimensat 1--import Utility.FileSystemEncoding--import Control.Monad (when)-import Foreign-#endif--import Foreign.C--newtype TimeSpec = TimeSpec CTime--touchBoth :: FilePath -> TimeSpec -> TimeSpec -> Bool -> IO ()--touch :: FilePath -> TimeSpec -> Bool -> IO ()-touch file mtime = touchBoth file mtime mtime--#ifdef use_utimensat--at_fdcwd :: CInt-at_fdcwd = #const AT_FDCWD--at_symlink_nofollow :: CInt-at_symlink_nofollow = #const AT_SYMLINK_NOFOLLOW--instance Storable TimeSpec where-	-- use the larger alignment of the two types in the struct-	alignment _ = max sec_alignment nsec_alignment-	  where-		sec_alignment = alignment (1::CTime)-		nsec_alignment = alignment (1::CLong)-	sizeOf _ = #{size struct timespec}-	peek ptr = do-		sec <- #{peek struct timespec, tv_sec} ptr-		return $ TimeSpec sec-	poke ptr (TimeSpec sec) = do-		#{poke struct timespec, tv_sec} ptr sec-		#{poke struct timespec, tv_nsec} ptr (0 :: CLong)--{- While its interface is beastly, utimensat is in recent-   POSIX standards, unlike lutimes. -}-foreign import ccall "utimensat" -	c_utimensat :: CInt -> CString -> Ptr TimeSpec -> CInt -> IO CInt--touchBoth file atime mtime follow = -	allocaArray 2 $ \ptr ->-	withFilePath file $ \f -> do-		pokeArray ptr [atime, mtime]-		r <- c_utimensat at_fdcwd f ptr flags-		when (r /= 0) $ throwErrno "touchBoth"-  where-	flags-       		| follow = 0-		| otherwise = at_symlink_nofollow --#else-#if 0-{- Using lutimes is needed for BSD.- - - - TODO: test if lutimes is available. May have to do it in configure.- - TODO: TimeSpec uses a CTime, while tv_sec is a CLong. It is implementation- - dependent whether these are the same; need to find a cast that works.- - (Without the cast it works on linux i386, but- - maybe not elsewhere.)- -}--instance Storable TimeSpec where-	alignment _ = alignment (1::CLong)-	sizeOf _ = #{size struct timeval}-	peek ptr = do-		sec <- #{peek struct timeval, tv_sec} ptr-		return $ TimeSpec sec-	poke ptr (TimeSpec sec) = do-		#{poke struct timeval, tv_sec} ptr sec-		#{poke struct timeval, tv_usec} ptr (0 :: CLong) --foreign import ccall "utimes" -	c_utimes :: CString -> Ptr TimeSpec -> IO CInt-foreign import ccall "lutimes" -	c_lutimes :: CString -> Ptr TimeSpec -> IO CInt--touchBoth file atime mtime follow = -	allocaArray 2 $ \ptr ->-	withFilePath file $ \f -> do-		pokeArray ptr [atime, mtime]-		r <- syscall f ptr-		when (r /= 0) $-			throwErrno "touchBoth"-  where-	syscall-       		| follow = c_lutimes-		| otherwise = c_utimes--#else-#warning "utimensat and lutimes not available; building without symlink timestamp preservation support"-touchBoth _ _ _ _ = return ()-#endif-#endif

@@ -47,8 +47,8 @@ #endif  myUserGecos :: IO (Maybe String)--- userGecos crashes on Android and is not available on Windows.-#if defined(__ANDROID__) || defined(mingw32_HOST_OS)+-- userGecos is not available on Windows.+#if defined(mingw32_HOST_OS) myUserGecos = return Nothing #else myUserGecos = eitherToMaybe <$> myVal [] userGecos

@@ -30,9 +30,6 @@ import Blaze.ByteString.Builder (Builder) import Control.Arrow ((***)) import Control.Concurrent-#ifdef __ANDROID__-import Data.Endian-#endif  localhost :: HostName localhost = "localhost"@@ -42,11 +39,6 @@ #ifdef darwin_HOST_OS browserProc url = proc "open" [url] #else-#ifdef __ANDROID__--- Warning: The `am` command does not work very reliably on Android.-browserProc url = proc "am"-	["start", "-a", "android.intent.action.VIEW", "-d", url]-#else #ifdef mingw32_HOST_OS -- Warning: On Windows, no quoting or escaping of the url seems possible, -- so spaces in it will cause problems. One approach is to make the url@@ -57,7 +49,6 @@ browserProc url = proc "xdg-open" [url] #endif #endif-#endif  {- Binds to a socket on localhost, or possibly a different specified  - hostname or address, and runs a webapp on it.@@ -69,18 +60,10 @@ runWebApp tlssettings h app observer = withSocketsDo $ do 	sock <- getSocket h 	void $ forkIO $ go webAppSettings sock app	-	sockaddr <- fixSockAddr <$> getSocketName sock+	sockaddr <- getSocketName sock 	observer sockaddr   where 	go = (maybe runSettingsSocket (\ts -> runTLSSocket ts) tlssettings)--fixSockAddr :: SockAddr -> SockAddr-#ifdef __ANDROID__-{- On Android, the port is currently incorrectly returned in network- - byte order, which is wrong on little endian systems. -}-fixSockAddr (SockAddrInet (PortNum port) addr) = SockAddrInet (PortNum $ swapEndian port) addr-#endif-fixSockAddr addr = addr  -- disable buggy sloworis attack prevention code webAppSettings :: Settings

@@ -1,7 +1,6 @@ {- Yesod stuff, that's typically found in the scaffolded site.  -- - Also a bit of a compatability layer to make it easier to support yesod- - 1.1-1.4 in the same code base.+ - Also a bit of a compatability layer for older versions of yesod.  -  - Copyright 2012-2014 Joey Hess <id@joeyh.name>  -@@ -13,28 +12,17 @@ module Utility.Yesod  	( module Y 	, liftH-#ifndef __NO_TH__ 	, widgetFile 	, hamletTemplate-#endif-#if ! MIN_VERSION_yesod_core(1,2,20)-	, withUrlRenderer-#endif 	) where  import Yesod as Y import Yesod.Form.Bootstrap3 as Y hiding (bfs)-#ifndef __NO_TH__ import Yesod.Default.Util import Language.Haskell.TH.Syntax (Q, Exp) import Data.Default (def) import Text.Hamlet hiding (Html)-#endif-#if ! MIN_VERSION_yesod(1,4,0)-import Data.Text (Text)-#endif -#ifndef __NO_TH__ widgetFile :: String -> Q Exp widgetFile = widgetFileNoReload $ def 	{ wfsHamletSettings = defaultHamletSettings@@ -44,7 +32,6 @@  hamletTemplate :: FilePath -> FilePath hamletTemplate f = globFile "hamlet" f-#endif  {- Lift Handler to Widget -} #if MIN_VERSION_yesod_core(1,6,0)@@ -53,8 +40,3 @@ liftH :: Monad m => HandlerT site m a -> WidgetT site m a #endif liftH = handlerToWidget--#if ! MIN_VERSION_yesod_core(1,2,20)-withUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output-withUrlRenderer = giveUrlRenderer-#endif

@@ -24,7 +24,7 @@ (This is not the case however when a repository is in a filesystem not supporting symlinks, or is in direct mode.) To add a file to the annex in unlocked form, `git add` can be used instead -(that only works when the repository has annex.version 6 or higher).+(that only works in repository v7 or higher).  This command can also be used to add symbolic links, both symlinks to annexed content, and other symlinks.

@@ -4,7 +4,7 @@  # SYNOPSIS -git annex adjust `--unlock|--fix`+git annex adjust `--unlock|--fix|--hide-missing [--unlock|--fix]`  # DESCRIPTION @@ -20,10 +20,15 @@ usual. Any commits that you make will initially only be made to the adjusted branch.  -To propagate changes from the adjusted branch back to the original branch,+To propagate commits from the adjusted branch back to the original branch, and to other repositories, as well as to merge in changes from other-repositories, use `git annex sync`.+repositories, run `git annex sync`. +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.+ This command can only be used in a v6 git-annex repository.  # OPTIONS@@ -39,6 +44,26 @@   object directory. This can be useful if a repository is checked out in an   unusual way that prevents the symlinks committed to git from pointing at   the annex objects.++* `--hide-missing`++  Only include annexed files in the adjusted branch when their content+  is present.++  The adjusted branch is not immediately changed when content availability+  changes, so if you `git annex drop` files, they will become broken+  links in the usual way. And when files that were missing are copied into the+  repository from elsewhere, they won't immediatly become visible in the+  branch.+  +  To update the adjusted branch to reflect changes to content availability, +  run `git annex adjust --hide-missing` again.++  Despite missing files being hidden, `git annex sync --content` will+  still operate on them, and can be used to download missing+  files from remotes.++  This option can be combined with --unlock or --fix.  # SEE ALSO 

@@ -17,7 +17,7 @@ When in a view, updates metadata to reflect changes made to files in the view. -When in a repository that has not been upgraded to annex.version 6, +When in a repository that has not been upgraded to v7,  also handles injecting changes to unlocked files into the annex.   # SEE ALSO

@@ -6,11 +6,13 @@  git annex smudge [--clean] file +git annex smudge --update+ # DESCRIPTION  This command lets git-annex be used as a git filter driver which lets-annexed files in the git repository to be unlocked at all times, instead-of being symlinks.+annexed files in the git repository to be unlocked, instead+of being symlinks, and lets `git add` store files in the annex.  When adding a file with `git add`, the annex.largefiles config is consulted to decide if a given file should be added to git as-is,@@ -31,6 +33,16 @@  	* filter=annex 	.* !filter++The smudge filter does not provide git with the content of annexed files,+because that would be slow and triggers memory leaks in git. Instead,+it records which worktree files need to be updated, and +`git annex smudge --update` later updates the work tree to contain+the content. That is run by several git hooks, including post-checkout+and post-merge. However, a few git commands, notably `git stash` and+`git cherry-pick`, do not run any hooks, so after using those commands+you can manually run `git annex smudge --update` to update the working+tree.  # SEE ALSO 

@@ -70,15 +70,15 @@ * `--content`, `--no-content`    Normally, syncing does not transfer the contents of annexed files.-  The --content option causes the content of files in the work tree+  The --content option causes the content of annexed files   to also be uploaded and downloaded as necessary.    The `annex.synccontent` configuration can be set to true to make content   be synced by default. -  Normally this tries to get each annexed file in the work tree-  that the local repository  does not yet have, and then copies each-  file in the work tree to every remote that it is syncing with.+  Normally this tries to get each annexed file that the local repository+  does not yet have, and then copies each file to every remote that it+  is syncing with.   This behavior can be overridden by configuring the preferred content   of a repository. See [[git-annex-preferred-content]](1). @@ -88,7 +88,7 @@  * `--content-of=path` `-C path` -  While --content operates on all annexed files in the work tree,+  While --content operates on all annexed files,   --content-of allows limiting the transferred files to ones in a given   location. 

@@ -14,10 +14,10 @@ You can then modify it and `git annex add` (or `git commit`) to save your changes. -In repositories with annex.version 5 or earlier, unlocking a file is local-to the repository, and is temporary. With version 6, unlocking a file+In v5 repositories, unlocking a file is local+to the repository, and is temporary. In v7 repositories, unlocking a file changes how it is stored in the git repository (from a symlink to a pointer-file), so you can commit it like any other change. Also in version 6, you+file), so you can commit it like any other change. Also in v7, you can use `git add` to add a file to the annex in unlocked form. This allows workflows where a file starts out unlocked, is modified as necessary, and is locked once it reaches its final version.@@ -26,7 +26,7 @@ so that its original content is preserved, while the copy can be modified. To use less space, annex.thin can be set to true; this makes a hard link to the content be made instead of a copy. (Only when supported by the file-system, and only in repository version 6.) While this can save considerable+system, and only in v7 and higher.) While this can save considerable disk space, any modification made to a file will cause the old version of the file to be lost from the local repository. So, enable annex.thin with care. 

@@ -901,7 +901,7 @@    Set to true to make commands like `git-annex add` that add files to the   repository add them in unlocked form. The default is to add files in-  locked form. This only has effect in version 6 repositories.+  locked form. This only has effect in v7 repositories.    When a repository has core.symlinks set to false, it implicitly   sets annex.addunlocked to true.@@ -1024,18 +1024,16 @@ * `annex.thin`    Set this to `true` to make unlocked files be a hard link to their content-  in the annex, rather than a second copy. (Only when supported by the file-  system, and only in repository version 6.) This can save considerable+  in the annex, rather than a second copy. This can save considerable   disk space, but when a modification is made to a file, you will lose the   local (and possibly only) copy of the old version. So, enable with care.    After setting (or unsetting) this, you should run `git annex fix` to   fix up the annexed files in the work tree to be hard links (or copies).--  Note that `annex.thin` is not honored when git updates an annexed file-  in the working tree. So when `git checkout` or `git merge` updates the-  working tree, a second copy of annexed files will result. You can run-  `git-annex fix` to fix up the hard links after running such git commands.+ +  Note that this has no effect when the filesystem does not support hard links.+  And when multiple files in the work tree have the same content, only+  one of them gets hard linked to the annex.  * `annex.delayadd` 

@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20181011+Version: 7.20181031 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -218,7 +218,6 @@   templates/configurators/ssh/add.hamlet   templates/configurators/ssh/setupmodal.hamlet   templates/configurators/ssh/confirm.hamlet-  templates/configurators/upgrade/android.hamlet   templates/configurators/enableia.hamlet   templates/configurators/fsck.hamlet   templates/configurators/addrepository/archive.hamlet@@ -270,23 +269,12 @@ Flag Production   Description: Enable production build (slower build; faster binary) -Flag Android-  Description: Cross building for Android-  Default: False--Flag AndroidSplice-  Description: Building to get TH splices for Android-  Default: False- Flag TorrentParser   Description: Use haskell torrent library to parse torrent files  Flag MagicMime   Description: Use libmagic to determine file MIME types -Flag ConcurrentOutput-  Description: Use concurrent-output library- Flag Benchmark   Description: Enable benchmarking   Default: False@@ -299,18 +287,18 @@   location: git://git-annex.branchable.com/  custom-setup-  Setup-Depends: base (>= 4.6), hslogger, split, unix-compat, process,+  Setup-Depends: base (>= 4.9), hslogger, split, unix-compat, process,     filepath, exceptions, bytestring, directory, IfElse, data-default,     utf8-string, transformers, Cabal  Executable git-annex   Main-Is: git-annex.hs   Build-Depends:-   base (>= 4.6 && < 5.0),+   base (>= 4.9 && < 5.0),    network (>= 2.6.3.0),    network-uri (>= 2.6),    optparse-applicative (>= 0.11.0), -   containers (>= 0.5.0.0),+   containers (>= 0.5.7.1),    exceptions (>= 0.6),    stm (>= 2.3),    mtl (>= 2),@@ -324,6 +312,7 @@    SafeSemaphore,    async,    directory (>= 1.2),+   disk-free-space,    filepath,    IfElse,    hslogger,@@ -347,9 +336,10 @@    time,    old-locale,    esqueleto,-   persistent-sqlite, +   persistent-sqlite (>= 2.1.3),     persistent,    persistent-template,+   microlens,    aeson,    vector,    tagsoup,@@ -365,6 +355,7 @@    memory,    split,    attoparsec,+   concurrent-output (>= 1.6),    QuickCheck (>= 2.1),    tasty (>= 0.7),    tasty-hunit,@@ -381,11 +372,8 @@   if flag(Production)     -- Lower memory systems can run out of memory with -O2, so     -- optimise slightly less.-    -- This needs -O1 before the -optlo, due to this bug:-    -- https://ghc.haskell.org/trac/ghc/ticket/14821-    -- But unfortunately, hackage currently refuses to accept -O1     if arch(arm)-      GHC-Options: -optlo-O2+      GHC-Options: -O2 -optlo-O2     else       GHC-Options: -O2 @@ -401,9 +389,7 @@       setenv,       process (>= 1.6.2.0)   else-    Build-Depends: unix-    if impl(ghc <= 7.6.3)-      Other-Modules: Utility.Touch.Old+    Build-Depends: unix (>= 2.7.2)    if flag(S3)     Build-Depends: aws (>= 0.9.2)@@ -501,7 +487,7 @@       Utility.Mounts       Utility.OSX -    if os(linux) || flag(Android)+    if os(linux)       Build-Depends: hinotify       CPP-Options: -DWITH_INOTIFY       Other-Modules: Utility.DirWatcher.INotify@@ -529,30 +515,21 @@       CPP-Options: -DWITH_DBUS -DWITH_DESKTOP_NOTIFY -DWITH_DBUS_NOTIFICATIONS       Other-Modules: Utility.DBus -  if flag(Android)-    Build-Depends: data-endian-    CPP-Options: -D__ANDROID__ -DANDROID_SPLICES -D__NO_TH__-  else-    Build-Depends: disk-free-space--  if flag(AndroidSplice)-    CPP-Options: -DANDROID_SPLICES-   if flag(Webapp)     Build-Depends:-     yesod (>= 1.2.6), -     yesod-static (>= 1.2.4),-     yesod-form (>= 1.3.15),-     yesod-core (>= 1.2.19),-     path-pieces (>= 0.1.4),-     warp (>= 3.0.0.5),-     warp-tls (>= 1.4),+     yesod (>= 1.4.3), +     yesod-static (>= 1.5.1),+     yesod-form (>= 1.4.8),+     yesod-core (>= 1.4.25),+     path-pieces (>= 0.2.1),+     warp (>= 3.2.8),+     warp-tls (>= 3.2.2),      wai,      wai-extra,      blaze-builder,      clientsession,      template-haskell,-     shakespeare (>= 2.0.0)+     shakespeare (>= 2.0.11)     CPP-Options: -DWITH_WEBAPP     Other-Modules:       Command.WebApp@@ -605,10 +582,6 @@       Build-Depends: magic       CPP-Options: -DWITH_MAGICMIME -  if flag(ConcurrentOutput)-    Build-Depends: concurrent-output (>= 1.6)-    CPP-Options: -DWITH_CONCURRENTOUTPUT-   if flag(Benchmark)     Build-Depends: criterion, deepseq     CPP-Options: -DWITH_BENCHMARK@@ -618,6 +591,7 @@     Annex     Annex.Action     Annex.AdjustedBranch+    Annex.AdjustedBranch.Name     Annex.AutoMerge     Annex.BloomFilter     Annex.Branch@@ -633,6 +607,7 @@     Annex.Content.Direct     Annex.Content.LowLevel     Annex.Content.PointerFile+    Annex.CurrentBranch     Annex.Difference     Annex.DirHashes     Annex.Direct@@ -901,7 +876,7 @@     Logs.Schedule     Logs.SingleValue     Logs.SingleValue.Pure-    Logs.TimeStamp+    Logs.Smudge     Logs.Transfer     Logs.Transitions     Logs.Trust@@ -965,6 +940,7 @@     Test.Framework     Types     Types.ActionItem+    Types.AdjustedBranch     Types.Availability     Types.Backend     Types.BranchState@@ -989,6 +965,7 @@     Types.NumCopies     Types.RefSpec     Types.Remote+    Types.RepoVersion     Types.ScheduledActivity     Types.StandardGroups     Types.StoreRetrieve@@ -1005,6 +982,7 @@     Upgrade.V3     Upgrade.V4     Upgrade.V5+    Upgrade.V6     Utility.Aeson     Utility.Android     Utility.Applicative@@ -1081,6 +1059,7 @@     Utility.SshHost     Utility.Su     Utility.SystemDirectory+    Utility.TimeStamp     Utility.TList     Utility.Tense     Utility.ThreadLock

@@ -1,6 +1,5 @@ flags:   git-annex:-    concurrentoutput: true     production: true     assistant: true     pairing: true@@ -10,8 +9,6 @@     webapp: true     magicmime: false     dbus: false-    android: false-    androidsplice: false packages: - '.' extra-deps:

@@ -1,10 +0,0 @@-<div .col-sm-9>-  <div .content-box>-    <h2>-      Upgrading git-annex-    <p>-      To start the upgrade #-      <a .btn .btn-primary href="#{url}">-        Download #{takeFileName url}-    <p>-      Once the download is complete, open the file to upgrade git-annex.

@@ -16,9 +16,8 @@               #{name}       $maybe reldir <- relDir webapp         <ul .nav .navbar-nav .navbar-right>-          $if hasFileBrowser-            <li>-              ^{actionButton FileBrowserR (Just "Files") (Just "Click to open a file browser") "" "glyphicon-folder-open icon-white"}+          <li>+            ^{actionButton FileBrowserR (Just "Files") (Just "Click to open a file browser") "" "glyphicon-folder-open icon-white"}           <li .dropdown #menu1>             <a .dropdown-toggle data-toggle="dropdown" href="#menu1">               Repository: #{reldir}