Use haskell setenv library to clean up several ugly workarounds for inability to manipulate the environment on windows.

Didn't know that this library existed!

This includes making git-annex not re-exec itself on start on windows, and
making the test suite on Windows run tests without forking.

11 files changed, 39 insertions, 78 deletions

diff --git a/Annex/Environment.hs b/Annex/Environment.hs
index b1b5e96e9..a580c0ed1 100644
--- a/Annex/Environment.hs
+++ b/Annex/Environment.hs
@@ -35,24 +35,19 @@ checkEnvironment = do
 		liftIO checkEnvironmentIO
 
 checkEnvironmentIO :: IO ()
-checkEnvironmentIO =
-#ifdef mingw32_HOST_OS
-	noop
-#else
-	whenM (null <$> myUserGecos) $ do
-		username <- myUserName
-		ensureEnv "GIT_AUTHOR_NAME" username
-		ensureEnv "GIT_COMMITTER_NAME" username
+checkEnvironmentIO = whenM (null <$> myUserGecos) $ do
+	username <- myUserName
+	ensureEnv "GIT_AUTHOR_NAME" username
+	ensureEnv "GIT_COMMITTER_NAME" username
   where
 #ifndef __ANDROID__
 	-- existing environment is not overwritten
-	ensureEnv var val = void $ setEnv var val False
+	ensureEnv var val = setEnv var val False
 #else
 	-- Environment setting is broken on Android, so this is dealt with
 	-- in runshell instead.
 	ensureEnv _ _ = noop
 #endif
-#endif
 
 {- Runs an action that commits to the repository, and if it fails, 
  - sets user.email and user.name to a dummy value and tries the action again. -}
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index 23ebbbcad..f611f7a34 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -5,17 +5,13 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-{-# LANGUAGE CPP #-}
-
 module Git.CurrentRepo where
 
 import Common
 import Git.Types
 import Git.Construct
 import qualified Git.Config
-#ifndef mingw32_HOST_OS
 import Utility.Env
-#endif
 
 {- Gets the current git repository.
  -
@@ -42,17 +38,13 @@ get = do
 				setCurrentDirectory d
 			return $ addworktree wt r
   where
-#ifndef mingw32_HOST_OS
 	pathenv s = do
 		v <- getEnv s
 		case v of
 			Just d -> do
-				void $ unsetEnv s
+				unsetEnv s
 				Just <$> absPath d
 			Nothing -> return Nothing
-#else
-	pathenv _ = return Nothing
-#endif
 
 	configure Nothing (Just r) = Git.Config.read r
 	configure (Just d) _ = do
diff --git a/Git/Index.hs b/Git/Index.hs
index d712245a8..c42ac42f8 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -21,8 +21,8 @@ import Utility.Env
 override :: FilePath -> IO (IO ())
 override index = do
 	res <- getEnv var
-	void $ setEnv var index True
-	return $ void $ reset res
+	setEnv var index True
+	return $ reset res
   where
 	var = "GIT_INDEX_FILE"
 	reset (Just v) = setEnv var v True
diff --git a/Test.hs b/Test.hs
index 5a12c11f1..298730fa5 100644
--- a/Test.hs
+++ b/Test.hs
@@ -1346,7 +1346,6 @@ test_add_subdirs testenv = intmpclonerepo testenv $ do
 -- (when the OS allows) so test coverage collection works.
 git_annex :: TestEnv -> String -> [String] -> IO Bool
 git_annex testenv command params = do
-#ifndef mingw32_HOST_OS
 	forM_ (M.toList testenv) $ \(var, val) ->
 		Utility.Env.setEnv var val True
 
@@ -1357,11 +1356,6 @@ git_annex testenv command params = do
 		Left _ -> return False
   where
 	run = GitAnnex.run (command:"-q":params)
-#else
-	Utility.SafeCommand.boolSystemEnv "git-annex"
-		(map Param $ command : params)
-		(Just $ M.toList testenv)
-#endif
 
 {- Runs git-annex and returns its output. -}
 git_annex_output :: TestEnv -> String -> [String] -> IO String
diff --git a/Utility/Env.hs b/Utility/Env.hs
index 6763c24e1..bfb61aa8d 100644
--- a/Utility/Env.hs
+++ b/Utility/Env.hs
@@ -14,6 +14,7 @@ import Utility.Exception
 import Control.Applicative
 import Data.Maybe
 import qualified System.Environment as E
+import qualified System.SetEnv
 #else
 import qualified System.Posix.Env as PE
 #endif
@@ -39,27 +40,27 @@ getEnvironment = PE.getEnvironment
 getEnvironment = E.getEnvironment
 #endif
 
-{- Returns True if it could successfully set the environment variable.
+{- Sets an environment variable. To overwrite an existing variable,
+ - overwrite must be True.
  -
- - There is, apparently, no way to do this in Windows. Instead,
- - environment varuables must be provided when running a new process. -}
-setEnv :: String -> String -> Bool -> IO Bool
+ - On Windows, setting a variable to "" unsets it. -}
+setEnv :: String -> String -> Bool -> IO ()
 #ifndef mingw32_HOST_OS
-setEnv var val overwrite = do
-	PE.setEnv var val overwrite
-	return True
+setEnv var val overwrite = PE.setEnv var val overwrite
 #else
-setEnv _ _ _ = return False
+setEnv var val True = System.Setenv.setEnv var val
+setEnv var val False = do
+	r <- getEnv var
+	case r of
+		Nothing -> setEnv var val True
+		Just _ -> return True
 #endif
 
-{- Returns True if it could successfully unset the environment variable. -}
-unsetEnv :: String -> IO Bool
+unsetEnv :: String -> IO ()
 #ifndef mingw32_HOST_OS
-unsetEnv var = do
-	PE.unsetEnv var
-	return True
+unsetEnv = PE.unsetEnv
 #else
-unsetEnv _ = return False
+unsetEnv = System.Setenv.unsetEnv
 #endif
 
 {- Adds the environment variable to the input environment. If already
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index f880e55fa..50f78a1de 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -334,7 +334,7 @@ testHarness a = do
 	setup = do
 		base <- getTemporaryDirectory
 		dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
-		void $ setEnv var dir True
+		setEnv var dir True
 		-- For some reason, recent gpg needs a trustdb to be set up.
 		_ <- pipeStrict [Params "--trust-model auto --update-trustdb"] []
 		_ <- pipeStrict [Params "--import -q"] $ unlines
diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs
index ee4036b16..e44d13197 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -32,7 +32,7 @@ setup = do
 	when (isAbsolute cmd) $ do
 		path <- getSearchPath
 		let path' = takeDirectory cmd : path
-		void $ setEnv "PATH" (intercalate [searchPathSeparator] path') True
+		setEnv "PATH" (intercalate [searchPathSeparator] path') True
 
 {- Checks each of the files in a directory to find open files.
  - Note that this will find hard links to files elsewhere that are open. -}
diff --git a/debian/changelog b/debian/changelog
index 4fafd331a..f00faf46d 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -6,6 +6,10 @@ git-annex (5.20141014) UNRELEASED; urgency=medium
     it.
   * initremote: Don't allow creating a special remote that has the same
     name as an existing git remote.
+  * Windows: Use haskell setenv library to clean up several ugly workarounds
+    for inability to manipulate the environment on windows. This includes
+    making git-annex not re-exec itself on start on windows, and making the
+    test suite on Windows run tests without forking.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 14 Oct 2014 14:09:24 -0400
 
diff --git a/doc/todo/windows_support.mdwn b/doc/todo/windows_support.mdwn
index 7e8ff4476..a48fcbc4e 100644
--- a/doc/todo/windows_support.mdwn
+++ b/doc/todo/windows_support.mdwn
@@ -19,10 +19,6 @@ usable!
 * Deleting a git repository from inside the webapp fails "RemoveDirectory
   permision denied ... file is being used by another process"
 
-* There are a lot of hacks to avoid setting environment on windows, 
-  because I didn't know about <https://hackage.haskell.org/package/setenv>.
-  Those hacks should be removed!
-
 ## potential encoding problems
 
 [[bugs/Unicode_file_names_ignored_on_Windows]] is fixed, but some potential
diff --git a/git-annex.cabal b/git-annex.cabal
index 4e13326c2..270e1b74a 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -125,7 +125,7 @@ Executable git-annex
     GHC-Options: -O2
 
   if (os(windows))
-    Build-Depends: Win32, Win32-extras, unix-compat (>= 0.4.1.3)
+    Build-Depends: Win32, Win32-extras, unix-compat (>= 0.4.1.3), setenv
     C-Sources: Utility/winprocess.c
   else
     Build-Depends: unix
diff --git a/git-annex.hs b/git-annex.hs
index f1af0eea5..f2005e13e 100644
--- a/git-annex.hs
+++ b/git-annex.hs
@@ -19,9 +19,6 @@ import qualified Test
 #ifdef mingw32_HOST_OS
 import Utility.UserInfo
 import Utility.Env
-import Config.Files
-import System.Process
-import System.Exit
 #endif
 
 main :: IO ()
@@ -33,7 +30,9 @@ main = do
 		| isshell n = CmdLine.GitAnnexShell.run ps
 		| otherwise =
 #ifdef mingw32_HOST_OS
-			winEnv gitannex ps
+			do
+				winEnv
+				gitannex ps
 #else
 			gitannex ps
 #endif
@@ -49,37 +48,17 @@ main = do
 
 #ifdef mingw32_HOST_OS
 {- On Windows, if HOME is not set, probe it and set it.
- - This is a workaround for some Cygwin commands needing HOME to be set,
- - and for there being no known way to set environment variables on
- - Windows, except by passing an environment in each call to a program.
- - While ugly, this workaround is easier than trying to ensure HOME is set
- - in all calls to the affected programs.
+ - This is a workaround for some Cygwin commands needing HOME to be set.
  -
  - If TZ is set, unset it.
  - TZ being set can interfere with workarounds for Windows timezone
  - horribleness, and prevents getCurrentTimeZone from seeing the system
  - time zone.
- -
- - Due to Windows limitations, have to re-exec git-annex with the new
- - environment.
  -}
-winEnv :: ([String] -> IO ()) -> [String] -> IO ()
-winEnv a ps = do
-	e <- getEnvironment
+winEnv :: IO ()
+winEnv = do
 	home <- myHomeDir
-	let e' = wantedenv e home
-	if (e' /= e)
-		then do
-			cmd <- readProgramFile
-			(_, _, _, pid) <- createProcess (proc cmd ps)
-				{ env = Just e' }
-			exitWith =<< waitForProcess pid		
-		else a ps
-  where
-	wantedenv e home = delEntry "TZ" $ case lookup "HOME" e of
-		Nothing -> e 
-		Just _ -> addEntries
-			[ ("HOME", home)
-			, ("CYGWIN", "nodosfilewarning")
-			] e
+	setEnv "HOME" home False
+	setEnv "CYGWIN" "nodosfilewarning" True
+	unsetEnv "TZ"
 #endif