Improve detection of inability to check free disk space.

Don't check if configure indicated checks won't work. This should fix a
FTBFS on mipsel, where configure correctly detects the checks won't work,
while garbage is returned for disk space info at git-annex runtime. It also
means that, when built via cabal, disk space checks are not enabled,
unfortunatly.

Annex/Content.hs

@@ -45,6 +45,7 @@ import Utility.DataUnits
 import Utility.CopyFile
 import Config
 import Annex.Exception
+import qualified Build.SysConfig
 
 {- Checks if a given key's content is currently present. -}
 inAnnex :: Key -> Annex Bool
@@ -178,13 +179,14 @@ checkDiskSpace' :: Integer -> Key -> Annex ()
 checkDiskSpace' adjustment key = do
 	g <- gitRepo
 	r <- getConfig g "diskreserve" ""
+	sanitycheck r
 	let reserve = fromMaybe megabyte $ readSize dataUnits r
 	stats <- liftIO $ getFileSystemStats (gitAnnexDir g)
-	sanitycheck r stats
+	case (cancheck, stats, keySize key) of
-	case (stats, keySize key) of
+		(False, _, _) -> return ()
-		(Nothing, _) -> return ()
+		(_, Nothing, _) -> return ()
-		(_, Nothing) -> return ()
+		(_, _, Nothing) -> return ()
-		(Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) ->
+		(_, Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) ->
 			when (need + reserve > have + adjustment) $
 				needmorespace (need + reserve - have - adjustment)
 	where
@@ -195,8 +197,8 @@ checkDiskSpace' adjustment key = do
 				roughSize storageUnits True n ++
 				" more" ++ forcemsg
 		forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
-		sanitycheck r stats
+		sanitycheck r
-			| not (null r) && isNothing stats = do
+			| not (null r) && not cancheck = do
 				unlessM (Annex.getState Annex.force) $
 					error $ "You have configured a diskreserve of "
 						++ r ++
@@ -204,6 +206,7 @@ checkDiskSpace' adjustment key = do
 						++ forcemsg
 				return ()
 			| otherwise = return ()
+		cancheck = Build.SysConfig.statfs_sanity_checked == Just True
 
 {- Moves a file into .git/annex/objects/
  -

Build/Configure.hs

@@ -10,8 +10,12 @@ import Control.Applicative
 import Build.TestConfig
 import Utility.SafeCommand
 
-tests :: [TestCase]
+tests :: Bool -> [TestCase]
-tests =
+tests True = cabaltests ++ common
+tests False = common
+
+common :: [TestCase]
+common =
 	[ TestCase "version" getVersion
 	, TestCase "git" $ requireCmd "git" "git --version >/dev/null"
 	, TestCase "git version" getGitVersion
@@ -28,6 +32,11 @@ tests =
 	, TestCase "ssh connection caching" getSshConnectionCaching
 	] ++ shaTestCases [1, 256, 512, 224, 384]
 
+cabaltests :: [TestCase]
+cabaltests =
+	[ TestCase "StatFS" testStatFSDummy
+	]
+
 shaTestCases :: [Int] -> [TestCase]
 shaTestCases l = map make l
 	where make n =
@@ -72,6 +81,10 @@ getSshConnectionCaching :: Test
 getSshConnectionCaching = Config "sshconnectioncaching" . BoolConfig <$>
 	boolSystem "sh" [Param "-c", Param "ssh -o ControlPersist=yes -V >/dev/null 2>/dev/null"]
 
+testStatFSDummy :: Test
+testStatFSDummy = 
+	return $ Config "statfs_sanity_checked" $ MaybeBoolConfig Nothing
+
 {- Set up cabal file with version. -}
 cabalSetup :: IO ()
 cabalSetup = do

Build/TestConfig.hs

@@ -10,7 +10,8 @@ type ConfigKey = String
 data ConfigValue =
 	BoolConfig Bool |
 	StringConfig String |
-	MaybeStringConfig (Maybe String)
+	MaybeStringConfig (Maybe String) |
+	MaybeBoolConfig (Maybe Bool)
 data Config = Config ConfigKey ConfigValue
 
 type Test = IO Config
@@ -21,6 +22,7 @@ instance Show ConfigValue where
 	show (BoolConfig b) = show b
 	show (StringConfig s) = show s
 	show (MaybeStringConfig s) = show s
+	show (MaybeBoolConfig s) = show s
 
 instance Show Config where
 	show (Config key value) = unlines
@@ -31,6 +33,7 @@ instance Show Config where
 			valuetype (BoolConfig _) = "Bool"
 			valuetype (StringConfig _) = "String"
 			valuetype (MaybeStringConfig _) = "Maybe String"
+			valuetype (MaybeBoolConfig _) = "Maybe Bool"
 
 writeSysConfig :: [Config] -> IO ()
 writeSysConfig config = writeFile "Build/SysConfig.hs" body
@@ -109,6 +112,9 @@ testEnd (Config _ (BoolConfig False)) = status "no"
 testEnd (Config _ (StringConfig s)) = status s
 testEnd (Config _ (MaybeStringConfig (Just s))) = status s
 testEnd (Config _ (MaybeStringConfig Nothing)) = status "not available"
+testEnd (Config _ (MaybeBoolConfig (Just True))) = status "yes"
+testEnd (Config _ (MaybeBoolConfig (Just False))) = status "no"
+testEnd (Config _ (MaybeBoolConfig Nothing)) = status "unknown"
 
 status :: String -> IO ()
 status s = putStrLn $ ' ':s

Setup.hs

@@ -8,5 +8,5 @@ import qualified Build.Configure as Configure
 main = defaultMainWithHooks simpleUserHooks { preConf = configure }
 
 configure _ _ = do
-	Configure.run Configure.tests
+	Configure.run $ Configure.tests True
 	return (Nothing, [])

configure.hs

@@ -8,14 +8,16 @@ import Utility.StatFS
 
 tests :: [TestCase]
 tests = [ TestCase "StatFS" testStatFS
-	] ++ Configure.tests
+	] ++ Configure.tests False
 
 {- This test cannot be included in Build.Configure due to needing
- - Utility/StatFS.hs to be built. -}
+ - Utility/StatFS.hs to be built, which it is not when "cabal configure"
+ - is run. -}
 testStatFS :: Test
 testStatFS = do
 	s <- getFileSystemStats "."
-	return $ Config "statfs_sane" $ BoolConfig $ isJust s
+	return $ Config "statfs_sanity_checked" $
+		MaybeBoolConfig $ Just $ isJust s
 
 main :: IO ()
 main = Configure.run tests

debian/changelog

@@ -1,3 +1,9 @@
+git-annex (3.20120316) UNRELEASED; urgency=low
+
+  * Improve detection of inability to check free disk space.
+
+ -- Joey Hess <joeyh@debian.org>  Wed, 21 Mar 2012 21:19:16 -0400
+
 git-annex (3.20120315) unstable; urgency=low
 
   * fsck: Fix up any broken links and misplaced content caused by the