From 63f9aba33b45e5bab688ffaa5e4182801c152828 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 26 Jun 2017 12:15:27 -0400 Subject: merge from git-annex Removes dependency on MissingH, adding a dependency on split instead. This commit was sponsored by Brock Spratlen on Patreon. --- CHANGELOG | 1 + Common.hs | 2 +- Git/CatFile.hs | 2 +- Git/Command.hs | 8 +- Git/Config.hs | 2 +- Git/Construct.hs | 8 +- Git/Filename.hs | 14 +++- Git/LsTree.hs | 16 ++-- Git/Ref.hs | 2 +- Git/Remote.hs | 6 +- Git/Repair.hs | 2 +- Utility/DataUnits.hs | 166 ++++++++++++++++++++++++++++++++++++++++++ Utility/Directory.hs | 4 +- Utility/DottedVersion.hs | 2 +- Utility/FileMode.hs | 22 +++++- Utility/FileSystemEncoding.hs | 41 ++++++++--- Utility/Format.hs | 21 ++++-- Utility/HumanNumber.hs | 21 ++++++ Utility/HumanTime.hs | 102 ++++++++++++++++++++++++++ Utility/Metered.hs | 104 +++++++++++++++++++++++--- Utility/PartialPrelude.hs | 2 +- Utility/Path.hs | 32 +++----- Utility/Percentage.hs | 33 +++++++++ Utility/Process.hs | 28 ++++--- Utility/QuickCheck.hs | 3 - Utility/Rsync.hs | 6 +- Utility/SafeCommand.hs | 4 +- Utility/Split.hs | 30 ++++++++ Utility/Tuple.hs | 17 +++++ git-repair.cabal | 10 ++- 30 files changed, 602 insertions(+), 109 deletions(-) create mode 100644 Utility/DataUnits.hs create mode 100644 Utility/HumanNumber.hs create mode 100644 Utility/HumanTime.hs create mode 100644 Utility/Percentage.hs create mode 100644 Utility/Split.hs create mode 100644 Utility/Tuple.hs diff --git a/CHANGELOG b/CHANGELOG index 55b8281..c6f328c 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,7 @@ git-repair (1.20161119) UNRELEASED; urgency=medium * Merge from git-annex. + * Removes dependency on MissingH, adding a dependency on split instead. * Fixes build with directory-1.3. -- Joey Hess Sat, 24 Dec 2016 14:53:47 -0400 diff --git a/Common.hs b/Common.hs index 9dab5dd..c1890e6 100644 --- a/Common.hs +++ b/Common.hs @@ -9,7 +9,6 @@ import Control.Monad.IO.Class as X (liftIO) import Data.Maybe as X import Data.List as X hiding (head, tail, init, last) -import Data.String.Utils as X hiding (join) import Data.Monoid as X import Data.Default as X @@ -31,5 +30,6 @@ import Utility.Data as X import Utility.Applicative as X import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X +import Utility.Split as X import Utility.PartialPrelude as X diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 4935cdf..ba68c4e 100644 --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -26,7 +26,6 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Map as M import Data.String import Data.Char -import Data.Tuple.Utils import Numeric import System.Posix.Types @@ -38,6 +37,7 @@ import Git.Types import Git.FilePath import qualified Utility.CoProcess as CoProcess import Utility.FileSystemEncoding +import Utility.Tuple data CatFileHandle = CatFileHandle { catFileProcess :: CoProcess.CoProcessHandle diff --git a/Git/Command.hs b/Git/Command.hs index adea762..f40dfab 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -91,16 +91,16 @@ pipeWrite params repo = withHandle StdinHandle createProcessSuccess $ pipeNullSplit :: [CommandParam] -> Repo -> IO ([String], IO Bool) pipeNullSplit params repo = do (s, cleanup) <- pipeReadLazy params repo - return (filter (not . null) $ split sep s, cleanup) + return (filter (not . null) $ splitc sep s, cleanup) where - sep = "\0" + sep = '\0' pipeNullSplitStrict :: [CommandParam] -> Repo -> IO [String] pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo - return $ filter (not . null) $ split sep s + return $ filter (not . null) $ splitc sep s where - sep = "\0" + sep = '\0' pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [String] pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo diff --git a/Git/Config.hs b/Git/Config.hs index 65bd9b7..9b4c342 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -132,7 +132,7 @@ parse s -- --list output will have an = in the first line | all ('=' `elem`) (take 1 ls) = sep '=' ls -- --null --list output separates keys from values with newlines - | otherwise = sep '\n' $ split "\0" s + | otherwise = sep '\n' $ splitc '\0' s where ls = lines s sep c = M.fromListWith (++) . map (\(k,v) -> (k, [v])) . diff --git a/Git/Construct.hs b/Git/Construct.hs index 7655622..4ad74fd 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -26,7 +26,7 @@ module Git.Construct ( #ifndef mingw32_HOST_OS import System.Posix.User #endif -import qualified Data.Map as M hiding (map, split) +import qualified Data.Map as M import Network.URI import Common @@ -94,7 +94,7 @@ fromUrl url fromUrlStrict :: String -> IO Repo fromUrlStrict url - | startswith "file://" url = fromAbsPath $ unEscapeString $ uriPath u + | "file://" `isPrefixOf` url = fromAbsPath $ unEscapeString $ uriPath u | otherwise = pure $ newFrom $ Url u where u = fromMaybe bad $ parseURI url @@ -128,7 +128,7 @@ fromRemotes repo = mapM construct remotepairs filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isremote - isremote k = startswith "remote." k && endswith ".url" k + isremote k = "remote." `isPrefixOf` k && ".url" `isSuffixOf` k construct (k,v) = remoteNamedFromKey k $ fromRemoteLocation v repo {- Sets the name of a remote when constructing the Repo to represent it. -} @@ -143,7 +143,7 @@ remoteNamedFromKey :: String -> IO Repo -> IO Repo remoteNamedFromKey k = remoteNamed basename where basename = intercalate "." $ - reverse $ drop 1 $ reverse $ drop 1 $ split "." k + reverse $ drop 1 $ reverse $ drop 1 $ splitc '.' k {- Constructs a new Repo for one of a Repo's remotes using a given - location (ie, an url). -} diff --git a/Git/Filename.hs b/Git/Filename.hs index ee84d48..355e75f 100644 --- a/Git/Filename.hs +++ b/Git/Filename.hs @@ -8,9 +8,10 @@ module Git.Filename where +import Common import Utility.Format (decode_c, encode_c) -import Common +import Data.Char decode :: String -> FilePath decode [] = [] @@ -23,6 +24,11 @@ decode f@(c:s) encode :: FilePath -> String encode s = "\"" ++ encode_c s ++ "\"" -{- for quickcheck -} -prop_isomorphic_deencode :: String -> Bool -prop_isomorphic_deencode s = s == decode (encode s) +{- For quickcheck. + - + - See comment on Utility.Format.prop_encode_c_decode_c_roundtrip for + - why this only tests chars < 256 -} +prop_encode_decode_roundtrip :: String -> Bool +prop_encode_decode_roundtrip s = s' == decode (encode s') + where + s' = filter (\c -> ord c < 256) s diff --git a/Git/LsTree.hs b/Git/LsTree.hs index 2060fa7..225f2ce 100644 --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -24,6 +24,7 @@ import Git.FilePath import qualified Git.Filename import Numeric +import Data.Char import System.Posix.Types data TreeItem = TreeItem @@ -66,7 +67,9 @@ lsTreeFiles t fs repo = map parseLsTree <$> pipeNullSplitStrict ps repo , File $ fromRef t ] ++ map File fs -{- Parses a line of ls-tree output. +{- Parses a line of ls-tree output, in format: + - mode SP type SP sha TAB file + - - (The --long format is not currently supported.) -} parseLsTree :: String -> TreeItem parseLsTree l = TreeItem @@ -76,12 +79,9 @@ parseLsTree l = TreeItem , file = sfile } where - -- l = SP SP TAB - -- All fields are fixed, so we can pull them out of - -- specific positions in the line. - (m, past_m) = splitAt 7 l - (!t, past_t) = splitAt 4 past_m - (!s, past_s) = splitAt shaSize $ Prelude.tail past_t - !f = Prelude.tail past_s + (m, past_m) = splitAt 7 l -- mode is 6 bytes + (!t, past_t) = separate isSpace past_m + (!s, past_s) = splitAt shaSize past_t + !f = drop 1 past_s !smode = fst $ Prelude.head $ readOct m !sfile = asTopFilePath $ Git.Filename.decode f diff --git a/Git/Ref.hs b/Git/Ref.hs index 5b3b853..2d80137 100644 --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -144,6 +144,6 @@ legal allowonelevel s = all (== False) illegal ends v = v `isSuffixOf` s begins v = v `isPrefixOf` s - pathbits = split "/" s + pathbits = splitc '/' s illegalchars = " ~^:?*[\\" ++ controlchars controlchars = chr 0o177 : [chr 0 .. chr (0o40-1)] diff --git a/Git/Remote.hs b/Git/Remote.hs index 717b540..f6eaf93 100644 --- a/Git/Remote.hs +++ b/Git/Remote.hs @@ -74,9 +74,9 @@ parseRemoteLocation s repo = ret $ calcloc s (bestkey, bestvalue) = maximumBy longestvalue insteadofs longestvalue (_, a) (_, b) = compare b a insteadofs = filterconfig $ \(k, v) -> - startswith prefix k && - endswith suffix k && - startswith v l + prefix `isPrefixOf` k && + suffix `isSuffixOf` k && + v `isPrefixOf` l filterconfig f = filter f $ concatMap splitconfigs $ M.toList $ fullconfig repo splitconfigs (k, vs) = map (\v -> (k, v)) vs diff --git a/Git/Repair.hs b/Git/Repair.hs index 1baf51a..8e43248 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -39,10 +39,10 @@ import qualified Git.Branch as Branch import Utility.Tmp import Utility.Rsync import Utility.FileMode +import Utility.Tuple import qualified Data.Set as S import qualified Data.ByteString.Lazy as L -import Data.Tuple.Utils {- Given a set of bad objects found by git fsck, which may not - be complete, finds and removes all corrupt objects. -} diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs new file mode 100644 index 0000000..a6c9ffc --- /dev/null +++ b/Utility/DataUnits.hs @@ -0,0 +1,166 @@ +{- data size display and parsing + - + - Copyright 2011 Joey Hess + - + - License: BSD-2-clause + - + - + - And now a rant: + - + - In the beginning, we had powers of two, and they were good. + - + - Disk drive manufacturers noticed that some powers of two were + - sorta close to some powers of ten, and that rounding down to the nearest + - power of ten allowed them to advertise their drives were bigger. This + - was sorta annoying. + - + - Then drives got big. Really, really big. This was good. + - + - Except that the small rounding error perpretrated by the drive + - manufacturers suffered the fate of a small error, and became a large + - error. This was bad. + - + - So, a committee was formed. And it arrived at a committee-like decision, + - which satisfied noone, confused everyone, and made the world an uglier + - place. As with all committees, this was meh. + - + - And the drive manufacturers happily continued selling drives that are + - increasingly smaller than you'd expect, if you don't count on your + - fingers. But that are increasingly too big for anyone to much notice. + - This caused me to need git-annex. + - + - Thus, I use units here that I loathe. Because if I didn't, people would + - be confused that their drives seem the wrong size, and other people would + - complain at me for not being standards compliant. And we call this + - progress? + -} + +module Utility.DataUnits ( + dataUnits, + storageUnits, + memoryUnits, + bandwidthUnits, + oldSchoolUnits, + Unit(..), + ByteSize, + + roughSize, + roughSize', + compareSizes, + readSize +) where + +import Data.List +import Data.Char + +import Utility.HumanNumber + +type ByteSize = Integer +type Name = String +type Abbrev = String +data Unit = Unit ByteSize Abbrev Name + deriving (Ord, Show, Eq) + +dataUnits :: [Unit] +dataUnits = storageUnits ++ memoryUnits + +{- Storage units are (stupidly) powers of ten. -} +storageUnits :: [Unit] +storageUnits = + [ Unit (p 8) "YB" "yottabyte" + , Unit (p 7) "ZB" "zettabyte" + , Unit (p 6) "EB" "exabyte" + , Unit (p 5) "PB" "petabyte" + , Unit (p 4) "TB" "terabyte" + , Unit (p 3) "GB" "gigabyte" + , Unit (p 2) "MB" "megabyte" + , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 1000^n + +{- Memory units are (stupidly named) powers of 2. -} +memoryUnits :: [Unit] +memoryUnits = + [ Unit (p 8) "YiB" "yobibyte" + , Unit (p 7) "ZiB" "zebibyte" + , Unit (p 6) "EiB" "exbibyte" + , Unit (p 5) "PiB" "pebibyte" + , Unit (p 4) "TiB" "tebibyte" + , Unit (p 3) "GiB" "gibibyte" + , Unit (p 2) "MiB" "mebibyte" + , Unit (p 1) "KiB" "kibibyte" + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 2^(n*10) + +{- Bandwidth units are only measured in bits if you're some crazy telco. -} +bandwidthUnits :: [Unit] +bandwidthUnits = error "stop trying to rip people off" + +{- Do you yearn for the days when men were men and megabytes were megabytes? -} +oldSchoolUnits :: [Unit] +oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits + where + mingle (Unit _ a n, Unit s' _ _) = Unit s' a n + +{- approximate display of a particular number of bytes -} +roughSize :: [Unit] -> Bool -> ByteSize -> String +roughSize units short i = roughSize' units short 2 i + +roughSize' :: [Unit] -> Bool -> Int -> ByteSize -> String +roughSize' units short precision i + | i < 0 = '-' : findUnit units' (negate i) + | otherwise = findUnit units' i + where + units' = sortBy (flip compare) units -- largest first + + findUnit (u@(Unit s _ _):us) i' + | i' >= s = showUnit i' u + | otherwise = findUnit us i' + findUnit [] i' = showUnit i' (last units') -- bytes + + showUnit x (Unit size abbrev name) = s ++ " " ++ unit + where + v = (fromInteger x :: Double) / fromInteger size + s = showImprecise precision v + unit + | short = abbrev + | s == "1" = name + | otherwise = name ++ "s" + +{- displays comparison of two sizes -} +compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String +compareSizes units abbrev old new + | old > new = roughSize units abbrev (old - new) ++ " smaller" + | old < new = roughSize units abbrev (new - old) ++ " larger" + | otherwise = "same" + +{- Parses strings like "10 kilobytes" or "0.5tb". -} +readSize :: [Unit] -> String -> Maybe ByteSize +readSize units input + | null parsednum || null parsedunit = Nothing + | otherwise = Just $ round $ number * fromIntegral multiplier + where + (number, rest) = head parsednum + multiplier = head parsedunit + unitname = takeWhile isAlpha $ dropWhile isSpace rest + + parsednum = reads input :: [(Double, String)] + parsedunit = lookupUnit units unitname + + lookupUnit _ [] = [1] -- no unit given, assume bytes + lookupUnit [] _ = [] + lookupUnit (Unit s a n:us) v + | a ~~ v || n ~~ v = [s] + | plural n ~~ v || a ~~ byteabbrev v = [s] + | otherwise = lookupUnit us v + + a ~~ b = map toLower a == map toLower b + + plural n = n ++ "s" + byteabbrev a = a ++ "b" diff --git a/Utility/Directory.hs b/Utility/Directory.hs index 693e771..c24f36d 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -96,10 +96,10 @@ dirTreeRecursiveSkipping skipdir topdir = go [] [topdir] go c (dir:dirs) | skipdir (takeFileName dir) = go c dirs | otherwise = unsafeInterleaveIO $ do - subdirs <- go c + subdirs <- go [] =<< filterM (isDirectory <$$> getSymbolicLinkStatus) =<< catchDefaultIO [] (dirContents dir) - go (subdirs++[dir]) dirs + go (subdirs++dir:c) dirs {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} diff --git a/Utility/DottedVersion.hs b/Utility/DottedVersion.hs index ebf4c0b..3198b1c 100644 --- a/Utility/DottedVersion.hs +++ b/Utility/DottedVersion.hs @@ -25,7 +25,7 @@ instance Show DottedVersion where normalize :: String -> DottedVersion normalize v = DottedVersion v $ sum $ mult 1 $ reverse $ extend precision $ take precision $ - map readi $ split "." v + map readi $ splitc '.' v where extend n l = l ++ replicate (n - length l) 0 mult _ [] = [] diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs index bb3780c..d9a2694 100644 --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -1,6 +1,6 @@ {- File mode utilities. - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2017 Joey Hess - - License: BSD-2-clause -} @@ -130,6 +130,21 @@ withUmask umask a = bracket setup cleanup go withUmask _ a = a #endif +getUmask :: IO FileMode +#ifndef mingw32_HOST_OS +getUmask = bracket setup cleanup return + where + setup = setFileCreationMask nullFileMode + cleanup = setFileCreationMask +#else +getUmask = return nullFileMode +#endif + +defaultFileMode :: IO FileMode +defaultFileMode = do + umask <- getUmask + return $ intersectFileModes (complement umask) stdFileMode + combineModes :: [FileMode] -> FileMode combineModes [] = 0 combineModes [m] = m @@ -162,7 +177,10 @@ writeFileProtected file content = writeFileProtected' file (\h -> hPutStr h content) writeFileProtected' :: FilePath -> (Handle -> IO ()) -> IO () -writeFileProtected' file writer = withUmask 0o0077 $ +writeFileProtected' file writer = protectedOutput $ withFile file WriteMode $ \h -> do void $ tryIO $ modifyFileMode file $ removeModes otherGroupModes writer h + +protectedOutput :: IO a -> IO a +protectedOutput = withUmask 0o0077 diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index be43ace..444dc4a 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -10,8 +10,8 @@ module Utility.FileSystemEncoding ( useFileSystemEncoding, + fileEncoding, withFilePath, - md5FilePath, decodeBS, encodeBS, decodeW8, @@ -19,6 +19,10 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, + s2w8, + w82s, + c2w8, + w82c, ) where import qualified GHC.Foreign as GHC @@ -26,17 +30,15 @@ import qualified GHC.IO.Encoding as Encoding import Foreign.C import System.IO import System.IO.Unsafe -import qualified Data.Hash.MD5 as MD5 import Data.Word -import Data.Bits.Utils import Data.List -import Data.List.Utils import qualified Data.ByteString.Lazy as L #ifdef mingw32_HOST_OS import qualified Data.ByteString.Lazy.UTF8 as L8 #endif import Utility.Exception +import Utility.Split {- Makes all subsequent Handles that are opened, as well as stdio Handles, - use the filesystem encoding, instead of the encoding of the current @@ -63,6 +65,13 @@ useFileSystemEncoding = do hSetEncoding stderr e Encoding.setLocaleEncoding e +fileEncoding :: Handle -> IO () +#ifndef mingw32_HOST_OS +fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding +#else +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, - reversing the decoding that should have been done when the FilePath @@ -93,10 +102,6 @@ _encodeFilePath fp = unsafePerformIO $ do GHC.withCString enc fp (GHC.peekCString Encoding.char8) `catchNonAsync` (\_ -> return fp) -{- Encodes a FilePath into a Md5.Str, applying the filesystem encoding. -} -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 @@ -137,14 +142,26 @@ decodeW8 = s2w8 . _encodeFilePath {- Like encodeW8 and decodeW8, but NULs are passed through unchanged. -} encodeW8NUL :: [Word8] -> FilePath -encodeW8NUL = intercalate nul . map encodeW8 . split (s2w8 nul) +encodeW8NUL = intercalate [nul] . map encodeW8 . splitc (c2w8 nul) where - nul = ['\NUL'] + nul = '\NUL' decodeW8NUL :: FilePath -> [Word8] -decodeW8NUL = intercalate (s2w8 nul) . map decodeW8 . split nul +decodeW8NUL = intercalate [c2w8 nul] . map decodeW8 . splitc nul where - nul = ['\NUL'] + nul = '\NUL' + +c2w8 :: Char -> Word8 +c2w8 = fromIntegral . fromEnum + +w82c :: Word8 -> Char +w82c = toEnum . fromIntegral + +s2w8 :: String -> [Word8] +s2w8 = map c2w8 + +w82s :: [Word8] -> String +w82s = map w82c {- Truncates a FilePath to the given number of bytes (or less), - as represented on disk. diff --git a/Utility/Format.hs b/Utility/Format.hs index 1ebf68d..3670cd7 100644 --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -11,7 +11,7 @@ module Utility.Format ( format, decode_c, encode_c, - prop_isomorphic_deencode + prop_encode_c_decode_c_roundtrip ) where import Text.Printf (printf) @@ -100,8 +100,8 @@ empty :: Frag -> Bool empty (Const "") = True empty _ = False -{- Decodes a C-style encoding, where \n is a newline, \NNN is an octal - - encoded character, and \xNN is a hex encoded character. +{- Decodes a C-style encoding, where \n is a newline (etc), + - \NNN is an octal encoded character, and \xNN is a hex encoded character. -} decode_c :: FormatString -> String decode_c [] = [] @@ -173,6 +173,15 @@ encode_c' p = concatMap echar e_asc c = showoctal $ ord c showoctal i = '\\' : printf "%03o" i -{- for quickcheck -} -prop_isomorphic_deencode :: String -> Bool -prop_isomorphic_deencode s = s == decode_c (encode_c s) +{- 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". + - + - This property papers over the problem, by only testing chars < 256. + -} +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 diff --git a/Utility/HumanNumber.hs b/Utility/HumanNumber.hs new file mode 100644 index 0000000..c3fede9 --- /dev/null +++ b/Utility/HumanNumber.hs @@ -0,0 +1,21 @@ +{- numbers for humans + - + - Copyright 2012-2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.HumanNumber where + +{- Displays a fractional value as a string with a limited number + - of decimal digits. -} +showImprecise :: RealFrac a => Int -> a -> String +showImprecise precision n + | precision == 0 || remainder == 0 = show (round n :: Integer) + | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder) + where + int :: Integer + (int, frac) = properFraction n + remainder = round (frac * 10 ^ precision) :: Integer + pad0s s = replicate (precision - length s) '0' ++ s + striptrailing0s = reverse . dropWhile (== '0') . reverse diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs new file mode 100644 index 0000000..fe7cf22 --- /dev/null +++ b/Utility/HumanTime.hs @@ -0,0 +1,102 @@ +{- Time for humans. + - + - Copyright 2012-2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.HumanTime ( + Duration(..), + durationSince, + durationToPOSIXTime, + durationToDays, + daysToDuration, + parseDuration, + fromDuration, + prop_duration_roundtrips +) where + +import Utility.PartialPrelude +import Utility.QuickCheck + +import qualified Data.Map as M +import Data.Time.Clock +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Char +import Control.Applicative +import Prelude + +newtype Duration = Duration { durationSeconds :: Integer } + deriving (Eq, Ord, Read, Show) + +durationSince :: UTCTime -> IO Duration +durationSince pasttime = do + now <- getCurrentTime + return $ Duration $ round $ diffUTCTime now pasttime + +durationToPOSIXTime :: Duration -> POSIXTime +durationToPOSIXTime = fromIntegral . durationSeconds + +durationToDays :: Duration -> Integer +durationToDays d = durationSeconds d `div` dsecs + +daysToDuration :: Integer -> Duration +daysToDuration i = Duration $ i * dsecs + +{- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} +parseDuration :: Monad m => String -> m Duration +parseDuration = maybe parsefail (return . Duration) . go 0 + where + go n [] = return n + go n s = do + num <- readish s :: Maybe Integer + case dropWhile isDigit s of + (c:rest) -> do + u <- M.lookup c unitmap + go (n + num * u) rest + _ -> return $ n + num + parsefail = fail "duration parse error; expected eg \"5m\" or \"1h5m\"" + +fromDuration :: Duration -> String +fromDuration Duration { durationSeconds = d } + | d == 0 = "0s" + | otherwise = concatMap showunit $ go [] units d + where + showunit (u, n) + | n > 0 = show n ++ [u] + | otherwise = "" + go c [] _ = reverse c + go c ((u, n):us) v = + let (q,r) = v `quotRem` n + in go ((u, q):c) us r + +units :: [(Char, Integer)] +units = + [ ('y', ysecs) + , ('d', dsecs) + , ('h', hsecs) + , ('m', msecs) + , ('s', 1) + ] + +unitmap :: M.Map Char Integer +unitmap = M.fromList units + +ysecs :: Integer +ysecs = dsecs * 365 + +dsecs :: Integer +dsecs = hsecs * 24 + +hsecs :: Integer +hsecs = msecs * 60 + +msecs :: Integer +msecs = 60 + +-- Durations cannot be negative. +instance Arbitrary Duration where + arbitrary = Duration <$> nonNegative arbitrary + +prop_duration_roundtrips :: Duration -> Bool +prop_duration_roundtrips d = parseDuration (fromDuration d) == Just d diff --git a/Utility/Metered.hs b/Utility/Metered.hs index e21e18c..a5dda54 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -10,6 +10,10 @@ module Utility.Metered where import Common +import Utility.FileSystemEncoding +import Utility.Percentage +import Utility.DataUnits +import Utility.HumanTime import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -17,7 +21,6 @@ import System.IO.Unsafe import Foreign.Storable (Storable(sizeOf)) import System.Posix.Types import Data.Int -import Data.Bits.Utils import Control.Concurrent import Control.Concurrent.Async import Control.Monad.IO.Class (MonadIO) @@ -168,22 +171,27 @@ defaultChunkSize = 32 * k - chunkOverhead k = 1024 chunkOverhead = 2 * sizeOf (1 :: Int) -- GHC specific -{- Runs an action, watching a file as it grows and updating the meter. -} +{- Runs an action, watching a file as it grows and updating the meter. + - + - The file may already exist, and the action could throw the original file + - away and start over. To avoid reporting the original file size followed + - by a smaller size in that case, wait until the file starts growing + - before updating the meter for the first time. + -} watchFileSize :: (MonadIO m, MonadMask m) => FilePath -> MeterUpdate -> m a -> m a watchFileSize f p a = bracket - (liftIO $ forkIO $ watcher zeroBytesProcessed) + (liftIO $ forkIO $ watcher =<< getsz) (liftIO . void . tryIO . killThread) (const a) where watcher oldsz = do - v <- catchMaybeIO $ toBytesProcessed <$> getFileSize f - newsz <- case v of - Just sz | sz /= oldsz -> do - p sz - return sz - _ -> return oldsz threadDelay 500000 -- 0.5 seconds - watcher newsz + sz <- getsz + when (sz > oldsz) $ + p sz + watcher sz + getsz = catchDefaultIO zeroBytesProcessed $ + toBytesProcessed <$> getFileSize f data OutputHandler = OutputHandler { quietMode :: Bool @@ -216,7 +224,7 @@ commandMeter progressparser oh meterupdate cmd params = unless (quietMode oh) $ do S.hPut stdout b hFlush stdout - let s = w82s (S.unpack b) + let s = encodeW8 (S.unpack b) let (mbytes, buf') = progressparser (buf++s) case mbytes of Nothing -> feedprogress prev buf' h @@ -297,3 +305,77 @@ rateLimitMeterUpdate delta totalsize meterupdate = do putMVar lastupdate now meterupdate n else putMVar lastupdate prev + +data Meter = Meter (Maybe Integer) (MVar MeterState) (MVar String) RenderMeter DisplayMeter + +type MeterState = (BytesProcessed, POSIXTime) + +type DisplayMeter = MVar String -> String -> 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 + <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) + <*> newMVar "" + <*> pure rendermeter + <*> pure displaymeter + +-- | Updates the meter, displaying it if necessary. +updateMeter :: Meter -> BytesProcessed -> IO () +updateMeter (Meter totalsize sv bv rendermeter displaymeter) new = do + now <- getPOSIXTime + (old, before) <- swapMVar sv (new, now) + when (old /= new) $ + displaymeter bv $ + rendermeter totalsize (old, before) (new, now) + +-- | Display meter to a Handle. +displayMeterHandle :: Handle -> DisplayMeter +displayMeterHandle h v s = do + olds <- swapMVar v s + -- Avoid writing when the rendered meter has not changed. + when (olds /= s) $ do + let padding = replicate (length olds - length s) ' ' + hPutStr h ('\r':s ++ padding) + hFlush h + +-- | Clear meter displayed by displayMeterHandle. +clearMeterHandle :: Meter -> Handle -> IO () +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 +-- or when total size is not known: +-- 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 rate + , estimatedcompletion + ] + where + percentoramount = case mtotalsize of + Just totalsize -> showPercentage 0 $ + percentage totalsize (min new totalsize) + Nothing -> roughSize' memoryUnits True 2 new + rate = roughSize' memoryUnits True 0 bytespersecond ++ "/s" + bytespersecond + | duration == 0 = fromIntegral transferred + | otherwise = floor $ fromIntegral transferred / duration + transferred = max 0 (new - old) + duration = max 0 (now - before) + estimatedcompletion = case mtotalsize of + Just totalsize + | bytespersecond > 0 -> + Just $ fromDuration $ Duration $ + totalsize `div` bytespersecond + _ -> Nothing diff --git a/Utility/PartialPrelude.hs b/Utility/PartialPrelude.hs index 5579556..47e9831 100644 --- a/Utility/PartialPrelude.hs +++ b/Utility/PartialPrelude.hs @@ -2,7 +2,7 @@ - bugs. - - This exports functions that conflict with the prelude, which avoids - - them being accidentially used. + - them being accidentally used. -} {-# OPTIONS_GHC -fno-warn-tabs #-} diff --git a/Utility/Path.hs b/Utility/Path.hs index 3ee5ff3..0779d16 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -10,7 +10,6 @@ module Utility.Path where -import Data.String.Utils import System.FilePath import Data.List import Data.Maybe @@ -25,10 +24,10 @@ import System.Posix.Files import Utility.Exception #endif -import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo import Utility.Directory +import Utility.Split {- Simplifies a path, removing any "." component, collapsing "dir/..", - and removing the trailing path separator. @@ -68,18 +67,6 @@ simplifyPath path = dropTrailingPathSeparator $ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) -{- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. -} -absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath -#ifndef mingw32_HOST_OS -absNormPathUnix dir path = MissingH.absNormPath dir path -#else -absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) - where - fromdos = replace "\\" "/" - todos = replace "/" "\\" -#endif - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath parentDir = takeDirectory . dropTrailingPathSeparator @@ -89,12 +76,13 @@ parentDir = takeDirectory . dropTrailingPathSeparator upFrom :: FilePath -> Maybe FilePath upFrom dir | length dirs < 2 = Nothing - | otherwise = Just $ joinDrive drive (intercalate s $ init dirs) + | otherwise = Just $ joinDrive drive $ intercalate s $ init dirs where - -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" + -- on Unix, the drive will be "/" when the dir is absolute, + -- otherwise "" (drive, path) = splitDrive dir - dirs = filter (not . null) $ split s path s = [pathSeparator] + dirs = filter (not . null) $ split s path prop_upFrom_basics :: FilePath -> Bool prop_upFrom_basics dir @@ -149,11 +137,11 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to | takeDrive from /= takeDrive to = to - | otherwise = intercalate s $ dotdots ++ uncommon + | otherwise = joinPath $ dotdots ++ uncommon where - s = [pathSeparator] - pfrom = split s from - pto = split s to + pfrom = sp from + pto = sp to + sp = map dropTrailingPathSeparator . splitPath common = map fst $ takeWhile same $ zip pfrom pto same (c,d) = c == d uncommon = drop numcommon pto @@ -227,6 +215,8 @@ inPath command = isJust <$> searchPath command - - The command may be fully qualified already, in which case it will - be returned if it exists. + - + - Note that this will find commands in PATH that are not executable. -} searchPath :: String -> IO (Maybe FilePath) searchPath command diff --git a/Utility/Percentage.hs b/Utility/Percentage.hs new file mode 100644 index 0000000..a30c260 --- /dev/null +++ b/Utility/Percentage.hs @@ -0,0 +1,33 @@ +{- percentages + - + - Copyright 2012 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Percentage ( + Percentage, + percentage, + showPercentage +) where + +import Data.Ratio + +import Utility.HumanNumber + +newtype Percentage = Percentage (Ratio Integer) + +instance Show Percentage where + show = showPercentage 0 + +{- Normally the big number comes first. But 110% is allowed if desired. :) -} +percentage :: Integer -> Integer -> Percentage +percentage 0 _ = Percentage 0 +percentage full have = Percentage $ have * 100 % full + +{- Pretty-print a Percentage, with a specified level of precision. -} +showPercentage :: Int -> Percentage -> String +showPercentage precision (Percentage p) = v ++ "%" + where + v = showImprecise precision n + n = fromRational p :: Double diff --git a/Utility/Process.hs b/Utility/Process.hs index ed02f49..6d981cb 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -174,22 +174,21 @@ createBackgroundProcess p a = a =<< createProcess p -- returns a transcript combining its stdout and stderr, and -- whether it succeeded or failed. processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) -processTranscript = processTranscript' id +processTranscript cmd opts = processTranscript' (proc cmd opts) -processTranscript' :: (CreateProcess -> CreateProcess) -> String -> [String] -> Maybe String -> IO (String, Bool) -processTranscript' modproc cmd opts input = do +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 $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = UseHandle writeh - , std_err = UseHandle writeh - } + 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 @@ -200,12 +199,11 @@ processTranscript' modproc cmd opts input = do return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} - p@(_, _, _, pid) <- createProcess $ modproc $ - (proc cmd opts) - { std_in = if isJust input then CreatePipe else Inherit - , std_out = CreatePipe - , std_err = CreatePipe - } + 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) diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs index 0181ea9..e89d103 100644 --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -35,9 +35,6 @@ instance (Arbitrary v, Ord v) => Arbitrary (S.Set v) where instance Arbitrary POSIXTime where arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral -instance Arbitrary EpochTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - {- Pids are never negative, or 0. -} instance Arbitrary ProcessID where arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index d3fe981..f190b40 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -11,10 +11,10 @@ module Utility.Rsync where import Common import Utility.Metered +import Utility.Tuple import Data.Char import System.Console.GetOpt -import Data.Tuple.Utils {- Generates parameters to make rsync use a specified command as its remote - shell. -} @@ -24,7 +24,7 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman {- rsync requires some weird, non-shell like quoting in - here. A doubled single quote inside the single quoted - string is a single quote. -} - escape s = "'" ++ intercalate "''" (split "'" s) ++ "'" + escape s = "'" ++ intercalate "''" (splitc '\'' s) ++ "'" {- Runs rsync in server mode to send a file. -} rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool @@ -123,7 +123,7 @@ parseRsyncProgress = go [] . reverse . progresschunks {- Find chunks that each start with delim. - The first chunk doesn't start with it - (it's empty when delim is at the start of the string). -} - progresschunks = drop 1 . split [delim] + progresschunks = drop 1 . splitc delim findbytesstart s = dropWhile isSpace s parsebytes :: String -> Maybe Integer diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs index 5ce17a8..eb34d3d 100644 --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -11,7 +11,7 @@ module Utility.SafeCommand where import System.Exit import Utility.Process -import Data.String.Utils +import Utility.Split import System.FilePath import Data.Char import Data.List @@ -86,7 +86,7 @@ shellEscape :: String -> String shellEscape f = "'" ++ escaped ++ "'" where -- replace ' with '"'"' - escaped = intercalate "'\"'\"'" $ split "'" f + escaped = intercalate "'\"'\"'" $ splitc '\'' f -- | Unescapes a set of shellEscaped words or filenames. shellUnEscape :: String -> [String] diff --git a/Utility/Split.hs b/Utility/Split.hs new file mode 100644 index 0000000..decfe7d --- /dev/null +++ b/Utility/Split.hs @@ -0,0 +1,30 @@ +{- split utility functions + - + - Copyright 2017 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} + +module Utility.Split where + +import Data.List (intercalate) +import Data.List.Split (splitOn) + +-- | same as Data.List.Utils.split +-- +-- intercalate x . splitOn x === id +split :: Eq a => [a] -> [a] -> [[a]] +split = splitOn + +-- | Split on a single character. This is over twice as fast as using +-- split on a list of length 1, while producing identical results. -} +splitc :: Eq c => c -> [c] -> [[c]] +splitc c s = case break (== c) s of + (i, _c:rest) -> i : splitc c rest + (i, []) -> i : [] + +-- | same as Data.List.Utils.replace +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace old new = intercalate new . split old diff --git a/Utility/Tuple.hs b/Utility/Tuple.hs new file mode 100644 index 0000000..25c6e8f --- /dev/null +++ b/Utility/Tuple.hs @@ -0,0 +1,17 @@ +{- tuple utility functions + - + - Copyright 2017 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.Tuple where + +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +thd3 :: (a,b,c) -> c +thd3 (_,_,c) = c diff --git a/git-repair.cabal b/git-repair.cabal index 7949439..490e69e 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -30,7 +30,7 @@ Flag network-uri Default: True custom-setup - Setup-Depends: base (>= 4.5), hslogger, MissingH, unix-compat, process, + Setup-Depends: base (>= 4.5), hslogger, split, unix-compat, process, unix, filepath, exceptions, bytestring, directory, IfElse, data-default, mtl, Cabal @@ -41,7 +41,7 @@ source-repository head Executable git-repair Main-Is: git-repair.hs GHC-Options: -threaded -Wall -fno-warn-tabs - Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, + Build-Depends: split, hslogger, directory, filepath, containers, mtl, unix-compat, bytestring, exceptions (>= 0.6), transformers, base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck, utf8-string, async, optparse-applicative (>= 0.10.0), @@ -92,6 +92,7 @@ Executable git-repair Utility.Batch Utility.CoProcess Utility.Data + Utility.DataUnits Utility.Directory Utility.DottedVersion Utility.Env @@ -100,18 +101,23 @@ Executable git-repair Utility.FileSize Utility.FileSystemEncoding Utility.Format + Utility.HumanNumber + Utility.HumanTime Utility.Metered Utility.Misc Utility.Monad Utility.PartialPrelude Utility.Path + Utility.Percentage Utility.PosixFiles Utility.Process Utility.Process.Shim Utility.QuickCheck Utility.Rsync Utility.SafeCommand + Utility.Split Utility.SystemDirectory Utility.ThreadScheduler Utility.Tmp + Utility.Tuple Utility.UserInfo -- cgit v1.2.3