Use lower case hash directories for storing files on crippled filesystems, same as is already done for bare repositories.

* since this is a crippled filesystem anyway, git-annex doesn't use
  symlinks on it
* so there's no reason to use the mixed case hash directories that we're
  stuck using to avoid breaking everyone's symlinks to the content
* so we can do what is already done for all bare repos, and make non-bare
  repos on crippled filesystems use the all-lower case hash directories
* which are, happily, all 3 letters long, so they cannot conflict with
  mixed case hash directories
* so I was able to 100% fix this and even resuming `git annex add` in the
  test case will recover and it will all just work.
This commit is contained in:
Joey Hess 2013-04-04 15:46:33 -04:00
parent c20143ee32
commit f1b0a4b404
22 changed files with 90 additions and 70 deletions

View file

@ -28,6 +28,7 @@ module Annex (
gitRepo,
inRepo,
fromRepo,
calcRepo,
getGitConfig,
changeGitConfig,
changeGitRepo,
@ -203,6 +204,11 @@ inRepo a = liftIO . a =<< gitRepo
fromRepo :: (Git.Repo -> a) -> Annex a
fromRepo a = a <$> gitRepo
calcRepo :: (Git.Repo -> GitConfig -> IO a) -> Annex a
calcRepo a = do
s <- getState id
liftIO $ a (repo s) (gitconfig s)
{- Gets the GitConfig settings. -}
getGitConfig :: Annex GitConfig
getGitConfig = getState gitconfig

View file

@ -9,7 +9,6 @@ module Annex.Content (
inAnnex,
inAnnexSafe,
lockContent,
calcGitLink,
getViaTmp,
getViaTmpChecked,
getViaTmpUnchecked,
@ -101,7 +100,7 @@ inAnnexSafe = inAnnex' (fromMaybe False) (Just False) go
- it. (If the content is not present, no locking is done.) -}
lockContent :: Key -> Annex a -> Annex a
lockContent key a = do
file <- inRepo $ gitAnnexLocation key
file <- calcRepo $ gitAnnexLocation key
bracketIO (openforlock file >>= lock) unlock a
where
{- Since files are stored with the write bit disabled, have
@ -123,16 +122,6 @@ lockContent key a = do
unlock Nothing = noop
unlock (Just l) = closeFd l
{- Calculates the relative path to use to link a file to a key. -}
calcGitLink :: FilePath -> Key -> Annex FilePath
calcGitLink file key = do
cwd <- liftIO getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPath cwd file
loc <- inRepo $ gitAnnexLocation key
return $ relPathDirToFile (parentDir absfile) loc
where
whoops = error $ "unable to normalize " ++ file
{- Runs an action, passing it a temporary filename to get,
- and if the action succeeds, moves the temp file into
- the annex as a key's content. -}
@ -251,7 +240,7 @@ moveAnnex key src = withObjectLoc key storeobject storedirect
storedirect fs = storedirect' =<< filterM validsymlink fs
validsymlink f = (==) (Just key) <$> isAnnexLink f
storedirect' [] = storeobject =<< inRepo (gitAnnexLocation key)
storedirect' [] = storeobject =<< calcRepo (gitAnnexLocation key)
storedirect' (dest:fs) = do
updateInodeCache key src
thawContent src
@ -341,11 +330,11 @@ withObjectLoc key indirect direct = ifM isDirect
, goindirect
)
where
goindirect = indirect =<< inRepo (gitAnnexLocation key)
goindirect = indirect =<< calcRepo (gitAnnexLocation key)
cleanObjectLoc :: Key -> Annex ()
cleanObjectLoc key = do
file <- inRepo $ gitAnnexLocation key
file <- calcRepo $ gitAnnexLocation key
unlessM crippledFileSystem $
void $ liftIO $ catchMaybeIO $ allowWrite $ parentDir file
liftIO $ removeparents file (3 :: Int)
@ -374,7 +363,7 @@ removeAnnex key = withObjectLoc key remove removedirect
removeInodeCache key
mapM_ (resetfile cache) fs
resetfile cache f = whenM (sameInodeCache f cache) $ do
l <- calcGitLink f key
l <- inRepo $ gitAnnexLink f key
top <- fromRepo Git.repoPath
cwd <- liftIO getCurrentDirectory
let top' = fromMaybe top $ absNormPath cwd top
@ -384,7 +373,7 @@ removeAnnex key = withObjectLoc key remove removedirect
{- Moves a key's file out of .git/annex/objects/ -}
fromAnnex :: Key -> FilePath -> Annex ()
fromAnnex key dest = do
file <- inRepo $ gitAnnexLocation key
file <- calcRepo $ gitAnnexLocation key
unlessM crippledFileSystem $
liftIO $ allowWrite $ parentDir file
thawContent file
@ -395,7 +384,7 @@ fromAnnex key dest = do
- returns the file it was moved to. -}
moveBad :: Key -> Annex FilePath
moveBad key = do
src <- inRepo $ gitAnnexLocation key
src <- calcRepo $ gitAnnexLocation key
bad <- fromRepo gitAnnexBadDir
let dest = bad </> takeFileName src
createAnnexDirectory (parentDir dest)
@ -468,7 +457,7 @@ preseedTmp key file = go =<< inAnnex key
copy = ifM (liftIO $ doesFileExist file)
( return True
, do
s <- inRepo $ gitAnnexLocation key
s <- calcRepo $ gitAnnexLocation key
liftIO $ copyFileExternal s file
)

View file

@ -42,7 +42,7 @@ associatedFiles key = do
- the top of the repo. -}
associatedFilesRelative :: Key -> Annex [FilePath]
associatedFilesRelative key = do
mapping <- inRepo $ gitAnnexMapping key
mapping <- calcRepo $ gitAnnexMapping key
liftIO $ catchDefaultIO [] $ do
h <- openFile mapping ReadMode
fileEncoding h
@ -52,7 +52,7 @@ associatedFilesRelative key = do
- transformation to the list. Returns new associatedFiles value. -}
changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]
changeAssociatedFiles key transform = do
mapping <- inRepo $ gitAnnexMapping key
mapping <- calcRepo $ gitAnnexMapping key
files <- associatedFilesRelative key
let files' = transform files
when (files /= files') $ do
@ -124,7 +124,7 @@ removeInodeCache key = withInodeCacheFile key $ \f -> do
liftIO $ nukeFile f
withInodeCacheFile :: Key -> (FilePath -> Annex a) -> Annex a
withInodeCacheFile key a = a =<< inRepo (gitAnnexInodeCache key)
withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)
{- Checks if a InodeCache matches the current version of a file. -}
sameInodeCache :: FilePath -> Maybe InodeCache -> Annex Bool

View file

@ -89,7 +89,8 @@ addDirect file cache = do
return False
got (Just (key, _)) = ifM (sameInodeCache file $ Just cache)
( do
stageSymlink file =<< hashSymlink =<< calcGitLink file key
l <- inRepo $ gitAnnexLink file key
stageSymlink file =<< hashSymlink l
writeInodeCache key cache
void $ addAssociatedFile key file
logStatus key InfoPresent
@ -152,7 +153,7 @@ mergeDirectCleanup d oldsha newsha = do
-
- Symlinks are replaced with their content, if it's available. -}
movein k f = do
l <- calcGitLink f k
l <- inRepo $ gitAnnexLink f k
replaceFile f $ makeAnnexLink l
toDirect k f
@ -169,7 +170,7 @@ toDirect k f = fromMaybe noop =<< toDirectGen k f
toDirectGen :: Key -> FilePath -> Annex (Maybe (Annex ()))
toDirectGen k f = do
loc <- inRepo $ gitAnnexLocation k
loc <- calcRepo $ gitAnnexLocation k
absf <- liftIO $ absPath f
locs <- filter (/= absf) <$> addAssociatedFile k f
case locs of

View file

@ -312,7 +312,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
done change file key = liftAnnex $ do
logStatus key InfoPresent
link <- ifM isDirect
( calcGitLink file key
( inRepo $ gitAnnexLink file key
, Command.Add.link file key True
)
whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ do

View file

@ -201,7 +201,7 @@ onAddDirect matcher file fs = do
- just been deleted and been put back,
- so it symlink is restaged to make sure. -}
( do
link <- liftAnnex $ calcGitLink file key
link <- liftAnnex $ inRepo $ gitAnnexLink file key
addLink file link (Just key)
, do
debug ["changed direct", file]
@ -222,7 +222,7 @@ onAddSymlink isdirect file filestatus = go =<< liftAnnex (Backend.lookupFile fil
go (Just (key, _)) = do
when isdirect $
liftAnnex $ void $ addAssociatedFile key file
link <- liftAnnex $ calcGitLink file key
link <- liftAnnex $ inRepo $ gitAnnexLink file key
ifM ((==) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file))
( ensurestaged (Just link) (Just key) =<< getDaemonStatus
, do

View file

@ -168,13 +168,13 @@ undo file key e = do
-- fromAnnex could fail if the file ownership is weird
tryharder :: IOException -> Annex ()
tryharder _ = do
src <- inRepo $ gitAnnexLocation key
src <- calcRepo $ gitAnnexLocation key
liftIO $ moveFile src file
{- Creates the symlink to the annexed content, returns the link target. -}
link :: FilePath -> Key -> Bool -> Annex String
link file key hascontent = handle (undo file key) $ do
l <- calcGitLink file key
l <- inRepo $ gitAnnexLink file key
replaceFile file $ makeAnnexLink l
#ifndef __ANDROID__
@ -206,7 +206,9 @@ cleanup file key hascontent = do
when hascontent $
logStatus key InfoPresent
ifM (isDirect <&&> pure hascontent)
( stageSymlink file =<< hashSymlink =<< calcGitLink file key
( do
l <- inRepo $ gitAnnexLink file key
stageSymlink file =<< hashSymlink l
, ifM (coreSymlinks <$> Annex.getGitConfig)
( do
_ <- link file key hascontent

View file

@ -10,7 +10,6 @@ module Command.Fix where
import Common.Annex
import Command
import qualified Annex.Queue
import Annex.Content
def :: [Command]
def = [notDirect $ noCommit $ command "fix" paramPaths seek
@ -22,7 +21,7 @@ seek = [withFilesInGit $ whenAnnexed start]
{- Fixes the symlink to an annexed file. -}
start :: FilePath -> (Key, Backend) -> CommandStart
start file (key, _) = do
link <- calcGitLink file key
link <- inRepo $ gitAnnexLink file key
stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do
showStart "fix" file
next $ perform file link

View file

@ -33,7 +33,7 @@ start _ = error "specify a key and a dest file"
perform :: Key -> FilePath -> CommandPerform
perform key file = do
link <- calcGitLink file key
link <- inRepo $ gitAnnexLink file key
liftIO $ createDirectoryIfMissing True (parentDir file)
liftIO $ createSymbolicLink link file
next $ cleanup file

View file

@ -188,7 +188,7 @@ check cs = all id <$> sequence cs
-}
fixLink :: Key -> FilePath -> Annex Bool
fixLink key file = do
want <- calcGitLink file key
want <- inRepo $ gitAnnexLink file key
have <- getAnnexLinkTarget file
maybe noop (go want) have
return True
@ -223,7 +223,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 && not direct) $ do
file <- inRepo $ gitAnnexLocation key
file <- calcRepo $ gitAnnexLocation key
freezeContent file
freezeContentDir file
@ -281,7 +281,7 @@ checkKeySize :: Key -> Annex Bool
checkKeySize key = ifM isDirect
( return True
, do
file <- inRepo $ gitAnnexLocation key
file <- calcRepo $ gitAnnexLocation key
ifM (liftIO $ doesFileExist file)
( checkKeySizeOr badContent key file
, return True
@ -322,7 +322,7 @@ checkKeySizeOr bad key file = case Types.Key.keySize key of
-}
checkBackend :: Backend -> Key -> Annex Bool
checkBackend backend key = do
file <- inRepo $ gitAnnexLocation key
file <- calcRepo $ gitAnnexLocation key
ifM isDirect
( ifM (goodContent key file)
( checkBackendOr' (badContentDirect file) backend key file
@ -443,14 +443,14 @@ needFsck _ _ = return True
-}
recordFsckTime :: Key -> Annex ()
recordFsckTime key = do
parent <- parentDir <$> inRepo (gitAnnexLocation key)
parent <- parentDir <$> calcRepo (gitAnnexLocation key)
liftIO $ void $ tryIO $ do
touchFile parent
setSticky parent
getFsckTime :: Key -> Annex (Maybe EpochTime)
getFsckTime key = do
parent <- parentDir <$> inRepo (gitAnnexLocation key)
parent <- parentDir <$> calcRepo (gitAnnexLocation key)
liftIO $ catchDefaultIO Nothing $ do
s <- getFileStatus parent
return $ if isSticky $ fileMode s

View file

@ -82,13 +82,13 @@ perform = do
cleandirect k -- clean before content directory gets frozen
whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
moveAnnex k f
l <- calcGitLink f k
l <- inRepo $ gitAnnexLink f k
liftIO $ createSymbolicLink l f
showEndOk
cleandirect k = do
liftIO . nukeFile =<< inRepo (gitAnnexInodeCache k)
liftIO . nukeFile =<< inRepo (gitAnnexMapping k)
liftIO . nukeFile =<< calcRepo (gitAnnexInodeCache k)
liftIO . nukeFile =<< calcRepo (gitAnnexMapping k)
cleanup :: CommandCleanup
cleanup = do

View file

@ -63,7 +63,7 @@ perform file oldkey oldbackend newbackend = do
go newkey = stopUnless (Command.ReKey.linkKey oldkey newkey) $
next $ Command.ReKey.cleanup file oldkey newkey
genkey = do
content <- inRepo $ gitAnnexLocation oldkey
content <- calcRepo $ gitAnnexLocation oldkey
let source = KeySource
{ keyFilename = file
, contentLocation = content

View file

@ -49,7 +49,7 @@ perform file oldkey newkey = do
{- Make a hard link to the old key content, to avoid wasting disk space. -}
linkKey :: Key -> Key -> Annex Bool
linkKey oldkey newkey = getViaTmpUnchecked newkey $ \tmp -> do
src <- inRepo $ gitAnnexLocation oldkey
src <- calcRepo $ gitAnnexLocation oldkey
ifM (liftIO $ doesFileExist tmp)
( return True
, ifM crippledFileSystem

View file

@ -14,7 +14,6 @@ import qualified Remote
import qualified Annex
import qualified Annex.Branch
import qualified Annex.Queue
import Annex.Content
import Annex.Direct
import Annex.CatFile
import Annex.Link
@ -268,7 +267,7 @@ resolveMerge' u
[Just SymlinkBlob, Nothing]
makelink (Just key) = do
let dest = mergeFile file key
l <- calcGitLink dest key
l <- inRepo $ gitAnnexLink dest key
liftIO $ nukeFile dest
addAnnexLink l dest
whenM (isDirect) $

View file

@ -60,7 +60,7 @@ cleanup file key = do
where
goFast = do
-- fast mode: hard link to content in annex
src <- inRepo $ gitAnnexLocation key
src <- calcRepo $ gitAnnexLocation key
-- creating a hard link could fall; fall back to non fast mode
ifM (liftIO $ catchBoolIO $ createLink src file >> return True)
( thawContent file

View file

@ -35,7 +35,7 @@ perform dest key = do
unlessM (inAnnex key) $ error "content not present"
unlessM (checkDiskSpace Nothing key 0) $ error "cannot unlock"
src <- inRepo $ gitAnnexLocation key
src <- calcRepo $ gitAnnexLocation key
tmpdest <- fromRepo $ gitAnnexTmpLocation key
liftIO $ createDirectoryIfMissing True (parentDir tmpdest)
showAction "copying"

View file

@ -3,6 +3,6 @@ module Common.Annex (module X) where
import Common as X
import Types as X
import Types.UUID as X (toUUID, fromUUID)
import Annex as X (gitRepo, inRepo, fromRepo)
import Annex as X (gitRepo, inRepo, fromRepo, calcRepo)
import Locations as X
import Messages as X

View file

@ -11,6 +11,7 @@ module Locations (
keyPaths,
keyPath,
gitAnnexLocation,
gitAnnexLink,
gitAnnexMapping,
gitAnnexInodeCache,
gitAnnexInodeSentinal,
@ -88,7 +89,7 @@ annexLocations key = map (annexLocation key) annexHashes
annexLocation :: Key -> Hasher -> FilePath
annexLocation key hasher = objectDir </> keyPath key hasher
{- Annexed file's absolute location in a repository.
{- Annexed object's absolute location in a repository.
-
- When there are multiple possible locations, returns the one where the
- file is actually present.
@ -99,35 +100,50 @@ annexLocation key hasher = objectDir </> keyPath key hasher
- This does not take direct mode into account, so in direct mode it is not
- the actual location of the file's content.
-}
gitAnnexLocation :: Key -> Git.Repo -> IO FilePath
gitAnnexLocation key r
| Git.repoIsLocalBare r =
{- Bare repositories default to hashDirLower for new
- content, as it's more portable. -}
gitAnnexLocation :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexLocation key r config = gitAnnexLocation' key r (annexCrippledFileSystem config)
gitAnnexLocation' :: Key -> Git.Repo -> Bool -> IO FilePath
gitAnnexLocation' key r crippled
{- Bare repositories default to hashDirLower for new
- content, as it's more portable.
-
- Repositories on filesystems that are crippled also use
- hashDirLower, since they do not use symlinks and it's
- more portable. -}
| Git.repoIsLocalBare r || crippled =
check $ map inrepo $ annexLocations key
| otherwise =
{- Non-bare repositories only use hashDirMixed, so
- don't need to do any work to check if the file is
- present. -}
return $ inrepo $ annexLocation key hashDirMixed
{- Non-bare repositories only use hashDirMixed, so
- don't need to do any work to check if the file is
- present. -}
| otherwise = return $ inrepo $ annexLocation key hashDirMixed
where
inrepo d = Git.localGitDir r </> d
check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs
check [] = error "internal"
{- Calculates a symlink to link a file to an annexed object. -}
gitAnnexLink :: FilePath -> Key -> Git.Repo -> IO FilePath
gitAnnexLink file key r = do
cwd <- getCurrentDirectory
let absfile = fromMaybe whoops $ absNormPath cwd file
loc <- gitAnnexLocation' key r False
return $ relPathDirToFile (parentDir absfile) loc
where
whoops = error $ "unable to normalize " ++ file
{- File that maps from a key to the file(s) in the git repository.
- Used in direct mode. -}
gitAnnexMapping :: Key -> Git.Repo -> IO FilePath
gitAnnexMapping key r = do
loc <- gitAnnexLocation key r
gitAnnexMapping :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexMapping key r config = do
loc <- gitAnnexLocation key r config
return $ loc ++ ".map"
{- File that caches information about a key's content, used to determine
- if a file has changed.
- Used in direct mode. -}
gitAnnexInodeCache :: Key -> Git.Repo -> IO FilePath
gitAnnexInodeCache key r = do
loc <- gitAnnexLocation key r
gitAnnexInodeCache :: Key -> Git.Repo -> GitConfig -> IO FilePath
gitAnnexInodeCache key r config = do
loc <- gitAnnexLocation key r config
return $ loc ++ ".cache"
gitAnnexInodeSentinal :: Git.Repo -> FilePath

View file

@ -111,6 +111,7 @@ gen r u _ gc = go <$> remoteCost gc defcst
else Nothing
, repo = r
, gitconfig = gc
{ remoteGitConfig = Just $ extractGitConfig r }
, readonly = Git.repoIsHttp r
, globallyAvailable = not $ Git.repoIsLocal r || Git.repoIsLocalUnknown r
, remotetype = remote
@ -332,7 +333,8 @@ copyFromRemote r key file dest
copyFromRemoteCheap :: Remote -> Key -> FilePath -> Annex Bool
copyFromRemoteCheap r key file
| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do
loc <- liftIO $ gitAnnexLocation key (repo r)
loc <- liftIO $ gitAnnexLocation key (repo r) $
fromJust $ remoteGitConfig $ gitconfig r
liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
| Git.repoIsSsh (repo r) =
ifM (Annex.Content.preseedTmp key file)

View file

@ -88,7 +88,8 @@ data RemoteGitConfig = RemoteGitConfig
, remoteAnnexStartCommand :: Maybe String
, remoteAnnexStopCommand :: Maybe String
-- these settings are specific to particular types of remotes
{- These settings are specific to particular types of remotes
- including special remotes. -}
, remoteAnnexSshOptions :: [String]
, remoteAnnexRsyncOptions :: [String]
, remoteAnnexGnupgOptions :: [String]
@ -97,6 +98,8 @@ data RemoteGitConfig = RemoteGitConfig
, remoteAnnexBupSplitOptions :: [String]
, remoteAnnexDirectory :: Maybe FilePath
, remoteAnnexHookType :: Maybe String
{- A regular git remote's git repository config. -}
, remoteGitConfig :: Maybe GitConfig
}
extractRemoteGitConfig :: Git.Repo -> String -> RemoteGitConfig
@ -117,6 +120,7 @@ extractRemoteGitConfig r remotename = RemoteGitConfig
, remoteAnnexBupSplitOptions = getoptions "bup-split-options"
, remoteAnnexDirectory = notempty $ getmaybe "directory"
, remoteAnnexHookType = notempty $ getmaybe "hooktype"
, remoteGitConfig = Nothing
}
where
getbool k def = fromMaybe def $ getmaybebool k

View file

@ -92,7 +92,7 @@ updateSymlinks = do
case r of
Nothing -> noop
Just (k, _) -> do
link <- calcGitLink f k
link <- inRepo $ gitAnnexLink f k
liftIO $ removeFile f
liftIO $ createSymbolicLink link f
Annex.Queue.addCommand "add" [Param "--"] [f]

2
debian/changelog vendored
View file

@ -30,6 +30,8 @@ git-annex (4.20130324) UNRELEASED; urgency=low
* webapp: Improved transfer queue management.
* init: Probe whether the filesystem supports fifos, and if not,
disable ssh connection caching.
* Use lower case hash directories for storing files on crippled filesystems,
same as is already done for bare repositories.
-- Joey Hess <joeyh@debian.org> Mon, 25 Mar 2013 10:21:46 -0400