packages feed

git-annex 6.20160619 → 6.20160808

raw patch · 77 files changed

+827/−331 lines, 77 filesdep +unordered-containersdep −jsondep ~http-conduitdep ~persistentdep ~uuid

Dependencies added: unordered-containers

Dependencies removed: json

Dependency ranges changed: http-conduit, persistent, uuid

Files

Annex/Content.hs view
@@ -54,6 +54,7 @@  import Annex.Common import Logs.Location+import Types.Transfer import Logs.Transfer import qualified Git import qualified Annex
Annex/Drop.hs view
@@ -117,10 +117,10 @@ 			)  	dropl fs n = checkdrop fs n Nothing $ \numcopies ->-		Command.Drop.startLocal afile numcopies key preverified+		Command.Drop.startLocal afile (mkActionItem afile) numcopies key preverified  	dropr fs r n  = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies ->-		Command.Drop.startRemote afile numcopies key r+		Command.Drop.startRemote afile (mkActionItem afile) numcopies key r  	slocs = S.fromList locs
Annex/MetaData.hs view
@@ -63,7 +63,7 @@ 	Just '+' -> AddMeta <$> mkMetaField f' <*> v 	Just '-' -> DelMeta <$> mkMetaField f' <*> (Just <$> v) 	Just '?' -> MaybeSetMeta <$> mkMetaField f' <*> v-	_ -> SetMeta <$> mkMetaField f <*> v+	_ -> SetMeta <$> mkMetaField f <*> (S.singleton <$> v)   where 	(f, sv) = separate (== '=') p 	f' = beginning f
Annex/Notification.hs view
@@ -10,7 +10,7 @@ module Annex.Notification (NotifyWitness, notifyTransfer, notifyDrop) where  import Annex.Common-import Logs.Transfer+import Types.Transfer #ifdef WITH_DBUS_NOTIFICATIONS import qualified Annex import Types.DesktopNotify
Annex/Transfer.hs view
@@ -9,7 +9,6 @@  module Annex.Transfer ( 	module X,-	noObserver, 	upload, 	download, 	runTransfer,@@ -20,6 +19,7 @@  import Annex.Common import Logs.Transfer as X+import Types.Transfer as X import Annex.Notification as X import Annex.Perms import Utility.Metered@@ -28,8 +28,6 @@  import Control.Concurrent -type TransferObserver = Bool -> Transfer -> TransferInfo -> Annex ()- class Observable a where 	observeBool :: a -> Bool 	observeFailure :: a@@ -42,16 +40,13 @@ 	observeBool = fst 	observeFailure = (False, UnVerified) -noObserver :: TransferObserver-noObserver _ _ _ = noop--upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v-upload u key f d o a _witness = guardHaveUUID u $ -	runTransfer (Transfer Upload u key) f d o a+upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v+upload u key f d a _witness = guardHaveUUID u $ +	runTransfer (Transfer Upload u key) f d a -download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v-download u key f d o a _witness = guardHaveUUID u $-	runTransfer (Transfer Download u key) f d o a+download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v+download u key f d a _witness = guardHaveUUID u $+	runTransfer (Transfer Download u key) f d a  guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v guardHaveUUID u a@@ -70,7 +65,7 @@  - An upload can be run from a read-only filesystem, and in this case  - no transfer information or lock file is used.  -}-runTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v+runTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v runTransfer = runTransfer' False  {- Like runTransfer, but ignores any existing transfer lock file for the@@ -78,11 +73,11 @@  -  - Note that this may result in confusing progress meter display in the  - webapp, if multiple processes are writing to the transfer info file. -}-alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v+alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v alwaysRunTransfer = runTransfer' True -runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> (MeterUpdate -> Annex v) -> Annex v-runTransfer' ignorelock t file shouldretry transferobserver transferaction = do+runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v+runTransfer' ignorelock t file shouldretry transferaction = do 	info <- liftIO $ startTransferInfo file 	(meter, tfile, metervar) <- mkProgressUpdater t info 	mode <- annexFileMode@@ -94,7 +89,9 @@ 		else do 			v <- retry info metervar $ transferaction meter 			liftIO $ cleanup tfile lck-			transferobserver (observeBool v) t info+			if observeBool v+				then removeFailedTransfer t+				else recordFailedTransfer t info 			return v   where #ifndef mingw32_HOST_OS
Annex/UUID.hs view
@@ -35,8 +35,8 @@ import Config  import qualified Data.UUID as U+import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5-import System.Random import Data.Bits.Utils  configkey :: ConfigKey@@ -44,7 +44,7 @@  {- Generates a random UUID, that does not include the MAC address. -} genUUID :: IO UUID-genUUID = UUID . show <$> (randomIO :: IO U.UUID)+genUUID = UUID . show <$> U4.nextRandom  {- Generates a UUID from a given string, using a namespace.  - Given the same namespace, the same string will always result
Assistant/Alert.hs view
@@ -14,7 +14,7 @@ import Assistant.Alert.Utility import qualified Remote import Utility.Tense-import Logs.Transfer+import Types.Transfer import Types.Distribution import Git.Types (RemoteName)
Assistant/DaemonStatus.hs view
@@ -14,6 +14,7 @@ import Utility.Tmp import Assistant.Types.NetMessager import Utility.NotificationBroadcaster+import Types.Transfer import Logs.Transfer import Logs.Trust import Logs.TimeStamp
Assistant/DeleteRemote.hs view
@@ -12,7 +12,7 @@ import Assistant.Common import Assistant.Types.UrlRenderer import Assistant.TransferQueue-import Logs.Transfer+import Types.Transfer import Logs.Location import Assistant.DaemonStatus import qualified Remote
Assistant/Sync.hs view
@@ -36,7 +36,7 @@ import Assistant.TransferSlots import Assistant.TransferQueue import Assistant.RepoProblem-import Logs.Transfer+import Types.Transfer  import Data.Time.Clock import qualified Data.Map as M
Assistant/Threads/Committer.hs view
@@ -17,7 +17,7 @@ import Assistant.DaemonStatus import Assistant.TransferQueue import Assistant.Drop-import Logs.Transfer+import Types.Transfer import Logs.Location import qualified Annex.Queue import qualified Git.LsFiles
Assistant/Threads/Cronner.hs view
@@ -24,7 +24,7 @@ import Utility.Batch import Assistant.TransferQueue import Annex.Content-import Logs.Transfer+import Types.Transfer import Assistant.Types.UrlRenderer import Assistant.Alert import Remote
Assistant/Threads/Glacier.hs view
@@ -14,6 +14,7 @@ import Utility.ThreadScheduler import qualified Types.Remote as Remote import qualified Remote.Glacier as Glacier+import Types.Transfer import Logs.Transfer import Assistant.DaemonStatus import Assistant.TransferQueue
Assistant/Threads/SanityChecker.hs view
@@ -38,7 +38,7 @@ import Git.Index import Assistant.Unused import Logs.Unused-import Logs.Transfer+import Types.Transfer import Annex.Path import qualified Annex #ifdef WITH_WEBAPP
Assistant/Threads/TransferPoller.hs view
@@ -9,6 +9,7 @@  import Assistant.Common import Assistant.DaemonStatus+import Types.Transfer import Logs.Transfer import Utility.NotificationBroadcaster import qualified Assistant.Threads.TransferWatcher as TransferWatcher
Assistant/Threads/TransferScanner.hs view
@@ -16,6 +16,7 @@ import Assistant.Sync import Assistant.DeleteRemote import Assistant.Types.UrlRenderer+import Types.Transfer import Logs.Transfer import Logs.Location import Logs.Group
Assistant/Threads/TransferWatcher.hs view
@@ -10,6 +10,7 @@ import Assistant.Common import Assistant.DaemonStatus import Assistant.TransferSlots+import Types.Transfer import Logs.Transfer import Utility.DirWatcher import Utility.DirWatcher.Types
Assistant/Threads/Transferrer.hs view
@@ -10,7 +10,7 @@ import Assistant.Common import Assistant.TransferQueue import Assistant.TransferSlots-import Logs.Transfer+import Types.Transfer import Annex.Path import Utility.Batch
Assistant/TransferQueue.hs view
@@ -26,6 +26,7 @@ import Assistant.Common import Assistant.DaemonStatus import Assistant.Types.TransferQueue+import Types.Transfer import Logs.Transfer import Types.Remote import qualified Remote
Assistant/TransferSlots.hs view
@@ -21,6 +21,7 @@ import Assistant.Alert.Utility import Assistant.Commits import Assistant.Drop+import Types.Transfer import Logs.Transfer import Logs.Location import qualified Git
Assistant/TransferrerPool.hs view
@@ -9,7 +9,7 @@  import Assistant.Common import Assistant.Types.TransferrerPool-import Logs.Transfer+import Types.Transfer import Utility.Batch  import qualified Command.TransferKeys as T
Assistant/Types/DaemonStatus.hs view
@@ -10,7 +10,7 @@ import Annex.Common import Assistant.Pairing import Utility.NotificationBroadcaster-import Logs.Transfer+import Types.Transfer import Assistant.Types.ThreadName import Assistant.Types.NetMessager import Assistant.Types.Alert
Assistant/Types/TransferQueue.hs view
@@ -8,7 +8,7 @@ module Assistant.Types.TransferQueue where  import Annex.Common-import Logs.Transfer+import Types.Transfer  import Control.Concurrent.STM import Utility.TList
Assistant/Upgrade.hs view
@@ -16,7 +16,7 @@ import Assistant.DaemonStatus import Utility.Env import Types.Distribution-import Logs.Transfer+import Types.Transfer import Logs.Web import Logs.Presence import Logs.Location
Assistant/WebApp/DashBoard.hs view
@@ -16,6 +16,7 @@ import Assistant.TransferSlots import Assistant.DaemonStatus import Utility.NotificationBroadcaster+import Types.Transfer import Logs.Transfer import Utility.Percentage import Utility.DataUnits
Assistant/WebApp/Types.hs view
@@ -19,7 +19,7 @@ import Utility.NotificationBroadcaster import Utility.WebApp import Utility.Yesod-import Logs.Transfer+import Types.Transfer import Utility.Gpg (KeyId) import Build.SysConfig (packageversion) import Types.ScheduledActivity
CHANGELOG view
@@ -1,3 +1,33 @@+git-annex (6.20160808) unstable; urgency=medium++  * metadata --json output format has changed, adding a inner json object+    named "fields" which contains only the fields and their values.+    This should be easier to parse than the old format, which mixed up+    metadata fields with other keys in the json object.+    Any consumers of the old format will need to be updated.+  * Added metadata --batch option, which allows getting, setting, deleting,+    and modifying metadata for multiple files/keys.+  * Added --branch option to copy, drop, fsck, get, metadata, mirror, move,+    and whereis commands. This option makes git-annex operate on files that+    are included in a specified branch (or other treeish).+  * git-annex.cabal: Temporarily limit to http-conduit <2.2.0+    since aws 0.14.0 is not compatible with the newer version.+  * git-annex.cabal: Temporarily limit to persistent <2.5+    since esqueleto 2.4.3 is not compatible with the newer version.+  * Removed dependency on json library; all JSON is now handled by aeson.+  * When built with uuid-1.3.12, generate more random UUIDs than before.+    (However, this did not impact git-annex much, so a hard depedency has+    not been added on uuid-1.3.12.)+  * info: When run on a file now includes an indication of whether+    the content is present locally.+  * get, move, copy, mirror: Added --failed switch which retries+    failed copies/moves.+  * Re-enable accumulating transfer failure log files for command-line+    actions (disabled in 5.20150522), and remove the log files after+    successful transfers.++ -- Joey Hess <id@joeyh.name>  Mon, 08 Aug 2016 11:42:17 -0400+ git-annex (6.20160619) unstable; urgency=medium    * get, drop: Add --batch and --json options.
CmdLine/Action.hs view
@@ -14,7 +14,6 @@ import Annex.Concurrent import Types.Command import Messages.Concurrent-import Messages.Internal import Types.Messages  import Control.Concurrent.Async
CmdLine/GitAnnex/Options.hs view
@@ -139,27 +139,37 @@ data KeyOptions 	= WantAllKeys 	| WantUnusedKeys+	| WantFailedTransfers 	| WantSpecificKey Key 	| WantIncompleteKeys+	| WantBranchKeys [Branch] -parseKeyOptions :: Bool -> Parser KeyOptions-parseKeyOptions allowincomplete = if allowincomplete-	then base-		<|> flag' WantIncompleteKeys-			( long "incomplete"-			<> help "resume previous downloads"-			)-	else base-  where-	base = parseAllOption-		<|> flag' WantUnusedKeys-			( long "unused" <> short 'U'-			<> help "operate on files found by last run of git-annex unused"-			)-		<|> (WantSpecificKey <$> option (str >>= parseKey)-			( long "key" <> metavar paramKey-			<> help "operate on specified key"-			))+parseKeyOptions :: Parser KeyOptions+parseKeyOptions = parseAllOption+	<|> WantBranchKeys <$> some (option (str >>= pure . Ref)+		( long "branch" <> metavar paramRef+		<> help "operate on files in the specified branch or treeish"+		))+	<|> flag' WantUnusedKeys+		( long "unused" <> short 'U'+		<> help "operate on files found by last run of git-annex unused"+		)+	<|> (WantSpecificKey <$> option (str >>= parseKey)+		( long "key" <> metavar paramKey+		<> help "operate on specified key"+		))++parseFailedTransfersOption :: Parser KeyOptions+parseFailedTransfersOption = flag' WantFailedTransfers+	( long "failed"+	<> help "operate on files that recently failed to be transferred"+	)++parseIncompleteOption :: Parser KeyOptions+parseIncompleteOption = flag' WantIncompleteKeys+	( long "incomplete"+	<> help "resume previous downloads"+	)  parseAllOption :: Parser KeyOptions parseAllOption = flag' WantAllKeys
CmdLine/Seek.hs view
@@ -4,7 +4,7 @@  - the values a user passes to a command, and prepare actions operating  - on them.  -- - 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.  -}@@ -25,6 +25,10 @@ import CmdLine.Action import Logs.Location import Logs.Unused+import Types.Transfer+import Logs.Transfer+import Remote.List+import qualified Remote import Annex.CatFile import Annex.Content @@ -154,42 +158,77 @@ withNothing a [] = seekActions $ return [a] withNothing _ _ = error "This command takes no parameters." -{- Handles the --all, --unused, --key, and --incomplete options,- - which specify particular keys to run an action on.+{- Handles the --all, --branch, --unused, --failed, --key, and+ - --incomplete options, which specify particular keys to run an+ - action on.  -  - In a bare repo, --all is the default.  -  - Otherwise falls back to a regular CommandSeek action on  - whatever params were passed. -}-withKeyOptions :: Maybe KeyOptions -> Bool -> (Key -> CommandStart) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek-withKeyOptions ko auto keyaction = withKeyOptions' ko auto $ \getkeys -> do-	matcher <- Limit.getMatcher-	seekActions $ map (process matcher) <$> getkeys+withKeyOptions +	:: Maybe KeyOptions+	-> Bool+	-> (Key -> ActionItem -> CommandStart)+	-> (CmdParams -> CommandSeek)+	-> CmdParams+	-> CommandSeek+withKeyOptions ko auto keyaction = withKeyOptions' ko auto mkkeyaction   where-	process matcher k = ifM (matcher $ MatchingKey k)-		( keyaction k-		, return Nothing-		)+	mkkeyaction = do+		matcher <- Limit.getMatcher+		return $ \k i ->+			whenM (matcher $ MatchingKey k) $+				commandAction $ keyaction k i -withKeyOptions' :: Maybe KeyOptions -> Bool -> (Annex [Key] -> Annex ()) -> (CmdParams -> CommandSeek) -> CmdParams -> CommandSeek-withKeyOptions' ko auto keyaction fallbackaction params = do+withKeyOptions' +	:: Maybe KeyOptions+	-> Bool+	-> Annex (Key -> ActionItem -> Annex ())+	-> (CmdParams -> CommandSeek)+	-> CmdParams+	-> CommandSeek+withKeyOptions' ko auto mkkeyaction fallbackaction params = do 	bare <- fromRepo Git.repoIsLocalBare 	when (auto && bare) $ 		error "Cannot use --auto in a bare repository" 	case (null params, ko) of 		(True, Nothing)-			| bare -> go auto loggedKeys+			| bare -> noauto $ runkeyaction loggedKeys 			| otherwise -> fallbackaction params 		(False, Nothing) -> fallbackaction params-		(True, Just WantAllKeys) -> go auto loggedKeys-		(True, Just WantUnusedKeys) -> go auto unusedKeys'-		(True, Just (WantSpecificKey k)) -> go auto $ return [k]-		(True, Just WantIncompleteKeys) -> go auto incompletekeys-		(False, Just _) -> error "Can only specify one of file names, --all, --unused, --key, or --incomplete"+		(True, Just WantAllKeys) -> noauto $ runkeyaction loggedKeys+		(True, Just WantUnusedKeys) -> noauto $ runkeyaction unusedKeys'+		(True, Just WantFailedTransfers) -> noauto runfailedtransfers+		(True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k])+		(True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys+		(True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs+		(False, Just _) -> error "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete"   where-	go True _ = error "Cannot use --auto with --all or --unused or --key or --incomplete"-	go False getkeys = keyaction getkeys+	noauto a+		| auto = error "Cannot use --auto with --all or --branch or --unused or --key or --incomplete"+		| otherwise = a 	incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True+	runkeyaction getks = do+		keyaction <- mkkeyaction+		ks <- getks+		forM_ ks $ \k -> keyaction k (mkActionItem k)+	runbranchkeys bs = do+		keyaction <- mkkeyaction+		forM_ bs $ \b -> do+			(l, cleanup) <- inRepo $ LsTree.lsTree b+			forM_ l $ \i -> do+				let bfp = mkActionItem $ BranchFilePath b (LsTree.file i)+				maybe noop (\k -> keyaction k bfp)+					=<< catKey (LsTree.sha i)+			unlessM (liftIO cleanup) $+				error ("git ls-tree " ++ Git.fromRef b ++ " failed")+	runfailedtransfers = do+		keyaction <- mkkeyaction+		rs <- remoteList+		ts <- concat <$> mapM (getFailedTransfers . Remote.uuid) rs+		forM_ ts $ \(t, i) ->+			keyaction (transferKey t) (mkActionItem (t, i))  prepFiltered :: (FilePath -> CommandStart) -> Annex [FilePath] -> Annex [CommandStart] prepFiltered a fs = do@@ -200,9 +239,7 @@ 		( a f , return Nothing )  seekActions :: Annex [CommandStart] -> Annex ()-seekActions gen = do-	as <- gen-	mapM_ commandAction as+seekActions gen = mapM_ commandAction =<< gen  seekHelper :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> [FilePath] -> Annex [FilePath] seekHelper a params = do
Command.hs view
@@ -1,6 +1,6 @@ {- git-annex command infrastructure  -- - 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.  -}@@ -26,6 +26,8 @@ import Annex.Init import Config import Utility.Daemon+import Types.Transfer+import Types.ActionItem  {- Generates a normal Command -} command :: String -> CommandSection -> String -> CmdParamsDesc -> (CmdParamsDesc -> CommandParser) -> Command@@ -90,6 +92,15 @@ {- Stops unless a condition is met. -} stopUnless :: Annex Bool -> Annex (Maybe a) -> Annex (Maybe a) stopUnless c a = ifM c ( a , stop )++{- When acting on a failed transfer, stops unless it was in the specified+ - direction. -}+checkFailedTransferDirection :: ActionItem -> Direction -> Annex (Maybe a) -> Annex (Maybe a)+checkFailedTransferDirection ai d = stopUnless (pure check)+  where+	check = case actionItemTransferDirection ai of+		Nothing -> True+		Just d' -> d' == d  commonChecks :: [CommandCheck] commonChecks = [repoExists]
Command/Add.hs view
@@ -146,7 +146,7 @@  cleanup :: Key -> Bool -> CommandCleanup cleanup key hascontent = do-	maybeShowJSON [("key", key2file key)]+	maybeShowJSON $ JSONChunk [("key", key2file key)] 	when hascontent $ 		logStatus key InfoPresent 	return True
Command/AddUrl.hs view
@@ -254,7 +254,7 @@ 				tmp <- fromRepo $ gitAnnexTmpObjectLocation key 				showOutput 				ok <- Transfer.notifyTransfer Transfer.Download (Just file) $-					Transfer.download webUUID key (Just file) Transfer.forwardRetry Transfer.noObserver $ \p -> do+					Transfer.download webUUID key (Just file) Transfer.forwardRetry $ \p -> do 						liftIO $ createDirectoryIfMissing True (parentDir tmp) 						downloadUrl key p [videourl] tmp 				if ok@@ -335,7 +335,7 @@ 			)   where 	runtransfer tmp =  Transfer.notifyTransfer Transfer.Download (Just file) $-		Transfer.download u dummykey (Just file) Transfer.forwardRetry Transfer.noObserver $ \p -> do+		Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do 			liftIO $ createDirectoryIfMissing True (parentDir tmp) 			downloader tmp p @@ -356,7 +356,7 @@ 			)   where 	go = do-		maybeShowJSON [("key", key2file key)]+		maybeShowJSON $ JSONChunk [("key", key2file key)] 		when (isJust mtmp) $ 			logStatus key InfoPresent 		setUrlPresent u key url
Command/Drop.hs view
@@ -41,7 +41,7 @@ 	<$> cmdParams desc 	<*> optional parseDropFromOption 	<*> parseAutoOption-	<*> optional (parseKeyOptions False)+	<*> optional parseKeyOptions 	<*> parseBatchOption  parseDropFromOption :: Parser (DeferredParse Remote)@@ -63,36 +63,38 @@ 	go = whenAnnexed $ start o  start :: DropOptions -> FilePath -> Key -> CommandStart-start o file key = start' o key (Just file)+start o file key = start' o key afile (mkActionItem afile)+  where+	afile = Just file -start' :: DropOptions -> Key -> AssociatedFile -> CommandStart-start' o key afile = do+start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart+start' o key afile ai = do 	from <- maybe (pure Nothing) (Just <$$> getParsed) (dropFrom o) 	checkDropAuto (autoMode o) from afile key $ \numcopies -> 		stopUnless (want from) $ 			case from of-				Nothing -> startLocal afile numcopies key []+				Nothing -> startLocal afile ai numcopies key [] 				Just remote -> do 					u <- getUUID 					if Remote.uuid remote == u-						then startLocal afile numcopies key []-						else startRemote afile numcopies key remote+						then startLocal afile ai numcopies key []+						else startRemote afile ai numcopies key remote 	  where 		want from 			| autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile 			| otherwise = return True -startKeys :: DropOptions -> Key -> CommandStart+startKeys :: DropOptions -> Key -> ActionItem -> CommandStart startKeys o key = start' o key Nothing -startLocal :: AssociatedFile -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart-startLocal afile numcopies key preverified = stopUnless (inAnnex key) $ do-	showStart' "drop" key afile+startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart+startLocal afile ai numcopies key preverified = stopUnless (inAnnex key) $ do+	showStart' "drop" key ai 	next $ performLocal key afile numcopies preverified -startRemote :: AssociatedFile -> NumCopies -> Key -> Remote -> CommandStart-startRemote afile numcopies key remote = do-	showStart' ("drop " ++ Remote.name remote) key afile+startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart+startRemote afile ai numcopies key remote = do+	showStart' ("drop " ++ Remote.name remote) key ai 	next $ performRemote key afile numcopies remote  performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform
Command/DropKey.hs view
@@ -42,7 +42,7 @@  start :: Key -> CommandStart start key = do-	showStart' "dropkey" key Nothing+	showStart' "dropkey" key (mkActionItem key) 	next $ perform key  perform :: Key -> CommandPerform
Command/Find.hs view
@@ -66,7 +66,7 @@  showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex () showFormatted format unformatted vars =-	unlessM (showFullJSON vars) $+	unlessM (showFullJSON $ JSONChunk vars) $ 		case format of 			Nothing -> liftIO $ putStrLn unformatted 			Just formatter -> liftIO $ putStr $
Command/Fsck.hs view
@@ -66,7 +66,7 @@ 		<> completeRemotes 		)) 	<*> optional parseincremental-	<*> optional (parseKeyOptions False)+	<*> optional parseKeyOptions   where 	parseincremental = 		flag' StartIncrementalO@@ -89,7 +89,7 @@ 	checkDeadRepo u 	i <- prepIncremental u (incrementalOpt o) 	withKeyOptions (keyOptions o) False-		(\k -> startKey i k =<< getNumCopies)+		(\k ai -> startKey i k ai =<< getNumCopies) 		(withFilesInGit $ whenAnnexed $ start from i) 		(fsckFiles o) 	cleanupIncremental i@@ -111,7 +111,7 @@ 				Nothing -> go $ perform key file backend numcopies 				Just r -> go $ performRemote key file backend numcopies r   where-	go = runFsck inc file key+	go = runFsck inc (mkActionItem (Just file)) key  perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool perform key file backend numcopies = do@@ -173,11 +173,11 @@ 		) 	dummymeter _ = noop -startKey :: Incremental -> Key -> NumCopies -> CommandStart-startKey inc key numcopies =+startKey :: Incremental -> Key -> ActionItem -> NumCopies -> CommandStart+startKey inc key ai numcopies = 	case Backend.maybeLookupBackendName (keyBackendName key) of 		Nothing -> stop-		Just backend -> runFsck inc (key2file key) key $+		Just backend -> runFsck inc ai key $ 			performKey key backend numcopies  performKey :: Key -> Backend -> NumCopies -> Annex Bool@@ -504,10 +504,10 @@ 		(False, True) -> "dropped from " ++ Remote.name remote 		(_, False) -> "failed to drop from" ++ Remote.name remote -runFsck :: Incremental -> FilePath -> Key -> Annex Bool -> CommandStart-runFsck inc file key a = ifM (needFsck inc key)+runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart+runFsck inc ai key a = ifM (needFsck inc key) 	( do-		showStart "fsck" file+		showStart' "fsck" key ai 		next $ do 			ok <- a 			when ok $
Command/Get.hs view
@@ -34,7 +34,7 @@ 	<$> cmdParams desc 	<*> optional parseFromOption 	<*> parseAutoOption-	<*> optional (parseKeyOptions True)+	<*> optional (parseIncompleteOption <|> parseKeyOptions <|> parseFailedTransfersOption) 	<*> parseBatchOption  seek :: GetOptions -> CommandSeek@@ -49,17 +49,19 @@ 			(getFiles o)  start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart-start o from file key = start' expensivecheck from key (Just file)+start o from file key = start' expensivecheck from key afile (mkActionItem afile)   where+	afile = Just file 	expensivecheck 		| autoMode o = numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file) 		| otherwise = return True -startKeys :: Maybe Remote -> Key -> CommandStart-startKeys from key = start' (return True) from key Nothing+startKeys :: Maybe Remote -> Key -> ActionItem -> CommandStart+startKeys from key ai = checkFailedTransferDirection ai Download $+	start' (return True) from key Nothing ai -start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> CommandStart-start' expensivecheck from key afile = stopUnless (not <$> inAnnex key) $+start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart+start' expensivecheck from key afile ai = stopUnless (not <$> inAnnex key) $ 	stopUnless expensivecheck $ 		case from of 			Nothing -> go $ perform key afile@@ -68,7 +70,7 @@ 					go $ Command.Move.fromPerform src False key afile   where 	go a = do-		showStart' "get" key afile+		showStart' "get" key ai 		next a  perform :: Key -> AssociatedFile -> CommandPerform@@ -106,7 +108,7 @@ 			either (const False) id <$> Remote.hasKey r key 		| otherwise = return True 	docopy r witness = getViaTmp (RemoteVerify r) key $ \dest ->-		download (Remote.uuid r) key afile noRetry noObserver +		download (Remote.uuid r) key afile noRetry 			(\p -> do 				showAction $ "from " ++ Remote.name r 				Remote.retrieveKeyFile r key afile dest p
Command/Info.hs view
@@ -11,8 +11,9 @@  import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M-import Text.JSON+import qualified Data.Text as T import Data.Ord+import Data.Aeson hiding (json)  import Command import qualified Git@@ -29,12 +30,14 @@ import Annex.NumCopies import Remote import Config+import Git.Config (boolConfig) import Utility.Percentage+import Types.Transfer import Logs.Transfer import Types.TrustLevel import Types.FileMatcher import qualified Limit-import Messages.JSON (DualDisp(..))+import Messages.JSON (DualDisp(..), ObjectMap(..)) import Annex.BloomFilter import qualified Command.Unused @@ -219,6 +222,7 @@ 	[ file_name f 	, key_size k 	, key_name k+	, content_present k 	]  remote_fast_stats :: Remote -> [Stat]@@ -247,10 +251,10 @@ nostat :: Stat nostat = return Nothing -json :: JSON j => (j -> String) -> StatState j -> String -> StatState String+json :: ToJSON j => (j -> String) -> StatState j -> String -> StatState String json fmt a desc = do 	j <- a-	lift $ maybeShowJSON [(desc, j)]+	lift $ maybeShowJSON $ JSONChunk [(desc, j)] 	return $ fmt j  nojson :: StatState String -> String -> StatState String@@ -353,6 +357,9 @@ key_name :: Key -> Stat key_name k = simpleStat "key" $ pure $ key2file k +content_present :: Key -> Stat+content_present k = stat "present" $ json boolConfig $ lift $ inAnnex k+ bloom_info :: Stat bloom_info = simpleStat "bloom filter size" $ do 	localkeys <- countKeys <$> cachedPresentData@@ -374,7 +381,7 @@ transfer_list = stat desc $ nojson $ lift $ do 	uuidmap <- Remote.remoteMap id 	ts <- getTransfers-	maybeShowJSON [(desc, map (uncurry jsonify) ts)]+	maybeShowJSON $ JSONChunk [(desc, map (uncurry jsonify) ts)] 	return $ if null ts 		then "none" 		else multiLine $@@ -388,11 +395,11 @@ 		, maybe (fromUUID $ transferUUID t) Remote.name $ 			M.lookup (transferUUID t) uuidmap 		]-	jsonify t i = toJSObject-		[ ("transfer", showLcDirection (transferDirection t))-		, ("key", key2file (transferKey t))-		, ("file", fromMaybe "" (associatedFile i))-		, ("remote", fromUUID (transferUUID t))+	jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $+		[ ("transfer", toJSON (showLcDirection (transferDirection t)))+		, ("key", toJSON (key2file (transferKey t)))+		, ("file", toJSON (associatedFile i))+		, ("remote", toJSON (fromUUID (transferUUID t))) 		]  disk_size :: Stat@@ -415,9 +422,9 @@  backend_usage :: Stat backend_usage = stat "backend usage" $ json fmt $-	toJSObject . sort . M.toList . backendsKeys <$> cachedReferencedData+	ObjectMap . backendsKeys <$> cachedReferencedData   where-	fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . fromJSObject+	fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . sort . M.toList . fromObjectMap  numcopies_stats :: Stat numcopies_stats = stat "numcopies stats" $ json fmt $
Command/MetaData.hs view
@@ -1,6 +1,6 @@ {- git-annex command  -- - Copyright 2014 Joey Hess <id@joeyh.name>+ - Copyright 2014-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -10,9 +10,16 @@ import Command import Annex.MetaData import Logs.MetaData+import Annex.WorkTree+import Messages.JSON (JSONActionItem(..))+import Types.Messages  import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.ByteString.Lazy.UTF8 as BU import Data.Time.Clock.POSIX+import Data.Aeson  cmd :: Command cmd = withGlobalOptions ([jsonOption] ++ annexedMatchingOptions) $ @@ -24,6 +31,7 @@ 	{ forFiles :: CmdParams 	, getSet :: GetSet 	, keyOptions :: Maybe KeyOptions+	, batchOption :: BatchMode 	}  data GetSet = Get MetaField | GetAll | Set [ModMeta]@@ -32,7 +40,8 @@ optParser desc = MetaDataOptions 	<$> cmdParams desc 	<*> ((Get <$> getopt) <|> (Set <$> some modopts) <|> pure GetAll)-	<*> optional (parseKeyOptions False)+	<*> optional parseKeyOptions+	<*> parseBatchOption   where 	getopt = option (eitherReader mkMetaField) 		( long "get" <> short 'g' <> metavar paramField@@ -58,31 +67,36 @@ seek :: MetaDataOptions -> CommandSeek seek o = do 	now <- liftIO getPOSIXTime-	let seeker = case getSet o of-		Get _ -> withFilesInGit-		GetAll -> withFilesInGit-		Set _ -> withFilesInGitNonRecursive-			"Not recursively setting metadata. Use --force to do that."-	withKeyOptions (keyOptions o) False-		(startKeys now o)-		(seeker $ whenAnnexed $ start now o)-		(forFiles o)+	case batchOption o of+		NoBatch -> do+			let seeker = case getSet o of+				Get _ -> withFilesInGit+				GetAll -> withFilesInGit+				Set _ -> withFilesInGitNonRecursive+					"Not recursively setting metadata. Use --force to do that."+			withKeyOptions (keyOptions o) False+				(startKeys now o)+				(seeker $ whenAnnexed $ start now o)+				(forFiles o)+		Batch -> withOutputType $ \ot -> case ot of+			JSONOutput -> batchInput parseJSONInput $+				commandAction . startBatch now+			_ -> error "--batch is currently only supported in --json mode"  start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart-start now o file = start' (Just file) now o--startKeys :: POSIXTime -> MetaDataOptions -> Key -> CommandStart-startKeys = start' Nothing+start now o file k = startKeys now o k (mkActionItem afile)+  where+	afile = Just file -start' :: AssociatedFile -> POSIXTime -> MetaDataOptions -> Key -> CommandStart-start' afile now o k = case getSet o of+startKeys :: POSIXTime -> MetaDataOptions -> Key -> ActionItem -> CommandStart+startKeys now o k ai = case getSet o of 	Get f -> do 		l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k 		liftIO $ forM_ l $ 			putStrLn . fromMetaValue 		stop 	_ -> do-		showStart' "metadata" k afile+		showStart' "metadata" k ai 		next $ perform now o k  perform :: POSIXTime -> MetaDataOptions -> Key -> CommandPerform@@ -96,10 +110,66 @@  cleanup :: Key -> CommandCleanup cleanup k = do-	l <- map unwrapmeta . fromMetaData <$> getCurrentMetaData k-	maybeShowJSON l-	showLongNote $ unlines $ concatMap showmeta l+	m <- getCurrentMetaData k+	let Object o = toJSON (MetaDataFields m)+	maybeShowJSON $ AesonObject o+	showLongNote $ unlines $ concatMap showmeta $+		map unwrapmeta (fromMetaData m) 	return True   where 	unwrapmeta (f, v) = (fromMetaField f, map fromMetaValue (S.toList v)) 	showmeta (f, vs) = map ((f ++ "=") ++) vs++-- Metadata serialized to JSON in the field named "fields" of+-- a larger object.+newtype MetaDataFields = MetaDataFields MetaData+	deriving (Show)++instance ToJSON MetaDataFields where+	toJSON (MetaDataFields m) = object [ (fieldsField, toJSON m) ]++instance FromJSON MetaDataFields where+	parseJSON (Object v) = do+		f <- v .: fieldsField+		case f of+			Nothing -> return (MetaDataFields emptyMetaData)+			Just v' -> MetaDataFields <$> parseJSON v'+	parseJSON _ = fail "expected an object"++fieldsField :: T.Text+fieldsField = T.pack "fields"++parseJSONInput :: String -> Either String (Either FilePath Key, MetaData)+parseJSONInput i = do+	v <- eitherDecode (BU.fromString i)+	let m = case itemAdded v of+		Nothing -> emptyMetaData+		Just (MetaDataFields m') -> m'+	case (itemKey v, itemFile v) of+		(Just k, _) -> Right (Right k, m)+		(Nothing, Just f) -> Right (Left f, m)+		(Nothing, Nothing) -> Left "JSON input is missing either file or key"++startBatch :: POSIXTime -> (Either FilePath Key, MetaData) -> CommandStart+startBatch now (i, (MetaData m)) = case i of+	Left f -> do+		mk <- lookupFile f+		case mk of+			Just k -> go k (mkActionItem (Just f))+			Nothing -> error $ "not an annexed file: " ++ f+	Right k -> go k (mkActionItem k)+  where+	go k ai = do+		showStart' "metadata" k ai+		let o = MetaDataOptions+			{ forFiles = []+			, getSet = if MetaData m == emptyMetaData+				then GetAll+				else Set $ map mkModMeta (M.toList m)+			, keyOptions = Nothing+			, batchOption = NoBatch+			}+		next $ perform now o k+	mkModMeta (f, s)+		| S.null s = DelMeta f Nothing+		| otherwise = SetMeta f s
Command/Mirror.hs view
@@ -14,6 +14,7 @@ import qualified Remote import Annex.Content import Annex.NumCopies+import Types.Transfer  cmd :: Command cmd = withGlobalOptions ([jobsOption] ++ annexedMatchingOptions) $@@ -31,7 +32,7 @@ optParser desc = MirrorOptions 	<$> cmdParams desc 	<*> parseFromToOptions-	<*> optional (parseKeyOptions False)+	<*> optional (parseKeyOptions <|> parseFailedTransfersOption)  instance DeferredParseClass MirrorOptions where 	finishParse v = MirrorOptions@@ -47,25 +48,27 @@ 		(mirrorFiles o)  start :: MirrorOptions -> FilePath -> Key -> CommandStart-start o file = startKey o (Just file)+start o file k = startKey o afile k (mkActionItem afile)+  where+	afile = Just file -startKey :: MirrorOptions -> Maybe FilePath -> Key -> CommandStart-startKey o afile key = case fromToOptions o of-	ToRemote r -> ifM (inAnnex key)-		( Command.Move.toStart False afile key =<< getParsed r+startKey :: MirrorOptions -> Maybe FilePath -> Key -> ActionItem -> CommandStart+startKey o afile key ai = case fromToOptions o of+	ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)+		( Command.Move.toStart False afile key ai =<< getParsed r 		, do 			numcopies <- getnumcopies-			Command.Drop.startRemote afile numcopies key =<< getParsed r+			Command.Drop.startRemote afile ai numcopies key =<< getParsed r 		)-	FromRemote r -> do+	FromRemote r -> checkFailedTransferDirection ai Download $ do 		haskey <- flip Remote.hasKey key =<< getParsed r 		case haskey of 			Left _ -> stop-			Right True -> Command.Get.start' (return True) Nothing key afile+			Right True -> Command.Get.start' (return True) Nothing key afile ai 			Right False -> ifM (inAnnex key) 				( do 					numcopies <- getnumcopies-					Command.Drop.startLocal afile numcopies key []+					Command.Drop.startLocal afile ai numcopies key [] 				, stop 				)   where
Command/Move.hs view
@@ -35,7 +35,7 @@ optParser desc = MoveOptions 	<$> cmdParams desc 	<*> parseFromToOptions-	<*> optional (parseKeyOptions False)+	<*> optional (parseKeyOptions <|> parseFailedTransfersOption)  instance DeferredParseClass MoveOptions where 	finishParse v = MoveOptions@@ -51,18 +51,22 @@ 		(moveFiles o)  start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart-start o move = start' o move . Just+start o move f k = start' o move afile k (mkActionItem afile)+  where+	afile = Just f -startKey :: MoveOptions -> Bool -> Key -> CommandStart+startKey :: MoveOptions -> Bool -> Key -> ActionItem -> CommandStart startKey o move = start' o move Nothing -start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> CommandStart-start' o move afile key = +start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart+start' o move afile key ai =  	case fromToOptions o of-		FromRemote src -> fromStart move afile key =<< getParsed src-		ToRemote dest -> toStart move afile key =<< getParsed dest+		FromRemote src -> checkFailedTransferDirection ai Download $+			fromStart move afile key ai =<< getParsed src+		ToRemote dest -> checkFailedTransferDirection ai Upload $+			toStart move afile key ai =<< getParsed dest -showMoveAction :: Bool -> Key -> AssociatedFile -> Annex ()+showMoveAction :: Bool -> Key -> ActionItem -> Annex () showMoveAction move = showStart' (if move then "move" else "copy")  {- Moves (or copies) the content of an annexed file to a remote.@@ -74,16 +78,16 @@  - A file's content can be moved even if there are insufficient copies to  - allow it to be dropped.  -}-toStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart-toStart move afile key dest = do+toStart :: Bool -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart+toStart move afile key ai dest = do 	u <- getUUID 	ishere <- inAnnex key 	if not ishere || u == Remote.uuid dest 		then stop -- not here, so nothing to do-		else toStart' dest move afile key+		else toStart' dest move afile key ai -toStart' :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart-toStart' dest move afile key = do+toStart' :: Remote -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart+toStart' dest move afile key ai = do 	fast <- Annex.getState Annex.fast 	if fast && not move && not (Remote.hasKeyCheap dest) 		then ifM (expectedPresent dest key)@@ -93,7 +97,7 @@ 		else go False (Remote.hasKey dest key)   where 	go fastcheck isthere = do-		showMoveAction move key afile+		showMoveAction move key ai 		next $ toPerform dest move key afile fastcheck =<< isthere  expectedPresent :: Remote -> Key -> Annex Bool@@ -110,7 +114,7 @@ 		Right False -> do 			showAction $ "to " ++ Remote.name dest 			ok <- notifyTransfer Upload afile $-				upload (Remote.uuid dest) key afile noRetry noObserver $+				upload (Remote.uuid dest) key afile noRetry $ 					Remote.storeKey dest key afile 			if ok 				then finish $@@ -143,13 +147,13 @@  - If the current repository already has the content, it is still removed  - from the remote.  -}-fromStart :: Bool -> AssociatedFile -> Key -> Remote -> CommandStart-fromStart move afile key src+fromStart :: Bool -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart+fromStart move afile key ai src 	| move = go 	| otherwise = stopUnless (not <$> inAnnex key) go   where 	go = stopUnless (fromOk src key) $ do-		showMoveAction move key afile+		showMoveAction move key ai 		next $ fromPerform src move key afile  fromOk :: Remote -> Key -> Annex Bool@@ -173,7 +177,7 @@ 	)   where 	go = notifyTransfer Download afile $ -		download (Remote.uuid src) key afile noRetry noObserver $ \p -> do+		download (Remote.uuid src) key afile noRetry $ \p -> do 			showAction $ "from " ++ Remote.name src 			getViaTmp (RemoteVerify src) key $ \t -> 				Remote.retrieveKeyFile src key afile t p
Command/RecvKey.hs view
@@ -12,7 +12,7 @@ import Annex.Action import Annex import Utility.Rsync-import Logs.Transfer+import Types.Transfer import Command.SendKey (fieldTransfer) import qualified CmdLine.GitAnnexShell.Fields as Fields
Command/SendKey.hs view
@@ -48,7 +48,7 @@ 	liftIO $ debugM "fieldTransfer" "transfer start" 	afile <- Fields.getField Fields.associatedFile 	ok <- maybe (a $ const noop)-		(\u -> runner (Transfer direction (toUUID u) key) afile noRetry noObserver a)+		(\u -> runner (Transfer direction (toUUID u) key) afile noRetry a) 		=<< Fields.getField Fields.remoteUUID 	liftIO $ debugM "fieldTransfer" "transfer done" 	liftIO $ exitBool ok
Command/SetPresentKey.hs view
@@ -23,7 +23,7 @@  start :: [String] -> CommandStart start (ks:us:vs:[]) = do-	showStart' "setpresentkey" k Nothing+	showStart' "setpresentkey" k (mkActionItem k) 	next $ perform k (toUUID us) s   where 	k = fromMaybe (error "bad key") (file2key ks)
Command/Status.hs view
@@ -43,7 +43,7 @@ 	let c = statusChar s 	absf <- fromRepo $ fromTopFilePath (statusFile s) 	f <- liftIO $ relPathCwdToFile absf-	unlessM (showFullJSON [("status", [c]), ("file", f)]) $+	unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $ 		liftIO $ putStrLn $ [c] ++ " " ++ f  -- Git thinks that present direct mode files are typechanged.
Command/Sync.hs view
@@ -441,7 +441,7 @@ 		Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar []) 		_ -> seekworktree mvar [] (const noop) >> pure Nothing 	withKeyOptions' (keyOptions o) False-		(seekkeys mvar bloom) +		(return (seekkeys mvar bloom)) 		(const noop) 		[] 	finishCommandActions@@ -449,8 +449,7 @@   where 	seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>= 		mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (Just f)) noop)-	seekkeys mvar bloom getkeys =-		mapM_ (go (Left bloom) mvar Nothing) =<< getkeys+	seekkeys mvar bloom k _ = go (Left bloom) mvar Nothing k 	go ebloom mvar af k = commandAction $ do 		whenM (syncFile ebloom rs af k) $ 			void $ liftIO $ tryPutMVar mvar ()@@ -512,7 +511,7 @@ 		, return [] 		) 	get have = includeCommandAction $ do-		showStart' "get" k af+		showStart' "get" k (mkActionItem af) 		next $ next $ getKey' k af have  	wantput r@@ -527,4 +526,4 @@ 		, return [] 		) 	put dest = includeCommandAction $ -		Command.Move.toStart' dest False af k+		Command.Move.toStart' dest False af k (mkActionItem af)
Command/TransferInfo.hs view
@@ -9,6 +9,7 @@  import Command import Annex.Content+import Types.Transfer import Logs.Transfer import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered
Command/TransferKey.hs view
@@ -51,7 +51,7 @@  toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform key file remote = go Upload file $-	upload (uuid remote) key file forwardRetry noObserver $ \p -> do+	upload (uuid remote) key file forwardRetry $ \p -> do 		ok <- Remote.storeKey remote key file p 		when ok $ 			Remote.logStatus remote key InfoPresent@@ -59,7 +59,7 @@  fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $-	download (uuid remote) key file forwardRetry noObserver $ \p ->+	download (uuid remote) key file forwardRetry $ \p -> 		getViaTmp (RemoteVerify remote) key $  			\t -> Remote.retrieveKeyFile remote key file t p
Command/TransferKeys.hs view
@@ -35,13 +35,13 @@   where 	runner (TransferRequest direction remote key file) 		| direction == Upload = notifyTransfer direction file $-			upload (Remote.uuid remote) key file forwardRetry observer $ \p -> do+			upload (Remote.uuid remote) key file forwardRetry $ \p -> do 				ok <- Remote.storeKey remote key file p 				when ok $ 					Remote.logStatus remote key InfoPresent 				return ok 		| otherwise = notifyTransfer direction file $-			download (Remote.uuid remote) key file forwardRetry observer $ \p ->+			download (Remote.uuid remote) key file forwardRetry $ \p -> 				getViaTmp (RemoteVerify remote) key $ \t -> do 					r <- Remote.retrieveKeyFile remote key file t p 					-- Make sure we get the current@@ -49,9 +49,6 @@ 					-- not old cached data. 					Database.Keys.closeDb			 					return r-	-	observer False t tinfo = recordFailedTransfer t tinfo-	observer True _ _ = noop  runRequests 	:: Handle
Command/Whereis.hs view
@@ -31,7 +31,7 @@ optParser :: CmdParamsDesc -> Parser WhereisOptions optParser desc = WhereisOptions 	<$> cmdParams desc-	<*> optional (parseKeyOptions False)+	<*> optional parseKeyOptions 	<*> parseBatchOption  seek :: WhereisOptions -> CommandSeek@@ -47,14 +47,13 @@ 				(whereisFiles o)  start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart-start remotemap file key = start' remotemap key (Just file)--startKeys :: M.Map UUID Remote -> Key -> CommandStart-startKeys remotemap key = start' remotemap key Nothing+start remotemap file key = startKeys remotemap key (mkActionItem afile)+  where+	afile = Just file -start' :: M.Map UUID Remote -> Key -> AssociatedFile -> CommandStart-start' remotemap key afile = do-	showStart' "whereis" key afile+startKeys :: M.Map UUID Remote -> Key -> ActionItem -> CommandStart+startKeys remotemap key ai = do+	showStart' "whereis" key ai 	next $ perform remotemap key  perform :: M.Map UUID Remote -> Key -> CommandPerform
Git/FilePath.hs view
@@ -14,6 +14,8 @@  module Git.FilePath ( 	TopFilePath,+	BranchFilePath(..),+	descBranchFilePath, 	getTopFilePath, 	fromTopFilePath, 	toTopFilePath,@@ -32,6 +34,13 @@ {- A FilePath, relative to the top of the git repository. -} newtype TopFilePath = TopFilePath { getTopFilePath :: FilePath } 	deriving (Show, Eq, Ord)++{- A file in a branch or other treeish. -}+data BranchFilePath = BranchFilePath Ref TopFilePath++{- Git uses the branch:file form to refer to a BranchFilePath -}+descBranchFilePath :: BranchFilePath -> String+descBranchFilePath (BranchFilePath b f) = fromRef b ++ ':' : getTopFilePath f  {- Path to a TopFilePath, within the provided git repo. -} fromTopFilePath :: TopFilePath -> Git.Repo -> FilePath
Logs/Transfer.hs view
@@ -9,6 +9,7 @@  module Logs.Transfer where +import Types.Transfer import Annex.Common import Annex.Perms import qualified Git@@ -22,38 +23,6 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Control.Concurrent--{- Enough information to uniquely identify a transfer, used as the filename- - of the transfer information file. -}-data Transfer = Transfer-	{ transferDirection :: Direction-	, transferUUID :: UUID-	, transferKey :: Key-	}-	deriving (Eq, Ord, Read, Show)--{- Information about a Transfer, stored in the transfer information file.- -- - Note that the associatedFile may not correspond to a file in the local- - git repository. It's some file, possibly relative to some directory,- - of some repository, that was acted on to initiate the transfer.- -}-data TransferInfo = TransferInfo-	{ startedTime :: Maybe POSIXTime-	, transferPid :: Maybe PID-	, transferTid :: Maybe ThreadId-	, transferRemote :: Maybe Remote-	, bytesComplete :: Maybe Integer-	, associatedFile :: Maybe FilePath-	, transferPaused :: Bool-	}-	deriving (Show, Eq, Ord)--stubTransferInfo :: TransferInfo-stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False--data Direction = Upload | Download-	deriving (Eq, Ord, Read, Show)  showLcDirection :: Direction -> String showLcDirection Upload = "upload"
Messages.hs view
@@ -1,12 +1,14 @@ {- git-annex output messages  -- - Copyright 2010-2014 Joey Hess <id@joeyh.name>+ - Copyright 2010-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -}  module Messages ( 	showStart,+	ActionItem,+	mkActionItem, 	showStart', 	showNote, 	showAction,@@ -25,6 +27,7 @@ 	earlyWarning, 	warningIO, 	indent,+	JSONChunk(..), 	maybeShowJSON, 	showFullJSON, 	showCustom,@@ -37,9 +40,9 @@ 	commandProgressDisabled, 	outputMessage, 	implicitMessage,+	withOutputType, ) where -import Text.JSON import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter)@@ -48,18 +51,23 @@ import Common import Types import Types.Messages+import Types.ActionItem import Messages.Internal import qualified Messages.JSON as JSON-import Types.Key+import Utility.JSONStream (JSONChunk(..)) import qualified Annex  showStart :: String -> FilePath -> Annex ()-showStart command file = outputMessage (JSON.start command (Just file) Nothing) $+showStart command file = outputMessage json $ 	command ++ " " ++ file ++ " "+  where+	json = JSON.start command (Just file) Nothing -showStart' :: String -> Key -> Maybe FilePath -> Annex ()-showStart' command key afile = outputMessage (JSON.start command afile (Just key)) $-	command ++ " " ++ fromMaybe (key2file key) afile ++ " "+showStart' :: String -> Key -> ActionItem -> Annex ()+showStart' command key i = outputMessage json $+	command ++ " " ++ actionItemDesc i key ++ " "+  where+	json = JSON.start command (actionItemWorkTreeFile i) (Just key)  showNote :: String -> Annex () showNote s = outputMessage (JSON.note s) $ "(" ++ s ++ ") "@@ -145,15 +153,15 @@ indent :: String -> String indent = intercalate "\n" . map (\l -> "  " ++ l) . lines -{- Shows a JSON fragment only when in json mode. -}-maybeShowJSON :: JSON a => [(String, a)] -> Annex ()+{- 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 ()  {- Shows a complete JSON value, only when in json mode. -}-showFullJSON :: JSON a => [(String, a)] -> Annex Bool+showFullJSON :: JSONChunk v -> Annex Bool showFullJSON v = withOutputType $ liftIO . go   where 	go JSONOutput = JSON.complete v >> return True
Messages/JSON.hs view
@@ -1,10 +1,12 @@-{- git-annex JSON output+{- git-annex command-line JSON output and input  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>  -  - Licensed under the GNU GPL version 3 or higher.  -} +{-# LANGUAGE OverloadedStrings #-}+ module Messages.JSON ( 	start, 	end,@@ -12,35 +14,43 @@ 	add, 	complete, 	DualDisp(..),+	ObjectMap(..),+	JSONActionItem(..), ) where -import Text.JSON+import Data.Aeson+import Control.Applicative+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as B+import System.IO+import Data.Monoid+import Prelude  import qualified Utility.JSONStream as Stream import Types.Key-import Data.Maybe  start :: String -> Maybe FilePath -> Maybe Key -> IO ()-start command file key = putStr $ Stream.start $ catMaybes-	[ part "command" (Just command)-	, part "file" file-	, part "key" (fmap key2file key)-	]+start command file key = B.hPut stdout $ Stream.start $ Stream.AesonObject o   where-	part _ Nothing = Nothing-	part l (Just v) = Just (l, v)+	Object o = toJSON $ JSONActionItem+		{ itemCommand = Just command+		, itemKey = key+		, itemFile = file+		, itemAdded = Nothing+		}  end :: Bool -> IO ()-end b = putStr $ Stream.add [("success", b)] ++ Stream.end+end b = B.hPut stdout $ Stream.add (Stream.JSONChunk [("success", b)]) `B.append` Stream.end  note :: String -> IO ()-note s = add [("note", s)]+note s = add (Stream.JSONChunk [("note", s)]) -add :: JSON a => [(String, a)] -> IO ()-add v = putStr $ Stream.add v+add :: Stream.JSONChunk a -> IO ()+add = B.hPut stdout . Stream.add -complete :: JSON a => [(String, a)] -> IO ()-complete v = putStr $ Stream.start v ++ Stream.end+complete :: Stream.JSONChunk a -> IO ()+complete v = B.hPut stdout $ Stream.start v `B.append` Stream.end  -- A value that can be displayed either normally, or as JSON. data DualDisp = DualDisp@@ -48,9 +58,45 @@ 	, dispJson :: String 	} -instance JSON DualDisp where-	showJSON = JSString . toJSString . dispJson-	readJSON _ = Error "stub"+instance ToJSON DualDisp where+	toJSON = toJSON . dispJson  instance Show DualDisp where 	show = dispNormal++-- A Map that is serialized to JSON as an object, with each key being a+-- field of the object. This is different from Aeson's normal +-- serialization of Map, which uses "[key, value]".+data ObjectMap a = ObjectMap { fromObjectMap :: M.Map String a }++instance ToJSON a => ToJSON (ObjectMap a) where+	toJSON (ObjectMap m) = object $ map go $ M.toList m+	  where+		go (k, v) = (T.pack k, toJSON v)++-- An item that a git-annex command acts on, and displays a JSON object about.+data JSONActionItem a = JSONActionItem+	{ itemCommand :: Maybe String+	, itemKey :: Maybe Key+	, itemFile :: Maybe FilePath+	, itemAdded :: Maybe a -- for additional fields added by `add`+	}+	deriving (Show)++instance ToJSON (JSONActionItem a) where+	toJSON i = object+		[ "command" .= itemCommand i+		, "key" .= (toJSON (itemKey i))+		, "file" .= itemFile i+		-- itemAdded is not included; must be added later by 'add'+		]++instance FromJSON a => FromJSON (JSONActionItem a) where+	parseJSON (Object v) = JSONActionItem+		<$> (v .:? "command")+		<*> (maybe (return Nothing) parseJSON =<< (v .:? "key"))+		<*> (v .:? "file")+		<*> parseadded+	  where+		parseadded = (Just <$> parseJSON (Object v)) <|> return Nothing+	parseJSON _ = mempty
Remote.hs view
@@ -55,10 +55,10 @@ 	claimingUrl, ) where -import qualified Data.Map as M-import Text.JSON-import Text.JSON.Generic import Data.Ord+import Data.Aeson+import qualified Data.Map as M+import qualified Data.Text as T  import Annex.Common import Types.Remote@@ -194,7 +194,7 @@  {- An optional field can be included in the list of UUIDs. -} prettyPrintUUIDsWith-	:: JSON v+	:: ToJSON v 	=> Maybe String  	-> String  	-> M.Map UUID RemoteName@@ -203,7 +203,7 @@ 	-> Annex String prettyPrintUUIDsWith optfield header descm showval uuidvals = do 	hereu <- getUUID-	maybeShowJSON [(header, map (jsonify hereu) uuidvals)]+	maybeShowJSON $ JSONChunk [(header, map (jsonify hereu) uuidvals)] 	return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals   where 	finddescription u = M.findWithDefault "" u descm@@ -220,12 +220,12 @@ 		addoptval s = case showval =<< optval of 			Nothing -> s 			Just val -> val ++ ": " ++ s-	jsonify hereu (u, optval) = toJSObject $ catMaybes-		[ Just ("uuid", toJSON $ fromUUID u)-		, Just ("description", toJSON $ finddescription u)-		, Just ("here", toJSON $ hereu == u)+	jsonify hereu (u, optval) = object $ catMaybes+		[ Just (T.pack "uuid", toJSON $ fromUUID u)+		, Just (T.pack "description", toJSON $ finddescription u)+		, Just (T.pack "here", toJSON $ hereu == u) 		, case (optfield, optval) of-			(Just field, Just val) -> Just (field, showJSON val)+			(Just field, Just val) -> Just (T.pack field, toJSON val) 			_ -> Nothing 		]
Remote/External.hs view
@@ -22,7 +22,7 @@ import Remote.Helper.Messages import Utility.Metered import Messages.Progress-import Logs.Transfer+import Types.Transfer import Logs.PreferredContent.Raw import Logs.RemoteState import Logs.Web
Remote/External/Types.hs view
@@ -34,7 +34,7 @@ import Annex.Common import Types.StandardGroups (PreferredContentExpression) import Utility.Metered (BytesProcessed(..))-import Logs.Transfer (Direction(..))+import Types.Transfer (Direction(..)) import Config.Cost (Cost) import Types.Remote (RemoteConfig) import Types.Availability (Availability(..))
Remote/GCrypt.hs view
@@ -25,6 +25,7 @@ import Types.GitConfig import Types.Crypto import Types.Creds+import Types.Transfer import qualified Git import qualified Git.Command import qualified Git.Config@@ -47,7 +48,6 @@ import Utility.Rsync import Utility.Tmp import Logs.Remote-import Logs.Transfer import Utility.Gpg  remote :: RemoteType
Remote/Git.hs view
@@ -439,7 +439,7 @@ 				Just (object, checksuccess) -> do 					copier <- mkCopier hardlink params 					runTransfer (Transfer Download u key)-						file noRetry noObserver +						file noRetry 						(\p -> copier object dest (combineMeterUpdate p meterupdate) checksuccess) 	| Git.repoIsSsh (repo r) = unVerified $ feedprogressback $ \p -> do 		Ssh.rsyncHelper (Just (combineMeterUpdate meterupdate p))@@ -565,7 +565,7 @@ 				ensureInitialized 				copier <- mkCopier hardlink params 				let verify = Annex.Content.RemoteVerify r-				runTransfer (Transfer Download u key) file noRetry noObserver $ \p ->+				runTransfer (Transfer Download u key) file noRetry $ \p -> 					let p' = combineMeterUpdate meterupdate p 					in Annex.Content.saveState True `after` 						Annex.Content.getViaTmp verify key
Remote/Helper/Ssh.hs view
@@ -20,7 +20,7 @@ import Utility.Metered import Utility.Rsync import Types.Remote-import Logs.Transfer+import Types.Transfer import Config  {- Generates parameters to ssh to a repository's host and run a command.
Remote/Rsync.hs view
@@ -34,7 +34,7 @@ import Utility.CopyFile import Messages.Progress import Utility.Metered-import Logs.Transfer+import Types.Transfer import Types.Creds import Annex.DirHashes import Utility.Tmp
Test.hs view
@@ -32,7 +32,8 @@ import Options.Applicative (switch, long, help)  import qualified Data.Map as M-import qualified Text.JSON+import qualified Data.Aeson+import qualified Data.ByteString.Lazy.UTF8 as BU8  import Common @@ -924,10 +925,10 @@  test_info :: Assertion test_info = intmpclonerepo $ do-	json <- git_annex_output "info" ["--json"]-	case Text.JSON.decodeStrict json :: Text.JSON.Result (Text.JSON.JSObject Text.JSON.JSValue) of-		Text.JSON.Ok _ -> return ()-		Text.JSON.Error e -> assertFailure e+	json <- BU8.fromString <$> git_annex_output "info" ["--json"]+	case Data.Aeson.eitherDecode json :: Either String Data.Aeson.Value of+		Right _ -> return ()+		Left e -> assertFailure e  test_version :: Assertion test_version = intmpclonerepo $
+ Types/ActionItem.hs view
@@ -0,0 +1,54 @@+{- items that a command can act on+ -+ - Copyright 2016 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module Types.ActionItem where++import Types.Key+import Types.Transfer+import Git.FilePath++import Data.Maybe++data ActionItem +	= ActionItemAssociatedFile AssociatedFile+	| ActionItemKey+	| ActionItemBranchFilePath BranchFilePath+	| ActionItemFailedTransfer Transfer TransferInfo++class MkActionItem t where+	mkActionItem :: t -> ActionItem++instance MkActionItem AssociatedFile where+	mkActionItem = ActionItemAssociatedFile++instance MkActionItem Key where+	mkActionItem _ = ActionItemKey++instance MkActionItem BranchFilePath where+	mkActionItem = ActionItemBranchFilePath++instance MkActionItem (Transfer, TransferInfo) where+	mkActionItem = uncurry ActionItemFailedTransfer++actionItemDesc :: ActionItem -> Key -> String+actionItemDesc (ActionItemAssociatedFile (Just f)) _ = f+actionItemDesc (ActionItemAssociatedFile Nothing) k = key2file k+actionItemDesc ActionItemKey k = key2file k+actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp+actionItemDesc (ActionItemFailedTransfer _ i) k = +	fromMaybe (key2file k) (associatedFile i)++actionItemWorkTreeFile :: ActionItem -> Maybe FilePath+actionItemWorkTreeFile (ActionItemAssociatedFile af) = af+actionItemWorkTreeFile _ = Nothing++actionItemTransferDirection :: ActionItem -> Maybe Direction+actionItemTransferDirection (ActionItemFailedTransfer t _) = Just $+	transferDirection t+actionItemTransferDirection _ = Nothing
Types/Key.hs view
@@ -1,6 +1,6 @@ {- git-annex Key data type  -- - 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.  -}@@ -21,6 +21,8 @@ ) where  import System.Posix.Types+import Data.Aeson+import qualified Data.Text as T  import Common import Utility.QuickCheck@@ -119,6 +121,13 @@ 			return $ k { keyChunkNum = Just chunknum } 		_ -> return k 	addfield _ _ _ = Nothing++instance ToJSON Key where+	toJSON = toJSON . key2file++instance FromJSON Key where+	parseJSON (String t) = maybe mempty pure $ file2key $ T.unpack t+	parseJSON _ = mempty  instance Arbitrary Key where 	arbitrary = Key
Types/MetaData.hs view
@@ -44,14 +44,32 @@ import Utility.Base64 import Utility.QuickCheck +import qualified Data.Text as T import qualified Data.Set as S import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM import Data.Char import qualified Data.CaseInsensitive as CI+import Data.Aeson  newtype MetaData = MetaData (M.Map MetaField (S.Set MetaValue)) 	deriving (Show, Eq, Ord) +instance ToJSON MetaData where+	toJSON (MetaData m) = object $ map go (M.toList m)+	  where+		go (MetaField f, s) = (T.pack (CI.original f), toJSON s)++instance FromJSON MetaData where+	parseJSON (Object o) = do+		l <- HM.toList <$> parseJSON (Object o)+		MetaData . M.fromList <$> mapM go l+	  where+		go (t, l) = case mkMetaField (T.unpack t) of+			Left e -> fail e+			Right f -> (,) <$> pure f <*> parseJSON l+	parseJSON _ = fail "expected an object"+ {- A metadata value can be currently be set (True), or may have been  - set before and we're remembering it no longer is (False). -} newtype CurrentlySet = CurrentlySet Bool@@ -64,6 +82,13 @@ data MetaValue = MetaValue CurrentlySet String 	deriving (Read, Show) +instance ToJSON MetaValue where+	toJSON (MetaValue _ v) = toJSON v++instance FromJSON MetaValue where+	parseJSON (String v) = return $ MetaValue (CurrentlySet True) (T.unpack v)+	parseJSON _  = fail "expected a string"+ {- Metadata values compare and order the same whether currently set or not. -} instance Eq MetaValue where 	MetaValue _ a == MetaValue _ b = a == b@@ -179,9 +204,12 @@ {- Can be used to set a value, or to unset it, depending on whether  - the MetaValue has CurrentlySet or not. -} updateMetaData :: MetaField -> MetaValue -> MetaData -> MetaData-updateMetaData f v (MetaData m) = MetaData $-	M.insertWith' S.union f (S.singleton v) m+updateMetaData f v = updateMetaData' f (S.singleton v) +updateMetaData' :: MetaField -> S.Set MetaValue -> MetaData -> MetaData+updateMetaData' f s (MetaData m) = MetaData $+	M.insertWith' S.union f s m+ {- New metadata overrides old._-} unionMetaData :: MetaData -> MetaData -> MetaData unionMetaData (MetaData old) (MetaData new) = MetaData $@@ -222,7 +250,7 @@ 	| DelMeta MetaField (Maybe MetaValue) 	-- ^ delete value of a field. With Just, only that specific value 	-- is deleted; with Nothing, all current values are deleted.-	| SetMeta MetaField MetaValue+	| SetMeta MetaField (S.Set MetaValue) 	-- ^ removes any existing values 	| MaybeSetMeta MetaField MetaValue 	-- ^ set when field has no existing value@@ -237,7 +265,7 @@ 	updateMetaData f (unsetMetaValue oldv) emptyMetaData modMeta m (DelMeta f Nothing) = MetaData $ M.singleton f $ 	S.fromList $ map unsetMetaValue $ S.toList $ currentMetaDataValues f m-modMeta m (SetMeta f v) = updateMetaData f v $+modMeta m (SetMeta f s) = updateMetaData' f s $ 	foldr (updateMetaData f) emptyMetaData $ 		map unsetMetaValue $ S.toList $ currentMetaDataValues f m modMeta m (MaybeSetMeta f v)
+ Types/Transfer.hs view
@@ -0,0 +1,47 @@+{- git-annex transfer types+ -+ - Copyright 2012 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Types.Transfer where++import Types+import Utility.PID++import Data.Time.Clock.POSIX+import Control.Concurrent++{- Enough information to uniquely identify a transfer, used as the filename+ - of the transfer information file. -}+data Transfer = Transfer+	{ transferDirection :: Direction+	, transferUUID :: UUID+	, transferKey :: Key+	}+	deriving (Eq, Ord, Read, Show)++{- Information about a Transfer, stored in the transfer information file.+ -+ - Note that the associatedFile may not correspond to a file in the local+ - git repository. It's some file, possibly relative to some directory,+ - of some repository, that was acted on to initiate the transfer.+ -}+data TransferInfo = TransferInfo+	{ startedTime :: Maybe POSIXTime+	, transferPid :: Maybe PID+	, transferTid :: Maybe ThreadId+	, transferRemote :: Maybe Remote+	, bytesComplete :: Maybe Integer+	, associatedFile :: Maybe FilePath+	, transferPaused :: Bool+	}+	deriving (Show, Eq, Ord)++stubTransferInfo :: TransferInfo+stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False++data Direction = Upload | Download+	deriving (Eq, Ord, Read, Show)+
Utility/JSONStream.hs view
@@ -1,44 +1,68 @@ {- Streaming JSON output.  -- - Copyright 2011 Joey Hess <id@joeyh.name>+ - Copyright 2011, 2016 Joey Hess <id@joeyh.name>  -  - License: BSD-2-clause  -} +{-# LANGUAGE GADTs #-}+ module Utility.JSONStream (+	JSONChunk(..), 	start, 	add, 	end ) where -import Text.JSON+import Data.Aeson+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as B+import Data.Char+import Data.Word -{- Text.JSON does not support building up a larger JSON document piece by- - piece as a stream. To support streaming, a hack. The JSObject is converted- - to a string with its final "}" is left off, allowing it to be added to- - later. -}-start :: JSON a => [(String, a)] -> String-start l-	| last s == endchar = init s-	| otherwise = bad s+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-	s = encodeStrict $ toJSObject l+	mkPair (s, v) = (T.pack s, toJSON v)+encodeJSONChunk (AesonObject o) = encode o -add :: JSON a => [(String, a)] -> String-add l-	| head s == startchar = ',' : drop 1 s-	| otherwise = bad s+{- 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-	s = start l+	b = encodeJSONChunk a -end :: String-end = [endchar, '\n']+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 -startchar :: Char-startchar = '{'+end :: B.ByteString+end = endchar `B.cons` sepchar `B.cons` B.empty -endchar :: Char-endchar = '}'+startchar :: Word8+startchar = fromIntegral (ord '{') -bad :: String -> a-bad s = error $ "Text.JSON returned unexpected string: " ++ s+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+
doc/git-annex-copy.mdwn view
@@ -51,9 +51,17 @@    This is the default behavior when running git-annex in a bare repository. +* `--branch=ref`++  Operate on files in the specified branch or treeish.+ * `--unused`    Operate on files found by last run of git-annex unused.++* `--failed`++  Operate on files that have recently failed to be transferred.  * `--key=keyname`
doc/git-annex-drop.mdwn view
@@ -42,13 +42,29 @@    This is the default behavior when running git-annex drop in a bare repository. +  Note that this bypasses checking the .gitattributes annex.numcopies+  setting.++* `--branch=ref`++  Drop files in the specified branch or treeish.++  Note that this bypasses checking the .gitattributes annex.numcopies+  setting.+ * `--unused`    Drop files found by last run of git-annex unused. +  Note that this bypasses checking the .gitattributes annex.numcopies+  setting.+ * `--key=keyname`    Use this option to drop a specified key.++  Note that this bypasses checking the .gitattributes annex.numcopies+  setting.  * file matching options
doc/git-annex-fsck.mdwn view
@@ -72,6 +72,10 @@    This is the default behavior when running git-annex in a bare repository. +* `--branch=ref`++  Operate on files in the specified branch or treeish.+ * `--unused`    Operate on files found by last run of git-annex unused.
doc/git-annex-get.mdwn view
@@ -32,6 +32,11 @@   Enables parallel download with up to the specified number of jobs   running at once. For example: `-J10` +* file matching options+ +  The [[git-annex-matching-options]](1)+  can be used to specify files to get.+ * `--incomplete`    Resume any incomplete downloads of files that were started and@@ -45,11 +50,6 @@   as git-annex does not know the associated file, and the associated file   may not even be in the current git working directory. -* file matching options- -  The [[git-annex-matching-options]](1)-  can be used to specify files to get.- * `--all`    Rather than specifying a filename or path to get, this option can be@@ -57,9 +57,20 @@    This is the default behavior when running git-annex in a bare repository. +* `--branch=ref`++  Operate on files in the specified branch or treeish.+ * `--unused`    Operate on files found by last run of git-annex unused.++* `--failed`++  Operate on files that have recently failed to be transferred.++  Not to be confused with `--incomplete` which resumes only downloads+  that managed to transfer part of the content of a file.  * `--key=keyname`
doc/git-annex-metadata.mdwn view
@@ -17,6 +17,11 @@  When run without any -s or -t parameters, displays the current metadata. +Each metadata field has its own "field-lastchanged" metadata, which+contains the date the field was last changed. Unlike other metadata,+this cannot be directly modified by this command. It is updated+automatically.+ # OPTIONS  * `-g field` / `--get field`@@ -66,15 +71,15 @@   The [[git-annex-matching-options]](1)   can be used to specify files to act on. -* `--json`--  Enable JSON output. This is intended to be parsed by programs that use-  git-annex. Each line of output is a JSON object.- * `--all`    Specify instead of a file to get/set metadata on all known keys. +* `--branch=ref`++  Specify instead of a file to get/set metadata on all files in the+  specified branch or treeish.+ * `--unused`    Specify instead of a file to get/set metadata on@@ -83,6 +88,55 @@ * `--key=keyname`    Specify instead of a file to get/set metadata of the specified key.++* `--json`++  Enable JSON output (and input). Each line is a JSON object.++  The format of the JSON objects changed in git-annex version 6.20160726.++  Example of the new format:++	{"command":"metadata","file":"foo","key":"...","fields":{"author":["bar"],...},"note":"...","success":true}++  Example of the old format, which lacks the inner fields object:++	{"command":"metadata","file":"foo","key":"...","author":["bar"],...,"note":"...","success":true}++* `--batch`++  Enables batch mode, which can be used to both get, store, and unset+  metadata for multiple files or keys.++  Batch currently only supports JSON input. So, you must+  enable `--json` along with `--batch`.++  In batch mode, git-annex reads lines from stdin, which contain+  JSON objects. It replies to each input with an output JSON object.++  The format of the JSON sent to git-annex can be the same as the JSON that+  it outputs. Or, a simplified version. Only the "file" (or "key") field+  is actually necessary.++  For example, to get the current metadata of file foo:++	{"file":"foo"}++  To get the current metadata of the key k:+	+	{"key":"k"}++  Any metadata fields included in the JSON object will be stored,+  replacing whatever values the fields had before.+  To unset a field, include it with an empty list of values.++  To change the author of file foo to bar:++	{"file":"foo","fields":{"author":["bar"]}}++  To remove the author of file foo:++	{"file":"foo","fields":{"author":[]}}  # EXAMPLES
doc/git-annex-mirror.mdwn view
@@ -46,6 +46,21 @@    This is the default behavior when running git-annex in a bare repository. +* `--branch=ref`++  Operate on files in the specified branch or treeish.++  Like --all, this bypasses checking the .gitattributes annex.numcopies+  setting when dropping files.++* `--unused`++  Operate on files found by last run of git-annex unused.++* `--failed`++  Operate on files that have recently failed to be transferred.+ * file matching options    The [[git-annex-matching-options]](1)
doc/git-annex-move.mdwn view
@@ -34,9 +34,17 @@    This is the default behavior when running git-annex in a bare repository. +* `--branch=ref`++  Operate on files in the specified branch or treeish.+ * `--unused`    Operate on files found by last run of git-annex unused.++* `--failed`++  Operate on files that have recently failed to be transferred.  * `--key=keyname`
doc/git-annex-whereis.mdwn view
@@ -35,6 +35,10 @@    Show whereis information for all known keys. +* `--branch=ref`++  Show whereis information for files in the specified branch or treeish.+ * `--unused`    Show whereis information for files found by last run of git-annex unused.
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 6.20160619+Version: 6.20160808 Cabal-Version: >= 1.8 License: GPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -323,21 +323,23 @@   Build-Depends:    base (>= 4.5 && < 5.0),    optparse-applicative (>= 0.11.0), -   containers (>= 0.5.0.0), +   containers (>= 0.5.0.0),    exceptions (>= 0.6),    QuickCheck (>= 2.1),    stm (>= 2.3),    mtl (>= 2),-   process, data-default, case-insensitive, uuid, random, dlist,+   uuid (>= 1.2.6),+   process, data-default, case-insensitive, random, dlist,    unix-compat, SafeSemaphore, async, directory, filepath, IfElse,    MissingH, hslogger, monad-logger,-   utf8-string, bytestring, text, sandi, json,+   utf8-string, bytestring, text, sandi,    monad-control, transformers,    bloomfilter, edit-distance,-   resourcet, http-conduit, http-client, http-types,+   resourcet, http-conduit (<2.2.0), http-client, http-types,    time, old-locale,-   esqueleto, persistent-sqlite, persistent, persistent-template,+   esqueleto, persistent-sqlite, persistent (<2.5), persistent-template,    aeson,+   unordered-containers,    feed,    regex-tdfa   CC-Options: -Wall@@ -911,6 +913,7 @@     RemoteDaemon.Types     Test     Types+    Types.ActionItem     Types.Availability     Types.Backend     Types.BranchState@@ -937,6 +940,7 @@     Types.StandardGroups     Types.StoreRetrieve     Types.Test+    Types.Transfer     Types.TrustLevel     Types.UUID     Types.UrlContents