git-annex 6.20180112 → 6.20180227

raw patch · 64 files changed

+1016/−667 lines, 64 filesdep +vector

Dependencies added: vector

Files

• Annex.hs +2/−1
• Annex/Branch.hs +7/−5
• CHANGELOG +40/−0
• CmdLine/GitAnnex/Options.hs +50/−26
• Command.hs +3/−3
• Command/Add.hs +4/−3
• Command/AddUrl.hs +4/−2
• Command/Copy.hs +1/−1
• Command/Drop.hs +1/−1
• Command/DropKey.hs +1/−1
• Command/ExamineKey.hs +1/−1
• Command/Find.hs +2/−2
• Command/FindRef.hs +1/−1
• Command/Fix.hs +1/−1
• Command/Fsck.hs +31/−2
• Command/Get.hs +1/−1
• Command/Import.hs +5/−4
• Command/Info.hs +1/−1
• Command/Inprogress.hs +1/−1
• Command/List.hs +1/−1
• Command/Lock.hs +1/−1
• Command/Log.hs +1/−1
• Command/MetaData.hs +1/−1
• Command/Migrate.hs +1/−1
• Command/Mirror.hs +1/−1
• Command/Move.hs +1/−1
• Command/Status.hs +1/−1
• Command/Sync.hs +1/−1
• Command/Unannex.hs +1/−1
• Command/Unlock.hs +3/−2
• Command/Whereis.hs +1/−1
• Messages.hs +12/−3
• Messages/Internal.hs +29/−12
• Messages/JSON.hs +31/−2
• Messages/Progress.hs +8/−7
• Remote/External.hs +15/−1
• Remote/External/Types.hs +23/−3
• Test.hs +4/−505
• Test/Framework.hs +534/−0
• Types/GitConfig.hs +2/−0
• Types/Messages.hs +15/−2
• doc/git-annex-add.mdwn +5/−0
• doc/git-annex-addurl.mdwn +5/−0
• doc/git-annex-copy.mdwn +5/−0
• doc/git-annex-diffdriver.mdwn +10/−5
• doc/git-annex-drop.mdwn +5/−0
• doc/git-annex-dropkey.mdwn +5/−0
• doc/git-annex-examinekey.mdwn +5/−0
• doc/git-annex-find.mdwn +5/−0
• doc/git-annex-fsck.mdwn +5/−0
• doc/git-annex-get.mdwn +5/−0
• doc/git-annex-import.mdwn +5/−0
• doc/git-annex-info.mdwn +5/−0
• doc/git-annex-lock.mdwn +5/−0
• doc/git-annex-metadata.mdwn +5/−0
• doc/git-annex-mirror.mdwn +5/−0
• doc/git-annex-move.mdwn +5/−0
• doc/git-annex-preferred-content.mdwn +0/−2
• doc/git-annex-required.mdwn +6/−3
• doc/git-annex-status.mdwn +8/−3
• doc/git-annex-unlock.mdwn +5/−0
• doc/git-annex-whereis.mdwn +10/−5
• doc/git-annex.mdwn +13/−3
• git-annex.cabal +45/−41

@@ -275,7 +275,8 @@ {- Sets the type of output to emit. -} setOutput :: OutputType -> Annex () setOutput o = changeState $ \s ->-	s { output = (output s) { outputType = o } }+	let m = output s+	in s { output = m { outputType = adjustOutputType (outputType m) o } }  {- Checks if a flag was set. -} getFlag :: String -> Annex Bool

@@ -140,7 +140,13 @@  - Returns True if any refs were merged in, False otherwise.  -} updateTo :: [(Git.Sha, Git.Branch)] -> Annex Bool-updateTo pairs = do+updateTo pairs = ifM (annexMergeAnnexBranches <$> Annex.getGitConfig)+	( updateTo' pairs+	, return False+	)++updateTo' :: [(Git.Sha, Git.Branch)] -> Annex Bool+updateTo' pairs = do 	-- ensure branch exists, and get its current ref 	branchref <- getBranch 	dirty <- journalDirty@@ -163,10 +169,6 @@ 				 - a commit needs to be done. -} 				when dirty $ 					go branchref True [] jl-			{- Only needed for a while, to populate the-			 - newly added merged refs cache with already-			 - merged refs. Can be safely removed at any time. -}-			addMergedRefs unignoredrefs 		else lockJournal $ go branchref dirty tomerge 	return $ not $ null tomerge   where

@@ -1,3 +1,43 @@+git-annex (6.20180227) upstream; urgency=medium++  * inprogress: Avoid showing failures for files not in progress. +  * Added INFO to external special remote protocol.+  * Added EXTENSIONS to external special remote protocol.+  * datalad < 0.9.1 had a problem in its special remote protocol handling+    which is broken by EXTENSIONS. Make the debian git-annex package+    conflict with the problem version of datalad.+  * fsck: Warn when required content is not present in the repository that+    requires it.+  * Add gpg-agent to Build-Depends.+    Needed to run the test suite.+  * --json: When there are multiple lines of notes about a file, make the note+    field multiline, rather than the old behavior of only including the+    last line.+  * git-annex.cabal: Once more try to not build the assistant on the hurd,+    hopefully hackage finally recognises that OS.+  * Split Test.hs and avoid optimising it much, to need less memory to+    compile.+  * Fix behavior of --json-progress followed by --json, the latter option+    used to disable the former.+  * Added --json-error-messages option, which makes messages+    that would normally be output to standard error be included in+    the json output.+  * Remove temporary code added in 6.20160619 to prime the mergedrefs+    log.+  * importfeed: Fix a failure when downloading with youtube-dl+    and the destination subdirectory does not exist yet.+  * Added annex.merge-annex-branches config setting which+    can be used to disable automatic merge of git-annex branches.+  * tips/automatically_adding_metadata/pre-commit-annex: Fix to not+    silently skip filenames containing non-ascii characters.+  * sync: Fix bug that prevented pulling changes into direct mode+    repositories that were committed to remotes using git commit+    rather than git-annex sync.+  * Makefile: Remove chrpath workaround for bug in cabal, +    which is no longer needed.++ -- Joey Hess <id@joeyh.name>  Tue, 27 Feb 2018 12:04:52 -0400+ git-annex (6.20180112) upstream; urgency=medium    * Added inprogress command for accessing files as they are being

@@ -191,7 +191,7 @@ 	[ nonWorkTreeMatchingOptions' 	, fileMatchingOptions' 	, combiningOptions-	, [timeLimitOption]+	, timeLimitOption 	]  -- Matching options that don't need to examine work tree files.@@ -294,29 +294,51 @@ 	longopt o h = globalFlag (Limit.addToken o) ( long o <> help h <> hidden ) 	shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h <> hidden ) -jsonOption :: GlobalOption-jsonOption = globalFlag (Annex.setOutput (JSONOutput False))-	( long "json" <> short 'j'-	<> help "enable JSON output"-	<> hidden-	)+jsonOptions :: [GlobalOption]+jsonOptions = +	[ globalFlag (Annex.setOutput (JSONOutput stdjsonoptions))+		( long "json" <> short 'j'+		<> help "enable JSON output"+		<> hidden+		)+	, globalFlag (Annex.setOutput (JSONOutput jsonerrormessagesoptions))+		( long "json-error-messages"+		<> help "include error messages in JSON"+		<> hidden+		)+	]+  where+	stdjsonoptions = JSONOptions+		{ jsonProgress = False+		, jsonErrorMessages = False+		}+	jsonerrormessagesoptions = stdjsonoptions { jsonErrorMessages = True } -jsonProgressOption :: GlobalOption-jsonProgressOption = globalFlag (Annex.setOutput (JSONOutput True))-	( long "json-progress"-	<> help "include progress in JSON output"-	<> hidden-	)+jsonProgressOption :: [GlobalOption]+jsonProgressOption = +	[ globalFlag (Annex.setOutput (JSONOutput jsonoptions))+		( long "json-progress"+		<> help "include progress in JSON output"+		<> hidden+		)+	]+  where+	jsonoptions = JSONOptions+		{ jsonProgress = True+		, jsonErrorMessages = False+		}  -- Note that a command that adds this option should wrap its seek -- action in `allowConcurrentOutput`.-jobsOption :: GlobalOption-jobsOption = globalSetter set $ -	option auto-		( long "jobs" <> short 'J' <> metavar paramNumber-		<> help "enable concurrent jobs"-		<> hidden-		)+jobsOption :: [GlobalOption]+jobsOption = +	[ globalSetter set $ +		option auto+			( long "jobs" <> short 'J' <> metavar paramNumber+			<> help "enable concurrent jobs"+			<> hidden+			)+	]   where 	set n = do 		Annex.changeState $ \s -> s { Annex.concurrency = Concurrent n }@@ -324,12 +346,14 @@ 		when (n > c) $ 			liftIO $ setNumCapabilities n -timeLimitOption :: GlobalOption-timeLimitOption = globalSetter Limit.addTimeLimit $ strOption-	( long "time-limit" <> short 'T' <> metavar paramTime-	<> help "stop after the specified amount of time"-	<> hidden-	)+timeLimitOption :: [GlobalOption]+timeLimitOption = +	[ globalSetter Limit.addTimeLimit $ strOption+		( long "time-limit" <> short 'T' <> metavar paramTime+		<> help "stop after the specified amount of time"+		<> hidden+		)+	]  data DaemonOptions = DaemonOptions 	{ foregroundDaemonOption :: Bool

@@ -79,9 +79,9 @@ noRepo :: (String -> Parser (IO ())) -> Command -> Command noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) } -{- Adds global options to a command's. -}-withGlobalOptions :: [GlobalOption] -> Command -> Command-withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ os }+{- Adds global options to a command. -}+withGlobalOptions :: [[GlobalOption]] -> Command -> Command+withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os }  {- For start and perform stages to indicate what step to run next. -} next :: a -> Annex (Maybe a)

@@ -22,9 +22,10 @@ import Git.FilePath  cmd :: Command-cmd = notBareRepo $ withGlobalOptions (jobsOption : jsonOption : fileMatchingOptions) $-	command "add" SectionCommon "add files to annex"-		paramPaths (seek <$$> optParser)+cmd = notBareRepo $ +	withGlobalOptions [jobsOption, jsonOptions, fileMatchingOptions] $+		command "add" SectionCommon "add files to annex"+			paramPaths (seek <$$> optParser)  data AddOptions = AddOptions 	{ addThese :: CmdParams

@@ -34,7 +34,7 @@ import qualified Annex.Transfer as Transfer  cmd :: Command-cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOption, jsonProgressOption] $+cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $ 	command "addurl" SectionCommon "add urls to annex" 		(paramRepeating paramUrl) (seek <$$> optParser) @@ -370,7 +370,9 @@ 	Nothing -> go 	Just tmp -> do 		-- Move to final location for large file check.-		pruneTmpWorkDirBefore tmp (\_ -> liftIO $ renameFile tmp file)+		pruneTmpWorkDirBefore tmp $ \_ -> liftIO $ do+			createDirectoryIfMissing True (takeDirectory file)+			renameFile tmp file 		largematcher <- largeFilesMatcher 		large <- checkFileMatcher largematcher file 		if large

@@ -14,7 +14,7 @@ import Annex.NumCopies  cmd :: Command-cmd = withGlobalOptions (jobsOption : jsonOption : jsonProgressOption : annexedMatchingOptions) $+cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ 	command "copy" SectionCommon 		"copy content of files to/from another repository" 		paramPaths (seek <--< optParser)

@@ -23,7 +23,7 @@ import qualified Data.Set as S  cmd :: Command-cmd = withGlobalOptions (jobsOption : jsonOption : annexedMatchingOptions) $+cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ 	command "drop" SectionCommon 		"remove content of files from repository" 		paramPaths (seek <$$> optParser)

@@ -13,7 +13,7 @@ import Annex.Content  cmd :: Command-cmd = noCommit $ withGlobalOptions [jsonOption] $+cmd = noCommit $ withGlobalOptions [jsonOptions] $ 	command "dropkey" SectionPlumbing 		"drops annexed content for specified keys" 		(paramRepeating paramKey)

@@ -13,7 +13,7 @@  cmd :: Command cmd = noCommit $ noMessages $ dontCheck repoExists $ -	withGlobalOptions [jsonOption] $+	withGlobalOptions [jsonOptions] $ 		command "examinekey" SectionPlumbing  			"prints information from a key" 			(paramRepeating paramKey)

@@ -18,12 +18,12 @@ import Utility.DataUnits  cmd :: Command-cmd = withGlobalOptions annexedMatchingOptions $ mkCommand $+cmd = withGlobalOptions [annexedMatchingOptions] $ mkCommand $ 	command "find" SectionQuery "lists available files" 		paramPaths (seek <$$> optParser)  mkCommand :: Command -> Command-mkCommand = noCommit . noMessages . withGlobalOptions [jsonOption]+mkCommand = noCommit . noMessages . withGlobalOptions [jsonOptions]  data FindOptions = FindOptions 	{ findThese :: CmdParams

@@ -12,7 +12,7 @@ import qualified Git  cmd :: Command-cmd = withGlobalOptions nonWorkTreeMatchingOptions $ Find.mkCommand $ +cmd = withGlobalOptions [nonWorkTreeMatchingOptions] $ Find.mkCommand $  	command "findref" SectionPlumbing 		"lists files in a git ref" 		paramRef (seek <$$> Find.optParser)

@@ -23,7 +23,7 @@ #endif  cmd :: Command-cmd = notDirect $ noCommit $ withGlobalOptions annexedMatchingOptions $+cmd = notDirect $ noCommit $ withGlobalOptions [annexedMatchingOptions] $ 	command "fix" SectionMaintenance 		"fix up links to annexed content" 		paramPaths (withParams seek)

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -23,6 +23,7 @@ import Logs.Trust import Logs.Activity import Logs.TimeStamp+import Logs.PreferredContent import Annex.NumCopies import Annex.UUID import Annex.ReplaceFile@@ -40,9 +41,11 @@  import Data.Time.Clock.POSIX import System.Posix.Types (EpochTime)+import qualified Data.Set as S+import qualified Data.Map as M  cmd :: Command-cmd = withGlobalOptions (jobsOption : jsonOption : annexedMatchingOptions) $+cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ 	command "fsck" SectionMaintenance 		"find and fix problems" 		paramPaths (seek <$$> optParser)@@ -121,6 +124,7 @@ 		-- order matters 		[ fixLink key file 		, verifyLocationLog key keystatus ai+		, verifyRequiredContent key ai 		, verifyAssociatedFiles key keystatus file 		, verifyWorkTree key file 		, checkKeySize key keystatus ai@@ -151,6 +155,7 @@ 	dispatch (Right False) = go False Nothing 	go present localcopy = check 		[ verifyLocationLogRemote key ai remote present+		, verifyRequiredContent key ai 		, withLocalCopy localcopy $ checkKeySizeRemote key remote ai 		, withLocalCopy localcopy $ checkBackendRemote backend key remote ai 		, checkKeyNumCopies key afile numcopies@@ -285,6 +290,30 @@ 	fix s = do 		showNote "fixing location log" 		updatestatus s++{- Verifies that all repos that are required to contain the content do,+ - checking against the location log. -}+verifyRequiredContent :: Key -> ActionItem -> Annex Bool+verifyRequiredContent key ai@(ActionItemAssociatedFile afile) = do+	requiredlocs <- S.fromList . M.keys <$> requiredContentMap+	if S.null requiredlocs+		then return True+		else do+			presentlocs <- S.fromList <$> loggedLocations key+			missinglocs <- filterM+				(\u -> isRequiredContent (Just u) S.empty (Just key) afile False)+				(S.toList $ S.difference requiredlocs presentlocs)+			if null missinglocs+				then return True+				else do+					missingrequired <- Remote.prettyPrintUUIDs "missingrequired" missinglocs+					warning $+						"** Required content " +++						actionItemDesc ai key +++						" is missing from these repositories:\n" +++						missingrequired+					return False+verifyRequiredContent _ _ = return True  {- Verifies the associated file records. -} verifyAssociatedFiles :: Key -> KeyStatus -> FilePath -> Annex Bool

@@ -16,7 +16,7 @@ import qualified Command.Move  cmd :: Command-cmd = withGlobalOptions (jobsOption : jsonOption : jsonProgressOption : annexedMatchingOptions) $ +cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $  	command "get" SectionCommon  		"make content of annexed files available" 		paramPaths (seek <$$> optParser)

@@ -24,10 +24,11 @@ import Logs.Location  cmd :: Command-cmd = withGlobalOptions (jobsOption : jsonOption : fileMatchingOptions) $ notBareRepo $-	command "import" SectionCommon -		"move and add files from outside git working copy"-		paramPaths (seek <$$> optParser)+cmd = notBareRepo $+	withGlobalOptions [jobsOption, jsonOptions, fileMatchingOptions] $+		command "import" SectionCommon +			"move and add files from outside git working copy"+			paramPaths (seek <$$> optParser)  data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates | ReinjectDuplicates 	deriving (Eq)

@@ -84,7 +84,7 @@ type StatState = StateT StatInfo Annex  cmd :: Command-cmd = noCommit $ withGlobalOptions (jsonOption : annexedMatchingOptions) $+cmd = noCommit $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $ 	command "info" SectionQuery 		"shows  information about the specified item or the repository as a whole" 		(paramRepeating paramItem) (seek <$$> optParser)

@@ -57,4 +57,4 @@ 		)  notInprogress :: CommandStart-notInprogress = next stop+notInprogress = stop

@@ -22,7 +22,7 @@ import Utility.Tuple  cmd :: Command-cmd = noCommit $ withGlobalOptions annexedMatchingOptions $+cmd = noCommit $ withGlobalOptions [annexedMatchingOptions] $ 	command "list" SectionQuery  		"show which remotes contain files" 		paramPaths (seek <$$> optParser)

@@ -23,7 +23,7 @@ import Git.FilePath 	 cmd :: Command-cmd = notDirect $ withGlobalOptions (jsonOption : annexedMatchingOptions) $+cmd = notDirect $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $ 	command "lock" SectionCommon 		"undo unlock command" 		paramPaths (withParams seek)

@@ -40,7 +40,7 @@ type Outputter = LogChange -> POSIXTime -> [UUID] -> Annex ()  cmd :: Command-cmd = withGlobalOptions annexedMatchingOptions $+cmd = withGlobalOptions [annexedMatchingOptions] $ 	command "log" SectionQuery "shows location log" 		paramPaths (seek <$$> optParser) 

@@ -23,7 +23,7 @@ import Control.Concurrent  cmd :: Command-cmd = withGlobalOptions ([jsonOption] ++ annexedMatchingOptions) $ +cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $  	command "metadata" SectionMetaData 		"sets or gets metadata of a file" 		paramPaths (seek <$$> optParser)

@@ -20,7 +20,7 @@ import qualified Remote  cmd :: Command-cmd = notDirect $ withGlobalOptions annexedMatchingOptions $+cmd = notDirect $ withGlobalOptions [annexedMatchingOptions] $ 	command "migrate" SectionUtility  		"switch data to different backend" 		paramPaths (withParams seek)

@@ -17,7 +17,7 @@ import Types.Transfer  cmd :: Command-cmd = withGlobalOptions (jobsOption : jsonOption : jsonProgressOption : annexedMatchingOptions) $+cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ 	command "mirror" SectionCommon  		"mirror content of files to/from another repository" 		paramPaths (seek <--< optParser)

@@ -20,7 +20,7 @@ import System.Log.Logger (debugM)  cmd :: Command-cmd = withGlobalOptions (jobsOption : jsonOption : jsonProgressOption : annexedMatchingOptions) $+cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ 	command "move" SectionCommon 		"move content of files to/from another repository" 		paramPaths (seek <--< optParser)

@@ -17,7 +17,7 @@  cmd :: Command cmd = notBareRepo $ noCommit $ noMessages $-	withGlobalOptions [jsonOption] $+	withGlobalOptions [jsonOptions] $ 		command "status" SectionCommon 			"show the working tree status" 			paramPaths (seek <$$> optParser)

@@ -434,7 +434,7 @@ 		(mapM (merge currbranch mergeconfig resolvemergeoverride Git.Branch.ManualCommit . remoteBranch remote) =<< getlist) 	tomerge = filterM (changed remote) 	branchlist Nothing = []-	branchlist (Just branch) = [branch, syncBranch branch]+	branchlist (Just branch) = [fromDirectBranch (fromAdjustedBranch branch), syncBranch branch]  pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart pushRemote _o _remote (Nothing, _) = stop

@@ -24,7 +24,7 @@ import Git.FilePath  cmd :: Command-cmd = withGlobalOptions annexedMatchingOptions $+cmd = withGlobalOptions [annexedMatchingOptions] $ 	command "unannex" SectionUtility 		"undo accidental add command" 		paramPaths (withParams seek)

@@ -26,8 +26,9 @@ editcmd = mkcmd "edit" "same as unlock"  mkcmd :: String -> String -> Command-mkcmd n d = notDirect $ withGlobalOptions (jsonOption : annexedMatchingOptions) $-	command n SectionCommon d paramPaths (withParams seek)+mkcmd n d = notDirect $ +	withGlobalOptions [jsonOptions, annexedMatchingOptions] $+		command n SectionCommon d paramPaths (withParams seek)  seek :: CmdParams -> CommandSeek seek ps = withFilesInGit (whenAnnexed start) =<< workTreeItems ps

@@ -17,7 +17,7 @@ import qualified Data.Map as M  cmd :: Command-cmd = noCommit $ withGlobalOptions (jsonOption : annexedMatchingOptions) $+cmd = noCommit $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $ 	command "whereis" SectionQuery 		"lists repositories that have file content" 		paramPaths (seek <$$> optParser)

@@ -19,6 +19,7 @@ 	showStoringStateAction, 	showOutput, 	showLongNote,+	showInfo, 	showEndOk, 	showEndFail, 	showEndResult,@@ -123,8 +124,16 @@ 	outputMessage JSON.none "\n"  showLongNote :: String -> Annex ()-showLongNote s = outputMessage (JSON.note s) ('\n' : indent s ++ "\n")+showLongNote s = outputMessage (JSON.note s) (formatLongNote s) +formatLongNote :: String -> String+formatLongNote s = '\n' : indent s ++ "\n"++-- Used by external special remote, displayed same as showLongNote+-- to console, but json object containing the info is emitted immediately.+showInfo :: String -> Annex ()+showInfo s = outputMessage' outputJSON (JSON.info s) (formatLongNote s)+ showEndOk :: Annex () showEndOk = showEndResult True @@ -165,11 +174,11 @@  {- Shows a JSON chunk only when in json mode. -} maybeShowJSON :: JSON.JSONChunk v -> Annex ()-maybeShowJSON v = void $ withMessageState $ outputJSON (JSON.add v)+maybeShowJSON v = void $ withMessageState $ bufferJSON (JSON.add v)  {- Shows a complete JSON value, only when in json mode. -} showFullJSON :: JSON.JSONChunk v -> Annex Bool-showFullJSON v = withMessageState $ outputJSON (JSON.complete v)+showFullJSON v = withMessageState $ bufferJSON (JSON.complete v)  {- Performs an action that outputs nonstandard/customized output, and  - in JSON mode wraps its output in JSON.start and JSON.end, so it's

@@ -1,6 +1,6 @@ {- git-annex output messages, including concurrent output to display regions  -- - Copyright 2010-2016 Joey Hess <id@joeyh.name>+ - Copyright 2010-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -11,27 +11,31 @@ import Annex import Types.Messages import Messages.Concurrent-import Messages.JSON+import qualified Messages.JSON as JSON+import Messages.JSON (JSONBuilder)  withMessageState :: (MessageState -> Annex a) -> Annex a withMessageState a = Annex.getState Annex.output >>= a  outputMessage :: JSONBuilder -> String -> Annex ()-outputMessage jsonbuilder msg = withMessageState $ \s -> case outputType s of+outputMessage = outputMessage' bufferJSON++outputMessage' :: (JSONBuilder -> MessageState -> Annex Bool) -> JSONBuilder -> String -> Annex ()+outputMessage' jsonoutputter jsonbuilder msg = withMessageState $ \s -> case outputType s of 	NormalOutput 		| concurrentOutputEnabled s -> concurrentMessage s False msg q 		| otherwise -> liftIO $ flushed $ putStr msg-	JSONOutput _ -> void $ outputJSON jsonbuilder s+	JSONOutput _ -> void $ jsonoutputter jsonbuilder s 	QuietOutput -> q  -- Buffer changes to JSON until end is reached and then emit it.-outputJSON :: JSONBuilder -> MessageState -> Annex Bool-outputJSON jsonbuilder s = case outputType s of-	JSONOutput _+bufferJSON :: JSONBuilder -> MessageState -> Annex Bool+bufferJSON jsonbuilder s = case outputType s of+	JSONOutput jsonoptions 		| endjson -> do 			Annex.changeState $ \st ->  				st { Annex.output = s { jsonBuffer = Nothing } }-			maybe noop (liftIO . flushed . emit) json+			maybe noop (liftIO . flushed . JSON.emit . JSON.finalize jsonoptions) json 			return True 		| otherwise -> do 			Annex.changeState $ \st ->@@ -46,11 +50,24 @@ 		Nothing -> Nothing 		Just b -> Just (b, False) +-- Immediately output JSON.+outputJSON :: JSONBuilder -> MessageState -> Annex Bool+outputJSON jsonbuilder s = case outputType s of+	JSONOutput _ -> do+		maybe noop (liftIO . flushed . JSON.emit)+			(fst <$> jsonbuilder Nothing)+		return True+	_ -> return False+ outputError :: String -> Annex ()-outputError msg = withMessageState $ \s ->-	if concurrentOutputEnabled s-		then concurrentMessage s True msg go-		else go+outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of+        (JSONOutput jsonoptions, Just jb) | jsonErrorMessages jsonoptions ->+		let jb' = Just (JSON.addErrorMessage (lines msg) jb)+		in Annex.changeState $ \st ->+			st { Annex.output = s { jsonBuffer = jb' } }+	_+		| concurrentOutputEnabled s -> concurrentMessage s True msg go+		| otherwise -> go   where 	go = liftIO $ do 		hFlush stdout

@@ -1,6 +1,6 @@ {- git-annex command-line JSON output and input  -- - Copyright 2011-2016 Joey Hess <id@joeyh.name>+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -14,7 +14,10 @@ 	none, 	start, 	end,+	finalize,+	addErrorMessage, 	note,+	info, 	add, 	complete, 	progress,@@ -27,6 +30,7 @@ import Control.Applicative import qualified Data.Map as M import qualified Data.Text as T+import qualified Data.Vector as V import qualified Data.ByteString.Lazy as B import qualified Data.HashMap.Strict as HM import System.IO@@ -36,6 +40,7 @@ import Data.Monoid import Prelude +import Types.Messages import Key import Utility.Metered import Utility.Percentage@@ -73,9 +78,33 @@ end b (Just (o, _)) = Just (HM.insert "success" (toJSON b) o, True) end _ Nothing = Nothing +finalize :: JSONOptions -> Object -> Object+finalize jsonoptions o+	-- Always include error-messages field, even if empty,+	-- to make the json be self-documenting.+	| jsonErrorMessages jsonoptions = addErrorMessage [] o+	| otherwise = o++addErrorMessage :: [String] -> Object -> Object+addErrorMessage msg o =+	HM.insertWith combinearray "error-messages" v o+  where+	combinearray (Array new) (Array old) = Array (old <> new)+	combinearray new _old = new+	v = Array $ V.fromList $ map (String . T.pack) msg+ note :: String -> JSONBuilder-note s (Just (o, e)) = Just (HM.insert "note" (toJSON s) o, e) note _ Nothing = Nothing+note s (Just (o, e)) = Just (HM.insertWith combinelines "note" (toJSON s) o, e)+  where+	combinelines (String new) (String old) =+		String (old <> T.pack "\n" <> new)+	combinelines new _old = new++info :: String -> JSONBuilder+info s _ = Just (o, True)+  where+	Object o = object ["info" .= toJSON s]  data JSONChunk v where 	AesonObject :: Object -> JSONChunk Object

@@ -55,12 +55,13 @@ #else 		nometer #endif-	go _ (MessageState { outputType = JSONOutput False }) = nometer-	go msize (MessageState { outputType = JSONOutput True }) = do-		buf <- withMessageState $ return . jsonBuffer-		m <- liftIO $ rateLimitMeterUpdate 0.1 msize $-			JSON.progress buf msize-		a (combinemeter m)+	go msize (MessageState { outputType = JSONOutput jsonoptions })+		| jsonProgress jsonoptions = do+			buf <- withMessageState $ return . jsonBuffer+			m <- liftIO $ rateLimitMeterUpdate 0.1 msize $+				JSON.progress buf msize+			a (combinemeter m)+		| otherwise = nometer  	nometer = a $ combinemeter (const noop) @@ -96,7 +97,7 @@  needOutputMeter :: MessageState -> Bool needOutputMeter s = case outputType s of-	JSONOutput True -> True+	JSONOutput jsonoptions -> jsonProgress jsonoptions 	NormalOutput | concurrentOutputEnabled s -> True 	_ -> False 

@@ -421,6 +421,7 @@ 		mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix 		send (VALUE "") -- end of list 	handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg+	handleRemoteRequest (INFO msg) = showInfo msg 	handleRemoteRequest (VERSION _) = 		sendMessage st external (ERROR "too late to send VERSION") @@ -504,7 +505,8 @@ 	 	dealloc st = liftIO $ atomically $ modifyTVar' v (st:) -{- Starts an external remote process running, and checks VERSION. -}+{- Starts an external remote process running, and checks VERSION and+ - exchanges EXTENSIONS. -} startExternal :: External -> Annex ExternalState startExternal external = do 	errrelayer <- mkStderrRelayer@@ -512,6 +514,18 @@ 	receiveMessage st external 		(const Nothing) 		(checkVersion st external)+		(const Nothing)+	sendMessage st external (EXTENSIONS supportedExtensionList)+	-- It responds with a EXTENSIONS_RESPONSE; that extensions list+	-- is reserved for future expansion. UNSUPPORTED_REQUEST is also+	-- accepted.+	receiveMessage st external+		(\resp -> case resp of+			EXTENSIONS_RESPONSE _ -> Just (return ())+			UNSUPPORTED_REQUEST -> Just (return ())+			_ -> Nothing+		)+		(const Nothing) 		(const Nothing) 	return st   where

@@ -1,6 +1,6 @@ {- External special remote data types.  -- - Copyright 2013 Joey Hess <id@joeyh.name>+ - Copyright 2013-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -14,6 +14,7 @@ 	ExternalType, 	ExternalState(..), 	PrepareStatus(..),+	supportedExtensionList, 	Proto.parseMessage, 	Proto.Sendable(..), 	Proto.Receivable(..),@@ -80,6 +81,14 @@  type PID = Int +-- List of extensions to the protocol.+newtype ExtensionList = ExtensionList [String]+	deriving (Show)++-- When adding a new RemoteRequest, also add it to the list here.+supportedExtensionList :: ExtensionList+supportedExtensionList = ExtensionList ["INFO"]+ data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg  -- The protocol does not support keys with spaces in their names;@@ -107,7 +116,8 @@  -- Messages that can be sent to the external remote to request it do something. data Request -	= PREPARE +	= EXTENSIONS ExtensionList+	| PREPARE 	| INITREMOTE 	| GETCOST 	| GETAVAILABILITY@@ -129,11 +139,13 @@ -- Does PREPARE need to have been sent before this request? needsPREPARE :: Request -> Bool needsPREPARE PREPARE = False+needsPREPARE (EXTENSIONS _) = False needsPREPARE INITREMOTE = False needsPREPARE EXPORTSUPPORTED = False needsPREPARE _ = True  instance Proto.Sendable Request where+	formatMessage (EXTENSIONS l) = ["EXTENSIONS", Proto.serialize l] 	formatMessage PREPARE = ["PREPARE"] 	formatMessage INITREMOTE = ["INITREMOTE"] 	formatMessage GETCOST = ["GETCOST"]@@ -172,7 +184,8 @@  -- Responses the external remote can make to requests. data Response-	= PREPARE_SUCCESS+	= EXTENSIONS_RESPONSE ExtensionList+	| PREPARE_SUCCESS 	| PREPARE_FAILURE ErrorMsg 	| TRANSFER_SUCCESS Direction Key 	| TRANSFER_FAILURE Direction Key ErrorMsg@@ -202,6 +215,7 @@ 	deriving (Show)  instance Proto.Receivable Response where+	parseCommand "EXTENSIONS" = Proto.parse1 EXTENSIONS_RESPONSE 	parseCommand "PREPARE-SUCCESS" = Proto.parse0 PREPARE_SUCCESS 	parseCommand "PREPARE-FAILURE" = Proto.parse1 PREPARE_FAILURE 	parseCommand "TRANSFER-SUCCESS" = Proto.parse2 TRANSFER_SUCCESS@@ -253,6 +267,7 @@ 	| SETURIMISSING Key URI 	| GETURLS Key String 	| DEBUG String+	| INFO String 	deriving (Show)  instance Proto.Receivable RemoteRequest where@@ -276,6 +291,7 @@ 	parseCommand "SETURIMISSING" = Proto.parse2 SETURIMISSING 	parseCommand "GETURLS" = Proto.parse2 GETURLS 	parseCommand "DEBUG" = Proto.parse1 DEBUG+	parseCommand "INFO" = Proto.parse1 INFO 	parseCommand _ = Proto.parseFail  -- Responses to RemoteRequest.@@ -364,3 +380,7 @@ instance Proto.Serializable ExportDirectory where 	serialize = fromExportDirectory 	deserialize = Just . mkExportDirectory++instance Proto.Serializable ExtensionList where+	serialize (ExtensionList l) = unwords l+	deserialize = Just . ExtensionList . words

@@ -6,10 +6,13 @@  -}  {-# LANGUAGE CPP #-}+{- Avoid optimising this file much, since it's large and does not need it._-}+{-# OPTIONS_GHC -O1 -optlo-O2 #-}  module Test where  import Types.Test+import Test.Framework import Options.Applicative.Types  import Test.Tasty@@ -29,12 +32,8 @@  import qualified Utility.SafeCommand import qualified Annex-import qualified Annex.UUID import qualified Annex.Version-import qualified Backend-import qualified Git.CurrentRepo import qualified Git.Filename-import qualified Git.Construct import qualified Git.Types import qualified Git.Ref import qualified Git.LsTree@@ -43,8 +42,6 @@ #ifndef mingw32_HOST_OS import qualified Types.GitConfig #endif-import qualified Types.KeySource-import qualified Types.Backend import qualified Types.TrustLevel import qualified Types import qualified Logs.MapLog@@ -57,14 +54,11 @@ import qualified Types.MetaData import qualified Remote import qualified Key-import qualified Types.Key-import qualified Types.Messages import qualified Config import qualified Config.Cost import qualified Crypto import qualified Database.Keys import qualified Annex.WorkTree-import qualified Annex.Link import qualified Annex.Init import qualified Annex.CatFile import qualified Annex.Path@@ -72,7 +66,6 @@ import qualified Annex.VectorClock import qualified Annex.View import qualified Annex.View.ViewedFile-import qualified Annex.Action import qualified Logs.View import qualified Utility.Path import qualified Utility.FileMode@@ -85,17 +78,13 @@ import qualified Utility.Env import qualified Utility.Env.Set import qualified Utility.Matcher-import qualified Utility.Exception import qualified Utility.Hash import qualified Utility.Scheduled import qualified Utility.Scheduled.QuickCheck import qualified Utility.HumanTime-import qualified Utility.ThreadScheduler import qualified Utility.Base64 import qualified Utility.Tmp.Dir import qualified Utility.FileSystemEncoding-import qualified Command.Uninit-import qualified CmdLine.GitAnnex as GitAnnex #ifndef mingw32_HOST_OS import qualified Remote.Helper.Encryptable import qualified Types.Crypto@@ -158,7 +147,7 @@  tests :: Bool -> TestOptions -> TestTree tests crippledfilesystem opts = testGroup "Tests" $ properties :-	map (\(d, te) -> withTestMode te (unitTests d)) testmodes+	map (\(d, te) -> withTestMode te initTests (unitTests d)) testmodes   where 	testmodes = catMaybes 		[ Just ("v6 unlocked", (testMode opts "6") { unlockedFiles = True })@@ -1734,493 +1723,3 @@ 	let dest = "addurlurldest" 	git_annex "addurl" ["--file", dest, url] @? ("addurl failed on " ++ url ++ "  with --file") 	doesFileExist dest @? (dest ++ " missing after addurl --file")---- This is equivilant to running git-annex, but it's all run in-process--- so test coverage collection works.-git_annex :: String -> [String] -> IO Bool-git_annex command params = do-	-- catch all errors, including normally fatal errors-	r <- try run ::IO (Either SomeException ())-	case r of-		Right _ -> return True-		Left _ -> return False-  where-	run = GitAnnex.run optParser Nothing (command:"-q":params)--{- Runs git-annex and returns its output. -}-git_annex_output :: String -> [String] -> IO String-git_annex_output command params = do-	pp <- Annex.Path.programPath-	got <- Utility.Process.readProcess pp (command:params)-	-- Since the above is a separate process, code coverage stats are-	-- not gathered for things run in it.-	-- Run same command again, to get code coverage.-	_ <- git_annex command params-	return got--git_annex_expectoutput :: String -> [String] -> [String] -> IO ()-git_annex_expectoutput command params expected = do-	got <- lines <$> git_annex_output command params-	got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected)---- Runs an action in the current annex. Note that shutdown actions--- are not run; this should only be used for actions that query state.-annexeval :: Types.Annex a -> IO a-annexeval a = do-	s <- Annex.new =<< Git.CurrentRepo.get-	Annex.eval s $ do-		Annex.setOutput Types.Messages.QuietOutput-		a `finally` Annex.Action.stopCoProcesses--innewrepo :: Assertion -> Assertion-innewrepo a = withgitrepo $ \r -> indir r a--inmainrepo :: Assertion -> Assertion-inmainrepo = indir mainrepodir--with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)-with_ssh_origin cloner a = cloner $ do-	origindir <- absPath-		=<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null")-	let originurl = "localhost:" ++ origindir-	boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"-	a-  where-	config = "remote.origin.url"--intmpclonerepo :: Assertion -> Assertion-intmpclonerepo a = withtmpclonerepo $ \r -> indir r a--intmpclonerepoInDirect :: Assertion -> Assertion-intmpclonerepoInDirect a = intmpclonerepo $-	ifM isdirect-		( putStrLn "not supported in direct mode; skipping"-		, a-		)-  where-	isdirect = annexeval $ do-		Annex.Init.initialize (Annex.Init.AutoInit False) Nothing Nothing-		Config.isDirect--checkRepo :: Types.Annex a -> FilePath -> IO a-checkRepo getval d = do-	s <- Annex.new =<< Git.Construct.fromPath d-	Annex.eval s $-		getval `finally` Annex.Action.stopCoProcesses--isInDirect :: FilePath -> IO Bool-isInDirect = checkRepo (not <$> Config.isDirect)--intmpbareclonerepo :: Assertion -> Assertion-intmpbareclonerepo a = withtmpclonerepo' (newCloneRepoConfig { bareClone = True } ) $-	\r -> indir r a--intmpsharedclonerepo :: Assertion -> Assertion-intmpsharedclonerepo a = withtmpclonerepo' (newCloneRepoConfig { sharedClone = True } ) $-	\r -> indir r a--withtmpclonerepo :: (FilePath -> Assertion) -> Assertion-withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig--withtmpclonerepo' :: CloneRepoConfig -> (FilePath -> Assertion) -> Assertion-withtmpclonerepo' cfg a = do-	dir <- tmprepodir-	clone <- clonerepo mainrepodir dir cfg-	r <- tryNonAsync (a clone)-	case r of-		Right () -> return ()-		Left e -> do-			whenM (keepFailures <$> getTestMode) $-				putStrLn $ "** Preserving repo for failure analysis in " ++ clone-			throwM e--disconnectOrigin :: Assertion-disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm"--withgitrepo :: (FilePath -> Assertion) -> Assertion-withgitrepo = bracket (setuprepo mainrepodir) return--indir :: FilePath -> Assertion -> Assertion-indir dir a = do-	currdir <- getCurrentDirectory-	-- Assertion failures throw non-IO errors; catch-	-- any type of error and change back to currdir before-	-- rethrowing.-	r <- bracket_ (changeToTmpDir dir) (setCurrentDirectory currdir)-		(try a::IO (Either SomeException ()))-	case r of-		Right () -> return ()-		Left e -> throwM e--setuprepo :: FilePath -> IO FilePath-setuprepo dir = do-	cleanup dir-	ensuretmpdir-	boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed"-	configrepo dir-	return dir--data CloneRepoConfig = CloneRepoConfig-	{ bareClone :: Bool-	, sharedClone :: Bool-	}--newCloneRepoConfig :: CloneRepoConfig-newCloneRepoConfig = CloneRepoConfig-	{ bareClone = False-	, sharedClone = False-	}---- clones are always done as local clones; we cannot test ssh clones-clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath-clonerepo old new cfg = do-	cleanup new-	ensuretmpdir-	let cloneparams = catMaybes-		[ Just $ Param "clone"-		, Just $ Param "-q"-		, if bareClone cfg then Just (Param "--bare") else Nothing-		, if sharedClone cfg then Just (Param "--shared") else Nothing-		, Just $ File old-		, Just $ File new-		]-	boolSystem "git" cloneparams @? "git clone failed"-	configrepo new-	indir new $ do-		ver <- annexVersion <$> getTestMode-		if ver == Annex.Version.defaultVersion-			then git_annex "init" ["-q", new] @? "git annex init failed"-			else git_annex "init" ["-q", new, "--version", ver] @? "git annex init failed"-	unless (bareClone cfg) $-		indir new $-			setupTestMode-	return new--configrepo :: FilePath -> IO ()-configrepo dir = indir dir $ do-	-- ensure git is set up to let commits happen-	boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed"-	boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed"-	-- avoid signed commits by test suite-	boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed"-	-- tell git-annex to not annex the ingitfile-	boolSystem "git"-		[ Param "config"-		, Param "annex.largefiles"-		, Param ("exclude=" ++ ingitfile)-		] @? "git config annex.largefiles failed"--ensuretmpdir :: IO ()-ensuretmpdir = do-	e <- doesDirectoryExist tmpdir-	unless e $-		createDirectory tmpdir-	-{- Prevent global git configs from affecting the test suite. -}-isolateGitConfig :: IO a -> IO a-isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do-	tmphomeabs <- absPath tmphome-	Utility.Env.Set.setEnv "HOME" tmphomeabs True-	Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True-	Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True-	a--cleanup :: FilePath -> IO ()-cleanup dir = whenM (doesDirectoryExist dir) $ do-	Command.Uninit.prepareRemoveAnnexDir' dir-	-- This can fail if files in the directory are still open by a-	-- subprocess.-	void $ tryIO $ removeDirectoryRecursive dir--finalCleanup :: IO ()-finalCleanup = whenM (doesDirectoryExist tmpdir) $ do-	Annex.Action.reapZombies-	Command.Uninit.prepareRemoveAnnexDir' tmpdir-	catchIO (removeDirectoryRecursive tmpdir) $ \e -> do-		print e-		putStrLn "sleeping 10 seconds and will retry directory cleanup"-		Utility.ThreadScheduler.threadDelaySeconds $-			Utility.ThreadScheduler.Seconds 10-		whenM (doesDirectoryExist tmpdir) $ do-			Annex.Action.reapZombies-			removeDirectoryRecursive tmpdir-	-checklink :: FilePath -> Assertion-checklink f =-	-- in direct mode, it may be a symlink, or not, depending-	-- on whether the content is present.-	unlessM (annexeval Config.isDirect) $-		ifM (annexeval Config.crippledFileSystem)-			( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))-				@? f ++ " is not a (crippled) symlink"-			, do-				s <- getSymbolicLinkStatus f-				isSymbolicLink s @? f ++ " is not a symlink"-			)--checkregularfile :: FilePath -> Assertion-checkregularfile f = do-	s <- getSymbolicLinkStatus f-	isRegularFile s @? f ++ " is not a normal file"-	return ()--checkdoesnotexist :: FilePath -> Assertion-checkdoesnotexist f = -	(either (const True) (const False) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))-		@? f ++ " exists unexpectedly"--checkexists :: FilePath -> Assertion-checkexists f = -	(either (const False) (const True) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))-		@? f ++ " does not exist"--checkcontent :: FilePath -> Assertion-checkcontent f = do-	c <- Utility.Exception.catchDefaultIO "could not read file" $ readFile f-	assertEqual ("checkcontent " ++ f) (content f) c--checkunwritable :: FilePath -> Assertion-checkunwritable f = unlessM (annexeval Config.isDirect) $ do-	-- Look at permissions bits rather than trying to write or-	-- using fileAccess because if run as root, any file can be-	-- modified despite permissions.-	s <- getFileStatus f-	let mode = fileMode s-	when (mode == mode `unionFileModes` ownerWriteMode) $-		assertFailure $ "able to modify annexed file's " ++ f ++ " content"--checkwritable :: FilePath -> Assertion-checkwritable f = do-	s <- getFileStatus f-	let mode = fileMode s-	unless (mode == mode `unionFileModes` ownerWriteMode) $-		assertFailure $ "unable to modify " ++ f--checkdangling :: FilePath -> Assertion-checkdangling f = ifM (annexeval Config.crippledFileSystem)-	( return () -- probably no real symlinks to test-	, do-		r <- tryIO $ readFile f-		case r of-			Left _ -> return () -- expected; dangling link-			Right _ -> assertFailure $ f ++ " was not a dangling link as expected"-	)--checklocationlog :: FilePath -> Bool -> Assertion-checklocationlog f expected = do-	thisuuid <- annexeval Annex.UUID.getUUID-	r <- annexeval $ Annex.WorkTree.lookupFile f-	case r of-		Just k -> do-			uuids <- annexeval $ Remote.keyLocations k-			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"--checkbackend :: FilePath -> Types.Backend -> Assertion-checkbackend file expected = do-	b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) -		=<< Annex.WorkTree.lookupFile file-	assertEqual ("backend for " ++ file) (Just expected) b--checkispointerfile :: FilePath -> Assertion-checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $-	assertFailure $ f ++ " is not a pointer file"--inlocationlog :: FilePath -> Assertion-inlocationlog f = checklocationlog f True--notinlocationlog :: FilePath -> Assertion-notinlocationlog f = checklocationlog f False--runchecks :: [FilePath -> Assertion] -> FilePath -> Assertion-runchecks [] _ = return ()-runchecks (a:as) f = do-	a f-	runchecks as f--annexed_notpresent :: FilePath -> Assertion-annexed_notpresent f = ifM (unlockedFiles <$> getTestMode)-	( annexed_notpresent_unlocked f-	, annexed_notpresent_locked f-	)--annexed_notpresent_locked :: FilePath -> Assertion-annexed_notpresent_locked = runchecks [checklink, checkdangling, notinlocationlog]--annexed_notpresent_unlocked :: FilePath -> Assertion-annexed_notpresent_unlocked = runchecks [checkregularfile, checkispointerfile, notinlocationlog]--annexed_present :: FilePath -> Assertion-annexed_present f = ifM (unlockedFiles <$> getTestMode)-	( annexed_present_unlocked f-	, annexed_present_locked f-	)--annexed_present_locked :: FilePath -> Assertion-annexed_present_locked f = ifM (annexeval Config.crippledFileSystem)-	( runchecks [checklink, inlocationlog] f-	, runchecks [checklink, checkcontent, checkunwritable, inlocationlog] f-	)--annexed_present_unlocked :: FilePath -> Assertion-annexed_present_unlocked = runchecks-	[checkregularfile, checkcontent, checkwritable, inlocationlog]--unannexed :: FilePath -> Assertion-unannexed = runchecks [checkregularfile, checkcontent, checkwritable]--add_annex :: FilePath -> IO Bool-add_annex f = ifM (unlockedFiles <$> getTestMode)-	( boolSystem "git" [Param "add", File f]-	, git_annex "add" [f]-	)--data TestMode = TestMode-	{ forceDirect :: Bool-	, unlockedFiles :: Bool-	, annexVersion :: Annex.Version.Version-	, keepFailures :: Bool-	} deriving (Read, Show)--testMode :: TestOptions -> Annex.Version.Version -> TestMode-testMode opts v = TestMode-	{ forceDirect = False-	, unlockedFiles = False-	, annexVersion = v-	, keepFailures = keepFailuresOption opts-	}--withTestMode :: TestMode -> TestTree -> TestTree-withTestMode testmode = withResource prepare release . const-  where-	prepare = do-		setTestMode testmode-		case tryIngredients [consoleTestReporter] mempty initTests of-			Nothing -> error "No tests found!?"-			Just act -> unlessM act $-				error "init tests failed! cannot continue"-		return ()-	release _ = cleanup mainrepodir--setTestMode :: TestMode -> IO ()-setTestMode testmode = do-	currdir <- getCurrentDirectory-	p <- Utility.Env.getEnvDefault "PATH" ""--	mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)-		-- Ensure that the just-built git annex is used.-		[ ("PATH", currdir ++ [searchPathSeparator] ++ p)-		, ("TOPDIR", currdir)-		-- Avoid git complaining if it cannot determine the user's-		-- email address, or exploding if it doesn't know the user's-		-- name.-		, ("GIT_AUTHOR_EMAIL", "test@example.com")-		, ("GIT_AUTHOR_NAME", "git-annex test")-		, ("GIT_COMMITTER_EMAIL", "test@example.com")-		, ("GIT_COMMITTER_NAME", "git-annex test")-		-- force gpg into batch mode for the tests-		, ("GPG_BATCH", "1")-		-- Make git and git-annex access ssh remotes on the local-		-- filesystem, without using ssh at all.-		, ("GIT_SSH_COMMAND", "git-annex test --fakessh --")-		, ("GIT_ANNEX_USE_GIT_SSH", "1")-		, ("TESTMODE", show testmode)-		]--runFakeSsh :: [String] -> IO ()-runFakeSsh ("-n":ps) = runFakeSsh ps-runFakeSsh (_host:cmd:[]) = do-	(_, _, _, pid) <- createProcess (shell cmd)-	exitWith =<< waitForProcess pid-runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps--getTestMode :: IO TestMode-getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""--setupTestMode :: IO ()-setupTestMode = do-	testmode <- getTestMode-	when (forceDirect testmode) $-		git_annex "direct" ["-q"] @? "git annex direct failed"--changeToTmpDir :: FilePath -> IO ()-changeToTmpDir t = do-	topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")-	setCurrentDirectory $ topdir ++ "/" ++ t--tmpdir :: String-tmpdir = ".t"--mainrepodir :: FilePath-mainrepodir = tmpdir </> "repo"--tmprepodir :: IO FilePath-tmprepodir = go (0 :: Int)-  where-	go n = do-		let d = tmpdir </> "tmprepo" ++ show n-		ifM (doesDirectoryExist d)-			( go $ n + 1-			, return d-			)--annexedfile :: String-annexedfile = "foo"--annexedfiledup :: String-annexedfiledup = "foodup"--wormannexedfile :: String-wormannexedfile = "apple"--sha1annexedfile :: String-sha1annexedfile = "sha1foo"--sha1annexedfiledup :: String-sha1annexedfiledup = "sha1foodup"--ingitfile :: String-ingitfile = "bar.c"--content :: FilePath -> String		-content f-	| f == annexedfile = "annexed file content"-	| f == ingitfile = "normal file content"-	| f == sha1annexedfile ="sha1 annexed file content"-	| f == annexedfiledup = content annexedfile-	| f == sha1annexedfiledup = content sha1annexedfile-	| f == wormannexedfile = "worm annexed file content"-	| "import" `isPrefixOf` f = "imported content"-	| otherwise = "unknown file " ++ f--changecontent :: FilePath -> IO ()-changecontent f = writeFile f $ changedcontent f--changedcontent :: FilePath -> String-changedcontent f = content f ++ " (modified)"--backendSHA1 :: Types.Backend-backendSHA1 = backend_ "SHA1"--backendSHA256 :: Types.Backend-backendSHA256 = backend_ "SHA256"--backendSHA256E :: Types.Backend-backendSHA256E = backend_ "SHA256E"--backendWORM :: Types.Backend-backendWORM = backend_ "WORM"--backend_ :: String -> Types.Backend-backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety--getKey :: Types.Backend -> FilePath -> IO Types.Key-getKey b f = fromJust <$> annexeval go-  where-	go = Types.Backend.getKey b-		Types.KeySource.KeySource-			{ Types.KeySource.keyFilename = f-			, Types.KeySource.contentLocation = f-			, Types.KeySource.inodeCache = Nothing-			}

@@ -0,0 +1,534 @@+{- git-annex test suite framework+ -+ - Copyright 2010-2017 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Test.Framework where++import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit++import Common+import Types.Test++import qualified Annex+import qualified Annex.UUID+import qualified Annex.Version+import qualified Backend+import qualified Git.CurrentRepo+import qualified Git.Construct+import qualified Types.KeySource+import qualified Types.Backend+import qualified Types+import qualified Remote+import qualified Key+import qualified Types.Key+import qualified Types.Messages+import qualified Config+import qualified Annex.WorkTree+import qualified Annex.Link+import qualified Annex.Init+import qualified Annex.Path+import qualified Annex.Action+import qualified Utility.Process+import qualified Utility.Env+import qualified Utility.Env.Set+import qualified Utility.Exception+import qualified Utility.ThreadScheduler+import qualified Utility.Tmp.Dir+import qualified Command.Uninit+import qualified CmdLine.GitAnnex as GitAnnex++-- This is equivilant to running git-annex, but it's all run in-process+-- so test coverage collection works.+git_annex :: String -> [String] -> IO Bool+git_annex command params = do+	-- catch all errors, including normally fatal errors+	r <- try run ::IO (Either SomeException ())+	case r of+		Right _ -> return True+		Left _ -> return False+  where+	run = GitAnnex.run dummyTestOptParser Nothing (command:"-q":params)+	dummyTestOptParser = pure mempty++{- Runs git-annex and returns its output. -}+git_annex_output :: String -> [String] -> IO String+git_annex_output command params = do+	pp <- Annex.Path.programPath+	got <- Utility.Process.readProcess pp (command:params)+	-- Since the above is a separate process, code coverage stats are+	-- not gathered for things run in it.+	-- Run same command again, to get code coverage.+	_ <- git_annex command params+	return got++git_annex_expectoutput :: String -> [String] -> [String] -> IO ()+git_annex_expectoutput command params expected = do+	got <- lines <$> git_annex_output command params+	got == expected @? ("unexpected value running " ++ command ++ " " ++ show params ++ " -- got: " ++ show got ++ " expected: " ++ show expected)++-- Runs an action in the current annex. Note that shutdown actions+-- are not run; this should only be used for actions that query state.+annexeval :: Types.Annex a -> IO a+annexeval a = do+	s <- Annex.new =<< Git.CurrentRepo.get+	Annex.eval s $ do+		Annex.setOutput Types.Messages.QuietOutput+		a `finally` Annex.Action.stopCoProcesses++innewrepo :: Assertion -> Assertion+innewrepo a = withgitrepo $ \r -> indir r a++inmainrepo :: Assertion -> Assertion+inmainrepo = indir mainrepodir++with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion)+with_ssh_origin cloner a = cloner $ do+	origindir <- absPath+		=<< annexeval (Config.getConfig (Config.ConfigKey config) "/dev/null")+	let originurl = "localhost:" ++ origindir+	boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed"+	a+  where+	config = "remote.origin.url"++intmpclonerepo :: Assertion -> Assertion+intmpclonerepo a = withtmpclonerepo $ \r -> indir r a++intmpclonerepoInDirect :: Assertion -> Assertion+intmpclonerepoInDirect a = intmpclonerepo $+	ifM isdirect+		( putStrLn "not supported in direct mode; skipping"+		, a+		)+  where+	isdirect = annexeval $ do+		Annex.Init.initialize (Annex.Init.AutoInit False) Nothing Nothing+		Config.isDirect++checkRepo :: Types.Annex a -> FilePath -> IO a+checkRepo getval d = do+	s <- Annex.new =<< Git.Construct.fromPath d+	Annex.eval s $+		getval `finally` Annex.Action.stopCoProcesses++isInDirect :: FilePath -> IO Bool+isInDirect = checkRepo (not <$> Config.isDirect)++intmpbareclonerepo :: Assertion -> Assertion+intmpbareclonerepo a = withtmpclonerepo' (newCloneRepoConfig { bareClone = True } ) $+	\r -> indir r a++intmpsharedclonerepo :: Assertion -> Assertion+intmpsharedclonerepo a = withtmpclonerepo' (newCloneRepoConfig { sharedClone = True } ) $+	\r -> indir r a++withtmpclonerepo :: (FilePath -> Assertion) -> Assertion+withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig++withtmpclonerepo' :: CloneRepoConfig -> (FilePath -> Assertion) -> Assertion+withtmpclonerepo' cfg a = do+	dir <- tmprepodir+	clone <- clonerepo mainrepodir dir cfg+	r <- tryNonAsync (a clone)+	case r of+		Right () -> return ()+		Left e -> do+			whenM (keepFailures <$> getTestMode) $+				putStrLn $ "** Preserving repo for failure analysis in " ++ clone+			throwM e++disconnectOrigin :: Assertion+disconnectOrigin = boolSystem "git" [Param "remote", Param "rm", Param "origin"] @? "remote rm"++withgitrepo :: (FilePath -> Assertion) -> Assertion+withgitrepo = bracket (setuprepo mainrepodir) return++indir :: FilePath -> Assertion -> Assertion+indir dir a = do+	currdir <- getCurrentDirectory+	-- Assertion failures throw non-IO errors; catch+	-- any type of error and change back to currdir before+	-- rethrowing.+	r <- bracket_ (changeToTmpDir dir) (setCurrentDirectory currdir)+		(try a::IO (Either SomeException ()))+	case r of+		Right () -> return ()+		Left e -> throwM e++setuprepo :: FilePath -> IO FilePath+setuprepo dir = do+	cleanup dir+	ensuretmpdir+	boolSystem "git" [Param "init", Param "-q", File dir] @? "git init failed"+	configrepo dir+	return dir++data CloneRepoConfig = CloneRepoConfig+	{ bareClone :: Bool+	, sharedClone :: Bool+	}++newCloneRepoConfig :: CloneRepoConfig+newCloneRepoConfig = CloneRepoConfig+	{ bareClone = False+	, sharedClone = False+	}++-- clones are always done as local clones; we cannot test ssh clones+clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath+clonerepo old new cfg = do+	cleanup new+	ensuretmpdir+	let cloneparams = catMaybes+		[ Just $ Param "clone"+		, Just $ Param "-q"+		, if bareClone cfg then Just (Param "--bare") else Nothing+		, if sharedClone cfg then Just (Param "--shared") else Nothing+		, Just $ File old+		, Just $ File new+		]+	boolSystem "git" cloneparams @? "git clone failed"+	configrepo new+	indir new $ do+		ver <- annexVersion <$> getTestMode+		if ver == Annex.Version.defaultVersion+			then git_annex "init" ["-q", new] @? "git annex init failed"+			else git_annex "init" ["-q", new, "--version", ver] @? "git annex init failed"+	unless (bareClone cfg) $+		indir new $+			setupTestMode+	return new++configrepo :: FilePath -> IO ()+configrepo dir = indir dir $ do+	-- ensure git is set up to let commits happen+	boolSystem "git" [Param "config", Param "user.name", Param "Test User"] @? "git config failed"+	boolSystem "git" [Param "config", Param "user.email", Param "test@example.com"] @? "git config failed"+	-- avoid signed commits by test suite+	boolSystem "git" [Param "config", Param "commit.gpgsign", Param "false"] @? "git config failed"+	-- tell git-annex to not annex the ingitfile+	boolSystem "git"+		[ Param "config"+		, Param "annex.largefiles"+		, Param ("exclude=" ++ ingitfile)+		] @? "git config annex.largefiles failed"++ensuretmpdir :: IO ()+ensuretmpdir = do+	e <- doesDirectoryExist tmpdir+	unless e $+		createDirectory tmpdir+	+{- Prevent global git configs from affecting the test suite. -}+isolateGitConfig :: IO a -> IO a+isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do+	tmphomeabs <- absPath tmphome+	Utility.Env.Set.setEnv "HOME" tmphomeabs True+	Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True+	Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True+	a++cleanup :: FilePath -> IO ()+cleanup dir = whenM (doesDirectoryExist dir) $ do+	Command.Uninit.prepareRemoveAnnexDir' dir+	-- This can fail if files in the directory are still open by a+	-- subprocess.+	void $ tryIO $ removeDirectoryRecursive dir++finalCleanup :: IO ()+finalCleanup = whenM (doesDirectoryExist tmpdir) $ do+	Annex.Action.reapZombies+	Command.Uninit.prepareRemoveAnnexDir' tmpdir+	catchIO (removeDirectoryRecursive tmpdir) $ \e -> do+		print e+		putStrLn "sleeping 10 seconds and will retry directory cleanup"+		Utility.ThreadScheduler.threadDelaySeconds $+			Utility.ThreadScheduler.Seconds 10+		whenM (doesDirectoryExist tmpdir) $ do+			Annex.Action.reapZombies+			removeDirectoryRecursive tmpdir+	+checklink :: FilePath -> Assertion+checklink f =+	-- in direct mode, it may be a symlink, or not, depending+	-- on whether the content is present.+	unlessM (annexeval Config.isDirect) $+		ifM (annexeval Config.crippledFileSystem)+			( (isJust <$> annexeval (Annex.Link.getAnnexLinkTarget f))+				@? f ++ " is not a (crippled) symlink"+			, do+				s <- getSymbolicLinkStatus f+				isSymbolicLink s @? f ++ " is not a symlink"+			)++checkregularfile :: FilePath -> Assertion+checkregularfile f = do+	s <- getSymbolicLinkStatus f+	isRegularFile s @? f ++ " is not a normal file"+	return ()++checkdoesnotexist :: FilePath -> Assertion+checkdoesnotexist f = +	(either (const True) (const False) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))+		@? f ++ " exists unexpectedly"++checkexists :: FilePath -> Assertion+checkexists f = +	(either (const False) (const True) <$> Utility.Exception.tryIO (getSymbolicLinkStatus f))+		@? f ++ " does not exist"++checkcontent :: FilePath -> Assertion+checkcontent f = do+	c <- Utility.Exception.catchDefaultIO "could not read file" $ readFile f+	assertEqual ("checkcontent " ++ f) (content f) c++checkunwritable :: FilePath -> Assertion+checkunwritable f = unlessM (annexeval Config.isDirect) $ do+	-- Look at permissions bits rather than trying to write or+	-- using fileAccess because if run as root, any file can be+	-- modified despite permissions.+	s <- getFileStatus f+	let mode = fileMode s+	when (mode == mode `unionFileModes` ownerWriteMode) $+		assertFailure $ "able to modify annexed file's " ++ f ++ " content"++checkwritable :: FilePath -> Assertion+checkwritable f = do+	s <- getFileStatus f+	let mode = fileMode s+	unless (mode == mode `unionFileModes` ownerWriteMode) $+		assertFailure $ "unable to modify " ++ f++checkdangling :: FilePath -> Assertion+checkdangling f = ifM (annexeval Config.crippledFileSystem)+	( return () -- probably no real symlinks to test+	, do+		r <- tryIO $ readFile f+		case r of+			Left _ -> return () -- expected; dangling link+			Right _ -> assertFailure $ f ++ " was not a dangling link as expected"+	)++checklocationlog :: FilePath -> Bool -> Assertion+checklocationlog f expected = do+	thisuuid <- annexeval Annex.UUID.getUUID+	r <- annexeval $ Annex.WorkTree.lookupFile f+	case r of+		Just k -> do+			uuids <- annexeval $ Remote.keyLocations k+			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"++checkbackend :: FilePath -> Types.Backend -> Assertion+checkbackend file expected = do+	b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) +		=<< Annex.WorkTree.lookupFile file+	assertEqual ("backend for " ++ file) (Just expected) b++checkispointerfile :: FilePath -> Assertion+checkispointerfile f = unlessM (isJust <$> Annex.Link.isPointerFile f) $+	assertFailure $ f ++ " is not a pointer file"++inlocationlog :: FilePath -> Assertion+inlocationlog f = checklocationlog f True++notinlocationlog :: FilePath -> Assertion+notinlocationlog f = checklocationlog f False++runchecks :: [FilePath -> Assertion] -> FilePath -> Assertion+runchecks [] _ = return ()+runchecks (a:as) f = do+	a f+	runchecks as f++annexed_notpresent :: FilePath -> Assertion+annexed_notpresent f = ifM (unlockedFiles <$> getTestMode)+	( annexed_notpresent_unlocked f+	, annexed_notpresent_locked f+	)++annexed_notpresent_locked :: FilePath -> Assertion+annexed_notpresent_locked = runchecks [checklink, checkdangling, notinlocationlog]++annexed_notpresent_unlocked :: FilePath -> Assertion+annexed_notpresent_unlocked = runchecks [checkregularfile, checkispointerfile, notinlocationlog]++annexed_present :: FilePath -> Assertion+annexed_present f = ifM (unlockedFiles <$> getTestMode)+	( annexed_present_unlocked f+	, annexed_present_locked f+	)++annexed_present_locked :: FilePath -> Assertion+annexed_present_locked f = ifM (annexeval Config.crippledFileSystem)+	( runchecks [checklink, inlocationlog] f+	, runchecks [checklink, checkcontent, checkunwritable, inlocationlog] f+	)++annexed_present_unlocked :: FilePath -> Assertion+annexed_present_unlocked = runchecks+	[checkregularfile, checkcontent, checkwritable, inlocationlog]++unannexed :: FilePath -> Assertion+unannexed = runchecks [checkregularfile, checkcontent, checkwritable]++add_annex :: FilePath -> IO Bool+add_annex f = ifM (unlockedFiles <$> getTestMode)+	( boolSystem "git" [Param "add", File f]+	, git_annex "add" [f]+	)++data TestMode = TestMode+	{ forceDirect :: Bool+	, unlockedFiles :: Bool+	, annexVersion :: Annex.Version.Version+	, keepFailures :: Bool+	} deriving (Read, Show)++testMode :: TestOptions -> Annex.Version.Version -> TestMode+testMode opts v = TestMode+	{ forceDirect = False+	, unlockedFiles = False+	, annexVersion = v+	, keepFailures = keepFailuresOption opts+	}++withTestMode :: TestMode -> TestTree -> TestTree -> TestTree+withTestMode testmode inittests = withResource prepare release . const+  where+	prepare = do+		setTestMode testmode+		case tryIngredients [consoleTestReporter] mempty inittests of+			Nothing -> error "No tests found!?"+			Just act -> unlessM act $+				error "init tests failed! cannot continue"+		return ()+	release _ = cleanup mainrepodir++setTestMode :: TestMode -> IO ()+setTestMode testmode = do+	currdir <- getCurrentDirectory+	p <- Utility.Env.getEnvDefault "PATH" ""++	mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)+		-- Ensure that the just-built git annex is used.+		[ ("PATH", currdir ++ [searchPathSeparator] ++ p)+		, ("TOPDIR", currdir)+		-- Avoid git complaining if it cannot determine the user's+		-- email address, or exploding if it doesn't know the user's+		-- name.+		, ("GIT_AUTHOR_EMAIL", "test@example.com")+		, ("GIT_AUTHOR_NAME", "git-annex test")+		, ("GIT_COMMITTER_EMAIL", "test@example.com")+		, ("GIT_COMMITTER_NAME", "git-annex test")+		-- force gpg into batch mode for the tests+		, ("GPG_BATCH", "1")+		-- Make git and git-annex access ssh remotes on the local+		-- filesystem, without using ssh at all.+		, ("GIT_SSH_COMMAND", "git-annex test --fakessh --")+		, ("GIT_ANNEX_USE_GIT_SSH", "1")+		, ("TESTMODE", show testmode)+		]++runFakeSsh :: [String] -> IO ()+runFakeSsh ("-n":ps) = runFakeSsh ps+runFakeSsh (_host:cmd:[]) = do+	(_, _, _, pid) <- createProcess (shell cmd)+	exitWith =<< waitForProcess pid+runFakeSsh ps = error $ "fake ssh option parse error: " ++ show ps++getTestMode :: IO TestMode+getTestMode = Prelude.read <$> Utility.Env.getEnvDefault "TESTMODE" ""++setupTestMode :: IO ()+setupTestMode = do+	testmode <- getTestMode+	when (forceDirect testmode) $+		git_annex "direct" ["-q"] @? "git annex direct failed"++changeToTmpDir :: FilePath -> IO ()+changeToTmpDir t = do+	topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set")+	setCurrentDirectory $ topdir ++ "/" ++ t++tmpdir :: String+tmpdir = ".t"++mainrepodir :: FilePath+mainrepodir = tmpdir </> "repo"++tmprepodir :: IO FilePath+tmprepodir = go (0 :: Int)+  where+	go n = do+		let d = tmpdir </> "tmprepo" ++ show n+		ifM (doesDirectoryExist d)+			( go $ n + 1+			, return d+			)++annexedfile :: String+annexedfile = "foo"++annexedfiledup :: String+annexedfiledup = "foodup"++wormannexedfile :: String+wormannexedfile = "apple"++sha1annexedfile :: String+sha1annexedfile = "sha1foo"++sha1annexedfiledup :: String+sha1annexedfiledup = "sha1foodup"++ingitfile :: String+ingitfile = "bar.c"++content :: FilePath -> String		+content f+	| f == annexedfile = "annexed file content"+	| f == ingitfile = "normal file content"+	| f == sha1annexedfile ="sha1 annexed file content"+	| f == annexedfiledup = content annexedfile+	| f == sha1annexedfiledup = content sha1annexedfile+	| f == wormannexedfile = "worm annexed file content"+	| "import" `isPrefixOf` f = "imported content"+	| otherwise = "unknown file " ++ f++changecontent :: FilePath -> IO ()+changecontent f = writeFile f $ changedcontent f++changedcontent :: FilePath -> String+changedcontent f = content f ++ " (modified)"++backendSHA1 :: Types.Backend+backendSHA1 = backend_ "SHA1"++backendSHA256 :: Types.Backend+backendSHA256 = backend_ "SHA256"++backendSHA256E :: Types.Backend+backendSHA256E = backend_ "SHA256E"++backendWORM :: Types.Backend+backendWORM = backend_ "WORM"++backend_ :: String -> Types.Backend+backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety++getKey :: Types.Backend -> FilePath -> IO Types.Key+getKey b f = fromJust <$> annexeval go+  where+	go = Types.Backend.getKey b+		Types.KeySource.KeySource+			{ Types.KeySource.keyFilename = f+			, Types.KeySource.contentLocation = f+			, Types.KeySource.inodeCache = Nothing+			}

@@ -59,6 +59,7 @@ 	, annexBloomAccuracy :: Maybe Int 	, annexSshCaching :: Maybe Bool 	, annexAlwaysCommit :: Bool+	, annexMergeAnnexBranches :: Bool 	, annexDelayAdd :: Maybe Int 	, annexHttpHeaders :: [String] 	, annexHttpHeadersCommand :: Maybe String@@ -116,6 +117,7 @@ 	, annexBloomAccuracy = getmayberead (annex "bloomaccuracy") 	, annexSshCaching = getmaybebool (annex "sshcaching") 	, annexAlwaysCommit = getbool (annex "alwayscommit") True+	, annexMergeAnnexBranches = getbool (annex "merge-annex-branches") True 	, annexDelayAdd = getmayberead (annex "delayadd") 	, annexHttpHeaders = getlist (annex "http-headers") 	, annexHttpHeadersCommand = getmaybe (annex "http-headers-command")

@@ -1,6 +1,6 @@ {- git-annex Messages data types  - - - Copyright 2012-2017 Joey Hess <id@joeyh.name>+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -16,8 +16,21 @@ import System.Console.Regions (ConsoleRegion) #endif -data OutputType = NormalOutput | QuietOutput | JSONOutput Bool+data OutputType = NormalOutput | QuietOutput | JSONOutput JSONOptions 	deriving (Show)++data JSONOptions = JSONOptions+	{ jsonProgress :: Bool+	, jsonErrorMessages :: Bool+	}+	deriving (Show)++adjustOutputType :: OutputType -> OutputType -> OutputType+adjustOutputType (JSONOutput old) (JSONOutput new) = JSONOutput $ JSONOptions+	{ jsonProgress = jsonProgress old || jsonProgress new+	, jsonErrorMessages = jsonErrorMessages old || jsonErrorMessages new+	}+adjustOutputType _old new = new  data SideActionBlock = NoBlock | StartBlock | InBlock 	deriving (Eq)

@@ -66,6 +66,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ * `--batch`    Enables batch mode, in which a file to add is read in a line from stdin,

@@ -97,6 +97,11 @@    Include progress objects in JSON output. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # CAVEATS  If annex.largefiles is configured, and does not match a file, `git annex

@@ -97,6 +97,11 @@    Include progress objects in JSON output. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # SEE ALSO  [[git-annex]](1)

@@ -9,14 +9,19 @@ # DESCRIPTION  This is an external git diff driver shim. Normally, when using `git diff`-with an external git driver, the symlinks to annexed files are not set up-right, so the external git driver cannot read them in order to perform+with an external diff driver, the symlinks to annexed files are not set up+right, so the external diff driver cannot read them in order to perform smart diffing of their contents. This command works around the problem, by passing the fixed up files to the real external diff driver. -To use, just configure git to use "git-annex diffdriver -- cmd params --"-as the external diff command, where cmd is the real external diff-command you want to use, and params are any extra parameters to pass+To use this, you will need to have installed some git external diff driver+command. This is not the regular diff command; it takes a git-specific+input. See git's documentation of `GIT_EXTERNAL_DIFF` and+gitattributes(5)'s documentation of external diff drivers.++Configure git to use "git-annex diffdriver -- cmd params --"+as the external diff driver, where cmd is the external diff+driver you want it to run, and params are any extra parameters to pass to it. Note the trailing "--", which is required.  For example, set `GIT_EXTERNAL_DIFF=git-annex diffdriver -- j-c-diff --`

@@ -87,6 +87,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # SEE ALSO  [[git-annex]](1)

@@ -29,6 +29,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # SEE ALSO  [[git-annex]](1)

@@ -33,6 +33,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ * `--batch`    Enable batch mode, in which a line containing a key is read from stdin,

@@ -54,6 +54,11 @@   This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ * `--batch`    Enables batch mode, in which a file is read in a line from stdin,

@@ -98,6 +98,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # OPTIONS  # SEE ALSO

@@ -106,6 +106,11 @@    Include progress objects in JSON output. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # SEE ALSO  [[git-annex]](1)

@@ -81,6 +81,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # CAVEATS  Note that using `--deduplicate` or `--clean-duplicates` with the WORM

@@ -26,6 +26,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ * `--bytes`    Show file sizes in bytes, disabling the default nicer units.

@@ -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. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # SEE ALSO  [[git-annex]](1)

@@ -112,6 +112,11 @@  	{"command":"metadata","file":"foo","key":"...","author":["bar"],...,"note":"...","success":true} +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ * `--batch`    Enables batch mode, which can be used to both get, store, and unset

@@ -75,6 +75,11 @@    Include progress objects in JSON output. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # SEE ALSO  [[git-annex]](1)

@@ -92,6 +92,11 @@    Include progress objects in JSON output. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # SEE ALSO  [[git-annex]](1)

@@ -164,8 +164,6 @@   When a repository is in exactly one such group, you can use the "standard"   keyword in its preferred content expression, to match whatever content   the group's expression matches.-  (If a repository is put into multiple standard-  groups, "standard" will match anything.. so don't do that!)    Most often, the whole preferred content expression is simply "standard".   But, you can do more complicated things, for example:

@@ -20,9 +20,12 @@  While [[git-annex-wanted]] is just a preference, [[git-annex-required]] designates content that should really not be-removed. For example a file that is `wanted` can be removed with `git-annex drop`, but if that file is `required`, it would need to be-removed with `git annex drop --force`.+removed. For example a file that is `wanted` can be removed with +`git annex drop`, but if that file is `required`, it would need to be+removed with `git annex drop --force`. ++Also, `git-annex fsck` will warn about required contents that are not+present.  # NOTES 

@@ -18,15 +18,20 @@  # OPTIONS +* `--ignore-submodules=when`++  This option is passed on to git status, see its man page for+  details.+ * `--json`    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`+* `--json-error-messages` -  This option is passed on to git status, see its man page for-  details.+  Messages that would normally be output to standard error are included in+  the json instead.  # SEE ALSO 

@@ -42,6 +42,11 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.+ # SEE ALSO  [[git-annex]](1)

@@ -43,11 +43,6 @@    Show whereis information for files found by last run of git-annex unused. -* `--json`--  Enable JSON output. This is intended to be parsed by programs that use-  git-annex. Each line of output is a JSON object.- * `--batch`    Enables batch mode, in which a file is read in a line from stdin,@@ -55,6 +50,16 @@    Note that if the file is not an annexed file, an empty line will be   output instead.++* `--json`++  Enable JSON output. This is intended to be parsed by programs that use+  git-annex. Each line of output is a JSON object.++* `--json-error-messages`++  Messages that would normally be output to standard error are included in+  the json instead.  # SEE ALSO 

@@ -970,10 +970,19 @@   commit the data by running `git annex merge` (or by automatic merges)   or `git annex sync`. -  Note that you beware running `git gc` if using this configuration,+  You should beware running `git gc` when using this configuration,   since it could garbage collect objects that are staged in git-annex's   index but not yet committed. +* `annex.merge-annex-branches`++  By default, git-annex branches that have been pulled from remotes+  are automatically merged into the local git-annex branch, so that+  git-annex has the most up-to-date possible knowledge.++  To avoid that merging, set this to "false". This can be useful+  particularly when you don't have write permission to the repository.+ * `annex.hardlink`    Set this to `true` to make file contents be hard linked between the@@ -1054,8 +1063,9 @@  * `annex.resolvemerge` -  Set to false to prevent merge conflicts being automatically resolved-  by the git-annex assitant, git-annex sync, git-annex merge,+  Set to false to prevent merge conflicts in the checked out branch+  being automatically resolved by the git-annex assitant,+  git-annex sync, git-annex merge,   and the git-annex post-receive hook.    To configure the behavior in all clones of the repository,

@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20180112+Version: 6.20180227 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -350,6 +350,7 @@    persistent,    persistent-template,    aeson,+   vector,    tagsoup,    unordered-containers,    feed (>= 0.3.9),@@ -407,8 +408,11 @@   if flag(WebDAV)     Build-Depends: DAV (>= 1.0)     CPP-Options: -DWITH_WEBDAV+    Other-Modules:+      Remote.WebDAV+      Remote.WebDAV.DavLocation -  if flag(Assistant) && ! os(solaris)+  if flag(Assistant) && ! os(solaris) && ! os(gnu)     Build-Depends: dns (>= 1.0.0), mountpoints     CPP-Options: -DWITH_ASSISTANT @@ -428,7 +432,7 @@           CPP-Options: -DWITH_WIN32NOTIFY           Other-Modules: Utility.DirWatcher.Win32Notify         else-          if (! os(solaris) && ! os(linux))+          if (! os(solaris) && ! os(gnu) && ! os(linux))             CPP-Options: -DWITH_KQUEUE             C-Sources: Utility/libkqueue.c             Includes: Utility/libkqueue.h@@ -465,6 +469,43 @@      template-haskell,      shakespeare (>= 2.0.0)     CPP-Options: -DWITH_WEBAPP+    Other-Modules:+      Command.WebApp+      Assistant.Threads.WebApp+      Assistant.Threads.PairListener+      Assistant.WebApp+      Assistant.WebApp.Common+      Assistant.WebApp.Configurators+      Assistant.WebApp.Configurators.AWS+      Assistant.WebApp.Configurators.Delete+      Assistant.WebApp.Configurators.Edit+      Assistant.WebApp.Configurators.Fsck+      Assistant.WebApp.Configurators.IA+      Assistant.WebApp.Configurators.Local+      Assistant.WebApp.Configurators.Pairing+      Assistant.WebApp.Configurators.Preferences+      Assistant.WebApp.Configurators.Ssh+      Assistant.WebApp.Configurators.Unused+      Assistant.WebApp.Configurators.Upgrade+      Assistant.WebApp.Configurators.WebDAV+      Assistant.WebApp.Control+      Assistant.WebApp.DashBoard+      Assistant.WebApp.Documentation+      Assistant.WebApp.Form+      Assistant.WebApp.Gpg+      Assistant.WebApp.MakeRemote+      Assistant.WebApp.Notifications+      Assistant.WebApp.OtherRepos+      Assistant.WebApp.Page+      Assistant.WebApp.Pairing+      Assistant.WebApp.Repair+      Assistant.WebApp.RepoId+      Assistant.WebApp.RepoList+      Assistant.WebApp.SideBar+      Assistant.WebApp.Types+      Annex.MakeRepo+      Utility.Yesod+      Utility.WebApp    if flag(Pairing)     Build-Depends: network-multicast, network-info@@ -525,7 +566,6 @@     Annex.LockFile     Annex.LockPool     Annex.LockPool.PosixOrPid-    Annex.MakeRepo     Annex.MetaData     Annex.MetaData.StandardFields     Annex.Multicast@@ -589,7 +629,6 @@     Assistant.Threads.Merger     Assistant.Threads.MountWatcher     Assistant.Threads.NetWatcher-    Assistant.Threads.PairListener     Assistant.Threads.ProblemFixer     Assistant.Threads.Pusher     Assistant.Threads.RemoteControl@@ -601,7 +640,6 @@     Assistant.Threads.UpgradeWatcher     Assistant.Threads.Upgrader     Assistant.Threads.Watcher-    Assistant.Threads.WebApp     Assistant.TransferQueue     Assistant.TransferSlots     Assistant.TransferrerPool@@ -624,36 +662,6 @@     Assistant.Types.UrlRenderer     Assistant.Unused     Assistant.Upgrade-    Assistant.WebApp-    Assistant.WebApp.Common-    Assistant.WebApp.Configurators-    Assistant.WebApp.Configurators.AWS-    Assistant.WebApp.Configurators.Delete-    Assistant.WebApp.Configurators.Edit-    Assistant.WebApp.Configurators.Fsck-    Assistant.WebApp.Configurators.IA-    Assistant.WebApp.Configurators.Local-    Assistant.WebApp.Configurators.Pairing-    Assistant.WebApp.Configurators.Preferences-    Assistant.WebApp.Configurators.Ssh-    Assistant.WebApp.Configurators.Unused-    Assistant.WebApp.Configurators.Upgrade-    Assistant.WebApp.Configurators.WebDAV-    Assistant.WebApp.Control-    Assistant.WebApp.DashBoard-    Assistant.WebApp.Documentation-    Assistant.WebApp.Form-    Assistant.WebApp.Gpg-    Assistant.WebApp.MakeRemote-    Assistant.WebApp.Notifications-    Assistant.WebApp.OtherRepos-    Assistant.WebApp.Page-    Assistant.WebApp.Pairing-    Assistant.WebApp.Repair-    Assistant.WebApp.RepoId-    Assistant.WebApp.RepoList-    Assistant.WebApp.SideBar-    Assistant.WebApp.Types     Backend     Backend.Hash     Backend.URL@@ -786,7 +794,6 @@     Command.View     Command.Wanted     Command.Watch-    Command.WebApp     Command.Whereis     Common     Config@@ -928,8 +935,6 @@     Remote.Rsync.RsyncUrl     Remote.Tahoe     Remote.Web-    Remote.WebDAV-    Remote.WebDAV.DavLocation     RemoteDaemon.Common     RemoteDaemon.Core     RemoteDaemon.Transport@@ -939,6 +944,7 @@     RemoteDaemon.Transport.Ssh.Types     RemoteDaemon.Types     Test+    Test.Framework     Types     Types.ActionItem     Types.Availability@@ -1069,8 +1075,6 @@     Utility.Url     Utility.UserInfo     Utility.Verifiable-    Utility.WebApp-    Utility.Yesod    if (os(windows))     Other-Modules: