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.

3 files changed, 28 insertions, 21 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 8be2cf008..0a66d9912 100644
--- a/Annex/Content.hs
+++ b/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
-		void $ catchMaybeIO $ do
-			allowWrite dir
-			removeDirectoryRecursive dir
-		removeparents dir (2 :: Int)
+	let dir = parentDir file
+	unlessM crippledFileSystem $
+		void $ liftIO $ catchMaybeIO $ allowWrite dir
+	void $ liftIO $ catchMaybeIO $ do
+		removeDirectoryRecursive dir
+	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
-			allowWrite $ parentDir file
-			removeFile file
+		unlessM crippledFileSystem $
+			liftIO $ allowWrite $ parentDir 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
-		allowWrite (parentDir src)
-		moveFile src dest
+	unlessM crippledFileSystem $
+		liftIO $ allowWrite (parentDir src)
+	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
diff --git a/Annex/Direct.hs b/Annex/Direct.hs
index 648bb7518..b33fef8bc 100644
--- a/Annex/Direct.hs
+++ b/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. -}
diff --git a/Annex/Perms.hs b/Annex/Perms.hs
index 27804ad3d..b1bac5e23 100644
--- a/Annex/Perms.hs
+++ b/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