From 44bf67b7a2da75ef80e32d6409cc41a6ab8b6ffe Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Dec 2016 15:14:05 -0400 Subject: GHC's fileSystemEncoding is used for all String IO, to avoid encoding-related crashes in eg, Propellor.Property.File. --- CHANGELOG | 7 ++++++ src/Propellor/CmdLine.hs | 2 ++ src/Propellor/Gpg.hs | 7 ++---- src/Propellor/PrivData.hs | 4 +--- src/Propellor/Property.hs | 2 +- src/Propellor/Property/Debootstrap.hs | 2 +- src/Propellor/Property/Gpg.hs | 2 -- src/Propellor/Shim.hs | 2 -- src/Utility/Exception.hs | 26 +++++++++++++++++++--- src/Utility/FileSystemEncoding.hs | 41 +++++++++++++++++++---------------- src/Utility/Misc.hs | 17 --------------- src/Utility/SystemDirectory.hs | 2 +- src/Utility/UserInfo.hs | 16 ++++++++------ src/wrapper.hs | 5 ++++- 14 files changed, 73 insertions(+), 62 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index cb313e2f..20923ab8 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +propellor (3.2.4) UNRELEASED; urgency=medium + + * GHC's fileSystemEncoding is used for all String IO, to avoid + encoding-related crashes in eg, Propellor.Property.File. + + -- Joey Hess Sat, 24 Dec 2016 15:06:36 -0400 + propellor (3.2.3) unstable; urgency=medium * Improve extraction of gpg secret key id list, to work with gpg 2.1. diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index fc256109..c407fce8 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -19,6 +19,7 @@ import Propellor.Types.CmdLine import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim +import Utility.FileSystemEncoding usage :: Handle -> IO () usage h = hPutStrLn h $ unlines @@ -94,6 +95,7 @@ data CanRebuild = CanRebuild | NoRebuild -- | Runs propellor on hosts, as controlled by command-line options. defaultMain :: [Host] -> IO () defaultMain hostlist = withConcurrentOutput $ do + useFileSystemEncoding Shim.cleanEnv checkDebugMode cmdline <- processCmdLine diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs index fd2fca79..6ac153cc 100644 --- a/src/Propellor/Gpg.hs +++ b/src/Propellor/Gpg.hs @@ -16,7 +16,6 @@ import Utility.Process.NonConcurrent import Utility.Monad import Utility.Misc import Utility.Tmp -import Utility.FileSystemEncoding import Utility.Env import Utility.Directory @@ -183,7 +182,7 @@ gpgDecrypt :: FilePath -> IO String gpgDecrypt f = do gpgbin <- getGpgBin ifM (doesFileExist f) - ( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing (Just fileEncoding) + ( writeReadProcessEnv gpgbin ["--decrypt", f] Nothing Nothing Nothing , return "" ) @@ -201,6 +200,4 @@ gpgEncrypt f s = do encrypted <- writeReadProcessEnv gpgbin opts Nothing (Just writer) Nothing viaTmp writeFile f encrypted where - writer h = do - fileEncoding h - hPutStr h s + writer h = hPutStr h s diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 2e9cdbab..8ca51e23 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -57,7 +57,6 @@ import Utility.Misc import Utility.FileMode import Utility.Env import Utility.Table -import Utility.FileSystemEncoding import Utility.Directory -- | Allows a Property to access the value of a specific PrivDataField, @@ -171,7 +170,6 @@ getPrivData field context m = do setPrivData :: PrivDataField -> Context -> IO () setPrivData field context = do putStrLn "Enter private data on stdin; ctrl-D when done:" - fileEncoding stdin setPrivDataTo field context . PrivData =<< hGetContentsStrict stdin unsetPrivData :: PrivDataField -> Context -> IO () @@ -274,7 +272,7 @@ readPrivData :: String -> PrivMap readPrivData = fromMaybe M.empty . readish readPrivDataFile :: FilePath -> IO PrivMap -readPrivDataFile f = readPrivData <$> readFileStrictAnyEncoding f +readPrivDataFile f = readPrivData <$> readFileStrict f makePrivDataDir :: IO () makePrivDataDir = createDirectoryIfMissing False privDataDir diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index ae4fc914..8f51035b 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -222,7 +222,7 @@ changesFile p f = checkResult getstat comparestat p changesFileContent :: Checkable p i => p i -> FilePath -> Property i changesFileContent p f = checkResult getmd5 comparemd5 p where - getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrictAnyEncoding f + getmd5 = catchMaybeIO $ MD5.md5 . MD5.Str <$> readFileStrict f comparemd5 oldmd5 = do newmd5 <- getmd5 return $ if oldmd5 == newmd5 then NoChange else MadeChange diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index f8cb6e0e..db114e01 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -148,7 +148,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do . filter ("debootstrap_" `isInfixOf`) . filter (".tar." `isInfixOf`) . extractUrls baseurl <$> - readFileStrictAnyEncoding indexfile + readFileStrict indexfile nukeFile indexfile tarfile <- case urls of diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs index 74e9df5a..27baa4ba 100644 --- a/src/Propellor/Property/Gpg.hs +++ b/src/Propellor/Property/Gpg.hs @@ -2,7 +2,6 @@ module Propellor.Property.Gpg where import Propellor.Base import qualified Propellor.Property.Apt as Apt -import Utility.FileSystemEncoding import System.PosixCompat @@ -35,7 +34,6 @@ keyImported key@(GpgKeyId keyid) user@(User u) = prop ( return NoChange , makeChange $ withHandle StdinHandle createProcessSuccess (proc "su" ["-c", "gpg --import", u]) $ \h -> do - fileEncoding h hPutStr h (unlines keylines) hClose h ) diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs index 27545afb..811ae7f0 100644 --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -9,7 +9,6 @@ module Propellor.Shim (setup, cleanEnv, file) where import Propellor.Base import Utility.LinuxMkLibs import Utility.FileMode -import Utility.FileSystemEncoding import Data.List import System.Posix.Files @@ -57,7 +56,6 @@ shebang = "#!/bin/sh" checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath checkAlreadyShimmed f nope = ifM (doesFileExist f) ( withFile f ReadMode $ \h -> do - fileEncoding h s <- hGetLine h if s == shebang then return f 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 + - Copyright 2011-2016 Joey Hess - - 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,8 +95,10 @@ 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 + - 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/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 diff --git a/src/wrapper.hs b/src/wrapper.hs index 06051500..20b4d8c6 100644 --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -20,6 +20,7 @@ import Utility.Directory import Utility.FileMode import Utility.Process import Utility.Process.NonConcurrent +import Utility.FileSystemEncoding import System.Environment (getArgs) import System.Exit @@ -30,7 +31,9 @@ import Control.Applicative import Prelude main :: IO () -main = withConcurrentOutput $ go =<< getArgs +main = withConcurrentOutput $ do + useFileSystemEncoding + go =<< getArgs where go ["--init"] = interactiveInit go args = ifM configInCurrentWorkingDirectory -- cgit v1.3-2-g0d8e