c3d40b9ec3
Each command that first checks preferred content (and/or required content) and then does something that can change the sizes of repositories needs to call prepareLiveUpdate, and plumb it through the preferred content check and the location log update. So far, only Command.Drop is done. Many other commands that don't need to do this have been updated to keep working. There may be some calls to NoLiveUpdate in places where that should be done. All will need to be double checked. Not currently in a compilable state.
862 lines
25 KiB
Haskell
862 lines
25 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2011-2024 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE BangPatterns, DeriveDataTypeable, PackageImports #-}
|
|
{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}
|
|
|
|
module Command.Info where
|
|
|
|
import "mtl" Control.Monad.State.Strict
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Set as S
|
|
import qualified Data.Vector as V
|
|
import qualified System.FilePath.ByteString as P
|
|
import System.PosixCompat.Files (isDirectory)
|
|
import Data.Ord
|
|
import qualified Data.Semigroup as Sem
|
|
import Prelude
|
|
|
|
import Command
|
|
import qualified Git
|
|
import qualified Annex
|
|
import qualified Remote
|
|
import qualified Types.Remote as Remote
|
|
import qualified Annex.SpecialRemote as SpecialRemote
|
|
import Utility.DataUnits
|
|
import Utility.DiskFree
|
|
import Annex.Content
|
|
import Annex.UUID
|
|
import Annex.CatFile
|
|
import Annex.WorkTree
|
|
import Logs.UUID
|
|
import Logs.Trust
|
|
import Logs.Location
|
|
import Annex.Branch (UnmergedBranches(..), getUnmergedRefs)
|
|
import Annex.NumCopies
|
|
import Git.Config (boolConfig)
|
|
import qualified Git.LsTree as LsTree
|
|
import Utility.Percentage
|
|
import Utility.Aeson hiding (json)
|
|
import Types.Transfer
|
|
import Logs.Transfer
|
|
import Types.Key
|
|
import Types.TrustLevel
|
|
import Types.FileMatcher
|
|
import Types.Availability
|
|
import qualified Limit
|
|
import Messages.JSON (DualDisp(..), ObjectMap(..))
|
|
import Annex.BloomFilter
|
|
import Annex.RepoSize
|
|
import qualified Command.Unused
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
-- a named computation that produces a statistic
|
|
type Stat = StatState (Maybe (String, StatState String))
|
|
|
|
-- data about a set of keys
|
|
data KeyInfo = KeyInfo
|
|
{ countKeys :: Integer
|
|
, sizeKeys :: Integer
|
|
, unknownSizeKeys :: Integer
|
|
, backendsKeys :: M.Map KeyVariety Integer
|
|
}
|
|
|
|
instance Sem.Semigroup KeyInfo where
|
|
a <> b = KeyInfo
|
|
{ countKeys = countKeys a + countKeys b
|
|
, sizeKeys = sizeKeys a + sizeKeys b
|
|
, unknownSizeKeys = unknownSizeKeys a + unknownSizeKeys b
|
|
, backendsKeys = backendsKeys a <> backendsKeys b
|
|
}
|
|
|
|
instance Monoid KeyInfo where
|
|
mempty = KeyInfo 0 0 0 M.empty
|
|
|
|
data NumCopiesStats = NumCopiesStats
|
|
{ numCopiesVarianceMap :: M.Map Variance Integer
|
|
}
|
|
|
|
newtype Variance = Variance Int
|
|
deriving (Eq, Ord)
|
|
|
|
instance Show Variance where
|
|
show (Variance n)
|
|
| n >= 0 = "+" ++ show n
|
|
| otherwise = show n
|
|
|
|
-- cached info that multiple Stats use
|
|
data StatInfo = StatInfo
|
|
{ presentData :: Maybe KeyInfo
|
|
, referencedData :: Maybe KeyInfo
|
|
, repoData :: M.Map UUID KeyInfo
|
|
, allRepoData :: Maybe KeyInfo
|
|
, numCopiesStats :: Maybe NumCopiesStats
|
|
, infoOptions :: InfoOptions
|
|
}
|
|
|
|
emptyStatInfo :: InfoOptions -> StatInfo
|
|
emptyStatInfo = StatInfo Nothing Nothing M.empty Nothing Nothing
|
|
|
|
-- a state monad for running Stats in
|
|
type StatState = StateT StatInfo Annex
|
|
|
|
cmd :: Command
|
|
cmd = noCommit $ withAnnexOptions [jsonOptions, annexedMatchingOptions] $
|
|
command "info" SectionQuery
|
|
"information about an item or the repository"
|
|
(paramRepeating paramItem) (seek <$$> optParser)
|
|
|
|
data InfoOptions = InfoOptions
|
|
{ infoFor :: CmdParams
|
|
, bytesOption :: Bool
|
|
, batchOption :: BatchMode
|
|
, autoenableOption :: Bool
|
|
, deadrepositoriesOption :: Bool
|
|
}
|
|
|
|
optParser :: CmdParamsDesc -> Parser InfoOptions
|
|
optParser desc = InfoOptions
|
|
<$> cmdParamsWithCompleter desc (completeFiles <> completeRemotes)
|
|
<*> switch
|
|
( long "bytes"
|
|
<> help "display file sizes in bytes"
|
|
)
|
|
<*> parseBatchOption False
|
|
<*> switch
|
|
( long "autoenable"
|
|
<> help "list special remotes that are configured to autoenable"
|
|
)
|
|
<*> switch
|
|
( long "dead-repositories"
|
|
<> help "list repositories that have been marked as dead"
|
|
)
|
|
|
|
seek :: InfoOptions -> CommandSeek
|
|
seek o = case batchOption o of
|
|
NoBatch -> withWords (commandAction . start o) (infoFor o)
|
|
Batch fmt -> batchOnly Nothing (infoFor o) $
|
|
batchInput fmt (pure . Right) (itemInfo o)
|
|
|
|
start :: InfoOptions -> [String] -> CommandStart
|
|
start o [] = do
|
|
if autoenableOption o
|
|
then autoenableInfo
|
|
else if deadrepositoriesOption o
|
|
then deadrepositoriesInfo o
|
|
else globalInfo o
|
|
stop
|
|
start o ps = do
|
|
mapM_ (\p -> itemInfo o (SeekInput [p], p)) ps
|
|
stop
|
|
|
|
globalInfo :: InfoOptions -> Annex ()
|
|
globalInfo o = do
|
|
u <- getUUID
|
|
whenM ((==) DeadTrusted <$> lookupTrust u) $
|
|
earlyWarning "Warning: This repository is currently marked as dead."
|
|
stats <- selStats global_fast_stats global_slow_stats
|
|
showCustom "info" (SeekInput []) $ do
|
|
evalStateT (mapM_ showStat stats) (emptyStatInfo o)
|
|
return True
|
|
|
|
autoenableInfo :: Annex ()
|
|
autoenableInfo = showCustom "info" (SeekInput []) $ do
|
|
m <- SpecialRemote.specialRemoteNameMap
|
|
<$> SpecialRemote.autoEnableable
|
|
descm <- M.unionWith Remote.addName
|
|
<$> uuidDescMap
|
|
<*> pure (M.map toUUIDDesc m)
|
|
s <- Remote.prettyPrintUUIDsDescs
|
|
"autoenable special remotes"
|
|
descm (M.keys m)
|
|
showRaw (encodeBS s)
|
|
return True
|
|
|
|
deadrepositoriesInfo :: InfoOptions -> Annex ()
|
|
deadrepositoriesInfo o = showCustom "info" (SeekInput []) $ do
|
|
evalStateT (showStat (repo_list DeadTrusted)) (emptyStatInfo o)
|
|
return True
|
|
|
|
itemInfo :: InfoOptions -> (SeekInput, String) -> Annex ()
|
|
itemInfo o (si, p) = ifM (isdir (toRawFilePath p))
|
|
( dirInfo o p si
|
|
, Remote.byName' p >>= \case
|
|
Right r -> remoteInfo o r si
|
|
Left _ -> Remote.nameToUUID' p >>= \case
|
|
([], _) -> do
|
|
relp <- liftIO $ relPathCwdToFile (toRawFilePath p)
|
|
lookupKey relp >>= \case
|
|
Just k -> fileInfo o (fromRawFilePath relp) si k
|
|
Nothing -> treeishInfo o p si
|
|
([u], _) -> uuidInfo o u si
|
|
(_us, msg) -> noInfo p si msg
|
|
)
|
|
where
|
|
isdir = liftIO . catchBoolIO . (isDirectory <$$> R.getFileStatus)
|
|
|
|
noInfo :: String -> SeekInput -> String -> Annex ()
|
|
noInfo s si msg = do
|
|
-- The string may not really be a file, but use ActionItemTreeFile,
|
|
-- rather than ActionItemOther to avoid breaking back-compat of
|
|
-- json output.
|
|
let ai = ActionItemTreeFile (toRawFilePath s)
|
|
showStartMessage (StartMessage "info" ai si)
|
|
showNote (UnquotedString msg)
|
|
showEndFail
|
|
Annex.incError
|
|
|
|
dirInfo :: InfoOptions -> FilePath -> SeekInput -> Annex ()
|
|
dirInfo o dir si = showCustom (unwords ["info", dir]) si $ do
|
|
stats <- selStats
|
|
(tostats (dir_name:tree_fast_stats True))
|
|
(tostats tree_slow_stats)
|
|
evalStateT (mapM_ showStat stats) =<< getDirStatInfo o dir
|
|
return True
|
|
where
|
|
tostats = map (\s -> s dir)
|
|
|
|
treeishInfo :: InfoOptions -> String -> SeekInput -> Annex ()
|
|
treeishInfo o t si = do
|
|
mi <- getTreeStatInfo o (Git.Ref (encodeBS t))
|
|
case mi of
|
|
Nothing -> noInfo t si
|
|
"not a directory or an annexed file or a treeish or a remote or a uuid"
|
|
Just i -> showCustom (unwords ["info", t]) si $ do
|
|
stats <- selStats
|
|
(tostats (tree_name:tree_fast_stats False))
|
|
(tostats tree_slow_stats)
|
|
evalStateT (mapM_ showStat stats) i
|
|
return True
|
|
where
|
|
tostats = map (\s -> s t)
|
|
|
|
fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex ()
|
|
fileInfo o file si k = do
|
|
matcher <- Limit.getMatcher
|
|
let file' = toRawFilePath file
|
|
whenM (matcher $ MatchingFile $ FileInfo file' file' (Just k)) $
|
|
showCustom (unwords ["info", file]) si $ do
|
|
evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o)
|
|
return True
|
|
|
|
remoteInfo :: InfoOptions -> Remote -> SeekInput -> Annex ()
|
|
remoteInfo o r si = showCustom (unwords ["info", Remote.name r]) si $ do
|
|
i <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r
|
|
let u = Remote.uuid r
|
|
l <- selStats
|
|
(uuid_fast_stats u ++ remote_fast_stats r ++ i)
|
|
(uuid_slow_stats u)
|
|
evalStateT (mapM_ showStat l) (emptyStatInfo o)
|
|
return True
|
|
|
|
uuidInfo :: InfoOptions -> UUID -> SeekInput -> Annex ()
|
|
uuidInfo o u si = showCustom (unwords ["info", fromUUID u]) si $ do
|
|
l <- selStats (uuid_fast_stats u) (uuid_slow_stats u)
|
|
evalStateT (mapM_ showStat l) (emptyStatInfo o)
|
|
return True
|
|
|
|
selStats :: [Stat] -> [Stat] -> Annex [Stat]
|
|
selStats fast_stats slow_stats = do
|
|
fast <- Annex.getRead Annex.fast
|
|
return $ if fast
|
|
then fast_stats
|
|
else fast_stats ++ slow_stats
|
|
|
|
{- Order is significant. Less expensive operations, and operations
|
|
- that share data go together.
|
|
-}
|
|
global_fast_stats :: [Stat]
|
|
global_fast_stats =
|
|
[ repo_list Trusted
|
|
, repo_list SemiTrusted
|
|
, repo_list UnTrusted
|
|
, transfer_list
|
|
, disk_size
|
|
]
|
|
|
|
global_slow_stats :: [Stat]
|
|
global_slow_stats =
|
|
[ tmp_size
|
|
, bad_data_size
|
|
, local_annex_keys
|
|
, local_annex_size
|
|
, known_annex_files True
|
|
, known_annex_size True
|
|
, total_annex_size
|
|
, reposizes_stats_global
|
|
, backend_usage
|
|
, bloom_info
|
|
]
|
|
|
|
tree_fast_stats :: Bool -> [FilePath -> Stat]
|
|
tree_fast_stats isworktree =
|
|
[ const local_annex_keys
|
|
, const local_annex_size
|
|
, const (known_annex_files isworktree)
|
|
, const (known_annex_size isworktree)
|
|
]
|
|
|
|
tree_slow_stats :: [FilePath -> Stat]
|
|
tree_slow_stats =
|
|
[ const numcopies_stats
|
|
, const reposizes_stats_tree
|
|
, const reposizes_total
|
|
]
|
|
|
|
file_stats :: FilePath -> Key -> [Stat]
|
|
file_stats f k =
|
|
[ file_name f
|
|
, key_size k
|
|
, key_name k
|
|
, content_present k
|
|
]
|
|
|
|
remote_fast_stats :: Remote -> [Stat]
|
|
remote_fast_stats r = map (\s -> s r)
|
|
[ remote_name
|
|
, remote_cost
|
|
, remote_type
|
|
, remote_availabile
|
|
]
|
|
|
|
uuid_fast_stats :: UUID -> [Stat]
|
|
uuid_fast_stats u = map (\s -> s u)
|
|
[ repo_uuid
|
|
, repo_description
|
|
, repo_trust
|
|
]
|
|
|
|
uuid_slow_stats :: UUID -> [Stat]
|
|
uuid_slow_stats u = map (\s -> s u)
|
|
[ repo_annex_keys
|
|
, repo_annex_size
|
|
]
|
|
|
|
stat :: String -> (String -> StatState String) -> Stat
|
|
stat desc a = return $ Just (desc, a desc)
|
|
|
|
-- The json simply contains the same string that is displayed.
|
|
simpleStat :: String -> StatState String -> Stat
|
|
simpleStat desc getval = stat desc $ json id getval
|
|
|
|
nostat :: Stat
|
|
nostat = return Nothing
|
|
|
|
json :: ToJSON' j => (j -> String) -> StatState j -> String -> StatState String
|
|
json fmt a desc = do
|
|
j <- a
|
|
lift $ maybeShowJSON $ JSONChunk [(desc, j)]
|
|
return $ fmt j
|
|
|
|
nojson :: StatState String -> String -> StatState String
|
|
nojson a _ = a
|
|
|
|
showStat :: Stat -> StatState ()
|
|
showStat s = maybe noop calc =<< s
|
|
where
|
|
calc (desc, a) = do
|
|
(lift . showHeader . encodeBS) desc
|
|
lift . showRaw . encodeBS =<< a
|
|
|
|
repo_list :: TrustLevel -> Stat
|
|
repo_list level = stat n $ nojson $ lift $ do
|
|
us <- filter (/= NoUUID) . M.keys
|
|
<$> (M.union <$> (M.map fromUUIDDesc <$> uuidDescMap) <*> Remote.remoteMap Remote.name)
|
|
rs <- fst <$> trustPartition level us
|
|
countRepoList (length rs)
|
|
-- This also handles json display.
|
|
<$> Remote.prettyPrintUUIDs n rs
|
|
where
|
|
n = showTrustLevel level ++ " repositories"
|
|
|
|
countRepoList :: Int -> String -> String
|
|
countRepoList _ [] = "0"
|
|
countRepoList n s = show n ++ "\n" ++ beginning s
|
|
|
|
dispRepoList :: String -> String
|
|
dispRepoList [] = ""
|
|
dispRepoList s = "\n" ++ beginning s
|
|
|
|
dir_name :: FilePath -> Stat
|
|
dir_name dir = simpleStat "directory" $ pure dir
|
|
|
|
tree_name :: String -> Stat
|
|
tree_name t = simpleStat "tree" $ pure t
|
|
|
|
file_name :: FilePath -> Stat
|
|
file_name file = simpleStat "file" $ pure file
|
|
|
|
remote_name :: Remote -> Stat
|
|
remote_name r = simpleStat "remote" $ pure (Remote.name r)
|
|
|
|
repo_description :: UUID -> Stat
|
|
repo_description = simpleStat "description" . lift . Remote.prettyUUID
|
|
|
|
repo_uuid :: UUID -> Stat
|
|
repo_uuid = simpleStat "uuid" . pure . fromUUID
|
|
|
|
repo_trust :: UUID -> Stat
|
|
repo_trust u = simpleStat "trust" $ lift $ showTrustLevel <$> lookupTrust u
|
|
|
|
remote_cost :: Remote -> Stat
|
|
remote_cost r = simpleStat "cost" $ pure $
|
|
show $ Remote.cost r
|
|
|
|
remote_type :: Remote -> Stat
|
|
remote_type r = simpleStat "type" $ pure $
|
|
Remote.typename $ Remote.remotetype r
|
|
|
|
remote_availabile :: Remote -> Stat
|
|
remote_availabile r = simpleStat "available" $ lift $
|
|
either show (\av -> boolConfig (av /= Unavailable))
|
|
<$> tryNonAsync (Remote.availability r)
|
|
|
|
local_annex_keys :: Stat
|
|
local_annex_keys = stat "local annex keys" $ json show $
|
|
countKeys <$> cachedPresentData
|
|
|
|
local_annex_size :: Stat
|
|
local_annex_size = simpleStat "local annex size" $
|
|
showSizeKeys =<< cachedPresentData
|
|
|
|
-- "remote" is in the name for JSON backwards-compatibility
|
|
repo_annex_keys :: UUID -> Stat
|
|
repo_annex_keys u = stat "remote annex keys" $ \d ->
|
|
cachedRemoteData u >>= \case
|
|
Right rd -> json show (pure (countKeys rd)) d
|
|
Left n-> json id (pure n) d
|
|
|
|
-- "remote" is in the name for JSON backwards-compatibility
|
|
repo_annex_size :: UUID -> Stat
|
|
repo_annex_size u = simpleStat "remote annex size" $
|
|
cachedRemoteData u >>= \case
|
|
Right d -> showSizeKeys d
|
|
Left n -> pure n
|
|
|
|
known_annex_files :: Bool -> Stat
|
|
known_annex_files isworktree =
|
|
stat ("annexed files in " ++ treeDesc isworktree) $ json show $
|
|
countKeys <$> cachedReferencedData
|
|
|
|
known_annex_size :: Bool -> Stat
|
|
known_annex_size isworktree =
|
|
simpleStat ("size of annexed files in " ++ treeDesc isworktree) $
|
|
showSizeKeys =<< cachedReferencedData
|
|
|
|
total_annex_size :: Stat
|
|
total_annex_size =
|
|
simpleStat "combined annex size of all repositories" $
|
|
showSizeKeys . fromMaybe mempty . allRepoData
|
|
=<< cachedAllRepoData
|
|
|
|
treeDesc :: Bool -> String
|
|
treeDesc True = "working tree"
|
|
treeDesc False = "tree"
|
|
|
|
tmp_size :: Stat
|
|
tmp_size = staleSize "temporary object directory size" gitAnnexTmpObjectDir
|
|
|
|
bad_data_size :: Stat
|
|
bad_data_size = staleSize "bad keys size" gitAnnexBadDir
|
|
|
|
key_size :: Key -> Stat
|
|
key_size k = simpleStat "size" $ showSizeKeys $ addKey k emptyKeyInfo
|
|
|
|
key_name :: Key -> Stat
|
|
key_name k = simpleStat "key" $ pure $ serializeKey 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
|
|
capacity <- fromIntegral <$> lift bloomCapacity
|
|
let note = aside $
|
|
if localkeys >= capacity
|
|
then "appears too small for this repository; adjust annex.bloomcapacity"
|
|
else showPercentage 1 (percentage capacity localkeys) ++ " full"
|
|
|
|
-- Two bloom filters are used at the same time when running
|
|
-- git-annex unused, so double the size of one.
|
|
sizer <- mkSizer
|
|
size <- sizer committeeUnits False . (* 2) . fromIntegral . fst <$>
|
|
lift bloomBitsHashes
|
|
|
|
return $ size ++ note
|
|
|
|
transfer_list :: Stat
|
|
transfer_list = stat desc $ nojson $ lift $ do
|
|
uuidmap <- Remote.remoteMap id
|
|
ts <- getTransfers
|
|
maybeShowJSON $ JSONChunk [(desc, V.fromList $ map (uncurry jsonify) ts)]
|
|
qp <- coreQuotePath <$> Annex.getGitConfig
|
|
return $ if null ts
|
|
then "none"
|
|
else multiLine $
|
|
map (uncurry $ line qp uuidmap) $ sort ts
|
|
where
|
|
desc = "transfers in progress"
|
|
line qp uuidmap t i = unwords
|
|
[ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing"
|
|
, fromRawFilePath $ quote qp $ actionItemDesc $ mkActionItem
|
|
(transferKey t, associatedFile i)
|
|
, if transferDirection t == Upload then "to" else "from"
|
|
, maybe (fromUUID $ transferUUID t) Remote.name $
|
|
M.lookup (transferUUID t) uuidmap
|
|
]
|
|
jsonify t i = object $ map (\(k, v) -> (textKey (packString k), v)) $
|
|
[ ("transfer", toJSON' (formatDirection (transferDirection t)))
|
|
, ("key", toJSON' (transferKey t))
|
|
, ("file", toJSON' (fromRawFilePath <$> afile))
|
|
, ("remote", toJSON' (fromUUID (transferUUID t) :: String))
|
|
]
|
|
where
|
|
AssociatedFile afile = associatedFile i
|
|
|
|
disk_size :: Stat
|
|
disk_size = simpleStat "available local disk space" $
|
|
calcfree
|
|
<$> (lift $ annexDiskReserve <$> Annex.getGitConfig)
|
|
<*> (lift $ inRepo $ getDiskFree . fromRawFilePath . gitAnnexDir)
|
|
<*> mkSizer
|
|
where
|
|
calcfree reserve (Just have) sizer = unwords
|
|
[ sizer storageUnits False $ nonneg $ have - reserve
|
|
, "(+" ++ sizer storageUnits False reserve
|
|
, "reserved)"
|
|
]
|
|
calcfree _ _ _ = "unknown"
|
|
|
|
nonneg x
|
|
| x >= 0 = x
|
|
| otherwise = 0
|
|
|
|
backend_usage :: Stat
|
|
backend_usage = stat "backend usage" $ json fmt $
|
|
ObjectMap . (M.mapKeys (decodeBS . formatKeyVariety)) . backendsKeys
|
|
<$> cachedReferencedData
|
|
where
|
|
fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . sort . M.toList . fromObjectMap
|
|
|
|
numcopies_stats :: Stat
|
|
numcopies_stats = stat "numcopies stats" $ json fmt $
|
|
calc <$> (maybe M.empty numCopiesVarianceMap <$> cachedNumCopiesStats)
|
|
where
|
|
calc = V.fromList
|
|
. map (\(variance, count) -> (show variance, count))
|
|
. sortBy (flip (comparing fst))
|
|
. M.toList
|
|
fmt = multiLine
|
|
. map (\(variance, count) -> "numcopies " ++ variance ++ ": " ++ show count)
|
|
. V.toList
|
|
|
|
reposizes_stats_tree :: Stat
|
|
reposizes_stats_tree = reposizes_stats True "repositories containing these files"
|
|
=<< cachedRepoData
|
|
|
|
reposizes_stats_global :: Stat
|
|
reposizes_stats_global = reposizes_stats False "annex sizes of repositories"
|
|
. repoData =<< cachedAllRepoData
|
|
|
|
reposizes_stats :: Bool -> String -> M.Map UUID KeyInfo -> Stat
|
|
reposizes_stats count desc m = stat desc $ nojson $ do
|
|
sizer <- mkSizer
|
|
let l = map (\(u, kd) -> (u, sizer storageUnits True (sizeKeys kd))) $
|
|
sortBy (flip (comparing (sizeKeys . snd))) $
|
|
M.toList m
|
|
let maxlen = maximum (map (length . snd) l)
|
|
descm <- lift Remote.uuidDescriptions
|
|
-- This also handles json display.
|
|
s <- lift $ Remote.prettyPrintUUIDsWith (Just "size") desc descm
|
|
(\sz -> Just $ show sz ++ ": ") $
|
|
map (\(u, sz) -> (u, Just $ mkdisp sz maxlen)) l
|
|
return $ if count
|
|
then countRepoList (length l) s
|
|
else dispRepoList s
|
|
where
|
|
mkdisp sz maxlen = DualDisp
|
|
{ dispNormal = lpad maxlen sz
|
|
, dispJson = sz
|
|
}
|
|
lpad n s = (replicate (n - length s) ' ') ++ s
|
|
|
|
reposizes_total :: Stat
|
|
reposizes_total = simpleStat "combined size of repositories containing these files" $
|
|
showSizeKeys . mconcat . M.elems =<< cachedRepoData
|
|
|
|
cachedPresentData :: StatState KeyInfo
|
|
cachedPresentData = do
|
|
s <- get
|
|
case presentData s of
|
|
Just v -> return v
|
|
Nothing -> do
|
|
matcher <- lift getKeyOnlyMatcher
|
|
v <- foldl' (flip addKey) emptyKeyInfo
|
|
<$> lift (listKeys' InAnnex (matchOnKey matcher))
|
|
put s { presentData = Just v }
|
|
return v
|
|
|
|
cachedRemoteData :: UUID -> StatState (Either String KeyInfo)
|
|
cachedRemoteData u = do
|
|
s <- get
|
|
case M.lookup u (repoData s) of
|
|
Just v -> return (Right v)
|
|
Nothing -> do
|
|
matcher <- lift getKeyOnlyMatcher
|
|
let combinedata d uk = finishCheck uk >>= \case
|
|
Nothing -> return d
|
|
Just k -> ifM (matchOnKey matcher k)
|
|
( return (addKey k d)
|
|
, return d
|
|
)
|
|
lift (loggedKeysFor' u) >>= \case
|
|
Just (ks, cleanup) -> do
|
|
v <- lift $ foldM combinedata emptyKeyInfo ks
|
|
liftIO $ void cleanup
|
|
put s { repoData = M.insert u v (repoData s) }
|
|
return (Right v)
|
|
Nothing -> return (Left "not available in this read-only repository with unmerged git-annex branches")
|
|
|
|
cachedReferencedData :: StatState KeyInfo
|
|
cachedReferencedData = do
|
|
s <- get
|
|
case referencedData s of
|
|
Just v -> return v
|
|
Nothing -> do
|
|
matcher <- lift getKeyOnlyMatcher
|
|
let combinedata k _f d = ifM (matchOnKey matcher k)
|
|
( return (addKey k d)
|
|
, return d
|
|
)
|
|
!v <- lift $ Command.Unused.withKeysReferenced
|
|
emptyKeyInfo combinedata
|
|
put s { referencedData = Just v }
|
|
return v
|
|
|
|
cachedAllRepoData :: StatState StatInfo
|
|
cachedAllRepoData = do
|
|
s <- get
|
|
case allRepoData s of
|
|
Just _ -> return s
|
|
Nothing -> do
|
|
s' <- ifM (lift Limit.limited)
|
|
( limitedcalc s
|
|
, usereposizes s
|
|
)
|
|
put s'
|
|
return s'
|
|
where
|
|
usereposizes s = do
|
|
sizemap <- lift $ getRepoSizes True
|
|
deadset <- lift $ S.fromList <$> trustGet DeadTrusted
|
|
let sizemap' = M.filter (> 0) $ M.withoutKeys sizemap deadset
|
|
lift $ unlessM (null <$> getUnmergedRefs)
|
|
warnunmerged
|
|
return $ s
|
|
{ allRepoData = Just $
|
|
convsize (sum (M.elems sizemap'))
|
|
, repoData = M.map convsize sizemap'
|
|
}
|
|
|
|
limitedcalc s = do
|
|
matcher <- lift getKeyOnlyMatcher
|
|
r <- lift $ overLocationLogs False False (emptyKeyInfo, mempty) $ \k locs (d, rd) -> do
|
|
ifM (matchOnKey matcher k)
|
|
( do
|
|
alivelocs <- snd
|
|
<$> trustPartition DeadTrusted locs
|
|
let !d' = addKeyCopies (genericLength alivelocs) k d
|
|
let !rd' = foldl' (flip (accumrepodata k)) rd alivelocs
|
|
return (d', rd')
|
|
, return (d, rd)
|
|
)
|
|
(!(d, rd), _) <- case r of
|
|
NoUnmergedBranches v ->
|
|
return v
|
|
UnmergedBranches v -> do
|
|
lift warnunmerged
|
|
return v
|
|
return $ s { allRepoData = Just d, repoData = rd }
|
|
|
|
accumrepodata k = M.alter (Just . addKey k . fromMaybe emptyKeyInfo)
|
|
|
|
convsize (RepoSize sz) = emptyKeyInfo { sizeKeys = sz }
|
|
|
|
warnunmerged = warning "There are unmerged git-annex branches. Information from those branches is not included here."
|
|
|
|
cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
|
|
cachedNumCopiesStats = numCopiesStats <$> get
|
|
|
|
cachedRepoData :: StatState (M.Map UUID KeyInfo)
|
|
cachedRepoData = repoData <$> get
|
|
|
|
getDirStatInfo :: InfoOptions -> FilePath -> Annex StatInfo
|
|
getDirStatInfo o dir = do
|
|
fast <- Annex.getRead Annex.fast
|
|
matcher <- Limit.getMatcher
|
|
(presentdata, referenceddata, numcopiesstats, repodata) <-
|
|
Command.Unused.withKeysFilesReferencedIn dir initial
|
|
(update matcher fast)
|
|
return $ StatInfo
|
|
(Just presentdata)
|
|
(Just referenceddata)
|
|
repodata
|
|
Nothing
|
|
(Just numcopiesstats)
|
|
o
|
|
where
|
|
initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty)
|
|
update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) =
|
|
ifM (matcher $ MatchingFile $ FileInfo file file (Just key))
|
|
( do
|
|
!presentdata' <- ifM (inAnnex key)
|
|
( return $ addKey key presentdata
|
|
, return presentdata
|
|
)
|
|
let !referenceddata' = addKey key referenceddata
|
|
(!numcopiesstats', !repodata') <- if fast
|
|
then return (numcopiesstats, repodata)
|
|
else do
|
|
locs <- Remote.keyLocations key
|
|
nc <- updateNumCopiesStats file numcopiesstats locs
|
|
return (nc, updateRepoData key locs repodata)
|
|
return $! (presentdata', referenceddata', numcopiesstats', repodata')
|
|
, return vs
|
|
)
|
|
|
|
getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo)
|
|
getTreeStatInfo o r = do
|
|
fast <- Annex.getRead Annex.fast
|
|
-- git lstree filenames start with a leading "./" that prevents
|
|
-- matching, and also things like --include are supposed to
|
|
-- match relative to the current directory, which does not make
|
|
-- sense when matching against files in some arbitrary tree.
|
|
matcher <- getKeyOnlyMatcher
|
|
(ls, cleanup) <- inRepo $ LsTree.lsTree
|
|
LsTree.LsTreeRecursive
|
|
(LsTree.LsTreeLong False)
|
|
r
|
|
(presentdata, referenceddata, repodata) <- go fast matcher ls initial
|
|
ifM (liftIO cleanup)
|
|
( return $ Just $
|
|
StatInfo (Just presentdata) (Just referenceddata) repodata Nothing Nothing o
|
|
, return Nothing
|
|
)
|
|
where
|
|
initial = (emptyKeyInfo, emptyKeyInfo, M.empty)
|
|
go _ _ [] vs = return vs
|
|
go fast matcher (l:ls) vs@(presentdata, referenceddata, repodata) =
|
|
catKey (LsTree.sha l) >>= \case
|
|
Nothing -> go fast matcher ls vs
|
|
Just key -> ifM (matchOnKey matcher key)
|
|
( do
|
|
!presentdata' <- ifM (inAnnex key)
|
|
( return $ addKey key presentdata
|
|
, return presentdata
|
|
)
|
|
let !referenceddata' = addKey key referenceddata
|
|
!repodata' <- if fast
|
|
then return repodata
|
|
else do
|
|
locs <- Remote.keyLocations key
|
|
return (updateRepoData key locs repodata)
|
|
go fast matcher ls $! (presentdata', referenceddata', repodata')
|
|
, go fast matcher ls vs
|
|
)
|
|
|
|
emptyKeyInfo :: KeyInfo
|
|
emptyKeyInfo = KeyInfo 0 0 0 M.empty
|
|
|
|
emptyNumCopiesStats :: NumCopiesStats
|
|
emptyNumCopiesStats = NumCopiesStats M.empty
|
|
|
|
addKey :: Key -> KeyInfo -> KeyInfo
|
|
addKey = addKeyCopies 1
|
|
|
|
addKeyCopies :: Integer -> Key -> KeyInfo -> KeyInfo
|
|
addKeyCopies numcopies key (KeyInfo count size unknownsize backends) =
|
|
KeyInfo count' size' unknownsize' backends'
|
|
where
|
|
{- All calculations strict to avoid thunks when repeatedly
|
|
- applied to many keys. -}
|
|
!count' = count + 1
|
|
!backends' = M.insertWith (+) (fromKey keyVariety key) 1 backends
|
|
!size' = maybe size (\sz -> sz * numcopies + size) ks
|
|
!unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks
|
|
!ks = fromKey keySize key
|
|
|
|
updateRepoData :: Key -> [UUID] -> M.Map UUID KeyInfo -> M.Map UUID KeyInfo
|
|
updateRepoData key locs m = m'
|
|
where
|
|
!m' = M.unionWith (\_old new -> new) m $
|
|
M.fromList $ zip locs (map update locs)
|
|
update loc = addKey key (fromMaybe emptyKeyInfo $ M.lookup loc m)
|
|
|
|
updateNumCopiesStats :: RawFilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats
|
|
updateNumCopiesStats file (NumCopiesStats m) locs = do
|
|
have <- trustExclude UnTrusted locs
|
|
!variance <- Variance <$> numCopiesCheck' file (-) have
|
|
let !m' = M.insertWith (+) variance 1 m
|
|
let !ret = NumCopiesStats m'
|
|
return ret
|
|
|
|
showSizeKeys :: KeyInfo -> StatState String
|
|
showSizeKeys d = do
|
|
sizer <- mkSizer
|
|
return $ total sizer ++ missingnote
|
|
where
|
|
total sizer = sizer storageUnits False $ sizeKeys d
|
|
missingnote
|
|
| unknownSizeKeys d == 0 = ""
|
|
| otherwise = aside $
|
|
"+ " ++ show (unknownSizeKeys d) ++
|
|
" unknown size"
|
|
|
|
staleSize :: String -> (Git.Repo -> RawFilePath) -> Stat
|
|
staleSize label dirspec = go =<< lift (dirKeys dirspec)
|
|
where
|
|
go [] = nostat
|
|
go keys = onsize =<< sum <$> keysizes keys
|
|
onsize 0 = nostat
|
|
onsize size = stat label $
|
|
json (++ aside "clean up with git-annex unused") $ do
|
|
sizer <- mkSizer
|
|
return $ sizer storageUnits False size
|
|
keysizes keys = do
|
|
dir <- lift $ fromRepo dirspec
|
|
liftIO $ forM keys $ \k ->
|
|
catchDefaultIO 0 $ getFileSize (dir P.</> keyFile k)
|
|
|
|
aside :: String -> String
|
|
aside s = " (" ++ s ++ ")"
|
|
|
|
multiLine :: [String] -> String
|
|
multiLine = concatMap (\l -> "\n\t" ++ l)
|
|
|
|
mkSizer :: StatState ([Unit] -> Bool -> ByteSize -> String)
|
|
mkSizer = ifM (bytesOption . infoOptions <$> get)
|
|
( return (const $ const show)
|
|
, return roughSize
|
|
)
|
|
|
|
getKeyOnlyMatcher :: Annex (MatchInfo -> Annex Bool)
|
|
getKeyOnlyMatcher = do
|
|
whenM (Limit.introspect matchNeedsFileName) $ do
|
|
warning "File matching options cannot be applied when getting this info."
|
|
giveup "Unable to continue."
|
|
Limit.getMatcher
|
|
|
|
matchOnKey :: (MatchInfo -> Annex Bool) -> Key -> Annex Bool
|
|
matchOnKey matcher k = matcher $ MatchingInfo $ ProvidedInfo
|
|
{ providedFilePath = Nothing
|
|
, providedKey = Just k
|
|
, providedFileSize = Nothing
|
|
, providedMimeType = Nothing
|
|
, providedMimeEncoding = Nothing
|
|
, providedLinkType = Nothing
|
|
}
|