adeiu, MissingH

Removed dependency on MissingH, instead depending on the split
library.

After laying groundwork for this since 2015, it
was mostly straightforward. Added Utility.Tuple and
Utility.Split. Eyeballed System.Path.WildMatch while implementing
the same thing.

Since MissingH's progress meter display was being used, I re-implemented
my own. Bonus: Now progress is displayed for transfers of files of
unknown size.

This commit was sponsored by Shane-o on Patreon.
This commit is contained in:
Joey Hess 2017-05-15 23:32:17 -04:00
parent 6dd806f1ad
commit a1730cd6af
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
37 changed files with 230 additions and 101 deletions

View file

@ -45,6 +45,7 @@ module Utility.DataUnits (
ByteSize,
roughSize,
roughSize',
compareSizes,
readSize
) where
@ -109,7 +110,10 @@ oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits
{- approximate display of a particular number of bytes -}
roughSize :: [Unit] -> Bool -> ByteSize -> String
roughSize units short i
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
@ -123,7 +127,7 @@ roughSize units short i
showUnit x (Unit size abbrev name) = s ++ " " ++ unit
where
v = (fromInteger x :: Double) / fromInteger size
s = showImprecise 2 v
s = showImprecise precision v
unit
| short = abbrev
| s == "1" = name

View file

@ -19,6 +19,10 @@ module Utility.FileSystemEncoding (
encodeW8NUL,
decodeW8NUL,
truncateFilePath,
s2w8,
w82s,
c2w8,
w82c,
) where
import qualified GHC.Foreign as GHC
@ -27,15 +31,14 @@ import Foreign.C
import System.IO
import System.IO.Unsafe
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
@ -139,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.

View file

@ -1,3 +1,5 @@
{-# LANGUAGE PackageImports #-}
{- file globbing
-
- Copyright 2014 Joey Hess <id@joeyh.name>
@ -14,10 +16,9 @@ module Utility.Glob (
import Utility.Exception
import System.Path.WildMatch
import "regex-tdfa" Text.Regex.TDFA
import "regex-tdfa" Text.Regex.TDFA.String
import Data.Char
newtype Glob = Glob Regex
@ -30,11 +31,31 @@ compileGlob glob globcase = Glob $
Right r -> r
Left _ -> giveup $ "failed to compile regex: " ++ regex
where
regex = '^':wildToRegex glob
regex = '^' : wildToRegex glob ++ "$"
casesentitive = case globcase of
CaseSensative -> True
CaseInsensative -> False
wildToRegex :: String -> String
wildToRegex = concat . go
where
go [] = []
go ('*':xs) = ".*" : go xs
go ('?':xs) = "." : go xs
go ('[':'!':xs) = "[^" : inpat xs
go ('[':xs) = "[" : inpat xs
go (x:xs)
| isDigit x || isAlpha x = [x] : go xs
| otherwise = esc x : go xs
inpat [] = []
inpat (x:xs) = case x of
']' -> "]" : go xs
'\\' -> esc x : inpat xs
_ -> [x] : inpat xs
esc c = ['\\', c]
matchGlob :: Glob -> String -> Bool
matchGlob (Glob regex) val =
case execute regex val of

View file

@ -14,11 +14,9 @@ import qualified Build.SysConfig as SysConfig
#ifndef mingw32_HOST_OS
import System.Posix.Types
import qualified System.Posix.IO
import System.Path
import Utility.Env
#else
import Utility.Tmp
#endif
import Utility.Tmp
import Utility.Format (decode_c)
import Control.Concurrent
@ -336,23 +334,21 @@ keyBlock public ls = unlines
{- Runs an action using gpg in a test harness, in which gpg does
- not use ~/.gpg/, but a directory with the test key set up to be used. -}
testHarness :: GpgCmd -> IO a -> IO a
testHarness cmd a = do
orig <- getEnv var
bracket setup (cleanup orig) (const a)
testHarness cmd a = withTmpDir "gpgtmpXXXXXX" $ \tmpdir ->
bracket (setup tmpdir) (cleanup tmpdir) (const a)
where
var = "GNUPGHOME"
setup = do
base <- getTemporaryDirectory
dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
setEnv var dir True
setup tmpdir = do
orig <- getEnv var
setEnv var tmpdir True
-- For some reason, recent gpg needs a trustdb to be set up.
_ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] []
_ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines
[testSecretKey, testKey]
return dir
return orig
cleanup orig tmpdir = do
cleanup tmpdir orig = do
removeDirectoryRecursive tmpdir
-- gpg-agent may be shutting down at the same time
-- and may delete its socket at the same time as

View file

@ -12,10 +12,10 @@ import Utility.Directory
import Utility.Process
import Utility.Monad
import Utility.Path
import Utility.Split
import Data.Maybe
import System.FilePath
import Data.List.Utils
import System.Posix.Files
import Data.Char
import Control.Monad.IfElse

View file

@ -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)
@ -216,7 +219,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 +300,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

View file

@ -45,14 +45,6 @@ separate c l = unbreak $ break c l
| null b = r
| otherwise = (a, tail b)
{- Split on a single character. This is over twice as fast as using
- Data.List.Utils.split on a list of length 1, while producing
- identical results. -}
splitc :: Char -> String -> [String]
splitc c s = case break (== c) s of
(i, _c:rest) -> i : splitc c rest
(i, []) -> i : []
{- Breaks out the first line. -}
firstLine :: String -> String
firstLine = takeWhile (/= '\n')

View file

@ -10,7 +10,6 @@
module Utility.Path where
import Data.String.Utils
import System.FilePath
import Data.List
import Data.Maybe
@ -28,6 +27,7 @@ import Utility.Exception
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.
@ -76,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
@ -140,9 +141,9 @@ relPathDirToFileAbs from to
where
pfrom = sp from
pto = sp to
sp = dropTrailingPathSeparator . splitPath
sp = map dropTrailingPathSeparator . splitPath
common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c = d
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common

View file

@ -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. -}

View file

@ -11,7 +11,7 @@ module Utility.SafeCommand where
import System.Exit
import Utility.Process
import Utility.Misc
import Utility.Split
import System.FilePath
import Data.Char
import Data.List

View file

@ -29,6 +29,7 @@ module Utility.Scheduled (
import Utility.Data
import Utility.PartialPrelude
import Utility.Misc
import Utility.Tuple
import Data.List
import Data.Time.Clock
@ -37,7 +38,6 @@ import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.OrdinalDate
import Data.Time.Format ()
import Data.Tuple.Utils
import Data.Char
import Control.Applicative
import Prelude

30
Utility/Split.hs Normal file
View file

@ -0,0 +1,30 @@
{- split utility functions
-
- Copyright 2017 Joey Hess <id@joeyh.name>
-
- 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

View file

@ -5,11 +5,13 @@
- License: BSD-2-clause
-}
module Utility.Tuple where
fst3 :: (a,b,c) -> a
fst3 (a,b,c) = a
fst3 (a,_,_) = a
snd3 :: (a,b,c) -> b
snd3 (a,b,c) = b
snd3 (_,b,_) = b
thd3 :: (a,b,c) -> c
thd3 (a,b,c) = c
thd3 (_,_,c) = c