remove unused backend machinery
The only remaining vestiage of backends is different types of keys. These are still called "backends", mostly to avoid needing to change user interface and configuration. But everything to do with storing keys in different backends was gone; instead different types of remotes are used. In the refactoring, lots of code was moved out of odd corners like Backend.File, to closer to where it's used, like Command.Drop and Command.Fsck. Quite a lot of dead code was removed. Several data structures became simpler, which may result in better runtime efficiency. There should be no user-visible changes.
This commit is contained in:
parent
674768abac
commit
9f1577f746
25 changed files with 308 additions and 445 deletions
11
Annex.hs
11
Annex.hs
|
@ -34,7 +34,6 @@ type Annex = StateT AnnexState IO
|
||||||
data AnnexState = AnnexState
|
data AnnexState = AnnexState
|
||||||
{ repo :: Git.Repo
|
{ repo :: Git.Repo
|
||||||
, backends :: [Backend Annex]
|
, backends :: [Backend Annex]
|
||||||
, supportedBackends :: [Backend Annex]
|
|
||||||
, remotes :: [Remote Annex]
|
, remotes :: [Remote Annex]
|
||||||
, repoqueue :: Queue
|
, repoqueue :: Queue
|
||||||
, quiet :: Bool
|
, quiet :: Bool
|
||||||
|
@ -52,12 +51,11 @@ data AnnexState = AnnexState
|
||||||
, cipher :: Maybe Cipher
|
, cipher :: Maybe Cipher
|
||||||
}
|
}
|
||||||
|
|
||||||
newState :: [Backend Annex] -> Git.Repo -> AnnexState
|
newState :: Git.Repo -> AnnexState
|
||||||
newState allbackends gitrepo = AnnexState
|
newState gitrepo = AnnexState
|
||||||
{ repo = gitrepo
|
{ repo = gitrepo
|
||||||
, backends = []
|
, backends = []
|
||||||
, remotes = []
|
, remotes = []
|
||||||
, supportedBackends = allbackends
|
|
||||||
, repoqueue = empty
|
, repoqueue = empty
|
||||||
, quiet = False
|
, quiet = False
|
||||||
, force = False
|
, force = False
|
||||||
|
@ -75,9 +73,8 @@ newState allbackends gitrepo = AnnexState
|
||||||
}
|
}
|
||||||
|
|
||||||
{- Create and returns an Annex state object for the specified git repo. -}
|
{- Create and returns an Annex state object for the specified git repo. -}
|
||||||
new :: Git.Repo -> [Backend Annex] -> IO AnnexState
|
new :: Git.Repo -> IO AnnexState
|
||||||
new gitrepo allbackends =
|
new gitrepo = newState `liftM` (liftIO . Git.configRead) gitrepo
|
||||||
newState allbackends `liftM` (liftIO . Git.configRead) gitrepo
|
|
||||||
|
|
||||||
{- performs an action in the Annex monad -}
|
{- performs an action in the Annex monad -}
|
||||||
run :: AnnexState -> Annex a -> IO (a, AnnexState)
|
run :: AnnexState -> Annex a -> IO (a, AnnexState)
|
||||||
|
|
168
Backend.hs
168
Backend.hs
|
@ -1,16 +1,4 @@
|
||||||
{- git-annex key-value storage backends
|
{- git-annex key/value backends
|
||||||
-
|
|
||||||
- git-annex uses a key-value abstraction layer to allow files contents to be
|
|
||||||
- stored in different ways. In theory, any key-value storage system could be
|
|
||||||
- used to store the file contents, and git-annex would then retrieve them
|
|
||||||
- as needed and put them in `.git/annex/`.
|
|
||||||
-
|
|
||||||
- When a file is annexed, a key is generated from its content and/or metadata.
|
|
||||||
- This key can later be used to retrieve the file's content (its value). This
|
|
||||||
- key generation must be stable for a given file content, name, and size.
|
|
||||||
-
|
|
||||||
- Multiple pluggable backends are supported, and more than one can be used
|
|
||||||
- to store different files' contents in a given repository.
|
|
||||||
-
|
-
|
||||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
||||||
-
|
-
|
||||||
|
@ -19,15 +7,10 @@
|
||||||
|
|
||||||
module Backend (
|
module Backend (
|
||||||
list,
|
list,
|
||||||
storeFileKey,
|
orderedList,
|
||||||
retrieveKeyFile,
|
genKey,
|
||||||
removeKey,
|
|
||||||
hasKey,
|
|
||||||
fsckKey,
|
|
||||||
upgradableKey,
|
|
||||||
lookupFile,
|
lookupFile,
|
||||||
chooseBackends,
|
chooseBackends,
|
||||||
keyBackend,
|
|
||||||
lookupBackendName,
|
lookupBackendName,
|
||||||
maybeLookupBackendName
|
maybeLookupBackendName
|
||||||
) where
|
) where
|
||||||
|
@ -36,7 +19,6 @@ import Control.Monad.State (liftIO, when)
|
||||||
import System.IO.Error (try)
|
import System.IO.Error (try)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import System.Directory
|
|
||||||
|
|
||||||
import Locations
|
import Locations
|
||||||
import qualified Git
|
import qualified Git
|
||||||
|
@ -45,12 +27,20 @@ import Types
|
||||||
import Types.Key
|
import Types.Key
|
||||||
import qualified Types.Backend as B
|
import qualified Types.Backend as B
|
||||||
import Messages
|
import Messages
|
||||||
import Content
|
|
||||||
import DataUnits
|
-- When adding a new backend, import it here and add it to the list.
|
||||||
|
import qualified Backend.WORM
|
||||||
|
import qualified Backend.SHA
|
||||||
|
|
||||||
|
list :: [Backend Annex]
|
||||||
|
list = concat
|
||||||
|
[ Backend.WORM.backends
|
||||||
|
, Backend.SHA.backends
|
||||||
|
]
|
||||||
|
|
||||||
{- List of backends in the order to try them when storing a new key. -}
|
{- List of backends in the order to try them when storing a new key. -}
|
||||||
list :: Annex [Backend Annex]
|
orderedList :: Annex [Backend Annex]
|
||||||
list = do
|
orderedList = do
|
||||||
l <- Annex.getState Annex.backends -- list is cached here
|
l <- Annex.getState Annex.backends -- list is cached here
|
||||||
if not $ null l
|
if not $ null l
|
||||||
then return l
|
then return l
|
||||||
|
@ -59,92 +49,49 @@ list = do
|
||||||
d <- Annex.getState Annex.forcebackend
|
d <- Annex.getState Annex.forcebackend
|
||||||
handle d s
|
handle d s
|
||||||
where
|
where
|
||||||
parseBackendList l [] = l
|
parseBackendList [] = list
|
||||||
parseBackendList bs s = map (lookupBackendName bs) $ words s
|
parseBackendList s = map lookupBackendName $ words s
|
||||||
handle Nothing s = return s
|
handle Nothing s = return s
|
||||||
handle (Just "") s = return s
|
handle (Just "") s = return s
|
||||||
handle (Just name) s = do
|
handle (Just name) s = do
|
||||||
bs <- Annex.getState Annex.supportedBackends
|
let l' = (lookupBackendName name):s
|
||||||
let l' = (lookupBackendName bs name):s
|
|
||||||
Annex.changeState $ \state -> state { Annex.backends = l' }
|
Annex.changeState $ \state -> state { Annex.backends = l' }
|
||||||
return l'
|
return l'
|
||||||
getstandard = do
|
getstandard = do
|
||||||
bs <- Annex.getState Annex.supportedBackends
|
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
return $ parseBackendList bs $
|
return $ parseBackendList $
|
||||||
Git.configGet g "annex.backends" ""
|
Git.configGet g "annex.backends" ""
|
||||||
|
|
||||||
{- Looks up a backend in a list. May fail if unknown. -}
|
{- Generates a key for a file, trying each backend in turn until one
|
||||||
lookupBackendName :: [Backend Annex] -> String -> Backend Annex
|
- accepts it. -}
|
||||||
lookupBackendName bs s = maybe unknown id $ maybeLookupBackendName bs s
|
genKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex))
|
||||||
where
|
genKey file trybackend = do
|
||||||
unknown = error $ "unknown backend " ++ s
|
bs <- orderedList
|
||||||
maybeLookupBackendName :: [Backend Annex] -> String -> Maybe (Backend Annex)
|
|
||||||
maybeLookupBackendName bs s =
|
|
||||||
if 1 /= length matches
|
|
||||||
then Nothing
|
|
||||||
else Just $ head matches
|
|
||||||
where matches = filter (\b -> s == B.name b) bs
|
|
||||||
|
|
||||||
{- Attempts to store a file in one of the backends. -}
|
|
||||||
storeFileKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex))
|
|
||||||
storeFileKey file trybackend = do
|
|
||||||
bs <- list
|
|
||||||
let bs' = maybe bs (:bs) trybackend
|
let bs' = maybe bs (:bs) trybackend
|
||||||
storeFileKey' bs' file
|
genKey' bs' file
|
||||||
storeFileKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
|
genKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex))
|
||||||
storeFileKey' [] _ = return Nothing
|
genKey' [] _ = return Nothing
|
||||||
storeFileKey' (b:bs) file = maybe nextbackend store =<< (B.getKey b) file
|
genKey' (b:bs) file = do
|
||||||
where
|
r <- (B.getKey b) file
|
||||||
nextbackend = storeFileKey' bs file
|
case r of
|
||||||
store key = do
|
Nothing -> genKey' bs file
|
||||||
stored <- (B.storeFileKey b) file key
|
Just k -> return $ Just (k, b)
|
||||||
if (not stored)
|
|
||||||
then nextbackend
|
|
||||||
else return $ Just (key, b)
|
|
||||||
|
|
||||||
{- Attempts to retrieve an key from one of the backends, saving it to
|
|
||||||
- a specified location. -}
|
|
||||||
retrieveKeyFile :: Backend Annex -> Key -> FilePath -> Annex Bool
|
|
||||||
retrieveKeyFile backend key dest = (B.retrieveKeyFile backend) key dest
|
|
||||||
|
|
||||||
{- Removes a key from a backend. -}
|
|
||||||
removeKey :: Backend Annex -> Key -> Maybe Int -> Annex Bool
|
|
||||||
removeKey backend key numcopies = (B.removeKey backend) key numcopies
|
|
||||||
|
|
||||||
{- Checks if a key is present in its backend. -}
|
|
||||||
hasKey :: Key -> Annex Bool
|
|
||||||
hasKey key = do
|
|
||||||
backend <- keyBackend key
|
|
||||||
(B.hasKey backend) key
|
|
||||||
|
|
||||||
{- Checks a key for problems. -}
|
|
||||||
fsckKey :: Backend Annex -> Key -> Maybe FilePath -> Maybe Int -> Annex Bool
|
|
||||||
fsckKey backend key file numcopies = do
|
|
||||||
size_ok <- checkKeySize key
|
|
||||||
backend_ok <-(B.fsckKey backend) key file numcopies
|
|
||||||
return $ size_ok && backend_ok
|
|
||||||
|
|
||||||
{- Checks if a key is upgradable to a newer representation. -}
|
|
||||||
upgradableKey :: Backend Annex -> Key -> Annex Bool
|
|
||||||
upgradableKey backend key = (B.upgradableKey backend) key
|
|
||||||
|
|
||||||
{- Looks up the key and backend corresponding to an annexed file,
|
{- Looks up the key and backend corresponding to an annexed file,
|
||||||
- by examining what the file symlinks to. -}
|
- by examining what the file symlinks to. -}
|
||||||
lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex))
|
lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex))
|
||||||
lookupFile file = do
|
lookupFile file = do
|
||||||
bs <- Annex.getState Annex.supportedBackends
|
|
||||||
tl <- liftIO $ try getsymlink
|
tl <- liftIO $ try getsymlink
|
||||||
case tl of
|
case tl of
|
||||||
Left _ -> return Nothing
|
Left _ -> return Nothing
|
||||||
Right l -> makekey bs l
|
Right l -> makekey l
|
||||||
where
|
where
|
||||||
getsymlink = do
|
getsymlink = do
|
||||||
l <- readSymbolicLink file
|
l <- readSymbolicLink file
|
||||||
return $ takeFileName l
|
return $ takeFileName l
|
||||||
makekey bs l = maybe (return Nothing) (makeret bs l) (fileKey l)
|
makekey l = maybe (return Nothing) (makeret l) (fileKey l)
|
||||||
makeret bs l k =
|
makeret l k =
|
||||||
case maybeLookupBackendName bs bname of
|
case maybeLookupBackendName bname of
|
||||||
Just backend -> return $ Just (k, backend)
|
Just backend -> return $ Just (k, backend)
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
when (isLinkToAnnex l) $
|
when (isLinkToAnnex l) $
|
||||||
|
@ -164,37 +111,20 @@ chooseBackends fs = do
|
||||||
forced <- Annex.getState Annex.forcebackend
|
forced <- Annex.getState Annex.forcebackend
|
||||||
if forced /= Nothing
|
if forced /= Nothing
|
||||||
then do
|
then do
|
||||||
l <- list
|
l <- orderedList
|
||||||
return $ map (\f -> (f, Just $ head l)) fs
|
return $ map (\f -> (f, Just $ head l)) fs
|
||||||
else do
|
else do
|
||||||
bs <- Annex.getState Annex.supportedBackends
|
|
||||||
pairs <- liftIO $ Git.checkAttr g "annex.backend" fs
|
pairs <- liftIO $ Git.checkAttr g "annex.backend" fs
|
||||||
return $ map (\(f,b) -> (f, maybeLookupBackendName bs b)) pairs
|
return $ map (\(f,b) -> (f, maybeLookupBackendName b)) pairs
|
||||||
|
|
||||||
{- Returns the backend to use for a key. -}
|
{- Looks up a backend by name. May fail if unknown. -}
|
||||||
keyBackend :: Key -> Annex (Backend Annex)
|
lookupBackendName :: String -> Backend Annex
|
||||||
keyBackend key = do
|
lookupBackendName s = maybe unknown id $ maybeLookupBackendName s
|
||||||
bs <- Annex.getState Annex.supportedBackends
|
where
|
||||||
return $ lookupBackendName bs $ keyBackendName key
|
unknown = error $ "unknown backend " ++ s
|
||||||
|
maybeLookupBackendName :: String -> Maybe (Backend Annex)
|
||||||
{- The size of the data for a key is checked against the size encoded in
|
maybeLookupBackendName s =
|
||||||
- the key's metadata, if available. -}
|
if 1 /= length matches
|
||||||
checkKeySize :: Key -> Annex Bool
|
then Nothing
|
||||||
checkKeySize key = do
|
else Just $ head matches
|
||||||
g <- Annex.gitRepo
|
where matches = filter (\b -> s == B.name b) list
|
||||||
let file = gitAnnexLocation g key
|
|
||||||
present <- liftIO $ doesFileExist file
|
|
||||||
case (present, keySize key) of
|
|
||||||
(_, Nothing) -> return True
|
|
||||||
(False, _) -> return True
|
|
||||||
(True, Just size) -> do
|
|
||||||
stat <- liftIO $ getFileStatus file
|
|
||||||
let size' = fromIntegral (fileSize stat)
|
|
||||||
if size == size'
|
|
||||||
then return True
|
|
||||||
else do
|
|
||||||
dest <- moveBad key
|
|
||||||
warning $ "Bad file size (" ++
|
|
||||||
compareSizes storageUnits True size size' ++
|
|
||||||
"); moved to " ++ dest
|
|
||||||
return False
|
|
||||||
|
|
220
Backend/File.hs
220
Backend/File.hs
|
@ -1,220 +0,0 @@
|
||||||
{- git-annex pseudo-backend
|
|
||||||
-
|
|
||||||
- This backend does not really do any independant data storage,
|
|
||||||
- it relies on the file contents in .git/annex/ in this repo,
|
|
||||||
- and other accessible repos.
|
|
||||||
-
|
|
||||||
- This is an abstract backend; name, getKey and fsckKey have to be implemented
|
|
||||||
- to complete it.
|
|
||||||
-
|
|
||||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
||||||
-
|
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
|
||||||
-}
|
|
||||||
|
|
||||||
module Backend.File (backend, checkKey) where
|
|
||||||
|
|
||||||
import Data.List
|
|
||||||
import Data.String.Utils
|
|
||||||
|
|
||||||
import Types.Backend
|
|
||||||
import LocationLog
|
|
||||||
import qualified Remote
|
|
||||||
import qualified Git
|
|
||||||
import Content
|
|
||||||
import qualified Annex
|
|
||||||
import Types
|
|
||||||
import UUID
|
|
||||||
import Messages
|
|
||||||
import Trust
|
|
||||||
import Types.Key
|
|
||||||
|
|
||||||
backend :: Backend Annex
|
|
||||||
backend = Backend {
|
|
||||||
name = mustProvide,
|
|
||||||
getKey = mustProvide,
|
|
||||||
storeFileKey = dummyStore,
|
|
||||||
retrieveKeyFile = copyKeyFile,
|
|
||||||
removeKey = checkRemoveKey,
|
|
||||||
hasKey = inAnnex,
|
|
||||||
fsckKey = checkKeyOnly,
|
|
||||||
upgradableKey = checkUpgradableKey
|
|
||||||
}
|
|
||||||
|
|
||||||
mustProvide :: a
|
|
||||||
mustProvide = error "must provide this field"
|
|
||||||
|
|
||||||
{- Storing a key is a no-op. -}
|
|
||||||
dummyStore :: FilePath -> Key -> Annex Bool
|
|
||||||
dummyStore _ _ = return True
|
|
||||||
|
|
||||||
{- Try to find a copy of the file in one of the remotes,
|
|
||||||
- and copy it to here. -}
|
|
||||||
copyKeyFile :: Key -> FilePath -> Annex Bool
|
|
||||||
copyKeyFile key file = do
|
|
||||||
remotes <- Remote.keyPossibilities key
|
|
||||||
if null remotes
|
|
||||||
then do
|
|
||||||
showNote "not available"
|
|
||||||
showLocations key []
|
|
||||||
return False
|
|
||||||
else trycopy remotes remotes
|
|
||||||
where
|
|
||||||
trycopy full [] = do
|
|
||||||
showTriedRemotes full
|
|
||||||
showLocations key []
|
|
||||||
return False
|
|
||||||
trycopy full (r:rs) = do
|
|
||||||
probablythere <- probablyPresent r
|
|
||||||
if probablythere
|
|
||||||
then docopy r (trycopy full rs)
|
|
||||||
else trycopy full rs
|
|
||||||
-- This check is to avoid an ugly message if a remote is a
|
|
||||||
-- drive that is not mounted.
|
|
||||||
probablyPresent r =
|
|
||||||
if Remote.hasKeyCheap r
|
|
||||||
then do
|
|
||||||
res <- Remote.hasKey r key
|
|
||||||
case res of
|
|
||||||
Right b -> return b
|
|
||||||
Left _ -> return False
|
|
||||||
else return True
|
|
||||||
docopy r continue = do
|
|
||||||
showNote $ "from " ++ Remote.name r ++ "..."
|
|
||||||
copied <- Remote.retrieveKeyFile r key file
|
|
||||||
if copied
|
|
||||||
then return True
|
|
||||||
else continue
|
|
||||||
|
|
||||||
{- Checks remotes to verify that enough copies of a key exist to allow
|
|
||||||
- for a key to be safely removed (with no data loss), and fails with an
|
|
||||||
- error if not. -}
|
|
||||||
checkRemoveKey :: Key -> Maybe Int -> Annex Bool
|
|
||||||
checkRemoveKey key numcopiesM = do
|
|
||||||
force <- Annex.getState Annex.force
|
|
||||||
if force || numcopiesM == Just 0
|
|
||||||
then return True
|
|
||||||
else do
|
|
||||||
(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
|
|
||||||
untrusteduuids <- trustGet UnTrusted
|
|
||||||
let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
|
|
||||||
numcopies <- getNumCopies numcopiesM
|
|
||||||
findcopies numcopies trusteduuids tocheck []
|
|
||||||
where
|
|
||||||
findcopies need have [] bad
|
|
||||||
| length have >= need = return True
|
|
||||||
| otherwise = notEnoughCopies need have bad
|
|
||||||
findcopies need have (r:rs) bad
|
|
||||||
| length have >= need = return True
|
|
||||||
| otherwise = do
|
|
||||||
let u = Remote.uuid r
|
|
||||||
let dup = u `elem` have
|
|
||||||
haskey <- Remote.hasKey r key
|
|
||||||
case (dup, haskey) of
|
|
||||||
(False, Right True) -> findcopies need (u:have) rs bad
|
|
||||||
(False, Left _) -> findcopies need have rs (r:bad)
|
|
||||||
_ -> findcopies need have rs bad
|
|
||||||
notEnoughCopies need have bad = do
|
|
||||||
unsafe
|
|
||||||
showLongNote $
|
|
||||||
"Could only verify the existence of " ++
|
|
||||||
show (length have) ++ " out of " ++ show need ++
|
|
||||||
" necessary copies"
|
|
||||||
showTriedRemotes bad
|
|
||||||
showLocations key have
|
|
||||||
hint
|
|
||||||
return False
|
|
||||||
unsafe = showNote "unsafe"
|
|
||||||
hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"
|
|
||||||
|
|
||||||
showLocations :: Key -> [UUID] -> Annex ()
|
|
||||||
showLocations key exclude = do
|
|
||||||
g <- Annex.gitRepo
|
|
||||||
u <- getUUID g
|
|
||||||
uuids <- keyLocations key
|
|
||||||
untrusteduuids <- trustGet UnTrusted
|
|
||||||
let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids)
|
|
||||||
let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)
|
|
||||||
ppuuidswanted <- Remote.prettyPrintUUIDs uuidswanted
|
|
||||||
ppuuidsskipped <- Remote.prettyPrintUUIDs uuidsskipped
|
|
||||||
showLongNote $ message ppuuidswanted ppuuidsskipped
|
|
||||||
where
|
|
||||||
filteruuids list x = filter (`notElem` x) list
|
|
||||||
message [] [] = "No other repository is known to contain the file."
|
|
||||||
message rs [] = "Try making some of these repositories available:\n" ++ rs
|
|
||||||
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
|
|
||||||
message rs us = message rs [] ++ message [] us
|
|
||||||
|
|
||||||
showTriedRemotes :: [Remote.Remote Annex] -> Annex ()
|
|
||||||
showTriedRemotes [] = return ()
|
|
||||||
showTriedRemotes remotes =
|
|
||||||
showLongNote $ "Unable to access these remotes: " ++
|
|
||||||
(join ", " $ map Remote.name remotes)
|
|
||||||
|
|
||||||
{- If a value is specified, it is used; otherwise the default is looked up
|
|
||||||
- in git config. forcenumcopies overrides everything. -}
|
|
||||||
getNumCopies :: Maybe Int -> Annex Int
|
|
||||||
getNumCopies v =
|
|
||||||
Annex.getState Annex.forcenumcopies >>= maybe (use v) (return . id)
|
|
||||||
where
|
|
||||||
use (Just n) = return n
|
|
||||||
use Nothing = do
|
|
||||||
g <- Annex.gitRepo
|
|
||||||
return $ read $ Git.configGet g config "1"
|
|
||||||
config = "annex.numcopies"
|
|
||||||
|
|
||||||
{- Ideally, all keys have file size metadata. Old keys may not. -}
|
|
||||||
checkUpgradableKey :: Key -> Annex Bool
|
|
||||||
checkUpgradableKey key
|
|
||||||
| keySize key == Nothing = return True
|
|
||||||
| otherwise = return False
|
|
||||||
|
|
||||||
{- This is used to check that numcopies is satisfied for the key on fsck.
|
|
||||||
- This trusts data in the the location log, and so can check all keys, even
|
|
||||||
- those with data not present in the current annex.
|
|
||||||
-
|
|
||||||
- The passed action is first run to allow backends deriving this one
|
|
||||||
- to do their own checks.
|
|
||||||
-}
|
|
||||||
checkKey :: (Key -> Annex Bool) -> Key -> Maybe FilePath -> Maybe Int -> Annex Bool
|
|
||||||
checkKey a key file numcopies = do
|
|
||||||
a_ok <- a key
|
|
||||||
copies_ok <- checkKeyNumCopies key file numcopies
|
|
||||||
return $ a_ok && copies_ok
|
|
||||||
|
|
||||||
checkKeyOnly :: Key -> Maybe FilePath -> Maybe Int -> Annex Bool
|
|
||||||
checkKeyOnly = checkKey (\_ -> return True)
|
|
||||||
|
|
||||||
checkKeyNumCopies :: Key -> Maybe FilePath -> Maybe Int -> Annex Bool
|
|
||||||
checkKeyNumCopies key file numcopies = do
|
|
||||||
needed <- getNumCopies numcopies
|
|
||||||
locations <- keyLocations key
|
|
||||||
untrusted <- trustGet UnTrusted
|
|
||||||
let untrustedlocations = intersect untrusted locations
|
|
||||||
let safelocations = filter (`notElem` untrusted) locations
|
|
||||||
let present = length safelocations
|
|
||||||
if present < needed
|
|
||||||
then do
|
|
||||||
ppuuids <- Remote.prettyPrintUUIDs untrustedlocations
|
|
||||||
warning $ missingNote (filename file key) present needed ppuuids
|
|
||||||
return False
|
|
||||||
else return True
|
|
||||||
where
|
|
||||||
filename Nothing k = show k
|
|
||||||
filename (Just f) _ = f
|
|
||||||
|
|
||||||
missingNote :: String -> Int -> Int -> String -> String
|
|
||||||
missingNote file 0 _ [] =
|
|
||||||
"** No known copies exist of " ++ file
|
|
||||||
missingNote file 0 _ untrusted =
|
|
||||||
"Only these untrusted locations may have copies of " ++ file ++
|
|
||||||
"\n" ++ untrusted ++
|
|
||||||
"Back it up to trusted locations with git-annex copy."
|
|
||||||
missingNote file present needed [] =
|
|
||||||
"Only " ++ show present ++ " of " ++ show needed ++
|
|
||||||
" trustworthy copies exist of " ++ file ++
|
|
||||||
"\nBack it up with git-annex copy."
|
|
||||||
missingNote file present needed untrusted =
|
|
||||||
missingNote file present needed [] ++
|
|
||||||
"\nThe following untrusted locations may also have copies: " ++
|
|
||||||
"\n" ++ untrusted
|
|
|
@ -16,7 +16,6 @@ import Data.Maybe
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
|
|
||||||
import qualified Backend.File
|
|
||||||
import Messages
|
import Messages
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import Locations
|
import Locations
|
||||||
|
@ -42,10 +41,10 @@ genBackend size
|
||||||
| shaCommand size == Nothing = Nothing
|
| shaCommand size == Nothing = Nothing
|
||||||
| otherwise = Just b
|
| otherwise = Just b
|
||||||
where
|
where
|
||||||
b = Backend.File.backend
|
b = Types.Backend.Backend
|
||||||
{ name = shaName size
|
{ name = shaName size
|
||||||
, getKey = keyValue size
|
, getKey = keyValue size
|
||||||
, fsckKey = Backend.File.checkKey $ checkKeyChecksum size
|
, fsckKey = checkKeyChecksum size
|
||||||
}
|
}
|
||||||
|
|
||||||
genBackendE :: SHASize -> Maybe (Backend Annex)
|
genBackendE :: SHASize -> Maybe (Backend Annex)
|
||||||
|
|
|
@ -11,7 +11,6 @@ import Control.Monad.State
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
|
|
||||||
import qualified Backend.File
|
|
||||||
import Types.Backend
|
import Types.Backend
|
||||||
import Types
|
import Types
|
||||||
import Types.Key
|
import Types.Key
|
||||||
|
@ -20,9 +19,10 @@ backends :: [Backend Annex]
|
||||||
backends = [backend]
|
backends = [backend]
|
||||||
|
|
||||||
backend :: Backend Annex
|
backend :: Backend Annex
|
||||||
backend = Backend.File.backend {
|
backend = Types.Backend.Backend {
|
||||||
name = "WORM",
|
name = "WORM",
|
||||||
getKey = keyValue
|
getKey = keyValue,
|
||||||
|
fsckKey = const (return True)
|
||||||
}
|
}
|
||||||
|
|
||||||
{- The key includes the file size, modification time, and the
|
{- The key includes the file size, modification time, and the
|
||||||
|
|
|
@ -1,19 +0,0 @@
|
||||||
{- git-annex backend list
|
|
||||||
-
|
|
||||||
- Copyright 2010 Joey Hess <joey@kitenet.net>
|
|
||||||
-
|
|
||||||
- Licensed under the GNU GPL version 3 or higher.
|
|
||||||
-}
|
|
||||||
|
|
||||||
module BackendList (allBackends) where
|
|
||||||
|
|
||||||
-- When adding a new backend, import it here and add it to the list.
|
|
||||||
import qualified Backend.WORM
|
|
||||||
import qualified Backend.SHA
|
|
||||||
import Types
|
|
||||||
|
|
||||||
allBackends :: [Backend Annex]
|
|
||||||
allBackends = concat
|
|
||||||
[ Backend.WORM.backends
|
|
||||||
, Backend.SHA.backends
|
|
||||||
]
|
|
|
@ -22,7 +22,6 @@ import qualified Git
|
||||||
import Content
|
import Content
|
||||||
import Types
|
import Types
|
||||||
import Command
|
import Command
|
||||||
import BackendList
|
|
||||||
import Version
|
import Version
|
||||||
import Options
|
import Options
|
||||||
import Messages
|
import Messages
|
||||||
|
@ -32,7 +31,7 @@ import UUID
|
||||||
dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
|
dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO ()
|
||||||
dispatch args cmds options header gitrepo = do
|
dispatch args cmds options header gitrepo = do
|
||||||
setupConsole
|
setupConsole
|
||||||
state <- Annex.new gitrepo allBackends
|
state <- Annex.new gitrepo
|
||||||
(actions, state') <- Annex.run state $ parseCmd args header cmds options
|
(actions, state') <- Annex.run state $ parseCmd args header cmds options
|
||||||
tryRun state' $ [startup] ++ actions ++ [shutdown]
|
tryRun state' $ [startup] ++ actions ++ [shutdown]
|
||||||
|
|
||||||
|
|
|
@ -42,8 +42,8 @@ start pair@(file, _) = notAnnexed file $ do
|
||||||
|
|
||||||
perform :: BackendFile -> CommandPerform
|
perform :: BackendFile -> CommandPerform
|
||||||
perform (file, backend) = do
|
perform (file, backend) = do
|
||||||
stored <- Backend.storeFileKey file backend
|
k <- Backend.genKey file backend
|
||||||
case stored of
|
case k of
|
||||||
Nothing -> stop
|
Nothing -> stop
|
||||||
Just (key, _) -> do
|
Just (key, _) -> do
|
||||||
moveAnnex key file
|
moveAnnex key file
|
||||||
|
|
|
@ -51,8 +51,8 @@ perform url file = do
|
||||||
if ok
|
if ok
|
||||||
then do
|
then do
|
||||||
[(_, backend)] <- Backend.chooseBackends [file]
|
[(_, backend)] <- Backend.chooseBackends [file]
|
||||||
stored <- Backend.storeFileKey tmp backend
|
k <- Backend.genKey tmp backend
|
||||||
case stored of
|
case k of
|
||||||
Nothing -> stop
|
Nothing -> stop
|
||||||
Just (key, _) -> do
|
Just (key, _) -> do
|
||||||
moveAnnex key tmp
|
moveAnnex key tmp
|
||||||
|
|
|
@ -8,12 +8,15 @@
|
||||||
module Command.Drop where
|
module Command.Drop where
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
import qualified Backend
|
import qualified Remote
|
||||||
|
import qualified Annex
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import Types
|
import Types
|
||||||
import Content
|
import Content
|
||||||
import Messages
|
import Messages
|
||||||
import Utility
|
import Utility
|
||||||
|
import Trust
|
||||||
|
import Config
|
||||||
|
|
||||||
command :: [Command]
|
command :: [Command]
|
||||||
command = [repoCommand "drop" paramPath seek
|
command = [repoCommand "drop" paramPath seek
|
||||||
|
@ -25,19 +28,19 @@ seek = [withAttrFilesInGit "annex.numcopies" start]
|
||||||
{- Indicates a file's content is not wanted anymore, and should be removed
|
{- Indicates a file's content is not wanted anymore, and should be removed
|
||||||
- if it's safe to do so. -}
|
- if it's safe to do so. -}
|
||||||
start :: CommandStartAttrFile
|
start :: CommandStartAttrFile
|
||||||
start (file, attr) = isAnnexed file $ \(key, backend) -> do
|
start (file, attr) = isAnnexed file $ \(key, _) -> do
|
||||||
inbackend <- Backend.hasKey key
|
present <- inAnnex key
|
||||||
if inbackend
|
if present
|
||||||
then do
|
then do
|
||||||
showStart "drop" file
|
showStart "drop" file
|
||||||
next $ perform key backend numcopies
|
next $ perform key numcopies
|
||||||
else stop
|
else stop
|
||||||
where
|
where
|
||||||
numcopies = readMaybe attr :: Maybe Int
|
numcopies = readMaybe attr :: Maybe Int
|
||||||
|
|
||||||
perform :: Key -> Backend Annex -> Maybe Int -> CommandPerform
|
perform :: Key -> Maybe Int -> CommandPerform
|
||||||
perform key backend numcopies = do
|
perform key numcopies = do
|
||||||
success <- Backend.removeKey backend key numcopies
|
success <- dropKey key numcopies
|
||||||
if success
|
if success
|
||||||
then next $ cleanup key
|
then next $ cleanup key
|
||||||
else stop
|
else stop
|
||||||
|
@ -47,3 +50,44 @@ cleanup key = do
|
||||||
whenM (inAnnex key) $ removeAnnex key
|
whenM (inAnnex key) $ removeAnnex key
|
||||||
logStatus key InfoMissing
|
logStatus key InfoMissing
|
||||||
return True
|
return True
|
||||||
|
|
||||||
|
{- Checks remotes to verify that enough copies of a key exist to allow
|
||||||
|
- for a key to be safely removed (with no data loss), and fails with an
|
||||||
|
- error if not. -}
|
||||||
|
dropKey :: Key -> Maybe Int -> Annex Bool
|
||||||
|
dropKey key numcopiesM = do
|
||||||
|
force <- Annex.getState Annex.force
|
||||||
|
if force || numcopiesM == Just 0
|
||||||
|
then return True
|
||||||
|
else do
|
||||||
|
(remotes, trusteduuids) <- Remote.keyPossibilitiesTrusted key
|
||||||
|
untrusteduuids <- trustGet UnTrusted
|
||||||
|
let tocheck = Remote.remotesWithoutUUID remotes (trusteduuids++untrusteduuids)
|
||||||
|
numcopies <- getNumCopies numcopiesM
|
||||||
|
findcopies numcopies trusteduuids tocheck []
|
||||||
|
where
|
||||||
|
findcopies need have [] bad
|
||||||
|
| length have >= need = return True
|
||||||
|
| otherwise = notEnoughCopies need have bad
|
||||||
|
findcopies need have (r:rs) bad
|
||||||
|
| length have >= need = return True
|
||||||
|
| otherwise = do
|
||||||
|
let u = Remote.uuid r
|
||||||
|
let dup = u `elem` have
|
||||||
|
haskey <- Remote.hasKey r key
|
||||||
|
case (dup, haskey) of
|
||||||
|
(False, Right True) -> findcopies need (u:have) rs bad
|
||||||
|
(False, Left _) -> findcopies need have rs (r:bad)
|
||||||
|
_ -> findcopies need have rs bad
|
||||||
|
notEnoughCopies need have bad = do
|
||||||
|
unsafe
|
||||||
|
showLongNote $
|
||||||
|
"Could only verify the existence of " ++
|
||||||
|
show (length have) ++ " out of " ++ show need ++
|
||||||
|
" necessary copies"
|
||||||
|
Remote.showTriedRemotes bad
|
||||||
|
Remote.showLocations key have
|
||||||
|
hint
|
||||||
|
return False
|
||||||
|
unsafe = showNote "unsafe"
|
||||||
|
hint = showLongNote "(Use --force to override this check, or adjust annex.numcopies.)"
|
||||||
|
|
|
@ -21,7 +21,6 @@ import qualified Command.Drop
|
||||||
import qualified Command.Move
|
import qualified Command.Move
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import Backend
|
|
||||||
import Types.Key
|
import Types.Key
|
||||||
import Utility
|
import Utility
|
||||||
|
|
||||||
|
@ -64,9 +63,7 @@ perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote
|
||||||
r <- Remote.byName name
|
r <- Remote.byName name
|
||||||
showNote $ "from " ++ Remote.name r ++ "..."
|
showNote $ "from " ++ Remote.name r ++ "..."
|
||||||
next $ Command.Move.fromCleanup r True key
|
next $ Command.Move.fromCleanup r True key
|
||||||
droplocal = do
|
droplocal = Command.Drop.perform key (Just 0) -- force drop
|
||||||
backend <- keyBackend key
|
|
||||||
Command.Drop.perform key backend (Just 0) -- force drop
|
|
||||||
|
|
||||||
performOther :: (Git.Repo -> Key -> FilePath) -> Key -> CommandPerform
|
performOther :: (Git.Repo -> Key -> FilePath) -> Key -> CommandPerform
|
||||||
performOther filespec key = do
|
performOther filespec key = do
|
||||||
|
|
|
@ -15,7 +15,6 @@ import Control.Monad (unless)
|
||||||
import Command
|
import Command
|
||||||
import qualified AnnexQueue
|
import qualified AnnexQueue
|
||||||
import Utility
|
import Utility
|
||||||
import qualified Backend
|
|
||||||
import Content
|
import Content
|
||||||
import Messages
|
import Messages
|
||||||
import Types.Key
|
import Types.Key
|
||||||
|
@ -30,7 +29,7 @@ seek = [withFilesMissing start]
|
||||||
start :: CommandStartString
|
start :: CommandStartString
|
||||||
start file = notBareRepo $ do
|
start file = notBareRepo $ do
|
||||||
key <- cmdlineKey
|
key <- cmdlineKey
|
||||||
inbackend <- Backend.hasKey key
|
inbackend <- inAnnex key
|
||||||
unless inbackend $ error $
|
unless inbackend $ error $
|
||||||
"key ("++keyName key++") is not present in backend"
|
"key ("++keyName key++") is not present in backend"
|
||||||
showStart "fromkey" file
|
showStart "fromkey" file
|
||||||
|
|
|
@ -9,10 +9,15 @@ module Command.Fsck where
|
||||||
|
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import Control.Monad.State (liftIO)
|
import Control.Monad.State (liftIO)
|
||||||
|
import System.Directory
|
||||||
|
import Data.List
|
||||||
|
import System.Posix.Files
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
import qualified Backend
|
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
|
import qualified Remote
|
||||||
|
import qualified Types.Backend
|
||||||
|
import qualified Types.Key
|
||||||
import UUID
|
import UUID
|
||||||
import Types
|
import Types
|
||||||
import Messages
|
import Messages
|
||||||
|
@ -20,6 +25,9 @@ import Utility
|
||||||
import Content
|
import Content
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import Locations
|
import Locations
|
||||||
|
import Trust
|
||||||
|
import DataUnits
|
||||||
|
import Config
|
||||||
|
|
||||||
command :: [Command]
|
command :: [Command]
|
||||||
command = [repoCommand "fsck" (paramOptional $ paramRepeating paramPath) seek
|
command = [repoCommand "fsck" (paramOptional $ paramRepeating paramPath) seek
|
||||||
|
@ -40,7 +48,7 @@ perform key file backend numcopies = do
|
||||||
-- the location log is checked first, so that if it has bad data
|
-- the location log is checked first, so that if it has bad data
|
||||||
-- that gets corrected
|
-- that gets corrected
|
||||||
locationlogok <- verifyLocationLog key file
|
locationlogok <- verifyLocationLog key file
|
||||||
backendok <- Backend.fsckKey backend key (Just file) numcopies
|
backendok <- fsckKey backend key (Just file) numcopies
|
||||||
if locationlogok && backendok
|
if locationlogok && backendok
|
||||||
then next $ return True
|
then next $ return True
|
||||||
else stop
|
else stop
|
||||||
|
@ -80,3 +88,68 @@ verifyLocationLog key file = do
|
||||||
fix g u s = do
|
fix g u s = do
|
||||||
showNote "fixing location log"
|
showNote "fixing location log"
|
||||||
logChange g key u s
|
logChange g key u s
|
||||||
|
|
||||||
|
{- Checks a key for problems. -}
|
||||||
|
fsckKey :: Backend Annex -> Key -> Maybe FilePath -> Maybe Int -> Annex Bool
|
||||||
|
fsckKey backend key file numcopies = do
|
||||||
|
size_ok <- checkKeySize key
|
||||||
|
copies_ok <- checkKeyNumCopies key file numcopies
|
||||||
|
backend_ok <-(Types.Backend.fsckKey backend) key
|
||||||
|
return $ size_ok && copies_ok && backend_ok
|
||||||
|
|
||||||
|
{- The size of the data for a key is checked against the size encoded in
|
||||||
|
- the key's metadata, if available. -}
|
||||||
|
checkKeySize :: Key -> Annex Bool
|
||||||
|
checkKeySize key = do
|
||||||
|
g <- Annex.gitRepo
|
||||||
|
let file = gitAnnexLocation g key
|
||||||
|
present <- liftIO $ doesFileExist file
|
||||||
|
case (present, Types.Key.keySize key) of
|
||||||
|
(_, Nothing) -> return True
|
||||||
|
(False, _) -> return True
|
||||||
|
(True, Just size) -> do
|
||||||
|
stat <- liftIO $ getFileStatus file
|
||||||
|
let size' = fromIntegral (fileSize stat)
|
||||||
|
if size == size'
|
||||||
|
then return True
|
||||||
|
else do
|
||||||
|
dest <- moveBad key
|
||||||
|
warning $ "Bad file size (" ++
|
||||||
|
compareSizes storageUnits True size size' ++
|
||||||
|
"); moved to " ++ dest
|
||||||
|
return False
|
||||||
|
|
||||||
|
|
||||||
|
checkKeyNumCopies :: Key -> Maybe FilePath -> Maybe Int -> Annex Bool
|
||||||
|
checkKeyNumCopies key file numcopies = do
|
||||||
|
needed <- getNumCopies numcopies
|
||||||
|
locations <- keyLocations key
|
||||||
|
untrusted <- trustGet UnTrusted
|
||||||
|
let untrustedlocations = intersect untrusted locations
|
||||||
|
let safelocations = filter (`notElem` untrusted) locations
|
||||||
|
let present = length safelocations
|
||||||
|
if present < needed
|
||||||
|
then do
|
||||||
|
ppuuids <- Remote.prettyPrintUUIDs untrustedlocations
|
||||||
|
warning $ missingNote (filename file key) present needed ppuuids
|
||||||
|
return False
|
||||||
|
else return True
|
||||||
|
where
|
||||||
|
filename Nothing k = show k
|
||||||
|
filename (Just f) _ = f
|
||||||
|
|
||||||
|
missingNote :: String -> Int -> Int -> String -> String
|
||||||
|
missingNote file 0 _ [] =
|
||||||
|
"** No known copies exist of " ++ file
|
||||||
|
missingNote file 0 _ untrusted =
|
||||||
|
"Only these untrusted locations may have copies of " ++ file ++
|
||||||
|
"\n" ++ untrusted ++
|
||||||
|
"Back it up to trusted locations with git-annex copy."
|
||||||
|
missingNote file present needed [] =
|
||||||
|
"Only " ++ show present ++ " of " ++ show needed ++
|
||||||
|
" trustworthy copies exist of " ++ file ++
|
||||||
|
"\nBack it up with git-annex copy."
|
||||||
|
missingNote file present needed untrusted =
|
||||||
|
missingNote file present needed [] ++
|
||||||
|
"\nThe following untrusted locations may also have copies: " ++
|
||||||
|
"\n" ++ untrusted
|
||||||
|
|
|
@ -8,7 +8,6 @@
|
||||||
module Command.Get where
|
module Command.Get where
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
import qualified Backend
|
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Types
|
import Types
|
||||||
|
@ -24,7 +23,7 @@ seek :: [CommandSeek]
|
||||||
seek = [withFilesInGit start]
|
seek = [withFilesInGit start]
|
||||||
|
|
||||||
start :: CommandStartString
|
start :: CommandStartString
|
||||||
start file = isAnnexed file $ \(key, backend) -> do
|
start file = isAnnexed file $ \(key, _) -> do
|
||||||
inannex <- inAnnex key
|
inannex <- inAnnex key
|
||||||
if inannex
|
if inannex
|
||||||
then stop
|
then stop
|
||||||
|
@ -32,14 +31,52 @@ start file = isAnnexed file $ \(key, backend) -> do
|
||||||
showStart "get" file
|
showStart "get" file
|
||||||
from <- Annex.getState Annex.fromremote
|
from <- Annex.getState Annex.fromremote
|
||||||
case from of
|
case from of
|
||||||
Nothing -> next $ perform key backend
|
Nothing -> next $ perform key
|
||||||
Just name -> do
|
Just name -> do
|
||||||
src <- Remote.byName name
|
src <- Remote.byName name
|
||||||
next $ Command.Move.fromPerform src False key
|
next $ Command.Move.fromPerform src False key
|
||||||
|
|
||||||
perform :: Key -> Backend Annex -> CommandPerform
|
perform :: Key -> CommandPerform
|
||||||
perform key backend = do
|
perform key = do
|
||||||
ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
|
ok <- getViaTmp key (getKeyFile key)
|
||||||
if ok
|
if ok
|
||||||
then next $ return True -- no cleanup needed
|
then next $ return True -- no cleanup needed
|
||||||
else stop
|
else stop
|
||||||
|
|
||||||
|
{- Try to find a copy of the file in one of the remotes,
|
||||||
|
- and copy it to here. -}
|
||||||
|
getKeyFile :: Key -> FilePath -> Annex Bool
|
||||||
|
getKeyFile key file = do
|
||||||
|
remotes <- Remote.keyPossibilities key
|
||||||
|
if null remotes
|
||||||
|
then do
|
||||||
|
showNote "not available"
|
||||||
|
Remote.showLocations key []
|
||||||
|
return False
|
||||||
|
else trycopy remotes remotes
|
||||||
|
where
|
||||||
|
trycopy full [] = do
|
||||||
|
Remote.showTriedRemotes full
|
||||||
|
Remote.showLocations key []
|
||||||
|
return False
|
||||||
|
trycopy full (r:rs) = do
|
||||||
|
probablythere <- probablyPresent r
|
||||||
|
if probablythere
|
||||||
|
then docopy r (trycopy full rs)
|
||||||
|
else trycopy full rs
|
||||||
|
-- This check is to avoid an ugly message if a remote is a
|
||||||
|
-- drive that is not mounted.
|
||||||
|
probablyPresent r =
|
||||||
|
if Remote.hasKeyCheap r
|
||||||
|
then do
|
||||||
|
res <- Remote.hasKey r key
|
||||||
|
case res of
|
||||||
|
Right b -> return b
|
||||||
|
Left _ -> return False
|
||||||
|
else return True
|
||||||
|
docopy r continue = do
|
||||||
|
showNote $ "from " ++ Remote.name r ++ "..."
|
||||||
|
copied <- Remote.retrieveKeyFile r key file
|
||||||
|
if copied
|
||||||
|
then return True
|
||||||
|
else continue
|
||||||
|
|
|
@ -15,6 +15,7 @@ import System.FilePath
|
||||||
import Command
|
import Command
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import qualified Backend
|
import qualified Backend
|
||||||
|
import qualified Types.Key
|
||||||
import Locations
|
import Locations
|
||||||
import Types
|
import Types
|
||||||
import Content
|
import Content
|
||||||
|
@ -32,18 +33,20 @@ start :: CommandStartBackendFile
|
||||||
start (file, b) = isAnnexed file $ \(key, oldbackend) -> do
|
start (file, b) = isAnnexed file $ \(key, oldbackend) -> do
|
||||||
exists <- inAnnex key
|
exists <- inAnnex key
|
||||||
newbackend <- choosebackend b
|
newbackend <- choosebackend b
|
||||||
upgradable <- Backend.upgradableKey oldbackend key
|
if (newbackend /= oldbackend || upgradableKey key) && exists
|
||||||
if (newbackend /= oldbackend || upgradable) && exists
|
|
||||||
then do
|
then do
|
||||||
showStart "migrate" file
|
showStart "migrate" file
|
||||||
next $ perform file key newbackend
|
next $ perform file key newbackend
|
||||||
else stop
|
else stop
|
||||||
where
|
where
|
||||||
choosebackend Nothing = do
|
choosebackend Nothing = return . head =<< Backend.orderedList
|
||||||
backends <- Backend.list
|
|
||||||
return $ head backends
|
|
||||||
choosebackend (Just backend) = return backend
|
choosebackend (Just backend) = return backend
|
||||||
|
|
||||||
|
{- Checks if a key is upgradable to a newer representation. -}
|
||||||
|
{- Ideally, all keys have file size metadata. Old keys may not. -}
|
||||||
|
upgradableKey :: Key -> Bool
|
||||||
|
upgradableKey key = Types.Key.keySize key == Nothing
|
||||||
|
|
||||||
perform :: FilePath -> Key -> Backend Annex -> CommandPerform
|
perform :: FilePath -> Key -> Backend Annex -> CommandPerform
|
||||||
perform file oldkey newbackend = do
|
perform file oldkey newbackend = do
|
||||||
g <- Annex.gitRepo
|
g <- Annex.gitRepo
|
||||||
|
@ -55,9 +58,9 @@ perform file oldkey newbackend = do
|
||||||
let src = gitAnnexLocation g oldkey
|
let src = gitAnnexLocation g oldkey
|
||||||
let tmpfile = gitAnnexTmpDir g </> takeFileName file
|
let tmpfile = gitAnnexTmpDir g </> takeFileName file
|
||||||
liftIO $ createLink src tmpfile
|
liftIO $ createLink src tmpfile
|
||||||
stored <- Backend.storeFileKey tmpfile $ Just newbackend
|
k <- Backend.genKey tmpfile $ Just newbackend
|
||||||
liftIO $ cleantmp tmpfile
|
liftIO $ cleantmp tmpfile
|
||||||
case stored of
|
case k of
|
||||||
Nothing -> stop
|
Nothing -> stop
|
||||||
Just (newkey, _) -> do
|
Just (newkey, _) -> do
|
||||||
ok <- getViaTmpUnchecked newkey $ \t -> do
|
ok <- getViaTmpUnchecked newkey $ \t -> do
|
||||||
|
|
|
@ -25,6 +25,7 @@ import DataUnits
|
||||||
import Content
|
import Content
|
||||||
import Types.Key
|
import Types.Key
|
||||||
import Locations
|
import Locations
|
||||||
|
import Backend
|
||||||
|
|
||||||
-- a named computation that produces a statistic
|
-- a named computation that produces a statistic
|
||||||
type Stat = StatState (Maybe (String, StatState String))
|
type Stat = StatState (Maybe (String, StatState String))
|
||||||
|
@ -96,8 +97,7 @@ showStat s = calc =<< s
|
||||||
|
|
||||||
supported_backends :: Stat
|
supported_backends :: Stat
|
||||||
supported_backends = stat "supported backends" $
|
supported_backends = stat "supported backends" $
|
||||||
lift (Annex.getState Annex.supportedBackends) >>=
|
return $ unwords $ map B.name Backend.list
|
||||||
return . unwords . (map B.name)
|
|
||||||
|
|
||||||
supported_remote_types :: Stat
|
supported_remote_types :: Stat
|
||||||
supported_remote_types = stat "supported remote types" $
|
supported_remote_types = stat "supported remote types" $
|
||||||
|
|
|
@ -13,10 +13,10 @@ import System.Directory
|
||||||
import System.Posix.Files
|
import System.Posix.Files
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
|
import qualified Command.Drop
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import qualified AnnexQueue
|
import qualified AnnexQueue
|
||||||
import Utility
|
import Utility
|
||||||
import qualified Backend
|
|
||||||
import LocationLog
|
import LocationLog
|
||||||
import Types
|
import Types
|
||||||
import Content
|
import Content
|
||||||
|
@ -33,7 +33,7 @@ seek = [withFilesInGit start]
|
||||||
|
|
||||||
{- The unannex subcommand undoes an add. -}
|
{- The unannex subcommand undoes an add. -}
|
||||||
start :: CommandStartString
|
start :: CommandStartString
|
||||||
start file = isAnnexed file $ \(key, backend) -> do
|
start file = isAnnexed file $ \(key, _) -> do
|
||||||
ishere <- inAnnex key
|
ishere <- inAnnex key
|
||||||
if ishere
|
if ishere
|
||||||
then do
|
then do
|
||||||
|
@ -46,13 +46,12 @@ start file = isAnnexed file $ \(key, backend) -> do
|
||||||
Annex.changeState $ \s -> s { Annex.force = True }
|
Annex.changeState $ \s -> s { Annex.force = True }
|
||||||
|
|
||||||
showStart "unannex" file
|
showStart "unannex" file
|
||||||
next $ perform file key backend
|
next $ perform file key
|
||||||
else stop
|
else stop
|
||||||
|
|
||||||
perform :: FilePath -> Key -> Backend Annex -> CommandPerform
|
perform :: FilePath -> Key -> CommandPerform
|
||||||
perform file key backend = do
|
perform file key = do
|
||||||
-- force backend to always remove
|
ok <- Command.Drop.dropKey key (Just 0) -- always remove
|
||||||
ok <- Backend.removeKey backend key (Just 0)
|
|
||||||
if ok
|
if ok
|
||||||
then next $ cleanup file key
|
then next $ cleanup file key
|
||||||
else stop
|
else stop
|
||||||
|
|
|
@ -12,7 +12,6 @@ import System.Directory hiding (copyFile)
|
||||||
|
|
||||||
import Command
|
import Command
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import qualified Backend
|
|
||||||
import Types
|
import Types
|
||||||
import Messages
|
import Messages
|
||||||
import Locations
|
import Locations
|
||||||
|
@ -38,7 +37,7 @@ start file = isAnnexed file $ \(key, _) -> do
|
||||||
|
|
||||||
perform :: FilePath -> Key -> CommandPerform
|
perform :: FilePath -> Key -> CommandPerform
|
||||||
perform dest key = do
|
perform dest key = do
|
||||||
unlessM (Backend.hasKey key) $ error "content not present"
|
unlessM (inAnnex key) $ error "content not present"
|
||||||
|
|
||||||
checkDiskSpace key
|
checkDiskSpace key
|
||||||
|
|
||||||
|
|
13
Config.hs
13
Config.hs
|
@ -86,3 +86,16 @@ remoteNotIgnored r = do
|
||||||
match a = do
|
match a = do
|
||||||
n <- Annex.getState a
|
n <- Annex.getState a
|
||||||
return $ n == Git.repoRemoteName r
|
return $ n == Git.repoRemoteName r
|
||||||
|
|
||||||
|
{- If a value is specified, it is used; otherwise the default is looked up
|
||||||
|
- in git config. forcenumcopies overrides everything. -}
|
||||||
|
getNumCopies :: Maybe Int -> Annex Int
|
||||||
|
getNumCopies v =
|
||||||
|
Annex.getState Annex.forcenumcopies >>= maybe (use v) (return . id)
|
||||||
|
where
|
||||||
|
use (Just n) = return n
|
||||||
|
use Nothing = do
|
||||||
|
g <- Annex.gitRepo
|
||||||
|
return $ read $ Git.configGet g config "1"
|
||||||
|
config = "annex.numcopies"
|
||||||
|
|
||||||
|
|
33
Remote.hs
33
Remote.hs
|
@ -14,10 +14,10 @@ module Remote (
|
||||||
removeKey,
|
removeKey,
|
||||||
hasKey,
|
hasKey,
|
||||||
hasKeyCheap,
|
hasKeyCheap,
|
||||||
|
|
||||||
keyPossibilities,
|
keyPossibilities,
|
||||||
keyPossibilitiesTrusted,
|
keyPossibilitiesTrusted,
|
||||||
forceTrust,
|
forceTrust,
|
||||||
|
|
||||||
remoteTypes,
|
remoteTypes,
|
||||||
genList,
|
genList,
|
||||||
byName,
|
byName,
|
||||||
|
@ -25,6 +25,8 @@ module Remote (
|
||||||
remotesWithUUID,
|
remotesWithUUID,
|
||||||
remotesWithoutUUID,
|
remotesWithoutUUID,
|
||||||
prettyPrintUUIDs,
|
prettyPrintUUIDs,
|
||||||
|
showTriedRemotes,
|
||||||
|
showLocations,
|
||||||
|
|
||||||
remoteLog,
|
remoteLog,
|
||||||
readRemoteLog,
|
readRemoteLog,
|
||||||
|
@ -40,6 +42,7 @@ import Data.List
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
import Data.String.Utils
|
||||||
|
|
||||||
import qualified Branch
|
import qualified Branch
|
||||||
import Types
|
import Types
|
||||||
|
@ -49,6 +52,7 @@ import qualified Annex
|
||||||
import Config
|
import Config
|
||||||
import Trust
|
import Trust
|
||||||
import LocationLog
|
import LocationLog
|
||||||
|
import Messages
|
||||||
|
|
||||||
import qualified Remote.Git
|
import qualified Remote.Git
|
||||||
import qualified Remote.S3
|
import qualified Remote.S3
|
||||||
|
@ -181,9 +185,34 @@ keyPossibilities' withtrusted key = do
|
||||||
|
|
||||||
return (sort validremotes, validtrusteduuids)
|
return (sort validremotes, validtrusteduuids)
|
||||||
|
|
||||||
|
{- Displays known locations of a key. -}
|
||||||
|
showLocations :: Key -> [UUID] -> Annex ()
|
||||||
|
showLocations key exclude = do
|
||||||
|
g <- Annex.gitRepo
|
||||||
|
u <- getUUID g
|
||||||
|
uuids <- keyLocations key
|
||||||
|
untrusteduuids <- trustGet UnTrusted
|
||||||
|
let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids)
|
||||||
|
let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted)
|
||||||
|
ppuuidswanted <- Remote.prettyPrintUUIDs uuidswanted
|
||||||
|
ppuuidsskipped <- Remote.prettyPrintUUIDs uuidsskipped
|
||||||
|
showLongNote $ message ppuuidswanted ppuuidsskipped
|
||||||
|
where
|
||||||
|
filteruuids l x = filter (`notElem` x) l
|
||||||
|
message [] [] = "No other repository is known to contain the file."
|
||||||
|
message rs [] = "Try making some of these repositories available:\n" ++ rs
|
||||||
|
message [] us = "Also these untrusted repositories may contain the file:\n" ++ us
|
||||||
|
message rs us = message rs [] ++ message [] us
|
||||||
|
|
||||||
|
showTriedRemotes :: [Remote Annex] -> Annex ()
|
||||||
|
showTriedRemotes [] = return ()
|
||||||
|
showTriedRemotes remotes =
|
||||||
|
showLongNote $ "Unable to access these remotes: " ++
|
||||||
|
(join ", " $ map name remotes)
|
||||||
|
|
||||||
forceTrust :: TrustLevel -> String -> Annex ()
|
forceTrust :: TrustLevel -> String -> Annex ()
|
||||||
forceTrust level remotename = do
|
forceTrust level remotename = do
|
||||||
r <- Remote.nameToUUID remotename
|
r <- nameToUUID remotename
|
||||||
Annex.changeState $ \s ->
|
Annex.changeState $ \s ->
|
||||||
s { Annex.forcetrust = (r, level):Annex.forcetrust s }
|
s { Annex.forcetrust = (r, level):Annex.forcetrust s }
|
||||||
|
|
||||||
|
|
|
@ -112,7 +112,7 @@ inAnnex r key = if Git.repoIsUrl r
|
||||||
checklocal = do
|
checklocal = do
|
||||||
-- run a local check inexpensively,
|
-- run a local check inexpensively,
|
||||||
-- by making an Annex monad using the remote
|
-- by making an Annex monad using the remote
|
||||||
a <- Annex.new r []
|
a <- Annex.new r
|
||||||
Annex.eval a (Content.inAnnex key)
|
Annex.eval a (Content.inAnnex key)
|
||||||
checkremote = do
|
checkremote = do
|
||||||
showNote ("checking " ++ Git.repoDescribe r ++ "...")
|
showNote ("checking " ++ Git.repoDescribe r ++ "...")
|
||||||
|
@ -142,7 +142,7 @@ copyToRemote r key
|
||||||
let keysrc = gitAnnexLocation g key
|
let keysrc = gitAnnexLocation g key
|
||||||
-- run copy from perspective of remote
|
-- run copy from perspective of remote
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
a <- Annex.new r []
|
a <- Annex.new r
|
||||||
Annex.eval a $ do
|
Annex.eval a $ do
|
||||||
ok <- Content.getViaTmp key $
|
ok <- Content.getViaTmp key $
|
||||||
rsyncOrCopyFile r keysrc
|
rsyncOrCopyFile r keysrc
|
||||||
|
|
|
@ -16,22 +16,8 @@ data Backend a = Backend {
|
||||||
name :: String,
|
name :: String,
|
||||||
-- converts a filename to a key
|
-- converts a filename to a key
|
||||||
getKey :: FilePath -> a (Maybe Key),
|
getKey :: FilePath -> a (Maybe Key),
|
||||||
-- stores a file's contents to a key
|
|
||||||
storeFileKey :: FilePath -> Key -> a Bool,
|
|
||||||
-- retrieves a key's contents to a file
|
|
||||||
retrieveKeyFile :: Key -> FilePath -> a Bool,
|
|
||||||
-- removes a key, optionally checking that enough copies are stored
|
|
||||||
-- elsewhere
|
|
||||||
removeKey :: Key -> Maybe Int -> a Bool,
|
|
||||||
-- checks if a backend is storing the content of a key
|
|
||||||
hasKey :: Key -> a Bool,
|
|
||||||
-- called during fsck to check a key
|
-- called during fsck to check a key
|
||||||
-- (second parameter may be the filename associated with it)
|
fsckKey :: Key -> a Bool
|
||||||
-- (third parameter may be the number of copies that there should
|
|
||||||
-- be of the key)
|
|
||||||
fsckKey :: Key -> Maybe FilePath -> Maybe Int -> a Bool,
|
|
||||||
-- Is a newer repesentation possible for a key?
|
|
||||||
upgradableKey :: Key -> a Bool
|
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Show (Backend a) where
|
instance Show (Backend a) where
|
||||||
|
|
|
@ -191,17 +191,16 @@ logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log"
|
||||||
|
|
||||||
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex))
|
lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex))
|
||||||
lookupFile1 file = do
|
lookupFile1 file = do
|
||||||
bs <- Annex.getState Annex.supportedBackends
|
|
||||||
tl <- liftIO $ try getsymlink
|
tl <- liftIO $ try getsymlink
|
||||||
case tl of
|
case tl of
|
||||||
Left _ -> return Nothing
|
Left _ -> return Nothing
|
||||||
Right l -> makekey bs l
|
Right l -> makekey l
|
||||||
where
|
where
|
||||||
getsymlink = do
|
getsymlink = do
|
||||||
l <- readSymbolicLink file
|
l <- readSymbolicLink file
|
||||||
return $ takeFileName l
|
return $ takeFileName l
|
||||||
makekey bs l = do
|
makekey l = do
|
||||||
case maybeLookupBackendName bs bname of
|
case maybeLookupBackendName bname of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
unless (null kname || null bname ||
|
unless (null kname || null bname ||
|
||||||
not (isLinkToAnnex l)) $
|
not (isLinkToAnnex l)) $
|
||||||
|
|
5
test.hs
5
test.hs
|
@ -25,7 +25,6 @@ import System.Path (recurseDir)
|
||||||
import System.IO.HVFS (SystemFS(..))
|
import System.IO.HVFS (SystemFS(..))
|
||||||
|
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import qualified BackendList
|
|
||||||
import qualified Backend
|
import qualified Backend
|
||||||
import qualified Git
|
import qualified Git
|
||||||
import qualified Locations
|
import qualified Locations
|
||||||
|
@ -483,7 +482,7 @@ annexeval :: Types.Annex a -> IO a
|
||||||
annexeval a = do
|
annexeval a = do
|
||||||
g <- Git.repoFromCwd
|
g <- Git.repoFromCwd
|
||||||
g' <- Git.configRead g
|
g' <- Git.configRead g
|
||||||
s <- Annex.new g' BackendList.allBackends
|
s <- Annex.new g'
|
||||||
Annex.eval s a
|
Annex.eval s a
|
||||||
|
|
||||||
innewrepo :: Assertion -> Assertion
|
innewrepo :: Assertion -> Assertion
|
||||||
|
@ -684,4 +683,4 @@ backendWORM :: Types.Backend Types.Annex
|
||||||
backendWORM = backend_ "WORM"
|
backendWORM = backend_ "WORM"
|
||||||
|
|
||||||
backend_ :: String -> Types.Backend Types.Annex
|
backend_ :: String -> Types.Backend Types.Annex
|
||||||
backend_ name = Backend.lookupBackendName BackendList.allBackends name
|
backend_ name = Backend.lookupBackendName name
|
||||||
|
|
Loading…
Reference in a new issue