Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Use lower case hash directories for storing files on crippled filesys…

…tems, 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.
  • Loading branch information...
commit f1b0a4b404ed835f1c4a27a92352180be8564f8a 1 parent c20143e
@joeyh authored
View
6 Annex.hs
@@ -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
27 Annex/Content.hs
@@ -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
6 Annex/Content/Direct.hs
@@ -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
7 Annex/Direct.hs
@@ -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
2  Assistant/Threads/Committer.hs
@@ -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
4 Assistant/Threads/Watcher.hs
@@ -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
8 Command/Add.hs
@@ -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
3  Command/Fix.hs
@@ -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
2  Command/FromKey.hs
@@ -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
12 Command/Fsck.hs
@@ -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
6 Command/Indirect.hs
@@ -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
2  Command/Migrate.hs
@@ -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
2  Command/ReKey.hs
@@ -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
3  Command/Sync.hs
@@ -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
2  Command/Unannex.hs
@@ -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
2  Command/Unlock.hs
@@ -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
2  Common/Annex.hs
@@ -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
50 Locations.hs
@@ -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
4 Remote/Git.hs
@@ -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
6 Types/GitConfig.hs
@@ -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
2  Upgrade/V1.hs
@@ -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]
View
2  debian/changelog
@@ -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
Please sign in to comment.
Something went wrong with that request. Please try again.