diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/FileMode.hs | 40 | ||||
| -rw-r--r-- | Utility/FileSystemEncoding.hs | 43 | ||||
| -rw-r--r-- | Utility/Misc.hs | 12 | ||||
| -rw-r--r-- | Utility/Path.hs | 1 | ||||
| -rw-r--r-- | Utility/Process.hs | 4 | ||||
| -rw-r--r-- | Utility/QuickCheck.hs | 4 | ||||
| -rw-r--r-- | Utility/Rsync.hs | 5 | ||||
| -rw-r--r-- | Utility/ThreadScheduler.hs | 7 | ||||
| -rw-r--r-- | Utility/URI.hs | 18 |
9 files changed, 103 insertions, 31 deletions
diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index b17cadc..9c15da8 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -9,15 +9,18 @@ module Utility.FileMode where -import Common - +import System.IO +import Control.Monad import Control.Exception (bracket) import System.PosixCompat.Types +import Utility.PosixFiles #ifndef mingw32_HOST_OS import System.Posix.Files #endif import Foreign (complement) +import Utility.Exception + {- Applies a conversion function to a file's mode. -} modifyFileMode :: FilePath -> (FileMode -> FileMode) -> IO () modifyFileMode f convert = void $ modifyFileMode' f convert @@ -56,6 +59,12 @@ readModes = [ownerReadMode, groupReadMode, otherReadMode] executeModes :: [FileMode] executeModes = [ownerExecuteMode, groupExecuteMode, otherExecuteMode] +otherGroupModes :: [FileMode] +otherGroupModes = + [ groupReadMode, otherReadMode + , groupWriteMode, otherWriteMode + ] + {- Removes the write bits from a file. -} preventWrite :: FilePath -> IO () preventWrite f = modifyFileMode f $ removeModes writeModes @@ -99,13 +108,20 @@ noUmask :: FileMode -> IO a -> IO a #ifndef mingw32_HOST_OS noUmask mode a | mode == stdFileMode = a - | otherwise = bracket setup cleanup go + | otherwise = withUmask nullFileMode a +#else +noUmask _ a = a +#endif + +withUmask :: FileMode -> IO a -> IO a +#ifndef mingw32_HOST_OS +withUmask umask a = bracket setup cleanup go where - setup = setFileCreationMask nullFileMode + setup = setFileCreationMask umask cleanup = setFileCreationMask go _ = a #else -noUmask _ a = a +withUmask _ a = a #endif combineModes :: [FileMode] -> FileMode @@ -127,14 +143,16 @@ setSticky f = modifyFileMode f $ addModes [stickyMode] #endif {- Writes a file, ensuring that its modes do not allow it to be read - - by anyone other than the current user, before any content is written. + - or written by anyone other than the current user, + - before any content is written. + - + - When possible, this is done using the umask. - - On a filesystem that does not support file permissions, this is the same - as writeFile. -} writeFileProtected :: FilePath -> String -> IO () -writeFileProtected file content = withFile file WriteMode $ \h -> do - void $ tryIO $ - modifyFileMode file $ - removeModes [groupReadMode, otherReadMode] - hPutStr h content +writeFileProtected file content = withUmask 0o0077 $ + withFile file WriteMode $ \h -> do + void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes + hPutStr h content diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index ac105e7..690942c 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,14 +1,17 @@ {- GHC File system encoding handling. - - - Copyright 2012-2013 Joey Hess <joey@kitenet.net> + - Copyright 2012-2014 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Utility.FileSystemEncoding ( fileEncoding, withFilePath, md5FilePath, + decodeBS, decodeW8, encodeW8, truncateFilePath, @@ -22,13 +25,24 @@ import System.IO.Unsafe import qualified Data.Hash.MD5 as MD5 import Data.Word import Data.Bits.Utils +import qualified Data.ByteString.Lazy as L +#ifdef mingw32_HOST_OS +import qualified Data.ByteString.Lazy.UTF8 as L8 +#endif {- Sets a Handle to use the filesystem encoding. This causes data - written or read from it to be encoded/decoded the same - as ghc 7.4 does to filenames etc. This special encoding - - allows "arbitrary undecodable bytes to be round-tripped through it". -} + - allows "arbitrary undecodable bytes to be round-tripped through it". + -} fileEncoding :: Handle -> IO () +#ifndef mingw32_HOST_OS fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding +#else +{- The file system encoding does not work well on Windows, + - and Windows only has utf FilePaths anyway. -} +fileEncoding h = hSetEncoding h Encoding.utf8 +#endif {- Marshal a Haskell FilePath into a NUL terminated C string using temporary - storage. The FilePath is encoded using the filesystem encoding, @@ -60,6 +74,16 @@ _encodeFilePath fp = unsafePerformIO $ do md5FilePath :: FilePath -> MD5.Str md5FilePath = MD5.Str . _encodeFilePath +{- Decodes a ByteString into a FilePath, applying the filesystem encoding. -} +decodeBS :: L.ByteString -> FilePath +#ifndef mingw32_HOST_OS +decodeBS = encodeW8 . L.unpack +#else +{- On Windows, we assume that the ByteString is utf-8, since Windows + - only uses unicode for filenames. -} +decodeBS = L8.toString +#endif + {- Converts a [Word8] to a FilePath, encoding using the filesystem encoding. - - w82c produces a String, which may contain Chars that are invalid @@ -84,6 +108,7 @@ decodeW8 = s2w8 . _encodeFilePath - cost of efficiency when running on a large FilePath. -} truncateFilePath :: Int -> FilePath -> FilePath +#ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where go f = @@ -91,3 +116,17 @@ truncateFilePath n = go . reverse in if length bytes <= n then reverse f else go (drop 1 f) +#else +{- On Windows, count the number of bytes used by each utf8 character. -} +truncateFilePath n = reverse . go [] n . L8.fromString + where + go coll cnt bs + | cnt <= 0 = coll + | otherwise = case L8.decode bs of + Just (c, x) | c /= L8.replacement_char -> + let x' = fromIntegral x + in if cnt - x' < 0 + then coll + else go (c:coll) (cnt - x') (L8.drop 1 bs) + _ -> coll +#endif diff --git a/Utility/Misc.hs b/Utility/Misc.hs index 20007ad..9c19df8 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -109,18 +109,6 @@ massReplace vs = go [] vs go (replacement:acc) vs (drop (length val) s) | otherwise = go acc rest s -{- Given two orderings, returns the second if the first is EQ and returns - - the first otherwise. - - - - Example use: - - - - compare lname1 lname2 `thenOrd` compare fname1 fname2 - -} -thenOrd :: Ordering -> Ordering -> Ordering -thenOrd EQ x = x -thenOrd x _ = x -{-# INLINE thenOrd #-} - {- Wrapper around hGetBufSome that returns a String. - - The null string is returned on eof, otherwise returns whatever diff --git a/Utility/Path.hs b/Utility/Path.hs index e22d0c3..570350d 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -18,7 +18,6 @@ import Data.Char import Control.Applicative #ifdef mingw32_HOST_OS -import Data.Char import qualified System.FilePath.Posix as Posix #else import System.Posix.Files diff --git a/Utility/Process.hs b/Utility/Process.hs index 1945e4b..3f93dc2 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -31,6 +31,7 @@ module Utility.Process ( stdinHandle, stdoutHandle, stderrHandle, + processHandle, devNull, ) where @@ -313,6 +314,9 @@ bothHandles :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> (Han bothHandles (Just hin, Just hout, _, _) = (hin, hout) bothHandles _ = error "expected bothHandles" +processHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> ProcessHandle +processHandle (_, _, _, pid) = pid + {- Debugging trace for a CreateProcess. -} debugProcess :: CreateProcess -> IO () debugProcess p = do diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index e2539f3..7f7234c 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -28,10 +28,10 @@ instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where {- Times before the epoch are excluded. -} instance Arbitrary POSIXTime where - arbitrary = nonNegative arbitrarySizedIntegral + arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral instance Arbitrary EpochTime where - arbitrary = nonNegative arbitrarySizedIntegral + arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 2c5e39b..82166f6 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -124,6 +124,9 @@ rsyncUrlIsPath s - after the \r is the number of bytes processed. After the number, - there must appear some whitespace, or we didn't get the whole number, - and return the \r and part we did get, for later processing. + - + - In some locales, the number will have one or more commas in the middle + - of it. -} parseRsyncProgress :: String -> (Maybe Integer, String) parseRsyncProgress = go [] . reverse . progresschunks @@ -142,7 +145,7 @@ parseRsyncProgress = go [] . reverse . progresschunks parsebytes s = case break isSpace s of ([], _) -> Nothing (_, []) -> Nothing - (b, _) -> readish b + (b, _) -> readish $ filter (/= ',') b {- Filters options to those that are safe to pass to rsync in server mode, - without causing it to eg, expose files. -} diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index dbb6cb3..dd88dc8 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -10,10 +10,13 @@ module Utility.ThreadScheduler where -import Common - +import Control.Monad import Control.Concurrent #ifndef mingw32_HOST_OS +import Control.Monad.IfElse +import System.Posix.IO +#endif +#ifndef mingw32_HOST_OS import System.Posix.Signals #ifndef __ANDROID__ import System.Posix.Terminal diff --git a/Utility/URI.hs b/Utility/URI.hs new file mode 100644 index 0000000..39c2f22 --- /dev/null +++ b/Utility/URI.hs @@ -0,0 +1,18 @@ +{- Network.URI + - + - Copyright 2014 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.URI where + +-- Old versions of network lacked an Ord for URI +#if ! MIN_VERSION_network(2,4,0) +import Network.URI + +instance Ord URI where + a `compare` b = show a `compare` show b +#endif |