summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
Diffstat (limited to 'Utility')
-rw-r--r--Utility/DataUnits.hs8
-rw-r--r--Utility/FileSystemEncoding.hs27
-rw-r--r--Utility/Glob.hs27
-rw-r--r--Utility/Gpg.hs20
-rw-r--r--Utility/LinuxMkLibs.hs2
-rw-r--r--Utility/Metered.hs81
-rw-r--r--Utility/Misc.hs8
-rw-r--r--Utility/Path.hs13
-rw-r--r--Utility/Rsync.hs2
-rw-r--r--Utility/SafeCommand.hs2
-rw-r--r--Utility/Scheduled.hs2
-rw-r--r--Utility/Split.hs30
-rw-r--r--Utility/Tuple.hs8
13 files changed, 184 insertions, 46 deletions
diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs
index 6e40932ef..a6c9ffcf1 100644
--- a/Utility/DataUnits.hs
+++ b/Utility/DataUnits.hs
@@ -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
diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs
index 785b078ef..444dc4a90 100644
--- a/Utility/FileSystemEncoding.hs
+++ b/Utility/FileSystemEncoding.hs
@@ -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.
diff --git a/Utility/Glob.hs b/Utility/Glob.hs
index 119ea4834..c7d535933 100644
--- a/Utility/Glob.hs
+++ b/Utility/Glob.hs
@@ -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
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index f6173cdb4..336711b3f 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -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
diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs
index 122f39643..15f82fd18 100644
--- a/Utility/LinuxMkLibs.hs
+++ b/Utility/LinuxMkLibs.hs
@@ -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
diff --git a/Utility/Metered.hs b/Utility/Metered.hs
index e21e18cf1..626aa2ca1 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)
@@ -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
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 564935ddb..4498c0a03 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -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')
diff --git a/Utility/Path.hs b/Utility/Path.hs
index c53d122d5..0779d1676 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
@@ -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
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index d3823a528..f190b40de 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. -}
diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs
index bef0a619d..eb34d3de7 100644
--- a/Utility/SafeCommand.hs
+++ b/Utility/SafeCommand.hs
@@ -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
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
index d23aaf039..b68ff901c 100644
--- a/Utility/Scheduled.hs
+++ b/Utility/Scheduled.hs
@@ -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
diff --git a/Utility/Split.hs b/Utility/Split.hs
new file mode 100644
index 000000000..decfe7d39
--- /dev/null
+++ b/Utility/Split.hs
@@ -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
diff --git a/Utility/Tuple.hs b/Utility/Tuple.hs
index 78dd5d0c9..25c6e8f36 100644
--- a/Utility/Tuple.hs
+++ b/Utility/Tuple.hs
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-21 03:32:23 +0000