git-annex 6.20160907 → 6.20160923

raw patch · 41 files changed

+475/−273 lines, 41 files

Files

• Annex.hs +3/−2
• Annex/AdjustedBranch.hs +2/−2
• Annex/Content.hs +1/−1
• Annex/Transfer.hs +4/−3
• Assistant/WebApp/Form.hs +1/−1
• CHANGELOG +37/−0
• CmdLine/Action.hs +15/−12
• CmdLine/GitAnnex/Options.hs +10/−2
• Command/AddUrl.hs +18/−12
• Command/Copy.hs +1/−1
• Command/Get.hs +1/−1
• Command/Info.hs +79/−20
• Command/MetaData.hs +2/−2
• Command/Mirror.hs +1/−1
• Command/Move.hs +1/−1
• Command/Sync.hs +1/−1
• Command/Whereis.hs +2/−3
• Git/Ref.hs +4/−11
• Messages.hs +16/−23
• Messages/Concurrent.hs +15/−18
• Messages/Internal.hs +39/−14
• Messages/JSON.hs +72/−16
• Messages/Progress.hs +48/−32
• Remote/Git.hs +2/−2
• Types/Concurrency.hs +8/−0
• Types/Messages.hs +6/−1
• Utility/FreeDesktop.hs +9/−9
• Utility/Gpg.hs +3/−1
• Utility/JSONStream.hs +0/−68
• Utility/Metered.hs +24/−1
• Utility/Url.hs +7/−1
• Utility/WebApp.hs +1/−1
• cabal.config +0/−3
• doc/git-annex-addurl.mdwn +4/−0
• doc/git-annex-copy.mdwn +9/−0
• doc/git-annex-get.mdwn +5/−1
• doc/git-annex-info.mdwn +3/−3
• doc/git-annex-mirror.mdwn +9/−0
• doc/git-annex-move.mdwn +9/−0
• git-annex.cabal +2/−3
• stack.yaml +1/−0

@@ -56,6 +56,7 @@ import Types.TrustLevel import Types.Group import Types.Messages+import Types.Concurrency import Types.UUID import Types.FileMatcher import Types.NumCopies@@ -101,6 +102,7 @@ 	, remotes :: [Types.Remote.RemoteA Annex] 	, remoteannexstate :: M.Map UUID AnnexState 	, output :: MessageState+	, concurrency :: Concurrency 	, force :: Bool 	, fast :: Bool 	, daemon :: Bool@@ -134,7 +136,6 @@ 	, existinghooks :: M.Map Git.Hook.Hook Bool 	, desktopnotify :: DesktopNotify 	, workers :: [Either AnnexState (Async AnnexState)]-	, concurrentjobs :: Maybe Int 	, activeremotes :: MVar (S.Set (Types.Remote.RemoteA Annex)) 	, keysdbhandle :: Maybe Keys.DbHandle 	, cachedcurrentbranch :: Maybe Git.Branch@@ -151,6 +152,7 @@ 		, remotes = [] 		, remoteannexstate = M.empty 		, output = def+		, concurrency = NonConcurrent 		, force = False 		, fast = False 		, daemon = False@@ -184,7 +186,6 @@ 		, existinghooks = M.empty 		, desktopnotify = mempty 		, workers = []-		, concurrentjobs = Nothing 		, activeremotes = emptyactiveremotes 		, keysdbhandle = Nothing 		, cachedcurrentbranch = Nothing

@@ -159,14 +159,14 @@ originalToAdjusted orig adj = AdjBranch $ Ref $ 	adjustedBranchPrefix ++ base ++ '(' : serialize adj ++ ")"   where-	base = fromRef (Git.Ref.basename orig)+	base = fromRef (Git.Ref.base orig)  adjustedToOriginal :: Branch -> Maybe (Adjustment, OrigBranch) adjustedToOriginal b 	| adjustedBranchPrefix `isPrefixOf` bs = do 		let (base, as) = separate (== '(') (drop prefixlen bs) 		adj <- deserialize (takeWhile (/= ')') as)-		Just (adj, Git.Ref.under "refs/heads" (Ref base))+		Just (adj, Git.Ref.underBase "refs/heads" (Ref base)) 	| otherwise = Nothing   where 	bs = fromRef b

@@ -902,7 +902,7 @@  {- Downloads content from any of a list of urls. -} downloadUrl :: Key -> MeterUpdate -> [Url.URLString] -> FilePath -> Annex Bool-downloadUrl k p urls file = concurrentMeteredFile file (Just p) k $+downloadUrl k p urls file = meteredFile file (Just p) k $ 	go =<< annexWebDownloadCommand <$> Annex.getGitConfig   where 	go Nothing = do

@@ -28,6 +28,7 @@ import Annex.LockPool import Types.Remote (Verification(..)) import qualified Types.Remote as Remote+import Types.Concurrency  import Control.Concurrent import qualified Data.Set as S@@ -180,11 +181,11 @@  - increase total transfer speed.  -} pickRemote :: Observable v => [Remote] -> (Remote -> Annex v) -> Annex v-pickRemote l a = go l =<< Annex.getState Annex.concurrentjobs+pickRemote l a = go l =<< Annex.getState Annex.concurrency   where 	go [] _ = return observeFailure 	go (r:[]) _ = a r-	go rs (Just n) | n > 1 = do+	go rs (Concurrent n) | n > 1 = do 		mv <- Annex.getState Annex.activeremotes 		active <- liftIO $ takeMVar mv 		let rs' = sortBy (inactiveFirst active) rs@@ -193,7 +194,7 @@ 		ok <- a r 		if observeBool ok 			then return ok-			else go rs Nothing+			else go rs NonConcurrent 	goconcurrent mv active [] = do 		liftIO $ putMVar mv active 		return observeFailure

@@ -49,7 +49,7 @@ 	}  {- Makes a note widget be displayed after a field. -}-withNote :: (Monad m, ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v+withNote :: (ToWidget (HandlerSite m) a) => Field m v -> a -> Field m v withNote field note = field { fieldView = newview }   where 	newview theId name attrs val isReq = 

@@ -1,3 +1,40 @@+git-annex (6.20160923) unstable; urgency=medium++  * Rate limit console progress display updates to 10 per second.+    Was updating as frequently as changes were reported, up to hundreds of+    times per second, which used unncessary bandwidth when running git-annex+    over ssh etc.+  * Make --json and --quiet work when used with -J.+    Previously, -J override the other options.+  * addurl, get: Added --json-progress option, which adds progress+    objects to the json output.+  * Remove key:null from git-annex add --json output.+  * copy, move, mirror: Support --json and --json-progress.+  * Improve gpg secret key list parser to deal with changes in gpg 2.1.15.+    Fixes key name display in webapp.+  * info: Support being passed a treeish, and show info about the annexed+    files in it similar to how a directory is handled.+  * sync: Previously, when run in a branch with a slash in its name,+    such as "foo/bar", the sync branch was "synced/bar". That conflicted+    with the sync branch used for branch "bar", so has been changed to+    "synced/foo/bar".+  * Note that if you're using an old version of git-annex to sync with+    a branch with a slash in its name, it won't see some changes synced by+    this version, and this version won't see some changes synced by the older+    version. This is not a problem if there's a central bare repository,+    but may impact other configurations until git-annex is upgraded to this+    version.+  * adjust: Previously, when adjusting a branch with a slash in its name,+    such as "foo/bar", the adjusted branch was "adjusted/bar(unlocked)".+    That conflicted with the adjusted branch used for branch "bar",+    so has been changed to "adjusted/foo/bar(unlocked)"+  * Also, running sync in an adjusted branch did not correctly sync+    changes back to the parent branch when it had a slash in its name.+    This bug has been fixed.+  * addurl, importfeed: Improve behavior when file being added is gitignored.++ -- Joey Hess <id@joeyh.name>  Fri, 23 Sep 2016 09:43:26 -0400+ git-annex (6.20160907) unstable; urgency=medium    * Windows: Handle shebang in external special remote program.

@@ -13,6 +13,7 @@ import qualified Annex import Annex.Concurrent import Types.Command+import Types.Concurrency import Messages.Concurrent import Types.Messages @@ -50,9 +51,9 @@  - This should only be run in the seek stage.  -} commandAction :: CommandStart -> Annex ()-commandAction a = withOutputType go +commandAction a = go =<< Annex.getState Annex.concurrency   where-	go o@(ConcurrentOutput n _) = do+	go (Concurrent n) = do 		ws <- Annex.getState Annex.workers 		(st, ws') <- if null ws 			then do@@ -62,9 +63,9 @@ 				l <- liftIO $ drainTo (n-1) ws 				findFreeSlot l 		w <- liftIO $ async-			$ snd <$> Annex.run st (inOwnConsoleRegion o run)+			$ snd <$> Annex.run st (inOwnConsoleRegion (Annex.output st) run) 		Annex.changeState $ \s -> s { Annex.workers = Right w:ws' }-	go _  =	run+	go NonConcurrent = run 	run = void $ includeCommandAction a  {- Waits for any forked off command actions to finish.@@ -151,19 +152,21 @@ {- Do concurrent output when that has been requested. -} allowConcurrentOutput :: Annex a -> Annex a #ifdef WITH_CONCURRENTOUTPUT-allowConcurrentOutput a = go =<< Annex.getState Annex.concurrentjobs+allowConcurrentOutput a = go =<< Annex.getState Annex.concurrency   where-	go Nothing = a-	go (Just n) = ifM (liftIO concurrentOutputSupported)+	go NonConcurrent = a+	go (Concurrent _) = ifM (liftIO concurrentOutputSupported) 		( Regions.displayConsoleRegions $-			goconcurrent (ConcurrentOutput n True)-		, goconcurrent (ConcurrentOutput n False)+			goconcurrent True+		, goconcurrent False 		)-	goconcurrent o = bracket_ (setup o) cleanup a-	setup = Annex.setOutput+	goconcurrent b = bracket_ (setup b) cleanup a+	setup = setconcurrentenabled 	cleanup = do 		finishCommandActions-		Annex.setOutput NormalOutput+		setconcurrentenabled False+	setconcurrentenabled b = Annex.changeState $ \s ->+		s { Annex.output = (Annex.output s) { concurrentOutputEnabled = b } } #else allowConcurrentOutput = id #endif

@@ -21,6 +21,7 @@ import Types.Command import Types.DeferredParse import Types.DesktopNotify+import Types.Concurrency import qualified Annex import qualified Remote import qualified Limit@@ -285,12 +286,19 @@ 	shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h <> hidden )  jsonOption :: GlobalOption-jsonOption = globalFlag (Annex.setOutput JSONOutput)+jsonOption = globalFlag (Annex.setOutput (JSONOutput False)) 	( long "json" <> short 'j' 	<> help "enable JSON output" 	<> hidden 	) +jsonProgressOption :: GlobalOption+jsonProgressOption = globalFlag (Annex.setOutput (JSONOutput True))+	( long "json-progress" <> short 'j'+	<> help "include progress in JSON output"+	<> hidden+	)+ -- Note that a command that adds this option should wrap its seek -- action in `allowConcurrentOutput`. jobsOption :: GlobalOption@@ -302,7 +310,7 @@ 		)   where 	set n = do-		Annex.changeState $ \s -> s { Annex.concurrentjobs = Just n }+		Annex.changeState $ \s -> s { Annex.concurrency = Concurrent n } 		c <- liftIO getNumCapabilities 		when (n > c) $ 			liftIO $ setNumCapabilities n

@@ -19,6 +19,7 @@ import qualified Command.Add import Annex.Content import Annex.Ingest+import Annex.CheckIgnore import Annex.UUID import Logs.Web import Types.KeySource@@ -31,7 +32,7 @@ import qualified Utility.Quvi as Quvi  cmd :: Command-cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOption] $+cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOption, jsonProgressOption] $ 	command "addurl" SectionCommon "add urls to annex" 		(paramRepeating paramUrl) (seek <$$> optParser) @@ -157,7 +158,7 @@ 	geturi = next $ isJust <$> downloadRemoteFile r relaxed uri file sz  downloadRemoteFile :: Remote -> Bool -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key)-downloadRemoteFile r relaxed uri file sz = do+downloadRemoteFile r relaxed uri file sz = checkCanAdd file $ do 	let urlkey = Backend.URL.fromUrl uri sz 	liftIO $ createDirectoryIfMissing True (parentDir file) 	ifM (Annex.getState Annex.fast <||> pure relaxed)@@ -236,7 +237,7 @@ 	geturl = next $ isJust <$> addUrlFileQuvi relaxed quviurl videourl file  addUrlFileQuvi :: Bool -> URLString -> URLString -> FilePath -> Annex (Maybe Key)-addUrlFileQuvi relaxed quviurl videourl file = stopUnless (doesNotExist file) $ do+addUrlFileQuvi relaxed quviurl videourl file = checkCanAdd file $ do 	let key = Backend.URL.fromUrl quviurl Nothing 	ifM (pure relaxed <||> Annex.getState Annex.fast) 		( do@@ -285,21 +286,13 @@ 		)  addUrlFile :: Bool -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key)-addUrlFile relaxed url urlinfo file = stopUnless (doesNotExist file) $ do+addUrlFile relaxed url urlinfo file = checkCanAdd file $ do 	liftIO $ createDirectoryIfMissing True (parentDir file) 	ifM (Annex.getState Annex.fast <||> pure relaxed) 		( nodownload url urlinfo file 		, downloadWeb url urlinfo file 		) -doesNotExist :: FilePath -> Annex Bool-doesNotExist file = go =<< liftIO (catchMaybeIO $ getSymbolicLinkStatus file)-  where-	go Nothing = return True-	go (Just _) = do-		warning $ file ++ " already exists and is not annexed; not overwriting"-		return False- downloadWeb :: URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) downloadWeb url urlinfo file = do 	let dummykey = addSizeUrlKey urlinfo $ Backend.URL.fromUrl url Nothing@@ -400,3 +393,16 @@   where 	addprefix f = maybe f (++ f) (prefixOption o) 	addsuffix f = maybe f (f ++) (suffixOption o)++checkCanAdd :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)+checkCanAdd file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file))+	( do+		warning $ file ++ " already exists and is not annexed; not overwriting"+		return Nothing+	, ifM ((not <$> Annex.getState Annex.force) <&&> checkIgnored file)+		( do+			warning $ "not adding " ++ file ++ " which is .gitignored (use --force to override)"+			return Nothing+		, a+		)+	)

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

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

@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2011-2014 Joey Hess <id@joeyh.name>+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -24,6 +24,7 @@ import Utility.DiskFree import Annex.Content import Annex.UUID+import Annex.CatFile import Logs.UUID import Logs.Trust import Logs.Location@@ -31,6 +32,7 @@ import Remote import Config import Git.Config (boolConfig)+import qualified Git.LsTree as LsTree import Utility.Percentage import Types.Transfer import Logs.Transfer@@ -136,7 +138,7 @@ 					Right u -> uuidInfo o u 					Left _ -> ifAnnexed p  						(fileInfo o p)-						(noInfo p)+						(treeishInfo o p) 	)   where 	isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)@@ -144,17 +146,33 @@ noInfo :: String -> Annex () noInfo s = do 	showStart "info" s-	showNote $ "not a directory or an annexed file or a remote or a uuid"+	showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid" 	showEndFail  dirInfo :: InfoOptions -> FilePath -> Annex () dirInfo o dir = showCustom (unwords ["info", dir]) $ do-	stats <- selStats (tostats dir_fast_stats) (tostats dir_slow_stats)+	stats <- selStats+		(tostats (dir_name:tree_fast_stats True))+		(tostats tree_slow_stats) 	evalStateT (mapM_ showStat stats) =<< getDirStatInfo o dir 	return True   where 	tostats = map (\s -> s dir) +treeishInfo :: InfoOptions -> String -> Annex ()+treeishInfo o t = do+	mi <- getTreeStatInfo o (Git.Ref t)+	case mi of+		Nothing -> noInfo t+		Just i -> showCustom (unwords ["info", t]) $ do+			stats <- selStats +				(tostats (tree_name:tree_fast_stats False)) +				(tostats tree_slow_stats)+			evalStateT (mapM_ showStat stats) i+			return True+  where+	tostats = map (\s -> s t)+ fileInfo :: InfoOptions -> FilePath -> Key -> Annex () fileInfo o file k = showCustom (unwords ["info", file]) $ do 	evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o)@@ -192,27 +210,29 @@ 	, transfer_list 	, disk_size 	]+ global_slow_stats :: [Stat] global_slow_stats =  	[ tmp_size 	, bad_data_size 	, local_annex_keys 	, local_annex_size-	, known_annex_files-	, known_annex_size+	, known_annex_files True+	, known_annex_size True 	, bloom_info 	, backend_usage 	]-dir_fast_stats :: [FilePath -> Stat]-dir_fast_stats =-	[ dir_name-	, const local_annex_keys++tree_fast_stats :: Bool -> [FilePath -> Stat]+tree_fast_stats isworktree =+	[ const local_annex_keys 	, const local_annex_size-	, const known_annex_files-	, const known_annex_size+	, const (known_annex_files isworktree)+	, const (known_annex_size isworktree) 	]-dir_slow_stats :: [FilePath -> Stat]-dir_slow_stats =++tree_slow_stats :: [FilePath -> Stat]+tree_slow_stats = 	[ const numcopies_stats 	, const reposizes_stats 	]@@ -295,6 +315,9 @@ dir_name :: FilePath -> Stat dir_name dir = simpleStat "directory" $ pure dir +tree_name :: String -> Stat+tree_name t = simpleStat "tree" $ pure t+ file_name :: FilePath -> Stat file_name file = simpleStat "file" $ pure file @@ -337,13 +360,19 @@ remote_annex_size u = simpleStat "remote annex size" $ 	showSizeKeys =<< cachedRemoteData u -known_annex_files :: Stat-known_annex_files = stat "annexed files in working tree" $ json show $-	countKeys <$> cachedReferencedData+known_annex_files :: Bool -> Stat+known_annex_files isworktree = +	stat ("annexed files in " ++ treeDesc isworktree) $ json show $+		countKeys <$> cachedReferencedData -known_annex_size :: Stat-known_annex_size = simpleStat "size of annexed files in working tree" $-	showSizeKeys =<< cachedReferencedData+known_annex_size :: Bool -> Stat+known_annex_size isworktree = +	simpleStat ("size of annexed files in " ++ treeDesc isworktree) $+		showSizeKeys =<< cachedReferencedData+  +treeDesc :: Bool -> String+treeDesc True = "working tree"+treeDesc False = "tree"  tmp_size :: Stat tmp_size = staleSize "temporary object directory size" gitAnnexTmpObjectDir@@ -522,6 +551,36 @@ 				return $! (presentdata', referenceddata', numcopiesstats', repodata') 			, return vs 			)++getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo)+getTreeStatInfo o r = do+	fast <- Annex.getState Annex.fast+	(ls, cleanup) <- inRepo $ LsTree.lsTree r+	(presentdata, referenceddata, repodata) <- go fast ls initial+	ifM (liftIO cleanup)+		( return $ Just $+			StatInfo (Just presentdata) (Just referenceddata) repodata Nothing o+		, return Nothing+		)+  where+	initial = (emptyKeyData, emptyKeyData, M.empty)+	go _ [] vs = return vs+	go fast (l:ls) vs@(presentdata, referenceddata, repodata) = do+		mk <- catKey (LsTree.sha l)+		case mk of+			Nothing -> go fast ls vs+			Just key -> do+				!presentdata' <- ifM (inAnnex key)+					( return $ addKey key presentdata+					, return presentdata+					)+				let !referenceddata' = addKey key referenceddata+				!repodata' <- if fast+					then return repodata+					else do+						locs <- Remote.keyLocations key+						return (updateRepoData key locs repodata)+				go fast ls $! (presentdata', referenceddata', repodata')  emptyKeyData :: KeyData emptyKeyData = KeyData 0 0 0 M.empty

@@ -78,8 +78,8 @@ 				(startKeys now o) 				(seeker $ whenAnnexed $ start now o) 				(forFiles o)-		Batch -> withOutputType $ \ot -> case ot of-			JSONOutput -> batchInput parseJSONInput $+		Batch -> withMessageState $ \s -> case outputType s of+			JSONOutput _ -> batchInput parseJSONInput $ 				commandAction . startBatch now 			_ -> error "--batch is currently only supported in --json mode" 

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

@@ -178,7 +178,7 @@ 	autoMergeFrom tomerge b mergeconfig commitmode  syncBranch :: Git.Branch -> Git.Branch-syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch . fromAdjustedBranch+syncBranch = Git.Ref.underBase "refs/heads/synced" . fromDirectBranch . fromAdjustedBranch  remoteBranch :: Remote -> Git.Ref -> Git.Ref remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote

@@ -105,7 +105,6 @@ showRemoteUrls remotemap (uu, us) 	| null us = noop 	| otherwise = case M.lookup uu remotemap of-		Just r -> do-			let ls = unlines $ map (\u -> name r ++ ": " ++ u) us -			outputMessage noop ('\n' : indent ls ++ "\n")+		Just r -> showLongNote $ +			unlines $ map (\u -> name r ++ ": " ++ u) us  		Nothing -> noop

@@ -28,23 +28,16 @@ describe :: Ref -> String describe = fromRef . base -{- Often git refs are fully qualified (eg: refs/heads/master).- - Converts such a fully qualified ref into a base ref (eg: master). -}+{- Often git refs are fully qualified + - (eg refs/heads/master or refs/remotes/origin/master).+ - Converts such a fully qualified ref into a base ref+ - (eg: master or origin/master). -} base :: Ref -> Ref base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef   where 	remove prefix s 		| prefix `isPrefixOf` s = drop (length prefix) s 		| otherwise = s--{- Gets the basename of any qualified ref. -}-basename :: Ref -> Ref-basename = Ref . reverse . takeWhile (/= '/') . reverse . fromRef--{- Given a directory and any ref, takes the basename of the ref and puts- - it under the directory. -}-under :: String -> Ref -> Ref-under dir r = Ref $ dir ++ "/" ++ fromRef (basename r)  {- Given a directory such as "refs/remotes/origin", and a ref such as  - refs/heads/master, yields a version of that ref under the directory,

@@ -27,7 +27,7 @@ 	earlyWarning, 	warningIO, 	indent,-	JSONChunk(..),+	JSON.JSONChunk(..), 	maybeShowJSON, 	showFullJSON, 	showCustom,@@ -40,7 +40,7 @@ 	commandProgressDisabled, 	outputMessage, 	implicitMessage,-	withOutputType,+	withMessageState, ) where  import System.Log.Logger@@ -54,7 +54,6 @@ import Types.ActionItem import Messages.Internal import qualified Messages.JSON as JSON-import Utility.JSONStream (JSONChunk(..)) import qualified Annex  showStart :: String -> FilePath -> Annex ()@@ -85,7 +84,7 @@ 			Annex.changeState $ \s -> s { Annex.output = st' } 		| sideActionBlock st == InBlock = return () 		| otherwise = p-	p = outputMessage q $ "(" ++ m ++ "...)\n"+	p = outputMessage JSON.none $ "(" ++ m ++ "...)\n" 			 showStoringStateAction :: Annex () showStoringStateAction = showSideAction "recording state in git"@@ -110,7 +109,7 @@ {- Make way for subsequent output of a command. -} showOutput :: Annex () showOutput = unlessM commandProgressDisabled $-	outputMessage q "\n"+	outputMessage JSON.none "\n"  showLongNote :: String -> Annex () showLongNote s = outputMessage (JSON.note s) ('\n' : indent s ++ "\n")@@ -140,7 +139,7 @@ warning' :: Bool -> String -> Annex () warning' makeway w = do 	when makeway $-		outputMessage q "\n"+		outputMessage JSON.none "\n" 	outputError (w ++ "\n")  {- Not concurrent output safe. -}@@ -154,18 +153,12 @@ indent = intercalate "\n" . map (\l -> "  " ++ l) . lines  {- Shows a JSON chunk only when in json mode. -}-maybeShowJSON :: JSONChunk v -> Annex ()-maybeShowJSON v = withOutputType $ liftIO . go-  where-	go JSONOutput = JSON.add v-	go _ = return ()+maybeShowJSON :: JSON.JSONChunk v -> Annex ()+maybeShowJSON v = void $ withMessageState $ outputJSON (JSON.add v)  {- Shows a complete JSON value, only when in json mode. -}-showFullJSON :: JSONChunk v -> Annex Bool-showFullJSON v = withOutputType $ liftIO . go-  where-	go JSONOutput = JSON.complete v >> return True-	go _ = return False+showFullJSON :: JSON.JSONChunk v -> Annex Bool+showFullJSON v = withMessageState $ outputJSON (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@@ -179,10 +172,10 @@ 	outputMessage (JSON.end r) ""  showHeader :: String -> Annex ()-showHeader h = outputMessage q $ (h ++ ": ")+showHeader h = outputMessage JSON.none $ (h ++ ": ")  showRaw :: String -> Annex ()-showRaw s = outputMessage q (s ++ "\n")+showRaw s = outputMessage JSON.none (s ++ "\n")  setupConsole :: IO () setupConsole = do@@ -216,11 +209,11 @@ {- Should commands that normally output progress messages have that  - output disabled? -} commandProgressDisabled :: Annex Bool-commandProgressDisabled = withOutputType $ \t -> return $ case t of-	QuietOutput -> True-	JSONOutput -> True-	NormalOutput -> False-	ConcurrentOutput {} -> True+commandProgressDisabled = withMessageState $ \s -> return $+	case outputType s of+		QuietOutput -> True+		JSONOutput _ -> True+		NormalOutput -> concurrentOutputEnabled s  {- Use to show a message that is displayed implicitly, and so might be  - disabled when running a certian command that needs more control over its

@@ -31,13 +31,13 @@  - When built without concurrent-output support, the fallback action is run  - instead.  -}-concurrentMessage :: OutputType -> Bool -> String -> Annex () -> Annex ()+concurrentMessage :: MessageState -> Bool -> String -> Annex () -> Annex () #ifdef WITH_CONCURRENTOUTPUT-concurrentMessage o iserror msg fallback -	| concurrentOutputEnabled o =+concurrentMessage s iserror msg fallback +	| concurrentOutputEnabled s = 		go =<< consoleRegion <$> Annex.getState Annex.output #else-concurrentMessage _o _iserror _msg fallback +concurrentMessage _s _iserror _msg fallback  #endif 	| otherwise = fallback #ifdef WITH_CONCURRENTOUTPUT@@ -50,8 +50,8 @@ 		-- console regions are in use, so set the errflag 		-- to get it to display to stderr later. 		when iserror $ do-			Annex.changeState $ \s ->-				s { Annex.output = (Annex.output s) { consoleRegionErrFlag = True } }+			Annex.changeState $ \st ->+				st { Annex.output = (Annex.output st) { consoleRegionErrFlag = True } } 		liftIO $ atomically $ do 			Regions.appendConsoleRegion r msg 			rl <- takeTMVar Regions.regionList@@ -68,24 +68,24 @@  - When not at a console, a region is not displayed until the action is  - complete.  -}-inOwnConsoleRegion :: OutputType -> Annex a -> Annex a+inOwnConsoleRegion :: MessageState -> Annex a -> Annex a #ifdef WITH_CONCURRENTOUTPUT-inOwnConsoleRegion o a-	| concurrentOutputEnabled o = do+inOwnConsoleRegion s a+	| concurrentOutputEnabled s = do 		r <- mkregion 		setregion (Just r) 		eret <- tryNonAsync a `onException` rmregion r 		case eret of 			Left e -> do 				-- Add error message to region before it closes.-				concurrentMessage o True (show e) noop+				concurrentMessage s True (show e) noop 				rmregion r 				throwM e 			Right ret -> do 				rmregion r 				return ret #else-inOwnConsoleRegion _o a+inOwnConsoleRegion _s a #endif 	| otherwise = a #ifdef WITH_CONCURRENTOUTPUT@@ -94,12 +94,13 @@ 	-- a message is added to it. This avoids unnecessary screen 	-- updates when a region does not turn out to need to be used. 	mkregion = Regions.newConsoleRegion Regions.Linear ""-	setregion r = Annex.changeState $ \s -> s { Annex.output = (Annex.output s) { consoleRegion = r } }+	setregion r = Annex.changeState $ \st -> st+		{ Annex.output = (Annex.output st) { consoleRegion = r } } 	rmregion r = do 		errflag <- consoleRegionErrFlag <$> Annex.getState Annex.output 		let h = if errflag then Console.StdErr else Console.StdOut-		Annex.changeState $ \s ->-			s { Annex.output = (Annex.output s) { consoleRegionErrFlag = False } }+		Annex.changeState $ \st -> st+			{ Annex.output = (Annex.output st) { consoleRegionErrFlag = False } } 		setregion Nothing 		liftIO $ atomically $ do 			t <- Regions.getConsoleRegion r@@ -135,7 +136,3 @@ #else concurrentOutputSupported = return False #endif--concurrentOutputEnabled :: OutputType -> Bool-concurrentOutputEnabled (ConcurrentOutput _ b) = b-concurrentOutputEnabled _ = False

@@ -1,6 +1,6 @@ {- git-annex output messages, including concurrent output to display regions  -- - Copyright 2010-2015 Joey Hess <id@joeyh.name>+ - Copyright 2010-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -11,26 +11,51 @@ import Annex import Types.Messages import Messages.Concurrent+import Messages.JSON -withOutputType :: (OutputType -> Annex a) -> Annex a-withOutputType a = outputType <$> Annex.getState Annex.output >>= a -outputMessage :: IO () -> String -> Annex ()-outputMessage json s = withOutputType go+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+	NormalOutput+		| concurrentOutputEnabled s -> concurrentMessage s False msg q+		| otherwise -> liftIO $ flushed $ putStr msg+	JSONOutput _ -> void $ outputJSON 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 _+		| endjson -> do+			Annex.changeState $ \st -> +				st { Annex.output = s { jsonBuffer = Nothing } }+			maybe noop (liftIO . flushed . emit) json+			return True+		| otherwise -> do+			Annex.changeState $ \st ->+			        st { Annex.output = s { jsonBuffer = json } }+			return True+	_ -> return False   where-	go NormalOutput = liftIO $-		flushed $ putStr s-	go QuietOutput = q-	go o@(ConcurrentOutput {}) = concurrentMessage o False s q-	go JSONOutput = liftIO $ flushed json+	(json, endjson) = case jsonbuilder i of+		Nothing -> (jsonBuffer s, False)+		(Just (j, e)) -> (Just j, e)+	i = case jsonBuffer s of+		Nothing -> Nothing+		Just b -> Just (b, False)  outputError :: String -> Annex ()-outputError s = withOutputType go+outputError msg = withMessageState $ \s ->+	if concurrentOutputEnabled s+		then concurrentMessage s True msg go+		else go   where-	go o@(ConcurrentOutput {}) = concurrentMessage o True s (go NormalOutput)-	go _ = liftIO $ do+	go = liftIO $ do 		hFlush stdout-		hPutStr stderr s+		hPutStr stderr msg 		hFlush stderr  q :: Monad m => m ()

@@ -5,14 +5,19 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, GADTs #-}  module Messages.JSON (+	JSONBuilder,+	JSONChunk(..),+	emit,+	none, 	start, 	end, 	note, 	add, 	complete,+	progress, 	DualDisp(..), 	ObjectMap(..), 	JSONActionItem(..),@@ -23,15 +28,39 @@ import qualified Data.Map as M import qualified Data.Text as T import qualified Data.ByteString.Lazy as B+import qualified Data.HashMap.Strict as HM import System.IO+import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent+import Data.Maybe import Data.Monoid import Prelude -import qualified Utility.JSONStream as Stream import Types.Key+import Utility.Metered+import Utility.Percentage -start :: String -> Maybe FilePath -> Maybe Key -> IO ()-start command file key = B.hPut stdout $ Stream.start $ Stream.AesonObject o+-- A global lock to avoid concurrent threads emitting json at the same time.+{-# NOINLINE emitLock #-}+emitLock :: MVar ()+emitLock = unsafePerformIO $ newMVar ()++emit :: Object -> IO ()+emit o = do+	takeMVar emitLock+	B.hPut stdout (encode o)+	putStr "\n"+	putMVar emitLock ()++-- Building up a JSON object can be done by first using start,+-- then add and note any number of times, and finally complete.+type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool)++none :: JSONBuilder+none = id++start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder+start command file key _ = Just (o, False)   where 	Object o = toJSON $ JSONActionItem 		{ itemCommand = Just command@@ -40,18 +69,43 @@ 		, itemAdded = Nothing 		} -end :: Bool -> IO ()-end b = B.hPut stdout $ Stream.add (Stream.JSONChunk [("success", b)]) `B.append` Stream.end+end :: Bool -> JSONBuilder+end b (Just (o, _)) = Just (HM.insert "success" (toJSON b) o, True)+end _ Nothing = Nothing -note :: String -> IO ()-note s = add (Stream.JSONChunk [("note", s)])+note :: String -> JSONBuilder+note s (Just (o, e)) = Just (HM.insert "note" (toJSON s) o, e)+note _ Nothing = Nothing -add :: Stream.JSONChunk a -> IO ()-add = B.hPut stdout . Stream.add+data JSONChunk v where+	AesonObject :: Object -> JSONChunk Object+	JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)] -complete :: Stream.JSONChunk a -> IO ()-complete v = B.hPut stdout $ Stream.start v `B.append` Stream.end+add :: JSONChunk v -> JSONBuilder+add v (Just (o, e)) = Just (HM.union o' o, e)+  where+	Object o' = case v of+		AesonObject ao -> Object ao+		JSONChunk l -> object (map mkPair l)+	mkPair (s, d) = (T.pack s, toJSON d)+add _ Nothing = Nothing +complete :: JSONChunk v -> JSONBuilder+complete v _ = add v (Just (HM.empty, True))++-- Show JSON formatted progress, including the current state of the JSON +-- object for the action being performed.+progress :: Maybe Object -> Integer -> BytesProcessed -> IO ()+progress maction size bytesprocessed = emit $ case maction of+	Just action -> HM.insert "action" (Object action) o+	Nothing -> o+  where+	n = fromBytesProcessed bytesprocessed :: Integer+	Object o = object+		[ "byte-progress" .= n+		, "percent-progress" .= showPercentage 2 (percentage size n)+		]+ -- A value that can be displayed either normally, or as JSON. data DualDisp = DualDisp 	{ dispNormal :: String@@ -84,10 +138,12 @@ 	deriving (Show)  instance ToJSON (JSONActionItem a) where-	toJSON i = object-		[ "command" .= itemCommand i-		, "key" .= (toJSON (itemKey i))-		, "file" .= itemFile i+	toJSON i = object $ catMaybes+		[ Just $ "command" .= itemCommand i+		, case itemKey i of+			Nothing -> Nothing+			Just k -> Just $ "key" .= toJSON k+		, Just $ "file" .= itemFile i 		-- itemAdded is not included; must be added later by 'add' 		] 

@@ -11,11 +11,11 @@  import Common import Messages-import Messages.Internal import Utility.Metered import Types import Types.Messages import Types.Key+import qualified Messages.JSON as JSON  #ifdef WITH_CONCURRENTOUTPUT import Messages.Concurrent@@ -30,61 +30,77 @@ {- Shows a progress meter while performing a transfer of a key.  - The action is passed a callback to use to update the meter. -} metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a-metered combinemeterupdate key a = case keySize key of+metered othermeter key a = case keySize key of 	Nothing -> nometer-	Just size -> withOutputType (go $ fromInteger size)+	Just size -> withMessageState (go $ fromInteger size)   where-	go _ QuietOutput = nometer-	go _ JSONOutput = nometer-	go size NormalOutput = do+	go _ (MessageState { outputType = QuietOutput }) = nometer+	go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do 		showOutput 		(progress, meter) <- mkmeter size-		r <- a $ \n -> liftIO $ do+		m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do 			setP progress $ fromBytesProcessed n 			displayMeter stdout meter-			maybe noop (\m -> m n) combinemeterupdate+		r <- a (combinemeter m) 		liftIO $ clearMeter stdout meter 		return r+	go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = #if WITH_CONCURRENTOUTPUT-	go size o@(ConcurrentOutput {})-		| concurrentOutputEnabled o = withProgressRegion $ \r -> do+		withProgressRegion $ \r -> do 			(progress, meter) <- mkmeter size-			a $ \n -> liftIO $ do+			m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do 				setP progress $ fromBytesProcessed n 				s <- renderMeter meter 				Regions.setConsoleRegion r ("\n" ++ s)-				maybe noop (\m -> m n) combinemeterupdate+			a (combinemeter m) #else-	go _size _o+		nometer #endif-		| otherwise = nometer+	go _ (MessageState { outputType = JSONOutput False }) = nometer+	go size (MessageState { outputType = JSONOutput True }) = do+		buf <- withMessageState $ return . jsonBuffer+		m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $+			JSON.progress buf size+		a (combinemeter m)  	mkmeter size = do 		progress <- liftIO $ newProgress "" size 		meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1) 		return (progress, meter) -	nometer = a (const noop)+	nometer = a $ combinemeter (const noop) -{- Use when the progress meter is only desired for concurrent- - output; as when a command's own progress output is preferred. -}-concurrentMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a-concurrentMetered combinemeterupdate key a = withOutputType go-  where-	go (ConcurrentOutput {}) = metered combinemeterupdate key a-	go _ = a (fromMaybe nullMeterUpdate combinemeterupdate)+	combinemeter m = case othermeter of+		Nothing -> m+		Just om -> combineMeterUpdate m om -{- Poll file size to display meter, but only for concurrent output. -}-concurrentMeteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a-concurrentMeteredFile file combinemeterupdate key a = withOutputType go-  where-	go (ConcurrentOutput {}) = metered combinemeterupdate key $ \p ->-		watchFileSize file p a-	go _ = a+{- Use when the command's own progress output is preferred.+ - The command's output will be suppressed and git-annex's progress meter+ - used for concurrent output, and json progress. -}+commandMetered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a+commandMetered combinemeterupdate key a = +	withMessageState $ \s -> if needOutputMeter s+		then metered combinemeterupdate key a+		else a (fromMaybe nullMeterUpdate combinemeterupdate) +{- Poll file size to display meter, but only when concurrent output or+ - json progress needs the information. -}+meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a+meteredFile file combinemeterupdate key a = +	withMessageState $ \s -> if needOutputMeter s+		then metered combinemeterupdate key $ \p ->+			watchFileSize file p a+		else a++needOutputMeter :: MessageState -> Bool+needOutputMeter s = case outputType s of+	JSONOutput True -> True+	NormalOutput | concurrentOutputEnabled s -> True+	_ -> False+ {- Progress dots. -} showProgressDots :: Annex ()-showProgressDots = outputMessage q "."+showProgressDots = outputMessage JSON.none "."  {- Runs a command, that may output progress to either stdout or  - stderr, as well as other messages.@@ -119,9 +135,9 @@  - messing it up with interleaved stderr from a command.  -} mkStderrEmitter :: Annex (String -> IO ())-mkStderrEmitter = withOutputType go+mkStderrEmitter = withMessageState go   where #ifdef WITH_CONCURRENTOUTPUT-	go o | concurrentOutputEnabled o = return Console.errorConcurrent+	go s | concurrentOutputEnabled s = return Console.errorConcurrent #endif 	go _ = return (hPutStrLn stderr)

@@ -421,7 +421,7 @@ copyFromRemote r key file dest p 	| Git.repoIsHttp (repo r) = unVerified $ 		Annex.Content.downloadUrl key p (keyUrls r key) dest-	| otherwise = concurrentMetered (Just p) key $+	| otherwise = commandMetered (Just p) key $ 		copyFromRemote' r key file dest  copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)@@ -531,7 +531,7 @@ {- Tries to copy a key's content to a remote's annex. -} copyToRemote :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool copyToRemote r key file meterupdate = -	concurrentMetered (Just meterupdate) key $+	commandMetered (Just meterupdate) key $ 		copyToRemote' r key file  copyToRemote' :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool

@@ -0,0 +1,8 @@+{- Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Types.Concurrency where++data Concurrency = NonConcurrent | Concurrent Int

@@ -10,12 +10,13 @@ module Types.Messages where  import Data.Default+import qualified Data.Aeson as Aeson  #ifdef WITH_CONCURRENTOUTPUT import System.Console.Regions (ConsoleRegion) #endif -data OutputType = NormalOutput | QuietOutput | ConcurrentOutput Int Bool | JSONOutput+data OutputType = NormalOutput | QuietOutput | JSONOutput Bool 	deriving (Show)  data SideActionBlock = NoBlock | StartBlock | InBlock@@ -23,22 +24,26 @@  data MessageState = MessageState 	{ outputType :: OutputType+	, concurrentOutputEnabled :: Bool 	, sideActionBlock :: SideActionBlock 	, implicitMessages :: Bool #ifdef WITH_CONCURRENTOUTPUT 	, consoleRegion :: Maybe ConsoleRegion 	, consoleRegionErrFlag :: Bool #endif+	, jsonBuffer :: Maybe Aeson.Object 	}  instance Default MessageState   where 	def = MessageState 		{ outputType = NormalOutput+		, concurrentOutputEnabled = False 		, sideActionBlock = NoBlock 		, implicitMessages = True  #ifdef WITH_CONCURRENTOUTPUT 		, consoleRegion = Nothing 		, consoleRegionErrFlag = False #endif+		, jsonBuffer = Nothing 		}

@@ -29,16 +29,13 @@ ) where  import Utility.Exception-import Utility.Path import Utility.UserInfo import Utility.Process-import Utility.PartialPrelude-import Utility.Directory  import System.Environment import System.FilePath+import System.Directory import Data.List-import Data.String.Utils import Data.Maybe import Control.Applicative import Prelude@@ -54,12 +51,13 @@ toString (BoolV b) 	| b = "true" 	| otherwise = "false"-toString(NumericV f) = show f+toString (NumericV f) = show f toString (ListV l) 	| null l = ""-	| otherwise = (intercalate ";" $ map (escapesemi . toString) l) ++ ";"+	| otherwise = (intercalate ";" $ map (concatMap escapesemi . toString) l) ++ ";"   where-	escapesemi = intercalate "\\;" . split ";"+	escapesemi ';' = "\\;"+	escapesemi c = [c]  genDesktopEntry :: String -> String -> Bool -> FilePath -> Maybe String -> [String] -> DesktopEntry genDesktopEntry name comment terminal program icon categories = catMaybes@@ -82,7 +80,7 @@  writeDesktopMenuFile :: DesktopEntry -> String -> IO () writeDesktopMenuFile d file = do-	createDirectoryIfMissing True (parentDir file)+	createDirectoryIfMissing True (takeDirectory file) 	writeFile file $ buildDesktopMenuFile d  {- Path to use for a desktop menu file, in either the systemDataDir or@@ -136,7 +134,9 @@ userDesktopDir :: IO FilePath userDesktopDir = maybe fallback return =<< (parse <$> xdg_user_dir)   where-	parse = maybe Nothing (headMaybe . lines)+	parse s = case lines <$> s of+		Just (l:_) -> Just l+		_ -> Nothing 	xdg_user_dir = catchMaybeIO $ readProcess "xdg-user-dir" ["DESKTOP"] 	fallback = xdgEnvHome "DESKTOP_DIR" "Desktop" 

@@ -178,8 +178,10 @@ 	parse = extract [] Nothing . map (split ":") 	extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) = 		extract ((keyid, decode_c userid):c) Nothing rest-	extract c (Just keyid) rest =+	extract c (Just keyid) rest@(("sec":_):_) = 		extract ((keyid, ""):c) Nothing rest+	extract c (Just keyid) (_:rest) =+		extract c (Just keyid) rest 	extract c _ [] = c 	extract c _ (("sec":_:_:_:keyid:_):rest) = 		extract c (Just keyid) rest

@@ -1,68 +0,0 @@-{- Streaming JSON output.- -- - Copyright 2011, 2016 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--{-# LANGUAGE GADTs #-}--module Utility.JSONStream (-	JSONChunk(..),-	start,-	add,-	end-) where--import Data.Aeson-import qualified Data.Text as T-import qualified Data.ByteString.Lazy as B-import Data.Char-import Data.Word--data JSONChunk v where-	JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)]-	AesonObject :: Object -> JSONChunk Object--encodeJSONChunk :: JSONChunk v -> B.ByteString-encodeJSONChunk (JSONChunk l) = encode $ object $ map mkPair l-  where-	mkPair (s, v) = (T.pack s, toJSON v)-encodeJSONChunk (AesonObject o) = encode o--{- Aeson does not support building up a larger JSON object piece by piece- - with streaming output. To support streaming, a hack:- - The final "}" is left off the JSON, allowing more chunks to be added- - to later. -}-start :: JSONChunk a -> B.ByteString-start a-	| not (B.null b) && B.last b == endchar = B.init b-	| otherwise = bad b-  where-	b = encodeJSONChunk a--add :: JSONChunk a -> B.ByteString-add a-	| not (B.null b) && B.head b == startchar = B.cons addchar (B.drop 1 b)-	| otherwise = bad b-  where-	b = start a--end :: B.ByteString-end = endchar `B.cons` sepchar `B.cons` B.empty--startchar :: Word8-startchar = fromIntegral (ord '{')--endchar :: Word8-endchar = fromIntegral (ord '}')--addchar :: Word8-addchar = fromIntegral (ord ',')--sepchar :: Word8-sepchar = fromIntegral (ord '\n')--bad :: B.ByteString -> a-bad b = error $ "JSON encoder generated unexpected value: " ++ show b-

@@ -1,6 +1,6 @@ {- Metered IO and actions  -- - Copyright 2012-2105 Joey Hess <id@joeyh.name>+ - Copyright 2012-2106 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -}@@ -21,6 +21,8 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Monad.IO.Class (MonadIO)+import Data.Time.Clock+import Data.Time.Clock.POSIX  {- An action that can be run repeatedly, updating it on the bytes processed.  -@@ -259,3 +261,24 @@   where 	p = (proc cmd (toCommand params)) 		{ env = environ }++-- | Limit a meter to only update once per unit of time.+--+-- It's nice to display the final update to 100%, even if it comes soon+-- after a previous update. To make that happen, a total size has to be+-- provided.+rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate+rateLimitMeterUpdate delta totalsize meterupdate = do+	lastupdate <- newMVar (toEnum 0 :: POSIXTime)+	return $ mu lastupdate+  where+	mu lastupdate n@(BytesProcessed i) = case totalsize of+		Just t | i >= t -> meterupdate n+		_ -> do+			now <- getPOSIXTime+			prev <- takeMVar lastupdate+			if now - prev >= delta+				then do+					putMVar lastupdate now+					meterupdate n+				else putMVar lastupdate prev

@@ -136,7 +136,7 @@  - also returning its size and suggested filename if available. -} getUrlInfo :: URLString -> UrlOptions -> IO UrlInfo getUrlInfo url uo = case parseURIRelaxed url of-	Just u -> case parseUrl (show u) of+	Just u -> case parseurlconduit (show u) of 		Just req -> catchJust 			-- When http redirects to a protocol which  			-- conduit does not support, it will throw@@ -215,6 +215,12 @@ 			-- got a length, it's good 			_ | isftp && isJust len -> good 			_ -> dne++#if MIN_VERSION_http_client(0,4,30)+	parseurlconduit = parseUrlThrow+#else+	parseurlconduit = parseUrl+#endif  -- Parse eg: attachment; filename="fname.ext" -- per RFC 2616

@@ -183,7 +183,7 @@  - Note that the usual Yesod error page is bypassed on error, to avoid  - possibly leaking the auth token in urls on that page!  -}-checkAuthToken :: (Monad m, Yesod.MonadHandler m) => (Yesod.HandlerSite m -> AuthToken) -> m Yesod.AuthResult+checkAuthToken :: Yesod.MonadHandler m => (Yesod.HandlerSite m -> AuthToken) -> m Yesod.AuthResult checkAuthToken extractAuthToken = do 	webapp <- Yesod.getYesod 	req <- Yesod.getRequest

@@ -1,3 +0,0 @@--- Temporary to support building with ghc 8.0.1, until all the library--- dependencies get worked out upstream.-allow-newer: base,time,transformers

@@ -88,6 +88,10 @@   Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object. +* `--json-progress`++  Include progress objects in JSON output.+ # CAVEATS  If annex.largefiles is configured, and does not match a file, `git annex

@@ -72,6 +72,15 @@   The [[git-annex-matching-options]](1)   can be used to specify files to copy. +* `--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-progress`++  Include progress objects in JSON output.+ # SEE ALSO  [[git-annex]](1)

@@ -86,7 +86,7 @@   displayed. If the specified file's content is already present, or   it is not an annexed file, a blank line is output in response instead. -  Since the usual progress output while getting a file is verbose and not+  Since the usual output while getting a file is verbose and not   machine-parseable, you may want to use --json in combination with   --batch. @@ -94,6 +94,10 @@    Enable JSON output. This is intended to be parsed by programs that use   git-annex. Each line of output is a JSON object.++* `--json-progress`++  Include progress objects in JSON output.  # SEE ALSO 

@@ -4,13 +4,13 @@  # SYNOPSIS -git annex info `[directory|file|remote|uuid ...]`+git annex info `[directory|file|treeish|remote|uuid ...]`  # DESCRIPTION  Displays statistics and other information for the specified item,-which can be a directory, or a file, or a remote, or the uuid of a-repository.+which can be a directory, or a file, or a treeish, or a remote,+or the uuid of a repository.    When no item is specified, displays statistics and information for the repository as a whole.

@@ -66,6 +66,15 @@   The [[git-annex-matching-options]](1)   can be used to specify files to mirror. +* `--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-progress`++  Include progress objects in JSON output.+ # SEE ALSO  [[git-annex]](1)

@@ -55,6 +55,15 @@   The [[git-annex-matching-options]](1)   can be used to specify files to move. +* `--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-progress`++  Include progress objects in JSON output.+ # SEE ALSO  [[git-annex]](1)

@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20160907+Version: 6.20160923 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -35,7 +35,6 @@ -- make cabal install git-annex work. Extra-Source-Files:   stack.yaml-  cabal.config   README   CHANGELOG   NEWS@@ -949,6 +948,7 @@     Types.BranchState     Types.CleanupActions     Types.Command+    Types.Concurrency     Types.Creds     Types.Crypto     Types.DeferredParse@@ -1016,7 +1016,6 @@     Utility.HumanNumber     Utility.HumanTime     Utility.InodeCache-    Utility.JSONStream     Utility.LinuxMkLibs     Utility.LockFile     Utility.LockFile.LockStatus

@@ -21,5 +21,6 @@ resolver: lts-5.18 extra-deps: - process-1.3.0.0+- concurrent-output-1.7.7 explicit-setup-deps:   git-annex: true