info: Added json output for "backend usage", "numcopies stats", "repositories containing these files", and "transfers in progress".

Command/Info.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}
 
 module Command.Info where
 
@@ -38,6 +38,7 @@ import Logs.Transfer
 import Types.TrustLevel
 import Types.FileMatcher
 import qualified Limit
+import Messages.JSON (DualDisp(..))
 
 -- a named computation that produces a statistic
 type Stat = StatState (Maybe (String, StatState String))
@@ -59,8 +60,8 @@ newtype Variance = Variance Int
 
 instance Show Variance where
 	show (Variance n)
-		| n >= 0 = "numcopies +" ++ show n
-		| otherwise = "numcopies " ++ show n
+		| n >= 0 = "+" ++ show n
+		| otherwise = show n
 
 -- cached info that multiple Stats use
 data StatInfo = StatInfo
@@ -221,10 +222,10 @@ nostat :: Stat
 nostat = return Nothing
 
 json :: JSON j => (j -> String) -> StatState j -> String -> StatState String
-json serialize a desc = do
+json fmt a desc = do
 	j <- a
 	lift $ maybeShowJSON [(desc, j)]
-	return $ serialize j
+	return $ fmt j
 
 nojson :: StatState String -> String -> StatState String
 nojson a _ = a
@@ -251,11 +252,16 @@ repo_list level = stat n $ nojson $ lift $ do
 	us <- filter (/= NoUUID) . M.keys 
 		<$> (M.union <$> uuidMap <*> remoteMap Remote.name)
 	rs <- fst <$> trustPartition level us
-	s <- prettyPrintUUIDs n rs
-	return $ if null s then "0" else show (length rs) ++ "\n" ++ beginning s
+	countRepoList (length rs)
+		-- This also handles json display.
+		<$> prettyPrintUUIDs n rs
   where
 	n = showTrustLevel level ++ " repositories"
 
+countRepoList :: Int -> String -> String
+countRepoList _ [] = "0"
+countRepoList n s = show n ++ "\n" ++ beginning s
+
 dir_name :: FilePath -> Stat
 dir_name dir = simpleStat "directory" $ pure dir
 
@@ -339,14 +345,16 @@ bloom_info = simpleStat "bloom filter size" $ do
 	return $ size ++ note
 
 transfer_list :: Stat
-transfer_list = stat "transfers in progress" $ nojson $ lift $ do
+transfer_list = stat desc $ nojson $ lift $ do
 	uuidmap <- Remote.remoteMap id
 	ts <- getTransfers
+	maybeShowJSON [(desc, map (uncurry jsonify) ts)]
 	return $ if null ts
 		then "none"
 		else multiLine $
 			map (uncurry $ line uuidmap) $ sort ts
   where
+	desc = "transfers in progress"
 	line uuidmap t i = unwords
 		[ showLcDirection (transferDirection t) ++ "ing"
 		, fromMaybe (key2file $ transferKey t) (associatedFile i)
@@ -354,6 +362,12 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do
 		, 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))
+		]
 
 disk_size :: Stat
 disk_size = simpleStat "available local disk space" $ lift $
@@ -374,42 +388,41 @@ disk_size = simpleStat "available local disk space" $ lift $
 		| otherwise = 0
 
 backend_usage :: Stat
-backend_usage = stat "backend usage" $ nojson $
+backend_usage = stat "backend usage" $ json fmt $
 	calc
 		<$> (backendsKeys <$> cachedReferencedData)
 		<*> (backendsKeys <$> cachedPresentData)
   where
-	calc x y = multiLine $
-		map (\(n, b) -> b ++ ": " ++ show n) $
-		sortBy (flip compare) $ map swap $ M.toList $
-		M.unionWith (+) x y
+	calc x y = sort $ M.toList $ M.unionWith (+) x y
+	fmt = multiLine . map (\(n, b) -> b ++ ": " ++ show n) . map swap
 
 numcopies_stats :: Stat
-numcopies_stats = stat "numcopies stats" $ nojson $
+numcopies_stats = stat "numcopies stats" $ json fmt $
 	calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats)
   where
-	calc = multiLine
-		. map (\(variance, count) -> show variance ++ ": " ++ show count)
-		. sortBy (flip (comparing snd)) . M.toList
+	calc = map (\(variance, count) -> (show variance, count)) 
+		. sortBy (flip (comparing snd))
+		. M.toList
+	fmt = multiLine . map (\(variance, count) -> "numcopies " ++ variance ++ ": " ++ show count)
 
 reposizes_stats :: Stat
-reposizes_stats = stat "repositories containing these files" $ nojson $
-	calc
-		<$> lift uuidDescriptions
-		<*> lift mkSizer
-		<*> cachedRepoData
+reposizes_stats = stat desc $ nojson $ do
+	sizer <- lift mkSizer
+	l <- map (\(u, kd) -> (u, sizer storageUnits True (sizeKeys kd)))
+		. sortBy (flip (comparing (sizeKeys . snd)))
+		. M.toList
+		<$> cachedRepoData
+	let maxlen = maximum (map (length . snd) l)
+	-- This also handles json display.
+	s <- lift $ prettyPrintUUIDsWith (Just "size") desc $
+		map (\(u, sz) -> (u, Just $ mkdisp sz maxlen)) l
+	return $ countRepoList (length l) s
   where
-	calc descm sizer = multiLine
-		. format
-		. map (\(u, d) -> line descm sizer u d)
-		. sortBy (flip (comparing (sizeKeys . snd))) . M.toList
-	line descm sizer u d = (sz, fromUUID u ++ " -- " ++ desc)
-	  where
-		sz = sizer storageUnits True (sizeKeys d)
-		desc = fromMaybe "" (M.lookup u descm)
-	format l = map (\(c1, c2) -> lpad maxc1 c1 ++ ": " ++ c2 ) l
-	  where
-		maxc1 = maximum (map (length . fst) l)
+	desc = "repositories containing these files"
+	mkdisp sz maxlen = DualDisp
+		{ dispNormal = lpad maxlen sz
+		, dispJson = sz
+		}
 	lpad n s = (replicate (n - length s) ' ') ++ s
 
 cachedPresentData :: StatState KeyData

Messages/JSON.hs

@@ -10,7 +10,8 @@ module Messages.JSON (
 	end,
 	note,
 	add,
-	complete
+	complete,
+	DualDisp(..),
 ) where
 
 import Text.JSON
@@ -35,3 +36,16 @@ add v = putStr $ Stream.add v
 
 complete :: JSON a => [(String, a)] -> IO ()
 complete v = putStr $ Stream.start v ++ Stream.end
+
+-- A value that can be displayed either normally, or as JSON.
+data DualDisp = DualDisp
+	{ dispNormal :: String
+	, dispJson :: String
+	}
+
+instance JSON DualDisp where
+	showJSON = JSString . toJSString . dispJson
+	readJSON _ = Error "stub"
+
+instance Show DualDisp where
+	show = dispNormal

Remote.hs

@@ -31,6 +31,7 @@ module Remote (
 	byNameWithUUID,
 	byCost,
 	prettyPrintUUIDs,
+	prettyPrintUUIDsWith,
 	prettyListUUIDs,
 	prettyUUID,
 	remoteFromUUID,
@@ -168,19 +169,29 @@ nameToUUID' n = byName' n >>= go
 
 {- Pretty-prints a list of UUIDs of remotes, for human display.
  -
- - When JSON is enabled, also generates a machine-readable description
+ - When JSON is enabled, also outputs a machine-readable description
  - of the UUIDs. -}
 prettyPrintUUIDs :: String -> [UUID] -> Annex String
-prettyPrintUUIDs desc uuids = do
+prettyPrintUUIDs desc uuids = prettyPrintUUIDsWith Nothing desc $
+	zip uuids (repeat (Nothing :: Maybe String))
+
+{- An optional field can be included in the list of UUIDs. -}
+prettyPrintUUIDsWith
+	:: (JSON v, Show v) 
+	=> Maybe String 
+	-> String 
+	-> [(UUID, Maybe v)] 
+	-> Annex String
+prettyPrintUUIDsWith optfield desc uuids = do
 	hereu <- getUUID
 	m <- uuidDescriptions
 	maybeShowJSON [(desc, map (jsonify m hereu) uuids)]
 	return $ unwords $ map (\u -> "\t" ++ prettify m hereu u ++ "\n") uuids
   where
 	finddescription m u = M.findWithDefault "" u m
-	prettify m hereu u
-		| not (null d) = fromUUID u ++ " -- " ++ d
-		| otherwise = fromUUID u
+	prettify m hereu (u, optval)
+		| not (null d) = addoptval $ fromUUID u ++ " -- " ++ d
+		| otherwise = addoptval $ fromUUID u
 	  where
 		ishere = hereu == u
 		n = finddescription m u
@@ -188,10 +199,16 @@ prettyPrintUUIDs desc uuids = do
 			| null n && ishere = "here"
 			| ishere = addName n "here"
 			| otherwise = n
-	jsonify m hereu u = toJSObject
-		[ ("uuid", toJSON $ fromUUID u)
-		, ("description", toJSON $ finddescription m u)
-		, ("here", toJSON $ hereu == u)
+		addoptval s = case optval of
+			Nothing -> s
+			Just val -> show val ++ ": " ++ s
+	jsonify m hereu (u, optval) = toJSObject $ catMaybes
+		[ Just ("uuid", toJSON $ fromUUID u)
+		, Just ("description", toJSON $ finddescription m u)
+		, Just ("here", toJSON $ hereu == u)
+		, case (optfield, optval) of
+			(Just field, Just val) -> Just (field, showJSON val)
+			_ -> Nothing
 		]
 
 {- List of remote names and/or descriptions, for human display.  -}

debian/changelog

@@ -32,6 +32,8 @@ git-annex (5.20150529) UNRELEASED; urgency=medium
   * Improve url parsing to handle some urls containing illegal []
     characters in their paths.
   * debian/cabal-wrapper: Removed this hack which should not be needed anymore.
+  * info: Added json output for "backend usage", "numcopies stats",
+    "repositories containing these files", and "transfers in progress".
 
  -- Joey Hess <id@joeyh.name>  Sat, 30 May 2015 02:07:18 -0400
 

doc/bugs/transfer_in_progress_not_present_in_json_output.mdwn

@@ -26,3 +26,7 @@ transfers in progress:
 """]]
 
 [[anarcat]]
+
+> JSON output has to be implemented on a case by case basis for stat
+> displays; I've now added it to this and more. [[done]]
+> --[[Joey]]