diff options
-rw-r--r-- | Annex/UUID.hs | 7 | ||||
-rw-r--r-- | Command.hs | 9 | ||||
-rw-r--r-- | Command/Get.hs | 12 | ||||
-rw-r--r-- | Command/Migrate.hs | 12 | ||||
-rw-r--r-- | Command/Move.hs | 14 | ||||
-rw-r--r-- | Command/Status.hs | 45 | ||||
-rw-r--r-- | Config.hs | 10 | ||||
-rw-r--r-- | Messages.hs | 24 | ||||
-rw-r--r-- | debian/changelog | 3 |
9 files changed, 78 insertions, 58 deletions
diff --git a/Annex/UUID.hs b/Annex/UUID.hs index 6fc04c0f0..e510a7ccd 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -39,10 +39,11 @@ genUUID = pOpen ReadFromPipe command params $ liftM toUUID . hGetLine -- uuidgen generates random uuid by default else [] +{- Get current repository's UUID. -} getUUID :: Annex UUID getUUID = getRepoUUID =<< gitRepo -{- Looks up a repo's UUID. May return "" if none is known. -} +{- Looks up a repo's UUID, caching it in .git/config if it's not already. -} getRepoUUID :: Git.Repo -> Annex UUID getRepoUUID r = do c <- fromRepo cached @@ -54,11 +55,11 @@ getRepoUUID r = do return u else return c where - cached g = toUUID $ Git.configGet cachekey "" g + cached = toUUID . Git.configGet cachekey "" updatecache u = do g <- gitRepo when (g /= r) $ storeUUID cachekey u - cachekey = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-uuid" + cachekey = remoteConfig r "uuid" getUncachedUUID :: Git.Repo -> UUID getUncachedUUID = toUUID . Git.configGet configkey "" diff --git a/Command.hs b/Command.hs index b66217192..4d5bbeb36 100644 --- a/Command.hs +++ b/Command.hs @@ -92,11 +92,10 @@ isBareRepo = fromRepo Git.repoIsLocalBare - copies of the key is > or < than the numcopies setting, before running - the action. -} autoCopies :: Key -> (Int -> Int -> Bool) -> Maybe Int -> CommandStart -> CommandStart -autoCopies key vs numcopiesattr a = do - auto <- Annex.getState Annex.auto - if auto - then do +autoCopies key vs numcopiesattr a = Annex.getState Annex.auto >>= auto + where + auto False = a + auto True = do needed <- getNumCopies numcopiesattr (_, have) <- trustPartition UnTrusted =<< keyLocations key if length have `vs` needed then a else stop - else a diff --git a/Command/Get.hs b/Command/Get.hs index f7d953bb6..093cd2cc5 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -27,14 +27,20 @@ start numcopies file (key, _) = do if inannex then stop else autoCopies key (<) numcopies $ do - showStart "get" file from <- Annex.getState Annex.fromremote case from of - Nothing -> next $ perform key + Nothing -> go $ perform key Just name -> do -- get --from = copy --from src <- Remote.byName name - next $ Command.Move.fromPerform src False key + ok <- Command.Move.fromOk src key + if ok + then go $ Command.Move.fromPerform src False key + else stop + where + go a = do + showStart "get" file + next a perform :: Key -> CommandPerform perform key = do diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 045b8f9b1..7a329080f 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -39,12 +39,16 @@ start b file (key, oldbackend) = do upgradableKey :: Key -> Bool upgradableKey key = isNothing $ Types.Key.keySize key +{- Store the old backend's key in the new backend + - The old backend's key is not dropped from it, because there may + - be other files still pointing at that key. + - + - Use the same filename as the file for the temp file name, to support + - backends that allow the filename to influence the keys they + - generate. + -} perform :: FilePath -> Key -> Backend Annex -> CommandPerform perform file oldkey newbackend = do - -- Store the old backend's cached key in the new backend - -- (the file can't be stored as usual, because it's already a symlink). - -- The old backend's key is not dropped from it, because there may - -- be other files still pointing at that key. src <- fromRepo $ gitAnnexLocation oldkey tmp <- fromRepo gitAnnexTmpDir let tmpfile = tmp </> takeFileName file diff --git a/Command/Move.hs b/Command/Move.hs index 155f4d605..4c4534c49 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -117,13 +117,17 @@ fromStart src move file key if ishere then stop else go where go = do - u <- getUUID - remotes <- Remote.keyPossibilities key - if u == Remote.uuid src || not (any (== src) remotes) - then stop - else do + ok <- fromOk src key + if ok + then do showMoveAction move file next $ fromPerform src move key + else stop +fromOk :: Remote.Remote Annex -> Key -> Annex Bool +fromOk src key = do + u <- getUUID + remotes <- Remote.keyPossibilities key + return $ u /= Remote.uuid src && any (== src) remotes fromPerform :: Remote.Remote Annex -> Bool -> Key -> CommandPerform fromPerform src move key = moveLock move key $ do ishere <- inAnnex key diff --git a/Command/Status.hs b/Command/Status.hs index 7448615cd..a47f21b91 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -11,6 +11,7 @@ import Control.Monad.State import qualified Data.Map as M import qualified Data.Set as S import Data.Set (Set) +import Text.JSON import Common.Annex import qualified Types.Backend as B @@ -78,12 +79,21 @@ start = do return True stop -stat :: String -> StatState String -> Stat -stat desc a = return $ Just (desc, a) +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 = calc =<< s where @@ -93,15 +103,15 @@ showStat s = calc =<< s calc Nothing = return () supported_backends :: Stat -supported_backends = stat "supported backends" $ - return $ unwords $ map B.name Backend.list +supported_backends = stat "supported backends" $ json unwords $ + return $ map B.name Backend.list supported_remote_types :: Stat -supported_remote_types = stat "supported remote types" $ - return $ unwords $ map R.typename Remote.remoteTypes +supported_remote_types = stat "supported remote types" $ json unwords $ + return $ map R.typename Remote.remoteTypes remote_list :: TrustLevel -> String -> Stat -remote_list level desc = stat n $ lift $ do +remote_list level desc = stat n $ nojson $ lift $ do us <- M.keys <$> (M.union <$> uuidMap <*> remoteMap) rs <- fst <$> trustPartition level us s <- prettyPrintUUIDs n rs @@ -110,20 +120,20 @@ remote_list level desc = stat n $ lift $ do n = desc ++ " repositories" local_annex_size :: Stat -local_annex_size = stat "local annex size" $ +local_annex_size = stat "local annex size" $ json id $ keySizeSum <$> cachedKeysPresent local_annex_keys :: Stat -local_annex_keys = stat "local annex keys" $ - show . S.size <$> cachedKeysPresent +local_annex_keys = stat "local annex keys" $ json show $ + S.size <$> cachedKeysPresent visible_annex_size :: Stat -visible_annex_size = stat "visible annex size" $ +visible_annex_size = stat "visible annex size" $ json id $ keySizeSum <$> cachedKeysReferenced visible_annex_keys :: Stat -visible_annex_keys = stat "visible annex keys" $ - show . S.size <$> cachedKeysReferenced +visible_annex_keys = stat "visible annex keys" $ json show $ + S.size <$> cachedKeysReferenced tmp_size :: Stat tmp_size = staleSize "temporary directory size" gitAnnexTmpDir @@ -132,7 +142,8 @@ bad_data_size :: Stat bad_data_size = staleSize "bad keys size" gitAnnexBadDir backend_usage :: Stat -backend_usage = stat "backend usage" $ usage <$> cachedKeysReferenced <*> cachedKeysPresent +backend_usage = stat "backend usage" $ nojson $ + usage <$> cachedKeysReferenced <*> cachedKeysPresent where usage a b = pp "" $ reverse . sort $ map swap $ splits $ S.toList $ S.union a b splits :: [Key] -> [(String, Integer)] @@ -179,9 +190,9 @@ staleSize label dirspec = do keys <- lift (Command.Unused.staleKeys dirspec) if null keys then nostat - else stat label $ do - let s = keySizeSum $ S.fromList keys - return $ s ++ aside "clean up with git-annex unused" + else do + stat label $ json (++ aside "clean up with git-annex unused") $ + return $ keySizeSum $ S.fromList keys aside :: String -> String aside s = " (" ++ s ++ ")" @@ -28,13 +28,13 @@ getConfig r key def = do def' <- fromRepo $ Git.configGet ("annex." ++ key) def fromRepo $ Git.configGet (remoteConfig r key) def' +{- Looks up a per-remote config setting in git config. -} remoteConfig :: Git.Repo -> ConfigKey -> String remoteConfig r key = "remote." ++ fromMaybe "" (Git.repoRemoteName r) ++ ".annex-" ++ key {- Calculates cost for a remote. Either the default, or as configured - by remote.<name>.annex-cost, or if remote.<name>.annex-cost-command - - is set and prints a number, that is used. - -} + - is set and prints a number, that is used. -} remoteCost :: Git.Repo -> Int -> Annex Int remoteCost r def = do cmd <- getConfig r "cost-command" "" @@ -55,7 +55,7 @@ semiCheapRemoteCost = 110 expensiveRemoteCost :: Int expensiveRemoteCost = 200 -{- Adjust's a remote's cost to reflect it being encrypted. -} +{- Adjusts a remote's cost to reflect it being encrypted. -} encryptedRemoteCostAdj :: Int encryptedRemoteCostAdj = 50 @@ -74,9 +74,7 @@ prop_cost_sane = False `notElem` - setting, or on command-line options. Allows command-line to override - annex-ignore. -} repoNotIgnored :: Git.Repo -> Annex Bool -repoNotIgnored r = do - ignored <- getConfig r "ignore" "false" - return $ not $ Git.configTrue ignored +repoNotIgnored r = not . Git.configTrue <$> getConfig r "ignore" "false" {- If a value is specified, it is used; otherwise the default is looked up - in git config. forcenumcopies overrides everything. -} diff --git a/Messages.hs b/Messages.hs index 57b706804..6ea347ca4 100644 --- a/Messages.hs +++ b/Messages.hs @@ -68,17 +68,17 @@ showEndFail :: Annex () showEndFail = showEndResult False showEndResult :: Bool -> Annex () -showEndResult b = handle (JSON.end b) $ putStrLn msg +showEndResult ok = handle (JSON.end ok) $ putStrLn msg where msg - | b = "ok" + | ok = "ok" | otherwise = "failed" showErr :: (Show a) => a -> Annex () showErr e = warning' $ "git-annex: " ++ show e warning :: String -> Annex () -warning w = warning' (indent w) +warning = warning' . indent warning' :: String -> Annex () warning' w = do @@ -88,7 +88,7 @@ warning' w = do hPutStrLn stderr w indent :: String -> String -indent s = join "\n" $ map (\l -> " " ++ l) $ lines s +indent = join "\n" . map (\l -> " " ++ l) . lines {- Shows a JSON value only when in json mode. -} maybeShowJSON :: JSON a => [(String, a)] -> Annex () @@ -105,9 +105,8 @@ showCustom command a = do handle (JSON.end r) q showHeader :: String -> Annex () -showHeader h = handle q $ do - putStr $ h ++ ": " - hFlush stdout +showHeader h = handle q $ + flushed $ putStr $ h ++ ": " showRaw :: String -> Annex () showRaw s = handle q $ putStrLn s @@ -126,12 +125,11 @@ setupConsole = do hSetBinaryMode stderr True handle :: IO () -> IO () -> Annex () -handle json normal = do - output <- Annex.getState Annex.output - case output of - Annex.NormalOutput -> liftIO normal - Annex.QuietOutput -> q - Annex.JSONOutput -> liftIO json +handle json normal = Annex.getState Annex.output >>= go + where + go Annex.NormalOutput = liftIO normal + go Annex.QuietOutput = q + go Annex.JSONOutput = liftIO json q :: Monad m => m () q = return () diff --git a/debian/changelog b/debian/changelog index 12bbba11d..9f96a4fff 100644 --- a/debian/changelog +++ b/debian/changelog @@ -11,8 +11,7 @@ git-annex (3.20111112) UNRELEASED; urgency=low * status: Now displays trusted, untrusted, and semitrusted repositories separately. * status: Include all special remotes in the list of repositories. - * status: Fix --json mode (only the repository lists are currently - displayed) + * status: Fix --json mode. * status: --fast is back * Fix support for insteadOf url remapping. Closes: #644278 * When not run in a git repository, git-annex can still display a usage |