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.
This commit is contained in:
parent
2b3c120506
commit
da9cd315be
15 changed files with 73 additions and 44 deletions
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue