support for storing files in direct mode
This commit is contained in:
parent
2adb38aa59
commit
3898d8c091
3 changed files with 56 additions and 13 deletions
|
@ -194,7 +194,8 @@ checkDiskSpace destination key alreadythere = do
|
|||
" more" ++ forcemsg
|
||||
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
|
||||
- various reasons; perhaps the same content is being annexed again.
|
||||
|
@ -216,16 +217,50 @@ checkDiskSpace destination key alreadythere = do
|
|||
- meet.
|
||||
-}
|
||||
moveAnnex :: Key -> FilePath -> Annex ()
|
||||
moveAnnex key src = do
|
||||
dest <- inRepo $ gitAnnexLocation key
|
||||
ifM (liftIO $ doesFileExist dest)
|
||||
( liftIO $ removeFile src
|
||||
, do
|
||||
createContentDir dest
|
||||
liftIO $ moveFile src dest
|
||||
freezeContent dest
|
||||
freezeContentDir dest
|
||||
)
|
||||
moveAnnex key src = ifM isDirect
|
||||
( storefiles =<< associatedFiles key
|
||||
, storeobject
|
||||
)
|
||||
where
|
||||
storeobject = do
|
||||
dest <- inRepo $ gitAnnexLocation key
|
||||
ifM (liftIO $ doesFileExist dest)
|
||||
( liftIO $ removeFile src
|
||||
, do
|
||||
createContentDir dest
|
||||
liftIO $ moveFile src dest
|
||||
freezeContent 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 a = do
|
||||
|
|
|
@ -117,8 +117,8 @@ getDiskReserve = fromMaybe megabyte . readSize dataUnits
|
|||
megabyte = 1000000
|
||||
|
||||
{- Gets annex.direct setting. -}
|
||||
getDirect :: Annex Bool
|
||||
getDirect = fromMaybe False . Git.Config.isTrue <$>
|
||||
isDirect :: Annex Bool
|
||||
isDirect = fromMaybe False . Git.Config.isTrue <$>
|
||||
getConfig (annexConfig "direct") ""
|
||||
|
||||
{- Gets annex.httpheaders or annex.httpheaders-command setting,
|
||||
|
|
|
@ -11,6 +11,7 @@ module Locations (
|
|||
keyPaths,
|
||||
keyPath,
|
||||
gitAnnexLocation,
|
||||
gitAnnexMapping,
|
||||
annexLocations,
|
||||
annexLocation,
|
||||
gitAnnexDir,
|
||||
|
@ -107,6 +108,13 @@ gitAnnexLocation key r
|
|||
check locs@(l:_) = fromMaybe l <$> firstM doesFileExist locs
|
||||
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. -}
|
||||
gitAnnexDir :: Git.Repo -> FilePath
|
||||
gitAnnexDir r = addTrailingPathSeparator $ Git.localGitDir r </> annexDir
|
||||
|
|
Loading…
Reference in a new issue