summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/UUID.hs7
-rw-r--r--Command.hs9
-rw-r--r--Command/Get.hs12
-rw-r--r--Command/Migrate.hs12
-rw-r--r--Command/Move.hs14
-rw-r--r--Command/Status.hs45
-rw-r--r--Config.hs10
-rw-r--r--Messages.hs24
-rw-r--r--debian/changelog3
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 ++ ")"
diff --git a/Config.hs b/Config.hs
index dbd13ad3f..cc0c92953 100644
--- a/Config.hs
+++ b/Config.hs
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-04 11:42:32 +0000