diff options
| -rw-r--r-- | Command/Status.hs | 29 | ||||
| -rw-r--r-- | Logs/Group.hs | 14 | ||||
| -rw-r--r-- | Types/Group.hs | 7 |
3 files changed, 38 insertions, 12 deletions
diff --git a/Command/Status.hs b/Command/Status.hs index 7bb4dc8ca..a3f5f1df7 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -11,6 +11,7 @@ module Command.Status where import Control.Monad.State.Strict import qualified Data.Map as M +import qualified Data.Set as S import Text.JSON import Common.Annex @@ -32,6 +33,8 @@ import Remote import Config import Utility.Percentage import Logs.Transfer +import Logs.Group +import Types.Group -- a named computation that produces a statistic type Stat = StatState (Maybe (String, StatState String)) @@ -71,6 +74,7 @@ fast_stats = , remote_list SemiTrusted "semitrusted" , remote_list UnTrusted "untrusted" , remote_list DeadTrusted "dead" + , group_list , transfer_list , disk_size ] @@ -172,16 +176,23 @@ bloom_info = stat "bloom filter size" $ json id $ do return $ size ++ note +group_list :: Stat +group_list = stat "repository groups" $ nojson $ lift $ do + m <- uuidsByGroup <$> groupMap + ls <- forM (M.toList m) $ \(g, s) -> do + l <- Remote.prettyListUUIDs (S.toList s) + return $ g ++ ": " ++ intercalate ", " l + return $ show (M.size m) ++ multiLine ls + transfer_list :: Stat transfer_list = stat "transfers in progress" $ nojson $ lift $ do uuidmap <- Remote.remoteMap id ts <- getTransfers if null ts then return "none" - else return $ pp uuidmap "" $ sort ts + else return $ multiLine $ + map (\(t, i) -> line uuidmap t i) $ sort ts where - pp _ c [] = c - pp uuidmap c ((t, i):xs) = "\n\t" ++ line uuidmap t i ++ pp uuidmap c xs line uuidmap t i = unwords [ showLcDirection (transferDirection t) ++ "ing" , fromMaybe (key2file $ transferKey t) (associatedFile i) @@ -213,10 +224,11 @@ backend_usage = stat "backend usage" $ nojson $ <$> (backendsKeys <$> cachedReferencedData) <*> (backendsKeys <$> cachedPresentData) where - calc a b = pp "" $ reverse . sort $ map swap $ M.toList $ M.unionWith (+) a b - pp c [] = c - pp c ((n, b):xs) = "\n\t" ++ b ++ ": " ++ show n ++ pp c xs - swap (a, b) = (b, a) + calc x y = multiLine $ + map (\(n, b) -> b ++ ": " ++ show n) $ + reverse $ sort $ map swap $ M.toList $ + M.unionWith (+) x y + swap (x, y) = (y, x) cachedPresentData :: StatState KeyData cachedPresentData = do @@ -284,3 +296,6 @@ staleSize label dirspec = go =<< lift (Command.Unused.staleKeys dirspec) aside :: String -> String aside s = " (" ++ s ++ ")" + +multiLine :: [String] -> String +multiLine = concatMap (\l -> "\n\t" ++ l) diff --git a/Logs/Group.hs b/Logs/Group.hs index f701c5270..59f48f3a3 100644 --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -27,7 +27,7 @@ groupLog = "group.log" {- Returns the groups of a given repo UUID. -} lookupGroups :: UUID -> Annex (S.Set Group) -lookupGroups u = (fromMaybe S.empty . M.lookup u) <$> groupMap +lookupGroups u = (fromMaybe S.empty . M.lookup u) . groupsByUUID <$> groupMap {- Applies a set modifier to change the groups for a uuid in the groupLog. -} groupChange :: UUID -> (S.Set Group -> S.Set Group) -> Annex () @@ -48,7 +48,15 @@ groupMap = do case cached of Just m -> return m Nothing -> do - m <- simpleMap . parseLog (Just . S.fromList . words) <$> - Annex.Branch.get groupLog + m <- makeGroupMap . simpleMap . + parseLog (Just . S.fromList . words) <$> + Annex.Branch.get groupLog Annex.changeState $ \s -> s { Annex.groupmap = Just m } return m + +makeGroupMap :: M.Map UUID (S.Set Group) -> GroupMap +makeGroupMap byuuid = GroupMap byuuid bygroup + where + bygroup = M.fromListWith S.union $ + concat $ map explode $ M.toList byuuid + explode (u, s) = map (\g -> (g, S.singleton u)) (S.toList s) diff --git a/Types/Group.hs b/Types/Group.hs index dd06cbfd7..564e75d0f 100644 --- a/Types/Group.hs +++ b/Types/Group.hs @@ -7,7 +7,7 @@ module Types.Group ( Group, - GroupMap + GroupMap(..) ) where import Types.UUID @@ -17,4 +17,7 @@ import qualified Data.Set as S type Group = String -type GroupMap = M.Map UUID (S.Set Group) +data GroupMap = GroupMap + { groupsByUUID :: M.Map UUID (S.Set Group) + , uuidsByGroup :: M.Map Group (S.Set UUID) + } |