diff options
| -rw-r--r-- | Annex/Environment.hs | 15 | ||||
| -rw-r--r-- | Git/CurrentRepo.hs | 10 | ||||
| -rw-r--r-- | Git/Index.hs | 4 | ||||
| -rw-r--r-- | Test.hs | 6 | ||||
| -rw-r--r-- | Utility/Env.hs | 29 | ||||
| -rw-r--r-- | Utility/Gpg.hs | 2 | ||||
| -rw-r--r-- | Utility/Lsof.hs | 2 | ||||
| -rw-r--r-- | debian/changelog | 4 | ||||
| -rw-r--r-- | doc/todo/windows_support.mdwn | 4 | ||||
| -rw-r--r-- | git-annex.cabal | 2 | ||||
| -rw-r--r-- | git-annex.hs | 39 |
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 @@ -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 |