diff options
Diffstat (limited to 'Command/Status.hs')
| -rw-r--r-- | Command/Status.hs | 390 |
1 files changed, 67 insertions, 323 deletions
diff --git a/Command/Status.hs b/Command/Status.hs index af85fcc2a..5dc625994 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -1,345 +1,89 @@ {- git-annex command - - - Copyright 2011 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} - module Command.Status where -import "mtl" Control.Monad.State.Strict -import qualified Data.Map as M -import Text.JSON -import Data.Tuple -import System.PosixCompat.Files - import Common.Annex -import qualified Types.Backend as B -import qualified Types.Remote as R -import qualified Remote -import qualified Command.Unused -import qualified Git -import qualified Annex import Command -import Utility.DataUnits -import Utility.DiskFree -import Annex.Content -import Types.Key -import Backend -import Logs.UUID -import Logs.Trust -import Remote +import Annex.CatFile +import Annex.Content.Direct import Config -import Utility.Percentage -import Logs.Transfer -import Types.TrustLevel -import Types.FileMatcher -import qualified Limit - --- a named computation that produces a statistic -type Stat = StatState (Maybe (String, StatState String)) - --- data about a set of keys -data KeyData = KeyData - { countKeys :: Integer - , sizeKeys :: Integer - , unknownSizeKeys :: Integer - , backendsKeys :: M.Map String Integer - } - --- cached info that multiple Stats use -data StatInfo = StatInfo - { presentData :: Maybe KeyData - , referencedData :: Maybe KeyData - } - --- a state monad for running Stats in -type StatState = StateT StatInfo Annex +import qualified Git.LsFiles as LsFiles +import qualified Git.Ref +import qualified Git def :: [Command] -def = [command "status" paramPaths seek - SectionQuery "shows status information about the annex"] +def = [notBareRepo $ noCommit $ noMessages $ + command "status" paramPaths seek SectionCommon + "show the working tree status"] seek :: [CommandSeek] -seek = [withWords start] +seek = + [ withWords start + ] start :: [FilePath] -> CommandStart start [] = do - globalStatus - stop -start ps = do - mapM_ localStatus =<< filterM isdir ps - stop - where - isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) - -globalStatus :: Annex () -globalStatus = do - fast <- Annex.getState Annex.fast - let stats = if fast - then global_fast_stats - else global_fast_stats ++ global_slow_stats - showCustom "status" $ do - evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing) - return True - -localStatus :: FilePath -> Annex () -localStatus dir = showCustom (unwords ["status", dir]) $ do - let stats = map (\s -> s dir) local_stats - evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir - return True - -{- Order is significant. Less expensive operations, and operations - - that share data go together. - -} -global_fast_stats :: [Stat] -global_fast_stats = - [ supported_backends - , supported_remote_types - , repository_mode - , remote_list Trusted - , remote_list SemiTrusted - , remote_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_keys - , known_annex_size - , bloom_info - , backend_usage - ] -local_stats :: [FilePath -> Stat] -local_stats = - [ local_dir - , const local_annex_keys - , const local_annex_size - , const known_annex_keys - , const known_annex_size - ] - -stat :: String -> (String -> StatState String) -> Stat -stat desc a = return $ Just (desc, a desc) - -nostat :: Stat -nostat = return Nothing - -json :: JSON j => (j -> String) -> StatState j -> String -> StatState String -json serialize a desc = do - j <- a - lift $ maybeShowJSON [(desc, j)] - return $ serialize 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) desc - lift . showRaw =<< a - -supported_backends :: Stat -supported_backends = stat "supported backends" $ json unwords $ - return $ map B.name Backend.list - -supported_remote_types :: Stat -supported_remote_types = stat "supported remote types" $ json unwords $ - return $ map R.typename Remote.remoteTypes - -repository_mode :: Stat -repository_mode = stat "repository mode" $ json id $ lift $ - ifM isDirect - ( return "direct", return "indirect" ) - -remote_list :: TrustLevel -> Stat -remote_list level = stat n $ nojson $ lift $ do - us <- 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 - where - n = showTrustLevel level ++ " repositories" + -- Like git status, when run without a directory, behave as if + -- given the path to the top of the repository. + cwd <- liftIO getCurrentDirectory + top <- fromRepo Git.repoPath + next $ perform [relPathDirToFile cwd top] +start locs = next $ perform locs -local_dir :: FilePath -> Stat -local_dir dir = stat "directory" $ json id $ return dir - -local_annex_size :: Stat -local_annex_size = stat "local annex size" $ json id $ - showSizeKeys <$> cachedPresentData - -local_annex_keys :: Stat -local_annex_keys = stat "local annex keys" $ json show $ - countKeys <$> cachedPresentData - -known_annex_size :: Stat -known_annex_size = stat "known annex size" $ json id $ - showSizeKeys <$> cachedReferencedData - -known_annex_keys :: Stat -known_annex_keys = stat "known annex keys" $ json show $ - countKeys <$> cachedReferencedData - -tmp_size :: Stat -tmp_size = staleSize "temporary directory size" gitAnnexTmpDir - -bad_data_size :: Stat -bad_data_size = staleSize "bad keys size" gitAnnexBadDir - -bloom_info :: Stat -bloom_info = stat "bloom filter size" $ json id $ do - localkeys <- countKeys <$> cachedPresentData - capacity <- fromIntegral <$> lift Command.Unused.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, so double the size - -- of one. - size <- roughSize memoryUnits False . (* 2) . fromIntegral . fst <$> - lift Command.Unused.bloomBitsHashes - - return $ size ++ note - -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 $ multiLine $ - map (\(t, i) -> line uuidmap t i) $ sort ts - where - line uuidmap t i = unwords - [ showLcDirection (transferDirection t) ++ "ing" - , fromMaybe (key2file $ transferKey t) (associatedFile i) - , if transferDirection t == Upload then "to" else "from" - , maybe (fromUUID $ transferUUID t) Remote.name $ - M.lookup (transferUUID t) uuidmap - ] - -disk_size :: Stat -disk_size = stat "available local disk space" $ json id $ lift $ - calcfree - <$> (annexDiskReserve <$> Annex.getGitConfig) - <*> inRepo (getDiskFree . gitAnnexDir) - where - calcfree reserve (Just have) = unwords - [ roughSize storageUnits False $ nonneg $ have - reserve - , "(+" ++ roughSize storageUnits False reserve - , "reserved)" - ] - calcfree _ _ = "unknown" - - nonneg x - | x >= 0 = x - | otherwise = 0 - -backend_usage :: Stat -backend_usage = stat "backend usage" $ nojson $ - calc - <$> (backendsKeys <$> cachedReferencedData) - <*> (backendsKeys <$> cachedPresentData) - where - calc x y = multiLine $ - map (\(n, b) -> b ++ ": " ++ show n) $ - reverse $ sort $ map swap $ M.toList $ - M.unionWith (+) x y - -cachedPresentData :: StatState KeyData -cachedPresentData = do - s <- get - case presentData s of - Just v -> return v - Nothing -> do - v <- foldKeys <$> lift getKeysPresent - put s { presentData = Just v } - return v - -cachedReferencedData :: StatState KeyData -cachedReferencedData = do - s <- get - case referencedData s of - Just v -> return v - Nothing -> do - !v <- lift $ Command.Unused.withKeysReferenced - emptyKeyData addKey - put s { referencedData = Just v } - return v - -getLocalStatInfo :: FilePath -> Annex StatInfo -getLocalStatInfo dir = do - matcher <- Limit.getMatcher - (presentdata, referenceddata) <- - Command.Unused.withKeysFilesReferencedIn dir initial - (update matcher) - return $ StatInfo (Just presentdata) (Just referenceddata) - where - initial = (emptyKeyData, emptyKeyData) - update matcher key file vs@(presentdata, referenceddata) = - ifM (matcher $ FileInfo file file) - ( (,) - <$> ifM (inAnnex key) - ( return $ addKey key presentdata - , return presentdata - ) - <*> pure (addKey key referenceddata) - , return vs - ) - -emptyKeyData :: KeyData -emptyKeyData = KeyData 0 0 0 M.empty - -foldKeys :: [Key] -> KeyData -foldKeys = foldl' (flip addKey) emptyKeyData - -addKey :: Key -> KeyData -> KeyData -addKey key (KeyData count size unknownsize backends) = - KeyData count' size' unknownsize' backends' - where - {- All calculations strict to avoid thunks when repeatedly - - applied to many keys. -} - !count' = count + 1 - !backends' = M.insertWith' (+) (keyBackendName key) 1 backends - !size' = maybe size (+ size) ks - !unknownsize' = maybe (unknownsize + 1) (const unknownsize) ks - ks = keySize key - -showSizeKeys :: KeyData -> String -showSizeKeys d = total ++ missingnote +perform :: [FilePath] -> CommandPerform +perform locs = do + (l, cleanup) <- inRepo $ LsFiles.modifiedOthers locs + getstatus <- ifM isDirect + ( return statusDirect + , return $ Just <$$> statusIndirect + ) + forM_ l $ \f -> maybe noop (showFileStatus f) =<< getstatus f + void $ liftIO cleanup + next $ return True + +data Status + = NewFile + | DeletedFile + | ModifiedFile + +showStatus :: Status -> String +showStatus NewFile = "?" +showStatus DeletedFile = "D" +showStatus ModifiedFile = "M" + +showFileStatus :: FilePath -> Status -> Annex () +showFileStatus f s = liftIO $ putStrLn $ showStatus s ++ " " ++ f + +statusDirect :: FilePath -> Annex (Maybe Status) +statusDirect f = checkstatus =<< liftIO (catchMaybeIO $ getFileStatus f) where - total = roughSize storageUnits False $ sizeKeys d - missingnote - | unknownSizeKeys d == 0 = "" - | otherwise = aside $ - "+ " ++ show (unknownSizeKeys d) ++ - " keys of unknown size" - -staleSize :: String -> (Git.Repo -> FilePath) -> Stat -staleSize label dirspec = go =<< lift (Command.Unused.staleKeys dirspec) + checkstatus Nothing = return $ Just DeletedFile + checkstatus (Just s) + -- Git thinks that present direct mode files modifed, + -- so have to check. + | not (isSymbolicLink s) = checkkey s =<< catKeyFile f + | otherwise = Just <$> checkNew f + + checkkey s (Just k) = ifM (sameFileStatus k s) + ( return Nothing + , return $ Just ModifiedFile + ) + checkkey _ Nothing = Just <$> checkNew f + +statusIndirect :: FilePath -> Annex Status +statusIndirect f = ifM (liftIO $ isJust <$> catchMaybeIO (getFileStatus f)) + ( checkNew f + , return DeletedFile + ) where - go [] = nostat - go keys = onsize =<< sum <$> keysizes keys - onsize 0 = nostat - onsize size = stat label $ - json (++ aside "clean up with git-annex unused") $ - return $ roughSize storageUnits False size - keysizes keys = map (fromIntegral . fileSize) <$> stats keys - stats keys = do - dir <- lift $ fromRepo dirspec - liftIO $ forM keys $ \k -> getFileStatus (dir </> keyFile k) - -aside :: String -> String -aside s = " (" ++ s ++ ")" -multiLine :: [String] -> String -multiLine = concatMap (\l -> "\n\t" ++ l) +checkNew :: FilePath -> Annex Status +checkNew f = ifM (isJust <$> catObjectDetails (Git.Ref.fileRef f)) + ( return ModifiedFile + , return NewFile + ) |