crippled filesystem support, probing and initial support

git annex init probes for crippled filesystems, and sets direct mode, as
well as `annex.crippledfilesystem`.

Avoid manipulating permissions of files on crippled filesystems.
That would likely cause an exception to be thrown.

Very basic support in Command.Add for cripped filesystems; avoids the lock
down entirely since doing it needs both permissions and hard links.
Will make this better soon.

Annex/Content.hs

@@ -335,12 +335,12 @@ withObjectLoc key indirect direct = ifM isDirect
 cleanObjectLoc :: Key -> Annex ()
 cleanObjectLoc key = do
 	file <- inRepo $ gitAnnexLocation key
-	liftIO $ do
+	let dir = parentDir file
-		let dir = parentDir file
+	unlessM crippledFileSystem $
-		void $ catchMaybeIO $ do
+		void $ liftIO $ catchMaybeIO $ allowWrite dir
-			allowWrite dir
+	void $ liftIO $ catchMaybeIO $ do
-			removeDirectoryRecursive dir
+		removeDirectoryRecursive dir
-		removeparents dir (2 :: Int)
+	liftIO $ removeparents dir (2 :: Int)
   where
 	removeparents _ 0 = noop
 	removeparents file n = do
@@ -356,9 +356,9 @@ removeAnnex :: Key -> Annex ()
 removeAnnex key = withObjectLoc key remove removedirect
   where
 	remove file = do
-		liftIO $ do
+		unlessM crippledFileSystem $
-			allowWrite $ parentDir file
+			liftIO $ allowWrite $ parentDir file
-			removeFile file
+		liftIO $ removeFile file
 		cleanObjectLoc key
 	removedirect fs = do
 		cache <- recordedCache key
@@ -377,7 +377,8 @@ removeAnnex key = withObjectLoc key remove removedirect
 fromAnnex :: Key -> FilePath -> Annex ()
 fromAnnex key dest = do
 	file <- inRepo $ gitAnnexLocation key
-	liftIO $ allowWrite $ parentDir file
+	unlessM crippledFileSystem $
+		liftIO $ allowWrite $ parentDir file
 	thawContent file
 	liftIO $ moveFile file dest
 	cleanObjectLoc key
@@ -390,9 +391,9 @@ moveBad key = do
 	bad <- fromRepo gitAnnexBadDir
 	let dest = bad </> takeFileName src
 	createAnnexDirectory (parentDir dest)
-	liftIO $ do
+	unlessM crippledFileSystem $
-		allowWrite (parentDir src)
+		liftIO $ allowWrite (parentDir src)
-		moveFile src dest
+	liftIO $ moveFile src dest
 	cleanObjectLoc key
 	logStatus key InfoMissing
 	return dest
@@ -454,7 +455,8 @@ preseedTmp key file = go =<< inAnnex key
  - to avoid accidental edits. core.sharedRepository may change
  - who can read it. -}
 freezeContent :: FilePath -> Annex ()
-freezeContent file = liftIO . go =<< fromRepo getSharedRepository
+freezeContent file = unlessM crippledFileSystem $
+	liftIO . go =<< fromRepo getSharedRepository
   where
 	go GroupShared = modifyFileMode file $
 		removeModes writeModes .
@@ -467,7 +469,8 @@ freezeContent file = liftIO . go =<< fromRepo getSharedRepository
 {- Allows writing to an annexed file that freezeContent was called on
  - before. -}
 thawContent :: FilePath -> Annex ()
-thawContent file = liftIO . go =<< fromRepo getSharedRepository
+thawContent file = unlessM crippledFileSystem $
+	liftIO . go =<< fromRepo getSharedRepository
   where
 	go GroupShared = groupWriteRead file
 	go AllShared = groupWriteRead file

Annex/Direct.hs

@@ -143,7 +143,7 @@ mergeDirectCleanup d oldsha newsha = do
 	 - Empty work tree directories are removed, per git behavior. -}
 	moveout_raw f = liftIO $ do
 		nukeFile f
-		void $ catchMaybeIO $ removeDirectory $ parentDir f
+		void $ tryIO $ removeDirectory $ parentDir f
 	
 	{- The symlink is created from the key, rather than moving in the
 	 - symlink created in the temp directory by the merge. This because
@@ -161,7 +161,7 @@ mergeDirectCleanup d oldsha newsha = do
 	 - directory by the merge, and are moved to the real work tree. -}
 	movein_raw f = liftIO $ do
 		createDirectoryIfMissing True $ parentDir f
-		void $ catchMaybeIO $ rename (d </> f) f
+		void $ tryIO $ rename (d </> f) f
 
 {- If possible, converts a symlink in the working tree into a direct
  - mode file. -}
@@ -203,7 +203,7 @@ removeDirect k f = do
 			_ -> noop
 	liftIO $ do
 		nukeFile f
-		void $ catchMaybeIO $ removeDirectory $ parentDir f
+		void $ tryIO $ removeDirectory $ parentDir f
 
 {- Called when a direct mode file has been changed. Its old content may be
  - lost. -}

Annex/Perms.hs

@@ -18,6 +18,7 @@ import Common.Annex
 import Utility.FileMode
 import Git.SharedRepository
 import qualified Annex
+import Config
 
 import System.Posix.Types
 
@@ -34,7 +35,8 @@ withShared a = maybe startup a =<< Annex.getState Annex.shared
  - use the default mode, but with core.sharedRepository set,
  - allow the group to write, etc. -}
 setAnnexPerm :: FilePath -> Annex ()
-setAnnexPerm file = withShared $ liftIO . go
+setAnnexPerm file = unlessM crippledFileSystem $
+	withShared $ liftIO . go
   where
 	go GroupShared = groupWriteRead file
 	go AllShared = modifyFileMode file $ addModes $
@@ -77,7 +79,8 @@ createAnnexDirectory dir = traverse dir [] =<< top
  - file.
  -}
 freezeContentDir :: FilePath -> Annex ()
-freezeContentDir file = liftIO . go =<< fromRepo getSharedRepository
+freezeContentDir file = unlessM crippledFileSystem $
+	liftIO . go =<< fromRepo getSharedRepository
   where
 	dir = parentDir file
 	go GroupShared = groupWriteRead dir
@@ -91,6 +94,7 @@ createContentDir dest = do
 	unlessM (liftIO $ doesDirectoryExist dir) $
 		createAnnexDirectory dir 
 	-- might have already existed with restricted perms
-	liftIO $ allowWrite dir
+	unlessM crippledFileSystem $
+		liftIO $ allowWrite dir
   where
 	dir = parentDir dest

Assistant/Pairing/Network.hs

@@ -60,7 +60,7 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats
 		go cache' $ pred <$> n
 	{- The multicast library currently chokes on ipv6 addresses. -}
 	sendinterface _ (IPv6Addr _) = noop
-	sendinterface cache i = void $ catchMaybeIO $
+	sendinterface cache i = void $ tryIO $
 		withSocketsDo $ bracket setup cleanup use
 	  where
 		setup = multicastSender (multicastAddress i) pairingPort

Assistant/Threads/Committer.hs

@@ -233,7 +233,8 @@ handleAdds delayadd cs = returnWhen (null incomplete) $ do
 			then a
 			else do
 				-- remove the hard link
-				void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
+				when (contentLocation keysource /= keyFilename keysource) $
+					void $ liftIO $ tryIO $ removeFile $ contentLocation keysource
 				return Nothing
 
 {- Files can Either be Right to be added now,
@@ -278,7 +279,8 @@ safeToAdd delayadd pending inprocess = do
 		warning $ keyFilename ks
 			++ " still has writers, not adding"
 		-- remove the hard link
-		void $ liftIO $ tryIO $ removeFile $ contentLocation ks
+		when (contentLocation ks /= keyFilename ks) $
+			void $ liftIO $ tryIO $ removeFile $ contentLocation ks
 	canceladd _ = noop
 
 	openwrite (_file, mode, _pid)

Assistant/WebApp/Utility.hs

@@ -97,7 +97,7 @@ cancelTransfer pause t = do
 		| otherwise = killThread tid
 	{- In order to stop helper processes like rsync,
 	 - kill the whole process group of the process running the transfer. -}
-	killproc pid = void $ catchMaybeIO $ do
+	killproc pid = void $ tryIO $ do
 		g <- getProcessGroupIDOf pid
 		void $ tryIO $ signalProcessGroup sigTERM g
 		threadDelay 50000 -- 0.05 second grace period

Command/Add.hs

@@ -67,18 +67,22 @@ start file = ifAnnexed file fixup add
  - Lockdown can fail if a file gets deleted, and Nothing will be returned.
  -}
 lockDown :: FilePath -> Annex (Maybe KeySource)
-lockDown file = do
+lockDown file = ifM (crippledFileSystem)
-	tmp <- fromRepo gitAnnexTmpDir
+	( return $ Just $
-	createAnnexDirectory tmp
+		KeySource { keyFilename = file, contentLocation = file }
-	liftIO $ catchMaybeIO $ do
+	, do
-		preventWrite file
+		tmp <- fromRepo gitAnnexTmpDir
-		(tmpfile, h) <- openTempFile tmp (takeFileName file)
+		createAnnexDirectory tmp
-		hClose h
+		liftIO $ catchMaybeIO $ do
-		nukeFile tmpfile
+			preventWrite file
-		createLink file tmpfile
+			(tmpfile, h) <- openTempFile tmp (takeFileName file)
-		return $ KeySource { keyFilename = file , contentLocation = tmpfile }
+			hClose h
+			nukeFile tmpfile
+			createLink file tmpfile
+			return $ KeySource { keyFilename = file , contentLocation = tmpfile }
+	)
 
-{- Moves a locked down file into the annex.
+{- Ingests a locked down file into the annex.
  -
  - In direct mode, leaves the file alone, and just updates bookkeeping
  - information.
@@ -107,15 +111,18 @@ ingest (Just source) = do
 			( do
 				writeCache key cache
 				void $ addAssociatedFile key $ keyFilename source
-				liftIO $ allowWrite $ keyFilename source
+				unlessM crippledFileSystem $
-				liftIO $ nukeFile $ contentLocation source
+					liftIO $ allowWrite $ keyFilename source
+				when (contentLocation source /= keyFilename source) $
+					liftIO $ nukeFile $ contentLocation source
 				return $ Just key
 			, failure
 			)
 	godirect _ _ = failure
 
 	failure = do
-		liftIO $ nukeFile $ contentLocation source
+		when (contentLocation source /= keyFilename source) $
+			liftIO $ nukeFile $ contentLocation source
 		return Nothing		
 
 perform :: FilePath -> CommandPerform

Command/Fsck.hs

@@ -203,7 +203,8 @@ fixLink key file = do
 				showNote "fixing content location"
 				dir <- liftIO $ parentDir <$> absPath file
 				let content = absPathFrom dir have
-				liftIO $ allowWrite (parentDir content)
+				unlessM crippledFileSystem $
+					liftIO $ allowWrite (parentDir content)
 				moveAnnex key content
 
 		showNote "fixing link"

Config.hs

@@ -86,6 +86,14 @@ setDirect b = do
 	setConfig (annexConfig "direct") (Git.Config.boolConfig b)
 	Annex.changeGitConfig $ \c -> c { annexDirect = b }
 
+crippledFileSystem :: Annex Bool
+crippledFileSystem = annexCrippledFileSystem <$> Annex.getGitConfig
+
+setCrippledFileSystem :: Bool -> Annex ()
+setCrippledFileSystem b = do
+	setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
+	Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b }
+
 {- Gets the http headers to use. -}
 getHttpHeaders :: Annex [String]
 getHttpHeaders = do

Init.hs

@@ -22,6 +22,8 @@ import Annex.Version
 import Annex.UUID
 import Utility.UserInfo
 import Utility.Shell
+import Utility.FileMode
+import Config
 
 genDescription :: Maybe String -> Annex String
 genDescription (Just d) = return d
@@ -35,6 +37,7 @@ genDescription Nothing = do
 initialize :: Maybe String -> Annex ()
 initialize mdescription = do
 	prepUUID
+	probeCrippledFileSystem
 	Annex.Branch.create
 	setVersion
 	gitPreCommitHookWrite
@@ -98,3 +101,27 @@ preCommitScript = unlines
 	, "# automatically configured by git-annex"
 	, "git annex pre-commit ."
 	]
+
+probeCrippledFileSystem :: Annex ()
+probeCrippledFileSystem = do
+	tmp <- fromRepo gitAnnexTmpDir
+	let f = tmp </> "init-probe"
+	liftIO $ do
+		createDirectoryIfMissing True tmp
+		writeFile f ""
+	whenM (liftIO $ not <$> probe f) $ do
+		warning "Detected a crippled filesystem. Enabling direct mode."
+		setDirect True
+		setCrippledFileSystem True
+	liftIO $ removeFile f
+  where
+	probe f = catchBoolIO $ do
+		let f2 = f ++ "2"
+		nukeFile f2
+		createLink f f2
+		nukeFile f2
+		createSymbolicLink f f2
+		nukeFile f2
+		preventWrite f
+		allowWrite f
+		return True

Remote/Directory.hs

@@ -183,12 +183,14 @@ storeHelper d chunksize key storer = check <&&> go
 		void $ tryIO $ removeDirectoryRecursive dest -- or not exist
 		createDirectoryIfMissing True (parentDir dest)
 		renameDirectory tmp dest
-		mapM_ preventWrite =<< dirContents dest
+		-- may fail on some filesystems
-		preventWrite dest
+		void $ tryIO $ do
+			mapM_ preventWrite =<< dirContents dest
+			preventWrite dest
 	recorder f s = do
 		void $ tryIO $ allowWrite f
 		writeFile f s
-		preventWrite f
+		void $ tryIO $ preventWrite f
 
 retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> Annex Bool
 retrieve d chunksize k _ f = metered Nothing k $ \meterupdate ->
@@ -215,10 +217,11 @@ retrieveCheap d _ k f = liftIO $ withStoredFiles Nothing d k go
 	go _files = return False
 
 remove :: FilePath -> Key -> Annex Bool
-remove d k = liftIO $ catchBoolIO $ do
+remove d k = liftIO $ do
-	allowWrite dir
+	void $ tryIO $ allowWrite dir
-	removeDirectoryRecursive dir
+	catchBoolIO $ do
-	return True
+		removeDirectoryRecursive dir
+		return True
   where
 	dir = storeDir d k
 

Types/GitConfig.hs

@@ -35,6 +35,7 @@ data GitConfig = GitConfig
 	, annexHttpHeadersCommand :: Maybe String
 	, annexAutoCommit :: Bool
 	, annexWebOptions :: [String]
+	, annexCrippledFileSystem :: Bool
 	}
 
 extractGitConfig :: Git.Repo -> GitConfig
@@ -55,6 +56,7 @@ extractGitConfig r = GitConfig
 	, annexHttpHeadersCommand = getmaybe "http-headers-command"
 	, annexAutoCommit = getbool "autocommit" True
 	, annexWebOptions = getwords "web-options"
+	, annexCrippledFileSystem = getbool "crippledfilesystem" False
 	}
   where
 	get k def = fromMaybe def $ getmayberead k

Types/KeySource.hs

@@ -12,9 +12,12 @@ module Types.KeySource where
  -
  - The contentLocation may be different from the filename
  - associated with the key. For example, the add command
- - temporarily puts the content into a lockdown directory
+ - may temporarily hard link the content into a lockdown directory
  - for checking. The migrate command uses the content
- - of a different Key. -}
+ - of a different Key.
+ -
+ - 
+ -}
 data KeySource = KeySource
 	{ keyFilename :: FilePath
 	, contentLocation :: FilePath

debian/changelog

@@ -4,6 +4,10 @@ git-annex (3.20130208) UNRELEASED; urgency=low
   * Now uses the Haskell Glob library, rather than pcre-light, avoiding
     the need to install libpcre. Currently done only for Cabal or when
     the Makefile is made to use -DWITH_GLOB
+  * init: Detect when the repository is on a filesystem that does not
+    support hard links, or symlinks, or unix permissions, and set
+    annex.crippledfilesystem, as well as annex.direct. This allows
+    use of git-annex repositories on FAT and even worse filesystems.
 
  -- Joey Hess <joeyh@debian.org>  Sun, 10 Feb 2013 14:52:01 -0400
 

doc/git-annex.mdwn

@@ -796,16 +796,22 @@ Here are all the supported configuration settings.
   to close it. On Mac OSX, when not using direct mode this defaults to
   1 second, to work around a bad interaction with software there.
 
+* `annex.autocommit`
+
+  Set to false to prevent the git-annex assistant from automatically
+  committing changes to files in the repository.
+
 * `annex.direct`
 
   Set to true to enable an (experimental) mode where files in the repository
   are accessed directly, rather than through symlinks. Note that many git
   and git-annex commands will not work with such a repository.
 
-* `annex.autocommit`
+* `annex.crippledfilesystem`
 
-  Set to false to prevent the git-annex assistant from automatically
+  Set to true if the repository is on a crippled filesystem, such as FAT,
-  committing changes to files in the repository.
+  which does not support symbolic links, or hard links, or unix permissions.
+  This is automatically probed by "git annex init".
 
 * `remote.<name>.annex-cost`