From 122b09e2f24cff55c65b84cbccd78ed640a234be Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Dec 2016 14:53:58 -0400 Subject: Merge from git-annex. --- Utility/CoProcess.hs | 6 +++--- Utility/Exception.hs | 18 +++++++++++++++++- Utility/FileSystemEncoding.hs | 41 ++++++++++++++++++++++------------------- Utility/Metered.hs | 43 +++++++++++++++++++++++++++++-------------- Utility/Misc.hs | 17 ----------------- Utility/SystemDirectory.hs | 2 +- Utility/URI.hs | 18 ------------------ Utility/UserInfo.hs | 3 ++- 8 files changed, 74 insertions(+), 74 deletions(-) delete mode 100644 Utility/URI.hs (limited to 'Utility') diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs index 94d5ac3..2bae40f 100644 --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -47,10 +47,10 @@ start' s = do rawMode to return $ CoProcessState pid to from s where - rawMode h = do - fileEncoding h #ifdef mingw32_HOST_OS - hSetNewlineMode h noNewlineTranslation + rawMode h = hSetNewlineMode h noNewlineTranslation +#else + rawMode _ = return () #endif stop :: CoProcessHandle -> IO () diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 0ffc710..67c2e85 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2015 Joey Hess + - Copyright 2011-2016 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.Exception ( module X, + giveup, catchBoolIO, catchMaybeIO, catchDefaultIO, @@ -40,6 +41,21 @@ import GHC.IO.Exception (IOErrorType(..)) import Utility.Data +{- Like error, this throws an exception. Unlike error, if this exception + - is not caught, it won't generate a backtrace. So use this for situations + - where there's a problem that the user is excpected to see in some + - circumstances. -} +giveup :: [Char] -> a +#ifdef MIN_VERSION_base +#if MIN_VERSION_base(4,9,0) +giveup = errorWithoutStackTrace +#else +giveup = error +#endif +#else +giveup = error +#endif + {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs index eab9833..be43ace 100644 --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2016 Joey Hess - - License: BSD-2-clause -} @@ -9,7 +9,7 @@ {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.FileSystemEncoding ( - fileEncoding, + useFileSystemEncoding, withFilePath, md5FilePath, decodeBS, @@ -19,7 +19,6 @@ module Utility.FileSystemEncoding ( encodeW8NUL, decodeW8NUL, truncateFilePath, - setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -39,19 +38,30 @@ import qualified Data.ByteString.Lazy.UTF8 as L8 import Utility.Exception -{- Sets a Handle to use the filesystem encoding. This causes data - - written or read from it to be encoded/decoded the same - - as ghc 7.4 does to filenames etc. This special encoding - - allows "arbitrary undecodable bytes to be round-tripped through it". +{- Makes all subsequent Handles that are opened, as well as stdio Handles, + - use the filesystem encoding, instead of the encoding of the current + - locale. + - + - The filesystem encoding allows "arbitrary undecodable bytes to be + - round-tripped through it". This avoids encoded failures when data is not + - encoded matching the current locale. + - + - Note that code can still use hSetEncoding to change the encoding of a + - Handle. This only affects the default encoding. -} -fileEncoding :: Handle -> IO () +useFileSystemEncoding :: IO () +useFileSystemEncoding = do #ifndef mingw32_HOST_OS -fileEncoding h = hSetEncoding h =<< Encoding.getFileSystemEncoding + e <- Encoding.getFileSystemEncoding #else -{- The file system encoding does not work well on Windows, - - and Windows only has utf FilePaths anyway. -} -fileEncoding h = hSetEncoding h Encoding.utf8 + {- The file system encoding does not work well on Windows, + - and Windows only has utf FilePaths anyway. -} + let e = Encoding.utf8 #endif + hSetEncoding stdin e + hSetEncoding stdout e + hSetEncoding stderr e + Encoding.setLocaleEncoding e {- Marshal a Haskell FilePath into a NUL terminated C string using temporary - storage. The FilePath is encoded using the filesystem encoding, @@ -165,10 +175,3 @@ truncateFilePath n = reverse . go [] n . L8.fromString else go (c:coll) (cnt - x') (L8.drop 1 bs) _ -> coll #endif - -{- This avoids ghc's output layer crashing on invalid encoded characters in - - filenames when printing them out. -} -setConsoleEncoding :: IO () -setConsoleEncoding = do - fileEncoding stdout - fileEncoding stderr diff --git a/Utility/Metered.hs b/Utility/Metered.hs index 440aa3f..e21e18c 100644 --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -1,11 +1,11 @@ {- Metered IO and actions - - - Copyright 2012-2106 Joey Hess + - Copyright 2012-2016 Joey Hess - - License: BSD-2-clause -} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, BangPatterns #-} module Utility.Metered where @@ -85,12 +85,15 @@ streamMeteredFile f meterupdate h = withMeteredFile f meterupdate $ L.hPut h {- Writes a ByteString to a Handle, updating a meter as it's written. -} meteredWrite :: MeterUpdate -> Handle -> L.ByteString -> IO () -meteredWrite meterupdate h = go zeroBytesProcessed . L.toChunks +meteredWrite meterupdate h = void . meteredWrite' meterupdate h + +meteredWrite' :: MeterUpdate -> Handle -> L.ByteString -> IO BytesProcessed +meteredWrite' meterupdate h = go zeroBytesProcessed . L.toChunks where - go _ [] = return () + go sofar [] = return sofar go sofar (c:cs) = do S.hPut h c - let sofar' = addBytesProcessed sofar $ S.length c + let !sofar' = addBytesProcessed sofar $ S.length c meterupdate sofar' go sofar' cs @@ -112,30 +115,30 @@ offsetMeterUpdate base offset = \n -> base (offset `addBytesProcessed` n) - meter updates, so use caution. -} hGetContentsMetered :: Handle -> MeterUpdate -> IO L.ByteString -hGetContentsMetered h = hGetUntilMetered h (const True) +hGetContentsMetered h = hGetMetered h Nothing -{- Reads from the Handle, updating the meter after each chunk. +{- Reads from the Handle, updating the meter after each chunk is read. + - + - Stops at EOF, or when the requested number of bytes have been read. + - Closes the Handle at EOF, but otherwise leaves it open. - - Note that the meter update is run in unsafeInterleaveIO, which means that - it can be run at any time. It's even possible for updates to run out - of order, as different parts of the ByteString are consumed. - - - - Stops at EOF, or when keepgoing evaluates to False. - - Closes the Handle at EOF, but otherwise leaves it open. -} -hGetUntilMetered :: Handle -> (Integer -> Bool) -> MeterUpdate -> IO L.ByteString -hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed +hGetMetered :: Handle -> Maybe Integer -> MeterUpdate -> IO L.ByteString +hGetMetered h wantsize meterupdate = lazyRead zeroBytesProcessed where lazyRead sofar = unsafeInterleaveIO $ loop sofar loop sofar = do - c <- S.hGet h defaultChunkSize + c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) if S.null c then do hClose h return $ L.empty else do - let sofar' = addBytesProcessed sofar (S.length c) + let !sofar' = addBytesProcessed sofar (S.length c) meterupdate sofar' if keepgoing (fromBytesProcessed sofar') then do @@ -145,6 +148,18 @@ hGetUntilMetered h keepgoing meterupdate = lazyRead zeroBytesProcessed cs <- lazyRead sofar' return $ L.append (L.fromChunks [c]) cs else return $ L.fromChunks [c] + + keepgoing n = case wantsize of + Nothing -> True + Just sz -> n < sz + + nextchunksize n = case wantsize of + Nothing -> defaultChunkSize + Just sz -> + let togo = sz - n + in if togo < toInteger defaultChunkSize + then fromIntegral togo + else defaultChunkSize {- Same default chunk size Lazy ByteStrings use. -} defaultChunkSize :: Int diff --git a/Utility/Misc.hs b/Utility/Misc.hs index ebb4257..4498c0a 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -10,9 +10,6 @@ module Utility.Misc where -import Utility.FileSystemEncoding -import Utility.Monad - import System.IO import Control.Monad import Foreign @@ -35,20 +32,6 @@ hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s -{- Reads a file strictly, and using the FileSystemEncoding, so it will - - never crash on a badly encoded file. -} -readFileStrictAnyEncoding :: FilePath -> IO String -readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do - fileEncoding h - hClose h `after` hGetContentsStrict h - -{- Writes a file, using the FileSystemEncoding so it will never crash - - on a badly encoded content string. -} -writeFileAnyEncoding :: FilePath -> String -> IO () -writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do - fileEncoding h - hPutStr h content - {- Like break, but the item matching the condition is not included - in the second result list. - diff --git a/Utility/SystemDirectory.hs b/Utility/SystemDirectory.hs index 3dd44d1..b9040fe 100644 --- a/Utility/SystemDirectory.hs +++ b/Utility/SystemDirectory.hs @@ -13,4 +13,4 @@ module Utility.SystemDirectory ( module System.Directory ) where -import System.Directory hiding (isSymbolicLink) +import System.Directory hiding (isSymbolicLink, getFileSize) diff --git a/Utility/URI.hs b/Utility/URI.hs deleted file mode 100644 index e68fda5..0000000 --- a/Utility/URI.hs +++ /dev/null @@ -1,18 +0,0 @@ -{- Network.URI - - - - Copyright 2014 Joey Hess - - - - License: BSD-2-clause - -} - -{-# LANGUAGE CPP #-} - -module Utility.URI where - --- Old versions of network lacked an Ord for URI -#if ! MIN_VERSION_network(2,4,0) -import Network.URI - -instance Ord URI where - a `compare` b = show a `compare` show b -#endif diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs index ec0b0d0..dd66c33 100644 --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -16,6 +16,7 @@ module Utility.UserInfo ( import Utility.Env import Utility.Data +import Utility.Exception import System.PosixCompat import Control.Applicative @@ -25,7 +26,7 @@ import Prelude - - getpwent will fail on LDAP or NIS, so use HOME if set. -} myHomeDir :: IO FilePath -myHomeDir = either error return =<< myVal env homeDirectory +myHomeDir = either giveup return =<< myVal env homeDirectory where #ifndef mingw32_HOST_OS env = ["HOME"] -- cgit v1.2.3