fully support core.symlinks=false in all relevant symlink handling code

Refactored annex link code into nice clean new library.

Audited and dealt with calls to createSymbolicLink.
Remaining calls are all safe, because:

Annex/Link.hs:  ( liftIO $ createSymbolicLink linktarget file
  only when core.symlinks=true
Assistant/WebApp/Configurators/Local.hs:                createSymbolicLink link link
  test if symlinks can be made
Command/Fix.hs: liftIO $ createSymbolicLink link file
  command only works in indirect mode
Command/FromKey.hs:     liftIO $ createSymbolicLink link file
  command only works in indirect mode
Command/Indirect.hs:                    liftIO $ createSymbolicLink l f
  refuses to run if core.symlinks=false
Init.hs:                createSymbolicLink f f2
  test if symlinks can be made
Remote/Directory.hs:    go [file] = catchBoolIO $ createSymbolicLink file f >> return True
  fast key linking; catches failure to make symlink and falls back to copy
Remote/Git.hs:          liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
  ditto
Upgrade/V1.hs:                          liftIO $ createSymbolicLink link f
  v1 repos could not be on a filesystem w/o symlinks

Audited and dealt with calls to readSymbolicLink.
Remaining calls are all safe, because:

Annex/Link.hs:		( liftIO $ catchMaybeIO $ readSymbolicLink file
  only when core.symlinks=true
Assistant/Threads/Watcher.hs:		ifM ((==) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file))
  code that fixes real symlinks when inotify sees them
  It's ok to not fix psdueo-symlinks.
Assistant/Threads/Watcher.hs:		mlink <- liftIO (catchMaybeIO $ readSymbolicLink file)
  ditto
Command/Fix.hs:	stopUnless ((/=) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file)) $ do
  command only works in indirect mode
Upgrade/V1.hs:	getsymlink = takeFileName <$> readSymbolicLink file
  v1 repos could not be on a filesystem w/o symlinks

Audited and dealt with calls to isSymbolicLink.
(Typically used with getSymbolicLinkStatus, but that is just used because
getFileStatus is not as robust; it also works on pseudolinks.)
Remaining calls are all safe, because:

Assistant/Threads/SanityChecker.hs:                             | isSymbolicLink s -> addsymlink file ms
  only handles staging of symlinks that were somehow not staged
  (might need to be updated to support pseudolinks, but this is
  only a belt-and-suspenders check anyway, and I've never seen the code run)
Command/Add.hs:         if isSymbolicLink s || not (isRegularFile s)
  avoids adding symlinks to the annex, so not relevant
Command/Indirect.hs:                            | isSymbolicLink s -> void $ flip whenAnnexed f $
  only allowed on systems that support symlinks
Command/Indirect.hs:            whenM (liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f) $ do
  ditto
Seek.hs:notSymlink f = liftIO $ not . isSymbolicLink <$> getSymbolicLinkStatus f
  used to find unlocked files, only relevant in indirect mode
Utility/FSEvents.hs:                    | Files.isSymbolicLink s = runhook addSymlinkHook $ Just s
Utility/FSEvents.hs:                                            | Files.isSymbolicLink s ->
Utility/INotify.hs:                             | Files.isSymbolicLink s ->
Utility/INotify.hs:                     checkfiletype Files.isSymbolicLink addSymlinkHook f
Utility/Kqueue.hs:              | Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change
  all above are lower-level, not relevant

Audited and dealt with calls to isSymLink.
Remaining calls are all safe, because:

Annex/Direct.hs:			| isSymLink (getmode item) =
  This is looking at git diff-tree objects, not files on disk
Command/Unused.hs:		| isSymLink (LsTree.mode l) = do
  This is looking at git ls-tree, not file on disk
Utility/FileMode.hs:isSymLink :: FileMode -> Bool
Utility/FileMode.hs:isSymLink = checkMode symbolicLinkMode
  low-level

Done!!

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
+			stageSymlink file =<< hashSymlink =<< calcGitLink file key
-			sha <- inRepo $ Git.HashObject.hashObject BlobObject link
-			Annex.Queue.addUpdateIndex =<<
-				inRepo (Git.UpdateIndex.stageSymlink file sha)
 			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 $
+		replaceFile f $
-			liftIO $ createSymbolicLink l 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
+	when (null locs) $
-		r <- liftIO $ catchMaybeIO $ getSymbolicLinkStatus f
+		whenM (not . isJust <$> getAnnexLinkTarget f) $
-		case r of
+			moveAnnex k f
-			Just s
-				| not (isSymbolicLink s) ->
-					moveAnnex k f
-			_ -> noop
 	liftIO $ do
 		nukeFile f
 		void $ tryIO $ removeDirectory $ parentDir f

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)

Assistant/Threads/Committer.hs

@@ -15,16 +15,13 @@ import Assistant.Types.Changes
 import Assistant.Commits
 import Assistant.Alert
 import Assistant.DaemonStatus
-import Assistant.Threads.Watcher
 import Assistant.TransferQueue
 import Logs.Transfer
 import Logs.Location
 import qualified Annex.Queue
 import qualified Git.Command
-import qualified Git.HashObject
 import qualified Git.LsFiles
 import qualified Git.Version
-import Git.Types
 import qualified Command.Add
 import Utility.ThreadScheduler
 import qualified Utility.Lsof as Lsof
@@ -33,6 +30,7 @@ import Types.KeySource
 import Config
 import Annex.Exception
 import Annex.Content
+import Annex.Link
 import qualified Annex
 
 import Data.Time.Clock
@@ -216,9 +214,7 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
 				, Command.Add.link file key True
 				)
 			whenM (pure DirWatcher.eventsCoalesce <||> isDirect) $ do
-				sha <- inRepo $
+				stageSymlink file =<< hashSymlink link
-					Git.HashObject.hashObject BlobObject link
-				stageSymlink file sha
 				showEndOk
 		queueTransfers Next key (Just file) Upload
 		return $ Just change

Assistant/Threads/Watcher.hs

@@ -12,7 +12,6 @@ module Assistant.Threads.Watcher (
 	WatcherException(..),
 	checkCanWatch,
 	needLsof,
-	stageSymlink,
 	onAddSymlink,
 	runHandler,
 ) where
@@ -32,13 +31,13 @@ import qualified Annex
 import qualified Annex.Queue
 import qualified Git
 import qualified Git.UpdateIndex
-import qualified Git.HashObject
 import qualified Git.LsFiles as LsFiles
 import qualified Backend
 import Annex.Content
 import Annex.Direct
 import Annex.Content.Direct
 import Annex.CatFile
+import Annex.Link
 import Git.Types
 import Config
 import Utility.ThreadScheduler
@@ -206,7 +205,7 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
 				ensurestaged (Just link) s
 			, do
 				liftIO $ removeFile file
-				liftIO $ createSymbolicLink link file
+				liftAnnex $ Backend.makeAnnexLink link file
 				checkcontent key =<< getDaemonStatus
 				addlink link
 			)
@@ -242,10 +241,7 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
 				Just (currlink, sha)
 					| s2w8 link == L.unpack currlink ->
 						stageSymlink file sha
-				_ -> do
+				_ -> stageSymlink file =<< hashSymlink link
-					sha <- inRepo $
-						Git.HashObject.hashObject BlobObject link
-					stageSymlink file sha
 		madeChange file LinkChange
 
 	{- When a new link appears, or a link is changed, after the startup
@@ -289,13 +285,3 @@ onErr msg _ = do
 	liftAnnex $ warning msg
 	void $ addAlert $ warningAlert "watcher" msg
 	noChange
-
-{- Adds a symlink to the index, without ever accessing the actual symlink
- - on disk. This avoids a race if git add is used, where the symlink is
- - changed to something else immediately after creation. It also allows
- - direct mode to work.
- -}
-stageSymlink :: FilePath -> Sha -> Annex ()
-stageSymlink file sha =
-	Annex.Queue.addUpdateIndex =<<
-		inRepo (Git.UpdateIndex.stageSymlink file sha)

Backend.hs

@@ -17,12 +17,11 @@ module Backend (
 	maybeLookupBackendName
 ) where
 
-import System.Posix.Files
-
 import Common.Annex
 import qualified Annex
 import Annex.CheckAttr
 import Annex.CatFile
+import Annex.Link
 import Types.Key
 import Types.KeySource
 import qualified Types.Backend as B
@@ -77,15 +76,12 @@ genKey' (b:bs) source = do
 		| otherwise = c
 
 {- Looks up the key and backend corresponding to an annexed file,
- - by examining what the file symlinks to.
+ - by examining what the file links to.
  -
- - In direct mode, there is often no symlink on disk, in which case
+ - In direct mode, there is often no link on disk, in which case
- - the symlink is looked up in git instead. However, a real symlink
+ - the symlink is looked up in git instead. However, a real link
  - 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
@@ -107,35 +103,6 @@ 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)

Command/Add.hs

@@ -12,22 +12,20 @@ module Command.Add where
 import Common.Annex
 import Annex.Exception
 import Command
-import qualified Annex
-import qualified Annex.Queue
 import Types.KeySource
 import Backend
 import Logs.Location
 import Annex.Content
 import Annex.Content.Direct
 import Annex.Perms
+import Annex.Link
+import qualified Annex
+import qualified Annex.Queue
 #ifndef WITH_ANDROID
 import Utility.Touch
 #endif
 import Utility.FileMode
 import Config
-import qualified Git.HashObject
-import qualified Git.UpdateIndex
-import Git.Types
 import Utility.InodeCache
 
 def :: [Command]
@@ -159,7 +157,7 @@ undo file key e = do
 link :: FilePath -> Key -> Bool -> Annex String
 link file key hascontent = handle (undo file key) $ do
 	l <- calcGitLink file key
-	liftIO $ createSymbolicLink l file
+	makeAnnexLink l file
 
 #ifndef WITH_ANDROID
 	when hascontent $ do
@@ -173,23 +171,35 @@ link file key hascontent = handle (undo file key) $ do
 	return l
 
 {- Note: Several other commands call this, and expect it to 
- - create the symlink and add it. -}
+ - create the link and add it.
+ - 
+ - In direct mode, when we have the content of the file, it's left as-is,
+ - and we just stage a symlink to git.
+ - 
+ - Otherwise, as long as the filesystem supports symlinks, we use
+ - git add, rather than directly staging the symlink to git.
+ - Using git add is best because it allows the queuing to work
+ - and is faster (staging the symlink runs hash-object commands each time).
+ - Also, using git add allows it to skip gitignored files, unless forced
+ - to include them.
+ -}
 cleanup :: FilePath -> Key -> Bool -> CommandCleanup
 cleanup file key hascontent = do
 	when hascontent $
 		logStatus key InfoPresent
 	ifM (isDirect <&&> pure hascontent)
-		( do
+		( stageSymlink file =<< hashSymlink =<< calcGitLink file key
-			l <- calcGitLink file key
+		, ifM (coreSymlinks <$> Annex.getGitConfig)
-			sha <- inRepo $ Git.HashObject.hashObject BlobObject l
+			( do
-			Annex.Queue.addUpdateIndex =<<
+				_ <- link file key hascontent
-				inRepo (Git.UpdateIndex.stageSymlink file sha)
+				params <- ifM (Annex.getState Annex.force)
-		, do
+					( return [Param "-f"]
-			_ <- link file key hascontent
+					, return []
-			params <- ifM (Annex.getState Annex.force)
+					)
-				( return [Param "-f"]
+				Annex.Queue.addCommand "add" (params++[Param "--"]) [file]
-				, return []
+			, do
-				)
+				l <- link file key hascontent
-			Annex.Queue.addCommand "add" (params++[Param "--"]) [file]
+				addAnnexLink l file
+			)
 		)
 	return True

Command/Fsck.hs

@@ -10,7 +10,6 @@ module Command.Fsck where
 import Common.Annex
 import Command
 import qualified Annex
-import qualified Annex.Queue
 import qualified Remote
 import qualified Types.Backend
 import qualified Types.Key
@@ -18,6 +17,7 @@ import qualified Backend
 import Annex.Content
 import Annex.Content.Direct
 import Annex.Perms
+import Annex.Link
 import Logs.Location
 import Logs.Trust
 import Annex.UUID
@@ -182,14 +182,14 @@ performBare key backend = check
 check :: [Annex Bool] -> Annex Bool
 check cs = all id <$> sequence cs
 
-{- Checks that the file's symlink points correctly to the content.
+{- Checks that the file's link points correctly to the content.
  -
- - In direct mode, there is only a symlink when the content is not present.
+ - In direct mode, there is only a link when the content is not present.
  -}
 fixLink :: Key -> FilePath -> Annex Bool
 fixLink key file = do
 	want <- calcGitLink file key
-	have <- liftIO $ catchMaybeIO $ readSymbolicLink file
+	have <- getAnnexLinkTarget file
 	maybe noop (go want) have
 	return True
   where
@@ -210,8 +210,7 @@ fixLink key file = do
 		showNote "fixing link"
 		liftIO $ createDirectoryIfMissing True (parentDir file)
 		liftIO $ removeFile file
-		liftIO $ createSymbolicLink want file
+		addAnnexLink want file
-		Annex.Queue.addCommand "add" [Param "--force", Param "--"] [file]
 
 {- Checks that the location log reflects the current status of the key,
  - in this repository only. -}

Command/Indirect.hs

@@ -13,6 +13,7 @@ import qualified Git
 import qualified Git.Command
 import qualified Git.LsFiles
 import Config
+import qualified Annex
 import Annex.Direct
 import Annex.Content
 import Annex.CatFile
@@ -27,10 +28,12 @@ seek = [withNothing start]
 
 start :: CommandStart
 start = ifM isDirect
-	( ifM probeCrippledFileSystem
+	( do
-		( error "This repository seems to be on a crippled filesystem, you must use direct mode."
+		unlessM (coreSymlinks <$> Annex.getGitConfig) $
-		, next perform
+			error "Git is configured to not use symlinks, so you must use direct mode."
-		)
+		whenM probeCrippledFileSystem $
+			error "This repository seems to be on a crippled filesystem, you must use direct mode."
+		next perform
 	, stop
 	)
 

Command/Sync.hs

@@ -17,6 +17,7 @@ import qualified Annex.Queue
 import Annex.Content
 import Annex.Direct
 import Annex.CatFile
+import Annex.Link
 import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
 import qualified Git.Merge
@@ -263,10 +264,8 @@ resolveMerge' u
 	makelink (Just key) = do
 		let dest = mergeFile file key
 		l <- calcGitLink dest key
-		liftIO $ do
+		liftIO $ nukeFile dest
-			nukeFile dest
+		addAnnexLink l dest
-			createSymbolicLink l dest
-		Annex.Queue.addCommand "add" [Param "--force", Param "--"] [dest]
 		whenM (isDirect) $
 			toDirect key dest
 	makelink _ = noop

debian/changelog

@@ -1,3 +1,10 @@
+git-annex (3.20130217) UNRELEASED; urgency=low
+
+  * Should now fully support git repositories with core.symlinks=false;
+    always using git's pseudosymlink files in such repositories.
+
+ -- Joey Hess <joeyh@debian.org>  Sun, 17 Feb 2013 16:42:16 -0400
+
 git-annex (3.20130216) unstable; urgency=low
 
   * Now uses the Haskell uuid library, rather than needing a uuid program.