diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Applicative.hs | 2 | ||||
| -rw-r--r-- | Utility/Batch.hs | 3 | ||||
| -rw-r--r-- | Utility/CoProcess.hs | 8 | ||||
| -rw-r--r-- | Utility/Data.hs | 2 | ||||
| -rw-r--r-- | Utility/Directory.hs | 103 | ||||
| -rw-r--r-- | Utility/Env.hs | 2 | ||||
| -rw-r--r-- | Utility/Exception.hs | 4 | ||||
| -rw-r--r-- | Utility/FileMode.hs | 2 | ||||
| -rw-r--r-- | Utility/FileSystemEncoding.hs | 2 | ||||
| -rw-r--r-- | Utility/Format.hs | 2 | ||||
| -rw-r--r-- | Utility/Metered.hs | 2 | ||||
| -rw-r--r-- | Utility/Misc.hs | 2 | ||||
| -rw-r--r-- | Utility/Monad.hs | 2 | ||||
| -rw-r--r-- | Utility/Path.hs | 2 | ||||
| -rw-r--r-- | Utility/PosixFiles.hs | 2 | ||||
| -rw-r--r-- | Utility/Process.hs | 39 | ||||
| -rw-r--r-- | Utility/QuickCheck.hs | 2 | ||||
| -rw-r--r-- | Utility/Rsync.hs | 2 | ||||
| -rw-r--r-- | Utility/SafeCommand.hs | 3 | ||||
| -rw-r--r-- | Utility/ThreadScheduler.hs | 5 | ||||
| -rw-r--r-- | Utility/Tmp.hs | 23 | ||||
| -rw-r--r-- | Utility/URI.hs | 2 | ||||
| -rw-r--r-- | Utility/UserInfo.hs | 2 |
23 files changed, 153 insertions, 65 deletions
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs index 64400c8..fd8944b 100644 --- a/Utility/Applicative.hs +++ b/Utility/Applicative.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Applicative where diff --git a/Utility/Batch.hs b/Utility/Batch.hs index 3f21478..d6dadae 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -16,7 +16,6 @@ import Control.Concurrent.Async import System.Posix.Process #endif import qualified Control.Exception as E -import System.Process (env) {- Runs an operation, at batch priority. - diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index c113401..332c09d 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -3,7 +3,7 @@ - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -37,8 +37,8 @@ data CoProcessSpec = CoProcessSpec } start :: Int -> FilePath -> [String] -> Maybe [(String, String)] -> IO CoProcessHandle -start numrestarts cmd params env = do - s <- start' $ CoProcessSpec numrestarts cmd params env +start numrestarts cmd params environ = do + s <- start' $ CoProcessSpec numrestarts cmd params environ newMVar s start' :: CoProcessSpec -> IO CoProcessState @@ -62,7 +62,7 @@ query ch send receive = do s <- readMVar ch restartable s (send $ coProcessTo s) $ const $ restartable s (hFlush $ coProcessTo s) $ const $ - restartable s (receive $ coProcessFrom s) $ + restartable s (receive $ coProcessFrom s) return where restartable s a cont diff --git a/Utility/Data.hs b/Utility/Data.hs index 3592582..2df12b3 100644 --- a/Utility/Data.hs +++ b/Utility/Data.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Data where diff --git a/Utility/Directory.hs b/Utility/Directory.hs index f1bcfad..ade5ef8 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -1,8 +1,8 @@ -{- directory manipulation +{- directory traversal and manipulation - - Copyright 2011-2014 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -11,12 +11,20 @@ module Utility.Directory where import System.IO.Error import System.Directory -import Control.Exception (throw) +import Control.Exception (throw, bracket) 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 @@ -43,7 +51,7 @@ dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d - When the directory does not exist, no exception is thrown, - instead, [] is returned. -} dirContentsRecursive :: FilePath -> IO [FilePath] -dirContentsRecursive topdir = dirContentsRecursiveSkipping (const False) True topdir +dirContentsRecursive = dirContentsRecursiveSkipping (const False) True {- Skips directories whose basenames match the skipdir. -} dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath] @@ -133,3 +141,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/Utility/Env.hs b/Utility/Env.hs index 90ed58f..6763c24 100644 --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/Exception.hs b/Utility/Exception.hs index cf2c615..1fecf65 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -2,7 +2,7 @@ - - Copyright 2011-2012 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE ScopedTypeVariables #-} @@ -18,7 +18,7 @@ import Utility.Data {- Catches IO errors and returns a Bool -} catchBoolIO :: IO Bool -> IO Bool -catchBoolIO a = catchDefaultIO False a +catchBoolIO = catchDefaultIO False {- Catches IO errors and returns a Maybe -} catchMaybeIO :: IO a -> IO (Maybe a) diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index 9c15da8..c2ef683 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index 690942c..b81fdc5 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/Format.hs b/Utility/Format.hs index e7a2751..2a5ae5c 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -2,7 +2,7 @@ - - Copyright 2010, 2011 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Format ( diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 7ad9b12..0d94c1c 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -2,7 +2,7 @@ - - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE TypeSynonymInstances #-} diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 9c19df8..949f41e 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2011 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/Monad.hs b/Utility/Monad.hs index 1ba43c5..eba3c42 100644 --- a/Utility/Monad.hs +++ b/Utility/Monad.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2012 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Monad where diff --git a/Utility/Path.hs b/Utility/Path.hs index 570350d..99c9438 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2014 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE PackageImports, CPP #-} diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs index 23edc25..5abbb57 100644 --- a/Utility/PosixFiles.hs +++ b/Utility/PosixFiles.hs @@ -4,7 +4,7 @@ - - Copyright 2014 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/Process.hs b/Utility/Process.hs index 3f93dc2..1f722af 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -3,14 +3,14 @@ - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP, Rank2Types #-} module Utility.Process ( module X, - CreateProcess, + CreateProcess(..), StdHandle(..), readProcess, readProcessEnv, @@ -167,10 +167,10 @@ processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) processTranscript cmd opts input = processTranscript' cmd opts Nothing input processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool) +processTranscript' cmd opts environ input = do #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} -processTranscript' cmd opts environ input = do (readf, writef) <- createPipe readh <- fdToHandle readf writeh <- fdToHandle writef @@ -184,24 +184,13 @@ processTranscript' cmd opts environ input = do hClose writeh get <- mkreader readh - - -- now write and flush any input - case input of - Just s -> do - let inh = stdinHandle p - unless (null s) $ do - hPutStr inh s - hFlush inh - hClose inh - Nothing -> return () - + writeinput input p transcript <- get ok <- checkSuccessProcess pid return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} -processTranscript' cmd opts environ input = do p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit @@ -212,17 +201,9 @@ processTranscript' cmd opts environ input = do getout <- mkreader (stdoutHandle p) geterr <- mkreader (stderrHandle p) - - case input of - Just s -> do - let inh = stdinHandle p - unless (null s) $ do - hPutStr inh s - hFlush inh - hClose inh - Nothing -> return () - + writeinput input p transcript <- (++) <$> getout <*> geterr + ok <- checkSuccessProcess pid return (transcript, ok) #endif @@ -237,6 +218,14 @@ processTranscript' cmd opts environ input = do takeMVar v return s + writeinput (Just s) p = do + let inh = stdinHandle p + unless (null s) $ do + hPutStr inh s + hFlush inh + hClose inh + writeinput Nothing _ = return () + {- Runs a CreateProcessRunner, on a CreateProcess structure, that - is adjusted to pipe only from/to a single StdHandle, and passes - the resulting Handle to an action. -} diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 7f7234c..a498ee6 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -2,7 +2,7 @@ - - Copyright 2012-2014 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 82166f6..6038126 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.Rsync where diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index c8318ec..86e60db 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -2,14 +2,13 @@ - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} module Utility.SafeCommand where import System.Exit import Utility.Process -import System.Process (env) import Data.String.Utils import Control.Applicative import System.FilePath diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index dd88dc8..e6a81ae 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -3,7 +3,7 @@ - Copyright 2012, 2013 Joey Hess <joey@kitenet.net> - Copyright 2011 Bas van Dijk & Roel van Dijk - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -57,8 +57,7 @@ unboundDelay time = do waitForTermination :: IO () waitForTermination = do #ifdef mingw32_HOST_OS - runEvery (Seconds 600) $ - void getLine + forever $ threadDelaySeconds (Seconds 6000) #else lock <- newEmptyMVar let check sig = void $ diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs index f46e1a5..bed30bb 100644 --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -2,7 +2,7 @@ - - Copyright 2010-2013 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} @@ -25,13 +25,20 @@ type Template = String - 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 a file content = bracket setup cleanup use + where + (dir, base) = splitFileName file + template = base ++ ".tmp" + setup = do + createDirectoryIfMissing True dir + openTempFile dir template + cleanup (tmpfile, handle) = do + _ <- tryIO $ hClose handle + tryIO $ removeFile tmpfile + use (tmpfile, handle) = do + hClose handle + a tmpfile content + 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. -} diff --git a/Utility/URI.hs b/Utility/URI.hs index 39c2f22..30c6be3 100644 --- a/Utility/URI.hs +++ b/Utility/URI.hs @@ -2,7 +2,7 @@ - - Copyright 2014 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index 9c3bfd4..617c3e9 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -2,7 +2,7 @@ - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - Licensed under the GNU GPL version 3 or higher. + - License: BSD-2-clause -} {-# LANGUAGE CPP #-} |