Commit 8dfdefce authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #3408 from dcoutts/fix-runprocess-io-output-exceptions

Report process output decoding errors in context
parents 7e8ea4ca 95ef187c
......@@ -555,9 +555,9 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do
out <- hGetContents outh
mv <- newEmptyMVar
let force str = (evaluate (length str) >> return ())
`Exception.finally` putMVar mv ()
--TODO: handle exceptions like text decoding.
let force str = do
mberr <- Exception.try (evaluate (length str) >> return ())
putMVar mv (mberr :: Either IOError ())
_ <- forkIO $ force out
_ <- forkIO $ force err
......@@ -573,8 +573,8 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do
-- or if it closes stdin (eg if it exits)
-- wait for both to finish, in either order
takeMVar mv
takeMVar mv
mberr1 <- takeMVar mv
mberr2 <- takeMVar mv
-- wait for the program to terminate
exitcode <- waitForProcess pid
......@@ -587,7 +587,17 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do
Just ("", _) -> ""
Just (inp, _) -> "\nstdin input:\n" ++ inp
-- Check if we we hit an exception while consuming the output
-- (e.g. a text decoding error)
reportOutputIOError mberr1
reportOutputIOError mberr2
return (out, err, exitcode)
where
reportOutputIOError :: Either IOError () -> IO ()
reportOutputIOError =
either (\e -> throwIO (ioeSetFileName e ("output of " ++ path)))
return
{-# DEPRECATED findProgramLocation
......
......@@ -9,7 +9,9 @@ import Data.IORef
import System.Directory ( doesDirectoryExist, doesFileExist
, getTemporaryDirectory
, removeDirectoryRecursive, removeFile )
import System.IO (hClose)
import System.IO (hClose, localeEncoding)
import System.IO.Error
import qualified Control.Exception as Exception
import Test.Tasty
import Test.Tasty.HUnit
......@@ -46,6 +48,24 @@ withTempDirRemovedTest = do
withTempDirectory normal tempDir "foo" $ \dirPath -> do
removeDirectoryRecursive dirPath
rawSystemStdInOutTextDecodingTest :: Assertion
rawSystemStdInOutTextDecodingTest
-- We can only get this exception when the locale encoding is UTF-8
-- so skip the test if it's not.
| show localeEncoding /= "UTF-8" = return ()
| otherwise = do
res <- Exception.try $
rawSystemStdInOut normal
-- hopefully this is sufficiently portable, we just need to execute a
-- program that will produce non-unicode output:
"ghc" ["-e", "Data.ByteString.putStr (Data.ByteString.pack [255])"]
Nothing Nothing Nothing
False -- not binary mode output, ie utf8 text mode so try to decode
case res of
Right _ -> assertFailure "expected IO decoding exception"
Left err | isDoesNotExistError err -> Exception.throwIO err -- no ghc!
| otherwise -> return ()
tests :: [TestTree]
tests =
[ testCase "withTempFile works as expected" $
......@@ -56,4 +76,6 @@ tests =
withTempDirTest
, testCase "withTempDirectory can handle removed directories" $
withTempDirRemovedTest
, testCase "rawSystemStdInOut reports text decoding errors" $
rawSystemStdInOutTextDecodingTest
]
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment