packages feed

git-annex 6.20180807 → 6.20180913

raw patch · 90 files changed

+1558/−830 lines, 90 filesdep +attoparsecdep −dns

Dependencies added: attoparsec

Dependencies removed: dns

Files

Annex.hs view
@@ -73,6 +73,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM+import qualified Control.Concurrent.SSem as SSem import qualified Data.Map.Strict as M import qualified Data.Set as S @@ -111,6 +112,7 @@ 	, daemon :: Bool 	, branchstate :: BranchState 	, repoqueue :: Maybe Git.Queue.Queue+	, repoqueuesem :: SSem.SSem 	, catfilehandles :: M.Map FilePath CatFileHandle 	, hashobjecthandle :: Maybe HashObjectHandle 	, checkattrhandle :: Maybe CheckAttrHandle@@ -153,6 +155,7 @@ 	emptyactivekeys <- newTVarIO M.empty 	o <- newMessageState 	sc <- newTMVarIO False+	qsem <- SSem.new 1 	return $ AnnexState 		{ repo = r 		, repoadjustment = return@@ -168,6 +171,7 @@ 		, daemon = False 		, branchstate = startBranchState 		, repoqueue = Nothing+		, repoqueuesem = qsem 		, catfilehandles = M.empty 		, hashobjecthandle = Nothing 		, checkattrhandle = Nothing
Annex/AdjustedBranch.hs view
@@ -270,7 +270,7 @@ preventCommits = bracket setup cleanup   where 	setup = do-		lck <- fromRepo indexFileLock+		lck <- fromRepo $ indexFileLock . indexFile 		liftIO $ Git.LockFile.openLock lck 	cleanup = liftIO . Git.LockFile.closeLock
Annex/Branch/Transitions.hs view
@@ -1,6 +1,6 @@ {- git-annex branch transitions  -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -15,10 +15,13 @@ import qualified Logs.UUIDBased as UUIDBased import qualified Logs.Presence.Pure as Presence import qualified Logs.Chunk.Pure as Chunk+import qualified Logs.MetaData.Pure as MetaData import Types.TrustLevel import Types.UUID+import Types.MetaData  import qualified Data.Map as M+import qualified Data.Set as S import Data.Default  data FileTransition@@ -49,16 +52,27 @@ 		in if null newlog 			then RemoveFile 			else ChangeFile $ Presence.showLog newlog+	Just RemoteMetaDataLog ->+		let newlog = dropDeadFromRemoteMetaDataLog trustmap $ MetaData.simplifyLog $ MetaData.parseLog content+		in if S.null newlog+			then RemoveFile+			else ChangeFile $ MetaData.showLog newlog 	Just OtherLog -> PreserveFile 	Nothing -> PreserveFile  dropDeadFromMapLog :: TrustMap -> (k -> UUID) -> M.Map k v -> M.Map k v-dropDeadFromMapLog trustmap getuuid = M.filterWithKey $ \k _v -> notDead trustmap getuuid k+dropDeadFromMapLog trustmap getuuid =+	M.filterWithKey $ \k _v -> notDead trustmap getuuid k  {- Presence logs can contain UUIDs or other values. Any line that matches  - a dead uuid is dropped; any other values are passed through. -} dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine]-dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info)+dropDeadFromPresenceLog trustmap =+	filter $ notDead trustmap (toUUID . Presence.info)++dropDeadFromRemoteMetaDataLog :: TrustMap -> MetaData.Log MetaData -> MetaData.Log MetaData+dropDeadFromRemoteMetaDataLog trustmap =+	MetaData.filterOutEmpty . MetaData.filterRemoteMetaData (notDead trustmap id)  notDead :: TrustMap -> (v -> UUID) -> v -> Bool notDead trustmap a v = M.findWithDefault def (a v) trustmap /= DeadTrusted
Annex/CatFile.hs view
@@ -13,6 +13,7 @@ 	catCommit, 	catObjectDetails, 	catFileHandle,+	catObjectMetaData, 	catFileStop, 	catKey, 	catKeyFile,
Annex/Concurrent.hs view
@@ -41,9 +41,13 @@ dupState :: Annex AnnexState dupState = do 	st <- Annex.getState id-	-- avoid sharing eg, open file handles 	return $ st 		{ Annex.workers = []+		-- each thread has its own repoqueue, but the repoqueuesem+		-- is shared to prevent more than one thread flushing its+		-- queue at the same time+		, Annex.repoqueue = Nothing+		-- avoid sharing eg, open file handles 		, Annex.catfilehandles = M.empty 		, Annex.checkattrhandle = Nothing 		, Annex.checkignorehandle = Nothing
Annex/Content.hs view
@@ -54,7 +54,6 @@ ) where  import System.IO.Unsafe (unsafeInterleaveIO)-import System.PosixCompat.Files import qualified Data.Set as S  import Annex.Common@@ -65,10 +64,8 @@ import qualified Annex import qualified Annex.Queue import qualified Annex.Branch-import Utility.DiskFree import Utility.FileMode import qualified Annex.Url as Url-import Utility.DataUnits import Utility.CopyFile import Utility.Metered import Config@@ -89,6 +86,8 @@ import Annex.UUID import Annex.InodeSentinal import Utility.InodeCache+import Annex.Content.LowLevel+import Annex.Content.PointerFile  {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool@@ -453,56 +452,11 @@ 	pruneTmpWorkDirBefore tmp (liftIO . nukeFile) 	return res -{- Checks that there is disk space available to store a given key,- - in a destination directory (or the annex) printing a warning if not. - -- - If the destination is on the same filesystem as the annex,- - checks for any other running downloads, removing the amount of data still- - to be downloaded from the free space. This way, we avoid overcommitting- - when doing concurrent downloads.- -}-checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool-checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (keySize key)) destdir key--{- Allows specifying the size of the key, if it's known, which is useful- - as not all keys know their size. -}-checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool-checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force)-	( return True-	, do-		-- We can't get inprogress and free at the same-		-- time, and both can be changing, so there's a-		-- small race here. Err on the side of caution-		-- by getting inprogress first, so if it takes-		-- a while, we'll see any decrease in the free-		-- disk space.-		inprogress <- if samefilesystem-			then sizeOfDownloadsInProgress (/= key)-			else pure 0-		dir >>= liftIO . getDiskFree >>= \case-			Just have -> do-				reserve <- annexDiskReserve <$> Annex.getGitConfig-				let delta = need + reserve - have - alreadythere + inprogress-				let ok = delta <= 0-				unless ok $-					warning $ needMoreDiskSpace delta-				return ok-			_ -> return True-	)-  where-	dir = maybe (fromRepo gitAnnexDir) return destdir--needMoreDiskSpace :: Integer -> String-needMoreDiskSpace n = "not enough free space, need " ++ -	roughSize storageUnits True n ++ " more" ++ forcemsg-  where-	forcemsg = " (use --force to override this check or adjust annex.diskreserve)"- {- Moves a key's content into .git/annex/objects/  -  - When a key has associated pointer files, the object is hard  - linked (or copied) to the files, and the object file is left thawed.- + -   - In direct mode, moves the object file to the associated file, or files.  -  - What if the key there already has content? This could happen for@@ -545,8 +499,8 @@ 			fs <- map (`fromTopFilePath` g) 				<$> Database.Keys.getAssociatedFiles key 			unless (null fs) $ do-				mapM_ (populatePointerFile key dest) fs-				Database.Keys.storeInodeCaches key (dest:fs)+				ics <- mapM (populatePointerFile (Restage True) key dest) fs+				Database.Keys.storeInodeCaches' key [dest] (catMaybes ics) 		) 	storeindirect = storeobject =<< calcRepo (gitAnnexLocation key) @@ -586,18 +540,6 @@ 		, return True 		) -populatePointerFile :: Key -> FilePath -> FilePath -> Annex ()-populatePointerFile k obj f = go =<< liftIO (isPointerFile f)-  where-	go (Just k') | k == k' = do-		destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f-		liftIO $ nukeFile f-		ifM (linkOrCopy k obj f destmode)-			( thawContent f-			, liftIO $ writePointerFile f k destmode-			)-	go _ = return ()- data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop  {- Populates the annex object file by hard linking or copying a source@@ -622,12 +564,13 @@ {- Hard links or copies from or to the annex object location.   - Updates inode cache.  -- - Thaws the file that is not the annex object.- - When a hard link was made, this necessarily thaws- - the annex object too. So, adding an object to the annex this- - way can prevent losing the content if the source file- - is deleted, but does not guard against modifications.+ - Freezes or thaws the destination appropriately.  -+ - When a hard link is made, the annex object necessarily has to be thawed+ - too. So, adding an object to the annex with a hard link can prevent+ - losing the content if the source file is deleted, but does not+ - guard against modifications.+ -  - Nothing is done if the destination file already exists.  -} linkAnnex :: FromTo -> Key -> FilePath -> Maybe InodeCache -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult@@ -640,14 +583,15 @@ 				then Database.Keys.addInodeCaches key [srcic, destic] 				else Database.Keys.addInodeCaches key [srcic] 			return LinkAnnexNoop-		Nothing -> ifM (linkOrCopy key src dest destmode)-			( do-				thawContent $ case fromto of-					From -> dest-					To -> src+		Nothing -> linkOrCopy key src dest destmode >>= \case+			Nothing -> failed+			Just r -> do+				case fromto of+					From -> thawContent dest+					To -> case r of+						Copied -> freezeContent dest+						Linked -> noop 				checksrcunchanged-			, failed-			)   where 	failed = do 		Database.Keys.addInodeCaches key [srcic]@@ -662,40 +606,6 @@ 			liftIO $ nukeFile dest 			failed -{- Hard links or copies src to dest, which must not already exists.- -- - Only uses a hard link when annex.thin is enabled and when src is- - not already hardlinked to elsewhere.- -- - Checks disk reserve before copying against the size of the key,- - and will fail if not enough space, or if the dest file already exists.- -- - The FileMode, if provided, influences the mode of the dest file.- - In particular, if it has an execute bit set, the dest file's- - execute bit will be set. The mode is not fully copied over because- - git doesn't support file modes beyond execute.- -}-linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool-linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig)--linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool-linkOrCopy' canhardlink key src dest destmode-	| maybe False isExecutable destmode = copy =<< getstat-	| otherwise = catchBoolIO $-		ifM canhardlink-			( hardlink-			, copy =<< getstat-			)-  where-	hardlink = do-		s <- getstat-		if linkCount s > 1-			then copy s-			else liftIO (createLink src dest >> preserveGitMode dest destmode >> return True)-				`catchIO` const (copy s)-	copy = checkedCopyFile' key src dest destmode-	getstat = liftIO $ getFileStatus src- {- Removes the annex object file for a key. Lowlevel. -} unlinkAnnex :: Key -> Annex () unlinkAnnex key = do@@ -704,31 +614,6 @@ 		secureErase obj 		liftIO $ nukeFile obj -{- Checks disk space before copying. -}-checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool-checkedCopyFile key src dest destmode = catchBoolIO $-	checkedCopyFile' key src dest destmode-		=<< liftIO (getFileStatus src)--checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool-checkedCopyFile' key src dest destmode s = catchBoolIO $-	ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True)-		( liftIO $-			copyFileExternal CopyAllMetaData src dest-				<&&> preserveGitMode dest destmode-		, return False-		)--preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool-preserveGitMode f (Just mode)-	| isExecutable mode = catchBoolIO $ do-		modifyFileMode f $ addModes executeModes-		return True-	| otherwise = catchBoolIO $ do-		modifyFileMode f $ removeModes executeModes-		return True-preserveGitMode _ _ = return True- {- Runs an action to transfer an object's content.  -  - In some cases, it's possible for the file to change as it's being sent.@@ -816,12 +701,6 @@ 			<=< catchMaybeIO $ removeDirectory dir  {- Removes a key's file from .git/annex/objects/- -- - When a key has associated pointer files, they are checked for- - modifications, and if unmodified, are reset.- -- - In direct mode, deletes the associated files or files, and replaces- - them with symlinks.  -} removeAnnex :: ContentRemovalLock -> Annex () removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect@@ -834,22 +713,25 @@ 			=<< Database.Keys.getAssociatedFiles key 		Database.Keys.removeInodeCaches key 		Direct.removeInodeCache key+ +	-- Check associated pointer file for modifications, and reset if+	-- it's unmodified. 	resetpointer file = ifM (isUnmodified key file)-		( do-			mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file-			secureErase file-			liftIO $ nukeFile file-			liftIO $ writePointerFile file key mode-		-- Can't delete the pointer file.+		( depopulatePointerFile key file+		-- Modified file, so leave it alone. 		-- If it was a hard link to the annex object, 		-- that object might have been frozen as part of the 		-- removal process, so thaw it. 		, void $ tryIO $ thawContent file 		)++	-- In direct mode, deletes the associated files or files, and replaces+	-- them with symlinks. 	removedirect fs = do 		cache <- Direct.recordedInodeCache key 		Direct.removeInodeCache key 		mapM_ (resetfile cache) fs+	 	resetfile cache f = whenM (Direct.sameInodeCache f cache) $ do 		l <- calcRepo $ gitAnnexLink f key 		secureErase f@@ -874,16 +756,6 @@ 		, return False 		) 	geti = withTSDelta (liftIO . genInodeCache f)--{- Runs the secure erase command if set, otherwise does nothing.- - File may or may not be deleted at the end; caller is responsible for- - making sure it's deleted. -}-secureErase :: FilePath -> Annex ()-secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig-  where-	go basecmd = void $ liftIO $-		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]-	gencmd = massReplace [ ("%file", shellEscape file) ]  {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and  - returns the file it was moved to. -}
+ Annex/Content/LowLevel.hs view
@@ -0,0 +1,139 @@+{- git-annex low-level content functions+ -+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Annex.Content.LowLevel where++import System.PosixCompat.Files++import Annex.Common+import Logs.Transfer+import qualified Annex+import Utility.DiskFree+import Utility.FileMode+import Utility.DataUnits+import Utility.CopyFile++{- Runs the secure erase command if set, otherwise does nothing.+ - File may or may not be deleted at the end; caller is responsible for+ - making sure it's deleted. -}+secureErase :: FilePath -> Annex ()+secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig+  where+	go basecmd = void $ liftIO $+		boolSystem "sh" [Param "-c", Param $ gencmd basecmd]+	gencmd = massReplace [ ("%file", shellEscape file) ]++data LinkedOrCopied = Linked | Copied++{- Hard links or copies src to dest, which must not already exist.+ -+ - Only uses a hard link when annex.thin is enabled and when src is+ - not already hardlinked to elsewhere.+ -+ - Checks disk reserve before copying against the size of the key,+ - and will fail if not enough space, or if the dest file already exists.+ -+ - The FileMode, if provided, influences the mode of the dest file.+ - In particular, if it has an execute bit set, the dest file's+ - execute bit will be set. The mode is not fully copied over because+ - git doesn't support file modes beyond execute.+ -}+linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex (Maybe LinkedOrCopied)+linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig)++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+			, copy =<< getstat+			)+  where+	hardlink = do+		s <- getstat+		if linkCount s > 1+			then copy s+			else liftIO (createLink src dest >> preserveGitMode dest destmode >> return (Just Linked))+				`catchIO` const (copy s)+	copy s = ifM (checkedCopyFile' key src dest destmode s)+		( return (Just Copied)+		, return Nothing+		)+	getstat = liftIO $ getFileStatus src++{- Checks disk space before copying. -}+checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool+checkedCopyFile key src dest destmode = catchBoolIO $+	checkedCopyFile' key src dest destmode+		=<< liftIO (getFileStatus src)++checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool+checkedCopyFile' key src dest destmode s = catchBoolIO $+	ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True)+		( liftIO $+			copyFileExternal CopyAllMetaData src dest+				<&&> preserveGitMode dest destmode+		, return False+		)++preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool+preserveGitMode f (Just mode)+	| isExecutable mode = catchBoolIO $ do+		modifyFileMode f $ addModes executeModes+		return True+	| otherwise = catchBoolIO $ do+		modifyFileMode f $ removeModes executeModes+		return True+preserveGitMode _ _ = return True++{- Checks that there is disk space available to store a given key,+ - in a destination directory (or the annex) printing a warning if not. + -+ - If the destination is on the same filesystem as the annex,+ - checks for any other running downloads, removing the amount of data still+ - to be downloaded from the free space. This way, we avoid overcommitting+ - when doing concurrent downloads.+ -}+checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool+checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (keySize key)) destdir key++{- Allows specifying the size of the key, if it's known, which is useful+ - as not all keys know their size. -}+checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool+checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force)+	( return True+	, do+		-- We can't get inprogress and free at the same+		-- time, and both can be changing, so there's a+		-- small race here. Err on the side of caution+		-- by getting inprogress first, so if it takes+		-- a while, we'll see any decrease in the free+		-- disk space.+		inprogress <- if samefilesystem+			then sizeOfDownloadsInProgress (/= key)+			else pure 0+		dir >>= liftIO . getDiskFree >>= \case+			Just have -> do+				reserve <- annexDiskReserve <$> Annex.getGitConfig+				let delta = need + reserve - have - alreadythere + inprogress+				let ok = delta <= 0+				unless ok $+					warning $ needMoreDiskSpace delta+				return ok+			_ -> return True+	)+  where+	dir = maybe (fromRepo gitAnnexDir) return destdir++needMoreDiskSpace :: Integer -> String+needMoreDiskSpace n = "not enough free space, need " ++ +	roughSize storageUnits True n ++ " more" ++ forcemsg+  where+	forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
+ Annex/Content/PointerFile.hs view
@@ -0,0 +1,57 @@+{- git-annex pointer files+ -+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Annex.Content.PointerFile where++import System.PosixCompat.Files++import Annex.Common+import Annex.Perms+import Annex.Link+import Annex.ReplaceFile+import Annex.InodeSentinal+import Utility.InodeCache+import Annex.Content.LowLevel++{- Populates a pointer file with the content of a key. + -+ - If the file already has some other content, it is not modified.+ -+ - Returns an InodeCache if it populated the pointer file.+ -}+populatePointerFile :: Restage -> Key -> FilePath -> FilePath -> Annex (Maybe InodeCache)+populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)+  where+	go (Just k') | k == k' = do+		destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f+		liftIO $ nukeFile f+		(ic, populated) <- replaceFile f $ \tmp -> do+			ok <- linkOrCopy k obj tmp destmode >>= \case+				Just _ -> thawContent tmp >> return True+				Nothing -> liftIO (writePointerFile tmp k destmode) >> return False+			ic <- withTSDelta (liftIO . genInodeCache tmp)+			return (ic, ok)+		maybe noop (restagePointerFile restage f) ic+		if populated+			then return ic+			else return Nothing+	go _ = return Nothing+	+{- Removes the content from a pointer file, replacing it with a pointer.+ -+ - Does not check if the pointer file is modified. -}+depopulatePointerFile :: Key -> FilePath -> Annex ()+depopulatePointerFile key file = do+	mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file+	secureErase file+	liftIO $ nukeFile file+	ic <- replaceFile file $ \tmp -> do+		liftIO $ writePointerFile tmp key mode+		withTSDelta (liftIO . genInodeCache tmp)+	maybe noop (restagePointerFile (Restage True) file) ic
Annex/Direct.hs view
@@ -164,7 +164,7 @@ mergeDirect :: Maybe Git.Ref -> Maybe Git.Ref -> Git.Branch -> Annex Bool -> [Git.Merge.MergeConfig] -> Git.Branch.CommitMode -> Annex Bool mergeDirect startbranch oldref branch resolvemerge mergeconfig commitmode = exclusively $ do 	reali <- liftIO . absPath =<< fromRepo indexFile-	tmpi <- liftIO . absPath =<< fromRepo indexFileLock+	tmpi <- liftIO . absPath =<< fromRepo (indexFileLock . indexFile) 	liftIO $ whenM (doesFileExist reali) $ 		copyFile reali tmpi
Annex/Drop.hs view
@@ -11,7 +11,7 @@ import qualified Annex import Logs.Trust import Annex.NumCopies-import Types.Remote (uuid)+import Types.Remote (uuid, appendonly) import qualified Remote import qualified Command.Drop import Command@@ -29,6 +29,9 @@ {- Drop a key from local and/or remote when allowed by the preferred content  - and numcopies settings.  -+ - Skips trying to drop from remotes that are appendonly, since those drops+ - would presumably fail.+ -  - The UUIDs are ones where the content is believed to be present.  - The Remote list can include other remotes that do not have the content;  - only ones that match the UUIDs will be dropped from.@@ -58,9 +61,10 @@ 		AssociatedFile (Just f) -> nub (f : l) 		AssociatedFile Nothing -> l 	n <- getcopies fs+	let rs' = filter (not . appendonly) rs 	void $ if fromhere && checkcopies n Nothing-		then go fs rs n >>= dropl fs-		else go fs rs n+		then go fs rs' n >>= dropl fs+		else go fs rs' n   where 	getcopies fs = do 		(untrusted, have) <- trustPartition UnTrusted locs
Annex/FileMatcher.hs view
@@ -10,6 +10,7 @@ module Annex.FileMatcher ( 	GetFileMatcher, 	checkFileMatcher,+	checkFileMatcher', 	checkMatcher, 	matchAll, 	preferredContentParser,@@ -42,17 +43,25 @@ type GetFileMatcher = FilePath -> Annex (FileMatcher Annex)  checkFileMatcher :: GetFileMatcher -> FilePath -> Annex Bool-checkFileMatcher getmatcher file = do+checkFileMatcher getmatcher file = checkFileMatcher' getmatcher file (return True)++-- | Allows running an action when no matcher is configured for the file.+checkFileMatcher' :: GetFileMatcher -> FilePath -> Annex Bool -> Annex Bool+checkFileMatcher' getmatcher file notconfigured = do 	matcher <- getmatcher file-	checkMatcher matcher Nothing (AssociatedFile (Just file)) S.empty True+	checkMatcher matcher Nothing afile S.empty notconfigured d+  where+	afile = AssociatedFile (Just file)+	-- checkMatcher will never use this, because afile is provided.+	d = return True -checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool-checkMatcher matcher mkey afile notpresent d-	| isEmpty matcher = return d+checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Annex Bool -> Annex Bool -> Annex Bool+checkMatcher matcher mkey afile notpresent notconfigured d+	| isEmpty matcher = notconfigured 	| otherwise = case (mkey, afile) of 		(_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file 		(Just key, _) -> go (MatchingKey key)-		_ -> return d+		_ -> d   where 	go mi = matchMrun matcher $ \a -> a notpresent mi
Annex/Ingest.hs view
@@ -140,14 +140,13 @@ 			return (Just k)  {- Ingests a locked down file into the annex. Does not update the working- - tree or the index.- -}+ - tree or the index. -} ingest :: Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)-ingest = ingest' Nothing+ingest ld mk = ingest' Nothing ld mk (Restage True) -ingest' :: Maybe Backend -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache)-ingest' _ Nothing _ = return (Nothing, Nothing)-ingest' preferredbackend (Just (LockedDown cfg source)) mk = withTSDelta $ \delta -> do+ingest' :: Maybe Backend -> Maybe LockedDown -> Maybe Key -> Restage -> Annex (Maybe Key, Maybe InodeCache)+ingest' _ Nothing _ _ = return (Nothing, Nothing)+ingest' preferredbackend (Just (LockedDown cfg source)) mk restage = withTSDelta $ \delta -> do 	k <- case mk of 		Nothing -> do 			backend <- maybe (chooseBackend $ keyFilename source) (return . Just) preferredbackend@@ -172,7 +171,7 @@ 	golocked key mcache s = 		tryNonAsync (moveAnnex key $ contentLocation source) >>= \case 			Right True -> do-				populateAssociatedFiles key source+				populateAssociatedFiles key source restage 				success key mcache s		 			Right False -> giveup "failed to add content to annex" 			Left e -> restoreFile (keyFilename source) key e@@ -186,7 +185,7 @@ 		linkToAnnex key (keyFilename source) (Just cache) >>= \case 			LinkAnnexFailed -> failure "failed to link to annex" 			_ -> do-				finishIngestUnlocked' key source+				finishIngestUnlocked' key source restage 				success key (Just cache) s 	gounlocked _ _ _ = failure "failed statting file" @@ -218,23 +217,23 @@ finishIngestUnlocked :: Key -> KeySource -> Annex () finishIngestUnlocked key source = do 	cleanCruft source-	finishIngestUnlocked' key source+	finishIngestUnlocked' key source (Restage True) -finishIngestUnlocked' :: Key -> KeySource -> Annex ()-finishIngestUnlocked' key source = do+finishIngestUnlocked' :: Key -> KeySource -> Restage -> Annex ()+finishIngestUnlocked' key source restage = do 	Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (keyFilename source))-	populateAssociatedFiles key source+	populateAssociatedFiles key source restage  {- Copy to any other locations using the same key. -}-populateAssociatedFiles :: Key -> KeySource -> Annex ()-populateAssociatedFiles key source = do+populateAssociatedFiles :: Key -> KeySource -> Restage -> Annex ()+populateAssociatedFiles key source restage = do 	obj <- calcRepo (gitAnnexLocation key) 	g <- Annex.gitRepo 	ingestedf <- flip fromTopFilePath g 		<$> inRepo (toTopFilePath (keyFilename source)) 	afs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key 	forM_ (filter (/= ingestedf) afs) $-		populatePointerFile key obj+		populatePointerFile restage key obj  cleanCruft :: KeySource -> Annex () cleanCruft source = when (contentLocation source /= keyFilename source) $
Annex/Init.hs view
@@ -35,6 +35,7 @@ import Annex.Link import Annex.WorkTree import Config+import Config.Smudge import Annex.Direct import Annex.AdjustedBranch import Annex.Environment
Annex/Link.hs view
@@ -7,7 +7,7 @@  -  - Pointer files are used instead of symlinks for unlocked files.  -- - Copyright 2013-2015 Joey Hess <id@joeyh.name>+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -18,13 +18,22 @@  import Annex.Common import qualified Annex-import qualified Git.UpdateIndex import qualified Annex.Queue+import qualified Git.Queue+import qualified Git.UpdateIndex+import qualified Git.Index+import qualified Git.LockFile+import qualified Git.Env+import qualified Git import Git.Types import Git.FilePath import Annex.HashObject+import Annex.InodeSentinal import Utility.FileMode import Utility.FileSystemEncoding+import Utility.InodeCache+import Utility.Tmp.Dir+import Utility.CopyFile  import qualified Data.ByteString.Lazy as L @@ -130,6 +139,89 @@ writePointerFile file k mode = do 	writeFile file (formatPointer k) 	maybe noop (setFileMode file) mode++newtype Restage = Restage Bool++{- Restage pointer file. This is used after updating a worktree file+ - when content is added/removed, to prevent git status from showing+ - it as modified.+ -+ - Asks git to refresh its index information for the file.+ - That in turn runs the clean filter on the file; when the clean+ - filter produces the same pointer that was in the index before, git+ - realizes that the file has not actually been modified.+ -+ - Note that, if the pointer file is staged for deletion, or has different+ - content than the current worktree content staged, this won't change+ - that. So it's safe to call at any time and any situation.+ -+ - If the index is known to be locked (eg, git add has run git-annex),+ - that would fail. Restage False will prevent the index being updated.+ - Will display a message to help the user understand why+ - the file will appear to be modified.+ -+ - This uses the git queue, so the update is not performed immediately,+ - and this can be run multiple times cheaply.+ -+ - The InodeCache is for the worktree file. It is used to detect when+ - the worktree file is changed by something else before git update-index+ - gets to look at it.+ -}+restagePointerFile :: Restage -> FilePath -> InodeCache -> Annex ()+restagePointerFile (Restage False) f _ =+	toplevelWarning True $ unableToRestage (Just f)+restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do+	-- update-index is documented as picky about "./file" and it+	-- fails on "../../repo/path/file" when cwd is not in the repo +	-- being acted on. Avoid these problems with an absolute path.+	absf <- liftIO $ absPath f+	Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)]+  where+	isunmodified tsd = genInodeCache f tsd >>= return . \case+		Nothing -> False+		Just new -> compareStrong orig new++	-- Other changes to the files may have been staged before this+	-- gets a chance to run. To avoid a race with any staging of+	-- changes, first lock the index file. Then run git update-index+	-- on all still-unmodified files, using a copy of the index file,+	-- to bypass the lock. Then replace the old index file with the new+	-- updated index file.+	runner = Git.Queue.InternalActionRunner "restagePointerFile" $ \r l -> do+		realindex <- Git.Index.currentIndexFile r+		let lock = Git.Index.indexFileLock realindex+		    lockindex = catchMaybeIO $ Git.LockFile.openLock' lock+		    unlockindex = maybe noop Git.LockFile.closeLock+		    showwarning = warningIO $ unableToRestage Nothing+		    go Nothing = showwarning+		    go (Just _) = withTmpDirIn (Git.localGitDir r) "annexindex" $ \tmpdir -> do+			let tmpindex = tmpdir </> "index"+			let updatetmpindex = do+				r' <- Git.Env.addGitEnv r Git.Index.indexEnv +					=<< Git.Index.indexEnvVal tmpindex+				Git.UpdateIndex.refreshIndex r' $ \feed ->+					forM_ l $ \(f', checkunmodified) ->+						whenM checkunmodified $+							feed f'+			let replaceindex = catchBoolIO $ do+				moveFile tmpindex realindex+				return True+			ok <- createLinkOrCopy realindex tmpindex+				<&&> updatetmpindex+				<&&> replaceindex+			unless ok showwarning+		bracket lockindex unlockindex go++unableToRestage :: Maybe FilePath -> String+unableToRestage mf = unwords+	[ "git status will show " ++ fromMaybe "some files" mf+	, "to be modified, since content availability has changed"+	, "and git-annex was unable to update the index."+	, "This is only a cosmetic problem affecting git status; git add,"+	, "git commit, etc won't be affected."+	, "To fix the git status display, you can run:"+	, "git update-index -q --refresh " ++ fromMaybe "<file>" mf+	]  {- Parses a symlink target or a pointer file to a Key.  - Only looks at the first line, as pointer files can have subsequent
Annex/Locations.hs view
@@ -33,6 +33,7 @@ 	gitAnnexUnusedLog, 	gitAnnexKeysDb, 	gitAnnexKeysDbLock,+	gitAnnexKeysDbIndexCache, 	gitAnnexFsckState, 	gitAnnexFsckDbDir, 	gitAnnexFsckDbLock,@@ -284,6 +285,11 @@ {- Lock file for the keys database. -} gitAnnexKeysDbLock :: Git.Repo -> FilePath gitAnnexKeysDbLock r = gitAnnexKeysDb r ++ ".lck"++{- Contains the stat of the last index file that was+ - reconciled with rhe keys database. -}+gitAnnexKeysDbIndexCache :: Git.Repo -> FilePath+gitAnnexKeysDbIndexCache r = gitAnnexKeysDb r ++ ".cache"  {- .git/annex/fsck/uuid/ is used to store information about incremental  - fscks. -}
Annex/Queue.hs view
@@ -9,6 +9,7 @@  module Annex.Queue ( 	addCommand,+	addInternalAction, 	addUpdateIndex, 	flush, 	flushWhenFull,@@ -22,6 +23,8 @@ import qualified Git.Queue import qualified Git.UpdateIndex +import qualified Control.Concurrent.SSem as SSem+ {- Adds a git command to the queue. -} addCommand :: String -> [CommandParam] -> [FilePath] -> Annex () addCommand command params files = do@@ -29,6 +32,12 @@ 	store <=< flushWhenFull <=< inRepo $ 		Git.Queue.addCommand command params files q +addInternalAction :: Git.Queue.InternalActionRunner -> [(FilePath, IO Bool)] -> Annex ()+addInternalAction runner files = do+	q <- get+	store <=< flushWhenFull <=< inRepo $+		Git.Queue.addInternalAction runner files q+ {- Adds an update-index stream to the queue. -} addUpdateIndex :: Git.UpdateIndex.Streamer -> Annex () addUpdateIndex streamer = do@@ -49,10 +58,23 @@ 	unless (0 == Git.Queue.size q) $ do 		store =<< flush' q +{- When there are multiple worker threads, each has its own queue.+ -+ - But, flushing two queues at the same time could lead to failures due to+ - git locking files. So, only one queue is allowed to flush at a time.+ - The repoqueuesem is shared between threads.+ -} flush' :: Git.Queue.Queue -> Annex Git.Queue.Queue-flush' q = do-	showStoringStateAction-	inRepo $ Git.Queue.flush q+flush' q = bracket lock unlock go+  where+	lock = do+		s <- getState repoqueuesem+		liftIO $ SSem.wait s+		return s+	unlock = liftIO . SSem.signal+	go _ = do+		showStoringStateAction+		inRepo $ Git.Queue.flush q  {- Gets the size of the queue. -} size :: Annex Int
Annex/ReplaceFile.hs view
@@ -26,7 +26,7 @@  -  - Throws an IO exception when it was unable to replace the file.  -}-replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex ()+replaceFile :: FilePath -> (FilePath -> Annex a) -> Annex a replaceFile file action = do 	misctmpdir <- fromRepo gitAnnexTmpMiscDir 	void $ createAnnexDirectory misctmpdir@@ -43,8 +43,9 @@ #endif 	withTmpDirIn misctmpdir basetmp $ \tmpdir -> do 		let tmpfile = tmpdir </> basetmp-		action tmpfile+		r <- action tmpfile 		liftIO $ replaceFileFrom tmpfile file+		return r  replaceFileFrom :: FilePath -> FilePath -> IO () replaceFileFrom src dest = go `catchIO` fallback
Annex/YoutubeDl.hs view
@@ -35,9 +35,10 @@  youtubeDlNotAllowedMessage :: String youtubeDlNotAllowedMessage = unwords-	[ "youtube-dl could potentially access any address, and the"+	[ "This url is supported by youtube-dl, but"+	, "youtube-dl could potentially access any address, and the" 	, "configuration of annex.security.allowed-http-addresses"-	, "does not allow that."+	, "does not allow that. Not using youtube-dl." 	]  -- Runs youtube-dl in a work directory, to download a single media file
Backend/Hash.hs view
@@ -18,9 +18,7 @@ import Types.Backend import Types.KeySource import Utility.Hash-import Utility.ExternalSHA -import qualified BuildInfo import qualified Data.ByteString.Lazy as L import Data.Char @@ -89,7 +87,7 @@ keyValue hash source = do 	let file = contentLocation source 	filesize <- liftIO $ getFileSize file-	s <- hashFile hash file filesize+	s <- hashFile hash file 	return $ Just $ stubKey 		{ keyName = s 		, keyVariety = hashKeyVariety hash (HasExt False)@@ -116,16 +114,16 @@ 		reverse $ splitc '.' $ takeExtensions f 	shortenough e = length e <= 4 -- long enough for "jpeg" -{- A key's checksum is checked during fsck. -}+{- A key's checksum is checked during fsck when it's content is present+ - except for in fast mode. -} checkKeyChecksum :: Hash -> Key -> FilePath -> Annex Bool checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do 	fast <- Annex.getState Annex.fast-	mstat <- liftIO $ catchMaybeIO $ getFileStatus file-	case (mstat, fast) of-		(Just stat, False) -> do-			filesize <- liftIO $ getFileSize' file stat+	exists <- liftIO $ doesFileExist file+	case (exists, fast) of+		(True, False) -> do 			showAction "checksum"-			check <$> hashFile hash file filesize+			check <$> hashFile hash file 		_ -> return True   where 	expected = keyHash key@@ -192,55 +190,33 @@ 	oldvariety = keyVariety oldkey 	newvariety = backendVariety newbackend -hashFile :: Hash -> FilePath -> Integer -> Annex String-hashFile hash file filesize = go hash+hashFile :: Hash -> FilePath -> Annex String+hashFile hash file = liftIO $ do+	h <- hasher <$> L.readFile file+	-- Force full evaluation so file is read and closed.+	return (length h `seq` h)   where-	go MD5Hash = use md5Hasher-	go SHA1Hash = usehasher (HashSize 1)-	go (SHA2Hash hashsize) = usehasher hashsize-	go (SHA3Hash hashsize) = use (sha3Hasher hashsize)-	go (SkeinHash hashsize) = use (skeinHasher hashsize)+	hasher = case hash of+		MD5Hash -> md5Hasher+		SHA1Hash -> sha1Hasher+		SHA2Hash hashsize -> sha2Hasher hashsize+		SHA3Hash hashsize -> sha3Hasher hashsize+		SkeinHash hashsize -> skeinHasher hashsize #if MIN_VERSION_cryptonite(0,23,0)-	go (Blake2bHash hashsize) = use (blake2bHasher hashsize)-	go (Blake2sHash hashsize) = use (blake2sHasher hashsize)-	go (Blake2spHash hashsize) = use (blake2spHasher hashsize)+		Blake2bHash hashsize -> blake2bHasher hashsize+		Blake2sHash hashsize -> blake2sHasher hashsize+		Blake2spHash hashsize -> blake2spHasher hashsize #endif-	-	use hasher = liftIO $ do-		h <- hasher <$> L.readFile file-		-- Force full evaluation so file is read and closed.-		return (length h `seq` h)-	-	usehasher hashsize@(HashSize sz) = case shaHasher hashsize filesize of-		Left sha -> use sha-		Right (external, internal) ->-			liftIO (externalSHA external sz file) >>= \case-				Right r -> return r-				Left e -> do-					warning e-					-- fall back to internal since-					-- external command failed-					use internal -shaHasher :: HashSize -> Integer -> Either (L.ByteString -> String) (String, L.ByteString -> String)-shaHasher (HashSize hashsize) filesize-	| hashsize == 1 = use BuildInfo.sha1 sha1-	| hashsize == 256 = use BuildInfo.sha256 sha2_256-	| hashsize == 224 = use BuildInfo.sha224 sha2_224-	| hashsize == 384 = use BuildInfo.sha384 sha2_384-	| hashsize == 512 = use BuildInfo.sha512 sha2_512+sha2Hasher :: HashSize -> (L.ByteString -> String)+sha2Hasher (HashSize hashsize)+	| hashsize == 256 = use sha2_256+	| hashsize == 224 = use sha2_224+	| hashsize == 384 = use sha2_384+	| hashsize == 512 = use sha2_512 	| otherwise = error $ "unsupported SHA size " ++ show hashsize   where-	use Nothing hasher = Left $ usehasher hasher-	use (Just c) hasher-		{- Use builtin, but slightly slower hashing for-		 - smallish files. Cryptohash benchmarks 90 to 101%-		 - faster than external hashers, depending on the hash-		 - and system. So there is no point forking an external-		 - process unless the file is large. -}-		| filesize < 1048576 = Left $ usehasher hasher-		| otherwise = Right (c, usehasher hasher)-	usehasher hasher = show . hasher+	use hasher = show . hasher  sha3Hasher :: HashSize -> (L.ByteString -> String) sha3Hasher (HashSize hashsize)@@ -279,6 +255,9 @@ 	| hashsize == 224 = show . blake2sp_224 	| otherwise = error $ "unsupported BLAKE2SP size " ++ show hashsize #endif++sha1Hasher :: L.ByteString -> String+sha1Hasher = show . sha1  md5Hasher :: L.ByteString -> String md5Hasher = show . md5
Build/BundledPrograms.hs view
@@ -75,13 +75,8 @@ 	, BuildInfo.lsof 	, BuildInfo.gcrypt #ifndef mingw32_HOST_OS-	-- All these utilities are included in git for Windows+	-- These utilities are included in git for Windows 	, ifset BuildInfo.curl "curl"-	, BuildInfo.sha1-	, BuildInfo.sha256-	, BuildInfo.sha512-	, BuildInfo.sha224-	, BuildInfo.sha384 	, Just "cp" #endif #ifdef linux_HOST_OS
Build/Configure.hs view
@@ -7,7 +7,6 @@ import Build.TestConfig import Build.Version import Utility.SafeCommand-import Utility.ExternalSHA import Utility.Env.Basic import qualified Git.Version import Utility.Directory@@ -38,38 +37,8 @@ 	, TestCase "lsof" $ findCmdPath "lsof" "lsof" 	, TestCase "git-remote-gcrypt" $ findCmdPath "gcrypt" "git-remote-gcrypt" 	, TestCase "ssh connection caching" getSshConnectionCaching-	] ++ shaTestCases-	[ (1, "da39a3ee5e6b4b0d3255bfef95601890afd80709")-	, (256, "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")-	, (512, "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e")-	, (224, "d14a028c2a3a2bc9476102bb288234c415a2b01f828ea62ac5b3e42f")-	, (384, "38b060a751ac96384cd9327eb1b1e36a21fdb71114be07434c0cc7bf63f6e1da274edebfe76f65fbd51ad2f14898b95b") 	] -{- shaNsum are the program names used by coreutils. Some systems- - install these with 'g' prefixes.- -- - On some systems, shaN is used instead, but on other- - systems, it might be "hashalot", which does not produce- - usable checksums. Only accept programs that produce- - known-good hashes when run on files. -}-shaTestCases :: [(Int, String)] -> [TestCase]-shaTestCases l = map make l-  where-	make (n, knowngood) = TestCase key $ -		Config key . MaybeStringConfig <$> search (shacmds n)-	  where-		key = "sha" ++ show n-		search [] = return Nothing-		search (c:cmds) = do-			sha <- externalSHA c n "/dev/null"-			if sha == Right knowngood-				then return $ Just c-				else search cmds-	-	shacmds n = concatMap (\x -> [x, 'g':x]) $-		map (\x -> "sha" ++ show n ++ x) ["sum", ""]- tmpDir :: String tmpDir = "tmp" @@ -128,8 +97,6 @@ 	overrides =  		[ Config "cp_reflink_auto" $ BoolConfig False 		, Config "curl" $ BoolConfig False-		, Config "sha224" $ MaybeStringConfig Nothing-		, Config "sha384" $ MaybeStringConfig Nothing 		] 	overridden (Config k _) = k `elem` overridekeys 	overridekeys = map (\(Config k _) -> k) overrides
CHANGELOG view
@@ -1,3 +1,54 @@+git-annex (6.20180913) upstream; urgency=medium++  * When --batch is used with matching options like --in, --metadata,+    etc, only operate on the provided files when they match those options.+    Otherwise, a blank line is output in the batch protocol.+    Affected commands: find, add, whereis, drop, copy, move, get+  * Make metadata --batch combined with matching options refuse to run,+    since it does not seem worth supporting that combination.+  * v6 add: Take advantage of improved SIGPIPE handler in git 2.5 to+    speed up the clean filter by not reading the file content from the+    pipe. This also avoids git buffering the whole file content in memory.+  * v6: After updating the worktree for an add/drop, update git's index,+    so git status will not show the files as modified.+  * v6: When annex.largefiles is not configured for a file, running git+    add or git commit, or otherwise using git to stage a file+    will add it to the annex if the file was in the annex before,+    and to git otherwise. This is to avoid accidental conversion.+    Note that git-annex add's behavior has not changed.+  * v6: Update associated files database when git has staged changes+    to pointer files.+  * v6: Fix some race conditions.+  * v6: Fix annex object file permissions when git-annex add is run+    on a modified unlocked file, and in some related cases.+  * v6: When a file is unlocked but has not been modified,+    and the unlocking is only staged, git-annex add did not lock it.+    Now it will, for consistency with how modified files are handled and+    with v5.+  * Fix git command queue to be concurrency safe.+  * linux standalone: When LOCPATH is already set, use it instead of the+    bundled locales. It can be set to an empty string to use the system+    locales too.+  * Stop using external hash programs, since cryptonite is faster.+  * Fix build on FreeBSD.+  * S3: Support buckets with versioning enabled. When a remote+    is configured with exporttree=yes versioning=yes, git-annex can+    download past versions of exported files from it.+  * S3: Multipart uploads are now only supported when git-annex is built+    with aws-0.16.0 or later, as earlier versions of the library don't+    support versioning with multipart uploads.+  * S3: Support AWS_SESSION_TOKEN.+  * Don't use GIT_PREFIX when GIT_WORK_TREE=. because it seems git+    does not intend GIT_WORK_TREE to be relative to GIT_PREFIX in that+    case, despite GIT_WORK_TREE=.. being relative to GIT_PREFIX.+  * Don't use GIT_PREFIX to fix up a relative GIT_DIR, because+    git 2.11 sets GIT_PREFIX to a path it's not relative to.+    and apparently GIT_DIR is never relative to GIT_PREFIX.+  * git-annex.cabal: Fix build without assistant, and some other refinements.+    Thanks fftehnik.++ -- Joey Hess <id@joeyh.name>  Thu, 13 Sep 2018 15:50:38 -0400+ git-annex (6.20180807) upstream; urgency=medium    * S3: Support credential-less download from remotes configured
CmdLine/Batch.hs view
@@ -12,6 +12,8 @@ import CmdLine.Action import CmdLine.GitAnnex.Options import Options.Applicative+import Limit+import Types.FileMatcher  data BatchMode = Batch | NoBatch @@ -72,5 +74,18 @@  -- Reads lines of batch input and passes the filepaths to a CommandStart -- to handle them.-batchFiles :: (FilePath -> CommandStart) -> Annex ()-batchFiles a = batchInput Right $ batchCommandAction . a+--+-- File matching options are not checked.+allBatchFiles :: (FilePath -> CommandStart) -> Annex ()+allBatchFiles a = batchInput Right $ batchCommandAction . a++-- Like allBatchFiles, but checks the file matching options+-- and skips non-matching files.+batchFilesMatching :: (FilePath -> CommandStart) -> Annex ()+batchFilesMatching a = do+	matcher <- getMatcher+	allBatchFiles $ \f ->+		ifM (matcher $ MatchingFile $ FileInfo f f)+			( a f+			, return Nothing+			)
CmdLine/Seek.hs view
@@ -4,7 +4,7 @@  - the values a user passes to a command, and prepare actions operating  - on them.  -- - Copyright 2010-2016 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -31,6 +31,8 @@ import qualified Remote import Annex.CatFile import Annex.Content+import Annex.InodeSentinal+import qualified Database.Keys  withFilesInGit :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek withFilesInGit a l = seekActions $ prepFiltered a $@@ -128,9 +130,6 @@ withFilesOldUnlocked :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek withFilesOldUnlocked = withFilesOldUnlocked' LsFiles.typeChanged -withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek-withFilesOldUnlockedToBeCommitted = withFilesOldUnlocked' LsFiles.typeChangedStaged- {- Unlocked files before v6 have changed type from a symlink to a regular file.  -  - Furthermore, unlocked files used to be a git-annex symlink,@@ -145,6 +144,23 @@ isOldUnlocked :: FilePath -> Annex Bool isOldUnlocked f = liftIO (notSymlink f) <&&>  	(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)++withFilesOldUnlockedToBeCommitted :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek+withFilesOldUnlockedToBeCommitted = withFilesOldUnlocked' LsFiles.typeChangedStaged++{- v6 unlocked pointer files that are staged, and whose content has not been+ - modified-}+withUnmodifiedUnlockedPointers :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek+withUnmodifiedUnlockedPointers a l = seekActions $+	prepFiltered a unlockedfiles+  where+	unlockedfiles = filterM isV6UnmodifiedUnlocked +		=<< seekHelper LsFiles.typeChangedStaged l++isV6UnmodifiedUnlocked :: FilePath -> Annex Bool+isV6UnmodifiedUnlocked f = catKeyFile f >>= \case+	Nothing -> return False+	Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k  {- Finds files that may be modified. -} withFilesMaybeModified :: (FilePath -> CommandStart) -> [WorkTreeItem] -> CommandSeek
Command/Add.hs view
@@ -62,15 +62,18 @@ 		Batch 			| updateOnly o -> 				giveup "--update --batch is not supported"-			| otherwise -> batchFiles gofile+			| otherwise -> batchFilesMatching gofile 		NoBatch -> do 			l <- workTreeItems (addThese o) 			let go a = a gofile l 			unless (updateOnly o) $ 				go (withFilesNotInGit (not $ includeDotFiles o)) 			go withFilesMaybeModified-			unlessM (versionSupportsUnlockedPointers <||> isDirect) $-				go withFilesOldUnlocked+			ifM versionSupportsUnlockedPointers+				( go withUnmodifiedUnlockedPointers+				, unlessM isDirect $+					go withFilesOldUnlocked+				)  {- Pass file off to git-add. -} startSmall :: FilePath -> CommandStart@@ -111,8 +114,7 @@ 	addpresent key = ifM versionSupportsUnlockedPointers 		( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case 			Just s | isSymbolicLink s -> fixuplink key-			_ -> ifM (sameInodeCache file =<< Database.Keys.getInodeCaches key)-				( stop, add )+			_ -> add 		, ifM isDirect 			( liftIO (catchMaybeIO $ getSymbolicLinkStatus file) >>= \case 				Just s | isSymbolicLink s -> fixuplink key
Command/Copy.hs view
@@ -47,7 +47,7 @@ seek o = allowConcurrentOutput $ do 	let go = whenAnnexed $ start o 	case batchOption o of-		Batch -> batchInput Right (batchCommandAction . go)+		Batch -> batchFilesMatching go 		NoBatch -> withKeyOptions 			(keyOptions o) (autoMode o) 			(Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever)
Command/Drop.hs view
@@ -54,7 +54,7 @@ seek :: DropOptions -> CommandSeek seek o = allowConcurrentOutput $ 	case batchOption o of-		Batch -> batchInput Right (batchCommandAction . go)+		Batch -> batchFilesMatching go 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o) 			(startKeys o) 			(withFilesInGit go)
Command/Export.hs view
@@ -285,11 +285,15 @@ 			removeExportedLocation db (asKey ek) loc 		flushDbQueue db -	remaininglocs <- liftIO $ -		concat <$> forM eks (\ek -> getExportedLocation db (asKey ek))-	when (null remaininglocs) $-		forM_ eks $ \ek ->-			logChange (asKey ek) (uuid r) InfoMissing+	-- An appendonly remote can support removeExportLocation to remove+	-- the file from the exported tree, but still retain the content+	-- and allow retrieving it.+	unless (appendonly r) $ do+		remaininglocs <- liftIO $ +			concat <$> forM eks (\ek -> getExportedLocation db (asKey ek))+		when (null remaininglocs) $+			forM_ eks $ \ek ->+				logChange (asKey ek) (uuid r) InfoMissing 	 	removeEmptyDirectories ea db loc (map asKey eks)
Command/Find.hs view
@@ -51,7 +51,7 @@ seek :: FindOptions -> CommandSeek seek o = case batchOption o of 	NoBatch -> withFilesInGit go =<< workTreeItems (findThese o)-	Batch -> batchFiles go+	Batch -> batchFilesMatching go   where 	go = whenAnnexed $ start o
Command/Get.hs view
@@ -42,7 +42,7 @@ 	from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) 	let go = whenAnnexed $ start o from 	case batchOption o of-		Batch -> batchInput Right (batchCommandAction . go)+		Batch -> batchFilesMatching go 		NoBatch -> withKeyOptions (keyOptions o) (autoMode o) 			(startKeys from) 			(withFilesInGit go)
Command/ImportFeed.hs view
@@ -85,7 +85,7 @@ 			showOutput 			ok <- and <$> mapM (performDownload opts cache) l 			unless ok $-				feedProblem url "problem downloading item"+				feedProblem url "problem downloading some item(s) from feed" 			next $ cleanup url True  cleanup :: URLString -> Bool -> CommandCleanup@@ -198,7 +198,7 @@ 		let mediaurl = setDownloader linkurl YoutubeDownloader 		let mediakey = Backend.URL.fromUrl mediaurl Nothing 		-- Old versions of git-annex that used quvi might have-		-- used the quviurl for this, so check i/f it's known+		-- used the quviurl for this, so check if it's known 		-- to avoid adding it a second time. 		let quviurl = setDownloader linkurl QuviDownloader 		checkknown mediaurl $ checkknown quviurl $
Command/MetaData.hs view
@@ -15,6 +15,7 @@ import Messages.JSON (JSONActionItem(..)) import Types.Messages import Utility.Aeson+import Limit  import qualified Data.Set as S import qualified Data.Map as M@@ -83,8 +84,11 @@ 			(seeker $ whenAnnexed $ start c o) 			=<< workTreeItems (forFiles o) 	Batch -> withMessageState $ \s -> case outputType s of-		JSONOutput _ -> batchInput parseJSONInput $-			commandAction . startBatch+		JSONOutput _ -> ifM limited+			( giveup "combining --batch with file matching options is not currently supported"+			, batchInput parseJSONInput $+				commandAction . startBatch+			) 		_ -> giveup "--batch is currently only supported in --json mode"  start :: VectorClock -> MetaDataOptions -> FilePath -> Key -> CommandStart@@ -108,7 +112,7 @@ 	Set ms -> do 		oldm <- getCurrentMetaData k 		let m = combineMetaData $ map (modMeta oldm) ms-		addMetaData' k m c+		addMetaDataClocked k m c 		next $ cleanup k 	_ -> next $ cleanup k
Command/Move.hs view
@@ -57,7 +57,7 @@ seek o = allowConcurrentOutput $ do 	let go = whenAnnexed $ start (fromToOptions o) (removeWhen o) 	case batchOption o of-		Batch -> batchInput Right (batchCommandAction . go)+		Batch -> batchFilesMatching go 		NoBatch -> withKeyOptions (keyOptions o) False 			(startKey (fromToOptions o) (removeWhen o)) 			(withFilesInGit go)
Command/ReKey.hs view
@@ -85,7 +85,7 @@ 	 - and vulnerable to corruption. -} 	( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do 		oldobj <- calcRepo (gitAnnexLocation oldkey)-		linkOrCopy' (return True) newkey oldobj tmp Nothing+		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
Command/Reinject.hs view
@@ -47,7 +47,7 @@   where 	go key = ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src) 		( perform src key-		, error "failed"+		, giveup $ src ++ " does not have expected content of " ++ dest 		) startSrcDest _ = giveup "specify a src file and a dest file"
Command/Smudge.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2015 Joey Hess <id@joeyh.name>+ - Copyright 2015-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,7 +16,9 @@ import Annex.CatFile import Logs.Location import qualified Database.Keys+import qualified Git.BuildVersion import Git.FilePath+import qualified Git.Ref import Backend  import qualified Data.ByteString.Lazy as B@@ -68,45 +70,85 @@  -- Clean filter is fed file content on stdin, decides if a file -- should be stored in the annex, and outputs a pointer to its--- injested content.+-- injested content if so. Otherwise, the original content. clean :: FilePath -> CommandStart clean file = do 	b <- liftIO $ B.hGetContents stdin-	if isJust (parseLinkOrPointer b)-		then liftIO $ B.hPut stdout b-		else ifM (shouldAnnex file)-			( do-				-- Even though we ingest the actual file,-				-- and not stdin, we need to consume all-				-- stdin, or git will get annoyed.-				B.length b `seq` return ()-				-- Look up the backend that was used-				-- for this file before, so that when-				-- git re-cleans a file its backend does-				-- not change.-				currbackend <- maybe Nothing (maybeLookupBackendVariety . keyVariety)-					<$> catKeyFile file-				liftIO . emitPointer-					=<< go-					=<< (\ld -> ingest' currbackend ld Nothing)-					=<< lockDown cfg file-			, liftIO $ B.hPut stdout b-			)+	case parseLinkOrPointer b of+		Just k -> do+			getMoveRaceRecovery k file+			liftIO $ B.hPut stdout b+		Nothing -> go b =<< catKeyFile file 	stop   where-	go (Just k, _) = do+	go b oldkey = ifM (shouldAnnex file oldkey)+		( do+			-- Before git 2.5, failing to consume all stdin here+			-- would cause a SIGPIPE and crash it.+			-- Newer git catches the signal and stops sending,+			-- which is much faster. (Also, git seems to forget+			-- to free memory when sending the file, so the+			-- less we let it send, the less memory it will waste.)+			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+		, liftIO $ B.hPut stdout b+		)++	postingest (Just k, _) = do 		logStatus k InfoPresent 		return k-	go _ = error "could not add file to the annex"+	postingest _ = error "could not add file to the annex"+ 	cfg = LockDownConfig 		{ lockingFile = False 		, hardlinkFileTmp = False 		} -shouldAnnex :: FilePath -> Annex Bool-shouldAnnex file = do+-- New files are annexed as configured by annex.largefiles, with a default+-- of annexing them.+-- +-- If annex.largefiles is not configured for a file, and a file with its+-- name is already in the index, preserve its annexed/not annexed state.+-- This prevents accidental conversions when annex.largefiles is being+-- set/unset on the fly rather than being set in gitattributes or .git/config.+shouldAnnex :: FilePath -> Maybe Key -> Annex Bool+shouldAnnex file moldkey = do 	matcher <- largeFilesMatcher-	checkFileMatcher matcher file+	checkFileMatcher' matcher file whenempty+  where+	whenempty = case moldkey of+		Just _ -> return True+		Nothing -> isNothing <$> catObjectMetaData (Git.Ref.fileRef file)  emitPointer :: Key -> IO () emitPointer = putStr . formatPointer++-- Recover from a previous race between eg git mv and git-annex get.+-- That could result in the file remaining a pointer file, while+-- its content is present in the annex. Populate the pointer file.+-- +-- This also handles the case where a copy of a pointer file is made,+-- then git-annex gets the content, and later git add is run on+-- 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]
Command/Whereis.hs view
@@ -40,7 +40,7 @@ 	m <- remoteMap id 	let go = whenAnnexed $ start m 	case batchOption o of-		Batch -> batchFiles go+		Batch -> batchFilesMatching go 		NoBatch ->  			withKeyOptions (keyOptions o) False 				(startKeys m)
Config.hs view
@@ -102,21 +102,3 @@ setCrippledFileSystem b = do 	setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) 	Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b }--configureSmudgeFilter :: Annex ()-configureSmudgeFilter = do-	setConfig (ConfigKey "filter.annex.smudge") "git-annex smudge %f"-	setConfig (ConfigKey "filter.annex.clean") "git-annex smudge --clean %f"-	lf <- Annex.fromRepo Git.attributesLocal-	gf <- Annex.fromRepo Git.attributes-	lfs <- readattr lf-	gfs <- readattr gf-	liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do-		createDirectoryIfMissing True (takeDirectory lf)-		writeFile lf (lfs ++ "\n" ++ stdattr)-  where-	readattr = liftIO . catchDefaultIO "" . readFileStrict-	stdattr = unlines-		[ "* filter=annex"-		, ".* !filter"-		]
+ Config/Smudge.hs view
@@ -0,0 +1,41 @@+{- Git smudge filter configuration+ -+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Config.Smudge where++import Annex.Common+import qualified Annex+import qualified Git+import qualified Git.Command+import Config++configureSmudgeFilter :: Annex ()+configureSmudgeFilter = unlessM (fromRepo Git.repoIsLocalBare) $ do+	-- If this is run in a newly cloned repository, git may not have+	-- cached file information in the index yet, and so after+	-- configuring the clean filter, the next git status would want to+	-- run it on every file. That is expensive and can also result in+	-- unexpected changes when the file is checked into git or annex+	-- counter to the annex.largefiles configuration.+	-- Avoid that problem by running git status now.+	inRepo $ Git.Command.runQuiet [Param "status", Param "--porcelain"]++	setConfig (ConfigKey "filter.annex.smudge") "git-annex smudge %f"+	setConfig (ConfigKey "filter.annex.clean") "git-annex smudge --clean %f"+	lf <- Annex.fromRepo Git.attributesLocal+	gf <- Annex.fromRepo Git.attributes+	lfs <- readattr lf+	gfs <- readattr gf+	liftIO $ unless ("filter=annex" `isInfixOf` (lfs ++ gfs)) $ do+		createDirectoryIfMissing True (takeDirectory lf)+		writeFile lf (lfs ++ "\n" ++ stdattr)+  where+	readattr = liftIO . catchDefaultIO "" . readFileStrict+	stdattr = unlines+		[ "* filter=annex"+		, ".* !filter"+		]
Database/Keys.hs view
@@ -1,6 +1,6 @@ {- Sqlite database of information about Keys  -- - Copyright 2015-2016 Joey Hess <id@joeyh.name>+ - Copyright 2015-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -15,6 +15,7 @@ 	getAssociatedKey, 	removeAssociatedFile, 	storeInodeCaches,+	storeInodeCaches', 	addInodeCaches, 	getInodeCaches, 	removeInodeCaches,@@ -31,9 +32,16 @@ import Annex.Version (versionUsesKeysDatabase) import qualified Annex import Annex.LockFile+import Annex.CatFile+import Annex.Content.PointerFile+import Annex.Link import Utility.InodeCache import Annex.InodeSentinal+import Git import Git.FilePath+import Git.Command+import Git.Types+import Git.Index  {- Runs an action that reads from the database.  -@@ -124,12 +132,16 @@ 			open db 		(False, False) -> return DbUnavailable   where-	open db = liftIO $ DbOpen <$> H.openDbQueue H.MultiWriter db SQL.containedTable 	-- If permissions don't allow opening the database, treat it as if 	-- it does not exist. 	permerr e = case createdb of 		False -> return DbUnavailable 		True -> throwM e+	+	open db = do+		qh <- liftIO $ H.openDbQueue H.MultiWriter db SQL.containedTable+		reconcileStaged qh+		return $ DbOpen qh  {- Closes the database if it was open. Any writes will be flushed to it.  -@@ -159,9 +171,13 @@  {- Stats the files, and stores their InodeCaches. -} storeInodeCaches :: Key -> [FilePath] -> Annex ()-storeInodeCaches k fs = withTSDelta $ \d ->-	addInodeCaches k . catMaybes =<< liftIO (mapM (`genInodeCache` d) fs)+storeInodeCaches k fs = storeInodeCaches' k fs [] +storeInodeCaches' :: Key -> [FilePath] -> [InodeCache] -> Annex ()+storeInodeCaches' k fs ics = withTSDelta $ \d ->+	addInodeCaches k . (++ ics) . catMaybes+		=<< liftIO (mapM (`genInodeCache` d) fs)+ addInodeCaches :: Key -> [InodeCache] -> Annex () addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toIKey k) is @@ -172,3 +188,116 @@  removeInodeCaches :: Key -> Annex () removeInodeCaches = runWriterIO . SQL.removeInodeCaches . toIKey++{- Looks at staged changes to find when unlocked files are copied/moved,+ - and updates associated files in the keys database.+ -+ - Since staged changes can be dropped later, does not remove any+ - associated files; only adds new associated files.+ -+ - This needs to be run before querying the keys database so that+ - information is consistent with the state of the repository.+ -+ - To avoid unncessary work, the index file is statted, and if it's not+ - changed since last time this was run, nothing is done.+ -+ - Note that this is run with a lock held, so only one process can be+ - running this at a time.+ -+ - This also cleans up after a race between eg a git mv and git-annex+ - get/drop/similar. If git moves the file between this being run and the+ - get/drop, the moved file won't be updated for the get/drop. + - The next time this runs, it will see the staged change. It then checks+ - if the worktree file's content availability does not match the git-annex+ - content availablity, and makes changes as necessary to reconcile them.+ -+ - Note that if a commit happens before this runs again, it won't see+ - the staged change. Instead, during the commit, git will run the clean+ - filter. If a drop missed the file then the file is added back into the+ - annex. If a get missed the file then the clean filter populates the+ - file.+ -}+reconcileStaged :: H.DbQueue -> Annex ()+reconcileStaged qh = whenM versionUsesKeysDatabase $ do+	gitindex <- inRepo currentIndexFile+	indexcache <- fromRepo gitAnnexKeysDbIndexCache+	withTSDelta (liftIO . genInodeCache gitindex) >>= \case+		Just cur -> +			liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case+				Nothing -> go cur indexcache+				Just prev -> ifM (compareInodeCaches prev cur)+					( noop+					, go cur indexcache+					)+		Nothing -> noop+  where+	go cur indexcache = do+		(l, cleanup) <- inRepo $ pipeNullSplit diff+		changed <- procdiff l False+		void $ liftIO cleanup+		-- Flush database changes immediately+		-- so other processes can see them.+		when changed $+			liftIO $ H.flushDbQueue qh+		liftIO $ writeFile indexcache $ showInodeCache cur+	+	diff =+		-- Avoid using external diff command, which would be slow.+		-- (The -G option may make it be used otherwise.)+		[ Param "-c", Param "diff.external="+		-- Avoid running smudge or clean filters, since we want the+		-- raw output, and they would block trying to access the+		-- locked database. The --raw normally avoids git diff+		-- running them, but older versions of git need this.+		, Param "-c", Param "filter.annex.smudge="+		, Param "-c", Param "filter.annex.clean="+		, Param "diff"+		, Param "--cached"+		, Param "--raw"+		, Param "-z"+		, Param "--abbrev=40"+		-- Optimization: Only find pointer files. This is not+		-- perfect. A file could start with this and not be a+		-- pointer file. And a pointer file that is replaced with+		-- a non-pointer file will match this.+		, Param $ "-G^" ++ toInternalGitPath (pathSeparator:objectDir)+		-- Don't include files that were deleted, because this only+		-- wants to update information for files that are present+		-- in the index.+		, Param "--diff-filter=AMUT"+		-- Disable rename detection.+		, Param "--no-renames"+		-- Avoid other complications.+		, Param "--ignore-submodules=all"+		, Param "--no-ext-diff"+		]+	+	procdiff (info:file:rest) changed = case words info of+		((':':_srcmode):dstmode:_srcsha:dstsha:_change:[])+			-- Only want files, not symlinks+			| dstmode /= fmtTreeItemType TreeSymlink -> do+				maybe noop (reconcile (asTopFilePath file)) +					=<< catKey (Ref dstsha)+				procdiff rest True+			| otherwise -> procdiff rest changed+		_ -> return changed -- parse failed+	procdiff _ changed = return changed++	-- Note that database writes done in here will not necessarily +	-- be visible to database reads also done in here.+	reconcile file key = do+		let ikey = toIKey key+		liftIO $ SQL.addAssociatedFileFast ikey file (SQL.WriteHandle qh)+		caches <- liftIO $ SQL.getInodeCaches ikey (SQL.ReadHandle qh)+		keyloc <- calcRepo (gitAnnexLocation key)+		keypopulated <- sameInodeCache keyloc caches+		p <- fromRepo $ fromTopFilePath file+		filepopulated <- sameInodeCache p caches+		case (keypopulated, filepopulated) of+			(True, False) ->+				populatePointerFile (Restage True) key keyloc p >>= \case+					Nothing -> return ()+					Just ic -> liftIO $+						SQL.addInodeCaches ikey [ic] (SQL.WriteHandle qh)+			(False, True) -> depopulatePointerFile key p+			_ -> return ()
Git/CurrentRepo.hs view
@@ -28,17 +28,17 @@  -  - Also works around a git bug when running some hooks. It  - runs the hooks in the top of the repository, but if GIT_WORK_TREE- - was relative, it then points to the wrong directory. In this situation- - GIT_PREFIX contains the directory that GIT_WORK_TREE (and GIT_DIR)- - are relative to.+ - was relative (but not "."), it then points to the wrong directory.+ - In this situation GIT_PREFIX contains the directory that + - GIT_WORK_TREE is relative to.  -} get :: IO Repo get = do-	prefix <- getpathenv "GIT_PREFIX"-	gd <- pathenv "GIT_DIR" prefix+	gd <- getpathenv "GIT_DIR" 	r <- configure gd =<< fromCwd+	prefix <- getpathenv "GIT_PREFIX" 	wt <- maybe (worktree $ location r) Just-		<$> pathenv "GIT_WORK_TREE" prefix+		<$> getpathenvprefix "GIT_WORK_TREE" prefix 	case wt of 		Nothing -> return r 		Just d -> do@@ -55,10 +55,13 @@ 				return (Just d) 			Nothing -> return Nothing 	-	pathenv s Nothing = getpathenv s-	pathenv s (Just prefix) = getpathenv s >>= \case-		Nothing -> return Nothing-		Just d -> Just <$> absPath (prefix </> d)+	getpathenvprefix s (Just prefix) | not (null prefix) =+		getpathenv s >>= \case+			Nothing -> return Nothing+			Just d+				| d == "." -> return (Just d)+				| otherwise -> Just <$> absPath (prefix </> d)+	getpathenvprefix s _ = getpathenv s  	configure Nothing (Just r) = Git.Config.read r 	configure (Just d) _ = do
Git/Index.hs view
@@ -1,6 +1,6 @@ {- git index file stuff  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -47,12 +47,17 @@ 	reset (Just v) = setEnv indexEnv v True 	reset _ = unsetEnv var +{- The normal index file. Does not check GIT_INDEX_FILE. -} indexFile :: Repo -> FilePath indexFile r = localGitDir r </> "index" +{- The index file git will currently use, checking GIT_INDEX_FILE. -}+currentIndexFile :: Repo -> IO FilePath+currentIndexFile r = fromMaybe (indexFile r) <$> getEnv indexEnv	+ {- Git locks the index by creating this file. -}-indexFileLock :: Repo -> FilePath-indexFileLock r = indexFile r ++ ".lock"+indexFileLock :: FilePath -> FilePath+indexFileLock f = f ++ ".lock"  {- When the pre-commit hook is run, and git commit has been run with  - a file or files specified to commit, rather than committing the staged
Git/Queue.hs view
@@ -1,6 +1,6 @@ {- git repository command queue  -- - Copyright 2010,2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -12,6 +12,8 @@ 	new, 	addCommand, 	addUpdateIndex,+	addInternalAction,+	InternalActionRunner(..), 	size, 	full, 	flush,@@ -38,14 +40,27 @@ 		, getParams :: [CommandParam] 		, getFiles :: [CommandParam] 		} +	{- An internal action to run, on a list of files that can be added+	 - to as the queue grows. -}+	| InternalAction+		{ getRunner :: InternalActionRunner+		, getInternalFiles :: [(FilePath, IO Bool)]+		} +{- The String must be unique for each internal action. -}+data InternalActionRunner = InternalActionRunner String (Repo -> [(FilePath, IO Bool)] -> IO ())++instance Eq InternalActionRunner where+	InternalActionRunner s1 _ == InternalActionRunner s2 _ = s1 == s2+ {- A key that can uniquely represent an action in a Map. -}-data ActionKey = UpdateIndexActionKey | CommandActionKey String+data ActionKey = UpdateIndexActionKey | CommandActionKey String | InternalActionKey String 	deriving (Eq, Ord)  actionKey :: Action -> ActionKey actionKey (UpdateIndexAction _) = UpdateIndexActionKey actionKey CommandAction { getSubcommand = s } = CommandActionKey s+actionKey InternalAction { getRunner = InternalActionRunner s _ } = InternalActionKey s  {- A queue of actions to perform (in any order) on a git repository,  - with lists of files to perform them on. This allows coalescing @@ -91,6 +106,19 @@ 	different (CommandAction { getSubcommand = s }) = s /= subcommand 	different _ = True +{- Adds an internal action to the queue. -}+addInternalAction :: InternalActionRunner -> [(FilePath, IO Bool)] -> Queue -> Repo -> IO Queue+addInternalAction runner files q repo =+	updateQueue action different (length files) q repo+  where+	action = InternalAction+		{ getRunner = runner+		, getInternalFiles = files+		}+	+	different (InternalAction { getRunner = r }) = r /= runner+	different _ = True+ {- Adds an update-index streamer to the queue. -} addUpdateIndex :: Git.UpdateIndex.Streamer -> Queue -> Repo -> IO Queue addUpdateIndex streamer q repo =@@ -119,11 +147,16 @@ 		!newsize = size q' + sizeincrease 		!newitems = M.insertWith combineNewOld (actionKey action) action (items q') +{- The new value comes first. It probably has a smaller list of files than+ - the old value. So, the list append of the new value first is more+ - efficient. -} combineNewOld :: Action -> Action -> Action combineNewOld (CommandAction _sc1 _ps1 fs1) (CommandAction sc2 ps2 fs2) = 	CommandAction sc2 ps2 (fs1++fs2) combineNewOld (UpdateIndexAction s1) (UpdateIndexAction s2) = 	UpdateIndexAction (s1++s2)+combineNewOld (InternalAction _r1 fs1) (InternalAction r2 fs2) =+	InternalAction r2 (fs1++fs2) combineNewOld anew _aold = anew  {- Merges the contents of the second queue into the first.@@ -172,3 +205,6 @@   where 	gitparams = gitCommandLine 		(Param (getSubcommand action):getParams action) repo+runAction repo action@(InternalAction {}) =+	let InternalActionRunner _ runner = getRunner action+	in runner repo (getInternalFiles action)
Git/UpdateIndex.hs view
@@ -1,6 +1,6 @@ {- git-update-index library  -- - Copyright 2011-2013 Joey Hess <id@joeyh.name>+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -21,6 +21,7 @@ 	unstageFile, 	stageSymlink, 	stageDiffTreeItem,+	refreshIndex, ) where  import Common@@ -123,3 +124,23 @@  indexPath :: TopFilePath -> InternalGitPath indexPath = toInternalGitPath . getTopFilePath++{- Refreshes the index, by checking file stat information.  -}+refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool+refreshIndex repo feeder = do+	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)+		{ std_in = CreatePipe }+	feeder $ \f -> do+		hPutStr h f+		hPutStr h "\0"+	hFlush h+	hClose h+	checkSuccessProcess p+  where+	params = +		[ Param "update-index"+		, Param "-q"+		, Param "--refresh"+		, Param "-z"+		, Param "--stdin"+		]
Logs.hs view
@@ -1,6 +1,6 @@ {- git-annex log file names  -- - Copyright 2013-2015 Joey Hess <id@joeyh.name>+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,6 +16,7 @@ 	| NewUUIDBasedLog 	| ChunkLog Key 	| PresenceLog Key+	| RemoteMetaDataLog 	| OtherLog 	deriving (Show) @@ -26,6 +27,7 @@ 	| f `elem` topLevelUUIDBasedLogs = Just UUIDBasedLog 	| isRemoteStateLog f = Just NewUUIDBasedLog 	| isChunkLog f = ChunkLog <$> chunkLogFileKey f+	| isRemoteMetaDataLog f = Just RemoteMetaDataLog 	| isMetaDataLog f || f `elem` otherLogs = Just OtherLog 	| otherwise = PresenceLog <$> firstJust (presenceLogs f) @@ -185,3 +187,13 @@  isMetaDataLog :: FilePath -> Bool isMetaDataLog path = metaDataLogExt `isSuffixOf` path++{- The filename of the remote metadata log for a given key. -}+remoteMetaDataLogFile :: GitConfig -> Key -> FilePath+remoteMetaDataLogFile config key = branchHashDir config key </> keyFile key ++ remoteMetaDataLogExt++remoteMetaDataLogExt :: String+remoteMetaDataLogExt = ".log.rmet"++isRemoteMetaDataLog :: FilePath -> Bool+isRemoteMetaDataLog path = remoteMetaDataLogExt `isSuffixOf` path
Logs/MetaData.hs view
@@ -1,7 +1,9 @@-{- git-annex general metadata storage log+{- git-annex general metadata storage log and per-remote metadata storage log.  -  - A line of the log will look like "timestamp field [+-]value [...]"  -+ - (In the per-remote log, each field is prefixed with "uuid:")+ -  - Note that unset values are preserved. Consider this case:  -  - We have:@@ -18,17 +20,15 @@  - and so foo currently has no value.  -  -- - Copyright 2014 Joey Hess <id@joeyh.name>- -  - Licensed under the GNU GPL version 3 or higher.  -} -{-# OPTIONS_GHC -fno-warn-orphans #-}- module Logs.MetaData ( 	getCurrentMetaData,+	getCurrentRemoteMetaData, 	addMetaData,-	addMetaData',+	addRemoteMetaData,+	addMetaDataClocked, 	currentMetaData, 	copyMetaData, ) where@@ -40,24 +40,12 @@ import qualified Annex.Branch import qualified Annex import Logs-import Logs.SingleValue import Logs.TimeStamp+import Logs.MetaData.Pure  import qualified Data.Set as S import qualified Data.Map as M -instance SingleValueSerializable MetaData where-	serialize = Types.MetaData.serialize-	deserialize = Types.MetaData.deserialize--getMetaDataLog :: Key -> Annex (Log MetaData)-getMetaDataLog key = do-	config <- Annex.getGitConfig-	readLog $ metaDataLogFile config key--logToCurrentMetaData :: [LogEntry MetaData] -> MetaData-logToCurrentMetaData = currentMetaData . combineMetaData . map value- {- Go through the log from oldest to newest, and combine it all  - into a single MetaData representing the current state.  -@@ -65,8 +53,12 @@  - currently set, based on timestamps in the log.  -} getCurrentMetaData :: Key -> Annex MetaData-getCurrentMetaData k = do-	ls <- S.toAscList <$> getMetaDataLog k+getCurrentMetaData = getCurrentMetaData' metaDataLogFile++getCurrentMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> Annex MetaData+getCurrentMetaData' getlogfile k = do+	config <- Annex.getGitConfig+	ls <- S.toAscList <$> readLog (getlogfile config k) 	let loggedmeta = logToCurrentMetaData ls 	return $ currentMetaData $ unionMetaData loggedmeta 		(lastchanged ls loggedmeta)@@ -92,86 +84,46 @@ 			Unknown -> 0 	showts = formatPOSIXTime "%F@%H-%M-%S" +getCurrentRemoteMetaData :: UUID -> Key -> Annex RemoteMetaData+getCurrentRemoteMetaData u k = extractRemoteMetaData u <$>+	getCurrentMetaData' remoteMetaDataLogFile k+ {- Adds in some metadata, which can override existing values, or unset  - them, but otherwise leaves any existing metadata as-is. -} addMetaData :: Key -> MetaData -> Annex ()-addMetaData k metadata = addMetaData' k metadata =<< liftIO currentVectorClock+addMetaData = addMetaData' metaDataLogFile +addMetaData' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> Annex ()+addMetaData' getlogfile k metadata = +	addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock+ {- Reusing the same VectorClock when making changes to the metadata  - of multiple keys is a nice optimisation. The same metadata lines  - will tend to be generated across the different log files, and so  - git will be able to pack the data more efficiently. -}-addMetaData' :: Key -> MetaData -> VectorClock -> Annex ()-addMetaData' k d@(MetaData m) c+addMetaDataClocked :: Key -> MetaData -> VectorClock -> Annex ()+addMetaDataClocked = addMetaDataClocked' metaDataLogFile++addMetaDataClocked' :: (GitConfig -> Key -> FilePath) -> Key -> MetaData -> VectorClock -> Annex ()+addMetaDataClocked' getlogfile k d@(MetaData m) c 	| d == emptyMetaData = noop 	| otherwise = do 		config <- Annex.getGitConfig-		Annex.Branch.change (metaDataLogFile config k) $+		Annex.Branch.change (getlogfile config k) $ 			showLog . simplifyLog  				. S.insert (LogEntry c metadata) 				. parseLog   where 	metadata = MetaData $ M.filterWithKey (\f _ -> not (isLastChangedField f)) m -{- Simplify a log, removing historical values that are no longer- - needed. - -- - This is not as simple as just making a single log line with the newest- - state of all metadata. Consider this case:- -- - We have:- -- - 100 foo +x bar +y- - 200 foo -x- -- - An unmerged remote has:- -- - 150 bar -y baz +w- -- - If what we have were simplified to "200 foo -x bar +y" then when the line- - from the remote became available, it would be older than the simplified- - line, and its change to bar would not take effect. That is wrong.- -- - Instead, simplify it to:- -- - 100 bar +y- - 200 foo -x- -- - (Note that this ends up with the same number of lines as the- - unsimplified version, so there's really no point in updating- - the log to this version. Doing so would only add data to git,- - with little benefit.)- -- - Now merging with the remote yields:- -- - 100 bar +y- - 150 bar -y baz +w- - 200 foo -x- -- - Simplifying again:- -- - 150 bar +z baz +w- - 200 foo -x- -}-simplifyLog :: Log MetaData -> Log MetaData-simplifyLog s = case sl of-	(newest:rest) -> -		let sl' = go [newest] (value newest) rest-		in if length sl' < length sl-			then S.fromList sl'-			else s-	_ -> s-  where-	sl = S.toDescList s+addRemoteMetaData :: Key -> RemoteMetaData -> Annex ()+addRemoteMetaData k m = do+	addMetaData' remoteMetaDataLogFile k (fromRemoteMetaData m) -	go c _ [] = c-	go c newer (l:ls)-		| unique == emptyMetaData = go c newer ls-		| otherwise = go (l { value = unique } : c)-			(unionMetaData unique newer) ls-	  where-		older = value l-		unique = older `differenceMetaData` newer+getMetaDataLog :: Key -> Annex (Log MetaData)+getMetaDataLog key = do+	config <- Annex.getGitConfig+	readLog $ metaDataLogFile config key  {- Copies the metadata from the old key to the new key.  -@@ -195,3 +147,6 @@ 				Annex.Branch.change (metaDataLogFile config newkey) $ 					const $ showLog l 				return True++readLog :: FilePath -> Annex (Log MetaData)+readLog = parseLog <$$> Annex.Branch.get
+ Logs/MetaData/Pure.hs view
@@ -0,0 +1,111 @@+{- git-annex metadata log, pure operations+ -+ - Copyright 2014-2018 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Logs.MetaData.Pure (+	Log,+	LogEntry(..),+	parseLog,+	showLog,+	logToCurrentMetaData,+	simplifyLog,+	filterRemoteMetaData,+	filterOutEmpty,+) where++import Types.MetaData+import Logs.SingleValue.Pure+import Types.UUID++import qualified Data.Set as S+import qualified Data.Map.Strict as M++instance SingleValueSerializable MetaData where+	serialize = Types.MetaData.serialize+	deserialize = Types.MetaData.deserialize++logToCurrentMetaData :: [LogEntry MetaData] -> MetaData+logToCurrentMetaData = currentMetaData . combineMetaData . map value++{- Simplify a log, removing historical values that are no longer+ - needed. + -+ - This is not as simple as just making a single log line with the newest+ - state of all metadata. Consider this case:+ -+ - We have:+ -+ - 100 foo +x bar +y+ - 200 foo -x+ -+ - An unmerged remote has:+ -+ - 150 bar -y baz +w+ -+ - If what we have were simplified to "200 foo -x bar +y" then when the line+ - from the remote became available, it would be older than the simplified+ - line, and its change to bar would not take effect. That is wrong.+ -+ - Instead, simplify it to:+ -+ - 100 bar +y+ - 200 foo -x+ -+ - (Note that this ends up with the same number of lines as the+ - unsimplified version, so there's really no point in updating+ - the log to this version. Doing so would only add data to git,+ - with little benefit.)+ -+ - Now merging with the remote yields:+ -+ - 100 bar +y+ - 150 bar -y baz +w+ - 200 foo -x+ -+ - Simplifying again:+ -+ - 150 bar +z baz +w+ - 200 foo -x+ -}+simplifyLog :: Log MetaData -> Log MetaData+simplifyLog s = case sl of+	(newest:rest) -> +		let sl' = go [newest] (value newest) rest+		in if length sl' < length sl+			then S.fromList sl'+			else s+	_ -> s+  where+	sl = S.toDescList s++	go c _ [] = c+	go c newer (l:ls)+		| unique == emptyMetaData = go c newer ls+		| otherwise = go (l { value = unique } : c)+			(unionMetaData unique newer) ls+	  where+		older = value l+		unique = older `differenceMetaData` newer++{- Filters per-remote metadata on the basis of UUID.+ -+ - Note that the LogEntry's clock is left the same, so this should not be+ - used except for in a transition.+ -}+filterRemoteMetaData :: (UUID -> Bool) -> Log MetaData -> Log MetaData+filterRemoteMetaData p = S.map go+  where+	go l@(LogEntry { value = MetaData m }) = +		l { value = MetaData $ M.filterWithKey fil m }+	fil f _v = case splitRemoteMetaDataField f of+		Just (u, _) -> p u+		Nothing -> True++{- Filters out log lines that are empty. -}+filterOutEmpty :: Log MetaData -> Log MetaData+filterOutEmpty = S.filter $ \l -> value l /= emptyMetaData
Logs/PreferredContent.hs view
@@ -58,7 +58,7 @@ 	m <- getmap 	case M.lookup u m of 		Nothing -> return d-		Just matcher -> checkMatcher matcher mkey afile notpresent d+		Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d)  preferredContentMap :: Annex (FileMatcherMap Annex) preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad) return
Logs/SingleValue.hs view
@@ -11,45 +11,19 @@  - Licensed under the GNU GPL version 3 or higher.  -} -module Logs.SingleValue where+module Logs.SingleValue (+	module Logs.SingleValue.Pure,+	readLog,+	getLog,+	setLog,+) where  import Annex.Common import qualified Annex.Branch-import Logs.Line+import Logs.SingleValue.Pure import Annex.VectorClock  import qualified Data.Set as S--class SingleValueSerializable v where-	serialize :: v -> String-	deserialize :: String -> Maybe v--data LogEntry v = LogEntry-	{ changed :: VectorClock-	, value :: v-	} deriving (Eq, Ord)--type Log v = S.Set (LogEntry v)--showLog :: (SingleValueSerializable v) => Log v -> String-showLog = unlines . map showline . S.toList-  where-	showline (LogEntry c v) = unwords [formatVectorClock c, serialize v]--parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v-parseLog = S.fromList . mapMaybe parse . splitLines-  where-	parse line = do-		let (sc, s) = splitword line-		c <- parseVectorClock sc-		v <- deserialize s-		Just (LogEntry c v)-	splitword = separate (== ' ')--newestValue :: Log v -> Maybe v-newestValue s-	| S.null s = Nothing-	| otherwise = Just (value $ S.findMax s)  readLog :: (Ord v, SingleValueSerializable v) => FilePath -> Annex (Log v) readLog = parseLog <$$> Annex.Branch.get
+ Logs/SingleValue/Pure.hs view
@@ -0,0 +1,45 @@+{- git-annex single-value log, pure operations+ -+ - Copyright 2014 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Logs.SingleValue.Pure where++import Annex.Common+import Logs.Line+import Annex.VectorClock++import qualified Data.Set as S++class SingleValueSerializable v where+	serialize :: v -> String+	deserialize :: String -> Maybe v++data LogEntry v = LogEntry+	{ changed :: VectorClock+	, value :: v+	} deriving (Eq, Ord)++type Log v = S.Set (LogEntry v)++showLog :: (SingleValueSerializable v) => Log v -> String+showLog = unlines . map showline . S.toList+  where+	showline (LogEntry c v) = unwords [formatVectorClock c, serialize v]++parseLog :: (Ord v, SingleValueSerializable v) => String -> Log v+parseLog = S.fromList . mapMaybe parse . splitLines+  where+	parse line = do+		let (sc, s) = splitword line+		c <- parseVectorClock sc+		v <- deserialize s+		Just (LogEntry c v)+	splitword = separate (== ' ')++newestValue :: Log v -> Maybe v+newestValue s+	| S.null s = Nothing+	| otherwise = Just (value $ S.findMax s)
Logs/Trust.hs view
@@ -66,8 +66,12 @@ trustMapLoad = do 	overrides <- Annex.getState Annex.forcetrust 	l <- remoteList-	-- Exports are never trusted, since they are not key/value stores.-	exports <- filterM Types.Remote.isExportSupported l+	-- Exports are not trusted, since they are not key/value stores.+	-- This does not apply to appendonly exports, which are key/value+	-- stores.+	let untrustworthy r = pure (not (Types.Remote.appendonly r)) +		<&&> Types.Remote.isExportSupported r +	exports <- filterM untrustworthy l 	let exportoverrides = M.fromList $ 		map (\r -> (Types.Remote.uuid r, UnTrusted)) exports 	logged <- trustMapRaw
P2P/IO.hs view
@@ -38,6 +38,7 @@ import Control.Monad.Free import Control.Monad.IO.Class import System.Exit (ExitCode(..))+import System.IO.Error import Network.Socket import Control.Concurrent import Control.Concurrent.Async@@ -159,9 +160,11 @@ 			Left e -> return (Left (show e)) 			Right () -> runner next 	ReceiveMessage next -> do-		v <- liftIO $ tryNonAsync $ getProtocolLine (connIhdl conn)+		v <- liftIO $ tryIOError $ getProtocolLine (connIhdl conn) 		case v of-			Left e -> return (Left (show e))+			Left e+				| isEOFError e -> runner (next (Just ProtocolEOF))+				| otherwise -> return (Left (show e)) 			Right Nothing -> return (Left "protocol error") 			Right (Just l) -> case parseMessage l of 				Just m -> do
P2P/Protocol.hs view
@@ -83,6 +83,7 @@ 	| DATA Len -- followed by bytes of data 	| VALIDITY Validity 	| ERROR String+	| ProtocolEOF 	deriving (Show)  instance Proto.Sendable Message where@@ -108,6 +109,7 @@ 	formatMessage (VALIDITY Invalid) = ["INVALID"] 	formatMessage (DATA len) = ["DATA", Proto.serialize len] 	formatMessage (ERROR err) = ["ERROR", Proto.serialize err]+	formatMessage (ProtocolEOF) = []  instance Proto.Receivable Message where 	parseCommand "AUTH" = Proto.parse2 AUTH@@ -367,6 +369,8 @@ serverLoop a = do 	mcmd <- net receiveMessage 	case mcmd of+		-- Stop loop at EOF+		Just ProtocolEOF -> return Nothing 		-- When the client sends ERROR to the server, the server 		-- gives up, since it's not clear what state the client 		-- is in, and so not possible to recover.
Remote/Adb.hs view
@@ -71,6 +71,7 @@ 		, remotetype = remote 		, availability = LocallyAvailable 		, readonly = False+		, appendonly = False 		, mkUnavailable = return Nothing 		, getInfo = return 			[ ("androidserial", fromAndroidSerial serial)
Remote/BitTorrent.hs view
@@ -76,6 +76,7 @@ 		, localpath = Nothing 		, getRepo = return r 		, readonly = True+		, appendonly = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/Bup.hs view
@@ -79,6 +79,7 @@ 		, remotetype = remote 		, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable 		, readonly = False+		, appendonly = False 		, mkUnavailable = return Nothing 		, getInfo = return [("repo", buprepo)] 		, claimUrl = Nothing
Remote/Ddar.hs view
@@ -78,6 +78,7 @@ 		, remotetype = remote 		, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable 		, readonly = False+		, appendonly = False 		, mkUnavailable = return Nothing 		, getInfo = return [("repo", ddarRepoLocation ddarrepo)] 		, claimUrl = Nothing
Remote/Directory.hs view
@@ -81,6 +81,7 @@ 			, gitconfig = gc 			, localpath = Just dir 			, readonly = False+			, appendonly = False 			, availability = LocallyAvailable 			, remotetype = remote 			, mkUnavailable = gen r u c $
Remote/External.hs view
@@ -127,6 +127,7 @@ 			, getRepo = return r 			, gitconfig = gc 			, readonly = False+			, appendonly = False 			, availability = avail 			, remotetype = remote  				{ exportSupported = cheapexportsupported }
Remote/GCrypt.hs view
@@ -127,6 +127,7 @@ 		, getRepo = return r 		, gitconfig = gc 		, readonly = Git.repoIsHttp r+		, appendonly = False 		, availability = availabilityCalc r 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/Git.hs view
@@ -179,6 +179,7 @@ 			, getRepo = getRepoFromState st 			, gitconfig = gc 			, readonly = Git.repoIsHttp r+			, appendonly = False 			, availability = availabilityCalc r 			, remotetype = remote 			, mkUnavailable = unavailable r u c gc
Remote/Glacier.hs view
@@ -73,6 +73,7 @@ 			, gitconfig = gc 			, localpath = Nothing 			, readonly = False+			, appendonly = False 			, availability = GloballyAvailable 			, remotetype = remote 			, mkUnavailable = return Nothing
Remote/Helper/Export.hs view
@@ -113,24 +113,20 @@ 			{ storeKey = \_ _ _ -> do 				warning "remote is configured with exporttree=yes; use `git-annex export` to store content on it" 				return False-			-- Keys can be retrieved, but since an export-			-- is not a true key/value store, the content of-			-- the key has to be able to be strongly verified.-			, retrieveKeyFile = \k _af dest p -> unVerified $-				if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))-					then do-						locs <- getexportlocs k-						case locs of-							[] -> do-								warning "unknown export location"-								return False-							(l:_) -> do-								ea <- exportActions r-								retrieveExport ea k l dest p-					else do-						warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"-						return False-			, retrieveKeyFileCheap = \_ _ _ -> return False+			-- Keys can be retrieved using retrieveExport, +			-- but since that retrieves from a path in the+			-- remote that another writer could have replaced+			-- with content not of the requested key,+			-- the content has to be strongly verified.+			--+			-- But, appendonly remotes have a key/value store,+			-- so don't need to use retrieveExport.+			, retrieveKeyFile = if appendonly r+				then retrieveKeyFile r+				else retrieveKeyFileFromExport getexportlocs+			, retrieveKeyFileCheap = if appendonly r+				then retrieveKeyFileCheap r+				else \_ _ _ -> return False 			-- Removing a key from an export would need to 			-- change the tree in the export log to not include 			-- the file. Otherwise, conflicts when removing@@ -143,16 +139,40 @@ 			-- Can't lock content on exports, since they're 			-- not key/value stores, and someone else could 			-- change what's exported to a file at any time.-			, lockContent = Nothing-			-- Check if any of the files a key was exported-			-- to are present. This doesn't guarantee the-			-- export contains the right content.-			, checkPresent = \k -> do-				ea <- exportActions r-				anyM (checkPresentExport ea k)-					=<< getexportlocs k+			--+			-- (except for appendonly remotes)+			, lockContent = if appendonly r+				then lockContent r+				else Nothing+			-- Check if any of the files a key was exported to+			-- are present. This doesn't guarantee the export+			-- contains the right content, which is why export+			-- remotes are untrusted.+			--+			-- (but appendonly remotes work the same as any+			-- non-export remote)+			, checkPresent = if appendonly r+				then checkPresent r+				else \k -> do+					ea <- exportActions r+					anyM (checkPresentExport ea k)+						=<< getexportlocs k 			, mkUnavailable = return Nothing 			, getInfo = do 				is <- getInfo r 				return (is++[("export", "yes")]) 			}+	retrieveKeyFileFromExport getexportlocs k _af dest p = unVerified $+		if maybe False (isJust . verifyKeyContent) (maybeLookupBackendVariety (keyVariety k))+			then do+				locs <- getexportlocs k+				case locs of+					[] -> do+						warning "unknown export location"+						return False+					(l:_) -> do+						ea <- exportActions r+						retrieveExport ea k l dest p+			else do+				warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"+				return False
Remote/Hook.hs view
@@ -65,6 +65,7 @@ 			, getRepo = return r 			, gitconfig = gc 			, readonly = False+			, appendonly = False 			, availability = GloballyAvailable 			, remotetype = remote 			, mkUnavailable = gen r u c $
Remote/P2P.hs view
@@ -67,6 +67,7 @@ 		, getRepo = return r 		, gitconfig = gc 		, readonly = False+		, appendonly = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/Rsync.hs view
@@ -95,6 +95,7 @@ 				then Just $ rsyncUrl o 				else Nothing 			, readonly = False+			, appendonly = False 			, availability = if islocal then LocallyAvailable else GloballyAvailable 			, remotetype = remote 			, mkUnavailable = return Nothing
Remote/S3.hs view
@@ -18,8 +18,9 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as S+import qualified Data.ByteString as BS import qualified Data.Map as M+import qualified Data.Set as S import Data.Char import Network.Socket (HostName) import Network.HTTP.Conduit (Manager)@@ -45,6 +46,8 @@ import Creds import Annex.UUID import Logs.Web+import Logs.MetaData+import Types.MetaData import Utility.Metered import qualified Annex.Url as Url import Utility.DataUnits@@ -52,6 +55,7 @@ import Annex.Content import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, UrlOptions(..))+import Utility.Env  type BucketName = String type BucketObject = String@@ -73,9 +77,9 @@   where 	new cst info = Just $ specialRemote c 		(prepareS3Handle this $ store this info)-		(prepareS3HandleMaybe this $ retrieve this info)+		(prepareS3HandleMaybe this $ retrieve this c info) 		(prepareS3Handle this $ remove info)-		(prepareS3HandleMaybe this $ checkKey this info)+		(prepareS3HandleMaybe this $ checkKey this c info) 		this 	  where 		this = Remote@@ -102,7 +106,7 @@ 					, removeExportDirectory = Nothing 					, renameExport = renameExportS3 u info mh 					}-			, whereisKey = Just (getWebUrls info c)+			, whereisKey = Just (getPublicWebUrls u info c) 			, remoteFsck = Nothing 			, repairRepo = Nothing 			, config = c@@ -110,6 +114,7 @@ 			, gitconfig = gc 			, localpath = Nothing 			, readonly = False+			, appendonly = versioning info 			, availability = GloballyAvailable 			, remotetype = remote 			, mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc@@ -186,13 +191,13 @@  store :: Remote -> S3Info -> S3Handle -> Storer store _r info h = fileStorer $ \k f p -> do-	storeHelper info h f (T.pack $ bucketObject info k) p+	void $ storeHelper info h f (T.pack $ bucketObject info k) p 	-- Store public URL to item in Internet Archive. 	when (isIA info && not (isChunkKey k)) $ 		setUrlPresent webUUID k (iaPublicUrl info (bucketObject info k)) 	return True -storeHelper :: S3Info -> S3Handle -> FilePath -> S3.Object -> MeterUpdate -> Annex ()+storeHelper :: S3Info -> S3Handle -> FilePath -> S3.Object -> MeterUpdate -> Annex (Maybe S3VersionID) storeHelper info h f object p = case partSize info of 	Just partsz | partsz > 0 -> do 		fsz <- liftIO $ getFileSize f@@ -203,9 +208,10 @@   where 	singlepartupload = do 		rbody <- liftIO $ httpBodyStorer f p-		void $ sendS3Handle h $ putObject info object rbody+		r <- sendS3Handle h $ putObject info object rbody+		return (mkS3VersionID object (S3.porVersionId r)) 	multipartupload fsz partsz = do-#if MIN_VERSION_aws(0,10,6)+#if MIN_VERSION_aws(0,16,0) 		let startreq = (S3.postInitiateMultipartUpload (bucket info) object) 				{ S3.imuStorageClass = Just (storageClass info) 				, S3.imuMetadata = metaHeaders info@@ -240,8 +246,9 @@ 						sendparts (offsetMeterUpdate meter (toBytesProcessed sz)) (etag:etags) (partnum + 1) 			sendparts p [] 1 -		void $ sendS3Handle h $ S3.postCompleteMultipartUpload+		r <- sendS3Handle h $ S3.postCompleteMultipartUpload 			(bucket info) object uploadid (zip [1..] etags)+		return (mkS3VersionID object (S3.cmurVersionId r)) #else 		warning $ "Cannot do multipart upload (partsize " ++ show partsz ++ ") of large file (" ++ show fsz ++ "); built with too old a version of the aws library." 		singlepartupload@@ -250,20 +257,24 @@ {- Implemented as a fileRetriever, that uses conduit to stream the chunks  - out to the file. Would be better to implement a byteRetriever, but  - that is difficult. -}-retrieve :: Remote -> S3Info -> Maybe S3Handle -> Retriever-retrieve _ info (Just h) = fileRetriever $ \f k p ->-	retrieveHelper info h (T.pack $ bucketObject info k) f p-retrieve r info Nothing = case getpublicurl info of-	Nothing -> \_ _ _ -> do-		needS3Creds (uuid r)-		return False-	Just geturl -> fileRetriever $ \f k p ->-		unlessM (downloadUrl k p [geturl $ bucketObject info k] f) $+retrieve :: Remote -> RemoteConfig -> S3Info -> Maybe S3Handle -> Retriever+retrieve r _ info (Just h) = fileRetriever $ \f k p -> do+	loc <- eitherS3VersionID info (uuid r) k (T.pack $ bucketObject info k)+	retrieveHelper info h loc f p+retrieve r c info Nothing = fileRetriever $ \f k p ->+	getPublicWebUrls (uuid r) info c k >>= \case+		[] -> do+			needS3Creds (uuid r)+			giveup "No S3 credentials configured"+		us -> unlessM (downloadUrl k p us f) $ 			giveup "failed to download content" -retrieveHelper :: S3Info -> S3Handle -> S3.Object -> FilePath -> MeterUpdate -> Annex ()-retrieveHelper info h object f p = liftIO $ runResourceT $ do-	let req = S3.getObject (bucket info) object+retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Annex ()+retrieveHelper info h loc f p = liftIO $ runResourceT $ do+	let req = case loc of+		Left o -> S3.getObject (bucket info) o+		Right (S3VersionID o vid) -> (S3.getObject (bucket info) o)+			{ S3.goVersionId = Just (T.pack vid) } 	S3.GetObjectResponse { S3.gorResponse = rsp } <- sendS3Handle' h req 	Url.sinkResponseFile p zeroBytesProcessed f WriteMode rsp @@ -279,21 +290,24 @@ 		S3.DeleteObject (T.pack $ bucketObject info k) (bucket info) 	return $ either (const False) (const True) res -checkKey :: Remote -> S3Info -> Maybe S3Handle -> CheckPresent-checkKey r info Nothing k = case getpublicurl info of-	Nothing -> do-		needS3Creds (uuid r)-		giveup "No S3 credentials configured"-	Just geturl -> do-		showChecking r-		withUrlOptions $ liftIO . -			checkBoth (geturl $ bucketObject info k) (keySize k)-checkKey r info (Just h) k = do+checkKey :: Remote -> RemoteConfig -> S3Info -> Maybe S3Handle -> CheckPresent+checkKey r _ info (Just h) k = do 	showChecking r-	checkKeyHelper info h (T.pack $ bucketObject info k)+	loc <- eitherS3VersionID info (uuid r) k (T.pack $ bucketObject info k)+	checkKeyHelper info h loc+checkKey r c info Nothing k = +	getPublicWebUrls (uuid r) info c k >>= \case+		[] -> do+			needS3Creds (uuid r)+			giveup "No S3 credentials configured"+		us -> do+			showChecking r+			let check u = withUrlOptions $ +				liftIO . checkBoth u (keySize k)+			anyM check us -checkKeyHelper :: S3Info -> S3Handle -> S3.Object -> Annex Bool-checkKeyHelper info h object = do+checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool+checkKeyHelper info h loc = do #if MIN_VERSION_aws(0,10,0) 	rsp <- go 	return (isJust $ S3.horMetadata rsp)@@ -303,7 +317,11 @@ 		return True #endif   where-	go = sendS3Handle h $ S3.headObject (bucket info) object+	go = sendS3Handle h req+	req = case loc of+		Left o -> S3.headObject (bucket info) o+		Right (S3VersionID o vid) -> (S3.headObject (bucket info) o)+			{ S3.hoVersionId = Just (T.pack vid) }  #if ! MIN_VERSION_aws(0,10,0) 	{- Catch exception headObject returns when an object is not present@@ -319,11 +337,13 @@ #endif  storeExportS3 :: UUID -> S3Info -> Maybe S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool-storeExportS3 _u info (Just h) f _k loc p = +storeExportS3 u info (Just h) f k loc p =  	catchNonAsync go (\e -> warning (show e) >> return False)   where 	go = do-		storeHelper info h f (T.pack $ bucketExportLocation info loc) p+		let o = T.pack $ bucketExportLocation info loc+		storeHelper info h f o p+			>>= setS3VersionID info u k 		return True storeExportS3 u _ Nothing _ _ _ _ = do 	needS3Creds u@@ -335,9 +355,9 @@   where 	go = case mh of 		Just h -> do-			retrieveHelper info h (T.pack exporturl) f p+			retrieveHelper info h (Left (T.pack exporturl)) f p 			return True-		Nothing -> case getpublicurl info of+		Nothing -> case getPublicUrlMaker info of 			Nothing -> do 				needS3Creds u 				return False@@ -359,8 +379,8 @@  checkPresentExportS3 :: UUID -> S3Info -> Maybe S3Handle -> Key -> ExportLocation -> Annex Bool checkPresentExportS3 _u info (Just h) _k loc =-	checkKeyHelper info h (T.pack $ bucketExportLocation info loc)-checkPresentExportS3 u info Nothing k loc = case getpublicurl info of+	checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc))+checkPresentExportS3 u info Nothing k loc = case getPublicUrlMaker info of 	Nothing -> do 		needS3Creds u 		giveup "No S3 credentials configured"@@ -536,14 +556,14 @@ 	proto 		| port == 443 = AWS.HTTPS 		| otherwise = AWS.HTTP-	host = fromJust $ M.lookup "host" c+	h = fromJust $ M.lookup "host" c 	datacenter = fromJust $ M.lookup "datacenter" c 	-- When the default S3 host is configured, connect directly to 	-- the S3 endpoint for the configured datacenter. 	-- When another host is configured, it's used as-is. 	endpoint-		| host == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter-		| otherwise = T.encodeUtf8 $ T.pack host+		| h == AWS.s3DefaultHost = AWS.s3HostName $ T.pack datacenter+		| otherwise = T.encodeUtf8 $ T.pack h 	port = let s = fromJust $ M.lookup "port" c in 		case reads s of 		[(p, _)] -> p@@ -558,8 +578,10 @@ 	, metaHeaders :: [(T.Text, T.Text)] 	, partSize :: Maybe Integer 	, isIA :: Bool+	, versioning :: Bool 	, public :: Bool-	, getpublicurl :: Maybe (BucketObject -> URLString)+	, publicurl :: Maybe URLString+	, host :: Maybe String 	}  extractS3Info :: RemoteConfig -> Annex S3Info@@ -568,7 +590,7 @@ 		(giveup "S3 bucket not configured") 		(return . T.pack) 		(getBucketName c)-	let info = S3Info+	return $ S3Info 		{ bucket = b 		, storageClass = getStorageClass c 		, bucketObject = getBucketObject c@@ -576,20 +598,15 @@ 		, metaHeaders = getMetaHeaders c 		, partSize = getPartSize c 		, isIA = configIA c-		, public = case M.lookup "public" c of-			Just "yes" -> True-			_ -> False-		, getpublicurl = case M.lookup "publicurl" c of-			Just u -> Just $ \p -> genericPublicUrl p u-			Nothing -> case M.lookup "host" c of-				Just h-					| h == AWS.s3DefaultHost ->-						Just (awsPublicUrl info)-					| isIAHost h ->-						Just (iaPublicUrl info)-				_ -> Nothing+		, versioning = boolcfg "versioning"+		, public = boolcfg "public"+		, publicurl = M.lookup "publicurl" c+		, host = M.lookup "host" c 		}-	return info+  where+	boolcfg k = case M.lookup k c of+		Just "yes" -> True+		_ -> False  putObject :: S3Info -> T.Text -> RequestBody -> S3.PutObject putObject info file rbody = (S3.putObject (bucket info) file rbody)@@ -665,22 +682,24 @@ iaItemUrl b = "http://archive.org/details/" ++ b  iaPublicUrl :: S3Info -> BucketObject -> URLString-iaPublicUrl info p = genericPublicUrl p $+iaPublicUrl info = genericPublicUrl $ 	"http://archive.org/download/" ++ T.unpack (bucket info) ++ "/"   awsPublicUrl :: S3Info -> BucketObject -> URLString-awsPublicUrl info p = genericPublicUrl p $ +awsPublicUrl info = genericPublicUrl $  	"https://" ++ T.unpack (bucket info) ++ ".s3.amazonaws.com/"  -genericPublicUrl :: BucketObject -> URLString -> URLString-genericPublicUrl p baseurl = baseurl ++ p+genericPublicUrl :: URLString -> BucketObject -> URLString+genericPublicUrl baseurl p = baseurl ++ p  genCredentials :: CredPair -> IO AWS.Credentials genCredentials (keyid, secret) = AWS.Credentials-	<$> pure (T.encodeUtf8 (T.pack keyid))-	<*> pure (T.encodeUtf8 (T.pack secret))+	<$> pure (tobs keyid)+	<*> pure (tobs secret) 	<*> newIORef []-	<*> pure Nothing+	<*> (fmap tobs <$> getEnv "AWS_SESSION_TOKEN")+  where+	tobs = T.encodeUtf8 . T.pack  mkLocationConstraint :: AWS.Region -> S3.LocationConstraint mkLocationConstraint "US" = S3.locationUsClassic@@ -698,7 +717,7 @@ s3Info :: RemoteConfig -> S3Info -> [(String, String)] s3Info c info = catMaybes 	[ Just ("bucket", fromMaybe "unknown" (getBucketName c))-	, Just ("endpoint", w82s (S.unpack (S3.s3Endpoint s3c)))+	, Just ("endpoint", w82s (BS.unpack (S3.s3Endpoint s3c))) 	, Just ("port", show (S3.s3Port s3c)) 	, Just ("storage class", showstorageclass (getStorageClass c)) 	, if configIA c@@ -706,6 +725,7 @@ 		else Nothing 	, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c)) 	, Just ("public", if public info then "yes" else "no")+	, Just ("versioning", if versioning info then "yes" else "no") 	]   where 	s3c = s3Configuration c@@ -714,10 +734,102 @@ #endif 	showstorageclass sc = show sc -getWebUrls :: S3Info -> RemoteConfig -> Key -> Annex [URLString]-getWebUrls info c k-	| exportTree c = return []-	| otherwise = case (public info, getpublicurl info) of-		(True, Just geturl) -> return [geturl $ bucketObject info k]-		_ -> return []+getPublicWebUrls :: UUID -> S3Info -> RemoteConfig -> Key -> Annex [URLString]+getPublicWebUrls u info c k+	| not (public info) = return []+	| exportTree c = if versioning info+		then case publicurl info of+			Just url -> getS3VersionIDPublicUrls (const $ genericPublicUrl url) info u k+			Nothing -> case host info of+				Just h | h == AWS.s3DefaultHost ->+					getS3VersionIDPublicUrls awsPublicUrl info u k+				_ -> return []+		else return []+	| otherwise = case getPublicUrlMaker info of+		Just geturl -> return [geturl $ bucketObject info k]+		Nothing -> return [] +getPublicUrlMaker :: S3Info -> Maybe (BucketObject -> URLString)+getPublicUrlMaker info = case publicurl info of+	Just url -> Just (genericPublicUrl url)+	Nothing -> case host info of+		Just h+			| h == AWS.s3DefaultHost ->+				Just (awsPublicUrl info)+			| isIAHost h ->+				Just (iaPublicUrl info)+		_ -> Nothing+++data S3VersionID = S3VersionID S3.Object String+	deriving (Show)++-- smart constructor+mkS3VersionID :: S3.Object -> Maybe T.Text -> Maybe S3VersionID+mkS3VersionID o = mkS3VersionID' o . fmap T.unpack++mkS3VersionID' :: S3.Object -> Maybe String -> Maybe S3VersionID+mkS3VersionID' o (Just s)+	| null s = Nothing+	-- AWS documentation says a version ID is at most 1024 bytes long.+	-- Since they are stored in the git-annex branch, prevent them from+	-- being very much larger than that.+	| length s < 2048 = Just (S3VersionID o s)+	| otherwise = Nothing+mkS3VersionID' _ Nothing = Nothing++-- Format for storage in per-remote metadata.+--+-- A S3 version ID is "url ready" so does not contain '#' and so we'll use+-- that to separate it from the object id. (Could use a space, but spaces+-- in metadata values lead to an inefficient encoding.)+formatS3VersionID :: S3VersionID -> String+formatS3VersionID (S3VersionID o v) = v ++ '#' : T.unpack o++-- Parse from value stored in per-remote metadata.+parseS3VersionID :: String -> Maybe S3VersionID+parseS3VersionID s = +	let (v, o) = separate (== '#') s+	in mkS3VersionID' (T.pack o) (Just v)++setS3VersionID :: S3Info -> UUID -> Key -> Maybe S3VersionID -> Annex ()+setS3VersionID info u k vid+	| versioning info = maybe noop (setS3VersionID' u k) vid+	| otherwise = noop++setS3VersionID' :: UUID -> Key -> S3VersionID -> Annex ()+setS3VersionID' u k vid = addRemoteMetaData k $+	RemoteMetaData u (updateMetaData s3VersionField v emptyMetaData)+  where+	v = mkMetaValue (CurrentlySet True) (formatS3VersionID vid)++getS3VersionID :: UUID -> Key -> Annex [S3VersionID]+getS3VersionID u k = do+	(RemoteMetaData _ m) <- getCurrentRemoteMetaData u k+	return $ mapMaybe parseS3VersionID $ map unwrap $ S.toList $+		metaDataValues s3VersionField m+  where+	unwrap (MetaValue _ v) = v++s3VersionField :: MetaField+s3VersionField = mkMetaFieldUnchecked "V"++eitherS3VersionID :: S3Info -> UUID -> Key -> S3.Object -> Annex (Either S3.Object S3VersionID)+eitherS3VersionID info u k fallback+	| versioning info = getS3VersionID u k >>= return . \case+		[] -> Left fallback+		-- It's possible for a key to be stored multiple timees in+		-- a bucket with different version IDs; only use one of them.+		(v:_) -> Right v+	| otherwise = return (Left fallback)++s3VersionIDPublicUrl :: (S3Info -> BucketObject -> URLString) -> S3Info -> S3VersionID -> URLString+s3VersionIDPublicUrl mk info (S3VersionID obj vid) = mk info $ concat+	[ T.unpack obj+	, "?versionId="+	, vid -- version ID is "url ready" so no escaping needed+	]++getS3VersionIDPublicUrls :: (S3Info -> BucketObject -> URLString) -> S3Info -> UUID -> Key -> Annex [URLString]+getS3VersionIDPublicUrls mk info u k =+	map (s3VersionIDPublicUrl mk info) <$> getS3VersionID u k
Remote/Tahoe.hs view
@@ -88,6 +88,7 @@ 		, gitconfig = gc 		, localpath = Nothing 		, readonly = False+		, appendonly = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/Web.hs view
@@ -66,6 +66,7 @@ 		, localpath = Nothing 		, getRepo = return r 		, readonly = True+		, appendonly = False 		, availability = GloballyAvailable 		, remotetype = remote 		, mkUnavailable = return Nothing
Remote/WebDAV.hs view
@@ -96,6 +96,7 @@ 			, gitconfig = gc 			, localpath = Nothing 			, readonly = False+			, appendonly = False 			, availability = GloballyAvailable 			, remotetype = remote 			, mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
Types/MetaData.hs view
@@ -1,6 +1,6 @@ {- git-annex general metadata  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -36,6 +36,10 @@ 	metaDataValues, 	ModMeta(..), 	modMeta,+	RemoteMetaData(..),+	extractRemoteMetaData,+	splitRemoteMetaDataField,+	fromRemoteMetaData, 	prop_metadata_sane, 	prop_metadata_serialize ) where@@ -44,6 +48,7 @@ import Utility.Base64 import Utility.QuickCheck import Utility.Aeson+import Types.UUID  import qualified Data.Text as T import qualified Data.Set as S@@ -281,6 +286,37 @@ 	| S.null (currentMetaDataValues f m) = updateMetaData f v emptyMetaData 	| otherwise = emptyMetaData modMeta m (ComposeModMeta a b) = unionMetaData (modMeta m a) (modMeta m b)++data RemoteMetaData = RemoteMetaData UUID MetaData+	deriving (Show, Eq, Ord)++{- Extracts only the fields prefixed with "uuid:", which belong to that+ - remote. -}+extractRemoteMetaData :: UUID -> MetaData -> RemoteMetaData+extractRemoteMetaData u (MetaData m) = RemoteMetaData u $ MetaData $+	M.mapKeys removeprefix $ M.filterWithKey belongsremote m+  where+	belongsremote (MetaField f) _v = prefix `isPrefixOf` CI.original f+	removeprefix (MetaField f) = MetaField $ +		CI.mk $ drop prefixlen $ CI.original f+	prefix = remoteMetaDataPrefix u+	prefixlen = length prefix++splitRemoteMetaDataField :: MetaField -> Maybe (UUID, MetaField)+splitRemoteMetaDataField (MetaField f) = do+	let (su, sf) = separate (== ':') (CI.original f)+	f' <- toMetaField sf+	return $ (toUUID su, f')++remoteMetaDataPrefix :: UUID -> String+remoteMetaDataPrefix u = fromUUID u ++ ":"++fromRemoteMetaData :: RemoteMetaData -> MetaData+fromRemoteMetaData (RemoteMetaData u (MetaData m)) = MetaData $+	M.mapKeys addprefix m+  where+	addprefix (MetaField f) = MetaField $ CI.mk $ (prefix ++) $ CI.original f+	prefix = remoteMetaDataPrefix u  {- Avoid putting too many fields in the map; extremely large maps make  - the seriaization test slow due to the sheer amount of data.
Types/Remote.hs view
@@ -55,7 +55,7 @@ 	-- enumerates remotes of this type 	-- The Bool is True if automatic initialization of remotes is desired 	, enumerate :: Bool -> a [Git.Repo]-	-- generates a remote of this type from the current git config+	-- generates a remote of this type 	, generate :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> a (Maybe (RemoteA a)) 	-- initializes or enables a remote 	, setup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> a (RemoteConfig, UUID)@@ -122,6 +122,11 @@ 	, localpath :: Maybe FilePath 	-- a Remote can be known to be readonly 	, readonly :: Bool+	-- a Remote can allow writes but not have a way to delete content+	-- from it. Note that an export remote that supports removeExport+	-- to remove a file from the exported tree, but still retains the+	-- content in accessible form should set this to True.+	, appendonly :: Bool 	-- a Remote can be globally available. (Ie, "in the cloud".) 	, availability :: Availability 	-- the type of the remote
Upgrade/V5.hs view
@@ -10,6 +10,7 @@ import Annex.Common import qualified Annex import Config+import Config.Smudge import Annex.InodeSentinal import Annex.Link import Annex.Direct
Utility/DirWatcher/Kqueue.hs view
@@ -109,7 +109,7 @@ 				Nothing -> walk c rest 				Just info -> do 					mfd <- catchMaybeIO $-						openFd dir ReadOnly Nothing defaultFileFlags+						Files.openFd dir Files.ReadOnly Nothing Files.defaultFileFlags 					case mfd of 						Nothing -> walk c rest 						Just fd -> do@@ -129,7 +129,7 @@ {- Removes a subdirectory (and all its children) from a directory map. -} removeSubDir :: DirMap -> FilePath -> IO DirMap removeSubDir dirmap dir = do-	mapM_ closeFd $ M.keys toremove+	mapM_ Files.closeFd $ M.keys toremove 	return rest   where 	(toremove, rest) = M.partition (dirContains dir . dirName) dirmap@@ -167,7 +167,7 @@ {- Stops a Kqueue. Note: Does not directly close the Fds in the dirmap,  - so it can be reused.  -} stopKqueue :: Kqueue -> IO ()-stopKqueue = closeFd . kqueueFd+stopKqueue = Files.closeFd . kqueueFd  {- Waits for a change on a Kqueue.  - May update the Kqueue.
− Utility/ExternalSHA.hs 
@@ -1,67 +0,0 @@-{- Calculating a SHA checksum with an external command.- -- - This is typically a bit faster than using Haskell libraries,- - by around 1% to 10%. Worth it for really big files.- -- - Copyright 2011-2013 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--{-# OPTIONS_GHC -fno-warn-tabs #-}--module Utility.ExternalSHA (externalSHA) where--import Utility.SafeCommand-import Utility.Process-import Utility.Misc-import Utility.Exception--import Data.List-import Data.Char-import System.IO--externalSHA :: String -> Int -> FilePath -> IO (Either String String)-externalSHA command shasize file = do-	v <- tryNonAsync $ readsha $ toCommand [File file]-	return $ case v of-		Right s -> sanitycheck =<< parse (lines s)-		Left _ -> Left (command ++ " failed")-  where-	readsha args = withHandle StdoutHandle createProcessSuccess p $ \h -> do-		output  <- hGetContentsStrict h-		hClose h-		return output-	  where-		p = (proc command args) { std_out = CreatePipe }--	{- The first word of the output is taken to be the sha. -}-	parse [] = bad-	parse (l:_)-		| null sha = bad-		-- sha is prefixed with \ when filename contains certian chars-		| "\\" `isPrefixOf` sha = Right $ drop 1 sha-		| otherwise = Right sha-	  where-		sha = fst $ separate (== ' ') l-	bad = Left $ command ++ " parse error"--	{- Check that we've correctly parsing the output of the command,-	 - by making sure the sha we read is of the expected length-	 - and contains only the right characters. -}-	sanitycheck sha-		| length sha /= expectedSHALength shasize =-			Left $ "Failed to parse the output of " ++ command-		| any (`notElem` "0123456789abcdef") sha' =-			Left $ "Unexpected character in output of " ++ command ++ "\"" ++ sha ++ "\""-		| otherwise = Right sha'-	  where-		sha' = map toLower sha--expectedSHALength :: Int -> Int-expectedSHALength 1 = 40-expectedSHALength 256 = 64-expectedSHALength 512 = 128-expectedSHALength 224 = 56-expectedSHALength 384 = 96-expectedSHALength _ = 0
Utility/Mounts.hs view
@@ -18,7 +18,8 @@ getMounts :: IO [Mntent]  #ifndef __ANDROID__ getMounts = System.MountPoints.getMounts-	-- That will crash when running on Android, so fall back to this.+	-- 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
− Utility/SRV.hs 
@@ -1,52 +0,0 @@-{- SRV record lookup- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--module Utility.SRV (-	mkSRVTcp,-	mkSRV,-	lookupSRV,-	HostPort,-) where--import Data.Function-import Data.List-import Network-import qualified Network.DNS.Lookup as DNS-import Network.DNS.Resolver-import qualified Data.ByteString.UTF8 as B8--newtype SRV = SRV String-	deriving (Show, Eq)--type HostPort = (HostName, PortID)--type PriorityWeight = (Int, Int) -- sort by priority first, then weight--mkSRV :: String -> String -> HostName -> SRV-mkSRV transport protocol host = SRV $ concat-	["_", protocol, "._", transport, ".", host]--mkSRVTcp :: String -> HostName -> SRV-mkSRVTcp = mkSRV "tcp"--{- Returns an ordered list, with highest priority hosts first.- -- - On error, returns an empty list. -}-lookupSRV :: SRV -> IO [HostPort]-lookupSRV (SRV srv) = do-	seed <- makeResolvSeed defaultResolvConf-	r <- withResolver seed $ flip DNS.lookupSRV $ B8.fromString srv-	return $ either (const []) use r-  where-	use = orderHosts . map tohosts-	tohosts (priority, weight, port, hostname) =-		( (fromIntegral priority, fromIntegral weight)-		, (B8.toString hostname, PortNumber $ fromIntegral port)-		)--orderHosts :: [(PriorityWeight, HostPort)] -> [HostPort]-orderHosts = map snd . sortBy (compare `on` fst)
Utility/SafeCommand.hs view
@@ -27,19 +27,21 @@ -- | Used to pass a list of CommandParams to a function that runs -- a command and expects Strings. -} toCommand :: [CommandParam] -> [String]-toCommand = map unwrap+toCommand = map toCommand'++toCommand' :: CommandParam -> String+toCommand' (Param s) = s+-- Files that start with a non-alphanumeric that is not a path+-- separator are modified to avoid the command interpreting them as+-- options or other special constructs.+toCommand' (File s@(h:_))+	| isAlphaNum h || h `elem` pathseps = s+	| otherwise = "./" ++ s   where-	unwrap (Param s) = s-	-- Files that start with a non-alphanumeric that is not a path-	-- separator are modified to avoid the command interpreting them as-	-- options or other special constructs.-	unwrap (File s@(h:_))-		| isAlphaNum h || h `elem` pathseps = s-		| otherwise = "./" ++ s-	unwrap (File s) = s 	-- '/' is explicitly included because it's an alternative 	-- path separator on Windows. 	pathseps = pathSeparator:"./"+toCommand' (File s) = s  -- | Run a system command, and returns True or False if it succeeded or failed. --
Utility/SimpleProtocol.hs view
@@ -113,6 +113,8 @@  - This implementation is not super efficient, but as long as the Handle  - supports buffering, it avoids reading a character at a time at the  - syscall level.+ -+ - Throws isEOFError when no more input is available.  -} getProtocolLine :: Handle -> IO (Maybe String) getProtocolLine h = go (32768 :: Int) []
Utility/Tmp/Dir.hs view
@@ -1,4 +1,4 @@-{- Temporary directorie+{- Temporary directories  -  - Copyright 2010-2013 Joey Hess <id@joeyh.name>  -
doc/git-annex-add.mdwn view
@@ -77,8 +77,9 @@   the file is added, and repeat.    Note that if a file is skipped (due to not existing, being gitignored,-  already being in git etc), an empty line will be output instead of the-  normal output produced when adding a file.+  already being in git, or doesn't meet the matching options), +  an empty line will be output instead of the normal output produced+  when adding a file.  # SEE ALSO
doc/git-annex-copy.mdwn view
@@ -80,8 +80,9 @@   are read from stdin.    As each specified file is processed, the usual progress output is-  displayed. If a file's content does not need to be copied or it-  is not an annexed file, a blank line is output in response instead.+  displayed. If a file's content does not need to be copied, or it does not+  match specified matching options, or it is not an annexed file,+  a blank line is output in response instead.    Since the usual output while copying a file is verbose and not   machine-parseable, you may want to use --json in combination with
doc/git-annex-drop.mdwn view
@@ -82,6 +82,11 @@   Enables batch mode, in which lines containing names of files to drop   are read from stdin. +  As each specified file is processed, the usual output is+  displayed. If a file's content is not present, or it does not+  match specified matching options, or it is not an annexed file,+  a blank line is output in response instead.+ * `--json`    Enable JSON output. This is intended to be parsed by programs that use
doc/git-annex-export.mdwn view
@@ -38,6 +38,13 @@ that are not based on checksums, cannot be downloaded from an export. And, git-annex will never trust an export to retain the content of a key. +However, some special remotes, notably S3, support keeping track of old+versions of files stored in them. If a special remote is set up to do +that, it can be used as a key/value store and the limitations in the above+paragraph do not appy. Note that dropping content from such a remote is+not supported. See individual special remotes' documentation for+details of how to  enable such versioning.+ # OPTIONS  * `--to=remote`
doc/git-annex-get.mdwn view
@@ -90,7 +90,8 @@   are read from stdin.    As each specified file is processed, the usual progress output is-  displayed. If the specified file's content is already present, or+  displayed. If the specified file's content is already present, +  or it does not match specified matching options, or   it is not an annexed file, a blank line is output in response instead.    Since the usual output while getting a file is verbose and not
doc/git-annex-metadata.mdwn view
@@ -152,6 +152,9 @@  	{"file":"foo","fields":{"author":[]}} +  Note that file matching options do not affect the files that are+  processed when in batch mode.+ # EXAMPLES  To set some tags on a file and also its author:
doc/git-annex-move.mdwn view
@@ -80,7 +80,8 @@   are read from stdin.    As each specified file is processed, the usual progress output is-  displayed. If a file's content does not need to be moved or it+  displayed. If a file's content does not need to be moved,+  or it does not match specified matching options, or it   is not an annexed file, a blank line is output in response instead.    Since the usual output while moving a file is verbose and not
doc/git-annex-whereis.mdwn view
@@ -48,7 +48,8 @@   Enables batch mode, in which a file is read in a line from stdin,   its information displayed, and repeat. -  Note that if the file is not an annexed file, an empty line will be+  Note that if the file is not an annexed file, or does not match+  specified file matching options, an empty line will be   output instead.  * `--json`
doc/git-annex.mdwn view
@@ -1296,10 +1296,10 @@  * `remote.<name>.annex-speculate-present` -  Make git-annex speculate that this remote may contain the content of any-  file, even though its normal location tracking does not indicate that it-  does. This will cause git-annex to try to get all file contents from the-  remote. Can be useful in setting up a caching remote.+  Set to "true" to make git-annex speculate that this remote may contain the+  content of any file, even though its normal location tracking does not+  indicate that it does. This will cause git-annex to try to get all file+  contents from the remote. Can be useful in setting up a caching remote.  * `remote.<name>.annex-bare`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20180807+Version: 6.20180913 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -364,6 +364,7 @@    cryptonite,    memory,    split,+   attoparsec,    QuickCheck (>= 2.1),    tasty (>= 0.7),    tasty-hunit,@@ -415,12 +416,91 @@     Other-Modules:       Remote.WebDAV       Remote.WebDAV.DavLocation+  if flag(S3) || flag(WebDAV)+    Other-Modules:+      Remote.Helper.Http    if flag(Assistant) && ! os(solaris) && ! os(gnu)-    Build-Depends: dns (>= 1.0.0), mountpoints+    Build-Depends: mountpoints     CPP-Options: -DWITH_ASSISTANT+    Other-Modules:+      Assistant+      Assistant.Alert+      Assistant.Alert.Utility+      Assistant.BranchChange+      Assistant.Changes+      Assistant.Commits+      Assistant.Common+      Assistant.CredPairCache+      Assistant.DaemonStatus+      Assistant.DeleteRemote+      Assistant.Drop+      Assistant.Fsck+      Assistant.Gpg+      Assistant.Install+      Assistant.Install.AutoStart+      Assistant.Install.Menu+      Assistant.MakeRemote+      Assistant.Monad+      Assistant.NamedThread+      Assistant.Pairing+      Assistant.Pairing.MakeRemote+      Assistant.Pairing.Network+      Assistant.Pushes+      Assistant.RemoteControl+      Assistant.Repair+      Assistant.RepoProblem+      Assistant.Restart+      Assistant.ScanRemotes+      Assistant.Ssh+      Assistant.Sync+      Assistant.Threads.Committer+      Assistant.Threads.ConfigMonitor+      Assistant.Threads.Cronner+      Assistant.Threads.DaemonStatus+      Assistant.Threads.Exporter+      Assistant.Threads.Glacier+      Assistant.Threads.Merger+      Assistant.Threads.MountWatcher+      Assistant.Threads.NetWatcher+      Assistant.Threads.ProblemFixer+      Assistant.Threads.Pusher+      Assistant.Threads.RemoteControl+      Assistant.Threads.SanityChecker+      Assistant.Threads.TransferPoller+      Assistant.Threads.TransferScanner+      Assistant.Threads.TransferWatcher+      Assistant.Threads.Transferrer+      Assistant.Threads.UpgradeWatcher+      Assistant.Threads.Upgrader+      Assistant.Threads.Watcher+      Assistant.TransferQueue+      Assistant.TransferSlots+      Assistant.TransferrerPool+      Assistant.Types.Alert+      Assistant.Types.BranchChange+      Assistant.Types.Changes+      Assistant.Types.Commits+      Assistant.Types.CredPairCache+      Assistant.Types.DaemonStatus+      Assistant.Types.NamedThread+      Assistant.Types.Pushes+      Assistant.Types.RemoteControl+      Assistant.Types.RepoProblem+      Assistant.Types.ScanRemotes+      Assistant.Types.ThreadName+      Assistant.Types.ThreadedMonad+      Assistant.Types.TransferQueue+      Assistant.Types.TransferSlots+      Assistant.Types.TransferrerPool+      Assistant.Types.UrlRenderer+      Assistant.Unused+      Assistant.Upgrade+      Command.Assistant+      Command.Watch+      Utility.Mounts+      Utility.OSX -  if flag(Assistant)     if os(linux) || flag(Android)       Build-Depends: hinotify       CPP-Options: -DWITH_INOTIFY@@ -429,7 +509,8 @@       if os(darwin)         Build-Depends: hfsevents         CPP-Options: -DWITH_FSEVENTS-        Other-Modules: Utility.DirWatcher.FSEvents+        Other-Modules:+          Utility.DirWatcher.FSEvents       else         if os(windows)           Build-Depends: Win32-notify@@ -550,6 +631,8 @@     Annex.Concurrent     Annex.Content     Annex.Content.Direct+    Annex.Content.LowLevel+    Annex.Content.PointerFile     Annex.Difference     Annex.DirHashes     Annex.Direct@@ -594,78 +677,6 @@     Annex.Wanted     Annex.WorkTree     Annex.YoutubeDl-    Assistant-    Assistant.Alert-    Assistant.Alert.Utility-    Assistant.BranchChange-    Assistant.Changes-    Assistant.Commits-    Assistant.Common-    Assistant.CredPairCache-    Assistant.DaemonStatus-    Assistant.DeleteRemote-    Assistant.Drop-    Assistant.Fsck-    Assistant.Gpg-    Assistant.Install-    Assistant.Install.AutoStart-    Assistant.Install.Menu-    Assistant.MakeRemote-    Assistant.Monad-    Assistant.NamedThread-    Assistant.Pairing-    Assistant.Pairing.MakeRemote-    Assistant.Pairing.Network-    Assistant.Pushes-    Assistant.RemoteControl-    Assistant.Repair-    Assistant.RepoProblem-    Assistant.Restart-    Assistant.ScanRemotes-    Assistant.Ssh-    Assistant.Sync-    Assistant.Threads.Committer-    Assistant.Threads.ConfigMonitor-    Assistant.Threads.Cronner-    Assistant.Threads.DaemonStatus-    Assistant.Threads.Exporter-    Assistant.Threads.Glacier-    Assistant.Threads.Merger-    Assistant.Threads.MountWatcher-    Assistant.Threads.NetWatcher-    Assistant.Threads.ProblemFixer-    Assistant.Threads.Pusher-    Assistant.Threads.RemoteControl-    Assistant.Threads.SanityChecker-    Assistant.Threads.TransferPoller-    Assistant.Threads.TransferScanner-    Assistant.Threads.TransferWatcher-    Assistant.Threads.Transferrer-    Assistant.Threads.UpgradeWatcher-    Assistant.Threads.Upgrader-    Assistant.Threads.Watcher-    Assistant.TransferQueue-    Assistant.TransferSlots-    Assistant.TransferrerPool-    Assistant.Types.Alert-    Assistant.Types.BranchChange-    Assistant.Types.Changes-    Assistant.Types.Commits-    Assistant.Types.CredPairCache-    Assistant.Types.DaemonStatus-    Assistant.Types.NamedThread-    Assistant.Types.Pushes-    Assistant.Types.RemoteControl-    Assistant.Types.RepoProblem-    Assistant.Types.ScanRemotes-    Assistant.Types.ThreadName-    Assistant.Types.ThreadedMonad-    Assistant.Types.TransferQueue-    Assistant.Types.TransferSlots-    Assistant.Types.TransferrerPool-    Assistant.Types.UrlRenderer-    Assistant.Unused-    Assistant.Upgrade     Backend     Backend.Hash     Backend.URL@@ -697,7 +708,6 @@     Command.AddUnused     Command.AddUrl     Command.Adjust-    Command.Assistant     Command.CalcKey     Command.CheckPresentKey     Command.Commit@@ -798,7 +808,6 @@     Command.Vicfg     Command.View     Command.Wanted-    Command.Watch     Command.Whereis     Common     Config@@ -806,6 +815,7 @@     Config.Files     Config.DynamicConfig     Config.GitConfig+    Config.Smudge     Creds     Crypto     Database.Export@@ -879,6 +889,7 @@     Logs.Location     Logs.MapLog     Logs.MetaData+    Logs.MetaData.Pure     Logs.Multicast     Logs.NumCopies     Logs.PreferredContent@@ -889,6 +900,7 @@     Logs.RemoteState     Logs.Schedule     Logs.SingleValue+    Logs.SingleValue.Pure     Logs.TimeStamp     Logs.Transfer     Logs.Transitions@@ -929,7 +941,6 @@     Remote.Helper.Export     Remote.Helper.Git     Remote.Helper.Hooks-    Remote.Helper.Http     Remote.Helper.Messages     Remote.Helper.P2P     Remote.Helper.ReadOnly@@ -1017,7 +1028,6 @@     Utility.Env.Basic     Utility.Env.Set     Utility.Exception-    Utility.ExternalSHA     Utility.FileMode     Utility.FileSize     Utility.FileSystemEncoding@@ -1047,10 +1057,8 @@     Utility.Metered     Utility.Misc     Utility.Monad-    Utility.Mounts     Utility.Network     Utility.NotificationBroadcaster-    Utility.OSX     Utility.OptParse     Utility.PID     Utility.Parallel@@ -1063,7 +1071,6 @@     Utility.Process.Transcript     Utility.QuickCheck     Utility.Rsync-    Utility.SRV     Utility.SafeCommand     Utility.Scheduled     Utility.Scheduled.QuickCheck