support for storing files in direct mode

This commit is contained in:
Joey Hess 2012-12-07 14:40:31 -04:00
parent 2adb38aa59
commit 3898d8c091
3 changed files with 56 additions and 13 deletions

View file

@ -194,7 +194,8 @@ checkDiskSpace destination key alreadythere = do
" more" ++ forcemsg " more" ++ forcemsg
forcemsg = " (use --force to override this check or adjust annex.diskreserve)" forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
{- Moves a file into .git/annex/objects/ {- Moves a key's content into .git/annex/objects/
- In direct mode, moves it to the associated file, or files.
- -
- What if the key there already has content? This could happen for - What if the key there already has content? This could happen for
- various reasons; perhaps the same content is being annexed again. - various reasons; perhaps the same content is being annexed again.
@ -216,7 +217,12 @@ checkDiskSpace destination key alreadythere = do
- meet. - meet.
-} -}
moveAnnex :: Key -> FilePath -> Annex () moveAnnex :: Key -> FilePath -> Annex ()
moveAnnex key src = do moveAnnex key src = ifM isDirect
( storefiles =<< associatedFiles key
, storeobject
)
where
storeobject = do
dest <- inRepo $ gitAnnexLocation key dest <- inRepo $ gitAnnexLocation key
ifM (liftIO $ doesFileExist dest) ifM (liftIO $ doesFileExist dest)
( liftIO $ removeFile src ( liftIO $ removeFile src
@ -226,6 +232,35 @@ moveAnnex key src = do
freezeContent dest freezeContent dest
freezeContentDir dest freezeContentDir dest
) )
storefiles [] = storeobject
storefiles (dest:fs) = do
thawContent src
liftIO $ replacefile dest $ moveFile src
liftIO $ forM_ fs $ \f -> replacefile f $ createLink dest
replacefile file a = do
{- Remove any symlink or existing file. -}
r <- tryIO $ removeFile file
{- Only need to create parent directory if file did not exist. -}
case r of
Left _ -> createDirectoryIfMissing True (parentDir file)
_ -> noop
a file
{- Files in the tree that are associated with a key.
- For use in direct mode.
-
- When no known associated files exist, returns the gitAnnexLocation. -}
associatedFiles :: Key -> Annex [FilePath]
associatedFiles key = do
mapping <- inRepo $ gitAnnexMapping key
files <- liftIO $ catchDefaultIO [] $ lines <$> readFile mapping
if null files
then do
l <- inRepo $ gitAnnexLocation key
return [l]
else do
top <- fromRepo Git.repoPath
return $ map (top </>) files
withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a
withObjectLoc key a = do withObjectLoc key a = do

View file

@ -117,8 +117,8 @@ getDiskReserve = fromMaybe megabyte . readSize dataUnits
megabyte = 1000000 megabyte = 1000000
{- Gets annex.direct setting. -} {- Gets annex.direct setting. -}
getDirect :: Annex Bool isDirect :: Annex Bool
getDirect = fromMaybe False . Git.Config.isTrue <$> isDirect = fromMaybe False . Git.Config.isTrue <$>
getConfig (annexConfig "direct") "" getConfig (annexConfig "direct") ""
{- Gets annex.httpheaders or annex.httpheaders-command setting, {- Gets annex.httpheaders or annex.httpheaders-command setting,

View file

@ -11,6 +11,7 @@ module Locations (
keyPaths, keyPaths,
keyPath, keyPath,
gitAnnexLocation, gitAnnexLocation,
gitAnnexMapping,
annexLocations, annexLocations,
annexLocation, annexLocation,
gitAnnexDir, gitAnnexDir,
@ -107,6 +108,13 @@ gitAnnexLocation key r
check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs
check [] = error "internal" check [] = error "internal"
{- 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
return $ loc ++ ".map"
{- The annex directory of a repository. -} {- The annex directory of a repository. -}
gitAnnexDir :: Git.Repo -> FilePath gitAnnexDir :: Git.Repo -> FilePath
gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir