git-annex 6.20170214 → 6.20170301

raw patch · 89 files changed

+1154/−538 lines, 89 filesdep −cryptohash

Dependencies removed: cryptohash

Files

• Annex/Common.hs +1/−1
• Annex/Concurrent.hs +9/−7
• Annex/Content.hs +36/−11
• Annex/DirHashes.hs +1/−1
• Annex/Direct.hs +4/−1
• Annex/FileMatcher.hs +1/−0
• Annex/Hook.hs +4/−1
• Annex/Ingest.hs +20/−12
• Annex/Init.hs +15/−2
• Annex/Locations.hs +2/−1
• Annex/Perms.hs +1/−1
• Annex/Ssh.hs +14/−4
• Annex/Transfer.hs +27/−2
• Annex/UpdateInstead.hs +27/−0
• Assistant/Threads/SanityChecker.hs +2/−1
• Assistant/Upgrade.hs +2/−2
• Assistant/WebApp/Configurators/Ssh.hs +4/−2
• Backend.hs +23/−21
• Backend/Hash.hs +31/−35
• Backend/URL.hs +3/−2
• Backend/WORM.hs +3/−2
• Build/Configure.hs +3/−3
• Build/DistributionUpdate.hs +2/−1
• Build/EvilLinker.hs +1/−1
• Build/OSXMkLibs.hs +0/−1
• CHANGELOG +68/−0
• CmdLine/GitAnnex.hs +2/−0
• CmdLine/GitAnnex/Options.hs +8/−1
• CmdLine/GlobalSetter.hs +1/−1
• Command.hs +12/−0
• Command/AddUrl.hs +6/−3
• Command/Config.hs +7/−1
• Command/Find.hs +2/−1
• Command/Fsck.hs +11/−2
• Command/Group.hs +3/−2
• Command/GroupWanted.hs +2/−1
• Command/ImportFeed.hs +6/−7
• Command/Indirect.hs +6/−6
• Command/Info.hs +7/−5
• Command/Map.hs +4/−2
• Command/Merge.hs +3/−3
• Command/NumCopies.hs +2/−3
• Command/PostReceive.hs +51/−0
• Command/Reinject.hs +1/−2
• Command/Schedule.hs +2/−4
• Command/Smudge.hs +1/−1
• Command/Status.hs +24/−6
• Command/Sync.hs +78/−29
• Command/TestRemote.hs +2/−2
• Command/Version.hs +3/−1
• Command/Wanted.hs +3/−4
• Crypto.hs +5/−2
• Database/Types.hs +1/−1
• Git/ConfigTypes.hs +40/−0
• Git/LsTree.hs +8/−8
• Git/SharedRepository.hs +0/−28
• Git/Status.hs +9/−8
• Git/Tree.hs +12/−0
• Key.hs +181/−0
• Limit.hs +11/−2
• Logs/Transfer.hs +3/−12
• Messages/JSON.hs +1/−1
• NEWS +12/−0
• Remote/Bup.hs +2/−1
• Remote/Ddar.hs +12/−10
• Remote/GCrypt.hs +4/−3
• Remote/Git.hs +37/−29
• Remote/Helper/Ssh.hs +13/−12
• Remote/Rsync.hs +1/−1
• RemoteDaemon/Transport/GCrypt.hs +2/−1
• RemoteDaemon/Transport/Ssh.hs +1/−1
• Test.hs +8/−7
• Types/ActionItem.hs +1/−1
• Types/Backend.hs +4/−4
• Types/Distribution.hs +42/−2
• Types/GitConfig.hs +5/−1
• Types/Key.hs +85/−131
• Types/Transfer.hs +11/−3
• Upgrade/V1.hs +9/−7
• Utility/Hash.hs +0/−12
• Utility/Process.hs +13/−15
• Utility/Url.hs +22/−11
• doc/git-annex-matching-options.mdwn +5/−0
• doc/git-annex-merge.mdwn +0/−4
• doc/git-annex-preferred-content.mdwn +5/−0
• doc/git-annex-status.mdwn +5/−0
• doc/git-annex.mdwn +24/−2
• git-annex.cabal +9/−15
• stack.yaml +0/−1

@@ -2,7 +2,7 @@  import Common as X import Types as X-import Types.Key as X+import Key as X import Types.UUID as X import Annex as X (gitRepo, inRepo, fromRepo, calcRepo) import Annex.Locations as X

@@ -56,14 +56,16 @@  - Also closes various handles in it. -} mergeState :: AnnexState -> Annex () mergeState st = do-	st' <- liftIO $ snd <$> run st closehandles+	st' <- liftIO $ snd <$> run st stopCoProcesses 	forM_ (M.toList $ Annex.cleanup st') $ 		uncurry addCleanup 	Annex.Queue.mergeFrom st' 	changeState $ \s -> s { errcounter = errcounter s + errcounter st' }-  where-	closehandles = do-		catFileStop-		checkAttrStop-		hashObjectStop-		checkIgnoreStop++{- Stops all long-running git query processes. -}+stopCoProcesses :: Annex ()+stopCoProcesses = do+	catFileStop+	checkAttrStop+	hashObjectStop+	checkIgnoreStop

@@ -1,6 +1,6 @@ {- git-annex file content managing  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -80,6 +80,7 @@ import qualified Backend import qualified Database.Keys import Types.NumCopies+import Types.Key import Annex.UUID import Annex.InodeSentinal import Utility.InodeCache@@ -307,10 +308,12 @@ 	(ok, verification) <- action tmpfile 	if ok 		then ifM (verifyKeyContent v verification key tmpfile)-			( do-				moveAnnex key tmpfile-				logStatus key InfoPresent-				return True+			( ifM (moveAnnex key tmpfile)+				( do+					logStatus key InfoPresent+					return True+				, return False+				) 			, do 				warning "verification of content failed" 				liftIO $ nukeFile tmpfile@@ -341,7 +344,7 @@ 		Just size -> do 			size' <- liftIO $ catchDefaultIO 0 $ getFileSize f 			return (size' == size)-	verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendName (keyBackendName k) of+	verifycontent = case Types.Backend.verifyKeyContent =<< Backend.maybeLookupBackendVariety (keyVariety k) of 		Nothing -> return True 		Just verifier -> verifier k f @@ -465,9 +468,18 @@  - key, and one of them will probably get deleted later. So, adding the  - check here would only raise expectations that git-annex cannot truely  - meet.+ -+ - May return false, when a particular variety of key is not being+ - accepted into the repository. Will display a warning message in this+ - case. May also throw exceptions in some cases.  -}-moveAnnex :: Key -> FilePath -> Annex ()-moveAnnex key src = withObjectLoc key storeobject storedirect+moveAnnex :: Key -> FilePath -> Annex Bool+moveAnnex key src = ifM (checkSecureHashes key)+	( do+		withObjectLoc key storeobject storedirect+		return True+	, return False+	)   where 	storeobject dest = ifM (liftIO $ doesFileExist dest) 		( alreadyhave@@ -509,6 +521,16 @@ 	 	alreadyhave = liftIO $ removeFile src +checkSecureHashes :: Key -> Annex Bool+checkSecureHashes key+	| cryptographicallySecure (keyVariety key) = return True+	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)+		( do+			warning $ "annex.securehashesonly blocked adding " ++ formatKeyVariety (keyVariety key) ++ " key to annex objects"+			return False+		, return True+		)+ populatePointerFile :: Key -> FilePath -> FilePath -> Annex () populatePointerFile k obj f = go =<< liftIO (isPointerFile f)   where@@ -526,9 +548,12 @@ {- Populates the annex object file by hard linking or copying a source  - file to it. -} linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult-linkToAnnex key src srcic = do-	dest <- calcRepo (gitAnnexLocation key)-	modifyContent dest $ linkAnnex To key src srcic dest Nothing+linkToAnnex key src srcic = ifM (checkSecureHashes key)+	( do+		dest <- calcRepo (gitAnnexLocation key)+		modifyContent dest $ linkAnnex To key src srcic dest Nothing+	, return LinkAnnexFailed+	)  {- Makes a destination file be a link or copy from the annex object. -} linkFromAnnex :: Key -> FilePath -> Maybe FileMode -> Annex LinkAnnexResult

@@ -23,7 +23,7 @@ import Data.Default  import Common-import Types.Key+import Key import Types.GitConfig import Types.Difference import Utility.FileSystemEncoding

@@ -383,8 +383,11 @@ removeDirect k f = do 	void $ removeAssociatedFileUnchecked k f 	unlessM (inAnnex k) $+		-- If moveAnnex rejects the content of the key,+		-- treat that the same as its content having changed. 		ifM (goodContent k f)-			( moveAnnex k f+			( unlessM (moveAnnex k f) $+				logStatus k InfoMissing 			, logStatus k InfoMissing 			) 	liftIO $ do

@@ -117,6 +117,7 @@ 		, SimpleToken "groupwanted" (call matchgroupwanted) 		, SimpleToken "present" (simply $ limitPresent mu) 		, SimpleToken "inpreferreddir" (simply $ limitInDir preferreddir)+		, SimpleToken "securehash" (simply limitSecureHash) 		, ValueToken "copies" (usev limitCopies) 		, ValueToken "lackingcopies" (usev $ limitLackingCopies False) 		, ValueToken "approxlackingcopies" (usev $ limitLackingCopies True)

@@ -4,7 +4,7 @@  - not change, otherwise removing old hooks using an old version of  - the script would fail.  -- - Copyright 2013-2014 Joey Hess <id@joeyh.name>+ - Copyright 2013-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -21,6 +21,9 @@  preCommitHook :: Git.Hook preCommitHook = Git.Hook "pre-commit" (mkHookScript "git annex pre-commit .")++postReceiveHook :: Git.Hook+postReceiveHook = Git.Hook "post-receive" (mkHookScript "git annex post-receive")  preCommitAnnexHook :: Git.Hook preCommitAnnexHook = Git.Hook "pre-commit-annex" ""

@@ -172,10 +172,13 @@ 	go _ _ _ = failure "failed to generate a key"  	golocked key mcache s = do-		catchNonAsync (moveAnnex key $ contentLocation source)-			(restoreFile (keyFilename source) key)-		populateAssociatedFiles key source-		success key mcache s+		v <- tryNonAsync (moveAnnex key $ contentLocation source)+		case v of+			Right True -> do+				populateAssociatedFiles key source+				success key mcache s		+			Right False -> giveup "failed to add content to annex"+			Left e -> restoreFile (keyFilename source) key e  	gounlocked key (Just cache) s = do 		-- Remove temp directory hard link first because@@ -352,8 +355,11 @@  {- Adds a file to the work tree for the key, and stages it in the index.  - The content of the key may be provided in a temp file, which will be- - moved into place. -}-addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex ()+ - moved into place.+ -+ - When the content of the key is not accepted into the annex, returns False.+ -}+addAnnexedFile :: FilePath -> Key -> Maybe FilePath -> Annex Bool addAnnexedFile file key mtmp = ifM (addUnlocked <&&> not <$> isDirect) 	( do 		mode <- maybe@@ -363,12 +369,13 @@ 		stagePointerFile file mode =<< hashPointerFile key 		Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) 		case mtmp of-			Just tmp -> do-				moveAnnex key tmp-				linkunlocked mode+			Just tmp -> ifM (moveAnnex key tmp)+				( linkunlocked mode >> return True+				, writepointer mode >> return False+				) 			Nothing -> ifM (inAnnex key)-				( linkunlocked mode-				, liftIO $ writePointerFile file key mode+				( linkunlocked mode >> return True+				, writepointer mode >> return True 				) 	, do 		addLink file key Nothing@@ -381,7 +388,7 @@ 				whenM isDirect $ 					Annex.Queue.flush 				moveAnnex key tmp-			Nothing -> return ()+			Nothing -> return True 	)   where 	linkunlocked mode = do@@ -390,3 +397,4 @@ 			LinkAnnexFailed -> liftIO $ 				writePointerFile file key mode 			_ -> return ()+	writepointer mode = liftIO $ writePointerFile file key mode

@@ -1,6 +1,6 @@ {- git-annex repository initialization  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -26,6 +26,7 @@ import qualified Annex.Branch import Logs.UUID import Logs.Trust.Basic+import Logs.Config import Types.TrustLevel import Annex.Version import Annex.Difference@@ -83,8 +84,9 @@ 	checkLockSupport 	checkFifoSupport 	checkCrippledFileSystem-	unlessM isBareRepo $+	unlessM isBareRepo $ do 		hookWrite preCommitHook+		hookWrite postReceiveHook 	setDifferences 	unlessM (isJust <$> getVersion) $ 		setVersion (fromMaybe defaultVersion mversion)@@ -109,11 +111,13 @@ 				, unlessM isBareRepo 					switchHEADBack 				)+	propigateSecureHashesOnly 	createInodeSentinalFile False  uninitialize :: Annex () uninitialize = do 	hookUnWrite preCommitHook+	hookUnWrite postReceiveHook 	removeRepoUUID 	removeVersion @@ -255,3 +259,12 @@ 	u <- getUUID 	trustSet u UnTrusted 	setConfig (annexConfig "hardlink") (Git.Config.boolConfig True)++{- Propigate annex.securehashesonly from then global config to local+ - config. This makes a clone inherit a parent's setting, but once+ - a repository has a local setting, changes to the global config won't+ - affect it. -}+propigateSecureHashesOnly :: Annex ()+propigateSecureHashesOnly =+	maybe noop (setConfig (ConfigKey "annex.securehashesonly"))+		=<< getGlobalConfig "annex.securehashesonly"

@@ -77,6 +77,7 @@ import Data.Default  import Common+import Key import Types.Key import Types.UUID import Types.GitConfig@@ -478,7 +479,7 @@ 	| null s = True -- it's not legal for a key to have no keyName 	| otherwise= Just k == fileKey (keyFile k)   where-	k = stubKey { keyName = s, keyBackendName = "test" }+	k = stubKey { keyName = s, keyVariety = OtherKey "test" }  {- A location to store a key on a special remote that uses a filesystem.  - A directory hash is used, to protect against filesystems that dislike

@@ -24,7 +24,7 @@  import Annex.Common import Utility.FileMode-import Git.SharedRepository+import Git.ConfigTypes import qualified Annex import Config 

@@ -1,6 +1,6 @@ {- git-annex ssh interface, with connection caching  -- - Copyright 2012-2015 Joey Hess <id@joeyh.name>+ - Copyright 2012-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -8,6 +8,7 @@ {-# LANGUAGE CPP #-}  module Annex.Ssh (+	ConsumeStdin(..), 	sshOptions, 	sshCacheDir, 	sshReadPort,@@ -41,10 +42,15 @@ import Annex.LockPool #endif +{- Some ssh commands are fed stdin on a pipe and so should be allowed to+ - consume it. But ssh commands that are not piped stdin should generally+ - not be allowed to consume the process's stdin. -}+data ConsumeStdin = ConsumeStdin | NoConsumeStdin+ {- Generates parameters to ssh to a given host (or user@host) on a given  - port. This includes connection caching parameters, and any ssh-options. -}-sshOptions :: (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]-sshOptions (host, port) gc opts = go =<< sshCachingInfo (host, port)+sshOptions :: ConsumeStdin -> (String, Maybe Integer) -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]+sshOptions cs (host, port) gc opts = go =<< sshCachingInfo (host, port)   where 	go (Nothing, params) = ret params 	go (Just socketfile, params) = do@@ -55,6 +61,9 @@ 		, map Param (remoteAnnexSshOptions gc) 		, opts 		, portParams port+		, case cs of+			ConsumeStdin -> []+			NoConsumeStdin -> [Param "-n"] 		, [Param "-T"] 		] @@ -249,7 +258,8 @@  - options. (The options are separated by newlines.)  -  - This is a workaround for GIT_SSH not being able to contain- - additional parameters to pass to ssh. -}+ - additional parameters to pass to ssh. (GIT_SSH_COMMAND can,+ - but is not supported by older versions of git.) -} sshOptionsEnv :: String sshOptionsEnv = "GIT_ANNEX_SSHOPTION" 

@@ -1,6 +1,6 @@ {- git-annex transfers  -- - Copyright 2012-2016 Joey Hess <id@joeyh.name>+ - Copyright 2012-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -26,6 +26,7 @@ import Annex.Perms import Utility.Metered import Annex.LockPool+import Types.Key import Types.Remote (Verification(..)) import qualified Types.Remote as Remote import Types.Concurrency@@ -87,7 +88,7 @@ alwaysRunTransfer = runTransfer' True  runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v-runTransfer' ignorelock t file shouldretry transferaction = do+runTransfer' ignorelock t file shouldretry transferaction = checkSecureHashes t $ do 	info <- liftIO $ startTransferInfo file 	(meter, tfile, metervar) <- mkProgressUpdater t info 	mode <- annexFileMode@@ -166,6 +167,30 @@ 		| otherwise = do 			f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t) 			liftIO $ catchDefaultIO 0 $ getFileSize f++{- Avoid download and upload of keys with insecure content when+ - annex.securehashesonly is configured.+ -+ - This is not a security check. Even if this let the content be+ - downloaded, the actual security checks would prevent the content from+ - being added to the repository. The only reason this is done here is to+ - avoid transferring content that's going to be rejected anyway.+ -+ - We assume that, if annex.securehashesonly is set and the local repo+ - still contains content using an insecure hash, remotes will likewise+ - tend to be configured to reject it, so Upload is also prevented.+ -}+checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v+checkSecureHashes t a+	| cryptographicallySecure variety = a+	| otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig)+		( do+			warning $ "annex.securehashesonly blocked transfer of " ++ formatKeyVariety variety ++ " key"+			return observeFailure+		, a+		)+  where+	variety = keyVariety (transferKey t)  type RetryDecider = TransferInfo -> TransferInfo -> Bool 

@@ -0,0 +1,27 @@+{- git-annex UpdateIntead emulation+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Annex.UpdateInstead where++import qualified Annex+import Annex.Common+import Config+import Annex.Version+import Annex.AdjustedBranch+import Git.Branch+import Git.ConfigTypes++{- receive.denyCurrentBranch=updateInstead does not work in direct mode+ - repositories or when an adjusted branch is checked out, so must be+ - emulated. -}+needUpdateInsteadEmulation :: Annex Bool+needUpdateInsteadEmulation = updateinsteadset <&&> (isDirect <||> isadjusted)+  where+	updateinsteadset = (== UpdateInstead) . receiveDenyCurrentBranch+		<$> Annex.getGitConfig+	isadjusted = versionSupportsUnlockedPointers+		<&&> (maybe False (isJust . getAdjustment) <$> inRepo Git.Branch.current)

@@ -39,6 +39,7 @@ import Assistant.Unused import Logs.Unused import Types.Transfer+import Types.Key import Annex.Path import qualified Annex #ifdef WITH_WEBAPP@@ -308,7 +309,7 @@ 	cleanjunk check f = case fileKey (takeFileName f) of 		Nothing -> cleanOld check f 		Just k-			| "GPGHMAC" `isPrefixOf` keyBackendName k ->+			| "GPGHMAC" `isPrefixOf` formatKeyVariety (keyVariety k) -> 				cleanOld check f 			| otherwise -> noop 

@@ -115,7 +115,7 @@ 	| otherwise = cleanup   where 	k = distributionKey d-	fsckit f = case Backend.maybeLookupBackendName (Types.Key.keyBackendName k) of+	fsckit f = case Backend.maybeLookupBackendVariety (Types.Key.keyVariety k) of 		Nothing -> return $ Just f 		Just b -> case Types.Backend.verifyKeyContent b of 			Nothing -> return $ Just f@@ -324,7 +324,7 @@ 		ifM (Url.downloadQuiet distributionInfoUrl infof uo 			<&&> Url.downloadQuiet distributionInfoSigUrl sigf uo 			<&&> verifyDistributionSig gpgcmd sigf)-			( readish <$> readFileStrict infof+			( parseInfoFile <$> readFileStrict infof 			, return Nothing 			) 

@@ -379,7 +379,7 @@ 	geti f = maybe "" T.unpack (f sshinput)  	go extraopts environ = processTranscript' -		(askPass environ) "ssh" (extraopts ++ opts)+		(askPass environ (proc "ssh" (extraopts ++ opts))) 		-- Always provide stdin, even when empty. 		(Just (fromMaybe "" input)) @@ -746,7 +746,9 @@ 	probeuuid sshdata = do 		r <- inRepo $ Git.Construct.fromRemoteLocation (fromJust $ sshRepoUrl sshdata) 		getUncachedUUID . either (const r) fst <$>-			Remote.Helper.Ssh.onRemote r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] []+			Remote.Helper.Ssh.onRemote NoConsumeStdin r+				(Git.Config.fromPipe r, return (Left $ error "configlist failed"))+				"configlist" [] [] 	verifysshworks sshdata = inRepo $ Git.Command.runBool 		[ Param "send-pack" 		, Param (fromJust $ sshRepoUrl sshdata)

@@ -1,6 +1,6 @@ {- git-annex key/value backends  -- - Copyright 2010-2014 Joey Hess <id@joeyh.name>+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -11,14 +11,15 @@ 	genKey, 	getBackend, 	chooseBackend,-	lookupBackendName,-	maybeLookupBackendName,+	lookupBackendVariety,+	maybeLookupBackendVariety, 	isStableKey, ) where  import Annex.Common import qualified Annex import Annex.CheckAttr+import Types.Key import Types.KeySource import qualified Types.Backend as B @@ -42,14 +43,15 @@ 			f <- Annex.getState Annex.forcebackend 			case f of 				Just name | not (null name) ->-					return [lookupBackendName name]+					return [lookupname name] 				_ -> do 					l' <- gen . annexBackends <$> Annex.getGitConfig 					Annex.changeState $ \s -> s { Annex.backends = l' } 					return l'   where 	gen [] = list-	gen l = map lookupBackendName l+	gen ns = map lookupname ns+	lookupname = lookupBackendVariety . parseKeyVariety  {- Generates a key for a file, trying each backend in turn until one  - accepts it. -}@@ -73,33 +75,33 @@ 		| otherwise = c  getBackend :: FilePath -> Key -> Annex (Maybe Backend)-getBackend file k = let bname = keyBackendName k in-	case maybeLookupBackendName bname of-		Just backend -> return $ Just backend-		Nothing -> do-			warning $ "skipping " ++ file ++ " (unknown backend " ++ bname ++ ")"-			return Nothing+getBackend file k = case maybeLookupBackendVariety (keyVariety k) of+	Just backend -> return $ Just backend+	Nothing -> do+		warning $ "skipping " ++ file ++ " (unknown backend " ++ formatKeyVariety (keyVariety k) ++ ")"+		return Nothing  {- Looks up the backend that should be used for a file.  - That can be configured on a per-file basis in the gitattributes file. -} chooseBackend :: FilePath -> Annex (Maybe Backend) chooseBackend f = Annex.getState Annex.forcebackend >>= go   where-	go Nothing =  maybeLookupBackendName <$> checkAttr "annex.backend" f+	go Nothing =  maybeLookupBackendVariety . parseKeyVariety+		<$> checkAttr "annex.backend" f 	go (Just _) = Just . Prelude.head <$> orderedList -{- Looks up a backend by name. May fail if unknown. -}-lookupBackendName :: String -> Backend-lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s+{- Looks up a backend by variety. May fail if unsupported or disabled. -}+lookupBackendVariety :: KeyVariety -> Backend+lookupBackendVariety v = fromMaybe unknown $ maybeLookupBackendVariety v   where-	unknown = error $ "unknown backend " ++ s+	unknown = error $ "unknown backend " ++ formatKeyVariety v -maybeLookupBackendName :: String -> Maybe Backend-maybeLookupBackendName s = M.lookup s nameMap+maybeLookupBackendVariety :: KeyVariety -> Maybe Backend+maybeLookupBackendVariety v = M.lookup v varietyMap -nameMap :: M.Map String Backend-nameMap = M.fromList $ zip (map B.name list) list+varietyMap :: M.Map KeyVariety Backend+varietyMap = M.fromList $ zip (map B.backendVariety list) list  isStableKey :: Key -> Bool isStableKey k = maybe False (`B.isStableKey` k) -	(maybeLookupBackendName (keyBackendName k))+	(maybeLookupBackendVariety (keyVariety k))

@@ -1,12 +1,10 @@ {- git-annex hashing backends  -- - Copyright 2011-2015 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE CPP #-}- module Backend.Hash ( 	backends, 	testKeyBackend,@@ -14,6 +12,7 @@  import Annex.Common import qualified Annex+import Types.Key import Types.Backend import Types.KeySource import Utility.Hash@@ -29,17 +28,14 @@ 	| SHA2Hash HashSize 	| SHA3Hash HashSize 	| SkeinHash HashSize-type HashSize = Int  {- Order is slightly significant; want SHA256 first, and more general  - sizes earlier. -} hashes :: [Hash] hashes = concat -	[ map SHA2Hash [256, 512, 224, 384]-#ifdef WITH_CRYPTONITE-	, map SHA3Hash [256, 512, 224, 384]-#endif-	, map SkeinHash [256, 512]+	[ map (SHA2Hash . HashSize) [256, 512, 224, 384]+	, map (SHA3Hash . HashSize) [256, 512, 224, 384]+	, map (SkeinHash . HashSize) [256, 512] 	, [SHA1Hash] 	, [MD5Hash] 	]@@ -50,7 +46,7 @@  genBackend :: Hash -> Backend genBackend hash = Backend-	{ name = hashName hash+	{ backendVariety = hashKeyVariety hash (HasExt False) 	, getKey = keyValue hash 	, verifyKeyContent = Just $ checkKeyChecksum hash 	, canUpgradeKey = Just needsUpgrade@@ -60,19 +56,16 @@  genBackendE :: Hash -> Backend genBackendE hash = (genBackend hash)-	{ name = hashNameE hash+	{ backendVariety = hashKeyVariety hash (HasExt True) 	, getKey = keyValueE hash 	} -hashName :: Hash -> String-hashName MD5Hash = "MD5"-hashName SHA1Hash = "SHA1"-hashName (SHA2Hash size) = "SHA" ++ show size-hashName (SHA3Hash size) = "SHA3_" ++ show size-hashName (SkeinHash size) = "SKEIN" ++ show size--hashNameE :: Hash -> String-hashNameE hash = hashName hash ++ "E"+hashKeyVariety :: Hash -> HasExt -> KeyVariety+hashKeyVariety MD5Hash = MD5Key+hashKeyVariety SHA1Hash = SHA1Key+hashKeyVariety (SHA2Hash size) = SHA2Key size+hashKeyVariety (SHA3Hash size) = SHA3Key size+hashKeyVariety (SkeinHash size) = SKEINKey size  {- A key is a hash of its contents. -} keyValue :: Hash -> KeySource -> Annex (Maybe Key)@@ -82,7 +75,7 @@ 	s <- hashFile hash file filesize 	return $ Just $ stubKey 		{ keyName = s-		, keyBackendName = hashName hash+		, keyVariety = hashKeyVariety hash (HasExt False) 		, keySize = Just filesize 		} @@ -92,7 +85,7 @@   where 	addE k = return $ Just $ k 		{ keyName = keyName k ++ selectExtension (keyFilename source)-		, keyBackendName = hashNameE hash+		, keyVariety = hashKeyVariety hash (HasExt True) 		}  selectExtension :: FilePath -> String@@ -149,24 +142,29 @@ trivialMigrate :: Key -> Backend -> AssociatedFile -> Maybe Key trivialMigrate oldkey newbackend afile 	{- Fast migration from hashE to hash backend. -}-	| keyBackendName oldkey == name newbackend ++ "E" = Just $ oldkey+	| migratable && hasExt newvariety = Just $ oldkey 		{ keyName = keyHash oldkey-		, keyBackendName = name newbackend+		, keyVariety = newvariety 		} 	{- Fast migration from hash to hashE backend. -}-	| keyBackendName oldkey ++"E" == name newbackend = case afile of+	| migratable && hasExt oldvariety = case afile of 		Nothing -> Nothing 		Just file -> Just $ oldkey 			{ keyName = keyHash oldkey ++ selectExtension file-			, keyBackendName = name newbackend+			, keyVariety = newvariety 			} 	| otherwise = Nothing+  where+	migratable = oldvariety /= newvariety +		&& sameExceptExt oldvariety newvariety+	oldvariety = keyVariety oldkey+	newvariety = backendVariety newbackend  hashFile :: Hash -> FilePath -> Integer -> Annex String hashFile hash file filesize = go hash   where 	go MD5Hash = use md5Hasher-	go SHA1Hash = usehasher 1+	go SHA1Hash = usehasher (HashSize 1) 	go (SHA2Hash hashsize) = usehasher hashsize 	go (SHA3Hash hashsize) = use (sha3Hasher hashsize) 	go (SkeinHash hashsize) = use (skeinHasher hashsize)@@ -176,10 +174,10 @@ 		-- Force full evaluation so file is read and closed. 		return (length h `seq` h) 	-	usehasher hashsize = case shaHasher hashsize filesize of+	usehasher hashsize@(HashSize sz) = case shaHasher hashsize filesize of 		Left sha -> use sha 		Right (external, internal) -> do-			v <- liftIO $ externalSHA external hashsize file+			v <- liftIO $ externalSHA external sz file 			case v of 				Right r -> return r 				Left e -> do@@ -189,7 +187,7 @@ 					use internal  shaHasher :: HashSize -> Integer -> Either (L.ByteString -> String) (String, L.ByteString -> String)-shaHasher hashsize filesize+shaHasher (HashSize hashsize) filesize 	| hashsize == 1 = use SysConfig.sha1 sha1 	| hashsize == 256 = use SysConfig.sha256 sha2_256 	| hashsize == 224 = use SysConfig.sha224 sha2_224@@ -209,17 +207,15 @@ 	usehasher hasher = show . hasher  sha3Hasher :: HashSize -> (L.ByteString -> String)-sha3Hasher hashsize-#ifdef WITH_CRYPTONITE+sha3Hasher (HashSize hashsize) 	| hashsize == 256 = show . sha3_256 	| hashsize == 224 = show . sha3_224 	| hashsize == 384 = show . sha3_384 	| hashsize == 512 = show . sha3_512-#endif 	| otherwise = error $ "unsupported SHA3 size " ++ show hashsize  skeinHasher :: HashSize -> (L.ByteString -> String)-skeinHasher hashsize +skeinHasher (HashSize hashsize) 	| hashsize == 256 = show . skein256 	| hashsize == 512 = show . skein512 	| otherwise = error $ "unsupported SKEIN size " ++ show hashsize@@ -236,7 +232,7 @@  -} testKeyBackend :: Backend testKeyBackend = -	let b = genBackendE (SHA2Hash 256)+	let b = genBackendE (SHA2Hash (HashSize 256)) 	in b { getKey = (fmap addE) <$$> getKey b }    where 	addE k = k { keyName = keyName k ++ longext }

@@ -11,6 +11,7 @@ ) where  import Annex.Common+import Types.Key import Types.Backend import Backend.Utilities @@ -19,7 +20,7 @@  backend :: Backend backend = Backend-	{ name = "URL"+	{ backendVariety = URLKey 	, getKey = const $ return Nothing 	, verifyKeyContent = Nothing 	, canUpgradeKey = Nothing@@ -33,6 +34,6 @@ fromUrl :: String -> Maybe Integer -> Key fromUrl url size = stubKey 	{ keyName = genKeyName url-	, keyBackendName = "URL"+	, keyVariety = URLKey 	, keySize = size 	}

@@ -8,6 +8,7 @@ module Backend.WORM (backends) where  import Annex.Common+import Types.Key import Types.Backend import Types.KeySource import Backend.Utilities@@ -18,7 +19,7 @@  backend :: Backend backend = Backend-	{ name = "WORM"+	{ backendVariety = WORMKey 	, getKey = keyValue 	, verifyKeyContent = Nothing 	, canUpgradeKey = Nothing@@ -37,7 +38,7 @@ 	relf <- getTopFilePath <$> inRepo (toTopFilePath $ keyFilename source) 	return $ Just $ stubKey 		{ keyName = genKeyName relf-		, keyBackendName = name backend+		, keyVariety = WORMKey 		, keySize = Just sz 		, keyMtime = Just $ modificationTime stat 		}

@@ -34,7 +34,7 @@ 	, TestCase "rsync" $ requireCmd "rsync" "rsync --version >/dev/null" 	, TestCase "curl" $ testCmd "curl" "curl --version >/dev/null" 	, TestCase "wget" $ testCmd "wget" "wget --version >/dev/null"-	, TestCase "wget supports -q --show-progress" checkWgetQuietProgress+	, TestCase "wget unclutter options" checkWgetUnclutter 	, TestCase "bup" $ testCmd "bup" "bup --version >/dev/null" 	, TestCase "nice" $ testCmd "nice" "nice true >/dev/null" 	, TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null"@@ -105,8 +105,8 @@ 			error $ "installed git version " ++ show v ++ " is too old! (Need " ++ show oldestallowed ++ " or newer)" 		return $ Config "gitversion" $ StringConfig $ show v -checkWgetQuietProgress :: Test-checkWgetQuietProgress = Config "wgetquietprogress" . BoolConfig+checkWgetUnclutter :: Test+checkWgetUnclutter = Config "wgetunclutter" . BoolConfig 	. maybe False (>= normalize "1.16") 	<$> getWgetVersion  

@@ -119,13 +119,14 @@ 			Just k -> whenM (inAnnex k) $ do 				liftIO $ putStrLn f 				let infofile = f ++ ".info"-				liftIO $ writeFile infofile $ show $ GitAnnexDistribution+				let d = GitAnnexDistribution 					{ distributionUrl = mkUrl f 					, distributionKey = k 					, distributionVersion = bv 					, distributionReleasedate = now 					, distributionUrgentUpgrade = Nothing 					}+				liftIO $ writeFile infofile $ formatInfoFile d 				void $ inRepo $ runBool [Param "add", File infofile] 				signFile infofile 				signFile f

@@ -127,7 +127,7 @@ 	putStrLn $ unwords [c, show ps] 	systemenviron <- getEnvironment 	let environ' = fromMaybe [] environ ++ systemenviron-	out@(_, ok) <- processTranscript' (\p -> p { Utility.Process.env = Just environ' }) c ps Nothing+	out@(_, ok) <- processTranscript' ((proc c ps) { Utility.Process.env = Just environ' }) Nothing 	putStrLn $ unwords [c, "finished", show ok] 	return out 

@@ -13,7 +13,6 @@ import Control.Monad import Control.Monad.IfElse import Data.List-import Data.String.Utils import Control.Applicative import Prelude 

@@ -1,3 +1,71 @@+git-annex (6.20170301) unstable; urgency=medium++  * No changes from 6.20170228; a new version number was needed due+    to a problem with Hackage.++ -- Joey Hess <id@joeyh.name>  Wed, 01 Mar 2017 12:06:02 -0400++git-annex (6.20170228) unstable; urgency=medium++  * Cryptographically secure hashes can be forced to be used in a+    repository, by setting annex.securehashesonly.+    This does not prevent the git repository from containing links+    to insecure hashes, but it does prevent the content of such files+    from being added to .git/annex/objects by any method.+  * Tighten key parser to prevent SHA1 collision attacks generating+    two keys that have the same SHA1. (Only done for keys that contain+    a hash). This ensures that signed git commits of annexed files+    will remain secure, as long as git-annex is using a secure hashing+    backend.+  * fsck: Warn about any files whose content is present, that don't+    use secure hashes, when annex.securehashesonly is set.+  * init: When annex.securehashesonly has been set with git-annex config,+    copy that value to the annex.securehashesonly git config.+  * Added --securehash option to match files using a secure hash function,+    and corresponding securehash preferred content expression.+  * sync, merge: Fail when the current branch has no commits yet, instead+    of not merging in anything from remotes and appearing to succeed.+  * Run ssh with -n whenever input is not being piped into it,+    to avoid it consuming stdin that it shouldn't.+    This fixes git-annex-checkpresentkey --batch remote,+    which didn't output results for all keys passed into it. Other+    git-annex commands that communicate with a remote over ssh may also+    have been consuming stdin that they shouldn't have, which could have+    impacted using them in eg, shell scripts.+  * sync: Improve integration with receive.denyCurrentBranch=updateInstead,+    displaying error messages from the remote then it fails to update+    its checked out branch.+  * Added post-recieve hook, which makes updateInstead work with direct+    mode and adjusted branches.+  * init: Set up the post-receive hook.+  * sync: When syncing with a local repository located on a crippled+    filesystem, run the post-receive hook there, since it wouldn't get run+    otherwise. This makes pushing to repos on FAT-formatted removable+    drives update them when receive.denyCurrentBranch=updateInstead.+  * config group groupwanted numcopies schedule wanted required: +    Avoid displaying extraneous messages about repository auto-init,+    git-annex branch merging, etc, when being used to get information.+  * adjust: Fix behavior when used in a repository that contains+    submodules.+  * Run wget with -nv instead of -q, so it will display HTTP errors.+  * Run curl with -S, so HTTP errors are displayed, even when+    it's otherwise silent.+  * When downloading in --json or --quiet mode, use curl in preference+    to wget, since curl is able to display only errors to stderr, unlike+    wget.+  * status: Pass --ignore-submodules=when option on to git status.+  * config --set: As well as setting value in git-annex branch,+    set local gitconfig. This is needed especially for+    annex.securehashesonly, which is read only from local gitconfig and not+    the git-annex branch.+  * Removed support for building with the old cryptohash library.+    Building with that library made git-annex not support SHA3; it's time+    for that to always be supported in case SHA2 dominoes.+  * git-annex.cabal: Make crypto-api a dependency even when built w/o+    webapp and test suite.++ -- Joey Hess <id@joeyh.name>  Tue, 28 Feb 2017 14:39:47 -0400+ git-annex (6.20170214) unstable; urgency=medium    * Increase default cost for p2p remotes from 200 to 1000.

@@ -61,6 +61,7 @@ import qualified Command.Unlock import qualified Command.Lock import qualified Command.PreCommit+import qualified Command.PostReceive import qualified Command.Find import qualified Command.FindRef import qualified Command.Whereis@@ -148,6 +149,7 @@ 	, Command.Uninit.cmd 	, Command.Reinit.cmd 	, Command.PreCommit.cmd+	, Command.PostReceive.cmd 	, Command.NumCopies.cmd 	, Command.Trust.cmd 	, Command.Untrust.cmd

@@ -15,6 +15,7 @@ import qualified Git.Config import qualified Git.Construct import Git.Types+import Types.Key import Types.TrustLevel import Types.NumCopies import Types.Messages@@ -223,6 +224,11 @@ 		<> hidden 		<> completeBackends 		)+	, globalFlag Limit.addSecureHash+		( long "securehash"+		<> help "match files using a cryptographically secure hash"+		<> hidden+		) 	, globalSetter Limit.addInAllGroup $ strOption 		( long "inallgroup" <> metavar paramGroup 		<> help "match files present in all remotes in a group"@@ -346,4 +352,5 @@ 		 		 completeBackends :: HasCompleter f => Mod f a-completeBackends = completeWith (map Backend.name Backend.list)+completeBackends = completeWith $+	map (formatKeyVariety . Backend.backendVariety) Backend.list

@@ -20,5 +20,5 @@ globalSetter setter parser = DeferredParse . setter <$> parser  combineGlobalOptions :: [GlobalOption] -> Parser GlobalSetter-combineGlobalOptions l = DeferredParse . sequence_ . map getParsed+combineGlobalOptions l = DeferredParse . mapM_ getParsed 	<$> many (foldl1 (<|>) l)

@@ -22,12 +22,14 @@ import CmdLine.GitAnnex.Options as ReExported import CmdLine.Batch as ReExported import Options.Applicative as ReExported hiding (command)+import qualified Annex import qualified Git import Annex.Init import Config import Utility.Daemon import Types.Transfer import Types.ActionItem+import Types.Messages  {- Generates a normal Command -} command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command@@ -62,6 +64,16 @@  - etc. -} noMessages :: Command -> Command noMessages c = c { cmdnomessages = True }++{- Undoes noMessages -}+allowMessages :: Annex ()+allowMessages = do+	curr <- Annex.getState Annex.output+	case outputType curr of+		QuietOutput -> Annex.setOutput NormalOutput+		_ -> noop+	Annex.changeState $ \s -> s+		{ Annex.output = (Annex.output s) { implicitMessages = True } }  {- Adds a fallback action to a command, that will be run if it's used  - outside a git repository. -}

@@ -356,10 +356,13 @@   where 	go = do 		maybeShowJSON $ JSONChunk [("key", key2file key)]-		when (isJust mtmp) $-			logStatus key InfoPresent 		setUrlPresent u key url-		addAnnexedFile file key mtmp+		ifM (addAnnexedFile file key mtmp)+			( do+				when (isJust mtmp) $+					logStatus key InfoPresent+			, liftIO $ maybe noop nukeFile mtmp+			)  nodownload :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) nodownload url urlinfo file

@@ -9,9 +9,11 @@  import Command import Logs.Config+import Config  cmd :: Command-cmd = command "config" SectionSetup "configuration stored in git-annex branch"+cmd = noMessages $ command "config" SectionSetup+	"configuration stored in git-annex branch" 	paramNothing (seek <$$> optParser)  data Action@@ -47,14 +49,18 @@  seek :: Action -> CommandSeek seek (SetConfig name val) = commandAction $ do+	allowMessages 	showStart name val 	next $ next $ do 		setGlobalConfig name val+		setConfig (ConfigKey name) val 		return True seek (UnsetConfig name) = commandAction $ do+	allowMessages 	showStart name "unset" 	next $ next $ do 		unsetGlobalConfig name+		unsetConfig (ConfigKey name) 		return True seek (GetConfig name) = commandAction $ do 	mv <- getGlobalConfig name

@@ -13,6 +13,7 @@ import Command import Annex.Content import Limit+import Types.Key import qualified Utility.Format import Utility.DataUnits @@ -76,7 +77,7 @@ keyVars :: Key -> [(String, String)] keyVars key = 	[ ("key", key2file key)-	, ("backend", keyBackendName key)+	, ("backend", formatKeyVariety $ keyVariety key) 	, ("bytesize", size show) 	, ("humansize", size $ roughSize storageUnits True) 	, ("keyname", keyName key)

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2016 Joey Hess <id@joeyh.name>+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -35,6 +35,7 @@ import qualified Database.Keys import qualified Database.Fsck as FsckDb import Types.CleanupActions+import Types.Key  import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime)@@ -175,7 +176,7 @@  startKey :: Maybe Remote -> Incremental -> Key -> ActionItem -> NumCopies -> CommandStart startKey from inc key ai numcopies =-	case Backend.maybeLookupBackendName (keyBackendName key) of+	case Backend.maybeLookupBackendVariety (keyVariety key) of 		Nothing -> stop 		Just backend -> runFsck inc ai key $ 			case from of@@ -233,6 +234,14 @@ 			warning $ "** Unable to set correct write mode for " ++ obj ++ " ; perhaps you don't own that file" 	whenM (liftIO $ doesDirectoryExist $ parentDir obj) $ 		freezeContentDir obj++	{- Warn when annex.securehashesonly is set and content using an +	 - insecure hash is present. This should only be able to happen+	 - if the repository already contained the content before the+	 - config was set. -}+	when (present && not (cryptographicallySecure (keyVariety key))) $+		whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $+			warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ formatKeyVariety (keyVariety key) ++ " key"  	{- In direct mode, modified files will show up as not present, 	 - but that is expected and not something to do anything about. -}

@@ -15,7 +15,7 @@ import qualified Data.Set as S  cmd :: Command-cmd = command "group" SectionSetup "add a repository to a group"+cmd = noMessages $ command "group" SectionSetup "add a repository to a group" 	(paramPair paramRemote paramDesc) (withParams seek)  seek :: CmdParams -> CommandSeek@@ -23,12 +23,13 @@  start :: [String] -> CommandStart start (name:g:[]) = do+	allowMessages 	showStart "group" name 	u <- Remote.nameToUUID name 	next $ setGroup u g start (name:[]) = do 	u <- Remote.nameToUUID name-	showRaw . unwords . S.toList =<< lookupGroups u+	liftIO . putStrLn . unwords . S.toList =<< lookupGroups u 	stop start _ = giveup "Specify a repository and a group." 

@@ -12,7 +12,7 @@ import Command.Wanted (performGet, performSet)  cmd :: Command-cmd = command "groupwanted" SectionSetup +cmd = noMessages $ command "groupwanted" SectionSetup  	"get or set groupwanted expression" 	(paramPair paramGroup (paramOptional paramExpression)) 	(withParams seek)@@ -23,6 +23,7 @@ start :: [String] -> CommandStart start (g:[]) = next $ performGet groupPreferredContentMapRaw g start (g:expr:[]) = do+	allowMessages 	showStart "groupwanted" g 	next $ performSet groupPreferredContentSet expr g start _ = giveup "Specify a group."

@@ -112,8 +112,9 @@ getCache opttemplate = ifM (Annex.getState Annex.force) 	( ret S.empty S.empty 	, do-		showAction "checking known urls"+		showStart "importfeed" "checking known urls" 		(is, us) <- unzip <$> (mapM knownItems =<< knownUrls)+		showEndOk 		ret (S.fromList us) (S.fromList (concat is)) 	)   where@@ -138,12 +139,10 @@ 			Just $ ToDownload f u i $ Enclosure enclosureurl 		Nothing -> mkquvi f i 	mkquvi f i = case getItemLink i of-		Just link -> do-			liftIO $ print ("link", link)-			ifM (quviSupported link)-				( return $ Just $ ToDownload f u i $ QuviLink link-				, return Nothing-				)+		Just link -> ifM (quviSupported link)+			( return $ Just $ ToDownload f u i $ QuviLink link+			, return Nothing+			) 		Nothing -> return Nothing  {- Feeds change, so a feed download cannot be resumed. -}

@@ -86,16 +86,16 @@ 		whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do 			v <- tryNonAsync (moveAnnex k f) 			case v of-				Right _ -> do +				Right True -> do  					l <- calcRepo $ gitAnnexLink f k 					liftIO $ createSymbolicLink l f-				Left e -> catchNonAsync (restoreFile f k e)-					warnlocked+				Right False -> warnlocked "Failed to move file to annex"+				Left e -> catchNonAsync (restoreFile f k e) $+					warnlocked . show 		showEndOk -	warnlocked :: SomeException -> Annex ()-	warnlocked e = do-		warning $ show e+	warnlocked msg = do+		warning msg 		warning "leaving this file as-is; correct this problem and run git annex add on it" 	 cleanup :: CommandCleanup

@@ -36,6 +36,7 @@ import Utility.Percentage import Types.Transfer import Logs.Transfer+import Types.Key import Types.TrustLevel import Types.FileMatcher import qualified Limit@@ -51,7 +52,7 @@ 	{ countKeys :: Integer 	, sizeKeys :: Integer 	, unknownSizeKeys :: Integer-	, backendsKeys :: M.Map String Integer+	, backendsKeys :: M.Map KeyVariety Integer 	}  data NumCopiesStats = NumCopiesStats@@ -418,14 +419,14 @@   where 	desc = "transfers in progress" 	line uuidmap t i = unwords-		[ showLcDirection (transferDirection t) ++ "ing"+		[ formatDirection (transferDirection t) ++ "ing" 		, fromMaybe (key2file $ transferKey t) (associatedFile i) 		, if transferDirection t == Upload then "to" else "from" 		, maybe (fromUUID $ transferUUID t) Remote.name $ 			M.lookup (transferUUID t) uuidmap 		] 	jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $-		[ ("transfer", toJSON (showLcDirection (transferDirection t)))+		[ ("transfer", toJSON (formatDirection (transferDirection t))) 		, ("key", toJSON (key2file (transferKey t))) 		, ("file", toJSON (associatedFile i)) 		, ("remote", toJSON (fromUUID (transferUUID t)))@@ -451,7 +452,8 @@  backend_usage :: Stat backend_usage = stat "backend usage" $ json fmt $-	ObjectMap . backendsKeys <$> cachedReferencedData+	ObjectMap . (M.mapKeys formatKeyVariety) . backendsKeys+		<$> cachedReferencedData   where 	fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . sort . M.toList . fromObjectMap @@ -598,7 +600,7 @@ 	{- All calculations strict to avoid thunks when repeatedly 	 - applied to many keys. -} 	!count' = count + 1-	!backends' = M.insertWith (+) (keyBackendName key) 1 backends+	!backends' = M.insertWith (+) (keyVariety key) 1 backends 	!size' = maybe size (+ size) ks 	!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks 	ks = keySize key

@@ -16,6 +16,7 @@ import qualified Git.Construct import qualified Remote import qualified Annex+import Annex.Ssh import Annex.UUID import Logs.UUID import Logs.Trust@@ -219,10 +220,11 @@ 	  where 		p = proc pcmd $ toCommand params -	configlist = Ssh.onRemote r (pipedconfig, return Nothing) "configlist" [] []+	configlist = Ssh.onRemote NoConsumeStdin r+		(pipedconfig, return Nothing) "configlist" [] [] 	manualconfiglist = do 		gc <- Annex.getRemoteGitConfig r-		sshparams <- Ssh.toRepo r gc [Param sshcmd]+		sshparams <- Ssh.toRepo NoConsumeStdin r gc [Param sshcmd] 		liftIO $ pipedconfig "ssh" sshparams 	  where 		sshcmd = "sh -c " ++ shellEscape

@@ -17,9 +17,9 @@ 	paramNothing (withParams seek)  seek :: CmdParams -> CommandSeek-seek ps = do-	withNothing mergeBranch ps-	withNothing mergeSynced ps+seek _ = do+	commandAction mergeBranch+	commandAction mergeSynced  mergeBranch :: CommandStart mergeBranch = do

@@ -10,10 +10,9 @@ import Command import qualified Annex import Annex.NumCopies-import Types.Messages  cmd :: Command-cmd = command "numcopies" SectionSetup +cmd = noMessages $ command "numcopies" SectionSetup  	"configure desired number of copies" 	paramNumber (withParams seek) @@ -35,7 +34,6 @@  startGet :: CommandStart startGet = next $ next $ do-	Annex.setOutput QuietOutput 	v <- getGlobalNumCopies 	case v of 		Just n -> liftIO $ putStrLn $ show $ fromNumCopies n@@ -49,6 +47,7 @@  startSet :: Int -> CommandStart startSet n = do+	allowMessages 	showStart "numcopies" (show n) 	next $ next $ do 		setGlobalNumCopies $ NumCopies n

@@ -0,0 +1,51 @@+{- git-annex command+ -+ - Copyright 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Command.PostReceive where++import Command+import qualified Annex+import Git.Types+import Annex.UpdateInstead+import Command.Sync (mergeLocal, prepMerge, mergeConfig, getCurrBranch)++-- This does not need to modify the git-annex branch to update the +-- work tree, but auto-initialization might change the git-annex branch.+-- Since it would be surprising for a post-receive hook to make such a+-- change, that's prevented by noCommit.+cmd :: Command+cmd = noCommit $+	command "post-receive" SectionPlumbing+		"run by git post-receive hook"+		paramNothing+		(withParams seek)++seek :: CmdParams -> CommandSeek+seek _ = whenM needUpdateInsteadEmulation $ do+	fixPostReceiveHookEnv+	commandAction updateInsteadEmulation++{- When run by the post-receive hook, the cwd is the .git directory, + - and GIT_DIR=. It's not clear why git does this.+ -+ - Fix up from that unusual situation, so that git commands+ - won't try to treat .git as the work tree. -}+fixPostReceiveHookEnv :: Annex ()+fixPostReceiveHookEnv = do+	g <- Annex.gitRepo+	case location g of+		Local { gitdir = ".", worktree = Just "." } ->+			Annex.adjustGitRepo $ \g' -> pure $ g'+				{ location = (location g')+					{ worktree = Just ".." }+				}+		_ -> noop++updateInsteadEmulation :: CommandStart+updateInsteadEmulation = do+	prepMerge+	mergeLocal mergeConfig =<< join getCurrBranch

@@ -74,9 +74,8 @@ 	, error "failed" 	)   where-	move = checkDiskSpaceToGet key False $ do+	move = checkDiskSpaceToGet key False $ 		moveAnnex key src-		return True  cleanup :: Key -> CommandCleanup cleanup key = do

@@ -8,16 +8,14 @@ module Command.Schedule where  import Command-import qualified Annex import qualified Remote import Logs.Schedule import Types.ScheduledActivity-import Types.Messages  import qualified Data.Set as S  cmd :: Command-cmd = command "schedule" SectionSetup "get or set scheduled jobs"+cmd = noMessages $ command "schedule" SectionSetup "get or set scheduled jobs" 	(paramPair paramRemote (paramOptional paramExpression)) 	(withParams seek) @@ -29,6 +27,7 @@   where 	parse (name:[]) = go name performGet 	parse (name:expr:[]) = go name $ \uuid -> do+		allowMessages 		showStart "schedule" name 		performSet expr uuid 	parse _ = giveup "Specify a repository."@@ -39,7 +38,6 @@  performGet :: UUID -> CommandPerform performGet uuid = do-	Annex.setOutput QuietOutput 	s <- scheduleGet uuid 	liftIO $ putStrLn $ intercalate "; " $  		map fromScheduledActivity $ S.toList s

@@ -84,7 +84,7 @@ 				-- for this file before, so that when 				-- git re-cleans a file its backend does 				-- not change.-				currbackend <- maybe Nothing (maybeLookupBackendName . keyBackendName)+				currbackend <- maybe Nothing (maybeLookupBackendVariety . keyVariety) 					<$> catKeyFile file 				liftIO . emitPointer 					=<< go

@@ -20,14 +20,28 @@ 	withGlobalOptions [jsonOption] $ 		command "status" SectionCommon 			"show the working tree status"-			paramPaths (withParams seek)+			paramPaths (seek <$$> optParser) -seek :: CmdParams -> CommandSeek-seek = withWords start+data StatusOptions = StatusOptions+	{ statusFiles :: CmdParams+	, ignoreSubmodules :: Maybe String+	}++optParser :: CmdParamsDesc -> Parser StatusOptions+optParser desc = StatusOptions+	<$> cmdParams desc+	<*> optional (strOption+		( long "ignore-submodules"+		<> help "passed on to git status"+		<> metavar "WHEN"+		))++seek :: StatusOptions -> CommandSeek+seek o = withWords (start o) (statusFiles o) 	-start :: [FilePath] -> CommandStart-start locs = do-	(l, cleanup) <- inRepo $ getStatus locs+start :: StatusOptions -> [FilePath] -> CommandStart+start o locs = do+	(l, cleanup) <- inRepo $ getStatus ps locs 	getstatus <- ifM isDirect 		( return statusDirect 		, return $ \s -> pure (Just s)@@ -35,6 +49,10 @@ 	forM_ l $ \s -> maybe noop displayStatus =<< getstatus s 	void $ liftIO cleanup 	stop+  where+	ps = case ignoreSubmodules o of+		Nothing -> []+		Just s -> [Param $ "--ignore-submodules="++s]  displayStatus :: Status -> Annex () -- renames not shown in this simplified status

@@ -1,7 +1,7 @@ {- git-annex command  -  - Copyright 2011 Joachim Breitner <mail@joachim-breitner.de>- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -40,6 +40,7 @@ import qualified Remote.Git import Config import Config.GitConfig+import Config.Files import Annex.Wanted import Annex.Content import Command.Get (getKey')@@ -51,6 +52,7 @@ import Annex.AdjustedBranch import Annex.Ssh import Annex.BloomFilter+import Annex.UpdateInstead import Utility.Bloom import Utility.OptParse @@ -272,22 +274,37 @@ 	return True  mergeLocal :: [Git.Merge.MergeConfig] -> CurrBranch -> CommandStart-mergeLocal mergeconfig currbranch@(Just branch, madj) = go =<< needmerge+mergeLocal mergeconfig currbranch@(Just _, _) =+	go =<< needMerge currbranch   where-	syncbranch = syncBranch branch-	needmerge = ifM isBareRepo-		( return False-		, ifM (inRepo $ Git.Ref.exists syncbranch)-			( inRepo $ Git.Branch.changed branch' syncbranch-			, return False-			)-		)-	go False = stop-	go True = do+	go Nothing = stop+	go (Just syncbranch) = do 		showStart "merge" $ Git.Ref.describe syncbranch 		next $ next $ merge currbranch mergeconfig Git.Branch.ManualCommit syncbranch+mergeLocal _ (Nothing, madj) = do+	b <- inRepo Git.Branch.currentUnsafe+	ifM (isJust <$> needMerge (b, madj))+		( do+			warning $ "There are no commits yet in the currently checked out branch, so cannot merge any remote changes into it."+			next $ next $ return False+		, stop+		)++-- Returns the branch that should be merged, if any.+needMerge :: CurrBranch -> Annex (Maybe Git.Branch)+needMerge (Nothing, _) = return Nothing+needMerge (Just branch, madj) = ifM (allM id checks)+	( return (Just syncbranch)+	, return Nothing+	)+  where+	checks =+		[ not <$> isBareRepo+		, inRepo (Git.Ref.exists syncbranch)+		, inRepo (Git.Branch.changed branch' syncbranch)+		]+	syncbranch = syncBranch branch 	branch' = maybe branch (adjBranch . originalToAdjusted branch) madj-mergeLocal _ (Nothing, _) = stop  pushLocal :: CurrBranch -> CommandStart pushLocal b = do@@ -362,30 +379,48 @@ 		showOutput 		ok <- inRepoWithSshOptionsTo (Remote.repo remote) (Remote.gitconfig remote) $ 			pushBranch remote branch-		unless ok $ do-			warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]-			showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"-		return ok+		if ok+			then postpushupdate+			else do+				warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ]+				showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)"+				return ok   where 	needpush 		| remoteAnnexReadOnly (Remote.gitconfig remote) = return False 		| otherwise = anyM (newer remote) [syncBranch branch, Annex.Branch.name]+	-- Do updateInstead emulation for remotes on eg removable drives+	-- formatted FAT, where the post-update hook won't run.+	postpushupdate+		| maybe False annexCrippledFileSystem (remoteGitConfig (Remote.gitconfig remote)) = +			case Git.repoWorkTree (Remote.repo remote) of+				Nothing -> return True+				Just wt -> ifM (Remote.Git.onLocal remote needUpdateInsteadEmulation)+					( liftIO $ do+						p <- readProgramFile+						boolSystem' p [Param "post-receive"]+							(\cp -> cp { cwd = Just wt })+					, return True+					)+		| otherwise = return True  {- Pushes a regular branch like master to a remote. Also pushes the git-annex  - branch.  -- - If the remote is a bare git repository, it's best to push the regular + - If the remote is a bare git repository, it's best to push the regular  - branch directly to it, so that cloning/pulling will get it.  - On the other hand, if it's not bare, pushing to the checked out branch- - will fail, and this is why we push to its syncBranch.+ - will generally fail (except with receive.denyCurrentBranch=updateInstead),+ - and this is why we push to its syncBranch.  -  - Git offers no way to tell if a remote is bare or not, so both methods  - are tried.  -- - The direct push is likely to spew an ugly error message, so stderr is- - elided. Since git progress display goes to stderr too, the sync push- - is done first, and actually sends the data. Then the direct push is- - tried, with stderr discarded, to update the branch ref on the remote.+ - The direct push is likely to spew an ugly error message, so its stderr is+ - often elided. Since git progress display goes to stderr too, the + - sync push is done first, and actually sends the data. Then the+ - direct push is tried, with stderr discarded, to update the branch ref+ - on the remote.  -  - The sync push forces the update of the remote synced/git-annex branch.  - This is necessary if a transition has rewritten the git-annex branch.@@ -401,16 +436,30 @@  - set on the remote.  -} pushBranch :: Remote -> Git.Branch -> Git.Repo -> IO Bool-pushBranch remote branch g = tryIO (directpush g) `after` syncpush g+pushBranch remote branch g = directpush `after` annexpush `after` syncpush   where-	syncpush = Git.Command.runBool $ pushparams+	syncpush = flip Git.Command.runBool g $ pushparams 		[ Git.Branch.forcePush $ refspec Annex.Branch.name 		, refspec $ fromAdjustedBranch branch 		]-	directpush = Git.Command.runQuiet $ pushparams-		[ Git.fromRef $ Git.Ref.base $ Annex.Branch.name-		, Git.fromRef $ Git.Ref.base $ fromDirectBranch $ fromAdjustedBranch branch-		]+	annexpush = void $ tryIO $ flip Git.Command.runQuiet g $ pushparams+		[ Git.fromRef $ Git.Ref.base $ Annex.Branch.name ]+	directpush = do+		-- Git prints out an error message when this fails.+		-- In the default configuration of receive.denyCurrentBranch,+		-- the error message mentions that config setting+		-- (and should even if it is localized), and is quite long,+		-- and the user was not intending to update the checked out+		-- branch, so in that case, avoid displaying the error+		-- message. Do display other error messages though,+		-- including the error displayed when+		-- receive.denyCurrentBranch=updateInstead -- the user+		-- will want to see that one.+		let p = flip Git.Command.gitCreateProcess g $ pushparams+			[ Git.fromRef $ Git.Ref.base $ fromDirectBranch $ fromAdjustedBranch branch ]+		(transcript, ok) <- processTranscript' p Nothing+		when (not ok && not ("denyCurrentBranch" `isInfixOf` transcript)) $+			hPutStr stderr transcript 	pushparams branches = 		[ Param "push" 		, Param $ Remote.name remote

@@ -149,7 +149,7 @@ 		Annex.eval st (Annex.setOutput QuietOutput >> a) @? "failed" 	present b = check ("present " ++ show b) $ 		(== Right b) <$> Remote.hasKey r k-	fsck = case maybeLookupBackendName (keyBackendName k) of+	fsck = case maybeLookupBackendVariety (keyVariety k) of 		Nothing -> return True 		Just b -> case Backend.verifyKeyContent b of 			Nothing -> return True@@ -225,5 +225,5 @@ 		} 	k <- fromMaybe (error "failed to generate random key") 		<$> Backend.getKey Backend.Hash.testKeyBackend ks-	moveAnnex k f+	_ <- moveAnnex k f 	return k

@@ -11,6 +11,7 @@ import qualified Build.SysConfig as SysConfig import Annex.Version import BuildFlags+import Types.Key import qualified Types.Backend as B import qualified Types.Remote as R import qualified Remote@@ -62,7 +63,8 @@ showPackageVersion = do 	vinfo "git-annex version" SysConfig.packageversion 	vinfo "build flags" $ unwords buildFlags-	vinfo "key/value backends" $ unwords $ map B.name Backend.list+	vinfo "key/value backends" $ unwords $+		map (formatKeyVariety . B.backendVariety) Backend.list 	vinfo "remote types" $ unwords $ map R.typename Remote.remoteTypes  showRawVersion :: IO ()

@@ -8,10 +8,8 @@ module Command.Wanted where  import Command-import qualified Annex import qualified Remote import Logs.PreferredContent-import Types.Messages import Types.StandardGroups  import qualified Data.Map as M@@ -27,7 +25,8 @@ 	-> Annex (M.Map UUID PreferredContentExpression) 	-> (UUID -> PreferredContentExpression -> Annex ()) 	-> Command-cmd' name desc getter setter = command name SectionSetup desc pdesc (withParams seek)+cmd' name desc getter setter = noMessages $ +	command name SectionSetup desc pdesc (withParams seek)   where 	pdesc = paramPair paramRemote (paramOptional paramExpression) @@ -35,6 +34,7 @@  	start (rname:[]) = go rname (performGet getter) 	start (rname:expr:[]) = go rname $ \uuid -> do+		allowMessages 		showStart name rname 		performSet setter expr uuid 	start _ = giveup "Specify a repository."@@ -45,7 +45,6 @@  performGet :: Ord a => Annex (M.Map a PreferredContentExpression) -> a -> CommandPerform performGet getter a = do-	Annex.setOutput QuietOutput 	m <- getter 	liftIO $ putStrLn $ fromMaybe "" $ M.lookup a m 	next $ return True

@@ -42,6 +42,7 @@ import qualified Utility.Gpg as Gpg import Types.Crypto import Types.Remote+import Types.Key  {- The beginning of a Cipher is used for MAC'ing; the remainder is used  - as the GPG symmetric encryption passphrase when using the hybrid@@ -159,14 +160,16 @@ encryptKey :: Mac -> Cipher -> EncKey encryptKey mac c k = stubKey 	{ keyName = macWithCipher mac c (key2file k)-	, keyBackendName = encryptedBackendNamePrefix ++ showMac mac+	, keyVariety = OtherKey (encryptedBackendNamePrefix ++ showMac mac) 	}  encryptedBackendNamePrefix :: String encryptedBackendNamePrefix = "GPG"  isEncKey :: Key -> Bool-isEncKey k = encryptedBackendNamePrefix `isPrefixOf` keyBackendName k+isEncKey k = case keyVariety k of+	OtherKey s ->  encryptedBackendNamePrefix `isPrefixOf` s+	_ -> False  type Feeder = Handle -> IO () type Reader m a = Handle -> m a

@@ -14,7 +14,7 @@ import Data.Char  import Utility.PartialPrelude-import Types.Key+import Key import Utility.InodeCache  -- A serialized Key

@@ -0,0 +1,40 @@+{- git config types+ -+ - Copyright 2012, 2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.ConfigTypes where++import Data.Char++import Common+import Git+import qualified Git.Config++data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int+	deriving (Eq)++getSharedRepository :: Repo -> SharedRepository+getSharedRepository r =+	case map toLower $ Git.Config.get "core.sharedrepository" "" r of+		"1" -> GroupShared+		"2" -> AllShared+		"group" -> GroupShared+		"true" -> GroupShared+		"all" -> AllShared+		"world" -> AllShared+		"everybody" -> AllShared+		v -> maybe UnShared UmaskShared (readish v)++data DenyCurrentBranch = UpdateInstead | RefusePush | WarnPush | IgnorePush+	deriving (Eq)++getDenyCurrentBranch :: Repo -> DenyCurrentBranch+getDenyCurrentBranch r =+	case map toLower $ Git.Config.get "receive.denycurrentbranch" "" r of+		"updateinstead" -> UpdateInstead+		"warn" -> WarnPush+		"ignore" -> IgnorePush+		_ -> RefusePush

@@ -24,6 +24,7 @@ import qualified Git.Filename  import Numeric+import Data.Char import System.Posix.Types  data TreeItem = TreeItem@@ -66,7 +67,9 @@ 		, File $ fromRef t 		] ++ map File fs -{- Parses a line of ls-tree output.+{- Parses a line of ls-tree output, in format:+ - mode SP type SP sha TAB file+ -  - (The --long format is not currently supported.) -} parseLsTree :: String -> TreeItem parseLsTree l = TreeItem @@ -76,12 +79,9 @@ 	, file = sfile 	}   where-	-- l = <mode> SP <type> SP <sha> TAB <file>-	-- All fields are fixed, so we can pull them out of-	-- specific positions in the line.-	(m, past_m) = splitAt 7 l-	(!t, past_t) = splitAt 4 past_m-	(!s, past_s) = splitAt shaSize $ Prelude.tail past_t-	!f = Prelude.tail past_s+	(m, past_m) = splitAt 7 l -- mode is 6 bytes+	(!t, past_t) = separate isSpace past_m+	(!s, past_s) = splitAt shaSize past_t+	!f = drop 1 past_s 	!smode = fst $ Prelude.head $ readOct m 	!sfile = asTopFilePath $ Git.Filename.decode f

@@ -1,28 +0,0 @@-{- git core.sharedRepository handling- -- - Copyright 2012 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU GPL version 3 or higher.- -}--module Git.SharedRepository where--import Data.Char--import Common-import Git-import qualified Git.Config--data SharedRepository = UnShared | GroupShared | AllShared | UmaskShared Int--getSharedRepository :: Repo -> SharedRepository-getSharedRepository r =-	case map toLower $ Git.Config.get "core.sharedrepository" "" r of-		"1" -> GroupShared-		"2" -> AllShared-		"group" -> GroupShared-		"true" -> GroupShared-		"all" -> AllShared-		"world" -> AllShared-		"everybody" -> AllShared-		v -> maybe UnShared UmaskShared (readish v)

@@ -64,13 +64,14 @@ 	cparse '?' = Just Untracked 	cparse _ = Nothing -getStatus :: [FilePath] -> Repo -> IO ([Status], IO Bool)-getStatus l r = do-	(ls, cleanup) <- pipeNullSplit params r+getStatus :: [CommandParam] -> [FilePath] -> Repo -> IO ([Status], IO Bool)+getStatus ps fs r = do+	(ls, cleanup) <- pipeNullSplit ps' r 	return (parseStatusZ ls, cleanup)   where-	params =-		[ Param "status"-		, Param "-uall"-		, Param "-z"-		] ++ map File l+	ps' = concat+		[ [Param "status"]+		, ps+		, [ Param "-uall" , Param "-z"]+		, map File fs+		]

@@ -35,11 +35,14 @@ 	deriving (Show)  data TreeContent+	-- A blob object in the tree. 	= TreeBlob TopFilePath FileMode Sha 	-- A subtree that is already recorded in git, with a known sha. 	| RecordedSubTree TopFilePath Sha [TreeContent] 	-- A subtree that has not yet been recorded in git. 	| NewSubTree TopFilePath [TreeContent]+	-- A commit object that is part of a tree (used for submodules)+	| TreeCommit TopFilePath FileMode Sha 	deriving (Show, Eq, Ord)  {- Gets the Tree for a Ref. -}@@ -93,6 +96,7 @@ 			TreeBlob f fm s -> mkTreeOutput fm BlobObject s f 			RecordedSubTree f s _ -> mkTreeOutput 0o040000 TreeObject s f 			NewSubTree _ _ -> error "recordSubTree internal error; unexpected NewSubTree"+			TreeCommit f fm s -> mkTreeOutput fm CommitObject s f 		hPutStr h "\NUL" -- signal end of tree to --batch 	receive h = getSha "mktree" (hGetLine h) @@ -152,6 +156,7 @@ 	go _ b@(TreeBlob _ _ _) = [b] 	go n' (RecordedSubTree _ _ l') = concatMap (go (n'-1)) l' 	go n' (NewSubTree _ l') = concatMap (go (n'-1)) l'+	go _ c@(TreeCommit _ _ _) = [c]  {- Applies an adjustment to items in a tree.  -@@ -200,6 +205,9 @@ 					else return $ RecordedSubTree (LsTree.file i) (LsTree.sha i) []  				let !modified' = modified || slmodified || wasmodified 				go h modified' (subtree : c) depth intree is'+			Just CommitObject -> do+				let ti = TreeCommit (LsTree.file i) (LsTree.mode i)  (LsTree.sha i)+				go h wasmodified (ti:c) depth intree is 			_ -> error ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") 		| otherwise = return (c, wasmodified, i:is) @@ -236,6 +244,9 @@ 					let st = RecordedSubTree (LsTree.file i) (LsTree.sha i) subtree 					in go (st:t) intree is' 				Left e -> Left e+			Just CommitObject ->+				let c = TreeCommit (LsTree.file i) (LsTree.mode i) (LsTree.sha i)+				in go (c:t) intree is 			_ -> parseerr ("unexpected object type \"" ++ LsTree.typeobj i ++ "\"") 		| otherwise = Right (t, i:is) 	parseerr = Left@@ -259,6 +270,7 @@ 	gitPath (TreeBlob f _ _) = gitPath f 	gitPath (RecordedSubTree f _ _) = gitPath f 	gitPath (NewSubTree f _) = gitPath f+	gitPath (TreeCommit f _ _) = gitPath f  inTopTree :: GitPath t => t -> Bool inTopTree = inTree "."

@@ -0,0 +1,181 @@+{- git-annex Keys+ -+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Key (+	Key(..),+	AssociatedFile,+	stubKey,+	key2file,+	file2key,+	nonChunkKey,+	chunkKeyOffset,+	isChunkKey,+	isKeyPrefix,++	prop_isomorphic_key_encode,+	prop_isomorphic_key_decode+) where++import Data.Aeson+import Data.Char+import qualified Data.Text as T++import Common+import Types.Key+import Utility.QuickCheck+import Utility.Bloom+import qualified Utility.SimpleProtocol as Proto++stubKey :: Key+stubKey = Key+	{ keyName = ""+	, keyVariety = OtherKey ""+	, keySize = Nothing+	, keyMtime = Nothing+	, keyChunkSize = Nothing+	, keyChunkNum = Nothing+	}++-- Gets the parent of a chunk key.+nonChunkKey :: Key -> Key+nonChunkKey k = k+	{ keyChunkSize = Nothing+	, keyChunkNum = Nothing+	}++-- Where a chunk key is offset within its parent.+chunkKeyOffset :: Key -> Maybe Integer+chunkKeyOffset k = (*)+	<$> keyChunkSize k+	<*> (pred <$> keyChunkNum k)++isChunkKey :: Key -> Bool+isChunkKey k = isJust (keyChunkSize k) && isJust (keyChunkNum k)++-- Checks if a string looks like at least the start of a key.+isKeyPrefix :: String -> Bool+isKeyPrefix s = [fieldSep, fieldSep] `isInfixOf` s++fieldSep :: Char+fieldSep = '-'++{- Converts a key to a string that is suitable for use as a filename.+ - The name field is always shown last, separated by doubled fieldSeps,+ - and is the only field allowed to contain the fieldSep. -}+key2file :: Key -> FilePath+key2file Key { keyVariety = kv, keySize = s, keyMtime = m, keyChunkSize = cs, keyChunkNum = cn, keyName = n } =+	formatKeyVariety kv +++ ('s' ?: s) +++ ('m' ?: m) +++ ('S' ?: cs) +++ ('C' ?: cn) +++ (fieldSep : n)+  where+	"" +++ y = y+	x +++ "" = x+	x +++ y = x ++ fieldSep:y+	f ?: (Just v) = f : show v+	_ ?: _ = ""++file2key :: FilePath -> Maybe Key+file2key s+	| key == Just stubKey || (keyName <$> key) == Just "" || (keyVariety <$> key) == Just (OtherKey "") = Nothing+	| otherwise = key+  where+	key = startbackend stubKey s++	startbackend k v = sepfield k v addvariety+		+	sepfield k v a = case span (/= fieldSep) v of+		(v', _:r) -> findfields r $ a k v'+		_ -> Nothing++	findfields (c:v) (Just k)+		| c == fieldSep = addkeyname k v+		| otherwise = sepfield k v $ addfield c+	findfields _ v = v++	addvariety k v = Just k { keyVariety = parseKeyVariety v }++	-- This is a strict parser for security reasons; a key+	-- can contain only 4 fields, which all consist only of numbers.+	-- Any key containing other fields, or non-numeric data is+	-- rejected with Nothing.+	--+	-- If a key contained non-numeric fields, they could be used to+	-- embed data used in a SHA1 collision attack, which would be a+	-- problem since the keys are committed to git.+	addfield _ _ v | not (all isDigit v) = Nothing+	addfield 's' k v = do+		sz <- readish v+		return $ k { keySize = Just sz }+	addfield 'm' k v = do+		mtime <- readish v+		return $ k { keyMtime = Just mtime }+	addfield 'S' k v = do+		chunksize <- readish v+		return $ k { keyChunkSize = Just chunksize }+	addfield 'C' k v = case readish v of+		Just chunknum | chunknum > 0 ->+			return $ k { keyChunkNum = Just chunknum }+		_ -> Nothing+	addfield _ _ _ = Nothing++	addkeyname k v+		| validKeyName k v = Just $ k { keyName = v }+		| otherwise = Nothing++{- When a key HasExt, the length of the extension is limited in order to+ - mitigate against SHA1 collision attacks.+ -+ - In such an attack, the extension of the key could be made to contain+ - the collision generation data, with the result that a signed git commit+ - including such keys would not be secure.+ -+ - The maximum extension length ever generated for such a key was 8+ - characters; 20 is used here to give a little future wiggle-room. + - The SHA1 common-prefix attack needs 128 bytes of data.+ -}+validKeyName :: Key -> String -> Bool+validKeyName k name+	| hasExt (keyVariety k) = length (takeExtensions name) <= 20+	| otherwise = True++instance Arbitrary Key where+	arbitrary = Key+		<$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t")+		<*> (parseKeyVariety <$> (listOf1 $ elements ['A'..'Z'])) -- BACKEND+		<*> ((abs <$>) <$> arbitrary) -- size cannot be negative+		<*> arbitrary+		<*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative+		<*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative++instance Hashable Key where+	hashIO32 = hashIO32 . key2file+	hashIO64 = hashIO64 . key2file++instance ToJSON Key where+	toJSON = toJSON . key2file++instance FromJSON Key where+	parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t+	parseJSON _ = mempty++instance Proto.Serializable Key where+	serialize = key2file+	deserialize = file2key++prop_isomorphic_key_encode :: Key -> Bool+prop_isomorphic_key_encode k = Just k == (file2key . key2file) k++prop_isomorphic_key_decode :: FilePath -> Bool+prop_isomorphic_key_decode f+	| normalfieldorder = maybe True (\k -> key2file k == f) (file2key f)+	| otherwise = True+  where+	-- file2key will accept the fields in any order, so don't+	-- try the test unless the fields are in the normal order+	normalfieldorder = fields `isPrefixOf` "smSC"+	fields = map (f !!) $ filter (< length f) $ map succ $+		elemIndices fieldSep f

@@ -1,6 +1,6 @@ {- user-specified limits on files to act on  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -19,6 +19,7 @@ import Annex.UUID import Logs.Trust import Annex.NumCopies+import Types.Key import Types.TrustLevel import Types.Group import Types.FileMatcher@@ -251,7 +252,15 @@ limitInBackend :: MkLimit Annex limitInBackend name = Right $ const $ checkKey check   where-	check key = pure $ keyBackendName key == name+	check key = pure $ keyVariety key == variety+	variety = parseKeyVariety name++{- Adds a limit to skip files not using a secure hash. -}+addSecureHash :: Annex ()+addSecureHash = addLimit $ Right limitSecureHash++limitSecureHash :: MatchFiles Annex+limitSecureHash _ = checkKey $ pure . cryptographicallySecure . keyVariety  {- Adds a limit to skip files that are too large or too small -} addLargerThan :: String -> Annex ()

@@ -23,15 +23,6 @@ import Data.Time.Clock.POSIX import Control.Concurrent -showLcDirection :: Direction -> String-showLcDirection Upload = "upload"-showLcDirection Download = "download"--readLcDirection :: String -> Maybe Direction-readLcDirection "upload" = Just Upload-readLcDirection "download" = Just Download-readLcDirection _ = Nothing- describeTransfer :: Transfer -> TransferInfo -> String describeTransfer t info = unwords 	[ show $ transferDirection t@@ -212,7 +203,7 @@ 	| "lck." `isPrefixOf` takeFileName file = Nothing 	| otherwise = case drop (length bits - 3) bits of 		[direction, u, key] -> Transfer-			<$> readLcDirection direction+			<$> parseDirection direction 			<*> pure (toUUID u) 			<*> fileKey key 		_ -> Nothing@@ -279,14 +270,14 @@  {- The directory holding transfer information files for a given Direction. -} transferDir :: Direction -> Git.Repo -> FilePath-transferDir direction r = gitAnnexTransferDir r </> showLcDirection direction+transferDir direction r = gitAnnexTransferDir r </> formatDirection direction  {- The directory holding failed transfer information files for a given  - Direction and UUID -} failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath failedTransferDir u direction r = gitAnnexTransferDir r 	</> "failed"-	</> showLcDirection direction+	</> formatDirection direction 	</> filter (/= '/') (fromUUID u)  prop_read_write_transferinfo :: TransferInfo -> Bool

@@ -36,7 +36,7 @@ import Data.Monoid import Prelude -import Types.Key+import Key import Utility.Metered import Utility.Percentage 

@@ -1,3 +1,15 @@+git-annex (6.20170228) unstable; urgency=medium++  This version of git-annex has mitigations for SHA1 hash collision+  problems.+  +  A new annex.securehashesonly configuration, when used in combination with+  signed git commits, avoids potential hash collision problems in git-annex+  repositories. For details, see this web page:+  <https://git-annex.branchable.com/tips/using_signed_git_commits/>++ -- Joey Hess <id@joeyh.name>  Tue, 28 Feb 2017 13:28:50 -0400+ git-annex (6.20170101) unstable; urgency=medium    XMPP support has been removed from the assistant in this release.

@@ -28,6 +28,7 @@ import Utility.Hash import Utility.UserInfo import Annex.UUID+import Annex.Ssh import Utility.Metered  type BupRepo = String@@ -213,7 +214,7 @@ onBupRemote :: Git.Repo -> (FilePath -> [CommandParam] -> IO a) -> FilePath -> [CommandParam] -> Annex a onBupRemote r a command params = do 	c <- Annex.getRemoteGitConfig r-	sshparams <- Ssh.toRepo r c [Param $+	sshparams <- Ssh.toRepo NoConsumeStdin r c [Param $ 			"cd " ++ dir ++ " && " ++ unwords (command : toCommand params)] 	liftIO $ a "ssh" sshparams   where

@@ -118,11 +118,11 @@  {- Return the command and parameters to use for a ddar call that may need to be  - made on a remote repository. This will call ssh if needed. -}-ddarRemoteCall :: DdarRepo -> Char -> [CommandParam] -> Annex (String, [CommandParam])-ddarRemoteCall ddarrepo cmd params+ddarRemoteCall :: ConsumeStdin -> DdarRepo -> Char -> [CommandParam] -> Annex (String, [CommandParam])+ddarRemoteCall cs ddarrepo cmd params 	| ddarLocal ddarrepo = return ("ddar", localParams) 	| otherwise = do-		os <- sshOptions (host, Nothing) (ddarRepoConfig ddarrepo) []+		os <- sshOptions cs (host, Nothing) (ddarRepoConfig ddarrepo) [] 		return ("ssh", os ++ remoteParams)   where 	(host, ddarrepo') = splitRemoteDdarRepo ddarrepo@@ -130,13 +130,13 @@ 	remoteParams = Param host : Param "ddar" : Param [cmd] : Param ddarrepo' : params  {- Specialized ddarRemoteCall that includes extraction command and flags -}-ddarExtractRemoteCall :: DdarRepo -> Key -> Annex (String, [CommandParam])-ddarExtractRemoteCall ddarrepo k =-	ddarRemoteCall ddarrepo 'x' [Param "--force-stdout", Param $ key2file k]+ddarExtractRemoteCall :: ConsumeStdin -> DdarRepo -> Key -> Annex (String, [CommandParam])+ddarExtractRemoteCall cs ddarrepo k =+	ddarRemoteCall cs ddarrepo 'x' [Param "--force-stdout", Param $ key2file k]  retrieve :: DdarRepo -> Retriever retrieve ddarrepo = byteRetriever $ \k sink -> do-	(cmd, params) <- ddarExtractRemoteCall ddarrepo k+	(cmd, params) <- ddarExtractRemoteCall NoConsumeStdin ddarrepo k 	let p = (proc cmd $ toCommand params) { std_out = CreatePipe } 	(_, Just h, _, pid) <- liftIO $ createProcess p 	liftIO (hClose h >> forceSuccessProcess p pid)@@ -147,7 +147,8 @@  remove :: DdarRepo -> Remover remove ddarrepo key = do-	(cmd, params) <- ddarRemoteCall ddarrepo 'd' [Param $ key2file key]+	(cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 'd'+		[Param $ key2file key] 	liftIO $ boolSystem cmd params  ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool)@@ -158,7 +159,8 @@ 			Left _ -> Right False 			Right status -> Right $ isDirectory status 	| otherwise = do-		ps <- sshOptions (host, Nothing) (ddarRepoConfig ddarrepo) []+		ps <- sshOptions NoConsumeStdin (host, Nothing)+			(ddarRepoConfig ddarrepo) [] 		exitCode <- liftIO $ safeSystem "ssh" (ps ++ params) 		case exitCode of 			ExitSuccess -> return $ Right True@@ -178,7 +180,7 @@ {- Use "ddar t" to determine if a given key is present in a ddar archive -} inDdarManifest :: DdarRepo -> Key -> Annex (Either String Bool) inDdarManifest ddarrepo k = do-	(cmd, params) <- ddarRemoteCall ddarrepo 't' []+	(cmd, params) <- ddarRemoteCall NoConsumeStdin ddarrepo 't' [] 	let p = proc cmd $ toCommand params 	liftIO $ catchMsgIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do 		contents <- hGetContents h

@@ -159,7 +159,7 @@ 		let rsyncpath = if "/~/" `isPrefixOf` path 			then drop 3 path 			else path-		opts <- sshOptions (host, Nothing) gc []+		opts <- sshOptions ConsumeStdin (host, Nothing) gc [] 		return (rsyncShell $ Param "ssh" : opts, host ++ ":" ++ rsyncpath, AccessShell) 	othertransport = return ([], loc, AccessDirect) @@ -263,7 +263,8 @@  	{-  Ask git-annex-shell to configure the repository as a gcrypt 	 -  repository. May fail if it is too old. -}-	gitannexshellsetup = Ssh.onRemote r (boolSystem, return False)+	gitannexshellsetup = Ssh.onRemote NoConsumeStdin r+		(boolSystem, return False) 		"gcryptsetup" [ Param gcryptid ] []  	denyNonFastForwards = "receive.denyNonFastForwards"@@ -398,7 +399,7 @@ 	| Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> 		liftIO (catchMaybeIO $ Git.Config.read r) 	| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)-		[ Ssh.onRemote r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] []+		[ Ssh.onRemote NoConsumeStdin r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] [] 		, getConfigViaRsync r gc 		] 	| otherwise = return (Nothing, r)

@@ -1,6 +1,6 @@ {- Standard git remotes.  -- - Copyright 2011-2015 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -11,6 +11,7 @@ 	remote, 	configRead, 	repoAvail,+	onLocal, ) where  import Annex.Common@@ -54,9 +55,9 @@ import P2P.Address import Annex.Path import Creds-import Annex.CatFile import Messages.Progress import Types.NumCopies+import Annex.Concurrent  import Control.Concurrent import Control.Concurrent.MSampleVar@@ -210,7 +211,9 @@ tryGitConfigRead autoinit r  	| haveconfig r = return r -- already read 	| Git.repoIsSsh r = store $ do-		v <- Ssh.onRemote r (pipedconfig, return (Left $ giveup "configlist failed")) "configlist" [] configlistfields+		v <- Ssh.onRemote NoConsumeStdin r+			(pipedconfig, return (Left $ giveup "configlist failed"))+			"configlist" [] configlistfields 		case v of 			Right r' 				| haveconfig r' -> return r'@@ -334,7 +337,7 @@ 	checkremote = Ssh.inAnnex r key 	checklocal = guardUsable r (cantCheck r) $ 		maybe (cantCheck r) return-			=<< onLocal rmt (Annex.Content.inAnnexSafe key)+			=<< onLocalFast rmt (Annex.Content.inAnnexSafe key)  keyUrls :: Remote -> Key -> [String] keyUrls r key = map tourl locs'@@ -357,7 +360,7 @@ dropKey r key 	| not $ Git.repoIsUrl (repo r) = 		guardUsable (repo r) (return False) $-			commitOnCleanup r $ onLocal r $ do+			commitOnCleanup r $ onLocalFast r $ do 				ensureInitialized 				whenM (Annex.Content.inAnnex key) $ do 					Annex.Content.lockContentForRemoval key $ \lock -> do@@ -376,7 +379,7 @@ 			-- Lock content from perspective of remote, 			-- and then run the callback in the original 			-- annex monad, not the remote's.-			onLocal r $ +			onLocalFast r $  				Annex.Content.lockContentShared key $ \vc -> 					ifM (Annex.Content.inAnnex key) 						( liftIO $ inorigrepo $ callback vc@@ -384,7 +387,8 @@ 						) 	| Git.repoIsSsh (repo r) = do 		showLocking r-		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"+		Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin+			(repo r) "lockcontent" 			[Param $ key2file key] [] 		(Just hin, Just hout, Nothing, p) <- liftIO $  			withFile devNull WriteMode $ \nullh ->@@ -439,7 +443,7 @@ 		u <- getUUID 		hardlink <- wantHardLink 		-- run copy from perspective of remote-		onLocal r $ do+		onLocalFast r $ do 			ensureInitialized 			v <- Annex.Content.prepSendAnnex key 			case v of@@ -477,7 +481,8 @@ 		u <- getUUID 		let fields = (Fields.remoteUUID, fromUUID u) 			: maybe [] (\f -> [(Fields.associatedFile, f)]) file-		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "transferinfo" +		Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin+			(repo r) "transferinfo"  			[Param $ key2file key] fields 		v <- liftIO (newEmptySV :: IO (MSampleVar Integer)) 		pidv <- liftIO $ newEmptyMVar@@ -567,7 +572,7 @@ 		u <- getUUID 		hardlink <- wantHardLink 		-- run copy from perspective of remote-		onLocal r $ ifM (Annex.Content.inAnnex key)+		onLocalFast r $ ifM (Annex.Content.inAnnex key) 			( return True 			, do 				ensureInitialized@@ -583,7 +588,7 @@ fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool) fsckOnRemote r params 	| Git.repoIsUrl r = do-		s <- Ssh.git_annex_shell r "fsck" params []+		s <- Ssh.git_annex_shell NoConsumeStdin r "fsck" params [] 		return $ case s of 			Nothing -> return False 			Just (c, ps) -> batchCommand c ps@@ -609,34 +614,36 @@ {- Runs an action from the perspective of a local remote.  -  - The AnnexState is cached for speed and to avoid resource leaks.- - However, catFileStop is called to avoid git-cat-file processes hanging- - around on removable media.- -- - The repository's git-annex branch is not updated, as an optimisation.- - No caller of onLocal can query data from the branch and be ensured- - it gets a current value. Caller of onLocal can make changes to- - the branch, however.+ - However, coprocesses are stopped after each call to avoid git+ - processes hanging around on removable media.  -} onLocal :: Remote -> Annex a -> Annex a onLocal r a = do 	m <- Annex.getState Annex.remoteannexstate-	case M.lookup (uuid r) m of-		Nothing -> do-			st <- liftIO $ Annex.new (repo r)-			go st $ do-				Annex.BranchState.disableUpdate	-				a-		Just st -> go st a+	go =<< maybe+		(liftIO $ Annex.new $ repo r)+		return+		(M.lookup (uuid r) m)   where 	cache st = Annex.changeState $ \s -> s 		{ Annex.remoteannexstate = M.insert (uuid r) st (Annex.remoteannexstate s) }-	go st a' = do+	go st = do 		curro <- Annex.getState Annex.output 		(ret, st') <- liftIO $ Annex.run (st { Annex.output = curro }) $-			catFileStop `after` a'+			stopCoProcesses `after` a 		cache st' 		return ret +{- Faster variant of onLocal.+ -+ - The repository's git-annex branch is not updated, as an optimisation.+ - No caller of onLocalFast can query data from the branch and be ensured+ - it gets the most current value. Caller of onLocalFast can make changes+ - to the branch, however.+ -}+onLocalFast :: Remote -> Annex a -> Annex a+onLocalFast r a = onLocal r $ Annex.BranchState.disableUpdate >> a+ {- Copys a file with rsync unless both locations are on the same  - filesystem. Then cp could be faster. -} rsyncOrCopyFile :: [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool@@ -660,12 +667,13 @@   where 	go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup 	cleanup-		| not $ Git.repoIsUrl (repo r) = onLocal r $+		| not $ Git.repoIsUrl (repo r) = onLocalFast r $ 			doQuietSideAction $ 				Annex.Branch.commit "update" 		| otherwise = void $ do 			Just (shellcmd, shellparams) <--				Ssh.git_annex_shell (repo r) "commit" [] []+				Ssh.git_annex_shell NoConsumeStdin+					(repo r) "commit" [] [] 			 			-- Throw away stderr, since the remote may not 			-- have a new enough git-annex shell to

@@ -26,17 +26,17 @@ {- Generates parameters to ssh to a repository's host and run a command.  - Caller is responsible for doing any neccessary shellEscaping of the  - passed command. -}-toRepo :: Git.Repo -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]-toRepo r gc sshcmd = do+toRepo :: ConsumeStdin -> Git.Repo -> RemoteGitConfig -> [CommandParam] -> Annex [CommandParam]+toRepo cs r gc sshcmd = do 	let opts = map Param $ remoteAnnexSshOptions gc 	let host = fromMaybe (giveup "bad ssh url") $ Git.Url.hostuser r-	params <- sshOptions (host, Git.Url.port r) gc opts+	params <- sshOptions cs (host, Git.Url.port r) gc opts 	return $ params ++ Param host : sshcmd  {- Generates parameters to run a git-annex-shell command on a remote  - repository. -}-git_annex_shell :: Git.Repo -> String -> [CommandParam] -> [(Field, String)] -> Annex (Maybe (FilePath, [CommandParam]))-git_annex_shell r command params fields+git_annex_shell :: ConsumeStdin -> Git.Repo -> String -> [CommandParam] -> [(Field, String)] -> Annex (Maybe (FilePath, [CommandParam]))+git_annex_shell cs r command params fields 	| not $ Git.repoIsUrl r = do 		shellopts <- getshellopts 		return $ Just (shellcmd, shellopts ++ fieldopts)@@ -49,7 +49,7 @@ 				: map shellEscape (toCommand shellopts) ++ 			uuidcheck u ++ 			map shellEscape (toCommand fieldopts)-		sshparams <- toRepo r gc [Param sshcmd]+		sshparams <- toRepo cs r gc [Param sshcmd] 		return $ Just ("ssh", sshparams) 	| otherwise = return Nothing   where@@ -76,14 +76,15 @@  - Or, if the remote does not support running remote commands, returns  - a specified error value. -} onRemote -	:: Git.Repo+	:: ConsumeStdin+	-> Git.Repo 	-> (FilePath -> [CommandParam] -> IO a, Annex a) 	-> String 	-> [CommandParam] 	-> [(Field, String)] 	-> Annex a-onRemote r (with, errorval) command params fields = do-	s <- git_annex_shell r command params fields+onRemote cs r (with, errorval) command params fields = do+	s <- git_annex_shell cs r command params fields 	case s of 		Just (c, ps) -> liftIO $ with c ps 		Nothing -> errorval@@ -92,7 +93,7 @@ inAnnex :: Git.Repo -> Key -> Annex Bool inAnnex r k = do 	showChecking r-	onRemote r (check, cantCheck r) "inannex" [Param $ key2file k] []+	onRemote NoConsumeStdin r (check, cantCheck r) "inannex" [Param $ key2file k] []   where 	check c p = dispatch =<< safeSystem c p 	dispatch ExitSuccess = return True@@ -101,7 +102,7 @@  {- Removes a key from a remote. -} dropKey :: Git.Repo -> Key -> Annex Bool-dropKey r key = onRemote r (boolSystem, return False) "dropkey"+dropKey r key = onRemote NoConsumeStdin r (boolSystem, return False) "dropkey" 	[ Param "--quiet", Param "--force" 	, Param $ key2file key 	]@@ -133,7 +134,7 @@ 		-- compatability. 		: (Fields.direct, if unlocked then "1" else "") 		: maybe [] (\f -> [(Fields.associatedFile, f)]) afile-	Just (shellcmd, shellparams) <- git_annex_shell (repo r)+	Just (shellcmd, shellparams) <- git_annex_shell ConsumeStdin (repo r) 		(if direction == Download then "sendkey" else "recvkey") 		[ Param $ key2file key ] 		fields

@@ -122,7 +122,7 @@ 				let (port, sshopts') = sshReadPort sshopts 				    userhost = takeWhile (/=':') url 				-- Connection caching-				(Param "ssh":) <$> sshOptions+				(Param "ssh":) <$> sshOptions ConsumeStdin 					(userhost, port) gc 					(map Param $ loginopt ++ sshopts') 			"rsh":rshopts -> return $ map Param $ "rsh" :

@@ -14,12 +14,13 @@ import Git.GCrypt import Remote.Helper.Ssh import Remote.GCrypt (accessShellConfig)+import Annex.Ssh  transport :: Transport transport rr@(RemoteRepo r gc) url h@(TransportHandle (LocalRepo g) _) ichan ochan 	| accessShellConfig gc = do 		r' <- encryptedRemote g r-		v <- liftAnnex h $ git_annex_shell r' "notifychanges" [] []+		v <- liftAnnex h $ git_annex_shell ConsumeStdin r' "notifychanges" [] [] 		case v of 			Nothing -> noop 			Just (cmd, params) -> 

@@ -23,7 +23,7 @@  transport :: Transport transport rr@(RemoteRepo r _) url h ichan ochan = do-	v <- liftAnnex h $ git_annex_shell r "notifychanges" [] []+	v <- liftAnnex h $ git_annex_shell ConsumeStdin r "notifychanges" [] [] 	case v of 		Nothing -> noop 		Just (cmd, params) -> transportUsingCmd cmd params rr url h ichan ochan

@@ -63,6 +63,7 @@ import qualified Logs.PreferredContent import qualified Types.MetaData import qualified Remote+import qualified Key import qualified Types.Key import qualified Types.Messages import qualified Config@@ -152,8 +153,8 @@ 	[ testProperty "prop_isomorphic_deencode_git" Git.Filename.prop_isomorphic_deencode 	, testProperty "prop_isomorphic_deencode" Utility.Format.prop_isomorphic_deencode 	, testProperty "prop_isomorphic_fileKey" Annex.Locations.prop_isomorphic_fileKey-	, testProperty "prop_isomorphic_key_encode" Types.Key.prop_isomorphic_key_encode-	, testProperty "prop_isomorphic_key_decode" Types.Key.prop_isomorphic_key_decode+	, testProperty "prop_isomorphic_key_encode" Key.prop_isomorphic_key_encode+	, testProperty "prop_isomorphic_key_decode" Key.prop_isomorphic_key_decode 	, testProperty "prop_isomorphic_shellEscape" Utility.SafeCommand.prop_isomorphic_shellEscape 	, testProperty "prop_isomorphic_shellEscape_multiword" Utility.SafeCommand.prop_isomorphic_shellEscape_multiword 	, testProperty "prop_isomorphic_configEscape" Logs.Remote.prop_isomorphic_configEscape@@ -390,7 +391,7 @@ 	git_annex "drop" ["--force", sha1annexedfile] @? "drop failed" 	annexed_notpresent sha1annexedfile 	writeFile tmp $ content sha1annexedfile-	key <- Types.Key.key2file <$> getKey backendSHA1 tmp+	key <- Key.key2file <$> getKey backendSHA1 tmp 	git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed" 	annexed_present sha1annexedfile 	-- fromkey can't be used on a crippled filesystem, since it makes a@@ -846,9 +847,9 @@ 	checkunused [annexedfilekey, sha1annexedfilekey] "after rm sha1annexedfile"  	-- good opportunity to test dropkey also-	git_annex "dropkey" ["--force", Types.Key.key2file annexedfilekey]+	git_annex "dropkey" ["--force", Key.key2file annexedfilekey] 		@? "dropkey failed"-	checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Types.Key.key2file annexedfilekey)+	checkunused [sha1annexedfilekey] ("after dropkey --force " ++ Key.key2file annexedfilekey)  	not <$> git_annex "dropunused" ["1"] @? "dropunused failed to fail without --force" 	git_annex "dropunused" ["--force", "1"] @? "dropunused failed"@@ -1959,7 +1960,7 @@ 	case r of 		Just k -> do 			uuids <- annexeval $ Remote.keyLocations k-			assertEqual ("bad content in location log for " ++ f ++ " key " ++ Types.Key.key2file k ++ " uuid " ++ show thisuuid)+			assertEqual ("bad content in location log for " ++ f ++ " key " ++ Key.key2file k ++ " uuid " ++ show thisuuid) 				expected (thisuuid `elem` uuids) 		_ -> assertFailure $ f ++ " failed to look up key" @@ -2152,7 +2153,7 @@ backendWORM = backend_ "WORM"  backend_ :: String -> Types.Backend-backend_ = Backend.lookupBackendName+backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety  getKey :: Types.Backend -> FilePath -> IO Types.Key getKey b f = fromJust <$> annexeval go

@@ -9,7 +9,7 @@  module Types.ActionItem where -import Types.Key+import Key import Types.Transfer import Git.FilePath 

@@ -2,7 +2,7 @@  -  - Most things should not need this, using Types instead  -- - Copyright 2010,2012 Joey Hess <id@joeyh.name>+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -13,7 +13,7 @@ import Types.KeySource  data BackendA a = Backend-	{ name :: String+	{ backendVariety :: KeyVariety 	, getKey :: KeySource -> a (Maybe Key)  	-- Verifies the content of a key. 	, verifyKeyContent :: Maybe (Key -> FilePath -> a Bool)@@ -28,7 +28,7 @@ 	}  instance Show (BackendA a) where-	show backend = "Backend { name =\"" ++ name backend ++ "\" }"+	show backend = "Backend { name =\"" ++ formatKeyVariety (backendVariety backend) ++ "\" }"  instance Eq (BackendA a) where-	a == b = name a == name b+	a == b = backendVariety a == backendVariety b

@@ -1,16 +1,24 @@ {- Data type for a distribution of git-annex  -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013, 2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}  module Types.Distribution where +import Utility.PartialPrelude import Types.Key+import Key import Data.Time.Clock import Git.Config (isTrue, boolConfig) +import Data.String.Utils+import Control.Applicative+import Prelude++type GitAnnexVersion = String+ data GitAnnexDistribution = GitAnnexDistribution 	{ distributionUrl :: String 	, distributionKey :: Key@@ -20,7 +28,39 @@ 	} 	deriving (Read, Show, Eq) -type GitAnnexVersion = String+{- The first line of the info file is in the format old versions of+ - git-annex expect to read a GitAnnexDistribution.+ - The remainder of the file is in the new format.+ - This works because old versions of git-annex used readish to parse+ - the file, and that ignores the second line.+ -}+formatInfoFile :: GitAnnexDistribution -> String+formatInfoFile d = replace "keyVariant = " "keyBackendName = " (show d) +++	"\n" ++ formatGitAnnexDistribution d++parseInfoFile :: String -> Maybe GitAnnexDistribution+parseInfoFile s = case lines s of+	(_oldformat:rest) -> parseGitAnnexDistribution (unlines rest)+	_ -> Nothing++formatGitAnnexDistribution :: GitAnnexDistribution -> String+formatGitAnnexDistribution d = unlines+	[ distributionUrl d+	, key2file (distributionKey d)+	, distributionVersion d+	, show (distributionReleasedate d)+	, maybe "" show (distributionUrgentUpgrade d)+	]++parseGitAnnexDistribution :: String -> Maybe GitAnnexDistribution+parseGitAnnexDistribution s = case lines s of+	(u:k:v:d:uu:_) -> GitAnnexDistribution+		<$> pure u+		<*> file2key k+		<*> pure v+		<*> readish d+		<*> pure (readish uu)+	_ -> Nothing  data AutoUpgrade = AskUpgrade | AutoUpgrade | NoAutoUpgrade 	deriving (Eq)

@@ -18,7 +18,7 @@ import qualified Git import qualified Git.Config import qualified Git.Construct-import Git.SharedRepository+import Git.ConfigTypes import Utility.DataUnits import Config.Cost import Types.UUID@@ -82,8 +82,10 @@ 	, annexPidLock :: Bool 	, annexPidLockTimeout :: Seconds 	, annexAddUnlocked :: Bool+	, annexSecureHashesOnly :: Bool 	, coreSymlinks :: Bool 	, coreSharedRepository :: SharedRepository+	, receiveDenyCurrentBranch :: DenyCurrentBranch 	, gcryptId :: Maybe String 	, gpgCmd :: GpgCmd 	}@@ -135,8 +137,10 @@ 	, annexPidLockTimeout = Seconds $ fromMaybe 300 $ 		getmayberead (annex "pidlocktimeout") 	, annexAddUnlocked = getbool (annex "addunlocked") False+	, annexSecureHashesOnly = getbool (annex "securehashesonly") False 	, coreSymlinks = getbool "core.symlinks" True 	, coreSharedRepository = getSharedRepository r+	, receiveDenyCurrentBranch = getDenyCurrentBranch r 	, gcryptId = getmaybe "core.gcrypt-id" 	, gpgCmd = mkGpgCmd (getmaybe "gpg.program") 	}

@@ -1,39 +1,21 @@ {- git-annex Key data type  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2017 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} -module Types.Key (-	Key(..),-	AssociatedFile,-	stubKey,-	key2file,-	file2key,-	nonChunkKey,-	chunkKeyOffset,-	isChunkKey,-	isKeyPrefix,+module Types.Key where -	prop_isomorphic_key_encode,-	prop_isomorphic_key_decode-) where+import Utility.PartialPrelude  import System.Posix.Types-import Data.Aeson-import qualified Data.Text as T -import Common-import Utility.QuickCheck-import Utility.Bloom-import qualified Utility.SimpleProtocol as Proto- {- A Key has a unique name, which is derived from a particular backend,  - and may contain other optional metadata. -} data Key = Key 	{ keyName :: String-	, keyBackendName :: String+	, keyVariety :: KeyVariety 	, keySize :: Maybe Integer 	, keyMtime :: Maybe EpochTime 	, keyChunkSize :: Maybe Integer@@ -43,120 +25,92 @@ {- A filename may be associated with a Key. -} type AssociatedFile = Maybe FilePath -stubKey :: Key-stubKey = Key-	{ keyName = ""-	, keyBackendName = ""-	, keySize = Nothing-	, keyMtime = Nothing-	, keyChunkSize = Nothing-	, keyChunkNum = Nothing-	}---- Gets the parent of a chunk key.-nonChunkKey :: Key -> Key-nonChunkKey k = k-	{ keyChunkSize = Nothing-	, keyChunkNum = Nothing-	}+{- There are several different varieties of keys. -}+data KeyVariety+	= SHA2Key HashSize HasExt+	| SHA3Key HashSize HasExt+	| SKEINKey HashSize HasExt+	| SHA1Key HasExt+	| MD5Key HasExt+	| WORMKey+	| URLKey+ 	-- Some repositories may contain keys of other varieties,+	-- which can still be processed to some extent.+	| OtherKey String+	deriving (Eq, Ord, Read, Show) --- Where a chunk key is offset within its parent.-chunkKeyOffset :: Key -> Maybe Integer-chunkKeyOffset k = (*)-	<$> keyChunkSize k-	<*> (pred <$> keyChunkNum k)+{- Some varieties of keys may contain an extension at the end of the+ - keyName -}+newtype HasExt = HasExt Bool+	deriving (Eq, Ord, Read, Show) -isChunkKey :: Key -> Bool-isChunkKey k = isJust (keyChunkSize k) && isJust (keyChunkNum k)+newtype HashSize = HashSize Int+	deriving (Eq, Ord, Read, Show) --- Checks if a string looks like at least the start of a key.-isKeyPrefix :: String -> Bool-isKeyPrefix s = [fieldSep, fieldSep] `isInfixOf` s+hasExt :: KeyVariety -> Bool+hasExt (SHA2Key _ (HasExt b)) = b+hasExt (SHA3Key _ (HasExt b)) = b+hasExt (SKEINKey _ (HasExt b)) = b+hasExt (SHA1Key (HasExt b)) = b+hasExt (MD5Key (HasExt b)) = b+hasExt WORMKey = False+hasExt URLKey = False+hasExt (OtherKey s) =  end s == "E" -fieldSep :: Char-fieldSep = '-'+sameExceptExt :: KeyVariety -> KeyVariety -> Bool+sameExceptExt (SHA2Key sz1 _) (SHA2Key sz2 _) = sz1 == sz2+sameExceptExt (SHA3Key sz1 _) (SHA3Key sz2 _) = sz1 == sz2+sameExceptExt (SKEINKey sz1 _) (SKEINKey sz2 _) = sz1 == sz2+sameExceptExt (SHA1Key _) (SHA1Key _) = True+sameExceptExt (MD5Key _) (MD5Key _) = True+sameExceptExt _ _ = False -{- Converts a key to a string that is suitable for use as a filename.- - The name field is always shown last, separated by doubled fieldSeps,- - and is the only field allowed to contain the fieldSep. -}-key2file :: Key -> FilePath-key2file Key { keyBackendName = b, keySize = s, keyMtime = m, keyChunkSize = cs, keyChunkNum = cn, keyName = n } =-	b +++ ('s' ?: s) +++ ('m' ?: m) +++ ('S' ?: cs) +++ ('C' ?: cn) +++ (fieldSep : n)-  where-	"" +++ y = y-	x +++ "" = x-	x +++ y = x ++ fieldSep:y-	f ?: (Just v) = f : show v-	_ ?: _ = ""+{- Is the Key variety cryptographically secure, such that no two differing+ - file contents can be mapped to the same Key? -}+cryptographicallySecure :: KeyVariety -> Bool+cryptographicallySecure (SHA2Key _ _) = True+cryptographicallySecure (SHA3Key _ _) = True+cryptographicallySecure (SKEINKey _ _) = True+cryptographicallySecure _ = False -file2key :: FilePath -> Maybe Key-file2key s-	| key == Just stubKey || (keyName <$> key) == Just "" || (keyBackendName <$> key) == Just "" = Nothing-	| otherwise = key+formatKeyVariety :: KeyVariety -> String+formatKeyVariety v = case v of+	SHA2Key sz e -> adde e (addsz sz "SHA")+	SHA3Key sz e -> adde e (addsz sz "SHA3_")+	SKEINKey sz e -> adde e (addsz sz "SKEIN")+	SHA1Key e -> adde e "SHA1"+	MD5Key e -> adde e "MD5"+	WORMKey -> "WORM"+	URLKey -> "URL"+	OtherKey s -> s   where-	key = startbackend stubKey s--	startbackend k v = sepfield k v addbackend-		-	sepfield k v a = case span (/= fieldSep) v of-		(v', _:r) -> findfields r $ a k v'-		_ -> Nothing--	findfields (c:v) (Just k)-		| c == fieldSep = Just $ k { keyName = v }-		| otherwise = sepfield k v $ addfield c-	findfields _ v = v--	addbackend k v = Just k { keyBackendName = v }-	addfield 's' k v = do-		sz <- readish v-		return $ k { keySize = Just sz }-	addfield 'm' k v = do-		mtime <- readish v-		return $ k { keyMtime = Just mtime }-	addfield 'S' k v = do-		chunksize <- readish v-		return $ k { keyChunkSize = Just chunksize }-	addfield 'C' k v = case readish v of-		Just chunknum | chunknum > 0 ->-			return $ k { keyChunkNum = Just chunknum }-		_ -> return k-	addfield _ _ _ = Nothing--instance ToJSON Key where-	toJSON = toJSON . key2file--instance FromJSON Key where-	parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t-	parseJSON _ = mempty--instance Proto.Serializable Key where-	serialize = key2file-	deserialize = file2key--instance Arbitrary Key where-	arbitrary = Key-		<$> (listOf1 $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "-_\r\n \t")-		<*> (listOf1 $ elements ['A'..'Z']) -- BACKEND-		<*> ((abs <$>) <$> arbitrary) -- size cannot be negative-		<*> arbitrary-		<*> ((abs <$>) <$> arbitrary) -- chunksize cannot be negative-		<*> ((succ . abs <$>) <$> arbitrary) -- chunknum cannot be 0 or negative--instance Hashable Key where-	hashIO32 = hashIO32 . key2file-	hashIO64 = hashIO64 . key2file--prop_isomorphic_key_encode :: Key -> Bool-prop_isomorphic_key_encode k = Just k == (file2key . key2file) k+	adde (HasExt False) s = s+	adde (HasExt True) s = s ++ "E"+	addsz (HashSize n) s =  s ++ show n -prop_isomorphic_key_decode :: FilePath -> Bool-prop_isomorphic_key_decode f-	| normalfieldorder = maybe True (\k -> key2file k == f) (file2key f)-	| otherwise = True-  where-	-- file2key will accept the fields in any order, so don't-	-- try the test unless the fields are in the normal order-	normalfieldorder = fields `isPrefixOf` "smSC"-	fields = map (f !!) $ filter (< length f) $ map succ $-		elemIndices fieldSep f+parseKeyVariety :: String -> KeyVariety+parseKeyVariety "SHA256"    =  SHA2Key (HashSize 256) (HasExt False)+parseKeyVariety "SHA256E"   = SHA2Key (HashSize 256) (HasExt True)+parseKeyVariety "SHA512"    = SHA2Key (HashSize 512) (HasExt False)+parseKeyVariety "SHA512E"   = SHA2Key (HashSize 512) (HasExt True)+parseKeyVariety "SHA224"    = SHA2Key (HashSize 224) (HasExt False)+parseKeyVariety "SHA224E"   = SHA2Key (HashSize 224) (HasExt True)+parseKeyVariety "SHA384"    = SHA2Key (HashSize 384) (HasExt False)+parseKeyVariety "SHA384E"   = SHA2Key (HashSize 384) (HasExt True)+parseKeyVariety "SHA3_512"  = SHA3Key (HashSize 512) (HasExt False)+parseKeyVariety "SHA3_512E" = SHA3Key (HashSize 512) (HasExt True)+parseKeyVariety "SHA3_384"  = SHA3Key (HashSize 384) (HasExt False)+parseKeyVariety "SHA3_384E" = SHA3Key (HashSize 384) (HasExt True)+parseKeyVariety "SHA3_256"  = SHA3Key (HashSize 256) (HasExt False)+parseKeyVariety "SHA3_256E" = SHA3Key (HashSize 256) (HasExt True)+parseKeyVariety "SHA3_224"  = SHA3Key (HashSize 224) (HasExt False)+parseKeyVariety "SHA3_224E" = SHA3Key (HashSize 224) (HasExt True)+parseKeyVariety "SKEIN512"  = SKEINKey (HashSize 512) (HasExt False)+parseKeyVariety "SKEIN512E" = SKEINKey (HashSize 512) (HasExt True)+parseKeyVariety "SKEIN256"  = SKEINKey (HashSize 256) (HasExt False)+parseKeyVariety "SKEIN256E" = SKEINKey (HashSize 256) (HasExt True)+parseKeyVariety "SHA1"      = SHA1Key (HasExt False)+parseKeyVariety "MD5"       = MD5Key (HasExt False)+parseKeyVariety "WORM"      = WORMKey+parseKeyVariety "URL"       = URLKey+parseKeyVariety s           = OtherKey s

@@ -16,8 +16,7 @@ import Control.Applicative import Prelude -{- Enough information to uniquely identify a transfer, used as the filename- - of the transfer information file. -}+{- Enough information to uniquely identify a transfer. -} data Transfer = Transfer 	{ transferDirection :: Direction 	, transferUUID :: UUID@@ -46,7 +45,16 @@ stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False  data Direction = Upload | Download-	deriving (Eq, Ord, Read, Show)+	deriving (Eq, Ord, Show, Read)++formatDirection :: Direction -> String+formatDirection Upload = "upload"+formatDirection Download = "download"++parseDirection :: String -> Maybe Direction+parseDirection "upload" = Just Upload+parseDirection "download" = Just Download+parseDirection _ = Nothing  instance Arbitrary TransferInfo where 	arbitrary = TransferInfo

@@ -14,6 +14,7 @@ import Annex.Common import Annex.Content import Annex.Link+import Types.Key import Logs.Presence import qualified Annex.Queue import qualified Git@@ -73,7 +74,7 @@ 		let d = parentDir f 		liftIO $ allowWrite d 		liftIO $ allowWrite f-		moveAnnex k f+		_ <- moveAnnex k f 		liftIO $ removeDirectory d  updateSymlinks :: Annex ()@@ -130,7 +131,7 @@   where 	len = length l - 4 	k = readKey1 (take len l)-	sane = (not . null $ keyName k) && (not . null $ keyBackendName k)+	sane = (not . null $ keyName k) && (not . null $ formatKeyVariety $ keyVariety k)  -- WORM backend keys: "WORM:mtime:size:filename" -- all the rest: "backend:key"@@ -143,7 +144,7 @@ 	| mixup = fromJust $ file2key $ intercalate ":" $ Prelude.tail bits 	| otherwise = stubKey 		{ keyName = n-		, keyBackendName = b+		, keyVariety = parseKeyVariety b 		, keySize = s 		, keyMtime = t 		}@@ -161,11 +162,12 @@ 	mixup = wormy && isUpper (Prelude.head $ bits !! 1)  showKey1 :: Key -> String-showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } =+showKey1 Key { keyName = n , keyVariety = v, keySize = s, keyMtime = t } = 	intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, n]   where 	showifhere Nothing = ""-	showifhere (Just v) = show v+	showifhere (Just x) = show x+	b = formatKeyVariety v  keyFile1 :: Key -> FilePath keyFile1 key = replace "/" "%" $ replace "%" "&s" $ replace "&" "&a"  $ showKey1 key@@ -189,7 +191,7 @@ 		Right l -> makekey l   where 	getsymlink = takeFileName <$> readSymbolicLink file-	makekey l = case maybeLookupBackendName bname of+	makekey l = case maybeLookupBackendVariety (keyVariety k) of 		Nothing -> do 			unless (null kname || null bname || 			        not (isLinkToAnnex l)) $@@ -198,7 +200,7 @@ 		Just backend -> return $ Just (k, backend) 	  where 		k = fileKey1 l-		bname = keyBackendName k+		bname = formatKeyVariety (keyVariety k) 		kname = keyName k 		skip = "skipping " ++ file ++  			" (unknown backend " ++ bname ++ ")"

@@ -4,20 +4,16 @@  - because of https://github.com/vincenthz/hs-cryptohash/issues/36  -} -{-# LANGUAGE CPP #-}- module Utility.Hash ( 	sha1, 	sha2_224, 	sha2_256, 	sha2_384, 	sha2_512,-#ifdef WITH_CRYPTONITE 	sha3_224, 	sha3_256, 	sha3_384, 	sha3_512,-#endif 	skein256, 	skein512, 	md5,@@ -31,12 +27,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString as S-#ifdef WITH_CRYPTONITE import "cryptonite" Crypto.MAC.HMAC import "cryptonite" Crypto.Hash-#else-import "cryptohash" Crypto.Hash-#endif  sha1 :: L.ByteString -> Digest SHA1 sha1 = hashlazy@@ -53,7 +45,6 @@ sha2_512 :: L.ByteString -> Digest SHA512 sha2_512 = hashlazy -#ifdef WITH_CRYPTONITE sha3_224 :: L.ByteString -> Digest SHA3_224 sha3_224 = hashlazy @@ -65,7 +56,6 @@  sha3_512 :: L.ByteString -> Digest SHA3_512 sha3_512 = hashlazy-#endif  skein256 :: L.ByteString -> Digest Skein256_256 skein256 = hashlazy@@ -86,12 +76,10 @@ 	, (show . sha2_512, "f7fbba6e0636f890e56fbbf3283e524c6fa3204ae298382d624741d0dc6638326e282c41be5e4254d8820772c5518a2c5a8c0c7f7eda19594a7eb539453e1ed7") 	, (show . skein256, "a04efd9a0aeed6ede40fe5ce0d9361ae7b7d88b524aa19917b9315f1ecf00d33") 	, (show . skein512, "fd8956898113510180aa4658e6c0ac85bd74fb47f4a4ba264a6b705d7a8e8526756e75aecda12cff4f1aca1a4c2830fbf57f458012a66b2b15a3dd7d251690a7")-#ifdef WITH_CRYPTONITE 	, (show . sha3_224, "f4f6779e153c391bbd29c95e72b0708e39d9166c7cea51d1f10ef58a") 	, (show . sha3_256, "76d3bc41c9f588f7fcd0d5bf4718f8f84b1c41b20882703100b9eb9413807c01") 	, (show . sha3_384, "665551928d13b7d84ee02734502b018d896a0fb87eed5adb4c87ba91bbd6489410e11b0fbcc06ed7d0ebad559e5d3bb5") 	, (show . sha3_512, "4bca2b137edc580fe50a88983ef860ebaca36c857b1f492839d6d7392452a63c82cbebc68e3b70a2a1480b4bb5d437a7cba6ecf9d89f9ff3ccd14cd6146ea7e7")-#endif 	, (show . md5, "acbd18db4cc2f85cedef654fccc4a4d8") 	]   where

@@ -174,22 +174,21 @@ -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)-processTranscript = processTranscript' id+processTranscript cmd opts = processTranscript' (proc cmd opts) -processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool)-processTranscript' modproc cmd opts input = do+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)+processTranscript' cp input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order  - the process writes them. -} 	(readf, writef) <- System.Posix.IO.createPipe 	readh <- System.Posix.IO.fdToHandle readf 	writeh <- System.Posix.IO.fdToHandle writef-	p@(_, _, _, pid) <- createProcess $ modproc $-		(proc cmd opts)-			{ std_in = if isJust input then CreatePipe else Inherit-			, std_out = UseHandle writeh-			, std_err = UseHandle writeh-			}+	p@(_, _, _, pid) <- createProcess $ cp+		{ std_in = if isJust input then CreatePipe else Inherit+		, std_out = UseHandle writeh+		, std_err = UseHandle writeh+		} 	hClose writeh  	get <- mkreader readh@@ -200,12 +199,11 @@ 	return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -}-	p@(_, _, _, pid) <- createProcess $ modproc $-		(proc cmd opts)-			{ std_in = if isJust input then CreatePipe else Inherit-			, std_out = CreatePipe-			, std_err = CreatePipe-			}+	p@(_, _, _, pid) <- createProcess $ cp+		{ std_in = if isJust input then CreatePipe else Inherit+		, std_out = CreatePipe+		, std_err = CreatePipe+		}  	getout <- mkreader (stdoutHandle p) 	geterr <- mkreader (stderrHandle p)

@@ -246,17 +246,16 @@ 		(requestHeaders r) 	} -{- Used to download large files, such as the contents of keys.+{- Download a perhaps large file, with auto-resume of incomplete downloads.  -- - Uses wget or curl program for its progress bar. (Wget has a better one,- - so is preferred.) Which program to use is determined at run time; it- - would not be appropriate to test at configure time and build support- - for only one in.+ - Uses wget or curl program for its progress bar and resuming support. + - Which program to use is determined at run time depending on which is+ - in path and which works best in a particular situation.  -} download :: URLString -> FilePath -> UrlOptions -> IO Bool download = download' False -{- No output, even on error. -}+{- No output to stdout. -} downloadQuiet :: URLString -> FilePath -> UrlOptions -> IO Bool downloadQuiet = download' True @@ -265,6 +264,12 @@ 	case parseURIRelaxed url of 		Just u 			| uriScheme u == "file:" -> curl+			-- curl is preferred in quiet mode, because+			-- it displays http errors to stderr, while wget+			-- does not display them in quiet mode+			| quiet -> ifM (inPath "curl") (curl, wget)+			-- wget is preferred mostly because it has a better+			-- progress bar 			| otherwise -> ifM (inPath "wget") (wget , curl) 		_ -> return False   where@@ -275,12 +280,13 @@ 	 - support, or need that option. 	 - 	 - When the wget version is new enough, pass options for-	 - a less cluttered download display.+	 - a less cluttered download display. Using -nv rather than -q+	 - avoids most clutter while still displaying http errors. 	 -} #ifndef __ANDROID__ 	wgetparams = concat-		[ if Build.SysConfig.wgetquietprogress && not quiet-			then [Param "-q", Param "--show-progress"]+		[ if Build.SysConfig.wgetunclutter && not quiet+			then [Param "-nv", Param "--show-progress"] 			else [] 		, [ Param "--clobber", Param "-c", Param "-O"] 		]@@ -296,8 +302,13 @@ 		-- curl does not create destination file 		-- if the url happens to be empty, so pre-create. 		writeFile file ""-		go "curl" $ headerparams ++ quietopt "-s" ++-			[Param "-f", Param "-L", Param "-C", Param "-", Param "-#", Param "-o"]+		go "curl" $ headerparams ++ quietopt "-sS" +++			[ Param "-f"+			, Param "-L"+			, Param "-C", Param "-"+			, Param "-#"+			, Param "-o"+			] 	 	{- Run wget in a temp directory because it has been buggy 	 - and overwritten files in the current directory, even though

@@ -95,6 +95,11 @@   Matches only files whose content is stored using the specified key-value   backend. +* `--securehash`++  Matches only files whose content is hashed using a cryptographically+  secure function. + * `--inallgroup=groupname`    Matches only files that git-annex believes are present in all repositories

@@ -12,10 +12,6 @@ that is done by the sync command, but without pushing or pulling any data. -One way to use this is to put `git annex merge` into a repository's-post-receive hook. Then any syncs to the repository will update its-working copy automatically.- # SEE ALSO  [[git-annex]](1)

@@ -96,6 +96,11 @@   Matches only files whose content is stored using the specified key-value   backend. +* `securehash`++  Matches only files whose content is hashed using a cryptographically+  secure function.+ * `inallgroup=groupname`    Matches only files that git-annex believes are present in all repositories

@@ -23,6 +23,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--ignore-submodules=when`++  This option is passed on to git status, see its man page for+  details.+ # SEE ALSO  [[git-annex]](1)

@@ -542,6 +542,13 @@      See [[git-annex-pre-commit]](1) for details. +* `post-receive`++  This is meant to be called from git's post-receive hook. `git annex init`+  automatically creates a post-receive hook using this.+  +  See [[git-annex-post-receive]](1) for details.+ * `lookupkey [file ...]`    Looks up key used for file.@@ -816,11 +823,26 @@  * `annex.backends` -  Space-separated list of names of the key-value backends to use.-  The first listed is used to store new files by default.+  Space-separated list of names of the key-value backends to use+  when adding new files to the repository.    This is overridden by annex annex.backend configuration in the   .gitattributes files.++* `annex.securehashesonly`++  Set to true to indicate that the repository should only use+  cryptographically secure hashes+  (SHA2, SHA3) and not insecure hashes (MD5, SHA1) for content.++  When this is set, the contents of files using cryptographically+  insecure hashes will not be allowed to be added to the repository.+  +  Also, git-annex fsck` will complain about any files present in+  the repository that use insecure hashes.+  +  To configure the behavior in new clones of the repository,+  this can be set in [[git-annex-config]].  * `annex.diskreserve` 

@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20170214+Version: 6.20170301 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -295,9 +295,6 @@   Description: Get Network.URI from the network-uri package   Default: True -Flag Cryptonite-  Description: Use the cryptonite library, instead of the older cryptohash- Flag Dbus   Description: Enable dbus support @@ -361,7 +358,9 @@    socks,    byteable,    stm-chans,-   securemem+   securemem,+   crypto-api,+   cryptonite   CC-Options: -Wall   GHC-Options: -Wall -fno-warn-tabs   Extensions: PackageImports@@ -382,12 +381,6 @@   else     Build-Depends: network (< 2.6), network (>= 2.4) -  if flag(Cryptonite)-    Build-Depends: cryptonite-    CPP-Options: -DWITH_CRYPTONITE-  else-    Build-Depends: cryptohash (>= 0.11.0)-   if (os(windows))     Build-Depends: Win32, Win32-extras, unix-compat (>= 0.4.1.3), setenv,       process (>= 1.3.0.0)@@ -397,8 +390,7 @@       Other-Modules: Utility.Touch.Old    if flag(TestSuite)-    Build-Depends: tasty (>= 0.7), tasty-hunit, tasty-quickcheck, tasty-rerun,-     crypto-api+    Build-Depends: tasty (>= 0.7), tasty-hunit, tasty-quickcheck, tasty-rerun     CPP-Options: -DWITH_TESTSUITE    if flag(S3)@@ -461,7 +453,6 @@      wai,      wai-extra,      blaze-builder,-     crypto-api,      clientsession,      template-haskell,      shakespeare (>= 2.0.0)@@ -538,6 +529,7 @@     Annex.Ssh     Annex.TaggedPush     Annex.Transfer+    Annex.UpdateInstead     Annex.UUID     Annex.Url     Annex.VariantFile@@ -743,6 +735,7 @@     Command.NotifyChanges     Command.NumCopies     Command.P2P+    Command.PostReceive     Command.PreCommit     Command.Proxy     Command.ReKey@@ -814,6 +807,7 @@     Git.Command     Git.Command.Batch     Git.Config+    Git.ConfigTypes     Git.Construct     Git.CurrentRepo     Git.DiffTree@@ -839,7 +833,6 @@     Git.Remote.Remove     Git.Repair     Git.Sha-    Git.SharedRepository     Git.Status     Git.Tree     Git.Types@@ -847,6 +840,7 @@     Git.UpdateIndex     Git.Url     Git.Version+    Key     Limit     Limit.Wanted     Logs

@@ -4,7 +4,6 @@     production: true     assistant: true     pairing: true-    cryptonite: true     network-uri: true     s3: true     testsuite: true