summaryrefslogtreecommitdiff
path: root/src/Utility
diff options
context:
space:
mode:
authorJoey Hess2016-12-24 15:14:05 -0400
committerJoey Hess2016-12-24 15:14:05 -0400
commit44bf67b7a2da75ef80e32d6409cc41a6ab8b6ffe (patch)
treed955382901fd4ea2bec6412d5b652d9ac7ecbe23 /src/Utility
parentfa974cfaaac31b25ae911b5e970507d0589e567b (diff)
GHC's fileSystemEncoding is used for all String IO, to avoid encoding-related crashes in eg, Propellor.Property.File.
Diffstat (limited to 'src/Utility')
-rw-r--r--src/Utility/Exception.hs26
-rw-r--r--src/Utility/FileSystemEncoding.hs41
-rw-r--r--src/Utility/Misc.hs17
-rw-r--r--src/Utility/SystemDirectory.hs2
-rw-r--r--src/Utility/UserInfo.hs16
5 files changed, 55 insertions, 47 deletions
diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
index f6551b45..67c2e85d 100644
--- a/src/Utility/Exception.hs
+++ b/src/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,
@@ -28,9 +29,11 @@ module Utility.Exception (
import Control.Monad.Catch as X hiding (Handler)
import qualified Control.Monad.Catch as M
import Control.Exception (IOException, AsyncException)
-#if MIN_VERSION_base(4,7,0)
+#ifdef MIN_VERSION_GLASGOW_HASKELL
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
import Control.Exception (SomeAsyncException)
#endif
+#endif
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Error (isDoesNotExistError, ioeGetErrorType)
@@ -38,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
@@ -77,9 +95,11 @@ bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup)
catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a
catchNonAsync a onerr = a `catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
-#if MIN_VERSION_base(4,7,0)
+#ifdef MIN_VERSION_GLASGOW_HASKELL
+#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
, M.Handler (\ (e :: SomeAsyncException) -> throwM e)
#endif
+#endif
, M.Handler (\ (e :: SomeException) -> onerr e)
]
diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs
index eab98337..be43ace9 100644
--- a/src/Utility/FileSystemEncoding.hs
+++ b/src/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/src/Utility/Misc.hs b/src/Utility/Misc.hs
index ebb42576..4498c0a0 100644
--- a/src/Utility/Misc.hs
+++ b/src/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/src/Utility/SystemDirectory.hs b/src/Utility/SystemDirectory.hs
index 3dd44d19..b9040fe1 100644
--- a/src/Utility/SystemDirectory.hs
+++ b/src/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/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs
index c6010116..dd66c331 100644
--- a/src/Utility/UserInfo.hs
+++ b/src/Utility/UserInfo.hs
@@ -15,6 +15,8 @@ module Utility.UserInfo (
) where
import Utility.Env
+import Utility.Data
+import Utility.Exception
import System.PosixCompat
import Control.Applicative
@@ -24,7 +26,7 @@ import Prelude
-
- getpwent will fail on LDAP or NIS, so use HOME if set. -}
myHomeDir :: IO FilePath
-myHomeDir = myVal env homeDirectory
+myHomeDir = either giveup return =<< myVal env homeDirectory
where
#ifndef mingw32_HOST_OS
env = ["HOME"]
@@ -33,7 +35,7 @@ myHomeDir = myVal env homeDirectory
#endif
{- Current user's user name. -}
-myUserName :: IO String
+myUserName :: IO (Either String String)
myUserName = myVal env userName
where
#ifndef mingw32_HOST_OS
@@ -47,15 +49,15 @@ myUserGecos :: IO (Maybe String)
#if defined(__ANDROID__) || defined(mingw32_HOST_OS)
myUserGecos = return Nothing
#else
-myUserGecos = Just <$> myVal [] userGecos
+myUserGecos = eitherToMaybe <$> myVal [] userGecos
#endif
-myVal :: [String] -> (UserEntry -> String) -> IO String
+myVal :: [String] -> (UserEntry -> String) -> IO (Either String String)
myVal envvars extract = go envvars
where
#ifndef mingw32_HOST_OS
- go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)
+ go [] = Right . extract <$> (getUserEntryForID =<< getEffectiveUserID)
#else
- go [] = extract <$> error ("environment not set: " ++ show envvars)
+ go [] = return $ Left ("environment not set: " ++ show envvars)
#endif
- go (v:vs) = maybe (go vs) return =<< getEnv v
+ go (v:vs) = maybe (go vs) (return . Right) =<< getEnv v