start to support core.symlinks=false

Utility functions to handle no symlink mode, and converted Annex.Content to
use them; still many other places to convert.

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 ()

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
 			)
 

Backend.hs

@@ -1,6 +1,6 @@
 {- git-annex key/value backends
  -
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010,2013 Joey Hess <joey@kitenet.net>
  -
  - 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)

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