summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2018-12-30 15:08:55 -0400
committerJoey Hess2018-12-30 15:08:55 -0400
commit3328fb83373adad786e57d4ed47e1d801e14260f (patch)
treef1e3502287f2cdd2bc19020f82b5a56ac90d0bbe
parent11b3e6c0017dadf64ea67a7ea8c98e78b0917256 (diff)
Merged Utility changes from git-annex
Last done in May 2017..
-rw-r--r--debian/changelog1
-rw-r--r--propellor.cabal7
-rw-r--r--src/Propellor/Gpg.hs2
-rw-r--r--src/Propellor/Utilities.hs8
-rw-r--r--src/Utility/Directory.hs114
-rw-r--r--src/Utility/Directory/Stream.hs130
-rw-r--r--src/Utility/Directory/TestDirectory.hs40
-rw-r--r--src/Utility/Env.hs24
-rw-r--r--src/Utility/Env/Basic.hs22
-rw-r--r--src/Utility/Env/Set.hs41
-rw-r--r--src/Utility/Exception.hs18
-rw-r--r--src/Utility/FileMode.hs5
-rw-r--r--src/Utility/FileSystemEncoding.hs20
-rw-r--r--src/Utility/Misc.hs21
-rw-r--r--src/Utility/PartialPrelude.hs8
-rw-r--r--src/Utility/Path.hs62
-rw-r--r--src/Utility/PosixFiles.hs42
-rw-r--r--src/Utility/Process.hs80
-rw-r--r--src/Utility/Process/Shim.hs5
-rw-r--r--src/Utility/Process/Transcript.hs83
-rw-r--r--src/Utility/SafeCommand.hs20
-rw-r--r--src/Utility/Scheduled.hs3
-rw-r--r--src/Utility/Split.hs4
-rw-r--r--src/Utility/ThreadScheduler.hs4
-rw-r--r--src/Utility/Tmp.hs55
-rw-r--r--src/Utility/Tmp/Dir.hs67
-rw-r--r--src/Utility/UserInfo.hs22
27 files changed, 482 insertions, 426 deletions
diff --git a/debian/changelog b/debian/changelog
index c870e48a..4c05966b 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -5,6 +5,7 @@ propellor (5.5.1) UNRELEASED; urgency=medium
* When bootstrapping on Debian, libghc-stm-dev may not be available,
as it's become part of ghc, so check before trying to install it.
* Fix build with ghc 8.6.3.
+ * Merged Utility changes from git-annex.
-- Joey Hess <id@joeyh.name> Tue, 23 Oct 2018 11:37:16 -0400
diff --git a/propellor.cabal b/propellor.cabal
index d021a300..232210e9 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -200,7 +200,11 @@ Library
Utility.Data
Utility.DataUnits
Utility.Directory
+ Utility.Directory.Stream
+ Utility.Directory.TestDirectory
Utility.Env
+ Utility.Env.Basic
+ Utility.Env.Set
Utility.Exception
Utility.FileMode
Utility.FileSystemEncoding
@@ -210,10 +214,10 @@ Library
Utility.Monad
Utility.Path
Utility.PartialPrelude
- Utility.PosixFiles
Utility.Process
Utility.Process.Shim
Utility.Process.NonConcurrent
+ Utility.Process.Transcript
Utility.SafeCommand
Utility.Scheduled
Utility.Scheduled
@@ -222,6 +226,7 @@ Library
Utility.Table
Utility.ThreadScheduler
Utility.Tmp
+ Utility.Tmp.Dir
Utility.Tuple
Utility.UserInfo
System.Console.Concurrent
diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs
index c48bc060..53e7ad5a 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -13,11 +13,13 @@ import Propellor.Message
import Propellor.Git.Config
import Utility.SafeCommand
import Utility.Process
+import Utility.Process.Transcript
import Utility.Process.NonConcurrent
import Utility.Monad
import Utility.Misc
import Utility.Tmp
import Utility.Env
+import Utility.Env.Set
import Utility.Directory
import Utility.Split
import Utility.Exception
diff --git a/src/Propellor/Utilities.hs b/src/Propellor/Utilities.hs
index 33af4eda..56e7f2fb 100644
--- a/src/Propellor/Utilities.hs
+++ b/src/Propellor/Utilities.hs
@@ -9,19 +9,27 @@
module Propellor.Utilities (
module Utility.PartialPrelude
, module Utility.Process
+ , module Utility.Process.Transcript
, module Utility.Exception
, module Utility.Env
+ , module Utility.Env.Set
, module Utility.Directory
+ , module Utility.Directory.TestDirectory
, module Utility.Tmp
+ , module Utility.Tmp.Dir
, module Utility.Monad
, module Utility.Misc
) where
import Utility.PartialPrelude
import Utility.Process
+import Utility.Process.Transcript
import Utility.Exception
import Utility.Env
+import Utility.Env.Set
import Utility.Directory
+import Utility.Directory.TestDirectory
import Utility.Tmp
+import Utility.Tmp.Dir
import Utility.Monad
import Utility.Misc
diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs
index e13191e4..e2c6a946 100644
--- a/src/Utility/Directory.hs
+++ b/src/Utility/Directory.hs
@@ -16,22 +16,18 @@ module Utility.Directory (
import System.IO.Error
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
import Utility.SystemDirectory
-import Utility.PosixFiles
import Utility.Tmp
import Utility.Exception
import Utility.Monad
@@ -42,10 +38,6 @@ dirCruft "." = True
dirCruft ".." = True
dirCruft _ = False
-fsCruft :: FilePath -> Bool
-fsCruft "lost+found" = True
-fsCruft d = dirCruft d
-
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: FilePath -> IO [FilePath]
@@ -100,10 +92,10 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir]
go c (dir:dirs)
| skipdir (takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do
- subdirs <- go c
+ subdirs <- go []
=<< filterM (isDirectory <$$> getSymbolicLinkStatus)
=<< catchDefaultIO [] (dirContents dir)
- go (subdirs++[dir]) dirs
+ go (subdirs++dir:c) dirs
{- Moves one filename to another.
- First tries a rename, but falls back to moving across devices if needed. -}
@@ -162,101 +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 = testDirectory d dirCruft
-
--- | True if the directory does not exist or contains nothing.
--- Ignores "lost+found" which can exist in an empty filesystem.
-isUnpopulated :: FilePath -> IO Bool
-isUnpopulated d = catchDefaultIO True $ testDirectory d fsCruft
-
--- | Run test on entries found in directory, return False as soon as the
--- test returns False, else return True. Throws exception if directory does
--- not exist.
-testDirectory :: FilePath -> (FilePath -> Bool) -> IO Bool
-testDirectory d test = bracket (openDirectory d) closeDirectory check
- where
- check h = do
- v <- readDirectory h
- case v of
- Nothing -> return True
- Just f
- | not (test f) -> return False
- | otherwise -> check h
diff --git a/src/Utility/Directory/Stream.hs b/src/Utility/Directory/Stream.hs
new file mode 100644
index 00000000..e827ef21
--- /dev/null
+++ b/src/Utility/Directory/Stream.hs
@@ -0,0 +1,130 @@
+{- streaming directory traversal
+ -
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Directory.Stream where
+
+import Control.Monad
+import System.FilePath
+import System.IO.Unsafe (unsafeInterleaveIO)
+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
+
+-- | Like getDirectoryContents, but rather than buffering the whole
+-- directory content in memory, lazily streams.
+--
+-- This is like lazy readFile in that the handle to the directory remains
+-- open until the whole list is consumed, or until the list is garbage
+-- collected. So use with caution particularly when traversing directory
+-- trees.
+streamDirectoryContents :: FilePath -> IO [FilePath]
+streamDirectoryContents d = openDirectory d >>= collect
+ where
+ collect hdl = readDirectory hdl >>= \case
+ Nothing -> return []
+ Just f -> do
+ rest <- unsafeInterleaveIO (collect hdl)
+ return (f:rest)
+
+-- | 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/src/Utility/Directory/TestDirectory.hs b/src/Utility/Directory/TestDirectory.hs
new file mode 100644
index 00000000..e1f961b9
--- /dev/null
+++ b/src/Utility/Directory/TestDirectory.hs
@@ -0,0 +1,40 @@
+{- testing properties of directories
+ -
+ - Copyright 2011-2018 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+module Utility.Directory.TestDirectory where
+
+import Utility.Directory
+import Utility.Directory.Stream
+import Utility.Exception
+
+-- | True only when directory exists and contains nothing.
+-- Throws exception if directory does not exist.
+isDirectoryEmpty :: FilePath -> IO Bool
+isDirectoryEmpty d = testDirectory d dirCruft
+
+-- | True if the directory does not exist or contains nothing.
+-- Ignores "lost+found" which can exist in an empty filesystem.
+isUnpopulated :: FilePath -> IO Bool
+isUnpopulated d = catchDefaultIO True $ testDirectory d fsCruft
+
+fsCruft :: FilePath -> Bool
+fsCruft "lost+found" = True
+fsCruft d = dirCruft d
+
+-- | Run test on entries found in directory, return False as soon as the
+-- test returns False, else return True. Throws exception if directory does
+-- not exist.
+testDirectory :: FilePath -> (FilePath -> Bool) -> IO Bool
+testDirectory d test = bracket (openDirectory d) closeDirectory check
+ where
+ check h = do
+ v <- readDirectory h
+ case v of
+ Nothing -> return True
+ Just f
+ | not (test f) -> return False
+ | otherwise -> check h
diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs
index c56f4ec2..dfebd986 100644
--- a/src/Utility/Env.hs
+++ b/src/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/src/Utility/Env/Basic.hs b/src/Utility/Env/Basic.hs
new file mode 100644
index 00000000..38295bea
--- /dev/null
+++ b/src/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/src/Utility/Env/Set.hs b/src/Utility/Env/Set.hs
new file mode 100644
index 00000000..bd835e97
--- /dev/null
+++ b/src/Utility/Env/Set.hs
@@ -0,0 +1,41 @@
+{- 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
+import Utility.Env
+#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/src/Utility/Exception.hs b/src/Utility/Exception.hs
index 67c2e85d..bcadb789 100644
--- a/src/Utility/Exception.hs
+++ b/src/Utility/Exception.hs
@@ -5,7 +5,7 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Exception (
@@ -29,11 +29,7 @@ module Utility.Exception (
import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
import Control.Exception (SomeAsyncException)
-#endif
-#endif
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
@@ -46,15 +42,7 @@ import Utility.Data
- where there's a problem that the user is excpected to see in some
- circumstances. -}
giveup :: [Char] -> a
-#ifdef MIN_VERSION_base
-#if MIN_VERSION_base(4,9,0)
giveup = errorWithoutStackTrace
-#else
-giveup = error
-#endif
-#else
-giveup = error
-#endif
{- Catches IO errors and returns a Bool -}
catchBoolIO :: MonadCatch m => m Bool -> m Bool
@@ -95,11 +83,7 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)
catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchNonAsync a onerr = a `catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
, M.Handler (\ (e :: SomeAsyncException) -> throwM e)
-#endif
-#endif
, M.Handler (\ (e :: SomeException) -> onerr e)
]
diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs
index d9a26944..7d36c554 100644
--- a/src/Utility/FileMode.hs
+++ b/src/Utility/FileMode.hs
@@ -15,9 +15,9 @@ module Utility.FileMode (
import System.IO
import Control.Monad
import System.PosixCompat.Types
-import Utility.PosixFiles
+import System.PosixCompat.Files
#ifndef mingw32_HOST_OS
-import System.Posix.Files
+import System.Posix.Files (symbolicLinkMode)
import Control.Monad.IO.Class (liftIO)
#endif
import Control.Monad.IO.Class (MonadIO)
@@ -69,6 +69,7 @@ otherGroupModes :: [FileMode]
otherGroupModes =
[ groupReadMode, otherReadMode
, groupWriteMode, otherWriteMode
+ , groupExecuteMode, otherExecuteMode
]
{- Removes the write bits from a file. -}
diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs
index 444dc4a9..ca6e7685 100644
--- a/src/Utility/FileSystemEncoding.hs
+++ b/src/Utility/FileSystemEncoding.hs
@@ -12,6 +12,9 @@ module Utility.FileSystemEncoding (
useFileSystemEncoding,
fileEncoding,
withFilePath,
+ RawFilePath,
+ fromRawFilePath,
+ toRawFilePath,
decodeBS,
encodeBS,
decodeW8,
@@ -32,6 +35,7 @@ import System.IO
import System.IO.Unsafe
import Data.Word
import Data.List
+import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
#ifdef mingw32_HOST_OS
import qualified Data.ByteString.Lazy.UTF8 as L8
@@ -120,6 +124,22 @@ encodeBS = L.pack . decodeW8NUL
encodeBS = L8.fromString
#endif
+{- Recent versions of the unix package have this alias; defined here
+ - for backwards compatibility. -}
+type RawFilePath = S.ByteString
+
+{- Note that the RawFilePath is assumed to never contain NUL,
+ - since filename's don't. This should only be used with actual
+ - RawFilePaths not arbitrary ByteString that may contain NUL. -}
+fromRawFilePath :: RawFilePath -> FilePath
+fromRawFilePath = encodeW8 . S.unpack
+
+{- Note that the FilePath is assumed to never contain NUL,
+ - since filename's don't. This should only be used with actual FilePaths
+ - not arbitrary String that may contain NUL. -}
+toRawFilePath :: FilePath -> RawFilePath
+toRawFilePath = S.pack . decodeW8
+
{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
-
- w82c produces a String, which may contain Chars that are invalid
diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs
index 4498c0a0..48fcceb7 100644
--- a/src/Utility/Misc.hs
+++ b/src/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 git processes.
- -
- - 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/src/Utility/PartialPrelude.hs b/src/Utility/PartialPrelude.hs
index 47e98318..85f80534 100644
--- a/src/Utility/PartialPrelude.hs
+++ b/src/Utility/PartialPrelude.hs
@@ -38,11 +38,9 @@ last = Prelude.last
{- Attempts to read a value from a String.
-
- - Ignores leading/trailing whitespace, and throws away any trailing
- - text after the part that can be read.
- -
- - readMaybe is available in Text.Read in new versions of GHC,
- - but that one requires the entire string to be consumed.
+ - Unlike Text.Read.readMaybe, this ignores some trailing text
+ - after the part that can be read. However, if the trailing text looks
+ - like another readable value, it fails.
-}
readish :: Read a => String -> Maybe a
readish s = case reads s of
diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs
index 0779d167..f1302ae8 100644
--- a/src/Utility/Path.hs
+++ b/src/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
@@ -136,17 +129,22 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
-}
relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
relPathDirToFileAbs from to
- | takeDrive from /= takeDrive to = to
+#ifdef mingw32_HOST_OS
+ | normdrive from /= normdrive to = to
+#endif
| otherwise = joinPath $ dotdots ++ uncommon
where
pfrom = sp from
pto = sp to
- sp = map dropTrailingPathSeparator . splitPath
+ sp = map dropTrailingPathSeparator . splitPath . dropDrive
common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
+#ifdef mingw32_HOST_OS
+ normdrive = map toLower . takeWhile (/= ':') . takeDrive
+#endif
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
@@ -242,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/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs
deleted file mode 100644
index 37253da2..00000000
--- a/src/Utility/PosixFiles.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{- POSIX files (and compatablity wrappers).
- -
- - This is like System.PosixCompat.Files, but with a few fixes.
- -
- - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- - License: BSD-2-clause
- -}
-
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Utility.PosixFiles (
- module X,
- rename
-) where
-
-import System.PosixCompat.Files as X hiding (rename)
-
-#ifndef mingw32_HOST_OS
-import System.Posix.Files (rename)
-#else
-import qualified System.Win32.File as Win32
-import qualified System.Win32.HardLink as Win32
-#endif
-
-{- System.PosixCompat.Files.rename on Windows calls renameFile,
- - so cannot rename directories.
- -
- - Instead, use Win32 moveFile, which can. It needs to be told to overwrite
- - any existing file. -}
-#ifdef mingw32_HOST_OS
-rename :: FilePath -> FilePath -> IO ()
-rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING
-#endif
-
-{- System.PosixCompat.Files.createLink throws an error, but windows
- - does support hard links. -}
-#ifdef mingw32_HOST_OS
-createLink :: FilePath -> FilePath -> IO ()
-createLink = Win32.createHardLink
-#endif
diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs
index 48e03f41..af3a5f4f 100644
--- a/src/Utility/Process.hs
+++ b/src/Utility/Process.hs
@@ -24,11 +24,10 @@ module Utility.Process (
createProcessSuccess,
createProcessChecked,
createBackgroundProcess,
- processTranscript,
- processTranscript',
withHandle,
withIOHandles,
withOEHandles,
+ withNullHandle,
withQuietOutput,
feedWithQuietOutput,
createProcess,
@@ -54,13 +53,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 +162,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.
@@ -281,13 +211,16 @@ withOEHandles creator p a = creator p' $ a . oeHandles
, std_err = CreatePipe
}
+withNullHandle :: (Handle -> IO a) -> IO a
+withNullHandle = withFile devNull WriteMode
+
-- | Forces the CreateProcessRunner to run quietly;
-- both stdout and stderr are discarded.
withQuietOutput
:: CreateProcessRunner
-> CreateProcess
-> IO ()
-withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
+withQuietOutput creator p = withNullHandle $ \nullh -> do
let p' = p
{ std_out = UseHandle nullh
, std_err = UseHandle nullh
@@ -313,7 +246,8 @@ devNull :: FilePath
#ifndef mingw32_HOST_OS
devNull = "/dev/null"
#else
-devNull = "NUL"
+-- Use device namespace to prevent GHC from rewriting path
+devNull = "\\\\.\\NUL"
#endif
-- | Extract a desired handle from createProcess's tuple.
diff --git a/src/Utility/Process/Shim.hs b/src/Utility/Process/Shim.hs
index 8c9d41d0..09312c7f 100644
--- a/src/Utility/Process/Shim.hs
+++ b/src/Utility/Process/Shim.hs
@@ -1,4 +1,3 @@
-module Utility.Process.Shim (module X, createProcess, waitForProcess) where
+module Utility.Process.Shim (module X) where
-import System.Process as X hiding (createProcess, waitForProcess)
-import System.Process.Concurrent
+import System.Process as X
diff --git a/src/Utility/Process/Transcript.hs b/src/Utility/Process/Transcript.hs
new file mode 100644
index 00000000..68fb2223
--- /dev/null
+++ b/src/Utility/Process/Transcript.hs
@@ -0,0 +1,83 @@
+{- Process transcript
+ -
+ - Copyright 2012-2018 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 Utility.Misc
+
+import System.IO
+import System.Exit
+import Control.Concurrent.Async
+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 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)
+
+-- | Also feeds the process some input.
+processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
+processTranscript' cp input = do
+ (t, c) <- processTranscript'' cp input
+ return (t, c == ExitSuccess)
+
+processTranscript'' :: CreateProcess -> Maybe String -> IO (String, ExitCode)
+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
+ System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True
+ System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True
+ 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 <- asyncreader readh
+ writeinput input p
+ transcript <- wait get
+#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 <- asyncreader (stdoutHandle p)
+ geterr <- asyncreader (stderrHandle p)
+ writeinput input p
+ transcript <- (++) <$> wait getout <*> wait geterr
+#endif
+ code <- waitForProcess pid
+ return (transcript, code)
+ where
+ asyncreader = async . hGetContentsStrict
+
+ 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/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs
index eb34d3de..f820e69f 100644
--- a/src/Utility/SafeCommand.hs
+++ b/src/Utility/SafeCommand.hs
@@ -27,19 +27,21 @@ data CommandParam
-- | Used to pass a list of CommandParams to a function that runs
-- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
-toCommand = map unwrap
+toCommand = map toCommand'
+
+toCommand' :: CommandParam -> String
+toCommand' (Param s) = s
+-- Files that start with a non-alphanumeric that is not a path
+-- separator are modified to avoid the command interpreting them as
+-- options or other special constructs.
+toCommand' (File s@(h:_))
+ | isAlphaNum h || h `elem` pathseps = s
+ | otherwise = "./" ++ s
where
- unwrap (Param s) = s
- -- Files that start with a non-alphanumeric that is not a path
- -- separator are modified to avoid the command interpreting them as
- -- options or other special constructs.
- unwrap (File s@(h:_))
- | isAlphaNum h || h `elem` pathseps = s
- | otherwise = "./" ++ s
- unwrap (File s) = s
-- '/' is explicitly included because it's an alternative
-- path separator on Windows.
pathseps = pathSeparator:"./"
+toCommand' (File s) = s
-- | Run a system command, and returns True or False if it succeeded or failed.
--
diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs
index b68ff901..12ead425 100644
--- a/src/Utility/Scheduled.hs
+++ b/src/Utility/Scheduled.hs
@@ -30,6 +30,7 @@ import Utility.Data
import Utility.PartialPrelude
import Utility.Misc
import Utility.Tuple
+import Utility.Split
import Data.List
import Data.Time.Clock
@@ -265,7 +266,7 @@ toRecurrance s = case words s of
constructor "month" = Just Monthly
constructor "year" = Just Yearly
constructor u
- | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u
+ | "s" `isSuffixOf` u = constructor $ dropFromEnd 1 u
| otherwise = Nothing
withday sd u = do
c <- constructor u
diff --git a/src/Utility/Split.hs b/src/Utility/Split.hs
index decfe7d3..ffea5d3f 100644
--- a/src/Utility/Split.hs
+++ b/src/Utility/Split.hs
@@ -28,3 +28,7 @@ splitc c s = case break (== c) s of
-- | same as Data.List.Utils.replace
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace old new = intercalate new . split old
+
+-- | Only traverses the list once while dropping the last n characters.
+dropFromEnd :: Int -> [a] -> [a]
+dropFromEnd n l = zipWith const l (drop n l)
diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs
index da05e996..5b46c92e 100644
--- a/src/Utility/ThreadScheduler.hs
+++ b/src/Utility/ThreadScheduler.hs
@@ -18,10 +18,8 @@ import System.Posix.IO
#endif
#ifndef mingw32_HOST_OS
import System.Posix.Signals
-#ifndef __ANDROID__
import System.Posix.Terminal
#endif
-#endif
newtype Seconds = Seconds { fromSeconds :: Int }
deriving (Eq, Ord, Show)
@@ -63,10 +61,8 @@ waitForTermination = do
let check sig = void $
installHandler sig (CatchOnce $ putMVar lock ()) Nothing
check softwareTermination
-#ifndef __ANDROID__
whenM (queryTerminal stdInput) $
check keyboardSignal
-#endif
takeMVar lock
#endif
diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs
index 6a541cfe..6e04b107 100644
--- a/src/Utility/Tmp.hs
+++ b/src/Utility/Tmp.hs
@@ -1,4 +1,4 @@
-{- Temporary files and directories.
+{- Temporary files.
-
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
@@ -11,24 +11,20 @@
module Utility.Tmp where
import System.IO
-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 System.PosixCompat.Files
import Utility.Exception
import Utility.FileSystemEncoding
-import Utility.PosixFiles
type Template = String
{- Runs an action like writeFile, writing to a temp file first and
- then moving it into place. The temp file is stored in the same
- directory as the final file to avoid cross-device renames. -}
-viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()
+viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -> m ()
viaTmp a file content = bracketIO setup cleanup use
where
(dir, base) = splitFileName file
@@ -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/src/Utility/Tmp/Dir.hs b/src/Utility/Tmp/Dir.hs
new file mode 100644
index 00000000..64c57d60
--- /dev/null
+++ b/src/Utility/Tmp/Dir.hs
@@ -0,0 +1,67 @@
+{- Temporary directories
+ -
+ - 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
+import Utility.Tmp (Template)
+
+{- 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/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs
index dd66c331..17ce8db5 100644
--- a/src/Utility/UserInfo.hs
+++ b/src/Utility/UserInfo.hs
@@ -14,12 +14,14 @@ module Utility.UserInfo (
myUserGecos,
) where
-import Utility.Env
-import Utility.Data
+import Utility.Env.Basic
import Utility.Exception
+#ifndef mingw32_HOST_OS
+import Utility.Data
+import Control.Applicative
+#endif
import System.PosixCompat
-import Control.Applicative
import Prelude
{- Current user's home directory.
@@ -45,8 +47,8 @@ myUserName = myVal env userName
#endif
myUserGecos :: IO (Maybe String)
--- userGecos crashes on Android and is not available on Windows.
-#if defined(__ANDROID__) || defined(mingw32_HOST_OS)
+-- userGecos is not available on Windows.
+#if defined(mingw32_HOST_OS)
myUserGecos = return Nothing
#else
myUserGecos = eitherToMaybe <$> myVal [] userGecos
@@ -55,9 +57,13 @@ myUserGecos = eitherToMaybe <$> myVal [] userGecos
myVal :: [String] -> (UserEntry -> String) -> IO (Either String String)
myVal envvars extract = go envvars
where
+ go [] = either (const $ envnotset) (Right . extract) <$> get
+ go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
#ifndef mingw32_HOST_OS
- go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)
+ -- This may throw an exception if the system doesn't have a
+ -- passwd file etc; don't let it crash.
+ get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID
#else
- go [] = return $ Left ("environment not set: " ++ show envvars)
+ get = return envnotset
#endif
- go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
+ envnotset = Left ("environment not set: " ++ show envvars)