From da9cd315beb03570b96f83063a39e799fe01b166 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Nov 2011 22:43:51 -0400 Subject: add support for using hashDirLower in addition to hashDirMixed Supporting multiple directory hash types will allow converting to a different one, without a flag day. gitAnnexLocation now checks which of the possible locations have a file. This means more statting of files. Several places currently use gitAnnexLocation and immediately check if the returned file exists; those need to be optimised. --- Annex/Content.hs | 17 ++++++++--------- Backend/SHA.hs | 2 +- Command/Add.hs | 2 +- Command/Fsck.hs | 4 ++-- Command/Migrate.hs | 2 +- Command/SendKey.hs | 2 +- Command/Unannex.hs | 2 +- Command/Unlock.hs | 2 +- Locations.hs | 35 +++++++++++++++++++++++++---------- Remote/Bup.hs | 4 ++-- Remote/Directory.hs | 4 ++-- Remote/Git.hs | 29 ++++++++++++++++++++++------- Remote/Hook.hs | 4 ++-- Remote/Rsync.hs | 4 ++-- Remote/S3real.hs | 4 ++-- 15 files changed, 73 insertions(+), 44 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index f5571b54a..90bde2975 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -43,12 +43,12 @@ import Annex.Exception {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool -inAnnex = inAnnex' doesFileExist +inAnnex = inAnnex' $ doesFileExist inAnnex' :: (FilePath -> IO a) -> Key -> Annex a inAnnex' a key = do whenM (fromRepo Git.repoIsUrl) $ error "inAnnex cannot check remote repo" - inRepo $ a . gitAnnexLocation key + inRepo $ \g -> gitAnnexLocation key g >>= a {- A safer check; the key's content must not only be present, but - is not in the process of being removed. -} @@ -70,7 +70,7 @@ inAnnexSafe = inAnnex' $ \f -> openForLock f False >>= check - it. (If the content is not present, no locking is done.) -} lockContent :: Key -> Annex a -> Annex a lockContent key a = do - file <- fromRepo $ gitAnnexLocation key + file <- inRepo $ gitAnnexLocation key bracketIO (openForLock file True >>= lock) unlock a where lock Nothing = return Nothing @@ -100,9 +100,8 @@ calcGitLink :: FilePath -> Key -> Annex FilePath calcGitLink file key = do cwd <- liftIO getCurrentDirectory let absfile = fromMaybe whoops $ absNormPath cwd file - top <- fromRepo Git.workTree - return $ relPathDirToFile (parentDir absfile) - top ".git" annexLocation key + loc <- inRepo $ gitAnnexLocation key + return $ relPathDirToFile (parentDir absfile) loc where whoops = error $ "unable to normalize " ++ file @@ -213,7 +212,7 @@ checkDiskSpace' adjustment key = do -} moveAnnex :: Key -> FilePath -> Annex () moveAnnex key src = do - dest <- fromRepo $ gitAnnexLocation key + dest <- inRepo $ gitAnnexLocation key let dir = parentDir dest e <- liftIO $ doesFileExist dest if e @@ -227,7 +226,7 @@ moveAnnex key src = do withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a withObjectLoc key a = do - file <- fromRepo $gitAnnexLocation key + file <- inRepo $ gitAnnexLocation key let dir = parentDir file a (dir, file) @@ -250,7 +249,7 @@ fromAnnex key dest = withObjectLoc key $ \(dir, file) -> liftIO $ do - returns the file it was moved to. -} moveBad :: Key -> Annex FilePath moveBad key = do - src <- fromRepo $ gitAnnexLocation key + src <- inRepo $ gitAnnexLocation key bad <- fromRepo gitAnnexBadDir let dest = bad takeFileName src liftIO $ do diff --git a/Backend/SHA.hs b/Backend/SHA.hs index a3846a410..2ae0cfcf4 100644 --- a/Backend/SHA.hs +++ b/Backend/SHA.hs @@ -99,7 +99,7 @@ keyValueE size file = keyValue size file >>= maybe (return Nothing) addE checkKeyChecksum :: SHASize -> Key -> Annex Bool checkKeyChecksum size key = do fast <- Annex.getState Annex.fast - file <- fromRepo $ gitAnnexLocation key + file <- inRepo $ gitAnnexLocation key present <- liftIO $ doesFileExist file if not present || fast then return True diff --git a/Command/Add.hs b/Command/Add.hs index 130f5e311..9fdbdcaa6 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -60,7 +60,7 @@ undo file key e = do -- fromAnnex could fail if the file ownership is weird tryharder :: IOException -> Annex () tryharder _ = do - src <- fromRepo $ gitAnnexLocation key + src <- inRepo $ gitAnnexLocation key liftIO $ moveFile src file cleanup :: FilePath -> Key -> Bool -> CommandCleanup diff --git a/Command/Fsck.hs b/Command/Fsck.hs index 99dda99e5..a803207e2 100644 --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -87,7 +87,7 @@ verifyLocationLog key desc = do -- Since we're checking that a key's file is present, throw -- in a permission fixup here too. when present $ do - f <- fromRepo $ gitAnnexLocation key + f <- inRepo $ gitAnnexLocation key liftIO $ do preventWrite f preventWrite (parentDir f) @@ -118,7 +118,7 @@ verifyLocationLog key desc = do - the key's metadata, if available. -} checkKeySize :: Key -> Annex Bool checkKeySize key = do - file <- fromRepo $ gitAnnexLocation key + file <- inRepo $ gitAnnexLocation key present <- liftIO $ doesFileExist file case (present, Types.Key.keySize key) of (_, Nothing) -> return True diff --git a/Command/Migrate.hs b/Command/Migrate.hs index 7a329080f..c85d7c2ac 100644 --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -49,7 +49,7 @@ upgradableKey key = isNothing $ Types.Key.keySize key -} perform :: FilePath -> Key -> Backend Annex -> CommandPerform perform file oldkey newbackend = do - src <- fromRepo $ gitAnnexLocation oldkey + src <- inRepo $ gitAnnexLocation oldkey tmp <- fromRepo gitAnnexTmpDir let tmpfile = tmp takeFileName file cleantmp tmpfile diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 573747867..7b1cd3eca 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -21,7 +21,7 @@ seek = [withKeys start] start :: Key -> CommandStart start key = do - file <- fromRepo $ gitAnnexLocation key + file <- inRepo $ gitAnnexLocation key whenM (inAnnex key) $ liftIO $ rsyncServerSend file -- does not return warning "requested key is not present" diff --git a/Command/Unannex.hs b/Command/Unannex.hs index b9190ce04..e97b6d05d 100644 --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -55,7 +55,7 @@ cleanup file key = do if fast then do -- fast mode: hard link to content in annex - src <- fromRepo $ gitAnnexLocation key + src <- inRepo $ gitAnnexLocation key liftIO $ do createLink src file allowWrite file diff --git a/Command/Unlock.hs b/Command/Unlock.hs index b6f39488d..673a7038a 100644 --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -37,7 +37,7 @@ perform dest key = do checkDiskSpace key - src <- fromRepo $ gitAnnexLocation key + src <- inRepo $ gitAnnexLocation key tmpdest <- fromRepo $ gitAnnexTmpLocation key liftIO $ createDirectoryIfMissing True (parentDir tmpdest) showAction "copying" diff --git a/Locations.hs b/Locations.hs index 3cb632aae..425e4fdcf 100644 --- a/Locations.hs +++ b/Locations.hs @@ -9,7 +9,7 @@ module Locations ( keyFile, fileKey, gitAnnexLocation, - annexLocation, + annexLocations, gitAnnexDir, gitAnnexObjectDir, gitAnnexTmpDir, @@ -58,17 +58,33 @@ annexDir = addTrailingPathSeparator "annex" objectDir :: FilePath objectDir = addTrailingPathSeparator $ annexDir "objects" -{- Annexed file's location relative to the .git directory. -} -annexLocation :: Key -> FilePath -annexLocation key = objectDir hashDirMixed key f f +{- Annexed file's possible locations relative to the .git directory. + - There are two different possibilities, using different hashes; + - the first is the default for new content. -} +annexLocations :: Key -> [FilePath] +annexLocations key = [using hashDirMixed, using hashDirLower] where + using h = objectDir h key f f f = keyFile key -{- Annexed file's absolute location in a repository. -} -gitAnnexLocation :: Key -> Git.Repo -> FilePath +{- Annexed file's absolute location in a repository. + - Out of the possible annexLocations, returns the one where the file + - is actually present. When the file is not present, returns the + - one where the file should be put. + -} +gitAnnexLocation :: Key -> Git.Repo -> IO FilePath gitAnnexLocation key r - | Git.repoIsLocalBare r = Git.workTree r annexLocation key - | otherwise = Git.workTree r ".git" annexLocation key + | Git.repoIsLocalBare r = + go (Git.workTree r) $ annexLocations key + | otherwise = + go (Git.workTree r ".git") $ annexLocations key + where + go dir locs = fromMaybe (dir head locs) <$> check dir locs + check _ [] = return Nothing + check dir (l:ls) = do + let f = dir l + e <- doesFileExist f + if e then return (Just f) else check dir ls {- The annex directory of a repository. -} gitAnnexDir :: Git.Repo -> FilePath @@ -76,8 +92,7 @@ gitAnnexDir r | Git.repoIsLocalBare r = addTrailingPathSeparator $ Git.workTree r annexDir | otherwise = addTrailingPathSeparator $ Git.workTree r ".git" annexDir -{- The part of the annex directory where file contents are stored. - -} +{- The part of the annex directory where file contents are stored. -} gitAnnexObjectDir :: Git.Repo -> FilePath gitAnnexObjectDir r | Git.repoIsLocalBare r = addTrailingPathSeparator $ Git.workTree r objectDir diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 4c826498d..589dea91d 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -102,13 +102,13 @@ bupSplitParams r buprepo k src = do store :: Git.Repo -> BupRepo -> Key -> Annex Bool store r buprepo k = do - src <- fromRepo $ gitAnnexLocation k + src <- inRepo $ gitAnnexLocation k params <- bupSplitParams r buprepo k (File src) liftIO $ boolSystem "bup" params storeEncrypted :: Git.Repo -> BupRepo -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted r buprepo (cipher, enck) k = do - src <- fromRepo $ gitAnnexLocation k + src <- inRepo $ gitAnnexLocation k params <- bupSplitParams r buprepo enck (Param "-") liftIO $ catchBoolIO $ withEncryptedHandle cipher (L.readFile src) $ \h -> diff --git a/Remote/Directory.hs b/Remote/Directory.hs index cadd5e759..891a19ef6 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -94,12 +94,12 @@ withStoredFile = withCheckedFile doesFileExist store :: FilePath -> Key -> Annex Bool store d k = do - src <- fromRepo $ gitAnnexLocation k + src <- inRepo $ gitAnnexLocation k liftIO $ catchBoolIO $ storeHelper d k $ copyFileExternal src storeEncrypted :: FilePath -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted d (cipher, enck) k = do - src <- fromRepo $ gitAnnexLocation k + src <- inRepo $ gitAnnexLocation k liftIO $ catchBoolIO $ storeHelper d enck $ encrypt src where encrypt src dest = do diff --git a/Remote/Git.hs b/Remote/Git.hs index 541d8e5f6..07afc0274 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -134,7 +134,14 @@ inAnnex r key | Git.repoIsUrl r = checkremote | otherwise = checklocal where - checkhttp = liftIO $ catchMsgIO $ Url.exists $ keyUrl r key + checkhttp = liftIO $ go undefined $ keyUrls r key + where + go e [] = return $ Left e + go _ (u:us) = do + res <- catchMsgIO $ Url.exists u + case res of + Left e -> go e us + v -> return v checkremote = do showAction $ "checking " ++ Git.repoDescribe r onRemote r (check, unknown) "inannex" [Param (show key)] @@ -169,8 +176,10 @@ onLocal r a = do liftIO Git.reap return ret -keyUrl :: Git.Repo -> Key -> String -keyUrl r key = Git.repoLocation r ++ "/" ++ annexLocation key +keyUrls :: Git.Repo -> Key -> [String] +keyUrls r key = map tourl (annexLocations key) + where + tourl l = Git.repoLocation r ++ "/" ++ l dropKey :: Git.Repo -> Key -> Annex Bool dropKey r key @@ -185,16 +194,22 @@ copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool copyFromRemote r key file | not $ Git.repoIsUrl r = do params <- rsyncParams r - rsyncOrCopyFile params (gitAnnexLocation key r) file + loc <- liftIO $ gitAnnexLocation key r + rsyncOrCopyFile params loc file | Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file - | Git.repoIsHttp r = liftIO $ Url.download (keyUrl r key) file + | Git.repoIsHttp r = liftIO $ downloadurls $ keyUrls r key | otherwise = error "copying from non-ssh, non-http repo not supported" + where + downloadurls [] = return False + downloadurls (u:us) = do + ok <- Url.download u file + if ok then return ok else downloadurls us {- Tries to copy a key's content to a remote's annex. -} copyToRemote :: Git.Repo -> Key -> Annex Bool copyToRemote r key | not $ Git.repoIsUrl r = do - keysrc <- fromRepo $ gitAnnexLocation key + keysrc <- inRepo $ gitAnnexLocation key params <- rsyncParams r -- run copy from perspective of remote liftIO $ onLocal r $ do @@ -203,7 +218,7 @@ copyToRemote r key Annex.Content.saveState return ok | Git.repoIsSsh r = do - keysrc <- fromRepo $ gitAnnexLocation key + keysrc <- inRepo $ gitAnnexLocation key rsyncHelper =<< rsyncParamsRemote r False key keysrc | otherwise = error "copying to non-ssh repo not supported" diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 03976fc70..ab84533b2 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -97,12 +97,12 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h store :: String -> Key -> Annex Bool store h k = do - src <- fromRepo $ gitAnnexLocation k + src <- inRepo $ gitAnnexLocation k runHook h "store" k (Just src) $ return True storeEncrypted :: String -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do - src <- fromRepo $ gitAnnexLocation k + src <- inRepo $ gitAnnexLocation k liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp runHook h "store" enck (Just tmp) $ return True diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 5cd27a609..836b93b31 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -95,11 +95,11 @@ rsyncKeyDir :: RsyncOpts -> Key -> String rsyncKeyDir o k = rsyncUrl o hashDirMixed k rsyncEscape o (keyFile k) store :: RsyncOpts -> Key -> Annex Bool -store o k = rsyncSend o k =<< fromRepo (gitAnnexLocation k) +store o k = rsyncSend o k =<< inRepo (gitAnnexLocation k) storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do - src <- fromRepo $ gitAnnexLocation k + src <- inRepo $ gitAnnexLocation k liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp rsyncSend o enck tmp diff --git a/Remote/S3real.hs b/Remote/S3real.hs index 97ac64821..b79939b90 100644 --- a/Remote/S3real.hs +++ b/Remote/S3real.hs @@ -112,7 +112,7 @@ s3Setup u c = handlehost $ M.lookup "host" c store :: Remote Annex -> Key -> Annex Bool store r k = s3Action r False $ \(conn, bucket) -> do - dest <- fromRepo $ gitAnnexLocation k + dest <- inRepo $ gitAnnexLocation k res <- liftIO $ storeHelper (conn, bucket) r k dest s3Bool res @@ -121,7 +121,7 @@ storeEncrypted r (cipher, enck) k = s3Action r False $ \(conn, bucket) -> -- To get file size of the encrypted content, have to use a temp file. -- (An alternative would be chunking to to a constant size.) withTmp enck $ \tmp -> do - f <- fromRepo $ gitAnnexLocation k + f <- inRepo $ gitAnnexLocation k liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s res <- liftIO $ storeHelper (conn, bucket) r enck tmp s3Bool res -- cgit v1.2.3