diff options
| -rw-r--r-- | Git/CatFile.hs | 7 | ||||
| -rw-r--r-- | Git/Command.hs | 3 | ||||
| -rw-r--r-- | Git/Types.hs | 5 | ||||
| -rw-r--r-- | Git/UpdateIndex.hs | 8 | ||||
| -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 |
13 files changed, 120 insertions, 37 deletions
diff --git a/Git/CatFile.hs b/Git/CatFile.hs index c8cb76d..8e64fc5 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -11,6 +11,7 @@ module Git.CatFile ( catFileStart', catFileStop, catFile, + catFileDetails, catTree, catObject, catObjectDetails, @@ -52,6 +53,10 @@ catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString catFile h branch file = catObject h $ Ref $ fromRef branch ++ ":" ++ toInternalGitPath file +catFileDetails :: CatFileHandle -> Branch -> FilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) +catFileDetails h branch file = catObjectDetails h $ Ref $ + fromRef branch ++ ":" ++ toInternalGitPath file + {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} catObject :: CatFileHandle -> Ref -> IO L.ByteString @@ -103,6 +108,6 @@ catTree h treeref = go <$> catObjectDetails h treeref dropsha = L.drop 21 parsemodefile b = - let (modestr, file) = separate (== ' ') (encodeW8 $ L.unpack b) + let (modestr, file) = separate (== ' ') (decodeBS b) in (file, readmode modestr) readmode = fst . fromMaybe (0, undefined) . headMaybe . readOct diff --git a/Git/Command.hs b/Git/Command.hs index 0fa3d1b..a0c7c4b 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -15,9 +15,6 @@ import Common import Git import Git.Types import qualified Utility.CoProcess as CoProcess -#ifdef mingw32_HOST_OS -import Git.FilePath -#endif import Utility.Batch {- Constructs a git command line operating on the specified repo. -} diff --git a/Git/Types.hs b/Git/Types.hs index 8029225..838c9e0 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -11,6 +11,7 @@ import Network.URI import qualified Data.Map as M import System.Posix.Types import Utility.SafeCommand +import Utility.URI () {- Support repositories on local disk, and repositories accessed via an URL. - @@ -27,7 +28,7 @@ data RepoLocation | LocalUnknown FilePath | Url URI | Unknown - deriving (Show, Eq) + deriving (Show, Eq, Ord) data Repo = Repo { location :: RepoLocation @@ -41,7 +42,7 @@ data Repo = Repo , gitEnv :: Maybe [(String, String)] -- global options to pass to git when running git commands , gitGlobalOpts :: [CommandParam] - } deriving (Show, Eq) + } deriving (Show, Eq, Ord) type RemoteName = String diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 6d1ff25..4ecd773 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -15,6 +15,7 @@ module Git.UpdateIndex ( startUpdateIndex, stopUpdateIndex, lsTree, + lsSubTree, updateIndexLine, stageFile, unstageFile, @@ -74,6 +75,13 @@ lsTree (Ref x) repo streamer = do void $ cleanup where params = map Param ["ls-tree", "-z", "-r", "--full-tree", x] +lsSubTree :: Ref -> FilePath -> Repo -> Streamer +lsSubTree (Ref x) p repo streamer = do + (s, cleanup) <- pipeNullSplit params repo + mapM_ streamer s + void $ cleanup + where + params = map Param ["ls-tree", "-z", "-r", "--full-tree", x, p] {- Generates a line suitable to be fed into update-index, to add - a given file with a given sha. -} 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 |