summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
Diffstat (limited to 'Utility')
-rw-r--r--Utility/CoProcess.hs6
-rw-r--r--Utility/Exception.hs18
-rw-r--r--Utility/FileSystemEncoding.hs41
-rw-r--r--Utility/Metered.hs43
-rw-r--r--Utility/Misc.hs17
-rw-r--r--Utility/SystemDirectory.hs2
-rw-r--r--Utility/URI.hs18
-rw-r--r--Utility/UserInfo.hs3
8 files changed, 74 insertions, 74 deletions
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 <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
-
- 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 <id@joeyh.name>
+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>
-
- 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 <id@joeyh.name>
+ - Copyright 2012-2016 Joey Hess <id@joeyh.name>
-
- 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 <id@joeyh.name>
- -
- - 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"]
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-28 14:10:06 +0000