diff --git a/Command/Info.hs b/Command/Info.hs index 1c2dd2fb2f..f5fa9c6bf7 100644 --- a/Command/Info.hs +++ b/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 diff --git a/Messages/JSON.hs b/Messages/JSON.hs index d0ed85a1f9..be3dbbc585 100644 --- a/Messages/JSON.hs +++ b/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 diff --git a/Remote.hs b/Remote.hs index 90cc6008ef..d425fc9183 100644 --- a/Remote.hs +++ b/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. -} diff --git a/debian/changelog b/debian/changelog index 2037de8da2..e05d80e4b6 100644 --- a/debian/changelog +++ b/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 Sat, 30 May 2015 02:07:18 -0400 diff --git a/doc/bugs/transfer_in_progress_not_present_in_json_output.mdwn b/doc/bugs/transfer_in_progress_not_present_in_json_output.mdwn index 1e4efe9da1..a6c8ebe8c7 100644 --- a/doc/bugs/transfer_in_progress_not_present_in_json_output.mdwn +++ b/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]]