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 ...@@ -555,9 +555,9 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do
out <- hGetContents outh out <- hGetContents outh
mv <- newEmptyMVar mv <- newEmptyMVar
let force str = (evaluate (length str) >> return ()) let force str = do
`Exception.finally` putMVar mv () mberr <- Exception.try (evaluate (length str) >> return ())
--TODO: handle exceptions like text decoding. putMVar mv (mberr :: Either IOError ())
_ <- forkIO $ force out _ <- forkIO $ force out
_ <- forkIO $ force err _ <- forkIO $ force err
...@@ -573,8 +573,8 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do ...@@ -573,8 +573,8 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do
-- or if it closes stdin (eg if it exits) -- or if it closes stdin (eg if it exits)
-- wait for both to finish, in either order -- wait for both to finish, in either order
takeMVar mv mberr1 <- takeMVar mv
takeMVar mv mberr2 <- takeMVar mv
-- wait for the program to terminate -- wait for the program to terminate
exitcode <- waitForProcess pid exitcode <- waitForProcess pid
...@@ -587,7 +587,17 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do ...@@ -587,7 +587,17 @@ rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do
Just ("", _) -> "" Just ("", _) -> ""
Just (inp, _) -> "\nstdin input:\n" ++ inp 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) return (out, err, exitcode)
where
reportOutputIOError :: Either IOError () -> IO ()
reportOutputIOError =
either (\e -> throwIO (ioeSetFileName e ("output of " ++ path)))
return
{-# DEPRECATED findProgramLocation {-# DEPRECATED findProgramLocation
......
...@@ -9,7 +9,9 @@ import Data.IORef ...@@ -9,7 +9,9 @@ import Data.IORef
import System.Directory ( doesDirectoryExist, doesFileExist import System.Directory ( doesDirectoryExist, doesFileExist
, getTemporaryDirectory , getTemporaryDirectory
, removeDirectoryRecursive, removeFile ) , 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
import Test.Tasty.HUnit import Test.Tasty.HUnit
...@@ -46,6 +48,24 @@ withTempDirRemovedTest = do ...@@ -46,6 +48,24 @@ withTempDirRemovedTest = do
withTempDirectory normal tempDir "foo" $ \dirPath -> do withTempDirectory normal tempDir "foo" $ \dirPath -> do
removeDirectoryRecursive dirPath 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 :: [TestTree]
tests = tests =
[ testCase "withTempFile works as expected" $ [ testCase "withTempFile works as expected" $
...@@ -56,4 +76,6 @@ tests = ...@@ -56,4 +76,6 @@ tests =
withTempDirTest withTempDirTest
, testCase "withTempDirectory can handle removed directories" $ , testCase "withTempDirectory can handle removed directories" $
withTempDirRemovedTest 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