From 3328fb83373adad786e57d4ed47e1d801e14260f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 30 Dec 2018 15:08:55 -0400 Subject: Merged Utility changes from git-annex Last done in May 2017.. --- debian/changelog | 1 + propellor.cabal | 7 +- src/Propellor/Gpg.hs | 2 + src/Propellor/Utilities.hs | 8 ++ src/Utility/Directory.hs | 114 +---------------------------- src/Utility/Directory/Stream.hs | 130 +++++++++++++++++++++++++++++++++ src/Utility/Directory/TestDirectory.hs | 40 ++++++++++ src/Utility/Env.hs | 24 ------ src/Utility/Env/Basic.hs | 22 ++++++ src/Utility/Env/Set.hs | 41 +++++++++++ src/Utility/Exception.hs | 18 +---- src/Utility/FileMode.hs | 5 +- src/Utility/FileSystemEncoding.hs | 20 +++++ src/Utility/Misc.hs | 21 ------ src/Utility/PartialPrelude.hs | 8 +- src/Utility/Path.hs | 62 ++-------------- src/Utility/PosixFiles.hs | 42 ----------- src/Utility/Process.hs | 80 ++------------------ src/Utility/Process/Shim.hs | 5 +- src/Utility/Process/Transcript.hs | 83 +++++++++++++++++++++ src/Utility/SafeCommand.hs | 20 ++--- src/Utility/Scheduled.hs | 3 +- src/Utility/Split.hs | 4 + src/Utility/ThreadScheduler.hs | 4 - src/Utility/Tmp.hs | 55 +------------- src/Utility/Tmp/Dir.hs | 67 +++++++++++++++++ src/Utility/UserInfo.hs | 22 ++++-- 27 files changed, 482 insertions(+), 426 deletions(-) create mode 100644 src/Utility/Directory/Stream.hs create mode 100644 src/Utility/Directory/TestDirectory.hs create mode 100644 src/Utility/Env/Basic.hs create mode 100644 src/Utility/Env/Set.hs delete mode 100644 src/Utility/PosixFiles.hs create mode 100644 src/Utility/Process/Transcript.hs create mode 100644 src/Utility/Tmp/Dir.hs 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 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 + - + - 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 + - + - 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 + - + - 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 + - + - 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 - - - - 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 + - + - 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 - @@ -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 + - + - 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) -- cgit v1.2.3