diff options
37 files changed, 230 insertions, 101 deletions
diff --git a/Annex/Branch.hs b/Annex/Branch.hs index af29b02b0..5482dc44b 100644 --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -29,8 +29,8 @@ module Annex.Branch ( import qualified Data.ByteString.Lazy as L import qualified Data.Set as S import qualified Data.Map as M -import Data.Bits.Utils import Data.Function +import Data.Char import Control.Concurrent (threadDelay) import Annex.Common @@ -304,7 +304,7 @@ commitIndex' jl branchref message basemessage retrynum parents = do -- look for "parent ref" lines and return the refs commitparents = map (Git.Ref . snd) . filter isparent . map (toassoc . decodeBS) . L.split newline - newline = c2w8 '\n' + newline = fromIntegral (ord '\n') toassoc = separate (== ' ') isparent (k,_) = k == "parent" diff --git a/Annex/UUID.hs b/Annex/UUID.hs index 0e87cda59..8a2d88427 100644 --- a/Annex/UUID.hs +++ b/Annex/UUID.hs @@ -37,7 +37,7 @@ import Config import qualified Data.UUID as U import qualified Data.UUID.V4 as U4 import qualified Data.UUID.V5 as U5 -import Data.Bits.Utils +import Utility.FileSystemEncoding configkey :: ConfigKey configkey = annexConfig "uuid" diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index d0acb8c60..3680349be 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -38,9 +38,9 @@ import Annex.Content.Direct import qualified Database.Keys import qualified Command.Sync import qualified Git.Branch +import Utility.Tuple import Data.Time.Clock -import Data.Tuple.Utils import qualified Data.Set as S import qualified Data.Map as M import Data.Either diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index 90bb3dc78..742b8c88f 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -44,13 +44,13 @@ import Git.FilePath import Config import Config.GitConfig import Utility.ThreadScheduler +import Utility.FileSystemEncoding import Logs.Location import qualified Database.Keys #ifndef mingw32_HOST_OS import qualified Utility.Lsof as Lsof #endif -import Data.Bits.Utils import Data.Typeable import qualified Data.ByteString.Lazy as L import qualified Control.Exception as E diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index 67a4d9fc2..cd1be4d4e 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -39,9 +39,9 @@ import qualified Utility.Lsof as Lsof import qualified Build.SysConfig import qualified Utility.Url as Url import qualified Annex.Url as Url +import Utility.Tuple import qualified Data.Map as M -import Data.Tuple.Utils {- Upgrade without interaction in the webapp. -} unattendedUpgrade :: Assistant () diff --git a/Build/EvilLinker.hs b/Build/EvilLinker.hs index 47111d476..8d3afa9cd 100644 --- a/Build/EvilLinker.hs +++ b/Build/EvilLinker.hs @@ -10,7 +10,6 @@ module Main where -import Data.List.Utils import Text.Parsec import Text.Parsec.String import Control.Applicative ((<$>)) @@ -23,6 +22,7 @@ import Utility.Process hiding (env) import qualified Utility.Process import Utility.Env import Utility.Directory +import Utility.Split data CmdParams = CmdParams { cmd :: String diff --git a/Build/EvilSplicer.hs b/Build/EvilSplicer.hs index 4e7b1c9bf..e07034c5b 100644 --- a/Build/EvilSplicer.hs +++ b/Build/EvilSplicer.hs @@ -35,7 +35,6 @@ import Text.Parsec.String import Control.Applicative ((<$>)) import Data.Either import Data.List hiding (find) -import Data.String.Utils import Data.Char import System.Environment import System.FilePath @@ -49,6 +48,7 @@ import Utility.Exception hiding (try) import Utility.Path import Utility.FileSystemEncoding import Utility.Directory +import Utility.Split data Coord = Coord { coordLine :: Int @@ -4,6 +4,8 @@ git-annex (6.20170511) UNRELEASED; urgency=medium When ssh connection caching is enabled (and when GIT_ANNEX_USE_GIT_SSH is not set), only one ssh password prompt will be made per host, and only one ssh password prompt will be made at a time. + * Removed dependency on MissingH, instead depending on the split library. + * Progress is displayed for transfers of files of unknown size. -- Joey Hess <id@joeyh.name> Thu, 11 May 2017 15:16:23 -0400 diff --git a/Command/List.hs b/Command/List.hs index 2676b5d5d..05f12822a 100644 --- a/Command/List.hs +++ b/Command/List.hs @@ -11,7 +11,6 @@ module Command.List where import qualified Data.Set as S import qualified Data.Map as M import Data.Function -import Data.Tuple.Utils import Data.Ord import Command @@ -20,6 +19,7 @@ import Logs.Trust import Logs.UUID import Annex.UUID import Git.Types (RemoteName) +import Utility.Tuple cmd :: Command cmd = noCommit $ withGlobalOptions annexedMatchingOptions $ diff --git a/Command/Uninit.hs b/Command/Uninit.hs index d8c7d1295..af628d7a9 100644 --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -18,9 +18,6 @@ import Annex.Content import Annex.Init import Utility.FileMode -import System.IO.HVFS -import System.IO.HVFS.Utils - cmd :: Command cmd = addCheck check $ command "uninit" SectionUtility @@ -101,7 +98,8 @@ prepareRemoveAnnexDir annexdir = do prepareRemoveAnnexDir' :: FilePath -> IO () prepareRemoveAnnexDir' annexdir = - recurseDir SystemFS annexdir >>= mapM_ (void . tryIO . allowWrite) + dirTreeRecursiveSkipping (const False) annexdir + >>= mapM_ (void . tryIO . allowWrite) {- Keys that were moved out of the annex have a hard link still in the - annex, with > 1 link count, and those can be removed. @@ -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 @@ -32,5 +31,6 @@ import Utility.Applicative as X import Utility.PosixFiles as X hiding (fileSize) import Utility.FileSize as X import Utility.Network as X +import Utility.Split as X import Utility.PartialPrelude as X diff --git a/Git/CatFile.hs b/Git/CatFile.hs index 4935cdffa..ba68c4ea3 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/Construct.hs b/Git/Construct.hs index 489927880..4ad74fd73 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -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. -} diff --git a/Git/Remote.hs b/Git/Remote.hs index 717b54045..f6eaf9362 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 1baf51a64..8e4324858 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/Messages/Progress.hs b/Messages/Progress.hs index c4f55de50..3c263c05c 100644 --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -23,34 +23,28 @@ import qualified System.Console.Regions as Regions import qualified System.Console.Concurrent as Console #endif -import Data.Progress.Meter -import Data.Progress.Tracker -import Data.Quantity - {- Shows a progress meter while performing a transfer of a key. - The action is passed a callback to use to update the meter. -} metered :: Maybe MeterUpdate -> Key -> (MeterUpdate -> Annex a) -> Annex a metered othermeter key a = withMessageState $ go (keySize key) where go _ (MessageState { outputType = QuietOutput }) = nometer - go Nothing (MessageState { outputType = NormalOutput }) = nometer - go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do + go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do showOutput - (progress, meter) <- mkmeter size - m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do - setP progress $ fromBytesProcessed n - displayMeter stdout meter + meter <- liftIO $ mkMeter msize bandwidthMeter $ + displayMeterHandle stdout + m <- liftIO $ rateLimitMeterUpdate 0.1 msize $ + updateMeter meter r <- a (combinemeter m) - liftIO $ clearMeter stdout meter + liftIO $ clearMeterHandle meter stdout return r - go (Just size) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = + go (msize) (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = #if WITH_CONCURRENTOUTPUT withProgressRegion $ \r -> do - (progress, meter) <- mkmeter size - m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $ \n -> do - setP progress $ fromBytesProcessed n - s <- renderMeter meter - Regions.setConsoleRegion r ("\n" ++ s) + meter <- liftIO $ mkMeter msize bandwidthMeter $ \_ s -> + Regions.setConsoleRegion r ('\n' : s) + m <- liftIO $ rateLimitMeterUpdate 0.1 msize $ + updateMeter meter a (combinemeter m) #else nometer @@ -62,11 +56,6 @@ metered othermeter key a = withMessageState $ go (keySize key) JSON.progress buf msize a (combinemeter m) - mkmeter size = do - progress <- liftIO $ newProgress "" size - meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1) - return (progress, meter) - nometer = a $ combinemeter (const noop) combinemeter m = case othermeter of diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index b72a60efa..1fe6d75be 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -21,13 +21,13 @@ module Remote.Helper.Encryptable ( import qualified Data.Map as M import qualified "sandi" Codec.Binary.Base64 as B64 import qualified Data.ByteString as B -import Data.Bits.Utils import Annex.Common import Types.Remote import Crypto import Types.Crypto import qualified Annex +import Utility.FileSystemEncoding -- Used to ensure that encryption has been set up before trying to -- eg, store creds in the remote config that would need to use the diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 28970872e..ae654d517 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -62,7 +62,7 @@ findSpecialRemotes s = do where remotepairs = M.toList . M.filterWithKey match construct (k,_) = Git.Construct.remoteNamedFromKey k (pure Git.Construct.fromUnknown) - match k _ = startswith "remote." k && endswith (".annex-"++s) k + match k _ = "remote." `isPrefixOf` k && (".annex-"++s) `isSuffixOf` k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex () diff --git a/Remote/Rsync/RsyncUrl.hs b/Remote/Rsync/RsyncUrl.hs index f7e9ebbb9..c0f30c1fb 100644 --- a/Remote/Rsync/RsyncUrl.hs +++ b/Remote/Rsync/RsyncUrl.hs @@ -17,7 +17,7 @@ import Utility.SafeCommand import Data.Default import System.FilePath.Posix #ifdef mingw32_HOST_OS -import Data.String.Utils +import Utility.Split #endif import Annex.DirHashes diff --git a/Remote/S3.hs b/Remote/S3.hs index ab8411726..a341da488 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -29,7 +29,6 @@ import Control.Monad.Trans.Resource import Control.Monad.Catch import Data.Conduit import Data.IORef -import Data.Bits.Utils import System.Log.Logger import Annex.Common @@ -46,6 +45,7 @@ import Annex.UUID import Logs.Web import Utility.Metered import Utility.DataUnits +import Utility.FileSystemEncoding import Annex.Content import Annex.Url (withUrlOptions) import Utility.Url (checkBoth, managerSettings, closeManager) diff --git a/Remote/WebDAV/DavLocation.hs b/Remote/WebDAV/DavLocation.hs index e0e184686..daa669de1 100644 --- a/Remote/WebDAV/DavLocation.hs +++ b/Remote/WebDAV/DavLocation.hs @@ -13,14 +13,14 @@ module Remote.WebDAV.DavLocation where import Types import Annex.Locations import Utility.Url (URLString) +#ifdef mingw32_HOST_OS +import Utility.Split +#endif import System.FilePath.Posix -- for manipulating url paths import Network.Protocol.HTTP.DAV (inDAVLocation, DAVT) import Control.Monad.IO.Class (MonadIO) import Data.Default -#ifdef mingw32_HOST_OS -import Data.String.Utils -#endif -- Relative to the top of the DAV url. type DavLocation = String diff --git a/Types/Distribution.hs b/Types/Distribution.hs index 80471c067..d19074bf9 100644 --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -8,12 +8,12 @@ module Types.Distribution where import Utility.PartialPrelude +import Utility.Split import Types.Key import Key import Data.Time.Clock import Git.Config (isTrue, boolConfig) -import Data.String.Utils import Control.Applicative import Prelude 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 diff --git a/debian/control b/debian/control index 1d012cea0..b34a79002 100644 --- a/debian/control +++ b/debian/control @@ -6,7 +6,7 @@ Build-Depends: ghc (>= 7.4), cabal-install, libghc-mtl-dev (>= 2.1.1), - libghc-missingh-dev, + libghc-split-dev, libghc-data-default-dev, libghc-hslogger-dev, libghc-pcre-light-dev, diff --git a/git-annex.cabal b/git-annex.cabal index 8d8255027..04b43d986 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -304,7 +304,7 @@ source-repository head location: git://git-annex.branchable.com/ 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, Cabal @@ -330,7 +330,6 @@ Executable git-annex directory (>= 1.2), filepath, IfElse, - MissingH, hslogger, monad-logger, free, @@ -362,7 +361,8 @@ Executable git-annex securemem, crypto-api, cryptonite, - memory + memory, + split CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs Extensions: PackageImports @@ -1051,6 +1051,7 @@ Executable git-annex Utility.Scheduled.QuickCheck Utility.Shell Utility.SimpleProtocol + Utility.Split Utility.SshConfig Utility.Su Utility.SystemDirectory @@ -1061,6 +1062,7 @@ Executable git-annex Utility.Tmp Utility.Tor Utility.Touch + Utility.Tuple Utility.Url Utility.UserInfo Utility.Verifiable |