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:
parent
6dd806f1ad
commit
a1730cd6af
37 changed files with 230 additions and 101 deletions
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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')
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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. -}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
30
Utility/Split.hs
Normal 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
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue