diff options
| -rw-r--r-- | Annex.hs | 11 | ||||
| -rw-r--r-- | Backend.hs | 168 | ||||
| -rw-r--r-- | Backend/File.hs | 220 | ||||
| -rw-r--r-- | Backend/SHA.hs | 5 | ||||
| -rw-r--r-- | Backend/WORM.hs | 6 | ||||
| -rw-r--r-- | BackendList.hs | 19 | ||||
| -rw-r--r-- | CmdLine.hs | 3 | ||||
| -rw-r--r-- | Command/Add.hs | 4 | ||||
| -rw-r--r-- | Command/AddUrl.hs | 4 | ||||
| -rw-r--r-- | Command/Drop.hs | 60 | ||||
| -rw-r--r-- | Command/DropUnused.hs | 5 | ||||
| -rw-r--r-- | Command/FromKey.hs | 3 | ||||
| -rw-r--r-- | Command/Fsck.hs | 77 | ||||
| -rw-r--r-- | Command/Get.hs | 49 | ||||
| -rw-r--r-- | Command/Migrate.hs | 17 | ||||
| -rw-r--r-- | Command/Status.hs | 6 | ||||
| -rw-r--r-- | Command/Unannex.hs | 13 | ||||
| -rw-r--r-- | Command/Unlock.hs | 3 | ||||
| -rw-r--r-- | Config.hs | 13 | ||||
| -rw-r--r-- | LocationLog.hs | 2 | ||||
| -rw-r--r-- | Remote.hs | 33 | ||||
| -rw-r--r-- | Remote/Git.hs | 4 | ||||
| -rw-r--r-- | Types/Backend.hs | 16 | ||||
| -rw-r--r-- | Upgrade/V1.hs | 7 | ||||
| -rw-r--r-- | test.hs | 5 |
25 files changed, 308 insertions, 445 deletions
@@ -34,7 +34,6 @@ type Annex = StateT AnnexState IO data AnnexState = AnnexState { repo :: Git.Repo , backends :: [Backend Annex] - , supportedBackends :: [Backend Annex] , remotes :: [Remote Annex] , repoqueue :: Queue , quiet :: Bool @@ -52,12 +51,11 @@ data AnnexState = AnnexState , cipher :: Maybe Cipher } -newState :: [Backend Annex] -> Git.Repo -> AnnexState -newState allbackends gitrepo = AnnexState +newState :: Git.Repo -> AnnexState +newState gitrepo = AnnexState { repo = gitrepo , backends = [] , remotes = [] - , supportedBackends = allbackends , repoqueue = empty , quiet = False , force = False @@ -75,9 +73,8 @@ newState allbackends gitrepo = AnnexState } {- Create and returns an Annex state object for the specified git repo. -} -new :: Git.Repo -> [Backend Annex] -> IO AnnexState -new gitrepo allbackends = - newState allbackends `liftM` (liftIO . Git.configRead) gitrepo +new :: Git.Repo -> IO AnnexState +new gitrepo = newState `liftM` (liftIO . Git.configRead) gitrepo {- performs an action in the Annex monad -} run :: AnnexState -> Annex a -> IO (a, AnnexState) diff --git a/Backend.hs b/Backend.hs index b1cd4c8f0..cf976d2b8 100644 --- a/Backend.hs +++ b/Backend.hs @@ -1,16 +1,4 @@ -{- git-annex key-value storage 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. +{- git-annex key/value backends - - Copyright 2010 Joey Hess <joey@kitenet.net> - @@ -19,15 +7,10 @@ module Backend ( list, - storeFileKey, - retrieveKeyFile, - removeKey, - hasKey, - fsckKey, - upgradableKey, + orderedList, + genKey, lookupFile, chooseBackends, - keyBackend, lookupBackendName, maybeLookupBackendName ) where @@ -36,7 +19,6 @@ import Control.Monad.State (liftIO, when) import System.IO.Error (try) import System.FilePath import System.Posix.Files -import System.Directory import Locations import qualified Git @@ -45,12 +27,20 @@ import Types import Types.Key import qualified Types.Backend as B 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 :: Annex [Backend Annex] -list = do +orderedList :: Annex [Backend Annex] +orderedList = do l <- Annex.getState Annex.backends -- list is cached here if not $ null l then return l @@ -59,92 +49,49 @@ list = do d <- Annex.getState Annex.forcebackend handle d s where - parseBackendList l [] = l - parseBackendList bs s = map (lookupBackendName bs) $ words s + parseBackendList [] = list + parseBackendList s = map lookupBackendName $ words s handle Nothing s = return s handle (Just "") s = return s handle (Just name) s = do - bs <- Annex.getState Annex.supportedBackends - let l' = (lookupBackendName bs name):s + let l' = (lookupBackendName name):s Annex.changeState $ \state -> state { Annex.backends = l' } return l' getstandard = do - bs <- Annex.getState Annex.supportedBackends g <- Annex.gitRepo - return $ parseBackendList bs $ + return $ parseBackendList $ Git.configGet g "annex.backends" "" -{- Looks up a backend in a list. May fail if unknown. -} -lookupBackendName :: [Backend Annex] -> String -> Backend Annex -lookupBackendName bs s = maybe unknown id $ maybeLookupBackendName bs s - where - unknown = error $ "unknown backend " ++ s -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 +{- Generates a key for a file, trying each backend in turn until one + - accepts it. -} +genKey :: FilePath -> Maybe (Backend Annex) -> Annex (Maybe (Key, Backend Annex)) +genKey file trybackend = do + bs <- orderedList let bs' = maybe bs (:bs) trybackend - storeFileKey' bs' file -storeFileKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex)) -storeFileKey' [] _ = return Nothing -storeFileKey' (b:bs) file = maybe nextbackend store =<< (B.getKey b) file - where - nextbackend = storeFileKey' bs file - store key = do - stored <- (B.storeFileKey b) file key - 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 + genKey' bs' file +genKey' :: [Backend Annex] -> FilePath -> Annex (Maybe (Key, Backend Annex)) +genKey' [] _ = return Nothing +genKey' (b:bs) file = do + r <- (B.getKey b) file + case r of + Nothing -> genKey' bs file + Just k -> return $ Just (k, b) {- Looks up the key and backend corresponding to an annexed file, - by examining what the file symlinks to. -} lookupFile :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile file = do - bs <- Annex.getState Annex.supportedBackends tl <- liftIO $ try getsymlink case tl of Left _ -> return Nothing - Right l -> makekey bs l + Right l -> makekey l where getsymlink = do l <- readSymbolicLink file return $ takeFileName l - makekey bs l = maybe (return Nothing) (makeret bs l) (fileKey l) - makeret bs l k = - case maybeLookupBackendName bs bname of + makekey l = maybe (return Nothing) (makeret l) (fileKey l) + makeret l k = + case maybeLookupBackendName bname of Just backend -> return $ Just (k, backend) Nothing -> do when (isLinkToAnnex l) $ @@ -164,37 +111,20 @@ chooseBackends fs = do forced <- Annex.getState Annex.forcebackend if forced /= Nothing then do - l <- list + l <- orderedList return $ map (\f -> (f, Just $ head l)) fs else do - bs <- Annex.getState Annex.supportedBackends pairs <- liftIO $ Git.checkAttr g "annex.backend" fs - return $ map (\(f,b) -> (f, maybeLookupBackendName bs b)) pairs - -{- Returns the backend to use for a key. -} -keyBackend :: Key -> Annex (Backend Annex) -keyBackend key = do - bs <- Annex.getState Annex.supportedBackends - return $ lookupBackendName bs $ keyBackendName key + return $ map (\(f,b) -> (f, maybeLookupBackendName b)) pairs -{- 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, 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 +{- Looks up a backend by name. May fail if unknown. -} +lookupBackendName :: String -> Backend Annex +lookupBackendName s = maybe unknown id $ maybeLookupBackendName s + where + unknown = error $ "unknown backend " ++ s +maybeLookupBackendName :: String -> Maybe (Backend Annex) +maybeLookupBackendName s = + if 1 /= length matches + then Nothing + else Just $ head matches + where matches = filter (\b -> s == B.name b) list diff --git a/Backend/File.hs b/Backend/File.hs deleted file mode 100644 index 174da4e6d..000000000 --- a/Backend/File.hs +++ /dev/null @@ -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 diff --git a/Backend/SHA.hs b/Backend/SHA.hs index 8930e4b93..bd6e411a0 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -16,7 +16,6 @@ import Data.Maybe import System.Posix.Files import System.FilePath -import qualified Backend.File import Messages import qualified Annex import Locations @@ -42,10 +41,10 @@ genBackend size | shaCommand size == Nothing = Nothing | otherwise = Just b where - b = Backend.File.backend + b = Types.Backend.Backend { name = shaName size , getKey = keyValue size - , fsckKey = Backend.File.checkKey $ checkKeyChecksum size + , fsckKey = checkKeyChecksum size } genBackendE :: SHASize -> Maybe (Backend Annex) diff --git a/Backend/WORM.hs b/Backend/WORM.hs index dc2e48adc..036d0564c 100644 --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -11,7 +11,6 @@ import Control.Monad.State import System.FilePath import System.Posix.Files -import qualified Backend.File import Types.Backend import Types import Types.Key @@ -20,9 +19,10 @@ backends :: [Backend Annex] backends = [backend] backend :: Backend Annex -backend = Backend.File.backend { +backend = Types.Backend.Backend { name = "WORM", - getKey = keyValue + getKey = keyValue, + fsckKey = const (return True) } {- The key includes the file size, modification time, and the diff --git a/BackendList.hs b/BackendList.hs deleted file mode 100644 index e4e1d76fe..000000000 --- a/BackendList.hs +++ /dev/null @@ -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 - ] diff --git a/CmdLine.hs b/CmdLine.hs index 46b980fbc..b807046df 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -22,7 +22,6 @@ import qualified Git import Content import Types import Command -import BackendList import Version import Options import Messages @@ -32,7 +31,7 @@ import UUID dispatch :: [String] -> [Command] -> [Option] -> String -> Git.Repo -> IO () dispatch args cmds options header gitrepo = do setupConsole - state <- Annex.new gitrepo allBackends + state <- Annex.new gitrepo (actions, state') <- Annex.run state $ parseCmd args header cmds options tryRun state' $ [startup] ++ actions ++ [shutdown] diff --git a/Command/Add.hs b/Command/Add.hs index 6a1ffb5da..2831e1b35 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -42,8 +42,8 @@ start pair@(file, _) = notAnnexed file $ do perform :: BackendFile -> CommandPerform perform (file, backend) = do - stored <- Backend.storeFileKey file backend - case stored of + k <- Backend.genKey file backend + case k of Nothing -> stop Just (key, _) -> do moveAnnex key file diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index ebf0810ba..e80fe9621 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -51,8 +51,8 @@ perform url file = do if ok then do [(_, backend)] <- Backend.chooseBackends [file] - stored <- Backend.storeFileKey tmp backend - case stored of + k <- Backend.genKey tmp backend + case k of Nothing -> stop Just (key, _) -> do moveAnnex key tmp diff --git a/Command/Drop.hs b/Command/Drop.hs index bd4740741..14f098349 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -8,12 +8,15 @@ module Command.Drop where import Command -import qualified Backend +import qualified Remote +import qualified Annex import LocationLog import Types import Content import Messages import Utility +import Trust +import Config command :: [Command] 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 - if it's safe to do so. -} start :: CommandStartAttrFile -start (file, attr) = isAnnexed file $ \(key, backend) -> do - inbackend <- Backend.hasKey key - if inbackend +start (file, attr) = isAnnexed file $ \(key, _) -> do + present <- inAnnex key + if present then do showStart "drop" file - next $ perform key backend numcopies + next $ perform key numcopies else stop where numcopies = readMaybe attr :: Maybe Int -perform :: Key -> Backend Annex -> Maybe Int -> CommandPerform -perform key backend numcopies = do - success <- Backend.removeKey backend key numcopies +perform :: Key -> Maybe Int -> CommandPerform +perform key numcopies = do + success <- dropKey key numcopies if success then next $ cleanup key else stop @@ -47,3 +50,44 @@ cleanup key = do whenM (inAnnex key) $ removeAnnex key logStatus key InfoMissing 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.)" diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs index 2125abdc3..55007c1f7 100644 --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -21,7 +21,6 @@ import qualified Command.Drop import qualified Command.Move import qualified Remote import qualified Git -import Backend import Types.Key import Utility @@ -64,9 +63,7 @@ perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote r <- Remote.byName name showNote $ "from " ++ Remote.name r ++ "..." next $ Command.Move.fromCleanup r True key - droplocal = do - backend <- keyBackend key - Command.Drop.perform key backend (Just 0) -- force drop + droplocal = Command.Drop.perform key (Just 0) -- force drop performOther :: (Git.Repo -> Key -> FilePath) -> Key -> CommandPerform performOther filespec key = do diff --git a/Command/FromKey.hs b/Command/FromKey.hs index 34816d657..fb9ab0775 100644 --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -15,7 +15,6 @@ import Control.Monad (unless) import Command import qualified AnnexQueue import Utility -import qualified Backend import Content import Messages import Types.Key @@ -30,7 +29,7 @@ seek = [withFilesMissing start] start :: CommandStartString start file = notBareRepo $ do key <- cmdlineKey - inbackend <- Backend.hasKey key + inbackend <- inAnnex key unless inbackend $ error $ "key ("++keyName key++") is not present in backend" showStart "fromkey" file diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 988cfd28d..446d25a44 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -9,10 +9,15 @@ module Command.Fsck where import Control.Monad (when) import Control.Monad.State (liftIO) +import System.Directory +import Data.List +import System.Posix.Files import Command -import qualified Backend import qualified Annex +import qualified Remote +import qualified Types.Backend +import qualified Types.Key import UUID import Types import Messages @@ -20,6 +25,9 @@ import Utility import Content import LocationLog import Locations +import Trust +import DataUnits +import Config command :: [Command] 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 -- that gets corrected locationlogok <- verifyLocationLog key file - backendok <- Backend.fsckKey backend key (Just file) numcopies + backendok <- fsckKey backend key (Just file) numcopies if locationlogok && backendok then next $ return True else stop @@ -80,3 +88,68 @@ verifyLocationLog key file = do fix g u s = do showNote "fixing location log" 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 diff --git a/Command/Get.hs b/Command/Get.hs index 50dc009fe..cc780cb6a 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -8,7 +8,6 @@ module Command.Get where import Command -import qualified Backend import qualified Annex import qualified Remote import Types @@ -24,7 +23,7 @@ seek :: [CommandSeek] seek = [withFilesInGit start] start :: CommandStartString -start file = isAnnexed file $ \(key, backend) -> do +start file = isAnnexed file $ \(key, _) -> do inannex <- inAnnex key if inannex then stop @@ -32,14 +31,52 @@ start file = isAnnexed file $ \(key, backend) -> do showStart "get" file from <- Annex.getState Annex.fromremote case from of - Nothing -> next $ perform key backend + Nothing -> next $ perform key Just name -> do src <- Remote.byName name next $ Command.Move.fromPerform src False key -perform :: Key -> Backend Annex -> CommandPerform -perform key backend = do - ok <- getViaTmp key (Backend.retrieveKeyFile backend key) +perform :: Key -> CommandPerform +perform key = do + ok <- getViaTmp key (getKeyFile key) if ok then next $ return True -- no cleanup needed 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 diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 09ff6df7d..495bf9fb6 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -15,6 +15,7 @@ import System.FilePath import Command import qualified Annex import qualified Backend +import qualified Types.Key import Locations import Types import Content @@ -32,18 +33,20 @@ start :: CommandStartBackendFile start (file, b) = isAnnexed file $ \(key, oldbackend) -> do exists <- inAnnex key newbackend <- choosebackend b - upgradable <- Backend.upgradableKey oldbackend key - if (newbackend /= oldbackend || upgradable) && exists + if (newbackend /= oldbackend || upgradableKey key) && exists then do showStart "migrate" file next $ perform file key newbackend else stop where - choosebackend Nothing = do - backends <- Backend.list - return $ head backends + choosebackend Nothing = return . head =<< Backend.orderedList 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 file oldkey newbackend = do g <- Annex.gitRepo @@ -55,9 +58,9 @@ perform file oldkey newbackend = do let src = gitAnnexLocation g oldkey let tmpfile = gitAnnexTmpDir g </> takeFileName file liftIO $ createLink src tmpfile - stored <- Backend.storeFileKey tmpfile $ Just newbackend + k <- Backend.genKey tmpfile $ Just newbackend liftIO $ cleantmp tmpfile - case stored of + case k of Nothing -> stop Just (newkey, _) -> do ok <- getViaTmpUnchecked newkey $ \t -> do diff --git a/Command/Status.hs b/Command/Status.hs index 53589030b..2448f65a4 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -25,6 +25,7 @@ import DataUnits import Content import Types.Key import Locations +import Backend -- a named computation that produces a statistic type Stat = StatState (Maybe (String, StatState String)) @@ -95,9 +96,8 @@ showStat s = calc =<< s calc Nothing = return () supported_backends :: Stat -supported_backends = stat "supported backends" $ - lift (Annex.getState Annex.supportedBackends) >>= - return . unwords . (map B.name) +supported_backends = stat "supported backends" $ + return $ unwords $ map B.name Backend.list supported_remote_types :: Stat supported_remote_types = stat "supported remote types" $ diff --git a/Command/Unannex.hs b/Command/Unannex.hs index f0c1b27c6..f22503ee0 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -13,10 +13,10 @@ import System.Directory import System.Posix.Files import Command +import qualified Command.Drop import qualified Annex import qualified AnnexQueue import Utility -import qualified Backend import LocationLog import Types import Content @@ -33,7 +33,7 @@ seek = [withFilesInGit start] {- The unannex subcommand undoes an add. -} start :: CommandStartString -start file = isAnnexed file $ \(key, backend) -> do +start file = isAnnexed file $ \(key, _) -> do ishere <- inAnnex key if ishere then do @@ -46,13 +46,12 @@ start file = isAnnexed file $ \(key, backend) -> do Annex.changeState $ \s -> s { Annex.force = True } showStart "unannex" file - next $ perform file key backend + next $ perform file key else stop -perform :: FilePath -> Key -> Backend Annex -> CommandPerform -perform file key backend = do - -- force backend to always remove - ok <- Backend.removeKey backend key (Just 0) +perform :: FilePath -> Key -> CommandPerform +perform file key = do + ok <- Command.Drop.dropKey key (Just 0) -- always remove if ok then next $ cleanup file key else stop diff --git a/Command/Unlock.hs b/Command/Unlock.hs index ca8b62502..8a897c365 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -12,7 +12,6 @@ import System.Directory hiding (copyFile) import Command import qualified Annex -import qualified Backend import Types import Messages import Locations @@ -38,7 +37,7 @@ start file = isAnnexed file $ \(key, _) -> do perform :: FilePath -> Key -> CommandPerform perform dest key = do - unlessM (Backend.hasKey key) $ error "content not present" + unlessM (inAnnex key) $ error "content not present" checkDiskSpace key @@ -86,3 +86,16 @@ remoteNotIgnored r = do match a = do n <- Annex.getState a 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" + diff --git a/LocationLog.hs b/LocationLog.hs index eb48b7916..28b423e2f 100644 --- a/LocationLog.hs +++ b/LocationLog.hs @@ -19,7 +19,7 @@ module LocationLog ( keyLocations, loggedKeys, logFile, - logFileKey + logFileKey ) where import System.FilePath @@ -14,10 +14,10 @@ module Remote ( removeKey, hasKey, hasKeyCheap, + keyPossibilities, keyPossibilitiesTrusted, forceTrust, - remoteTypes, genList, byName, @@ -25,6 +25,8 @@ module Remote ( remotesWithUUID, remotesWithoutUUID, prettyPrintUUIDs, + showTriedRemotes, + showLocations, remoteLog, readRemoteLog, @@ -40,6 +42,7 @@ import Data.List import qualified Data.Map as M import Data.Maybe import Data.Char +import Data.String.Utils import qualified Branch import Types @@ -49,6 +52,7 @@ import qualified Annex import Config import Trust import LocationLog +import Messages import qualified Remote.Git import qualified Remote.S3 @@ -181,9 +185,34 @@ keyPossibilities' withtrusted key = do 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 level remotename = do - r <- Remote.nameToUUID remotename + r <- nameToUUID remotename Annex.changeState $ \s -> s { Annex.forcetrust = (r, level):Annex.forcetrust s } diff --git a/Remote/Git.hs b/Remote/Git.hs index 471417e34..b4006d7fd 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -112,7 +112,7 @@ inAnnex r key = if Git.repoIsUrl r checklocal = do -- run a local check inexpensively, -- by making an Annex monad using the remote - a <- Annex.new r [] + a <- Annex.new r Annex.eval a (Content.inAnnex key) checkremote = do showNote ("checking " ++ Git.repoDescribe r ++ "...") @@ -142,7 +142,7 @@ copyToRemote r key let keysrc = gitAnnexLocation g key -- run copy from perspective of remote liftIO $ do - a <- Annex.new r [] + a <- Annex.new r Annex.eval a $ do ok <- Content.getViaTmp key $ rsyncOrCopyFile r keysrc diff --git a/Types/Backend.hs b/Types/Backend.hs index 8100eaf28..f86d0845c 100644 --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -16,22 +16,8 @@ data Backend a = Backend { name :: String, -- converts a filename to a 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 - -- (second parameter may be the filename associated with it) - -- (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 + fsckKey :: Key -> a Bool } instance Show (Backend a) where diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs index 39b8e47c5..c0bbeebaf 100644 --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -191,17 +191,16 @@ logFile1 repo key = Upgrade.V2.gitStateDir repo ++ keyFile1 key ++ ".log" lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend Annex)) lookupFile1 file = do - bs <- Annex.getState Annex.supportedBackends tl <- liftIO $ try getsymlink case tl of Left _ -> return Nothing - Right l -> makekey bs l + Right l -> makekey l where getsymlink = do l <- readSymbolicLink file return $ takeFileName l - makekey bs l = do - case maybeLookupBackendName bs bname of + makekey l = do + case maybeLookupBackendName bname of Nothing -> do unless (null kname || null bname || not (isLinkToAnnex l)) $ @@ -25,7 +25,6 @@ import System.Path (recurseDir) import System.IO.HVFS (SystemFS(..)) import qualified Annex -import qualified BackendList import qualified Backend import qualified Git import qualified Locations @@ -483,7 +482,7 @@ annexeval :: Types.Annex a -> IO a annexeval a = do g <- Git.repoFromCwd g' <- Git.configRead g - s <- Annex.new g' BackendList.allBackends + s <- Annex.new g' Annex.eval s a innewrepo :: Assertion -> Assertion @@ -684,4 +683,4 @@ backendWORM :: Types.Backend Types.Annex backendWORM = backend_ "WORM" backend_ :: String -> Types.Backend Types.Annex -backend_ name = Backend.lookupBackendName BackendList.allBackends name +backend_ name = Backend.lookupBackendName name |