From 063a183a61cc6244d9c4f7673aebafd9c7445c7b Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 10 Dec 2013 01:18:04 -0400
Subject: [PATCH] windows disk free space checking

---
 Assistant/WebApp/Configurators/Local.hs | 19 ++++++++-----------
 Utility/DiskFree.hs                     | 10 ++++++++++
 debian/changelog                        |  1 +
 git-annex.cabal                         |  4 +++-
 4 files changed, 22 insertions(+), 12 deletions(-)

diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index b4de972d62..74cb80374c 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -351,20 +351,11 @@ driveList :: IO [RemovableDrive]
 #ifdef mingw32_HOST_OS
 -- Just enumerate all likely drive letters for Windows.
 -- Could use wmic, but it only works for administrators.
-driveList = return $ map (\l -> gen $ l:":\\") ['A'..'Z']
-  where
-	gen dir = RemovableDrive
-		Nothing
-		(T.pack dir)
-		(T.pack gitAnnexAssistantDefaultDir)
+driveList = mapM (\d -> genRemovableDrive $ d:":\\") ['A'..'Z']
 #else
 #ifdef WITH_CLIBS
-driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
+driveList = mapM (genRemovableDrive . mnt_dir) =<< filter sane <$> getMounts
   where
-	gen dir = RemovableDrive
-		<$> getDiskFree dir
-		<*> pure (T.pack dir)
-		<*> pure (T.pack gitAnnexAssistantDefaultDir)
 	-- filter out some things that are surely not removable drives
 	sane Mntent { mnt_dir = dir, mnt_fsname = dev }
 		{- We want real disks like /dev/foo, not
@@ -387,6 +378,12 @@ driveList = return []
 #endif
 #endif
 
+genRemovableDrive :: FilePath -> IO RemovableDrive
+genRemovableDrive dir = RemovableDrive
+	<$> getDiskFree dir
+	<*> pure (T.pack dir)
+	<*> pure (T.pack gitAnnexAssistantDefaultDir)
+
 {- Bootstraps from first run mode to a fully running assistant in a
  - repository, by running the postFirstRun callback, which returns the
  - url to the new webapp. -}
diff --git a/Utility/DiskFree.hs b/Utility/DiskFree.hs
index aa1bfeedb3..1f23ff5126 100644
--- a/Utility/DiskFree.hs
+++ b/Utility/DiskFree.hs
@@ -31,8 +31,18 @@ getDiskFree path = withFilePath path $ \c_path -> do
 	safeErrno (Errno v) = v == 0
 
 #else
+#ifdef mingw32_HOST_OS
+
+import System.Win32.File
+
+getDiskFree :: FilePath -> IO (Maybe Integer)
+getDiskFree path = catchMaybeIO $ do
+	(sectors, bytes, nfree, _ntotal) <- getDiskFreeSpace (Just path)
+	return $ toInteger sectors * toInteger bytes * toInteger nfree
+#else
 
 getDiskFree :: FilePath -> IO (Maybe Integer)
 getDiskFree _ = return Nothing
 
 #endif
+#endif
diff --git a/debian/changelog b/debian/changelog
index a51f2b6645..f931bdd947 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -19,6 +19,7 @@ git-annex (5.20131131) UNRELEASED; urgency=low
   * import: better handling of overwriting an existing file/directory/broken
     link when importing
   * Windows: assistant and webapp work! (very experimental)
+  * Windows: Support annex.diskreserve.
   * Fix bad behavior in Firefox, which was caused by an earlier fix to
     bad behavior in Chromium.
 
diff --git a/git-annex.cabal b/git-annex.cabal
index b4b3d209dc..789ded518c 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -100,7 +100,9 @@ Executable git-annex
   if flag(Production)
     GHC-Options: -O2
 
-  if (! os(windows))
+  if (os(windows))
+    Build-Depends: Win32
+  else
     Build-Depends: unix
     -- Need to list these because they're generated from .hsc files.
     Other-Modules: Utility.Touch Utility.Mounts