diff --git a/Annex/Content.hs b/Annex/Content.hs index e488de2747..5abcb2a9e1 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -50,6 +50,7 @@ import Annex.Exception import Git.SharedRepository import Annex.Perms import Annex.Content.Direct +import Backend {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool @@ -248,33 +249,27 @@ moveAnnex key src = withObjectLoc key storeobject storedirect freezeContent dest freezeContentDir dest ) - storedirect fs = storedirect' =<< liftIO (filterM validsymlink fs) - - validsymlink f = do - tl <- tryIO $ readSymbolicLink f - return $ case tl of - Right l - | isLinkToAnnex l -> - Just key == fileKey (takeFileName l) - _ -> False + storedirect fs = storedirect' =<< filterM validsymlink fs + validsymlink f = (==) (Just key) <$> isAnnexLink f storedirect' [] = storeobject =<< inRepo (gitAnnexLocation key) storedirect' (dest:fs) = do updateInodeCache key src thawContent src - liftIO $ replaceFile dest $ moveFile src - liftIO $ forM_ fs $ \f -> replaceFile f $ - void . copyFileExternal dest + replaceFile dest $ liftIO . moveFile src + forM_ fs $ \f -> replaceFile f $ + void . liftIO . copyFileExternal dest {- Replaces any existing file with a new version, by running an action. - First, makes sure the file is deleted. Or, if it didn't already exist, - makes sure the parent directory exists. -} -replaceFile :: FilePath -> (FilePath -> IO ()) -> IO () +replaceFile :: FilePath -> (FilePath -> Annex ()) -> Annex () replaceFile file a = do - r <- tryIO $ removeFile file - case r of - Left _ -> createDirectoryIfMissing True (parentDir file) - _ -> noop + liftIO $ do + r <- tryIO $ removeFile file + case r of + Left _ -> createDirectoryIfMissing True $ parentDir file + _ -> noop a file {- Runs an action to transfer an object's content. @@ -370,8 +365,8 @@ removeAnnex key = withObjectLoc key remove removedirect cwd <- liftIO getCurrentDirectory let top' = fromMaybe top $ absNormPath cwd top let l' = relPathDirToFile top' (fromMaybe l $ absNormPath top' l) - liftIO $ replaceFile f $ const $ - createSymbolicLink l' f + replaceFile f $ const $ + makeAnnexLink l' f {- Moves a key's file out of .git/annex/objects/ -} fromAnnex :: Key -> FilePath -> Annex () diff --git a/Annex/Direct.hs b/Annex/Direct.hs index 733cb93563..a4839d509f 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -155,8 +155,8 @@ mergeDirectCleanup d oldsha newsha = do - Symlinks are replaced with their content, if it's available. -} movein k f = do l <- calcGitLink f k - liftIO $ replaceFile f $ const $ - createSymbolicLink l f + replaceFile f $ const $ + liftIO $ createSymbolicLink l f toDirect k f {- Any new, modified, or renamed files were written to the temp @@ -181,14 +181,15 @@ toDirectGen k f = do {- Move content from annex to direct file. -} updateInodeCache k loc thawContent loc - liftIO $ replaceFile f $ moveFile loc + replaceFile f $ + liftIO . moveFile loc , return Nothing ) (loc':_) -> ifM (liftIO $ catchBoolIO $ not . isSymbolicLink <$> getSymbolicLinkStatus loc') {- Another direct file has the content; copy it. -} - ( return $ Just $ do - liftIO $ replaceFile f $ - void . copyFileExternal loc' + ( return $ Just $ + replaceFile f $ + void . liftIO . copyFileExternal loc' , return Nothing ) diff --git a/Backend.hs b/Backend.hs index d5007f0f97..076f7c2cee 100644 --- a/Backend.hs +++ b/Backend.hs @@ -1,6 +1,6 @@ {- git-annex key/value backends - - - Copyright 2010 Joey Hess + - Copyright 2010,2013 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -10,6 +10,8 @@ module Backend ( orderedList, genKey, lookupFile, + isAnnexLink, + makeAnnexLink, chooseBackend, lookupBackendName, maybeLookupBackendName @@ -81,20 +83,20 @@ genKey' (b:bs) source = do - the symlink is looked up in git instead. However, a real symlink - on disk still takes precedence over what was committed to git in direct - mode. + - + - On a filesystem that does not support symlinks, git will instead store + - the symlink target in a regular file. -} lookupFile :: FilePath -> Annex (Maybe (Key, Backend)) lookupFile file = do - tl <- liftIO $ tryIO $ readSymbolicLink file - case tl of - Right l - | isLinkToAnnex l -> makekey l - | otherwise -> return Nothing - Left _ -> ifM isDirect + mkey <- isAnnexLink file + case mkey of + Just key -> makeret key + Nothing -> ifM isDirect ( maybe (return Nothing) makeret =<< catKeyFile file , return Nothing ) where - makekey l = maybe (return Nothing) makeret (fileKey $ takeFileName l) makeret k = let bname = keyBackendName k in case maybeLookupBackendName bname of Just backend -> do @@ -105,6 +107,35 @@ lookupFile file = do " (unknown backend " ++ bname ++ ")" return Nothing +{- Checks if a file is a symlink to a key. + - + - On a filesystem that does not support symlinks, git will instead store + - the symlink target in a regular file. (Only look at first 8k of file, + - more than enough for any symlink target.) + -} +isAnnexLink :: FilePath -> Annex (Maybe Key) +isAnnexLink file = maybe Nothing makekey <$> gettarget + where + gettarget = ifM (coreSymlinks <$> Annex.getGitConfig) + ( liftIO $ catchMaybeIO $ readSymbolicLink file + , liftIO $ catchMaybeIO $ take 8192 <$> readFile file + ) + makekey l + | isLinkToAnnex l = fileKey $ takeFileName l + | otherwise = Nothing + +{- Creates a symlink 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. + -} +makeAnnexLink :: String -> FilePath -> Annex () +makeAnnexLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig) + ( liftIO $ createSymbolicLink linktarget file + , liftIO $ writeFile file linktarget + ) + {- Looks up the backend that should be used for a file. - That can be configured on a per-file basis in the gitattributes file. -} chooseBackend :: FilePath -> Annex (Maybe Backend) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 014a409e1f..2430a73a70 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -36,38 +36,40 @@ data GitConfig = GitConfig , annexAutoCommit :: Bool , annexWebOptions :: [String] , annexCrippledFileSystem :: Bool + , coreSymlinks :: Bool } extractGitConfig :: Git.Repo -> GitConfig extractGitConfig r = GitConfig - { annexVersion = notempty $ getmaybe "version" - , annexNumCopies = get "numcopies" 1 + { annexVersion = notempty $ getmaybe (annex "version") + , annexNumCopies = get (annex "numcopies") 1 , annexDiskReserve = fromMaybe onemegabyte $ - readSize dataUnits =<< getmaybe "diskreserve" - , annexDirect = getbool "direct" False - , annexBackends = getwords "backends" - , annexQueueSize = getmayberead "queuesize" - , annexBloomCapacity = getmayberead "bloomcapacity" - , annexBloomAccuracy = getmayberead "bloomaccuracy" - , annexSshCaching = getmaybebool "sshcaching" - , annexAlwaysCommit = getbool "alwayscommit" True - , annexDelayAdd = getmayberead "delayadd" - , annexHttpHeaders = getlist "http-headers" - , annexHttpHeadersCommand = getmaybe "http-headers-command" - , annexAutoCommit = getbool "autocommit" True - , annexWebOptions = getwords "web-options" - , annexCrippledFileSystem = getbool "crippledfilesystem" False + readSize dataUnits =<< getmaybe (annex "diskreserve") + , annexDirect = getbool (annex "direct") False + , annexBackends = getwords (annex "backends") + , annexQueueSize = getmayberead (annex "queuesize") + , annexBloomCapacity = getmayberead (annex "bloomcapacity") + , annexBloomAccuracy = getmayberead (annex "bloomaccuracy") + , annexSshCaching = getmaybebool (annex "sshcaching") + , annexAlwaysCommit = getbool (annex "alwayscommit") True + , annexDelayAdd = getmayberead (annex "delayadd") + , annexHttpHeaders = getlist (annex "http-headers") + , annexHttpHeadersCommand = getmaybe (annex "http-headers-command") + , annexAutoCommit = getbool (annex "autocommit") True + , annexWebOptions = getwords (annex "web-options") + , annexCrippledFileSystem = getbool (annex "crippledfilesystem") False + , coreSymlinks = getbool "core.symlinks" True } where get k def = fromMaybe def $ getmayberead k getbool k def = fromMaybe def $ getmaybebool k getmaybebool k = Git.Config.isTrue =<< getmaybe k getmayberead k = readish =<< getmaybe k - getmaybe k = Git.Config.getMaybe (key k) r - getlist k = Git.Config.getList (key k) r + getmaybe k = Git.Config.getMaybe k r + getlist k = Git.Config.getList k r getwords k = fromMaybe [] $ words <$> getmaybe k - key k = "annex." ++ k + annex k = "annex." ++ k onemegabyte = 1000000