summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--CHANGELOG7
-rw-r--r--src/Propellor/CmdLine.hs2
-rw-r--r--src/Propellor/Gpg.hs7
-rw-r--r--src/Propellor/PrivData.hs4
-rw-r--r--src/Propellor/Property.hs2
-rw-r--r--src/Propellor/Property/Debootstrap.hs2
-rw-r--r--src/Propellor/Property/Gpg.hs2
-rw-r--r--src/Propellor/Shim.hs2
-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
-rw-r--r--src/wrapper.hs5
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 <id@joeyh.name> 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 <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
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