Rewrote free disk space checking code

Moving the portability handling into a small C library cleans up things
a lot, avoiding the pain of unpacking structs from inside haskell code.

Annex/Content.hs

@@ -36,7 +36,7 @@ import qualified Git
 import qualified Annex
 import qualified Annex.Queue
 import qualified Annex.Branch
-import Utility.StatFS
+import Utility.DiskFree
 import Utility.FileMode
 import qualified Utility.Url as Url
 import Types.Key
@@ -44,7 +44,6 @@ 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
@@ -176,22 +175,19 @@ checkDiskSpace = checkDiskSpace' 0
 
 checkDiskSpace' :: Integer -> Key -> Annex ()
 checkDiskSpace' adjustment key = do
-	reserve <- getDiskReserve True
-	stats <- inRepo $ getFileSystemStats .gitAnnexDir
-	case (cancheck, stats, keySize key) of
-		(False, _, _) -> return ()
-		(_, Nothing, _) -> return ()
-		(_, _, Nothing) -> return ()
-		(_, Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) ->
+	reserve <- getDiskReserve
+	free <- inRepo $ getDiskFree . gitAnnexDir
+	case (free, keySize key) of
+		(Just have, Just need) ->
 			when (need + reserve > have + adjustment) $
 				needmorespace (need + reserve - have - adjustment)
+		_ -> return ()
 	where
 		needmorespace n = unlessM (Annex.getState Annex.force) $
 			error $ "not enough free space, need " ++ 
 				roughSize storageUnits True n ++
 				" more" ++ forcemsg
 		forcemsg = " (use --force to override this check or adjust annex.diskreserve)"
-		cancheck = Build.SysConfig.statfs_sanity_checked == Just True
 
 {- Moves a file into .git/annex/objects/
  -

Build/Configure.hs

@@ -10,12 +10,8 @@ import Control.Applicative
 import Build.TestConfig
 import Utility.SafeCommand
 
-tests :: Bool -> [TestCase]
-tests True = cabaltests ++ common
-tests False = common
-
-common :: [TestCase]
-common =
+tests :: [TestCase]
+tests =
 	[ TestCase "version" getVersion
 	, TestCase "git" $ requireCmd "git" "git --version >/dev/null"
 	, TestCase "git version" getGitVersion
@@ -32,11 +28,6 @@ common =
 	, 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 =
@@ -81,10 +72,6 @@ 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

Command/Status.hs

@@ -22,7 +22,7 @@ import qualified Git
 import qualified Annex
 import Command
 import Utility.DataUnits
-import Utility.StatFS
+import Utility.DiskFree
 import Annex.Content
 import Types.Key
 import Backend
@@ -30,7 +30,6 @@ import Logs.UUID
 import Logs.Trust
 import Remote
 import Config
-import qualified Build.SysConfig
 
 -- a named computation that produces a statistic
 type Stat = StatState (Maybe (String, StatState String))
@@ -173,19 +172,16 @@ bloom_info = stat "bloom filter size" $ json id $ do
 
 disk_size :: Stat
 disk_size = stat "available local disk space" $ json id $ lift $
-	if Build.SysConfig.statfs_sanity_checked == Just True
-		then calcfree
-			<$> getDiskReserve False
-			<*> inRepo (getFileSystemStats . gitAnnexDir)
-		else return unknown
+	calcfree
+		<$> getDiskReserve
+		<*> inRepo (getDiskFree . gitAnnexDir)
 	where
-		calcfree reserve (Just (FileSystemStats { fsStatBytesAvailable = have })) =
+		calcfree reserve (Just have) =
 			roughSize storageUnits True $ nonneg $ have - reserve
-		calcfree _ _ = unknown
+		calcfree _ _ = "unknown"
 		nonneg x
 			| x >= 0 = x
 			| otherwise = 0
-		unknown = "unknown"
 
 backend_usage :: Stat
 backend_usage = stat "backend usage" $ nojson $

Config.hs

@@ -12,7 +12,6 @@ import qualified Git
 import qualified Git.Config
 import qualified Git.Command
 import qualified Annex
-import qualified Build.SysConfig
 import Utility.DataUnits
 
 type ConfigKey = String
@@ -92,19 +91,8 @@ getTrustLevel :: Git.Repo -> Annex (Maybe String)
 getTrustLevel r = fromRepo $ Git.Config.getMaybe $ remoteConfig r "trustlevel"
 
 {- Gets annex.diskreserve setting. -}
-getDiskReserve :: Bool -> Annex Integer
-getDiskReserve sanitycheck = do
-	r <- getConfig "diskreserve" ""
-	when sanitycheck $ check r
-	return $ fromMaybe megabyte $ readSize dataUnits r
+getDiskReserve :: Annex Integer
+getDiskReserve = fromMaybe megabyte . readSize dataUnits
+	<$> getConfig "diskreserve" ""
 	where
 		megabyte = 1000000
-		check r
-			| not (null r) && not cancheck = do
-				unlessM (Annex.getState Annex.force) $
-					error $ "You have configured a diskreserve of "
-						++ r ++
-						" but disk space checking is not working"
-				return ()
-			| otherwise = return ()
-		cancheck = Build.SysConfig.statfs_sanity_checked == Just True

Makefile

@@ -1,6 +1,6 @@
 PREFIX=/usr
 IGNORE=-ignore-package monads-fd
-BASEFLAGS=-Wall $(IGNORE) -outputdir tmp
+BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility
 GHCFLAGS=-O2 $(BASEFLAGS)
 
 ifdef PROFILE
@@ -11,7 +11,8 @@ GHCMAKE=ghc $(GHCFLAGS) --make
 
 bins=git-annex
 mans=git-annex.1 git-annex-shell.1
-sources=Build/SysConfig.hs Utility/StatFS.hs Utility/Touch.hs
+sources=Build/SysConfig.hs Utility/Touch.hs
+clibs=Utility/diskfree.o
 
 all=$(bins) $(mans) docs
 
@@ -28,15 +29,16 @@ sources: $(sources)
 fast: GHCFLAGS=$(BASEFLAGS)
 fast: $(bins)
 
-Build/SysConfig.hs: configure.hs Build/TestConfig.hs Utility/StatFS.hs
+Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs
 	$(GHCMAKE) configure
 	./configure
 
 %.hs: %.hsc
 	hsc2hs $<
 
-$(bins): $(sources)
-	$(GHCMAKE) $@
+
+git-annex: $(sources) $(clibs)
+	$(GHCMAKE) $@ $(clibs)
 
 git-annex.1: doc/git-annex.mdwn
 	./mdwn2man git-annex 1 doc/git-annex.mdwn > git-annex.1
@@ -92,7 +94,7 @@ docs: $(mans)
 
 clean:
 	rm -rf tmp $(bins) $(mans) test configure  *.tix .hpc $(sources) \
-		doc/.ikiwiki html dist
+		doc/.ikiwiki html dist $(clibs)
 
 # Workaround for cabal sdist not running Setup hooks, so I cannot
 # generate a file list there.

Utility/DiskFree.hs

@@ -0,0 +1,32 @@
+{- disk free space checking 
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Utility.DiskFree ( getDiskFree ) where
+
+import Common
+
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.C.Error
+
+foreign import ccall unsafe "diskfree.h diskfree" c_diskfree
+	:: CString -> IO CULLong
+
+getDiskFree :: String -> IO (Maybe Integer)
+getDiskFree path = withFilePath path $ \c_path -> do
+	free <- c_diskfree c_path
+	ifM (safeErrno <$> getErrno)
+		( return $ Just $ toInteger free
+		, do
+			Errno i <- getErrno
+			print i
+			return Nothing
+		)
+	where
+		safeErrno (Errno v) = v == 0

Utility/StatFS.hsc

@@ -1,128 +0,0 @@
------------------------------------------------------------------------------
--- |
---
--- (This code originally comes from xmobar)
--- 
--- Module      :  StatFS
--- Copyright   :  (c) Jose A Ortega Ruiz
--- License     :  BSD-3-clause
---
--- All rights reserved.
--- 
--- Redistribution and use in source and binary forms, with or without
--- modification, are permitted provided that the following conditions
--- are met:
--- 
--- 1. Redistributions of source code must retain the above copyright
---    notice, this list of conditions and the following disclaimer.
--- 2. Redistributions in binary form must reproduce the above copyright
---    notice, this list of conditions and the following disclaimer in the
---    documentation and/or other materials provided with the distribution.
--- 3. Neither the name of the author nor the names of his contributors
---    may be used to endorse or promote products derived from this software
---    without specific prior written permission.
--- 
--- THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
--- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
--- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
--- ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
--- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
--- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
--- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
--- SUCH DAMAGE.
---
--- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org>
--- Stability   :  unstable
--- Portability :  unportable
---
---  A binding to C's statvfs(2)
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}
-
-
-module Utility.StatFS ( FileSystemStats(..), getFileSystemStats ) where
-
-import Utility.FileSystemEncoding
-
-import Foreign
-import Foreign.C.Types
-import Foreign.C.String
-
-#if defined (__FreeBSD__) || defined (__FreeBSD_kernel__) || defined (__APPLE__)
-# include <sys/param.h>
-# include <sys/mount.h>
-#else
-#if defined (__linux__)
-#include <sys/vfs.h>
-#else
-#define UNKNOWN
-#endif
-#endif
-
-data FileSystemStats = FileSystemStats {
-  fsStatBlockSize :: Integer
-  -- ^ Optimal transfer block size.
-  , fsStatBlockCount :: Integer
-  -- ^ Total data blocks in file system.
-  , fsStatByteCount :: Integer
-  -- ^ Total bytes in file system.
-  , fsStatBytesFree :: Integer
-  -- ^ Free bytes in file system.
-  , fsStatBytesAvailable :: Integer
-  -- ^ Free bytes available to non-superusers.
-  , fsStatBytesUsed :: Integer
-  -- ^ Bytes used.
-  } deriving (Show, Eq)
-
-data CStatfs
-
-#ifdef UNKNOWN
-#warning free space checking code not available for this OS
-#else
-#if defined(__APPLE__)
-foreign import ccall unsafe "sys/mount.h statfs64"
-#else
-#if defined(__FreeBSD__) || defined (__FreeBSD_kernel__)
-foreign import ccall unsafe "sys/mount.h statfs"
-#else
-foreign import ccall unsafe "sys/vfs.h statfs64"
-#endif
-#endif
-  c_statfs :: CString -> Ptr CStatfs -> IO CInt
-#endif
-
-toI :: CULong -> Integer
-toI = toInteger
-
-getFileSystemStats :: String -> IO (Maybe FileSystemStats)
-getFileSystemStats path =
-#ifdef UNKNOWN
-  return Nothing
-#else
-  allocaBytes (#size struct statfs) $ \vfs ->
-  withFilePath path $ \cpath -> do
-    res <- c_statfs cpath vfs
-    if res == -1 then return Nothing
-      else do
-        bsize <- (#peek struct statfs, f_bsize) vfs
-        bcount <- (#peek struct statfs, f_blocks) vfs
-        bfree <- (#peek struct statfs, f_bfree) vfs
-        bavail <- (#peek struct statfs, f_bavail) vfs
-        let bpb = toI bsize
-        let stats = FileSystemStats
-                       { fsStatBlockSize = bpb
-                       , fsStatBlockCount = toI bcount
-                       , fsStatByteCount = toI bcount * bpb
-                       , fsStatBytesFree = toI bfree * bpb
-                       , fsStatBytesAvailable = toI bavail * bpb
-                       , fsStatBytesUsed = toI (bcount - bfree) * bpb
-                       }
-        if fsStatBlockCount stats == 0 || fsStatBlockSize stats == 0
-          then return Nothing
-          else return $ Just stats
-#endif

Utility/diskfree.c

@@ -0,0 +1,61 @@
+/* disk free space checking, C mini-library
+ *
+ * Copyright 2012 Joey Hess <joey@kitenet.net>
+ *
+ * Licensed under the GNU GPL version 3 or higher.
+ */
+
+/* Include appropriate headers for the OS, and define what will be used to
+ * check the free space. */
+#if defined(__APPLE__)
+# include <sys/param.h>
+# include <sys/mount.h>
+# define STATSTRUCT statfs
+# define STATCALL statfs64
+#else
+#if defined (__FreeBSD__) || defined (__FreeBSD_kernel__)
+# include <sys/param.h>
+# include <sys/mount.h>
+# define STATSTRUCT statfs
+# define STATCALL statfs
+#else
+#if defined (__linux__)
+# include <sys/statvfs.h>
+# define STATSTRUCT statvfs
+# define STATCALL statvfs
+#else
+# warning free space checking code not available for this OS
+# define UNKNOWN
+#endif
+#endif
+#endif
+
+#include <errno.h>
+
+/* Checks the amount of disk that is available to regular (non-root) users.
+ * (If there's an error, or this is not supported,
+ * returns 0 and sets errno to nonzero.)
+ */
+unsigned long long int diskfree(const char *path) {
+#ifdef UNKNOWN
+	errno = 1;
+	return 0;
+#else
+	unsigned long long int available, blocksize;
+	struct STATSTRUCT buf;
+
+	errno = 0;
+	if (STATCALL(path, &buf) != 0)
+		return 0; /* errno is set */
+
+	available = buf.f_bavail;
+	blocksize = buf.f_bsize;
+	return available * blocksize;
+#endif
+}
+
+/*
+main () {
+	printf("%lli\n", diskfree("."));
+}
+*/

Utility/diskfree.h

@@ -0,0 +1 @@
+unsigned long long int diskfree(const char *path);

configure.hs

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

debian/changelog

@@ -1,8 +1,7 @@
 git-annex (3.20120316) UNRELEASED; urgency=low
 
-  * Improve detection of inability to check free disk space.
-  * status: Prints available local disk space, or shows if git-annex
-    doesn't know.
+  * Rewrote free disk space checking code, moving the portability
+    handling into a small C library.
 
  -- Joey Hess <joeyh@debian.org>  Wed, 21 Mar 2012 21:19:16 -0400
 

debian/copyright

@@ -7,33 +7,3 @@ License: GPL-3+
  The full text of version 3 of the GPL is distributed as doc/GPL in
  this package's source, or in /usr/share/common-licenses/GPL-3 on
  Debian systems.
-
-Files: Utility/StatFS.hsc
-Copyright: Jose A Ortega Ruiz <jao@gnu.org>
-License: BSD-3-clause
- -- All rights reserved.
- -- 
- -- Redistribution and use in source and binary forms, with or without
- -- modification, are permitted provided that the following conditions
- -- are met:
- -- 
- -- 1. Redistributions of source code must retain the above copyright
- --    notice, this list of conditions and the following disclaimer.
- -- 2. Redistributions in binary form must reproduce the above copyright
- --    notice, this list of conditions and the following disclaimer in the
- --    documentation and/or other materials provided with the distribution.
- -- 3. Neither the name of the author nor the names of his contributors
- --    may be used to endorse or promote products derived from this software
- --    without specific prior written permission.
- -- 
- -- THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
- -- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- -- ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
- -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- -- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- -- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- -- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- -- SUCH DAMAGE.

git-annex.cabal

@@ -1,5 +1,5 @@
 Name: git-annex
-Version: 3.20120315
+Version: 3.20120316
 Cabal-Version: >= 1.6
 License: GPL
 Maintainer: Joey Hess <joey@kitenet.net>