aboutsummaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2017-12-31 16:08:31 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2017-12-31 16:36:39 -0400
commit8f3134e5408ea1ea6207028ae17f2b5fb84e0c65 (patch)
tree99739954cd6b8a3c229a230f005d69f6ed74fb8c /Utility
parent6f83a6c8f45d7aa325d315654c4fd28de9feb4a6 (diff)
finally really add back custom-setup stanza
Fourth or fifth try at this and finally found a way to make it work. Absurd amount of busy-work forced on me by change in cabal's behavior. Split up Utility modules that need posix stuff out of ones used by Setup. Various other hacks around inability for Setup to use anything that ifdefs a use of unix. Probably lost a full day of my life to this. This is how build systems make their users hate them. Just saying.
Diffstat (limited to 'Utility')
-rw-r--r--Utility/Directory.hs93
-rw-r--r--Utility/Directory/Stream.hs113
-rw-r--r--Utility/Env.hs24
-rw-r--r--Utility/Env/Basic.hs22
-rw-r--r--Utility/Env/Set.hs40
-rw-r--r--Utility/Gpg.hs5
-rw-r--r--Utility/LogFile.hs1
-rw-r--r--Utility/Lsof.hs2
-rw-r--r--Utility/Misc.hs21
-rw-r--r--Utility/Path.hs53
-rw-r--r--Utility/Path/Max.hs40
-rw-r--r--Utility/Process.hs71
-rw-r--r--Utility/Process/Transcript.hs87
-rw-r--r--Utility/Rsync.hs30
-rw-r--r--Utility/Su.hs1
-rw-r--r--Utility/Tmp.hs51
-rw-r--r--Utility/Tmp/Dir.hs68
-rw-r--r--Utility/Url.hs2
-rw-r--r--Utility/UserInfo.hs2
19 files changed, 411 insertions, 315 deletions
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 895581dff..e2c6a9462 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -18,15 +18,11 @@ import Control.Monad
import System.FilePath
import System.PosixCompat.Files
import Control.Applicative
-import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe
import Prelude
-#ifdef mingw32_HOST_OS
-import qualified System.Win32 as Win32
-#else
-import qualified System.Posix as Posix
+#ifndef mingw32_HOST_OS
import Utility.SafeCommand
import Control.Monad.IfElse
#endif
@@ -158,90 +154,3 @@ nukeFile file = void $ tryWhenExists go
#else
go = removeFile file
#endif
-
-#ifndef mingw32_HOST_OS
-data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
-#else
-data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())
-#endif
-
-type IsOpen = MVar () -- full when the handle is open
-
-openDirectory :: FilePath -> IO DirectoryHandle
-openDirectory path = do
-#ifndef mingw32_HOST_OS
- dirp <- Posix.openDirStream path
- isopen <- newMVar ()
- return (DirectoryHandle isopen dirp)
-#else
- (h, fdat) <- Win32.findFirstFile (path </> "*")
- -- Indicate that the fdat contains a filename that readDirectory
- -- has not yet returned, by making the MVar be full.
- -- (There's always at least a "." entry.)
- alreadyhave <- newMVar ()
- isopen <- newMVar ()
- return (DirectoryHandle isopen h fdat alreadyhave)
-#endif
-
-closeDirectory :: DirectoryHandle -> IO ()
-#ifndef mingw32_HOST_OS
-closeDirectory (DirectoryHandle isopen dirp) =
- whenOpen isopen $
- Posix.closeDirStream dirp
-#else
-closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
- whenOpen isopen $ do
- _ <- tryTakeMVar alreadyhave
- Win32.findClose h
-#endif
- where
- whenOpen :: IsOpen -> IO () -> IO ()
- whenOpen mv f = do
- v <- tryTakeMVar mv
- when (isJust v) f
-
-{- |Reads the next entry from the handle. Once the end of the directory
-is reached, returns Nothing and automatically closes the handle.
--}
-readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
-#ifndef mingw32_HOST_OS
-readDirectory hdl@(DirectoryHandle _ dirp) = do
- e <- Posix.readDirStream dirp
- if null e
- then do
- closeDirectory hdl
- return Nothing
- else return (Just e)
-#else
-readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
- -- If the MVar is full, then the filename in fdat has
- -- not yet been returned. Otherwise, need to find the next
- -- file.
- r <- tryTakeMVar mv
- case r of
- Just () -> getfn
- Nothing -> do
- more <- Win32.findNextFile h fdat
- if more
- then getfn
- else do
- closeDirectory hdl
- return Nothing
- where
- getfn = do
- filename <- Win32.getFindDataFileName fdat
- return (Just filename)
-#endif
-
--- True only when directory exists and contains nothing.
--- Throws exception if directory does not exist.
-isDirectoryEmpty :: FilePath -> IO Bool
-isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
- where
- check h = do
- v <- readDirectory h
- case v of
- Nothing -> return True
- Just f
- | not (dirCruft f) -> return False
- | otherwise -> check h
diff --git a/Utility/Directory/Stream.hs b/Utility/Directory/Stream.hs
new file mode 100644
index 000000000..ac62263a8
--- /dev/null
+++ b/Utility/Directory/Stream.hs
@@ -0,0 +1,113 @@
+{- streaming directory traversal
+ -
+ - Copyright 2011-2014 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Directory.Stream where
+
+import Control.Monad
+import System.FilePath
+import Control.Concurrent
+import Data.Maybe
+import Prelude
+
+#ifdef mingw32_HOST_OS
+import qualified System.Win32 as Win32
+#else
+import qualified System.Posix as Posix
+#endif
+
+import Utility.Directory
+import Utility.Exception
+
+#ifndef mingw32_HOST_OS
+data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
+#else
+data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())
+#endif
+
+type IsOpen = MVar () -- full when the handle is open
+
+openDirectory :: FilePath -> IO DirectoryHandle
+openDirectory path = do
+#ifndef mingw32_HOST_OS
+ dirp <- Posix.openDirStream path
+ isopen <- newMVar ()
+ return (DirectoryHandle isopen dirp)
+#else
+ (h, fdat) <- Win32.findFirstFile (path </> "*")
+ -- Indicate that the fdat contains a filename that readDirectory
+ -- has not yet returned, by making the MVar be full.
+ -- (There's always at least a "." entry.)
+ alreadyhave <- newMVar ()
+ isopen <- newMVar ()
+ return (DirectoryHandle isopen h fdat alreadyhave)
+#endif
+
+closeDirectory :: DirectoryHandle -> IO ()
+#ifndef mingw32_HOST_OS
+closeDirectory (DirectoryHandle isopen dirp) =
+ whenOpen isopen $
+ Posix.closeDirStream dirp
+#else
+closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
+ whenOpen isopen $ do
+ _ <- tryTakeMVar alreadyhave
+ Win32.findClose h
+#endif
+ where
+ whenOpen :: IsOpen -> IO () -> IO ()
+ whenOpen mv f = do
+ v <- tryTakeMVar mv
+ when (isJust v) f
+
+{- |Reads the next entry from the handle. Once the end of the directory
+is reached, returns Nothing and automatically closes the handle.
+-}
+readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
+#ifndef mingw32_HOST_OS
+readDirectory hdl@(DirectoryHandle _ dirp) = do
+ e <- Posix.readDirStream dirp
+ if null e
+ then do
+ closeDirectory hdl
+ return Nothing
+ else return (Just e)
+#else
+readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
+ -- If the MVar is full, then the filename in fdat has
+ -- not yet been returned. Otherwise, need to find the next
+ -- file.
+ r <- tryTakeMVar mv
+ case r of
+ Just () -> getfn
+ Nothing -> do
+ more <- Win32.findNextFile h fdat
+ if more
+ then getfn
+ else do
+ closeDirectory hdl
+ return Nothing
+ where
+ getfn = do
+ filename <- Win32.getFindDataFileName fdat
+ return (Just filename)
+#endif
+
+-- True only when directory exists and contains nothing.
+-- Throws exception if directory does not exist.
+isDirectoryEmpty :: FilePath -> IO Bool
+isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check
+ where
+ check h = do
+ v <- readDirectory h
+ case v of
+ Nothing -> return True
+ Just f
+ | not (dirCruft f) -> return False
+ | otherwise -> check h
diff --git a/Utility/Env.hs b/Utility/Env.hs
index c56f4ec23..dfebd9868 100644
--- a/Utility/Env.hs
+++ b/Utility/Env.hs
@@ -16,7 +16,6 @@ import Control.Applicative
import Data.Maybe
import Prelude
import qualified System.Environment as E
-import qualified System.SetEnv
#else
import qualified System.Posix.Env as PE
#endif
@@ -42,29 +41,6 @@ getEnvironment = PE.getEnvironment
getEnvironment = E.getEnvironment
#endif
-{- Sets an environment variable. To overwrite an existing variable,
- - overwrite must be True.
- -
- - On Windows, setting a variable to "" unsets it. -}
-setEnv :: String -> String -> Bool -> IO ()
-#ifndef mingw32_HOST_OS
-setEnv var val overwrite = PE.setEnv var val overwrite
-#else
-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 ()
-#endif
-
-unsetEnv :: String -> IO ()
-#ifndef mingw32_HOST_OS
-unsetEnv = PE.unsetEnv
-#else
-unsetEnv = System.SetEnv.unsetEnv
-#endif
-
{- Adds the environment variable to the input environment. If already
- present in the list, removes the old value.
-
diff --git a/Utility/Env/Basic.hs b/Utility/Env/Basic.hs
new file mode 100644
index 000000000..38295bea0
--- /dev/null
+++ b/Utility/Env/Basic.hs
@@ -0,0 +1,22 @@
+{- portable environment variables, without any dependencies
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Env.Basic where
+
+import Utility.Exception
+import Control.Applicative
+import Data.Maybe
+import Prelude
+import qualified System.Environment as E
+
+getEnv :: String -> IO (Maybe String)
+getEnv = catchMaybeIO . E.getEnv
+
+getEnvDefault :: String -> String -> IO String
+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs
new file mode 100644
index 000000000..fd8d5140d
--- /dev/null
+++ b/Utility/Env/Set.hs
@@ -0,0 +1,40 @@
+{- portable environment variables
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Env.Set where
+
+#ifdef mingw32_HOST_OS
+import qualified System.Environment as E
+import qualified System.SetEnv
+#else
+import qualified System.Posix.Env as PE
+#endif
+
+{- Sets an environment variable. To overwrite an existing variable,
+ - overwrite must be True.
+ -
+ - On Windows, setting a variable to "" unsets it. -}
+setEnv :: String -> String -> Bool -> IO ()
+#ifndef mingw32_HOST_OS
+setEnv var val overwrite = PE.setEnv var val overwrite
+#else
+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 ()
+#endif
+
+unsetEnv :: String -> IO ()
+#ifndef mingw32_HOST_OS
+unsetEnv = PE.unsetEnv
+#else
+unsetEnv = System.SetEnv.unsetEnv
+#endif
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index 4af0067bb..2c643b45f 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -13,10 +13,11 @@ import Common
import qualified BuildInfo
#ifndef mingw32_HOST_OS
import System.Posix.Types
-import qualified System.Posix.IO
+import System.Posix.IO
import Utility.Env
+import Utility.Env.Set
#endif
-import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.Format (decode_c)
import Control.Concurrent
diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs
index bc6d92ca9..4e08e9b9f 100644
--- a/Utility/LogFile.hs
+++ b/Utility/LogFile.hs
@@ -13,6 +13,7 @@ import Common
#ifndef mingw32_HOST_OS
import System.Posix.Types
+import System.Posix.IO
#endif
openLog :: FilePath -> IO Handle
diff --git a/Utility/Lsof.hs b/Utility/Lsof.hs
index ab80258b7..7cab8d98a 100644
--- a/Utility/Lsof.hs
+++ b/Utility/Lsof.hs
@@ -11,7 +11,7 @@ module Utility.Lsof where
import Common
import BuildInfo
-import Utility.Env
+import Utility.Env.Set
import System.Posix.Types
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 2ae992874..48fcceb7e 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -5,7 +5,6 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Misc where
@@ -16,10 +15,6 @@ import Foreign
import Data.Char
import Data.List
import System.Exit
-#ifndef mingw32_HOST_OS
-import System.Posix.Process (getAnyProcessStatus)
-import Utility.Exception
-#endif
import Control.Applicative
import Prelude
@@ -112,22 +107,6 @@ hGetSomeString h sz = do
peekbytes :: Int -> Ptr Word8 -> IO [Word8]
peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
-{- Reaps any zombie processes that may be hanging around.
- -
- - Warning: Not thread safe. Anything that was expecting to wait
- - on a process and get back an exit status is going to be confused
- - if this reap gets there first. -}
-reapZombies :: IO ()
-#ifndef mingw32_HOST_OS
-reapZombies =
- -- throws an exception when there are no child processes
- catchDefaultIO Nothing (getAnyProcessStatus False True)
- >>= maybe (return ()) (const reapZombies)
-
-#else
-reapZombies = return ()
-#endif
-
exitBool :: Bool -> IO a
exitBool False = exitFailure
exitBool True = exitSuccess
diff --git a/Utility/Path.hs b/Utility/Path.hs
index dc91ce50c..f1302ae8c 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -5,7 +5,7 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE PackageImports, CPP #-}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Path where
@@ -17,13 +17,6 @@ import Data.Char
import Control.Applicative
import Prelude
-#ifdef mingw32_HOST_OS
-import qualified System.FilePath.Posix as Posix
-#else
-import System.Posix.Files
-import Utility.Exception
-#endif
-
import Utility.Monad
import Utility.UserInfo
import Utility.Directory
@@ -247,50 +240,6 @@ dotfile file
where
f = takeFileName file
-{- Converts a DOS style path to a msys2 style path. Only on Windows.
- - Any trailing '\' is preserved as a trailing '/'
- -
- - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
- -
- - The virtual filesystem contains:
- - /c, /d, ... mount points for Windows drives
- -}
-toMSYS2Path :: FilePath -> FilePath
-#ifndef mingw32_HOST_OS
-toMSYS2Path = id
-#else
-toMSYS2Path p
- | null drive = recombine parts
- | otherwise = recombine $ "/" : driveletter drive : parts
- where
- (drive, p') = splitDrive p
- parts = splitDirectories p'
- driveletter = map toLower . takeWhile (/= ':')
- recombine = fixtrailing . Posix.joinPath
- fixtrailing s
- | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
- | otherwise = s
-#endif
-
-{- Maximum size to use for a file in a specified directory.
- -
- - Many systems have a 255 byte limit to the name of a file,
- - so that's taken as the max if the system has a larger limit, or has no
- - limit.
- -}
-fileNameLengthLimit :: FilePath -> IO Int
-#ifdef mingw32_HOST_OS
-fileNameLengthLimit _ = return 255
-#else
-fileNameLengthLimit dir = do
- -- getPathVar can fail due to statfs(2) overflow
- l <- catchDefaultIO 0 $
- fromIntegral <$> getPathVar dir FileNameLimit
- if l <= 0
- then return 255
- else return $ minimum [l, 255]
-#endif
-
{- Given a string that we'd like to use as the basis for FilePath, but that
- was provided by a third party and is not to be trusted, returns the closest
- sane FilePath.
diff --git a/Utility/Path/Max.hs b/Utility/Path/Max.hs
new file mode 100644
index 000000000..4a810e591
--- /dev/null
+++ b/Utility/Path/Max.hs
@@ -0,0 +1,40 @@
+{- path manipulation
+ -
+ - Copyright 2010-2014 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Path.Max where
+
+import System.FilePath
+import Data.List
+import Control.Applicative
+import Prelude
+
+#ifndef mingw32_HOST_OS
+import Utility.Exception
+import System.Posix.Files
+#endif
+
+{- Maximum size to use for a file in a specified directory.
+ -
+ - Many systems have a 255 byte limit to the name of a file,
+ - so that's taken as the max if the system has a larger limit, or has no
+ - limit.
+ -}
+fileNameLengthLimit :: FilePath -> IO Int
+#ifdef mingw32_HOST_OS
+fileNameLengthLimit _ = return 255
+#else
+fileNameLengthLimit dir = do
+ -- getPathVar can fail due to statfs(2) overflow
+ l <- catchDefaultIO 0 $
+ fromIntegral <$> getPathVar dir FileNameLimit
+ if l <= 0
+ then return 255
+ else return $ minimum [l, 255]
+#endif
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 6d981cb51..ff454f799 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -24,8 +24,6 @@ module Utility.Process (
createProcessSuccess,
createProcessChecked,
createBackgroundProcess,
- processTranscript,
- processTranscript',
withHandle,
withIOHandles,
withOEHandles,
@@ -54,13 +52,6 @@ import System.Log.Logger
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
-#ifndef mingw32_HOST_OS
-import qualified System.Posix.IO
-#else
-import Control.Applicative
-#endif
-import Data.Maybe
-import Prelude
type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
@@ -170,68 +161,6 @@ createProcessChecked checker p a = do
createBackgroundProcess :: CreateProcessRunner
createBackgroundProcess p a = a =<< createProcess p
--- | Runs a process, optionally feeding it some input, and
--- returns a transcript combining its stdout and stderr, and
--- whether it succeeded or failed.
-processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
-processTranscript cmd opts = processTranscript' (proc cmd opts)
-
-processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
-processTranscript' cp input = do
-#ifndef mingw32_HOST_OS
-{- This implementation interleves stdout and stderr in exactly the order
- - the process writes them. -}
- (readf, writef) <- System.Posix.IO.createPipe
- readh <- System.Posix.IO.fdToHandle readf
- writeh <- System.Posix.IO.fdToHandle writef
- p@(_, _, _, pid) <- createProcess $ cp
- { std_in = if isJust input then CreatePipe else Inherit
- , std_out = UseHandle writeh
- , std_err = UseHandle writeh
- }
- hClose writeh
-
- get <- mkreader readh
- writeinput input p
- transcript <- get
-
- ok <- checkSuccessProcess pid
- return (transcript, ok)
-#else
-{- This implementation for Windows puts stderr after stdout. -}
- p@(_, _, _, pid) <- createProcess $ cp
- { std_in = if isJust input then CreatePipe else Inherit
- , std_out = CreatePipe
- , std_err = CreatePipe
- }
-
- getout <- mkreader (stdoutHandle p)
- geterr <- mkreader (stderrHandle p)
- writeinput input p
- transcript <- (++) <$> getout <*> geterr
-
- ok <- checkSuccessProcess pid
- return (transcript, ok)
-#endif
- where
- mkreader h = do
- s <- hGetContents h
- v <- newEmptyMVar
- void $ forkIO $ do
- void $ E.evaluate (length s)
- putMVar v ()
- return $ do
- takeMVar v
- return s
-
- writeinput (Just s) p = do
- let inh = stdinHandle p
- unless (null s) $ do
- hPutStr inh s
- hFlush inh
- hClose inh
- writeinput Nothing _ = return ()
-
-- | Runs a CreateProcessRunner, on a CreateProcess structure, that
-- is adjusted to pipe only from/to a single StdHandle, and passes
-- the resulting Handle to an action.
diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs
new file mode 100644
index 000000000..0dbe428f7
--- /dev/null
+++ b/Utility/Process/Transcript.hs
@@ -0,0 +1,87 @@
+{- Process transcript
+ -
+ - Copyright 2012-2015 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Process.Transcript where
+
+import Utility.Process
+
+import System.IO
+import Control.Concurrent
+import qualified Control.Exception as E
+import Control.Monad
+#ifndef mingw32_HOST_OS
+import qualified System.Posix.IO
+#else
+import Control.Applicative
+#endif
+import Data.Maybe
+import Prelude
+
+-- | Runs a process, optionally feeding it some input, and
+-- returns a transcript combining its stdout and stderr, and
+-- whether it succeeded or failed.
+processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
+processTranscript cmd opts = processTranscript' (proc cmd opts)
+
+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
+processTranscript' cp input = do
+#ifndef mingw32_HOST_OS
+{- This implementation interleves stdout and stderr in exactly the order
+ - the process writes them. -}
+ (readf, writef) <- System.Posix.IO.createPipe
+ readh <- System.Posix.IO.fdToHandle readf
+ writeh <- System.Posix.IO.fdToHandle writef
+ p@(_, _, _, pid) <- createProcess $ cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = UseHandle writeh
+ , std_err = UseHandle writeh
+ }
+ hClose writeh
+
+ get <- mkreader readh
+ writeinput input p
+ transcript <- get
+
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+#else
+{- This implementation for Windows puts stderr after stdout. -}
+ p@(_, _, _, pid) <- createProcess $ cp
+ { std_in = if isJust input then CreatePipe else Inherit
+ , std_out = CreatePipe
+ , std_err = CreatePipe
+ }
+
+ getout <- mkreader (stdoutHandle p)
+ geterr <- mkreader (stderrHandle p)
+ writeinput input p
+ transcript <- (++) <$> getout <*> geterr
+
+ ok <- checkSuccessProcess pid
+ return (transcript, ok)
+#endif
+ where
+ mkreader h = do
+ s <- hGetContents h
+ v <- newEmptyMVar
+ void $ forkIO $ do
+ void $ E.evaluate (length s)
+ putMVar v ()
+ return $ do
+ takeMVar v
+ return s
+
+ writeinput (Just s) p = do
+ let inh = stdinHandle p
+ unless (null s) $ do
+ hPutStr inh s
+ hFlush inh
+ hClose inh
+ writeinput Nothing _ = return ()
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index f190b40de..25af52617 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -13,6 +13,10 @@ import Common
import Utility.Metered
import Utility.Tuple
+#ifdef mingw32_HOST_OS
+import qualified System.FilePath.Posix as Posix
+#endif
+
import Data.Char
import System.Console.GetOpt
@@ -139,3 +143,29 @@ filterRsyncSafeOptions = fst3 . getOpt Permute
[ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ]
where
reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) ""
+
+{- Converts a DOS style path to a msys2 style path. Only on Windows.
+ - Any trailing '\' is preserved as a trailing '/'
+ -
+ - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
+ -
+ - The virtual filesystem contains:
+ - /c, /d, ... mount points for Windows drives
+ -}
+toMSYS2Path :: FilePath -> FilePath
+#ifndef mingw32_HOST_OS
+toMSYS2Path = id
+#else
+toMSYS2Path p
+ | null drive = recombine parts
+ | otherwise = recombine $ "/" : driveletter drive : parts
+ where
+ (drive, p') = splitDrive p
+ parts = splitDirectories p'
+ driveletter = map toLower . takeWhile (/= ':')
+ recombine = fixtrailing . Posix.joinPath
+ fixtrailing s
+ | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
+ | otherwise = s
+#endif
+
diff --git a/Utility/Su.hs b/Utility/Su.hs
index 84ea4c5da..a0500e483 100644
--- a/Utility/Su.hs
+++ b/Utility/Su.hs
@@ -13,6 +13,7 @@ import Common
#ifndef mingw32_HOST_OS
import Utility.Env
+import System.Posix.IO
import System.Posix.Terminal
#endif
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index 7255c141e..6e04b1076 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -1,4 +1,4 @@
-{- Temporary files and directories.
+{- Temporary files.
-
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
@@ -11,14 +11,10 @@
module Utility.Tmp where
import System.IO
-import Control.Monad.IfElse
import System.FilePath
import System.Directory
import Control.Monad.IO.Class
import System.PosixCompat.Files
-#ifndef mingw32_HOST_OS
-import System.Posix.Temp (mkdtemp)
-#endif
import Utility.Exception
import Utility.FileSystemEncoding
@@ -62,51 +58,6 @@ withTmpFileIn tmpdir template a = bracket create remove use
catchBoolIO (removeFile name >> return True)
use (name, h) = a name h
-{- Runs an action with a tmp directory located within the system's tmp
- - directory (or within "." if there is none), then removes the tmp
- - directory and all its contents. -}
-withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
-withTmpDir template a = do
- topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
-#ifndef mingw32_HOST_OS
- -- Use mkdtemp to create a temp directory securely in /tmp.
- bracket
- (liftIO $ mkdtemp $ topleveltmpdir </> template)
- removeTmpDir
- a
-#else
- withTmpDirIn topleveltmpdir template a
-#endif
-
-{- Runs an action with a tmp directory located within a specified directory,
- - then removes the tmp directory and all its contents. -}
-withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
-withTmpDirIn tmpdir template = bracketIO create removeTmpDir
- where
- create = do
- createDirectoryIfMissing True tmpdir
- makenewdir (tmpdir </> template) (0 :: Int)
- makenewdir t n = do
- let dir = t ++ "." ++ show n
- catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
- createDirectory dir
- return dir
-
-{- Deletes the entire contents of the the temporary directory, if it
- - exists. -}
-removeTmpDir :: MonadIO m => FilePath -> m ()
-removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
-#if mingw32_HOST_OS
- -- Windows will often refuse to delete a file
- -- after a process has just written to it and exited.
- -- Because it's crap, presumably. So, ignore failure
- -- to delete the temp directory.
- _ <- tryIO $ removeDirectoryRecursive tmpdir
- return ()
-#else
- removeDirectoryRecursive tmpdir
-#endif
-
{- It's not safe to use a FilePath of an existing file as the template
- for openTempFile, because if the FilePath is really long, the tmpfile
- will be longer, and may exceed the maximum filename length.
diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs
new file mode 100644
index 000000000..ddf6ddbde
--- /dev/null
+++ b/Utility/Tmp/Dir.hs
@@ -0,0 +1,68 @@
+{- Temporary directorie
+ -
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Tmp.Dir where
+
+import Control.Monad.IfElse
+import System.FilePath
+import System.Directory
+import Control.Monad.IO.Class
+#ifndef mingw32_HOST_OS
+import System.Posix.Temp (mkdtemp)
+#endif
+
+import Utility.Exception
+
+type Template = String
+
+{- Runs an action with a tmp directory located within the system's tmp
+ - directory (or within "." if there is none), then removes the tmp
+ - directory and all its contents. -}
+withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
+withTmpDir template a = do
+ topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
+#ifndef mingw32_HOST_OS
+ -- Use mkdtemp to create a temp directory securely in /tmp.
+ bracket
+ (liftIO $ mkdtemp $ topleveltmpdir </> template)
+ removeTmpDir
+ a
+#else
+ withTmpDirIn topleveltmpdir template a
+#endif
+
+{- Runs an action with a tmp directory located within a specified directory,
+ - then removes the tmp directory and all its contents. -}
+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
+withTmpDirIn tmpdir template = bracketIO create removeTmpDir
+ where
+ create = do
+ createDirectoryIfMissing True tmpdir
+ makenewdir (tmpdir </> template) (0 :: Int)
+ makenewdir t n = do
+ let dir = t ++ "." ++ show n
+ catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
+ createDirectory dir
+ return dir
+
+{- Deletes the entire contents of the the temporary directory, if it
+ - exists. -}
+removeTmpDir :: MonadIO m => FilePath -> m ()
+removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
+#if mingw32_HOST_OS
+ -- Windows will often refuse to delete a file
+ -- after a process has just written to it and exited.
+ -- Because it's crap, presumably. So, ignore failure
+ -- to delete the temp directory.
+ _ <- tryIO $ removeDirectoryRecursive tmpdir
+ return ()
+#else
+ removeDirectoryRecursive tmpdir
+#endif
diff --git a/Utility/Url.hs b/Utility/Url.hs
index 14a755f26..ad595e3d1 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -32,7 +32,7 @@ module Utility.Url (
) where
import Common
-import Utility.Tmp
+import Utility.Tmp.Dir
import qualified BuildInfo
import Network.URI
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index d504fa5c3..694bbe6d0 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -14,7 +14,7 @@ module Utility.UserInfo (
myUserGecos,
) where
-import Utility.Env
+import Utility.Env.Basic
import Utility.Exception
#ifndef mingw32_HOST_OS
import Utility.Data