summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
authorJoey Hess <joeyh@joeyh.name>2020-01-02 12:34:10 -0400
committerJoey Hess <joeyh@joeyh.name>2020-01-02 12:42:57 -0400
commit9df8a6eb9405dde4464d27133c04f5ee539a85de (patch)
tree8a7ac5f52be8679f8a2525515a0b2c1b715c99ad /Utility
parent16022a8b98f4bc134542e78a42538364d2f97d92 (diff)
downloadgit-repair-9df8a6eb9405dde4464d27133c04f5ee539a85de.tar.gz
merge from git-annex and relicense accordingly
Merge git library and utility from git-annex. The former is now relicensed AGPL, so git-repair as a whole becomes AGPL. For simplicity, I am relicensing the remainder of the code in git-repair AGPL as well, per the header changes in this commit. While that code is also technically available under the GPL license, as it's been released under that license before, changes going forward will be only released by me under the AGPL.
Diffstat (limited to 'Utility')
-rw-r--r--Utility/Applicative.hs6
-rw-r--r--Utility/Attoparsec.hs21
-rw-r--r--Utility/Batch.hs17
-rw-r--r--Utility/Data.hs5
-rw-r--r--Utility/Directory.hs93
-rw-r--r--Utility/DottedVersion.hs11
-rw-r--r--Utility/Env.hs33
-rw-r--r--Utility/Env/Basic.hs25
-rw-r--r--Utility/Env/Set.hs43
-rw-r--r--Utility/Exception.hs18
-rw-r--r--Utility/FileMode.hs3
-rw-r--r--Utility/FileSize.hs12
-rw-r--r--Utility/FileSystemEncoding.hs93
-rw-r--r--Utility/Format.hs10
-rw-r--r--Utility/HumanNumber.hs2
-rw-r--r--Utility/HumanTime.hs12
-rw-r--r--Utility/Metered.hs135
-rw-r--r--Utility/Misc.hs42
-rw-r--r--Utility/Monad.hs14
-rw-r--r--Utility/PartialPrelude.hs21
-rw-r--r--Utility/Path.hs92
-rw-r--r--Utility/PosixFiles.hs42
-rw-r--r--Utility/Process.hs91
-rw-r--r--Utility/QuickCheck.hs32
-rw-r--r--Utility/Rsync.hs51
-rw-r--r--Utility/SafeCommand.hs38
-rw-r--r--Utility/Split.hs11
-rw-r--r--Utility/ThreadScheduler.hs13
-rw-r--r--Utility/Tmp.hs61
-rw-r--r--Utility/Tmp/Dir.hs70
-rw-r--r--Utility/Tuple.hs6
-rw-r--r--Utility/UserInfo.hs17
32 files changed, 617 insertions, 523 deletions
diff --git a/Utility/Applicative.hs b/Utility/Applicative.hs
index fce3c04..fcd6932 100644
--- a/Utility/Applicative.hs
+++ b/Utility/Applicative.hs
@@ -5,7 +5,11 @@
- License: BSD-2-clause
-}
-module Utility.Applicative where
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Applicative (
+ (<$$>),
+) where
{- Like <$> , but supports one level of currying.
-
diff --git a/Utility/Attoparsec.hs b/Utility/Attoparsec.hs
new file mode 100644
index 0000000..bd20e8e
--- /dev/null
+++ b/Utility/Attoparsec.hs
@@ -0,0 +1,21 @@
+{- attoparsec utility functions
+ -
+ - Copyright 2019 Joey Hess <id@joeyh.name>
+ - Copyright 2007-2015 Bryan O'Sullivan
+ -
+ - License: BSD-3-clause
+ -}
+
+module Utility.Attoparsec where
+
+import qualified Data.Attoparsec.ByteString as A
+import qualified Data.ByteString as B
+
+-- | Parse and decode an unsigned octal number.
+--
+-- This parser does not accept a leading @\"0o\"@ string.
+octal :: Integral a => A.Parser a
+octal = B.foldl' step 0 `fmap` A.takeWhile1 isOctDigit
+ where
+ isOctDigit w = w >= 48 && w <= 55
+ step a w = a * 8 + fromIntegral (w - 48)
diff --git a/Utility/Batch.hs b/Utility/Batch.hs
index d96f9d3..1d66881 100644
--- a/Utility/Batch.hs
+++ b/Utility/Batch.hs
@@ -7,11 +7,18 @@
{-# LANGUAGE CPP #-}
-module Utility.Batch where
+module Utility.Batch (
+ batch,
+ BatchCommandMaker,
+ getBatchCommandMaker,
+ toBatchCommand,
+ batchCommand,
+ batchCommandEnv,
+) where
import Common
-#if defined(linux_HOST_OS) || defined(__ANDROID__)
+#if defined(linux_HOST_OS)
import Control.Concurrent.Async
import System.Posix.Process
#endif
@@ -29,7 +36,7 @@ import qualified Control.Exception as E
- systems, the action is simply ran.
-}
batch :: IO a -> IO a
-#if defined(linux_HOST_OS) || defined(__ANDROID__)
+#if defined(linux_HOST_OS)
batch a = wait =<< batchthread
where
batchthread = asyncBound $ do
@@ -51,11 +58,7 @@ getBatchCommandMaker = do
#ifndef mingw32_HOST_OS
nicers <- filterM (inPath . fst)
[ ("nice", [])
-#ifndef __ANDROID__
- -- Android's ionice does not allow specifying a command,
- -- so don't use it.
, ("ionice", ["-c3"])
-#endif
, ("nocache", [])
]
return $ \(command, params) ->
diff --git a/Utility/Data.hs b/Utility/Data.hs
index 27c0a82..5510845 100644
--- a/Utility/Data.hs
+++ b/Utility/Data.hs
@@ -7,7 +7,10 @@
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.Data where
+module Utility.Data (
+ firstJust,
+ eitherToMaybe,
+) where
{- First item in the list that is not Nothing. -}
firstJust :: Eq a => [Maybe a] -> Maybe a
diff --git a/Utility/Directory.hs b/Utility/Directory.hs
index 895581d..e2c6a94 100644
--- a/Utility/Directory.hs
+++ b/Utility/Directory.hs
@@ -18,15 +18,11 @@ import Control.Monad
import System.FilePath
import System.PosixCompat.Files
import Control.Applicative
-import Control.Concurrent
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe
import Prelude
-#ifdef mingw32_HOST_OS
-import qualified System.Win32 as Win32
-#else
-import qualified System.Posix as Posix
+#ifndef mingw32_HOST_OS
import Utility.SafeCommand
import Control.Monad.IfElse
#endif
@@ -158,90 +154,3 @@ nukeFile file = void $ tryWhenExists go
#else
go = removeFile file
#endif
-
-#ifndef mingw32_HOST_OS
-data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
-#else
-data DirectoryHandle = DirectoryHandle IsOpen Win32.HANDLE Win32.FindData (MVar ())
-#endif
-
-type IsOpen = MVar () -- full when the handle is open
-
-openDirectory :: FilePath -> IO DirectoryHandle
-openDirectory path = do
-#ifndef mingw32_HOST_OS
- dirp <- Posix.openDirStream path
- isopen <- newMVar ()
- return (DirectoryHandle isopen dirp)
-#else
- (h, fdat) <- Win32.findFirstFile (path </> "*")
- -- Indicate that the fdat contains a filename that readDirectory
- -- has not yet returned, by making the MVar be full.
- -- (There's always at least a "." entry.)
- alreadyhave <- newMVar ()
- isopen <- newMVar ()
- return (DirectoryHandle isopen h fdat alreadyhave)
-#endif
-
-closeDirectory :: DirectoryHandle -> IO ()
-#ifndef mingw32_HOST_OS
-closeDirectory (DirectoryHandle isopen dirp) =
- whenOpen isopen $
- Posix.closeDirStream dirp
-#else
-closeDirectory (DirectoryHandle isopen h _ alreadyhave) =
- whenOpen isopen $ do
- _ <- tryTakeMVar alreadyhave
- Win32.findClose h
-#endif
- where
- whenOpen :: IsOpen -> IO () -> IO ()
- whenOpen mv f = do
- v <- tryTakeMVar mv
- when (isJust v) f
-
-{- |Reads the next entry from the handle. Once the end of the directory
-is reached, returns Nothing and automatically closes the handle.
--}
-readDirectory :: DirectoryHandle -> IO (Maybe FilePath)
-#ifndef mingw32_HOST_OS
-readDirectory hdl@(DirectoryHandle _ dirp) = do
- e <- Posix.readDirStream dirp
- if null e
- then do
- closeDirectory hdl
- return Nothing
- else return (Just e)
-#else
-readDirectory hdl@(DirectoryHandle _ h fdat mv) = do
- -- If the MVar is full, then the filename in fdat has
- -- not yet been returned. Otherwise, need to find the next
- -- file.
- r <- tryTakeMVar mv
- case r of
- Just () -> getfn
- Nothing -> do
- more <- Win32.findNextFile h fdat
- if more
- then getfn
- else do
- closeDirectory hdl
- return Nothing
- where
- getfn = do
- filename <- Win32.getFindDataFileName fdat
- return (Just filename)
-#endif
-
--- True only when directory exists and contains nothing.
--- Throws exception if directory does not exist.
-isDirectoryEmpty :: FilePath -> IO Bool
-isDirectoryEmpty d = 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/DottedVersion.hs b/Utility/DottedVersion.hs
index 3198b1c..dff3717 100644
--- a/Utility/DottedVersion.hs
+++ b/Utility/DottedVersion.hs
@@ -7,7 +7,11 @@
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.DottedVersion where
+module Utility.DottedVersion (
+ DottedVersion,
+ fromDottedVersion,
+ normalize,
+) where
import Common
@@ -18,7 +22,10 @@ instance Ord DottedVersion where
compare (DottedVersion _ x) (DottedVersion _ y) = compare x y
instance Show DottedVersion where
- show (DottedVersion s _) = s
+ show = fromDottedVersion
+
+fromDottedVersion :: DottedVersion -> String
+fromDottedVersion (DottedVersion s _) = s
{- To compare dotted versions like 1.7.7 and 1.8, they are normalized to
- a somewhat arbitrary integer representation. -}
diff --git a/Utility/Env.hs b/Utility/Env.hs
index c56f4ec..9847326 100644
--- a/Utility/Env.hs
+++ b/Utility/Env.hs
@@ -8,7 +8,14 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.Env where
+module Utility.Env (
+ getEnv,
+ getEnvDefault,
+ getEnvironment,
+ addEntry,
+ addEntries,
+ delEntry,
+) where
#ifdef mingw32_HOST_OS
import Utility.Exception
@@ -16,7 +23,6 @@ import Control.Applicative
import Data.Maybe
import Prelude
import qualified System.Environment as E
-import qualified System.SetEnv
#else
import qualified System.Posix.Env as PE
#endif
@@ -42,29 +48,6 @@ getEnvironment = PE.getEnvironment
getEnvironment = E.getEnvironment
#endif
-{- Sets an environment variable. To overwrite an existing variable,
- - overwrite must be True.
- -
- - On Windows, setting a variable to "" unsets it. -}
-setEnv :: String -> String -> Bool -> IO ()
-#ifndef mingw32_HOST_OS
-setEnv var val overwrite = PE.setEnv var val overwrite
-#else
-setEnv var val True = System.SetEnv.setEnv var val
-setEnv var val False = do
- r <- getEnv var
- case r of
- Nothing -> setEnv var val True
- Just _ -> return ()
-#endif
-
-unsetEnv :: String -> IO ()
-#ifndef mingw32_HOST_OS
-unsetEnv = PE.unsetEnv
-#else
-unsetEnv = System.SetEnv.unsetEnv
-#endif
-
{- Adds the environment variable to the input environment. If already
- present in the list, removes the old value.
-
diff --git a/Utility/Env/Basic.hs b/Utility/Env/Basic.hs
new file mode 100644
index 0000000..db73827
--- /dev/null
+++ b/Utility/Env/Basic.hs
@@ -0,0 +1,25 @@
+{- portable environment variables, without any dependencies
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Env.Basic (
+ getEnv,
+ getEnvDefault,
+) where
+
+import Utility.Exception
+import Control.Applicative
+import Data.Maybe
+import Prelude
+import qualified System.Environment as E
+
+getEnv :: String -> IO (Maybe String)
+getEnv = catchMaybeIO . E.getEnv
+
+getEnvDefault :: String -> String -> IO String
+getEnvDefault var fallback = fromMaybe fallback <$> getEnv var
diff --git a/Utility/Env/Set.hs b/Utility/Env/Set.hs
new file mode 100644
index 0000000..f14674c
--- /dev/null
+++ b/Utility/Env/Set.hs
@@ -0,0 +1,43 @@
+{- portable environment variables
+ -
+ - Copyright 2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Env.Set (
+ setEnv,
+ unsetEnv,
+) where
+
+#ifdef mingw32_HOST_OS
+import qualified System.SetEnv
+import Utility.Env
+#else
+import qualified System.Posix.Env as PE
+#endif
+
+{- Sets an environment variable. To overwrite an existing variable,
+ - overwrite must be True.
+ -
+ - On Windows, setting a variable to "" unsets it. -}
+setEnv :: String -> String -> Bool -> IO ()
+#ifndef mingw32_HOST_OS
+setEnv var val overwrite = PE.setEnv var val overwrite
+#else
+setEnv var val True = System.SetEnv.setEnv var val
+setEnv var val False = do
+ r <- getEnv var
+ case r of
+ Nothing -> setEnv var val True
+ Just _ -> return ()
+#endif
+
+unsetEnv :: String -> IO ()
+#ifndef mingw32_HOST_OS
+unsetEnv = PE.unsetEnv
+#else
+unsetEnv = System.SetEnv.unsetEnv
+#endif
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index 67c2e85..bcadb78 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -5,7 +5,7 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Exception (
@@ -29,11 +29,7 @@ module Utility.Exception (
import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
import Control.Exception (SomeAsyncException)
-#endif
-#endif
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
@@ -46,15 +42,7 @@ import Utility.Data
- where there's a problem that the user is excpected to see in some
- circumstances. -}
giveup :: [Char] -> a
-#ifdef MIN_VERSION_base
-#if MIN_VERSION_base(4,9,0)
giveup = errorWithoutStackTrace
-#else
-giveup = error
-#endif
-#else
-giveup = error
-#endif
{- Catches IO errors and returns a Bool -}
catchBoolIO :: MonadCatch m => m Bool -> m Bool
@@ -95,11 +83,7 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)
catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchNonAsync a onerr = a `catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
-#ifdef MIN_VERSION_GLASGOW_HASKELL
-#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
, M.Handler (\ (e :: SomeAsyncException) -> throwM e)
-#endif
-#endif
, M.Handler (\ (e :: SomeException) -> onerr e)
]
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs
index 370bcf6..7d36c55 100644
--- a/Utility/FileMode.hs
+++ b/Utility/FileMode.hs
@@ -17,7 +17,7 @@ import Control.Monad
import System.PosixCompat.Types
import System.PosixCompat.Files
#ifndef mingw32_HOST_OS
-import System.Posix.Files
+import System.Posix.Files (symbolicLinkMode)
import Control.Monad.IO.Class (liftIO)
#endif
import Control.Monad.IO.Class (MonadIO)
@@ -69,6 +69,7 @@ otherGroupModes :: [FileMode]
otherGroupModes =
[ groupReadMode, otherReadMode
, groupWriteMode, otherWriteMode
+ , groupExecuteMode, otherExecuteMode
]
{- Removes the write bits from a file. -}
diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs
index 5f89cff..8544ad4 100644
--- a/Utility/FileSize.hs
+++ b/Utility/FileSize.hs
@@ -4,8 +4,13 @@
-}
{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.FileSize where
+module Utility.FileSize (
+ FileSize,
+ getFileSize,
+ getFileSize',
+) where
import System.PosixCompat.Files
#ifdef mingw32_HOST_OS
@@ -28,7 +33,10 @@ getFileSize f = fmap (fromIntegral . fileSize) (getFileStatus f)
getFileSize f = bracket (openFile f ReadMode) hClose hFileSize
#endif
-{- Gets the size of the file, when its FileStatus is already known. -}
+{- Gets the size of the file, when its FileStatus is already known.
+ -
+ - On windows, uses getFileSize. Otherwise, the FileStatus contains the
+ - size, so this does not do any work. -}
getFileSize' :: FilePath -> FileStatus -> IO FileSize
#ifndef mingw32_HOST_OS
getFileSize' _ s = return $ fromIntegral $ fileSize s
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index 444dc4a..f9e9814 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -12,12 +12,17 @@ module Utility.FileSystemEncoding (
useFileSystemEncoding,
fileEncoding,
withFilePath,
+ RawFilePath,
+ fromRawFilePath,
+ toRawFilePath,
+ decodeBL,
+ encodeBL,
decodeBS,
encodeBS,
- decodeW8,
- encodeW8,
- encodeW8NUL,
- decodeW8NUL,
+ decodeBL',
+ encodeBL',
+ decodeBS',
+ encodeBS',
truncateFilePath,
s2w8,
w82s,
@@ -32,8 +37,10 @@ import System.IO
import System.IO.Unsafe
import Data.Word
import Data.List
+import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
#ifdef mingw32_HOST_OS
+import qualified Data.ByteString.UTF8 as S8
import qualified Data.ByteString.Lazy.UTF8 as L8
#endif
@@ -103,31 +110,91 @@ _encodeFilePath fp = unsafePerformIO $ do
`catchNonAsync` (\_ -> return fp)
{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -}
-decodeBS :: L.ByteString -> FilePath
+decodeBL :: L.ByteString -> FilePath
#ifndef mingw32_HOST_OS
-decodeBS = encodeW8NUL . L.unpack
+decodeBL = encodeW8NUL . L.unpack
#else
{- On Windows, we assume that the ByteString is utf-8, since Windows
- only uses unicode for filenames. -}
-decodeBS = L8.toString
+decodeBL = L8.toString
#endif
{- Encodes a FilePath into a ByteString, applying the filesystem encoding. -}
-encodeBS :: FilePath -> L.ByteString
+encodeBL :: FilePath -> L.ByteString
#ifndef mingw32_HOST_OS
-encodeBS = L.pack . decodeW8NUL
+encodeBL = L.pack . decodeW8NUL
#else
-encodeBS = L8.fromString
+encodeBL = L8.fromString
#endif
+decodeBS :: S.ByteString -> FilePath
+#ifndef mingw32_HOST_OS
+decodeBS = encodeW8NUL . S.unpack
+#else
+decodeBS = S8.toString
+#endif
+
+encodeBS :: FilePath -> S.ByteString
+#ifndef mingw32_HOST_OS
+encodeBS = S.pack . decodeW8NUL
+#else
+encodeBS = S8.fromString
+#endif
+
+{- Faster version that assumes the string does not contain NUL;
+ - if it does it will be truncated before the NUL. -}
+decodeBS' :: S.ByteString -> FilePath
+#ifndef mingw32_HOST_OS
+decodeBS' = encodeW8 . S.unpack
+#else
+decodeBS' = S8.toString
+#endif
+
+encodeBS' :: FilePath -> S.ByteString
+#ifndef mingw32_HOST_OS
+encodeBS' = S.pack . decodeW8
+#else
+encodeBS' = S8.fromString
+#endif
+
+decodeBL' :: L.ByteString -> FilePath
+#ifndef mingw32_HOST_OS
+decodeBL' = encodeW8 . L.unpack
+#else
+decodeBL' = L8.toString
+#endif
+
+encodeBL' :: FilePath -> L.ByteString
+#ifndef mingw32_HOST_OS
+encodeBL' = L.pack . decodeW8
+#else
+encodeBL' = L8.fromString
+#endif
+
+{- Recent versions of the unix package have this alias; defined here
+ - for backwards compatibility. -}
+type RawFilePath = S.ByteString
+
+{- Note that the RawFilePath is assumed to never contain NUL,
+ - since filename's don't. This should only be used with actual
+ - RawFilePaths not arbitrary ByteString that may contain NUL. -}
+fromRawFilePath :: RawFilePath -> FilePath
+fromRawFilePath = decodeBS'
+
+{- Note that the FilePath is assumed to never contain NUL,
+ - since filename's don't. This should only be used with actual FilePaths
+ - not arbitrary String that may contain NUL. -}
+toRawFilePath :: FilePath -> RawFilePath
+toRawFilePath = encodeBS'
+
{- Converts a [Word8] to a FilePath, encoding using the filesystem encoding.
-
- - w82c produces a String, which may contain Chars that are invalid
+ - w82s 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.
+ - cannot contain embedded NUL, but Haskell Strings may.
-}
{-# NOINLINE encodeW8 #-}
encodeW8 :: [Word8] -> FilePath
@@ -135,8 +202,6 @@ encodeW8 w8 = unsafePerformIO $ do
enc <- Encoding.getFileSystemEncoding
GHC.withCString Encoding.char8 (w82s w8) $ GHC.peekCString enc
-{- Useful when you want the actual number of bytes that will be used to
- - represent the FilePath on disk. -}
decodeW8 :: FilePath -> [Word8]
decodeW8 = s2w8 . _encodeFilePath
diff --git a/Utility/Format.hs b/Utility/Format.hs
index 3670cd7..a2470fa 100644
--- a/Utility/Format.hs
+++ b/Utility/Format.hs
@@ -15,7 +15,7 @@ module Utility.Format (
) where
import Text.Printf (printf)
-import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord)
+import Data.Char (isAlphaNum, isOctDigit, isHexDigit, isSpace, chr, ord, isAscii)
import Data.Maybe (fromMaybe)
import Data.Word (Word8)
import Data.List (isPrefixOf)
@@ -176,12 +176,12 @@ encode_c' p = concatMap echar
{- For quickcheck.
-
- Encoding and then decoding roundtrips only when
- - the string does not contain high unicode, because eg,
- - both "\12345" and "\227\128\185" are encoded to "\343\200\271".
+ - the string is ascii because eg, both "\12345" and
+ - "\227\128\185" are encoded to "\343\200\271".
-
- - This property papers over the problem, by only testing chars < 256.
+ - This property papers over the problem, by only testing ascii.
-}
prop_encode_c_decode_c_roundtrip :: String -> Bool
prop_encode_c_decode_c_roundtrip s = s' == decode_c (encode_c s')
where
- s' = filter (\c -> ord c < 256) s
+ s' = filter isAscii s
diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs
index c3fede9..6143cef 100644
--- a/Utility/HumanNumber.hs
+++ b/Utility/HumanNumber.hs
@@ -5,7 +5,7 @@
- License: BSD-2-clause
-}
-module Utility.HumanNumber where
+module Utility.HumanNumber (showImprecise) where
{- Displays a fractional value as a string with a limited number
- of decimal digits. -}
diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs
index fe7cf22..01fbeac 100644
--- a/Utility/HumanTime.hs
+++ b/Utility/HumanTime.hs
@@ -60,15 +60,17 @@ parseDuration = maybe parsefail (return . Duration) . go 0
fromDuration :: Duration -> String
fromDuration Duration { durationSeconds = d }
| d == 0 = "0s"
- | otherwise = concatMap showunit $ go [] units d
+ | otherwise = concatMap showunit $ take 2 $ go [] units d
where
- showunit (u, n)
- | n > 0 = show n ++ [u]
- | otherwise = ""
+ showunit (u, n) = show n ++ [u]
go c [] _ = reverse c
go c ((u, n):us) v =
let (q,r) = v `quotRem` n
- in go ((u, q):c) us r
+ in if q > 0
+ then go ((u, q):c) us r
+ else if null c
+ then go c us r
+ else reverse c
units :: [(Char, Integer)]
units =
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index a5dda54..ec16e33 100644
--- a/Utility/Metered.hs
+++ b/Utility/Metered.hs
@@ -1,16 +1,48 @@
{- Metered IO and actions
-
- - Copyright 2012-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE TypeSynonymInstances, BangPatterns #-}
-module Utility.Metered where
+module Utility.Metered (
+ MeterUpdate,
+ nullMeterUpdate,
+ combineMeterUpdate,
+ BytesProcessed(..),
+ toBytesProcessed,
+ fromBytesProcessed,
+ addBytesProcessed,
+ zeroBytesProcessed,
+ withMeteredFile,
+ meteredWrite,
+ meteredWrite',
+ meteredWriteFile,
+ offsetMeterUpdate,
+ hGetContentsMetered,
+ hGetMetered,
+ defaultChunkSize,
+ watchFileSize,
+ OutputHandler(..),
+ ProgressParser,
+ commandMeter,
+ commandMeter',
+ demeterCommand,
+ demeterCommandEnv,
+ avoidProgress,
+ rateLimitMeterUpdate,
+ Meter,
+ mkMeter,
+ setMeterTotalSize,
+ updateMeter,
+ displayMeterHandle,
+ clearMeterHandle,
+ bandwidthMeter,
+) where
import Common
-import Utility.FileSystemEncoding
import Utility.Percentage
import Utility.DataUnits
import Utility.HumanTime
@@ -81,11 +113,6 @@ withMeteredFile :: FilePath -> MeterUpdate -> (L.ByteString -> IO a) -> IO a
withMeteredFile f meterupdate a = withBinaryFile f ReadMode $ \h ->
hGetContentsMetered h meterupdate >>= a
-{- Sends the content of a file to a Handle, updating the meter as it's
- - written. -}
-streamMeteredFile :: FilePath -> MeterUpdate -> Handle -> IO ()
-streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h
-
{- Writes a ByteString to a Handle, updating a meter as it's written. -}
meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO ()
meteredWrite meterupdate h = void . meteredWrite' meterupdate h
@@ -211,7 +238,14 @@ type ProgressParser = String -> (Maybe BytesProcessed, String)
- to update a meter.
-}
commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool
-commandMeter progressparser oh meterupdate cmd params =
+commandMeter progressparser oh meterupdate cmd params = do
+ ret <- commandMeter' progressparser oh meterupdate cmd params
+ return $ case ret of
+ Just ExitSuccess -> True
+ _ -> False
+
+commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode)
+commandMeter' progressparser oh meterupdate cmd params =
outputFilter cmd params Nothing
(feedprogress zeroBytesProcessed [])
handlestderr
@@ -224,7 +258,7 @@ commandMeter progressparser oh meterupdate cmd params =
unless (quietMode oh) $ do
S.hPut stdout b
hFlush stdout
- let s = encodeW8 (S.unpack b)
+ let s = decodeBS b
let (mbytes, buf') = progressparser (buf++s)
case mbytes of
Nothing -> feedprogress prev buf' h
@@ -246,9 +280,13 @@ demeterCommand :: OutputHandler -> FilePath -> [CommandParam] -> IO Bool
demeterCommand oh cmd params = demeterCommandEnv oh cmd params Nothing
demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
-demeterCommandEnv oh cmd params environ = outputFilter cmd params environ
- (\outh -> avoidProgress True outh stdouthandler)
- (\errh -> avoidProgress True errh $ stderrHandler oh)
+demeterCommandEnv oh cmd params environ = do
+ ret <- outputFilter cmd params environ
+ (\outh -> avoidProgress True outh stdouthandler)
+ (\errh -> avoidProgress True errh $ stderrHandler oh)
+ return $ case ret of
+ Just ExitSuccess -> True
+ _ -> False
where
stdouthandler l =
unless (quietMode oh) $
@@ -271,16 +309,15 @@ outputFilter
-> Maybe [(String, String)]
-> (Handle -> IO ())
-> (Handle -> IO ())
- -> IO Bool
-outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do
+ -> IO (Maybe ExitCode)
+outputFilter cmd params environ outfilter errfilter = catchMaybeIO $ do
(_, Just outh, Just errh, pid) <- createProcess p
{ std_out = CreatePipe
, std_err = CreatePipe
}
void $ async $ tryIO (outfilter outh) >> hClose outh
void $ async $ tryIO (errfilter errh) >> hClose errh
- ret <- checkSuccessProcess pid
- return ret
+ waitForProcess pid
where
p = (proc cmd (toCommand params))
{ env = environ }
@@ -288,14 +325,14 @@ outputFilter cmd params environ outfilter errfilter = catchBoolIO $ do
-- | Limit a meter to only update once per unit of time.
--
-- It's nice to display the final update to 100%, even if it comes soon
--- after a previous update. To make that happen, a total size has to be
--- provided.
-rateLimitMeterUpdate :: NominalDiffTime -> Maybe Integer -> MeterUpdate -> IO MeterUpdate
-rateLimitMeterUpdate delta totalsize meterupdate = do
+-- after a previous update. To make that happen, the Meter has to know
+-- its total size.
+rateLimitMeterUpdate :: NominalDiffTime -> Meter -> MeterUpdate -> IO MeterUpdate
+rateLimitMeterUpdate delta (Meter totalsizev _ _ _) meterupdate = do
lastupdate <- newMVar (toEnum 0 :: POSIXTime)
return $ mu lastupdate
where
- mu lastupdate n@(BytesProcessed i) = case totalsize of
+ mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case
Just t | i >= t -> meterupdate n
_ -> do
now <- getPOSIXTime
@@ -306,35 +343,38 @@ rateLimitMeterUpdate delta totalsize meterupdate = do
meterupdate n
else putMVar lastupdate prev
-data Meter = Meter (Maybe Integer) (MVar MeterState) (MVar String) RenderMeter DisplayMeter
+data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter
type MeterState = (BytesProcessed, POSIXTime)
-type DisplayMeter = MVar String -> String -> IO ()
+type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO ()
type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String
-- | Make a meter. Pass the total size, if it's known.
-mkMeter :: Maybe Integer -> RenderMeter -> DisplayMeter -> IO Meter
-mkMeter totalsize rendermeter displaymeter = Meter
- <$> pure totalsize
+mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter
+mkMeter totalsize displaymeter = Meter
+ <$> newMVar totalsize
<*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime)
<*> newMVar ""
- <*> pure rendermeter
<*> pure displaymeter
+setMeterTotalSize :: Meter -> Integer -> IO ()
+setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just
+
-- | Updates the meter, displaying it if necessary.
-updateMeter :: Meter -> BytesProcessed -> IO ()
-updateMeter (Meter totalsize sv bv rendermeter displaymeter) new = do
+updateMeter :: Meter -> MeterUpdate
+updateMeter (Meter totalsizev sv bv displaymeter) new = do
now <- getPOSIXTime
(old, before) <- swapMVar sv (new, now)
- when (old /= new) $
- displaymeter bv $
- rendermeter totalsize (old, before) (new, now)
+ when (old /= new) $ do
+ totalsize <- readMVar totalsizev
+ displaymeter bv totalsize (old, before) (new, now)
-- | Display meter to a Handle.
-displayMeterHandle :: Handle -> DisplayMeter
-displayMeterHandle h v s = do
+displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter
+displayMeterHandle h rendermeter v msize old new = do
+ let s = rendermeter msize old new
olds <- swapMVar v s
-- Avoid writing when the rendered meter has not changed.
when (olds /= s) $ do
@@ -344,29 +384,32 @@ displayMeterHandle h v s = do
-- | Clear meter displayed by displayMeterHandle.
clearMeterHandle :: Meter -> Handle -> IO ()
-clearMeterHandle (Meter _ _ v _ _) h = do
+clearMeterHandle (Meter _ _ v _) h = do
olds <- readMVar v
hPutStr h $ '\r' : replicate (length olds) ' ' ++ "\r"
hFlush h
-- | Display meter in the form:
--- 10% 300 KiB/s 16m40s
+-- 10% 1.3MiB 300 KiB/s 16m40s
-- or when total size is not known:
--- 1.3 MiB 300 KiB/s
+-- 1.3 MiB 300 KiB/s
bandwidthMeter :: RenderMeter
bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) =
unwords $ catMaybes
- [ Just percentoramount
- -- Pad enough for max width: "xxxx.xx KiB xxxx KiB/s"
- , Just $ replicate (23 - length percentoramount - length rate) ' '
+ [ Just percentamount
+ -- Pad enough for max width: "100% xxxx.xx KiB xxxx KiB/s"
+ , Just $ replicate (29 - length percentamount - length rate) ' '
, Just rate
, estimatedcompletion
]
where
- percentoramount = case mtotalsize of
- Just totalsize -> showPercentage 0 $
- percentage totalsize (min new totalsize)
- Nothing -> roughSize' memoryUnits True 2 new
+ amount = roughSize' memoryUnits True 2 new
+ percentamount = case mtotalsize of
+ Just totalsize ->
+ let p = showPercentage 0 $
+ percentage totalsize (min new totalsize)
+ in p ++ replicate (6 - length p) ' ' ++ amount
+ Nothing -> amount
rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s"
bytespersecond
| duration == 0 = fromIntegral transferred
@@ -377,5 +420,5 @@ bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now)
Just totalsize
| bytespersecond > 0 ->
Just $ fromDuration $ Duration $
- totalsize `div` bytespersecond
+ (totalsize - new) `div` bytespersecond
_ -> Nothing
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 2ae9928..2f1766e 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -5,10 +5,22 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.Misc where
+module Utility.Misc (
+ hGetContentsStrict,
+ readFileStrict,
+ separate,
+ firstLine,
+ firstLine',
+ segment,
+ segmentDelim,
+ massReplace,
+ hGetSomeString,
+ exitBool,
+
+ prop_segment_regressionTest,
+) where
import System.IO
import Control.Monad
@@ -16,11 +28,8 @@ import Foreign
import Data.Char
import Data.List
import System.Exit
-#ifndef mingw32_HOST_OS
-import System.Posix.Process (getAnyProcessStatus)
-import Utility.Exception
-#endif
import Control.Applicative
+import qualified Data.ByteString as S
import Prelude
{- A version of hgetContents that is not lazy. Ensures file is
@@ -49,6 +58,11 @@ separate c l = unbreak $ break c l
firstLine :: String -> String
firstLine = takeWhile (/= '\n')
+firstLine' :: S.ByteString -> S.ByteString
+firstLine' = S.takeWhile (/= nl)
+ where
+ nl = fromIntegral (ord '\n')
+
{- Splits a list into segments that are delimited by items matching
- a predicate. (The delimiters are not included in the segments.)
- Segments may be empty. -}
@@ -112,22 +126,6 @@ hGetSomeString h sz = do
peekbytes :: Int -> Ptr Word8 -> IO [Word8]
peekbytes len buf = mapM (peekElemOff buf) [0..pred len]
-{- Reaps any zombie processes that may be hanging around.
- -
- - Warning: Not thread safe. Anything that was expecting to wait
- - on a process and get back an exit status is going to be confused
- - if this reap gets there first. -}
-reapZombies :: IO ()
-#ifndef mingw32_HOST_OS
-reapZombies =
- -- throws an exception when there are no child processes
- catchDefaultIO Nothing (getAnyProcessStatus False True)
- >>= maybe (return ()) (const reapZombies)
-
-#else
-reapZombies = return ()
-#endif
-
exitBool :: Bool -> IO a
exitBool False = exitFailure
exitBool True = exitSuccess
diff --git a/Utility/Monad.hs b/Utility/Monad.hs
index ac75104..abe06f3 100644
--- a/Utility/Monad.hs
+++ b/Utility/Monad.hs
@@ -7,7 +7,19 @@
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.Monad where
+module Utility.Monad (
+ firstM,
+ getM,
+ anyM,
+ allM,
+ untilTrue,
+ ifM,
+ (<||>),
+ (<&&>),
+ observe,
+ after,
+ noop,
+) where
import Data.Maybe
import Control.Monad
diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs
index 47e9831..90c67ff 100644
--- a/Utility/PartialPrelude.hs
+++ b/Utility/PartialPrelude.hs
@@ -7,7 +7,18 @@
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.PartialPrelude where
+module Utility.PartialPrelude (
+ Utility.PartialPrelude.read,
+ Utility.PartialPrelude.head,
+ Utility.PartialPrelude.tail,
+ Utility.PartialPrelude.init,
+ Utility.PartialPrelude.last,
+ Utility.PartialPrelude.readish,
+ Utility.PartialPrelude.headMaybe,
+ Utility.PartialPrelude.lastMaybe,
+ Utility.PartialPrelude.beginning,
+ Utility.PartialPrelude.end,
+) where
import qualified Data.Maybe
@@ -38,11 +49,9 @@ last = Prelude.last
{- Attempts to read a value from a String.
-
- - Ignores leading/trailing whitespace, and throws away any trailing
- - text after the part that can be read.
- -
- - readMaybe is available in Text.Read in new versions of GHC,
- - but that one requires the entire string to be consumed.
+ - Unlike Text.Read.readMaybe, this ignores some trailing text
+ - after the part that can be read. However, if the trailing text looks
+ - like another readable value, it fails.
-}
readish :: Read a => String -> Maybe a
readish s = case reads s of
diff --git a/Utility/Path.hs b/Utility/Path.hs
index dc91ce5..ecc752c 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -5,10 +5,32 @@
- License: BSD-2-clause
-}
-{-# LANGUAGE PackageImports, CPP #-}
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.Path where
+module Utility.Path (
+ simplifyPath,
+ absPathFrom,
+ parentDir,
+ upFrom,
+ dirContains,
+ absPath,
+ relPathCwdToFile,
+ relPathDirToFile,
+ relPathDirToFileAbs,
+ segmentPaths,
+ runSegmentPaths,
+ relHome,
+ inPath,
+ searchPath,
+ dotfile,
+ sanitizeFilePath,
+ splitShortExtensions,
+
+ prop_upFrom_basics,
+ prop_relPathDirToFile_basics,
+ prop_relPathDirToFile_regressionTest,
+) where
import System.FilePath
import Data.List
@@ -17,17 +39,11 @@ import Data.Char
import Control.Applicative
import Prelude
-#ifdef mingw32_HOST_OS
-import qualified System.FilePath.Posix as Posix
-#else
-import System.Posix.Files
-import Utility.Exception
-#endif
-
import Utility.Monad
import Utility.UserInfo
import Utility.Directory
import Utility.Split
+import Utility.FileSystemEncoding
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
@@ -97,7 +113,10 @@ prop_upFrom_basics dir
- are all equivilant.
-}
dirContains :: FilePath -> FilePath -> Bool
-dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
+dirContains a b = a == b
+ || a' == b'
+ || (addTrailingPathSeparator a') `isPrefixOf` b'
+ || a' == "." && normalise ("." </> b') == b'
where
a' = norm a
b' = norm b
@@ -185,20 +204,21 @@ prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
- 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 :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = found : segmentPaths ls rest
where
(found, rest) = if length ls < 100
- then partition (l `dirContains`) new
- else break (\p -> not (l `dirContains` p)) new
+ then partition inl new
+ else break (not . inl) new
+ inl f = fromRawFilePath l `dirContains` fromRawFilePath f
{- 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
- the case of git file list commands, that assumption tends to hold.
-}
-runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
+runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]]
runSegmentPaths a paths = segmentPaths paths <$> a paths
{- Converts paths in the home directory to use ~/ -}
@@ -247,50 +267,6 @@ dotfile file
where
f = takeFileName file
-{- Converts a DOS style path to a msys2 style path. Only on Windows.
- - Any trailing '\' is preserved as a trailing '/'
- -
- - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
- -
- - The virtual filesystem contains:
- - /c, /d, ... mount points for Windows drives
- -}
-toMSYS2Path :: FilePath -> FilePath
-#ifndef mingw32_HOST_OS
-toMSYS2Path = id
-#else
-toMSYS2Path p
- | null drive = recombine parts
- | otherwise = recombine $ "/" : driveletter drive : parts
- where
- (drive, p') = splitDrive p
- parts = splitDirectories p'
- driveletter = map toLower . takeWhile (/= ':')
- recombine = fixtrailing . Posix.joinPath
- fixtrailing s
- | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
- | otherwise = s
-#endif
-
-{- Maximum size to use for a file in a specified directory.
- -
- - Many systems have a 255 byte limit to the name of a file,
- - so that's taken as the max if the system has a larger limit, or has no
- - limit.
- -}
-fileNameLengthLimit :: FilePath -> IO Int
-#ifdef mingw32_HOST_OS
-fileNameLengthLimit _ = return 255
-#else
-fileNameLengthLimit dir = do
- -- getPathVar can fail due to statfs(2) overflow
- l <- catchDefaultIO 0 $
- fromIntegral <$> getPathVar dir FileNameLimit
- if l <= 0
- then return 255
- else return $ minimum [l, 255]
-#endif
-
{- Given a string that we'd like to use as the basis for FilePath, but that
- was provided by a third party and is not to be trusted, returns the closest
- sane FilePath.
diff --git a/Utility/PosixFiles.hs b/Utility/PosixFiles.hs
deleted file mode 100644
index 37253da..0000000
--- a/Utility/PosixFiles.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{- POSIX files (and compatablity wrappers).
- -
- - This is like System.PosixCompat.Files, but with a few fixes.
- -
- - Copyright 2014 Joey Hess <id@joeyh.name>
- -
- - License: BSD-2-clause
- -}
-
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Utility.PosixFiles (
- module X,
- rename
-) where
-
-import System.PosixCompat.Files as X hiding (rename)
-
-#ifndef mingw32_HOST_OS
-import System.Posix.Files (rename)
-#else
-import qualified System.Win32.File as Win32
-import qualified System.Win32.HardLink as Win32
-#endif
-
-{- System.PosixCompat.Files.rename on Windows calls renameFile,
- - so cannot rename directories.
- -
- - Instead, use Win32 moveFile, which can. It needs to be told to overwrite
- - any existing file. -}
-#ifdef mingw32_HOST_OS
-rename :: FilePath -> FilePath -> IO ()
-rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING
-#endif
-
-{- System.PosixCompat.Files.createLink throws an error, but windows
- - does support hard links. -}
-#ifdef mingw32_HOST_OS
-createLink :: FilePath -> FilePath -> IO ()
-createLink = Win32.createHardLink
-#endif
diff --git a/Utility/Process.hs b/Utility/Process.hs
index 6d981cb..af3a5f4 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -24,11 +24,10 @@ module Utility.Process (
createProcessSuccess,
createProcessChecked,
createBackgroundProcess,
- processTranscript,
- processTranscript',
withHandle,
withIOHandles,
withOEHandles,
+ withNullHandle,
withQuietOutput,
feedWithQuietOutput,
createProcess,
@@ -54,13 +53,6 @@ import System.Log.Logger
import Control.Concurrent
import qualified Control.Exception as E
import Control.Monad
-#ifndef mingw32_HOST_OS
-import qualified System.Posix.IO
-#else
-import Control.Applicative
-#endif
-import Data.Maybe
-import Prelude
type CreateProcessRunner = forall a. CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a
@@ -170,68 +162,6 @@ createProcessChecked checker p a = do
createBackgroundProcess :: CreateProcessRunner
createBackgroundProcess p a = a =<< createProcess p
--- | Runs a process, optionally feeding it some input, and
--- returns a transcript combining its stdout and stderr, and
--- whether it succeeded or failed.
-processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
-processTranscript cmd opts = processTranscript' (proc cmd opts)
-
-processTranscript' :: CreateProcess -> Maybe String -> IO (String, Bool)
-processTranscript' cp input = do
-#ifndef mingw32_HOST_OS
-{- This implementation interleves stdout and stderr in exactly the order
- - the process writes them. -}
- (readf, writef) <- System.Posix.IO.createPipe
- readh <- System.Posix.IO.fdToHandle readf
- writeh <- System.Posix.IO.fdToHandle writef
- p@(_, _, _, pid) <- createProcess $ cp
- { std_in = if isJust input then CreatePipe else Inherit
- , std_out = UseHandle writeh
- , std_err = UseHandle writeh
- }
- hClose writeh
-
- get <- mkreader readh
- writeinput input p
- transcript <- get
-
- ok <- checkSuccessProcess pid
- return (transcript, ok)
-#else
-{- This implementation for Windows puts stderr after stdout. -}
- p@(_, _, _, pid) <- createProcess $ cp
- { std_in = if isJust input then CreatePipe else Inherit
- , std_out = CreatePipe
- , std_err = CreatePipe
- }
-
- getout <- mkreader (stdoutHandle p)
- geterr <- mkreader (stderrHandle p)
- writeinput input p
- transcript <- (++) <$> getout <*> geterr
-
- ok <- checkSuccessProcess pid
- return (transcript, ok)
-#endif
- where
- mkreader h = do
- s <- hGetContents h
- v <- newEmptyMVar
- void $ forkIO $ do
- void $ E.evaluate (length s)
- putMVar v ()
- return $ do
- takeMVar v
- return s
-
- writeinput (Just s) p = do
- let inh = stdinHandle p
- unless (null s) $ do
- hPutStr inh s
- hFlush inh
- hClose inh
- writeinput Nothing _ = return ()
-
-- | Runs a CreateProcessRunner, on a CreateProcess structure, that
-- is adjusted to pipe only from/to a single StdHandle, and passes
-- the resulting Handle to an action.
@@ -248,13 +178,10 @@ withHandle h creator p a = creator p' $ a . select
, std_out = Inherit
, std_err = Inherit
}
- (select, p')
- | h == StdinHandle =
- (stdinHandle, base { std_in = CreatePipe })
- | h == StdoutHandle =
- (stdoutHandle, base { std_out = CreatePipe })
- | h == StderrHandle =
- (stderrHandle, base { std_err = CreatePipe })
+ (select, p') = case h of
+ StdinHandle -> (stdinHandle, base { std_in = CreatePipe })
+ StdoutHandle -> (stdoutHandle, base { std_out = CreatePipe })
+ StderrHandle -> (stderrHandle, base { std_err = CreatePipe })
-- | Like withHandle, but passes (stdin, stdout) handles to the action.
withIOHandles
@@ -284,13 +211,16 @@ withOEHandles creator p a = creator p' $ a . oeHandles
, std_err = CreatePipe
}
+withNullHandle :: (Handle -> IO a) -> IO a
+withNullHandle = withFile devNull WriteMode
+
-- | Forces the CreateProcessRunner to run quietly;
-- both stdout and stderr are discarded.
withQuietOutput
:: CreateProcessRunner
-> CreateProcess
-> IO ()
-withQuietOutput creator p = withFile devNull WriteMode $ \nullh -> do
+withQuietOutput creator p = withNullHandle $ \nullh -> do
let p' = p
{ std_out = UseHandle nullh
, std_err = UseHandle nullh
@@ -316,7 +246,8 @@ devNull :: FilePath
#ifndef mingw32_HOST_OS
devNull = "/dev/null"
#else
-devNull = "NUL"
+-- Use device namespace to prevent GHC from rewriting path
+devNull = "\\\\.\\NUL"
#endif
-- | Extract a desired handle from createProcess's tuple.
diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs
index e89d103..b0a39f3 100644
--- a/Utility/QuickCheck.hs
+++ b/Utility/QuickCheck.hs
@@ -6,7 +6,7 @@
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE TypeSynonymInstances, CPP #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module Utility.QuickCheck
( module X
@@ -15,29 +15,24 @@ module Utility.QuickCheck
import Test.QuickCheck as X
import Data.Time.Clock.POSIX
+import Data.Ratio
import System.Posix.Types
-#if ! MIN_VERSION_QuickCheck(2,8,2)
-import qualified Data.Map as M
-import qualified Data.Set as S
-#endif
-import Control.Applicative
+import Data.List.NonEmpty (NonEmpty(..))
import Prelude
-#if ! MIN_VERSION_QuickCheck(2,8,2)
-instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where
- arbitrary = M.fromList <$> arbitrary
-
-instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where
- arbitrary = S.fromList <$> arbitrary
-#endif
-
-{- Times before the epoch are excluded. -}
+{- Times before the epoch are excluded. Half with decimal and half without. -}
instance Arbitrary POSIXTime where
- arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral
+ arbitrary = do
+ n <- nonNegative arbitrarySizedBoundedIntegral :: Gen Int
+ d <- nonNegative arbitrarySizedIntegral
+ withd <- arbitrary
+ return $ if withd
+ then fromIntegral n + fromRational (1 % max d 1)
+ else fromIntegral n
{- Pids are never negative, or 0. -}
instance Arbitrary ProcessID where
- arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0)
+ arbitrary = positive arbitrarySizedBoundedIntegral
{- Inodes are never negative. -}
instance Arbitrary FileID where
@@ -47,6 +42,9 @@ instance Arbitrary FileID where
instance Arbitrary FileOffset where
arbitrary = nonNegative arbitrarySizedIntegral
+instance Arbitrary l => Arbitrary (NonEmpty l) where
+ arbitrary = (:|) <$> arbitrary <*> arbitrary
+
nonNegative :: (Num a, Ord a) => Gen a -> Gen a
nonNegative g = g `suchThat` (>= 0)
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index f190b40..c6881b7 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -7,12 +7,26 @@
{-# LANGUAGE CPP #-}
-module Utility.Rsync where
+module Utility.Rsync (
+ rsyncShell,
+ rsyncServerSend,
+ rsyncServerReceive,
+ rsyncUseDestinationPermissions,
+ rsync,
+ rsyncUrlIsShell,
+ rsyncUrlIsPath,
+ rsyncProgress,
+ filterRsyncSafeOptions,
+) where
import Common
import Utility.Metered
import Utility.Tuple
+#ifdef mingw32_HOST_OS
+import qualified System.FilePath.Posix as Posix
+#endif
+
import Data.Char
import System.Console.GetOpt
@@ -99,7 +113,16 @@ rsyncUrlIsPath s
- The params must enable rsync's --progress mode for this to work.
-}
rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool
-rsyncProgress oh meter = commandMeter parseRsyncProgress oh meter "rsync" . rsyncParamsFixup
+rsyncProgress oh meter ps =
+ commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case
+ Just ExitSuccess -> return True
+ Just (ExitFailure exitcode) -> do
+ when (exitcode /= 1) $
+ hPutStrLn stderr $ "rsync exited " ++ show exitcode
+ return False
+ Nothing -> do
+ hPutStrLn stderr $ "unable to run rsync"
+ return False
{- Strategy: Look for chunks prefixed with \r (rsync writes a \r before
- the first progress output, and each thereafter). The first number
@@ -139,3 +162,27 @@ filterRsyncSafeOptions = fst3 . getOpt Permute
[ Option [] ["bwlimit"] (reqArgLong "bwlimit") "" ]
where
reqArgLong x = ReqArg (\v -> "--" ++ x ++ "=" ++ v) ""
+
+{- Converts a DOS style path to a msys2 style path. Only on Windows.
+ - Any trailing '\' is preserved as a trailing '/'
+ -
+ - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
+ -
+ - The virtual filesystem contains:
+ - /c, /d, ... mount points for Windows drives
+ -}
+#ifdef mingw32_HOST_OS
+toMSYS2Path :: FilePath -> FilePath
+toMSYS2Path p
+ | null drive = recombine parts
+ | otherwise = recombine $ "/" : driveletter drive : parts
+ where
+ (drive, p') = splitDrive p
+ parts = splitDirectories p'
+ driveletter = map toLower . takeWhile (/= ':')
+ recombine = fixtrailing . Posix.joinPath
+ fixtrailing s
+ | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
+ | otherwise = s
+#endif
+
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index eb34d3d..19d5f20 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -7,7 +7,23 @@
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.SafeCommand where
+module Utility.SafeCommand (
+ CommandParam(..),
+ toCommand,
+ boolSystem,
+ boolSystem',
+ boolSystemEnv,
+ safeSystem,
+ safeSystem',
+ safeSystemEnv,
+ shellWrap,
+ shellEscape,
+ shellUnEscape,
+ segmentXargsOrdered,
+ segmentXargsUnordered,
+ prop_isomorphic_shellEscape,
+ prop_isomorphic_shellEscape_multiword,
+) where
import System.Exit
import Utility.Process
@@ -27,19 +43,21 @@ data CommandParam
-- | Used to pass a list of CommandParams to a function that runs
-- a command and expects Strings. -}
toCommand :: [CommandParam] -> [String]
-toCommand = map unwrap
+toCommand = map toCommand'
+
+toCommand' :: CommandParam -> String
+toCommand' (Param s) = s
+-- Files that start with a non-alphanumeric that is not a path
+-- separator are modified to avoid the command interpreting them as
+-- options or other special constructs.
+toCommand' (File s@(h:_))
+ | isAlphaNum h || h `elem` pathseps = s
+ | otherwise = "./" ++ s
where
- unwrap (Param s) = s
- -- Files that start with a non-alphanumeric that is not a path
- -- separator are modified to avoid the command interpreting them as
- -- options or other special constructs.
- unwrap (File s@(h:_))
- | isAlphaNum h || h `elem` pathseps = s
- | otherwise = "./" ++ s
- unwrap (File s) = s
-- '/' is explicitly included because it's an alternative
-- path separator on Windows.
pathseps = pathSeparator:"./"
+toCommand' (File s) = s
-- | Run a system command, and returns True or False if it succeeded or failed.
--
diff --git a/Utility/Split.hs b/Utility/Split.hs
index decfe7d..028218e 100644
--- a/Utility/Split.hs
+++ b/Utility/Split.hs
@@ -7,7 +7,12 @@
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.Split where
+module Utility.Split (
+ split,
+ splitc,
+ replace,
+ dropFromEnd,
+) where
import Data.List (intercalate)
import Data.List.Split (splitOn)
@@ -28,3 +33,7 @@ splitc c s = case break (== c) s of
-- | same as Data.List.Utils.replace
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace old new = intercalate new . split old
+
+-- | Only traverses the list once while dropping the last n items.
+dropFromEnd :: Int -> [a] -> [a]
+dropFromEnd n l = zipWith const l (drop n l)
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
index da05e99..ef69ead 100644
--- a/Utility/ThreadScheduler.hs
+++ b/Utility/ThreadScheduler.hs
@@ -8,7 +8,14 @@
{-# LANGUAGE CPP #-}
-module Utility.ThreadScheduler where
+module Utility.ThreadScheduler (
+ Seconds(..),
+ Microseconds,
+ runEvery,
+ threadDelaySeconds,
+ waitForTermination,
+ oneSecond,
+) where
import Control.Monad
import Control.Concurrent
@@ -18,10 +25,8 @@ import System.Posix.IO
#endif
#ifndef mingw32_HOST_OS
import System.Posix.Signals
-#ifndef __ANDROID__
import System.Posix.Terminal
#endif
-#endif
newtype Seconds = Seconds { fromSeconds :: Int }
deriving (Eq, Ord, Show)
@@ -63,10 +68,8 @@ waitForTermination = do
let check sig = void $
installHandler sig (CatchOnce $ putMVar lock ()) Nothing
check softwareTermination
-#ifndef __ANDROID__
whenM (queryTerminal stdInput) $
check keyboardSignal
-#endif
takeMVar lock
#endif
diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs
index 7255c14..6ee592b 100644
--- a/Utility/Tmp.hs
+++ b/Utility/Tmp.hs
@@ -1,4 +1,4 @@
-{- Temporary files and directories.
+{- Temporary files.
-
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
-
@@ -8,17 +8,19 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Utility.Tmp where
+module Utility.Tmp (
+ Template,
+ viaTmp,
+ withTmpFile,
+ withTmpFileIn,
+ relatedTemplate,
+) where
import System.IO
-import Control.Monad.IfElse
import System.FilePath
import System.Directory
import Control.Monad.IO.Class
import System.PosixCompat.Files
-#ifndef mingw32_HOST_OS
-import System.Posix.Temp (mkdtemp)
-#endif
import Utility.Exception
import Utility.FileSystemEncoding
@@ -32,7 +34,7 @@ viaTmp :: (MonadMask m, MonadIO m) => (FilePath -> v -> m ()) -> FilePath -> v -
viaTmp a file content = bracketIO setup cleanup use
where
(dir, base) = splitFileName file
- template = base ++ ".tmp"
+ template = relatedTemplate (base ++ ".tmp")
setup = do
createDirectoryIfMissing True dir
openTempFile dir template
@@ -62,51 +64,6 @@ withTmpFileIn tmpdir template a = bracket create remove use
catchBoolIO (removeFile name >> return True)
use (name, h) = a name h
-{- Runs an action with a tmp directory located within the system's tmp
- - directory (or within "." if there is none), then removes the tmp
- - directory and all its contents. -}
-withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
-withTmpDir template a = do
- topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
-#ifndef mingw32_HOST_OS
- -- Use mkdtemp to create a temp directory securely in /tmp.
- bracket
- (liftIO $ mkdtemp $ topleveltmpdir </> template)
- removeTmpDir
- a
-#else
- withTmpDirIn topleveltmpdir template a
-#endif
-
-{- Runs an action with a tmp directory located within a specified directory,
- - then removes the tmp directory and all its contents. -}
-withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
-withTmpDirIn tmpdir template = bracketIO create removeTmpDir
- where
- create = do
- createDirectoryIfMissing True tmpdir
- makenewdir (tmpdir </> template) (0 :: Int)
- makenewdir t n = do
- let dir = t ++ "." ++ show n
- catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
- createDirectory dir
- return dir
-
-{- Deletes the entire contents of the the temporary directory, if it
- - exists. -}
-removeTmpDir :: MonadIO m => FilePath -> m ()
-removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
-#if mingw32_HOST_OS
- -- Windows will often refuse to delete a file
- -- after a process has just written to it and exited.
- -- Because it's crap, presumably. So, ignore failure
- -- to delete the temp directory.
- _ <- tryIO $ removeDirectoryRecursive tmpdir
- return ()
-#else
- removeDirectoryRecursive tmpdir
-#endif
-
{- It's not safe to use a FilePath of an existing file as the template
- for openTempFile, because if the FilePath is really long, the tmpfile
- will be longer, and may exceed the maximum filename length.
diff --git a/Utility/Tmp/Dir.hs b/Utility/Tmp/Dir.hs
new file mode 100644
index 0000000..c68ef86
--- /dev/null
+++ b/Utility/Tmp/Dir.hs
@@ -0,0 +1,70 @@
+{- Temporary directories
+ -
+ - Copyright 2010-2013 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.Tmp.Dir (
+ withTmpDir,
+ withTmpDirIn,
+) where
+
+import Control.Monad.IfElse
+import System.FilePath
+import System.Directory
+import Control.Monad.IO.Class
+#ifndef mingw32_HOST_OS
+import System.Posix.Temp (mkdtemp)
+#endif
+
+import Utility.Exception
+import Utility.Tmp (Template)
+
+{- Runs an action with a tmp directory located within the system's tmp
+ - directory (or within "." if there is none), then removes the tmp
+ - directory and all its contents. -}
+withTmpDir :: (MonadMask m, MonadIO m) => Template -> (FilePath -> m a) -> m a
+withTmpDir template a = do
+ topleveltmpdir <- liftIO $ catchDefaultIO "." getTemporaryDirectory
+#ifndef mingw32_HOST_OS
+ -- Use mkdtemp to create a temp directory securely in /tmp.
+ bracket
+ (liftIO $ mkdtemp $ topleveltmpdir </> template)
+ removeTmpDir
+ a
+#else
+ withTmpDirIn topleveltmpdir template a
+#endif
+
+{- Runs an action with a tmp directory located within a specified directory,
+ - then removes the tmp directory and all its contents. -}
+withTmpDirIn :: (MonadMask m, MonadIO m) => FilePath -> Template -> (FilePath -> m a) -> m a
+withTmpDirIn tmpdir template = bracketIO create removeTmpDir
+ where
+ create = do
+ createDirectoryIfMissing True tmpdir
+ makenewdir (tmpdir </> template) (0 :: Int)
+ makenewdir t n = do
+ let dir = t ++ "." ++ show n
+ catchIOErrorType AlreadyExists (const $ makenewdir t $ n + 1) $ do
+ createDirectory dir
+ return dir
+
+{- Deletes the entire contents of the the temporary directory, if it
+ - exists. -}
+removeTmpDir :: MonadIO m => FilePath -> m ()
+removeTmpDir tmpdir = liftIO $ whenM (doesDirectoryExist tmpdir) $ do
+#if mingw32_HOST_OS
+ -- Windows will often refuse to delete a file
+ -- after a process has just written to it and exited.
+ -- Because it's crap, presumably. So, ignore failure
+ -- to delete the temp directory.
+ _ <- tryIO $ removeDirectoryRecursive tmpdir
+ return ()
+#else
+ removeDirectoryRecursive tmpdir
+#endif
diff --git a/Utility/Tuple.hs b/Utility/Tuple.hs
index 25c6e8f..9638bcc 100644
--- a/Utility/Tuple.hs
+++ b/Utility/Tuple.hs
@@ -5,7 +5,11 @@
- License: BSD-2-clause
-}
-module Utility.Tuple where
+module Utility.Tuple (
+ fst3,
+ snd3,
+ thd3,
+) where
fst3 :: (a,b,c) -> a
fst3 (a,_,_) = a
diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs
index d504fa5..17ce8db 100644
--- a/Utility/UserInfo.hs
+++ b/Utility/UserInfo.hs
@@ -14,7 +14,7 @@ module Utility.UserInfo (
myUserGecos,
) where
-import Utility.Env
+import Utility.Env.Basic
import Utility.Exception
#ifndef mingw32_HOST_OS
import Utility.Data
@@ -47,8 +47,8 @@ myUserName = myVal env userName
#endif
myUserGecos :: IO (Maybe String)
--- userGecos crashes on Android and is not available on Windows.
-#if defined(__ANDROID__) || defined(mingw32_HOST_OS)
+-- userGecos is not available on Windows.
+#if defined(mingw32_HOST_OS)
myUserGecos = return Nothing
#else
myUserGecos = eitherToMaybe <$> myVal [] userGecos
@@ -57,10 +57,13 @@ myUserGecos = eitherToMaybe <$> myVal [] userGecos
myVal :: [String] -> (UserEntry -> String) -> IO (Either String String)
myVal envvars extract = go envvars
where
+ go [] = either (const $ envnotset) (Right . extract) <$> get
+ go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
#ifndef mingw32_HOST_OS
- go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)
+ -- This may throw an exception if the system doesn't have a
+ -- passwd file etc; don't let it crash.
+ get = tryNonAsync $ getUserEntryForID =<< getEffectiveUserID
#else
- go [] = return $ either Left (Right . extract) $
- Left ("environment not set: " ++ show envvars)
+ get = return envnotset
#endif
- go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v
+ envnotset = Left ("environment not set: " ++ show envvars)