diff options
Diffstat (limited to 'Annex')
| -rw-r--r-- | Annex/Direct.hs | 24 | ||||
| -rw-r--r-- | Annex/Link.hs | 74 |
2 files changed, 82 insertions, 16 deletions
diff --git a/Annex/Direct.hs b/Annex/Direct.hs index a4839d509..596997652 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -10,8 +10,6 @@ module Annex.Direct where import Common.Annex import qualified Git import qualified Git.LsFiles -import qualified Git.UpdateIndex -import qualified Git.HashObject import qualified Git.Merge import qualified Git.DiffTree as DiffTree import Git.Sha @@ -24,6 +22,7 @@ import Backend import Types.KeySource import Annex.Content import Annex.Content.Direct +import Annex.Link import Utility.InodeCache import Utility.CopyFile @@ -88,10 +87,7 @@ addDirect file cache = do return False got (Just (key, _)) = ifM (liftIO $ compareInodeCache file $ Just cache) ( do - link <- calcGitLink file key - sha <- inRepo $ Git.HashObject.hashObject BlobObject link - Annex.Queue.addUpdateIndex =<< - inRepo (Git.UpdateIndex.stageSymlink file sha) + stageSymlink file =<< hashSymlink =<< calcGitLink file key writeInodeCache key cache void $ addAssociatedFile key file logStatus key InfoPresent @@ -155,8 +151,8 @@ mergeDirectCleanup d oldsha newsha = do - Symlinks are replaced with their content, if it's available. -} movein k f = do l <- calcGitLink f k - replaceFile f $ const $ - liftIO $ createSymbolicLink l f + replaceFile f $ + makeAnnexLink l toDirect k f {- Any new, modified, or renamed files were written to the temp @@ -185,7 +181,7 @@ toDirectGen k f = do liftIO . moveFile loc , return Nothing ) - (loc':_) -> ifM (liftIO $ catchBoolIO $ not . isSymbolicLink <$> getSymbolicLinkStatus loc') + (loc':_) -> ifM (not . isJust <$> getAnnexLinkTarget loc') {- Another direct file has the content; copy it. -} ( return $ Just $ replaceFile f $ @@ -197,13 +193,9 @@ toDirectGen k f = do removeDirect :: Key -> FilePath -> Annex () removeDirect k f = do locs <- removeAssociatedFile k f - when (null locs) $ do - r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f - case r of - Just s - | not (isSymbolicLink s) -> - moveAnnex k f - _ -> noop + when (null locs) $ + whenM (not . isJust <$> getAnnexLinkTarget f) $ + moveAnnex k f liftIO $ do nukeFile f void $ tryIO $ removeDirectory $ parentDir f diff --git a/Annex/Link.hs b/Annex/Link.hs new file mode 100644 index 000000000..f35c069ee --- /dev/null +++ b/Annex/Link.hs @@ -0,0 +1,74 @@ +{- git-annex links to content + - + - On file systems that support them, symlinks are used. + - + - On other filesystems, git instead stores the symlink target in a regular + - file. + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Annex.Link where + +import Common.Annex +import qualified Annex +import qualified Git.HashObject +import qualified Git.UpdateIndex +import qualified Annex.Queue +import Git.Types + +{- Checks if a file is a link to a key. -} +isAnnexLink :: FilePath -> Annex (Maybe Key) +isAnnexLink file = maybe Nothing (fileKey . takeFileName) <$> getAnnexLinkTarget file + +{- Gets the link target of a symlink. + - + - On a filesystem that does not support symlinks, get the link + - target by looking inside the file. (Only return at first 8k of the file, + - more than enough for any symlink target.) + - + - Returns Nothing if the file is not a symlink, or not a link to annex + - content. + -} +getAnnexLinkTarget :: FilePath -> Annex (Maybe String) +getAnnexLinkTarget file = do + v <- ifM (coreSymlinks <$> Annex.getGitConfig) + ( liftIO $ catchMaybeIO $ readSymbolicLink file + , liftIO $ catchMaybeIO $ take 8192 <$> readFile file + ) + case v of + Nothing -> return Nothing + Just l + | isLinkToAnnex l -> return v + | otherwise -> return Nothing + +{- Creates a link on disk. + - + - On a filesystem that does not support symlinks, writes the link target + - to a file. Note that git will only treat the file as a symlink if + - it's staged as such, so use addAnnexLink when adding a new file or + - modified link to git. + -} +makeAnnexLink :: String -> FilePath -> Annex () +makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) + ( liftIO $ createSymbolicLink linktarget file + , liftIO $ writeFile file linktarget + ) + +{- Creates a link on disk, and additionally stages it in git. -} +addAnnexLink :: String -> FilePath -> Annex () +addAnnexLink linktarget file = do + makeAnnexLink linktarget file + stageSymlink file =<< hashSymlink linktarget + +{- Injects a symlink target into git, returning its Sha. -} +hashSymlink :: String -> Annex Sha +hashSymlink linktarget = inRepo $ Git.HashObject.hashObject BlobObject linktarget + +{- Stages a symlink to the annex, using a Sha of its target. -} +stageSymlink :: FilePath -> Sha -> Annex () +stageSymlink file sha = + Annex.Queue.addUpdateIndex =<< + inRepo (Git.UpdateIndex.stageSymlink file sha) |