diff --git a/debian/changelog b/debian/changelog index 6ef509c..ae8deef 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,11 +1,18 @@ -propellor (2.3.1) UNRELEASED; urgency=medium +propellor (2.4.0) unstable; urgency=medium + * Propellor no longer supports Debian wheezy (oldstable). * Git.bareRepo: Fix bug in calls to userScriptProperty. Thanks, Jelmer Vernooij. * Removed Obnam.latestVersion which was only needed for Debian wheezy backport. + * Merged Utility changes from git-annex. + * Switched from MonadCatchIO-transformers to the newer transformers and + exceptions libraries. + * Ensure build deps are installed before building propellor in --spin + and cron job, even if propellor was already built before, to deal with + upgrades that add new dependencies. - -- Joey Hess Wed, 22 Apr 2015 20:59:59 -0400 + -- Joey Hess Wed, 06 May 2015 14:28:59 -0400 propellor (2.3.0) unstable; urgency=medium diff --git a/debian/control b/debian/control index a9b6c2c..2bebd6f 100644 --- a/debian/control +++ b/debian/control @@ -15,7 +15,8 @@ Build-Depends: libghc-network-dev, libghc-quickcheck2-dev, libghc-mtl-dev, - libghc-monadcatchio-transformers-dev, + libghc-transformers-dev, + libghc-exceptions-dev, Maintainer: Gergely Nagy Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor @@ -36,7 +37,8 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-network-dev, libghc-quickcheck2-dev, libghc-mtl-dev, - libghc-monadcatchio-transformers-dev, + libghc-transformers-dev, + libghc-exceptions-dev, git, Description: property-based host configuration management in haskell Propellor enures that the system it's run in satisfies a list of diff --git a/propellor.cabal b/propellor.cabal index 105eac9..5120ab8 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 2.3.0 +Version: 2.4.0 Cabal-Version: >= 1.6 License: BSD3 Maintainer: Joey Hess @@ -37,8 +37,8 @@ Executable propellor Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, - MonadCatchIO-transformers + containers, network, async, time, QuickCheck, mtl, transformers, + exceptions if (! os(windows)) Build-Depends: unix @@ -49,8 +49,8 @@ Executable propellor-config Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, - MonadCatchIO-transformers + containers, network, async, time, QuickCheck, mtl, transformers, + exceptions if (! os(windows)) Build-Depends: unix @@ -60,8 +60,8 @@ Library Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, - MonadCatchIO-transformers + containers, network, async, time, QuickCheck, mtl, transformers, + exceptions if (! os(windows)) Build-Depends: unix diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index a07347e..51ba69a 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -17,12 +17,10 @@ type ShellCommand = String -- Should be run inside the propellor config dir, and will install -- all necessary build dependencies and build propellor. bootstrapPropellorCommand :: ShellCommand -bootstrapPropellorCommand = "if ! test -x ./propellor; then " ++ go ++ "; fi;" ++ checkBinaryCommand - where - go = intercalate " && " - [ depsCommand - , buildCommand - ] +bootstrapPropellorCommand = checkDepsCommand ++ + "&& if ! test -x ./propellor; then " + ++ buildCommand ++ + "; fi;" ++ checkBinaryCommand -- Use propellor --check to detect if the local propellor binary has -- stopped working (eg due to library changes), and must be rebuilt. @@ -41,6 +39,11 @@ buildCommand = intercalate " && " , "ln -sf dist/build/propellor-config/propellor-config propellor" ] +-- Run cabal configure to check if all dependencies are installed; +-- if not, run the depsCommand. +checkDepsCommand :: ShellCommand +checkDepsCommand = "if ! cabal configure >/dev/null 2>&1; then " ++ depsCommand ++ "; fi" + -- Install build dependencies of propellor. -- -- First, try to install ghc, cabal, gnupg, and all haskell libraries that @@ -77,7 +80,8 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " , "libghc-network-dev" , "libghc-quickcheck2-dev" , "libghc-mtl-dev" - , "libghc-monadcatchio-transformers-dev" + , "libghc-transformers-dev" + , "libghc-exceptions-dev" ] installGitCommand :: ShellCommand diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 99f1660..dd3d465 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -17,7 +17,6 @@ import Data.Monoid import Control.Applicative import System.Console.ANSI import "mtl" Control.Monad.RWS.Strict -import Control.Exception (bracket) import System.PosixCompat import System.Posix.IO import System.FilePath diff --git a/src/Propellor/Exception.hs b/src/Propellor/Exception.hs index f6fd15f..2b38af0 100644 --- a/src/Propellor/Exception.hs +++ b/src/Propellor/Exception.hs @@ -2,11 +2,11 @@ module Propellor.Exception where -import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M -import Control.Exception - import Propellor.Types import Propellor.Message +import Utility.Exception + +import Control.Exception (IOException) -- | Catches IO exceptions and returns FailedChange. catchPropellor :: Propellor Result -> Propellor Result @@ -15,4 +15,4 @@ catchPropellor a = either err return =<< tryPropellor a err e = warningMessage (show e) >> return FailedChange tryPropellor :: Propellor a -> Propellor (Either IOException a) -tryPropellor = M.try +tryPropellor = try diff --git a/src/Propellor/Message.hs b/src/Propellor/Message.hs index bcd9964..f62d3cd 100644 --- a/src/Propellor/Message.hs +++ b/src/Propellor/Message.hs @@ -6,7 +6,7 @@ import System.Console.ANSI import System.IO import System.Log.Logger import System.Log.Formatter -import System.Log.Handler (setFormatter, LogHandler) +import System.Log.Handler (setFormatter) import System.Log.Handler.Simple import "mtl" Control.Monad.Reader import Data.Maybe diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index d4947ab..5d6a8be 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -20,7 +20,6 @@ import Utility.FileMode import Data.List import Data.Char -import Control.Exception import System.Posix.Directory import System.Posix.Files diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index f55f297..986305d 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -12,7 +12,6 @@ import System.PosixCompat import System.Posix.IO import System.Posix.Directory import Control.Concurrent.Async -import Control.Exception (bracket) import qualified Data.ByteString as B import qualified Data.Set as S import qualified Network.BSD as BSD @@ -168,7 +167,7 @@ updateServer -> CreateProcess -> IO () updateServer target relay hst connect haveprecompiled = - withBothHandles createProcessSuccess connect go + withIOHandles createProcessSuccess connect go where hn = fromMaybe target relay relaying = relay == Just target diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index ba63cf9..474385b 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -40,7 +40,7 @@ module Propellor.Types import Data.Monoid import Control.Applicative import "mtl" Control.Monad.RWS.Strict -import "MonadCatchIO-transformers" Control.Monad.CatchIO +import Control.Monad.Catch import qualified Data.Set as S import qualified Data.Map as M @@ -73,7 +73,9 @@ newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } , MonadReader Host , MonadWriter [EndAction] , MonadIO - , MonadCatchIO + , MonadCatch + , MonadThrow + , MonadMask ) instance Monoid (Propellor Result) where diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs index fd8944b..fce3c04 100644 --- a/src/Utility/Applicative.hs +++ b/src/Utility/Applicative.hs @@ -1,6 +1,6 @@ {- applicative stuff - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs index 2df12b3..5ecd218 100644 --- a/src/Utility/Data.hs +++ b/src/Utility/Data.hs @@ -1,6 +1,6 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs index 2ece143..6e40932 100644 --- a/src/Utility/DataUnits.hs +++ b/src/Utility/DataUnits.hs @@ -42,6 +42,7 @@ module Utility.DataUnits ( bandwidthUnits, oldSchoolUnits, Unit(..), + ByteSize, roughSize, compareSizes, diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs index 6b50016..2e037fd 100644 --- a/src/Utility/Directory.hs +++ b/src/Utility/Directory.hs @@ -1,4 +1,4 @@ -{- directory manipulation +{- directory traversal and manipulation - - Copyright 2011-2014 Joey Hess - @@ -11,12 +11,19 @@ module Utility.Directory where import System.IO.Error import System.Directory -import Control.Exception (throw) import Control.Monad import Control.Monad.IfElse import System.FilePath import Control.Applicative +import Control.Concurrent import System.IO.Unsafe (unsafeInterleaveIO) +import Data.Maybe + +#ifdef mingw32_HOST_OS +import qualified System.Win32 as Win32 +#else +import qualified System.Posix as Posix +#endif import Utility.PosixFiles import Utility.SafeCommand @@ -49,7 +56,7 @@ dirContentsRecursive = dirContentsRecursiveSkipping (const False) True dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] where - go [] = return [] + go [] = return [] go (dir:dirs) | skipdir (takeFileName dir) = go dirs | otherwise = unsafeInterleaveIO $ do @@ -80,7 +87,7 @@ dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir] dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath] dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] where - go c [] = return c + go c [] = return c go c (dir:dirs) | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do @@ -104,9 +111,9 @@ moveFile src dest = tryIO (rename src dest) >>= onrename -- But, mv will move into a directory if -- dest is one, which is not desired. whenM (isdir dest) rethrow - viaTmp mv dest undefined + viaTmp mv dest "" where - rethrow = throw e + rethrow = throwM e mv tmp _ = do ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] unless ok $ do @@ -133,3 +140,90 @@ 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/src/Utility/Env.hs b/src/Utility/Env.hs index ff6644f..fdf06d8 100644 --- a/src/Utility/Env.hs +++ b/src/Utility/Env.hs @@ -1,6 +1,6 @@ {- portable environment variables - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs index c6510db..ab47ae9 100644 --- a/src/Utility/Exception.hs +++ b/src/Utility/Exception.hs @@ -1,59 +1,88 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2012 Joey Hess + - Copyright 2011-2014 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE ScopedTypeVariables #-} -module Utility.Exception where +module Utility.Exception ( + module X, + catchBoolIO, + catchMaybeIO, + catchDefaultIO, + catchMsgIO, + catchIO, + tryIO, + bracketIO, + catchNonAsync, + tryNonAsync, + tryWhenExists, +) where -import Control.Exception -import qualified Control.Exception as E -import Control.Applicative +import Control.Monad.Catch as X hiding (Handler) +import qualified Control.Monad.Catch as M +import Control.Exception (IOException, AsyncException) import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError) import Utility.Data {- Catches IO errors and returns a Bool -} -catchBoolIO :: IO Bool -> IO Bool +catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False {- Catches IO errors and returns a Maybe -} -catchMaybeIO :: IO a -> IO (Maybe a) -catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a +catchMaybeIO :: MonadCatch m => m a -> m (Maybe a) +catchMaybeIO a = do + catchDefaultIO Nothing $ do + v <- a + return (Just v) {- Catches IO errors and returns a default value. -} -catchDefaultIO :: a -> IO a -> IO a +catchDefaultIO :: MonadCatch m => a -> m a -> m a catchDefaultIO def a = catchIO a (const $ return def) {- Catches IO errors and returns the error message. -} -catchMsgIO :: IO a -> IO (Either String a) -catchMsgIO a = either (Left . show) Right <$> tryIO a +catchMsgIO :: MonadCatch m => m a -> m (Either String a) +catchMsgIO a = do + v <- tryIO a + return $ either (Left . show) Right v {- catch specialized for IO errors only -} -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO = E.catch +catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a +catchIO = M.catch {- try specialized for IO errors only -} -tryIO :: IO a -> IO (Either IOException a) -tryIO = try +tryIO :: MonadCatch m => m a -> m (Either IOException a) +tryIO = M.try + +{- bracket with setup and cleanup actions lifted to IO. + - + - Note that unlike catchIO and tryIO, this catches all exceptions. -} +bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a +bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) {- Catches all exceptions except for async exceptions. - This is often better to use than catching them all, so that - ThreadKilled and UserInterrupt get through. -} -catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a +catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` - [ Handler (\ (e :: AsyncException) -> throw e) - , Handler (\ (e :: SomeException) -> onerr e) + [ M.Handler (\ (e :: AsyncException) -> throwM e) + , M.Handler (\ (e :: SomeException) -> onerr e) ] -tryNonAsync :: IO a -> IO (Either SomeException a) -tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left) +tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) +tryNonAsync a = go `catchNonAsync` (return . Left) + where + go = do + v <- a + return (Right v) {- Catches only DoesNotExist exceptions, and lets all others through. -} -tryWhenExists :: IO a -> IO (Maybe a) -tryWhenExists a = eitherToMaybe <$> - tryJust (guard . isDoesNotExistError) a +tryWhenExists :: MonadCatch m => m a -> m (Maybe a) +tryWhenExists a = do + v <- tryJust (guard . isDoesNotExistError) a + return (eitherToMaybe v) diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs index 82568f6..201b845 100644 --- a/src/Utility/FileMode.hs +++ b/src/Utility/FileMode.hs @@ -11,7 +11,6 @@ module Utility.FileMode where import System.IO import Control.Monad -import Control.Exception (bracket) import System.PosixCompat.Types import Utility.PosixFiles #ifndef mingw32_HOST_OS @@ -125,7 +124,7 @@ withUmask _ a = a #endif combineModes :: [FileMode] -> FileMode -combineModes [] = undefined +combineModes [] = 0 combineModes [m] = m combineModes (m:ms) = foldl unionFileModes m ms @@ -152,7 +151,11 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] - as writeFile. -} writeFileProtected :: FilePath -> String -> IO () -writeFileProtected file content = withUmask 0o0077 $ +writeFileProtected file content = writeFileProtected' file + (\h -> hPutStr h content) + +writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () +writeFileProtected' file writer = withUmask 0o0077 $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes - hPutStr h content + writer h diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs index fa4b39a..139b74f 100644 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} @@ -14,6 +14,8 @@ module Utility.FileSystemEncoding ( decodeBS, decodeW8, encodeW8, + encodeW8NUL, + decodeW8NUL, truncateFilePath, ) where @@ -25,6 +27,7 @@ import System.IO.Unsafe import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils +import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 @@ -89,6 +92,9 @@ decodeBS = L8.toString - w82c produces a String, which may contain Chars that are invalid - unicode. From there, this is really a simple matter of applying the - file system encoding, only complicated by GHC's interface to doing so. + - + - Note that the encoding stops at any NUL in the input. FilePaths + - do not normally contain embedded NUL, but Haskell Strings may. -} {-# NOINLINE encodeW8 #-} encodeW8 :: [Word8] -> FilePath @@ -101,6 +107,17 @@ encodeW8 w8 = unsafePerformIO $ do decodeW8 :: FilePath -> [Word8] decodeW8 = s2w8 . _encodeFilePath +{- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} +encodeW8NUL :: [Word8] -> FilePath +encodeW8NUL = join nul . map encodeW8 . split (s2w8 nul) + where + nul = ['\NUL'] + +decodeW8NUL :: FilePath -> [Word8] +decodeW8NUL = join (s2w8 nul) . map decodeW8 . split nul + where + nul = ['\NUL'] + {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. - diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs index 6074ba2..db64d12 100644 --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -1,6 +1,6 @@ {- Linux library copier and binary shimmer - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} @@ -29,14 +29,14 @@ installLib installfile top lib = ifM (doesFileExist lib) ( do installfile top lib checksymlink lib - return $ Just $ takeDirectory lib + return $ Just $ parentDir lib , return Nothing ) where checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do l <- readSymbolicLink (inTop top f) - let absl = absPathFrom (takeDirectory f) l - let target = relPathDirToFile (takeDirectory f) absl + let absl = absPathFrom (parentDir f) l + target <- relPathDirToFile (takeDirectory f) absl installfile top absl nukeFile (top ++ f) createSymbolicLink target (inTop top f) diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs index 949f41e..e4eccac 100644 --- a/src/Utility/Misc.hs +++ b/src/Utility/Misc.hs @@ -1,6 +1,6 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2011 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs index eba3c42..878e0da 100644 --- a/src/Utility/Monad.hs +++ b/src/Utility/Monad.hs @@ -1,6 +1,6 @@ {- monadic stuff - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs index 7f03491..9f0737f 100644 --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -1,6 +1,6 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2014 Joey Hess - - License: BSD-2-clause -} @@ -66,7 +66,7 @@ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) {- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. Resulting path will use / separators. -} + - MissingH's absNormPath on them. -} absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath #ifndef mingw32_HOST_OS absNormPathUnix dir path = MissingH.absNormPath dir path @@ -77,11 +77,15 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos todos = replace "/" "\\" #endif +{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} +parentDir :: FilePath -> FilePath +parentDir = takeDirectory . dropTrailingPathSeparator + {- Just the parent directory of a path, or Nothing if the path has no - - parent (ie for "/") -} -parentDir :: FilePath -> Maybe FilePath -parentDir dir - | null dirs = Nothing +- parent (ie for "/" or ".") -} +upFrom :: FilePath -> Maybe FilePath +upFrom dir + | length dirs < 2 = Nothing | otherwise = Just $ joinDrive drive (join s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" @@ -89,13 +93,13 @@ parentDir dir dirs = filter (not . null) $ split s path s = [pathSeparator] -prop_parentDir_basics :: FilePath -> Bool -prop_parentDir_basics dir +prop_upFrom_basics :: FilePath -> Bool +prop_upFrom_basics dir | null dir = True - | dir == "/" = parentDir dir == Nothing + | dir == "/" = p == Nothing | otherwise = p /= Just dir where - p = parentDir dir + p = upFrom dir {- Checks if the first FilePath is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc @@ -124,14 +128,25 @@ absPath file = do - relPathCwdToFile "/tmp/foo/bar" == "" -} relPathCwdToFile :: FilePath -> IO FilePath -relPathCwdToFile f = relPathDirToFile <$> getCurrentDirectory <*> absPath f +relPathCwdToFile f = do + c <- getCurrentDirectory + relPathDirToFile c f -{- Constructs a relative path from a directory to a file. +{- Constructs a relative path from a directory to a file. -} +relPathDirToFile :: FilePath -> FilePath -> IO FilePath +relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to + +{- This requires the first path to be absolute, and the + - second path cannot contain ../ or ./ - - - Both must be absolute, and cannot contain .. etc. (eg use absPath first). + - On Windows, if the paths are on different drives, + - a relative path is not possible and the path is simply + - returned as-is. -} -relPathDirToFile :: FilePath -> FilePath -> FilePath -relPathDirToFile from to = join s $ dotdots ++ uncommon +relPathDirToFileAbs :: FilePath -> FilePath -> FilePath +relPathDirToFileAbs from to + | takeDrive from /= takeDrive to = to + | otherwise = join s $ dotdots ++ uncommon where s = [pathSeparator] pfrom = split s from @@ -144,10 +159,11 @@ relPathDirToFile from to = join s $ dotdots ++ uncommon prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics from to + | null from || null to = True | from == to = null r | otherwise = not (null r) where - r = relPathDirToFile from to + r = relPathDirToFileAbs from to prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference @@ -156,22 +172,31 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference - location, but it's not really the same directory. - Code used to get this wrong. -} same_dir_shortcurcuits_at_difference = - relPathDirToFile (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) + relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"]) (joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]) == joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"] {- Given an original list of paths, and an expanded list derived from it, - - generates a list of lists, where each sublist corresponds to one of the - - original paths. When the original path is a directory, any items - - in the expanded list that are contained in that directory will appear in - - its segment. + - which may be arbitrarily reordered, generates a list of lists, where + - each sublist corresponds to one of the original paths. + - + - When the original path is a directory, any items in the expanded list + - that are contained in that directory will appear in its segment. + - + - The order of the original list of paths is attempted to be preserved in + - the order of the returned segments. However, doing so has a O^NM + - growth factor. So, if the original list has more than 100 paths on it, + - we stop preserving ordering at that point. Presumably a user passing + - that many paths in doesn't care too much about order of the later ones. -} segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]] segmentPaths [] new = [new] segmentPaths [_] new = [new] -- optimisation -segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest +segmentPaths (l:ls) new = found : segmentPaths ls rest where - (found, rest)=partition (l `dirContains`) new + (found, rest) = if length ls < 100 + then partition (l `dirContains`) new + else break (\p -> not (l `dirContains` p)) new {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In @@ -185,7 +210,7 @@ relHome :: FilePath -> IO String relHome path = do home <- myHomeDir return $ if dirContains home path - then "~/" ++ relPathDirToFile home path + then "~/" ++ relPathDirToFileAbs home path else path {- Checks if a command is available in PATH. diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs index 5abbb57..5a94ead 100644 --- a/src/Utility/PosixFiles.hs +++ b/src/Utility/PosixFiles.hs @@ -2,7 +2,7 @@ - - This is like System.PosixCompat.Files, except with a fixed rename. - - - Copyright 2014 Joey Hess + - Copyright 2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Process.hs b/src/Utility/Process.hs index 8fefaa5..cbbe8a8 100644 --- a/src/Utility/Process.hs +++ b/src/Utility/Process.hs @@ -25,14 +25,16 @@ module Utility.Process ( processTranscript, processTranscript', withHandle, - withBothHandles, + withIOHandles, + withOEHandles, withQuietOutput, + feedWithQuietOutput, createProcess, startInteractiveProcess, stdinHandle, stdoutHandle, stderrHandle, - bothHandles, + ioHandles, processHandle, devNull, ) where @@ -255,12 +257,12 @@ withHandle h creator p a = creator p' $ a . select (stderrHandle, base { std_err = CreatePipe }) {- Like withHandle, but passes (stdin, stdout) handles to the action. -} -withBothHandles +withIOHandles :: CreateProcessRunner -> CreateProcess -> ((Handle, Handle) -> IO a) -> IO a -withBothHandles creator p a = creator p' $ a . bothHandles +withIOHandles creator p a = creator p' $ a . ioHandles where p' = p { std_in = CreatePipe @@ -268,6 +270,20 @@ withBothHandles creator p a = creator p' $ a . bothHandles , std_err = Inherit } +{- Like withHandle, but passes (stdout, stderr) handles to the action. -} +withOEHandles + :: CreateProcessRunner + -> CreateProcess + -> ((Handle, Handle) -> IO a) + -> IO a +withOEHandles creator p a = creator p' $ a . oeHandles + where + p' = p + { std_in = Inherit + , std_out = CreatePipe + , std_err = CreatePipe + } + {- Forces the CreateProcessRunner to run quietly; - both stdout and stderr are discarded. -} withQuietOutput @@ -281,6 +297,21 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do } creator p' $ const $ return () +{- Stdout and stderr are discarded, while the process is fed stdin + - from the handle. -} +feedWithQuietOutput + :: CreateProcessRunner + -> CreateProcess + -> (Handle -> IO a) + -> IO a +feedWithQuietOutput creator p a = withFile devNull WriteMode $ \nullh -> do + let p' = p + { std_in = CreatePipe + , std_out = UseHandle nullh + , std_err = UseHandle nullh + } + creator p' $ a . stdinHandle + devNull :: FilePath #ifndef mingw32_HOST_OS devNull = "/dev/null" @@ -303,9 +334,12 @@ stdoutHandle _ = error "expected stdoutHandle" stderrHandle :: HandleExtractor stderrHandle (_, _, Just h, _) = h stderrHandle _ = error "expected stderrHandle" -bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) -bothHandles (Just hin, Just hout, _, _) = (hin, hout) -bothHandles _ = error "expected bothHandles" +ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +ioHandles (Just hin, Just hout, _, _) = (hin, hout) +ioHandles _ = error "expected ioHandles" +oeHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) +oeHandles (_, Just hout, Just herr, _) = (hout, herr) +oeHandles _ = error "expected oeHandles" processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle processHandle (_, _, _, pid) = pid diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs index a498ee6..54200d3 100644 --- a/src/Utility/QuickCheck.hs +++ b/src/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs index 86e60db..f44112b 100644 --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -1,6 +1,6 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2013 Joey Hess - - License: BSD-2-clause -} @@ -101,19 +101,26 @@ prop_idempotent_shellEscape s = [s] == (shellUnEscape . shellEscape) s prop_idempotent_shellEscape_multiword :: [String] -> Bool prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s -{- Segements a list of filenames into groups that are all below the manximum - - command-line length limit. Does not preserve order. -} -segmentXargs :: [FilePath] -> [[FilePath]] -segmentXargs l = go l [] 0 [] +{- Segments a list of filenames into groups that are all below the maximum + - command-line length limit. -} +segmentXargsOrdered :: [FilePath] -> [[FilePath]] +segmentXargsOrdered = reverse . map reverse . segmentXargsUnordered + +{- Not preserving data is a little faster, and streams better when + - there are a great many filesnames. -} +segmentXargsUnordered :: [FilePath] -> [[FilePath]] +segmentXargsUnordered l = go l [] 0 [] where - go [] c _ r = c:r + go [] c _ r = (c:r) go (f:fs) c accumlen r - | len < maxlen && newlen > maxlen = go (f:fs) [] 0 (c:r) + | newlen > maxlen && len < maxlen = go (f:fs) [] 0 (c:r) | otherwise = go fs (f:c) newlen r where len = length f newlen = accumlen + len - {- 10k of filenames per command, well under Linux's 20k limit; - - allows room for other parameters etc. -} + {- 10k of filenames per command, well under 100k limit + - of Linux (and OSX has a similar limit); + - allows room for other parameters etc. Also allows for + - eg, multibyte characters. -} maxlen = 10240 diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs index 4fa3a29..e077a1f 100644 --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -1,6 +1,6 @@ {- scheduled activities - - - Copyright 2013-2014 Joey Hess + - Copyright 2013-2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs index e6a81ae..da05e99 100644 --- a/src/Utility/ThreadScheduler.hs +++ b/src/Utility/ThreadScheduler.hs @@ -1,6 +1,6 @@ {- thread scheduling - - - Copyright 2012, 2013 Joey Hess + - Copyright 2012, 2013 Joey Hess - Copyright 2011 Bas van Dijk & Roel van Dijk - - License: BSD-2-clause diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs index d0cae33..dc55981 100644 --- a/src/Utility/Tmp.hs +++ b/src/Utility/Tmp.hs @@ -9,11 +9,11 @@ module Utility.Tmp where -import Control.Exception (bracket) import System.IO import System.Directory import Control.Monad.IfElse import System.FilePath +import Control.Monad.IO.Class import Utility.Exception import Utility.FileSystemEncoding @@ -24,45 +24,52 @@ 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 :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () -viaTmp a file content = do - let (dir, base) = splitFileName file - createDirectoryIfMissing True dir - (tmpfile, handle) <- openTempFile dir (base ++ ".tmp") - hClose handle - a tmpfile content - rename tmpfile file +viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m () +viaTmp a file content = bracketIO setup cleanup use + where + (dir, base) = splitFileName file + template = base ++ ".tmp" + setup = do + createDirectoryIfMissing True dir + openTempFile dir template + cleanup (tmpfile, h) = do + _ <- tryIO $ hClose h + tryIO $ removeFile tmpfile + use (tmpfile, h) = do + liftIO $ hClose h + a tmpfile content + liftIO $ rename tmpfile file {- Runs an action with a tmp file located in the system's tmp directory - (or in "." if there is none) then removes the file. -} -withTmpFile :: Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFile :: (MonadIO m, MonadMask m) => Template -> (FilePath -> Handle -> m a) -> m a withTmpFile template a = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory + tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory withTmpFileIn tmpdir template a {- Runs an action with a tmp file located in the specified directory, - then removes the file. -} -withTmpFileIn :: FilePath -> Template -> (FilePath -> Handle -> IO a) -> IO a +withTmpFileIn :: (MonadIO m, MonadMask m) => FilePath -> Template -> (FilePath -> Handle -> m a) -> m a withTmpFileIn tmpdir template a = bracket create remove use where - create = openTempFile tmpdir template - remove (name, handle) = do - hClose handle + create = liftIO $ openTempFile tmpdir template + remove (name, h) = liftIO $ do + hClose h catchBoolIO (removeFile name >> return True) - use (name, handle) = a name handle + 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 :: Template -> (FilePath -> IO a) -> IO a +withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a withTmpDir template a = do - tmpdir <- catchDefaultIO "." getTemporaryDirectory + tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory withTmpDirIn tmpdir template a {- Runs an action with a tmp directory located within a specified directory, - then removes the tmp directory and all its contents. -} -withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a -withTmpDirIn tmpdir template = bracket create remove +withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a +withTmpDirIn tmpdir template = bracketIO create remove where remove d = whenM (doesDirectoryExist d) $ do #if mingw32_HOST_OS diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs index c82f040..5bf8d5c 100644 --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -1,6 +1,6 @@ {- user info - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -}