propellor spin

This commit is contained in:
Joey Hess 2015-04-29 14:26:13 -04:00
parent 960745b95e
commit 681e4dbbcb
Failed to extract signature
28 changed files with 348 additions and 127 deletions

5
debian/changelog vendored
View File

@ -1,9 +1,12 @@
propellor (2.3.1) UNRELEASED; urgency=medium propellor (2.4.0) UNRELEASED; urgency=medium
* Git.bareRepo: Fix bug in calls to userScriptProperty. * Git.bareRepo: Fix bug in calls to userScriptProperty.
Thanks, Jelmer Vernooij. Thanks, Jelmer Vernooij.
* Removed Obnam.latestVersion which was only needed for Debian wheezy * Removed Obnam.latestVersion which was only needed for Debian wheezy
backport. backport.
* Merged Utility changes from git-annex.
* Switched from MonadCatchIO-transformers to the newer transformers and
exceptions libraries.
-- Joey Hess <id@joeyh.name> Wed, 22 Apr 2015 20:59:59 -0400 -- Joey Hess <id@joeyh.name> Wed, 22 Apr 2015 20:59:59 -0400

6
debian/control vendored
View File

@ -15,7 +15,8 @@ Build-Depends:
libghc-network-dev, libghc-network-dev,
libghc-quickcheck2-dev, libghc-quickcheck2-dev,
libghc-mtl-dev, libghc-mtl-dev,
libghc-monadcatchio-transformers-dev, libghc-transformers-dev,
libghc-exceptions-dev,
Maintainer: Gergely Nagy <algernon@madhouse-project.org> Maintainer: Gergely Nagy <algernon@madhouse-project.org>
Standards-Version: 3.9.6 Standards-Version: 3.9.6
Vcs-Git: git://git.joeyh.name/propellor Vcs-Git: git://git.joeyh.name/propellor
@ -36,7 +37,8 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-network-dev, libghc-network-dev,
libghc-quickcheck2-dev, libghc-quickcheck2-dev,
libghc-mtl-dev, libghc-mtl-dev,
libghc-monadcatchio-transformers-dev, libghc-transformers-dev,
libghc-exceptions-dev,
git, git,
Description: property-based host configuration management in haskell Description: property-based host configuration management in haskell
Propellor enures that the system it's run in satisfies a list of Propellor enures that the system it's run in satisfies a list of

View File

@ -37,8 +37,8 @@ Executable propellor
Hs-Source-Dirs: src Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async, time, QuickCheck, mtl, containers, network, async, time, QuickCheck, mtl, transformers,
MonadCatchIO-transformers exceptions
if (! os(windows)) if (! os(windows))
Build-Depends: unix Build-Depends: unix
@ -49,8 +49,8 @@ Executable propellor-config
Hs-Source-Dirs: src Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async, time, QuickCheck, mtl, containers, network, async, time, QuickCheck, mtl, transformers,
MonadCatchIO-transformers exceptions
if (! os(windows)) if (! os(windows))
Build-Depends: unix Build-Depends: unix
@ -60,8 +60,8 @@ Library
Hs-Source-Dirs: src Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
containers, network, async, time, QuickCheck, mtl, containers, network, async, time, QuickCheck, mtl, transformers,
MonadCatchIO-transformers exceptions
if (! os(windows)) if (! os(windows))
Build-Depends: unix Build-Depends: unix

View File

@ -17,7 +17,6 @@ import Data.Monoid
import Control.Applicative import Control.Applicative
import System.Console.ANSI import System.Console.ANSI
import "mtl" Control.Monad.RWS.Strict import "mtl" Control.Monad.RWS.Strict
import Control.Exception (bracket)
import System.PosixCompat import System.PosixCompat
import System.Posix.IO import System.Posix.IO
import System.FilePath import System.FilePath

View File

@ -2,11 +2,11 @@
module Propellor.Exception where module Propellor.Exception where
import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as M
import Control.Exception
import Propellor.Types import Propellor.Types
import Propellor.Message import Propellor.Message
import Utility.Exception
import Control.Exception (IOException)
-- | Catches IO exceptions and returns FailedChange. -- | Catches IO exceptions and returns FailedChange.
catchPropellor :: Propellor Result -> Propellor Result catchPropellor :: Propellor Result -> Propellor Result
@ -15,4 +15,4 @@ catchPropellor a = either err return =<< tryPropellor a
err e = warningMessage (show e) >> return FailedChange err e = warningMessage (show e) >> return FailedChange
tryPropellor :: Propellor a -> Propellor (Either IOException a) tryPropellor :: Propellor a -> Propellor (Either IOException a)
tryPropellor = M.try tryPropellor = try

View File

@ -20,7 +20,6 @@ import Utility.FileMode
import Data.List import Data.List
import Data.Char import Data.Char
import Control.Exception
import System.Posix.Directory import System.Posix.Directory
import System.Posix.Files import System.Posix.Files

View File

@ -12,7 +12,6 @@ import System.PosixCompat
import System.Posix.IO import System.Posix.IO
import System.Posix.Directory import System.Posix.Directory
import Control.Concurrent.Async import Control.Concurrent.Async
import Control.Exception (bracket)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.Set as S import qualified Data.Set as S
import qualified Network.BSD as BSD import qualified Network.BSD as BSD
@ -168,7 +167,7 @@ updateServer
-> CreateProcess -> CreateProcess
-> IO () -> IO ()
updateServer target relay hst connect haveprecompiled = updateServer target relay hst connect haveprecompiled =
withBothHandles createProcessSuccess connect go withIOHandles createProcessSuccess connect go
where where
hn = fromMaybe target relay hn = fromMaybe target relay
relaying = relay == Just target relaying = relay == Just target

View File

@ -40,7 +40,7 @@ module Propellor.Types
import Data.Monoid import Data.Monoid
import Control.Applicative import Control.Applicative
import "mtl" Control.Monad.RWS.Strict 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.Set as S
import qualified Data.Map as M import qualified Data.Map as M
@ -73,7 +73,9 @@ newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p }
, MonadReader Host , MonadReader Host
, MonadWriter [EndAction] , MonadWriter [EndAction]
, MonadIO , MonadIO
, MonadCatchIO , MonadCatch
, MonadThrow
, MonadMask
) )
instance Monoid (Propellor Result) where instance Monoid (Propellor Result) where

View File

@ -1,6 +1,6 @@
{- applicative stuff {- applicative stuff
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}

View File

@ -1,6 +1,6 @@
{- utilities for simple data types {- utilities for simple data types
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}

View File

@ -42,6 +42,7 @@ module Utility.DataUnits (
bandwidthUnits, bandwidthUnits,
oldSchoolUnits, oldSchoolUnits,
Unit(..), Unit(..),
ByteSize,
roughSize, roughSize,
compareSizes, compareSizes,

View File

@ -1,4 +1,4 @@
{- directory manipulation {- directory traversal and manipulation
- -
- Copyright 2011-2014 Joey Hess <id@joeyh.name> - Copyright 2011-2014 Joey Hess <id@joeyh.name>
- -
@ -11,12 +11,19 @@ module Utility.Directory where
import System.IO.Error import System.IO.Error
import System.Directory import System.Directory
import Control.Exception (throw)
import Control.Monad import Control.Monad
import Control.Monad.IfElse import Control.Monad.IfElse
import System.FilePath import System.FilePath
import Control.Applicative import Control.Applicative
import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO) 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.PosixFiles
import Utility.SafeCommand import Utility.SafeCommand
@ -104,9 +111,9 @@ moveFile src dest = tryIO (rename src dest) >>= onrename
-- But, mv will move into a directory if -- But, mv will move into a directory if
-- dest is one, which is not desired. -- dest is one, which is not desired.
whenM (isdir dest) rethrow whenM (isdir dest) rethrow
viaTmp mv dest undefined viaTmp mv dest ""
where where
rethrow = throw e rethrow = throwM e
mv tmp _ = do mv tmp _ = do
ok <- boolSystem "mv" [Param "-f", Param src, Param tmp] ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
unless ok $ do unless ok $ do
@ -133,3 +140,90 @@ nukeFile file = void $ tryWhenExists go
#else #else
go = removeFile file go = removeFile file
#endif #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

View File

@ -1,6 +1,6 @@
{- portable environment variables {- portable environment variables
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}

View File

@ -1,59 +1,88 @@
{- Simple IO exception handling (and some more) {- Simple IO exception handling (and some more)
- -
- Copyright 2011-2012 Joey Hess <id@joeyh.name> - Copyright 2011-2014 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}
{-# LANGUAGE ScopedTypeVariables #-} {-# 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 Control.Monad.Catch as X hiding (Handler)
import qualified Control.Exception as E import qualified Control.Monad.Catch as M
import Control.Applicative import Control.Exception (IOException, AsyncException)
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError) import System.IO.Error (isDoesNotExistError)
import Utility.Data import Utility.Data
{- Catches IO errors and returns a Bool -} {- Catches IO errors and returns a Bool -}
catchBoolIO :: IO Bool -> IO Bool catchBoolIO :: MonadCatch m => m Bool -> m Bool
catchBoolIO = catchDefaultIO False catchBoolIO = catchDefaultIO False
{- Catches IO errors and returns a Maybe -} {- Catches IO errors and returns a Maybe -}
catchMaybeIO :: IO a -> IO (Maybe a) catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
catchMaybeIO a = catchDefaultIO Nothing $ Just <$> a catchMaybeIO a = do
catchDefaultIO Nothing $ do
v <- a
return (Just v)
{- Catches IO errors and returns a default value. -} {- 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) catchDefaultIO def a = catchIO a (const $ return def)
{- Catches IO errors and returns the error message. -} {- Catches IO errors and returns the error message. -}
catchMsgIO :: IO a -> IO (Either String a) catchMsgIO :: MonadCatch m => m a -> m (Either String a)
catchMsgIO a = either (Left . show) Right <$> tryIO a catchMsgIO a = do
v <- tryIO a
return $ either (Left . show) Right v
{- catch specialized for IO errors only -} {- catch specialized for IO errors only -}
catchIO :: IO a -> (IOException -> IO a) -> IO a catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a
catchIO = E.catch catchIO = M.catch
{- try specialized for IO errors only -} {- try specialized for IO errors only -}
tryIO :: IO a -> IO (Either IOException a) tryIO :: MonadCatch m => m a -> m (Either IOException a)
tryIO = try 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. {- Catches all exceptions except for async exceptions.
- This is often better to use than catching them all, so that - This is often better to use than catching them all, so that
- ThreadKilled and UserInterrupt get through. - 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` catchNonAsync a onerr = a `catches`
[ Handler (\ (e :: AsyncException) -> throw e) [ M.Handler (\ (e :: AsyncException) -> throwM e)
, Handler (\ (e :: SomeException) -> onerr e) , M.Handler (\ (e :: SomeException) -> onerr e)
] ]
tryNonAsync :: IO a -> IO (Either SomeException a) tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a)
tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left) tryNonAsync a = go `catchNonAsync` (return . Left)
where
go = do
v <- a
return (Right v)
{- Catches only DoesNotExist exceptions, and lets all others through. -} {- Catches only DoesNotExist exceptions, and lets all others through. -}
tryWhenExists :: IO a -> IO (Maybe a) tryWhenExists :: MonadCatch m => m a -> m (Maybe a)
tryWhenExists a = eitherToMaybe <$> tryWhenExists a = do
tryJust (guard . isDoesNotExistError) a v <- tryJust (guard . isDoesNotExistError) a
return (eitherToMaybe v)

View File

@ -11,7 +11,6 @@ module Utility.FileMode where
import System.IO import System.IO
import Control.Monad import Control.Monad
import Control.Exception (bracket)
import System.PosixCompat.Types import System.PosixCompat.Types
import Utility.PosixFiles import Utility.PosixFiles
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
@ -125,7 +124,7 @@ withUmask _ a = a
#endif #endif
combineModes :: [FileMode] -> FileMode combineModes :: [FileMode] -> FileMode
combineModes [] = undefined combineModes [] = 0
combineModes [m] = m combineModes [m] = m
combineModes (m:ms) = foldl unionFileModes m ms combineModes (m:ms) = foldl unionFileModes m ms
@ -152,7 +151,11 @@ setSticky f = modifyFileMode f $ addModes [stickyMode]
- as writeFile. - as writeFile.
-} -}
writeFileProtected :: FilePath -> String -> IO () 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 withFile file WriteMode $ \h -> do
void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes
hPutStr h content writer h

View File

@ -1,6 +1,6 @@
{- GHC File system encoding handling. {- GHC File system encoding handling.
- -
- Copyright 2012-2014 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}
@ -14,6 +14,8 @@ module Utility.FileSystemEncoding (
decodeBS, decodeBS,
decodeW8, decodeW8,
encodeW8, encodeW8,
encodeW8NUL,
decodeW8NUL,
truncateFilePath, truncateFilePath,
) where ) where
@ -25,6 +27,7 @@ import System.IO.Unsafe
import qualified Data.Hash.MD5 as MD5 import qualified Data.Hash.MD5 as MD5
import Data.Word import Data.Word
import Data.Bits.Utils import Data.Bits.Utils
import Data.List.Utils
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
import qualified Data.ByteString.Lazy.UTF8 as L8 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 - w82c produces a String, which may contain Chars that are invalid
- unicode. From there, this is really a simple matter of applying the - unicode. From there, this is really a simple matter of applying the
- file system encoding, only complicated by GHC's interface to doing so. - 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 #-} {-# NOINLINE encodeW8 #-}
encodeW8 :: [Word8] -> FilePath encodeW8 :: [Word8] -> FilePath
@ -101,6 +107,17 @@ encodeW8 w8 = unsafePerformIO $ do
decodeW8 :: FilePath -> [Word8] decodeW8 :: FilePath -> [Word8]
decodeW8 = s2w8 . _encodeFilePath 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), {- Truncates a FilePath to the given number of bytes (or less),
- as represented on disk. - as represented on disk.
- -

View File

@ -1,6 +1,6 @@
{- Linux library copier and binary shimmer {- Linux library copier and binary shimmer
- -
- Copyright 2013 Joey Hess <joey@kitenet.net> - Copyright 2013 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}
@ -29,14 +29,14 @@ installLib installfile top lib = ifM (doesFileExist lib)
( do ( do
installfile top lib installfile top lib
checksymlink lib checksymlink lib
return $ Just $ takeDirectory lib return $ Just $ parentDir lib
, return Nothing , return Nothing
) )
where where
checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do
l <- readSymbolicLink (inTop top f) l <- readSymbolicLink (inTop top f)
let absl = absPathFrom (takeDirectory f) l let absl = absPathFrom (parentDir f) l
let target = relPathDirToFile (takeDirectory f) absl target <- relPathDirToFile (takeDirectory f) absl
installfile top absl installfile top absl
nukeFile (top ++ f) nukeFile (top ++ f)
createSymbolicLink target (inTop top f) createSymbolicLink target (inTop top f)

View File

@ -1,6 +1,6 @@
{- misc utility functions {- misc utility functions
- -
- Copyright 2010-2011 Joey Hess <joey@kitenet.net> - Copyright 2010-2011 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}

View File

@ -1,6 +1,6 @@
{- monadic stuff {- monadic stuff
- -
- Copyright 2010-2012 Joey Hess <joey@kitenet.net> - Copyright 2010-2012 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}

View File

@ -1,6 +1,6 @@
{- path manipulation {- path manipulation
- -
- Copyright 2010-2014 Joey Hess <joey@kitenet.net> - Copyright 2010-2014 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}
@ -66,7 +66,7 @@ absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom dir path = simplifyPath (combine dir path) absPathFrom dir path = simplifyPath (combine dir path)
{- On Windows, this converts the paths to unix-style, in order to run {- 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 absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
absNormPathUnix dir path = MissingH.absNormPath dir path absNormPathUnix dir path = MissingH.absNormPath dir path
@ -77,11 +77,15 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos
todos = replace "/" "\\" todos = replace "/" "\\"
#endif #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 {- Just the parent directory of a path, or Nothing if the path has no
- parent (ie for "/") -} - parent (ie for "/" or ".") -}
parentDir :: FilePath -> Maybe FilePath upFrom :: FilePath -> Maybe FilePath
parentDir dir upFrom dir
| null dirs = Nothing | length dirs < 2 = Nothing
| otherwise = Just $ joinDrive drive (join s $ init dirs) | otherwise = Just $ joinDrive drive (join s $ init dirs)
where where
-- on Unix, the drive will be "/" when the dir is absolute, otherwise "" -- 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 dirs = filter (not . null) $ split s path
s = [pathSeparator] s = [pathSeparator]
prop_parentDir_basics :: FilePath -> Bool prop_upFrom_basics :: FilePath -> Bool
prop_parentDir_basics dir prop_upFrom_basics dir
| null dir = True | null dir = True
| dir == "/" = parentDir dir == Nothing | dir == "/" = p == Nothing
| otherwise = p /= Just dir | otherwise = p /= Just dir
where where
p = parentDir dir p = upFrom dir
{- Checks if the first FilePath is, or could be said to contain the second. {- 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 - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
@ -124,14 +128,25 @@ absPath file = do
- relPathCwdToFile "/tmp/foo/bar" == "" - relPathCwdToFile "/tmp/foo/bar" == ""
-} -}
relPathCwdToFile :: FilePath -> IO FilePath 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 relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
relPathDirToFile from to = join s $ dotdots ++ uncommon relPathDirToFileAbs from to
| takeDrive from /= takeDrive to = to
| otherwise = join s $ dotdots ++ uncommon
where where
s = [pathSeparator] s = [pathSeparator]
pfrom = split s from pfrom = split s from
@ -144,10 +159,11 @@ relPathDirToFile from to = join s $ dotdots ++ uncommon
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to prop_relPathDirToFile_basics from to
| null from || null to = True
| from == to = null r | from == to = null r
| otherwise = not (null r) | otherwise = not (null r)
where where
r = relPathDirToFile from to r = relPathDirToFileAbs from to
prop_relPathDirToFile_regressionTest :: Bool prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference 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. - location, but it's not really the same directory.
- Code used to get this wrong. -} - Code used to get this wrong. -}
same_dir_shortcurcuits_at_difference = 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 [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
== joinPath ["..", "..", "..", "..", ".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, {- 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 - which may be arbitrarily reordered, generates a list of lists, where
- original paths. When the original path is a directory, any items - each sublist corresponds to one of the original paths.
- in the expanded list that are contained in that directory will appear in -
- its segment. - 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 :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths [] new = [new] segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = [found] ++ segmentPaths ls rest segmentPaths (l:ls) new = found : segmentPaths ls rest
where 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, {- 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 - than it would be to run the action separately with each path. In
@ -185,7 +210,7 @@ relHome :: FilePath -> IO String
relHome path = do relHome path = do
home <- myHomeDir home <- myHomeDir
return $ if dirContains home path return $ if dirContains home path
then "~/" ++ relPathDirToFile home path then "~/" ++ relPathDirToFileAbs home path
else path else path
{- Checks if a command is available in PATH. {- Checks if a command is available in PATH.

View File

@ -2,7 +2,7 @@
- -
- This is like System.PosixCompat.Files, except with a fixed rename. - This is like System.PosixCompat.Files, except with a fixed rename.
- -
- Copyright 2014 Joey Hess <joey@kitenet.net> - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}

View File

@ -25,14 +25,16 @@ module Utility.Process (
processTranscript, processTranscript,
processTranscript', processTranscript',
withHandle, withHandle,
withBothHandles, withIOHandles,
withOEHandles,
withQuietOutput, withQuietOutput,
feedWithQuietOutput,
createProcess, createProcess,
startInteractiveProcess, startInteractiveProcess,
stdinHandle, stdinHandle,
stdoutHandle, stdoutHandle,
stderrHandle, stderrHandle,
bothHandles, ioHandles,
processHandle, processHandle,
devNull, devNull,
) where ) where
@ -255,12 +257,12 @@ withHandle h creator p a = creator p' $ a . select
(stderrHandle, base { std_err = CreatePipe }) (stderrHandle, base { std_err = CreatePipe })
{- Like withHandle, but passes (stdin, stdout) handles to the action. -} {- Like withHandle, but passes (stdin, stdout) handles to the action. -}
withBothHandles withIOHandles
:: CreateProcessRunner :: CreateProcessRunner
-> CreateProcess -> CreateProcess
-> ((Handle, Handle) -> IO a) -> ((Handle, Handle) -> IO a)
-> IO a -> IO a
withBothHandles creator p a = creator p' $ a . bothHandles withIOHandles creator p a = creator p' $ a . ioHandles
where where
p' = p p' = p
{ std_in = CreatePipe { std_in = CreatePipe
@ -268,6 +270,20 @@ withBothHandles creator p a = creator p' $ a . bothHandles
, std_err = Inherit , 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; {- Forces the CreateProcessRunner to run quietly;
- both stdout and stderr are discarded. -} - both stdout and stderr are discarded. -}
withQuietOutput withQuietOutput
@ -281,6 +297,21 @@ withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
} }
creator p' $ const $ return () 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 devNull :: FilePath
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
devNull = "/dev/null" devNull = "/dev/null"
@ -303,9 +334,12 @@ stdoutHandle _ = error "expected stdoutHandle"
stderrHandle :: HandleExtractor stderrHandle :: HandleExtractor
stderrHandle (_, _, Just h, _) = h stderrHandle (_, _, Just h, _) = h
stderrHandle _ = error "expected stderrHandle" stderrHandle _ = error "expected stderrHandle"
bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle) ioHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Handle, Handle)
bothHandles (Just hin, Just hout, _, _) = (hin, hout) ioHandles (Just hin, Just hout, _, _) = (hin, hout)
bothHandles _ = error "expected bothHandles" 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 :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle
processHandle (_, _, _, pid) = pid processHandle (_, _, _, pid) = pid

View File

@ -1,6 +1,6 @@
{- QuickCheck with additional instances {- QuickCheck with additional instances
- -
- Copyright 2012-2014 Joey Hess <joey@kitenet.net> - Copyright 2012-2014 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}

View File

@ -1,6 +1,6 @@
{- safely running shell commands {- safely running shell commands
- -
- Copyright 2010-2013 Joey Hess <joey@kitenet.net> - Copyright 2010-2013 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - 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 :: [String] -> Bool
prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s prop_idempotent_shellEscape_multiword s = s == (shellUnEscape . unwords . map shellEscape) s
{- Segements a list of filenames into groups that are all below the manximum {- Segments a list of filenames into groups that are all below the maximum
- command-line length limit. Does not preserve order. -} - command-line length limit. -}
segmentXargs :: [FilePath] -> [[FilePath]] segmentXargsOrdered :: [FilePath] -> [[FilePath]]
segmentXargs l = go l [] 0 [] 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 where
go [] c _ r = c:r go [] c _ r = (c:r)
go (f:fs) c accumlen 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 | otherwise = go fs (f:c) newlen r
where where
len = length f len = length f
newlen = accumlen + len newlen = accumlen + len
{- 10k of filenames per command, well under Linux's 20k limit; {- 10k of filenames per command, well under 100k limit
- allows room for other parameters etc. -} - of Linux (and OSX has a similar limit);
- allows room for other parameters etc. Also allows for
- eg, multibyte characters. -}
maxlen = 10240 maxlen = 10240

View File

@ -1,6 +1,6 @@
{- scheduled activities {- scheduled activities
- -
- Copyright 2013-2014 Joey Hess <joey@kitenet.net> - Copyright 2013-2014 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}

View File

@ -1,6 +1,6 @@
{- thread scheduling {- thread scheduling
- -
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
- Copyright 2011 Bas van Dijk & Roel van Dijk - Copyright 2011 Bas van Dijk & Roel van Dijk
- -
- License: BSD-2-clause - License: BSD-2-clause

View File

@ -9,11 +9,11 @@
module Utility.Tmp where module Utility.Tmp where
import Control.Exception (bracket)
import System.IO import System.IO
import System.Directory import System.Directory
import Control.Monad.IfElse import Control.Monad.IfElse
import System.FilePath import System.FilePath
import Control.Monad.IO.Class
import Utility.Exception import Utility.Exception
import Utility.FileSystemEncoding import Utility.FileSystemEncoding
@ -24,45 +24,52 @@ type Template = String
{- Runs an action like writeFile, writing to a temp file first and {- 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 - then moving it into place. The temp file is stored in the same
- directory as the final file to avoid cross-device renames. -} - directory as the final file to avoid cross-device renames. -}
viaTmp :: (FilePath -> String -> IO ()) -> FilePath -> String -> IO () viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> String -> m ()) -> FilePath -> String -> m ()
viaTmp a file content = do viaTmp a file content = bracketIO setup cleanup use
let (dir, base) = splitFileName file where
(dir, base) = splitFileName file
template = base ++ ".tmp"
setup = do
createDirectoryIfMissing True dir createDirectoryIfMissing True dir
(tmpfile, handle) <- openTempFile dir (base ++ ".tmp") openTempFile dir template
hClose handle cleanup (tmpfile, h) = do
_ <- tryIO $ hClose h
tryIO $ removeFile tmpfile
use (tmpfile, h) = do
liftIO $ hClose h
a tmpfile content a tmpfile content
rename tmpfile file liftIO $ rename tmpfile file
{- Runs an action with a tmp file located in the system's tmp directory {- Runs an action with a tmp file located in the system's tmp directory
- (or in "." if there is none) then removes the file. -} - (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 withTmpFile template a = do
tmpdir <- catchDefaultIO "." getTemporaryDirectory tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
withTmpFileIn tmpdir template a withTmpFileIn tmpdir template a
{- Runs an action with a tmp file located in the specified directory, {- Runs an action with a tmp file located in the specified directory,
- then removes the file. -} - 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 withTmpFileIn tmpdir template a = bracket create remove use
where where
create = openTempFile tmpdir template create = liftIO $ openTempFile tmpdir template
remove (name, handle) = do remove (name, h) = liftIO $ do
hClose handle hClose h
catchBoolIO (removeFile name >> return True) 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 {- 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 (or within "." if there is none), then removes the tmp
- directory and all its contents. -} - 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 withTmpDir template a = do
tmpdir <- catchDefaultIO "." getTemporaryDirectory tmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
withTmpDirIn tmpdir template a withTmpDirIn tmpdir template a
{- Runs an action with a tmp directory located within a specified directory, {- Runs an action with a tmp directory located within a specified directory,
- then removes the tmp directory and all its contents. -} - then removes the tmp directory and all its contents. -}
withTmpDirIn :: FilePath -> Template -> (FilePath -> IO a) -> IO a withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
withTmpDirIn tmpdir template = bracket create remove withTmpDirIn tmpdir template = bracketIO create remove
where where
remove d = whenM (doesDirectoryExist d) $ do remove d = whenM (doesDirectoryExist d) $ do
#if mingw32_HOST_OS #if mingw32_HOST_OS

View File

@ -1,6 +1,6 @@
{- user info {- user info
- -
- Copyright 2012 Joey Hess <joey@kitenet.net> - Copyright 2012 Joey Hess <id@joeyh.name>
- -
- License: BSD-2-clause - License: BSD-2-clause
-} -}