Improve ExitCodeException Show instance

package.yaml

@@ -21,6 +21,7 @@ dependencies:
 - stm
 - transformers
 - unliftio-core
+- text
 
 library:
   source-dirs: src

src/System/Process/Typed/Internal.hs

@@ -17,6 +17,10 @@ import qualified Control.Exception as E
 import Control.Exception hiding (bracket, finally, handle)
 import Control.Monad (void)
 import qualified System.Process as P
+import qualified Data.Text as T
+import Data.Text.Encoding.Error (lenientDecode)
+import qualified Data.Text.Lazy as TL (toStrict)
+import qualified Data.Text.Lazy.Encoding as TLE
 import Data.Typeable (Typeable)
 import System.IO (Handle, hClose, IOMode(ReadWriteMode), withBinaryFile)
 import Control.Concurrent.Async (async)
@@ -88,29 +92,38 @@ data ProcessConfig stdin stdout stderr = ProcessConfig
 #endif
     }
 instance Show (ProcessConfig stdin stdout stderr) where
-    show pc = concat
-        [ case pcCmdSpec pc of
-            P.ShellCommand s -> "Shell command: " ++ s
-            P.RawCommand x xs -> "Raw command: " ++ unwords (map escape (x:xs))
-        , "\n"
-        , case pcWorkingDir pc of
-            Nothing -> ""
-            Just wd -> concat
-                [ "Run from: "
-                , wd
-                , "\n"
-                ]
-        , case pcEnv pc of
-            Nothing -> ""
-            Just e -> unlines
-                $ "Modified environment:"
-                : map (\(k, v) -> concat [k, "=", v]) e
-        ]
+    show pc = concat $
+        command
+        ++ workingDir
+        ++ env
       where
         escape x
             | any (`elem` " \\\"'") x = show x
             | x == "" = "\"\""
             | otherwise = x
+
+        command =
+            case pcCmdSpec pc of
+                P.ShellCommand s -> ["Shell command: ", s]
+                P.RawCommand program args ->
+                    ["Raw command:"]
+                    ++ do arg <- program:args
+                          [" ", escape arg]
+
+        workingDir =
+            case pcWorkingDir pc of
+              Nothing -> []
+              Just wd -> ["\nRun from: ", wd]
+
+        env =
+            case pcEnv pc of
+              Nothing -> []
+              Just [] -> []
+              Just env' ->
+                  ["\nEnvironment:"]
+                  ++ do (key, value) <- env'
+                        ["\n", key, "=", value]
+
 instance (stdin ~ (), stdout ~ (), stderr ~ ())
   => IsString (ProcessConfig stdin stdout stderr) where
     fromString s
@@ -607,20 +620,39 @@ data ExitCodeException = ExitCodeException
     deriving Typeable
 instance Exception ExitCodeException
 instance Show ExitCodeException where
-    show ece = concat
-        [ "Received "
-        , show (eceExitCode ece)
-        , " when running\n"
-        -- Too much output for an exception if we show the modified
-        -- environment, so hide it
-        , show (eceProcessConfig ece) { pcEnv = Nothing }
-        , if L.null (eceStdout ece)
-            then ""
-            else "Standard output:\n\n" ++ L8.unpack (eceStdout ece)
-        , if L.null (eceStderr ece)
-            then ""
-            else "Standard error:\n\n" ++ L8.unpack (eceStderr ece)
-        ]
+    show ece =
+        let decode = TL.toStrict . TLE.decodeUtf8With lenientDecode
+
+            isAsciiSpace char = case char of
+                                  ' ' -> True
+                                  '\t' -> True
+                                  '\n' -> True
+                                  '\r' -> True
+                                  _ -> False
+            isOnlyAsciiWhitespace = T.null . T.dropAround isAsciiSpace
+
+            stdout = decode $ eceStdout ece
+            stderr = decode $ eceStderr ece
+            stdout' = if isOnlyAsciiWhitespace stdout
+                         then []
+                         else [ "\n\nStandard output:\n"
+                              , T.unpack stdout
+                              ]
+            stderr' = if isOnlyAsciiWhitespace stderr
+                         then []
+                         else [ "\nStandard error:\n"
+                              , T.unpack stderr
+                              ]
+        in concat $
+            [ "Received "
+            , show (eceExitCode ece)
+            , " when running\n"
+            -- Too much output for an exception if we show the modified
+            -- environment, so hide it.
+            , show (eceProcessConfig ece) { pcEnv = Nothing }
+            ]
+            ++ stdout'
+            ++ stderr'
 
 -- | Wrapper for when an exception is thrown when reading from a child
 -- process, used by 'byteStringOutput'.

test/System/Process/TypedSpec.hs

@@ -12,7 +12,7 @@ import System.Exit
 import System.IO.Temp
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
-import Data.String (IsString)
+import Data.String (IsString(..))
 import Data.Monoid ((<>))
 import qualified Data.ByteString.Base64 as B64
 
@@ -168,5 +168,161 @@ spec = do
         L.take (L.length expected) lbs1 `shouldBe` expected
 
     it "empty param are showed" $
-      let expected = "Raw command: podman exec --detach-keys \"\" ctx bash\n"
+      let expected = "Raw command: podman exec --detach-keys \"\" ctx bash"
        in show (proc "podman" ["exec", "--detach-keys", "", "ctx", "bash"]) `shouldBe` expected
+
+    describe "ProcessConfig" $ do
+        it "Show shell-escapes arguments" $ do
+            let processConfig = proc "echo" ["a", "", "\"b\"", "'c'", "\\d"]
+            -- I promise this escaping behavior is correct; paste it into GHCi
+            -- `putStrLn` and then paste it into `sh` to verify.
+            show processConfig `shouldBe`
+                "Raw command: echo a \"\" \"\\\"b\\\"\" \"'c'\" \"\\\\d\""
+
+        it "Show displays working directory" $ do
+            let processConfig = setWorkingDir "puppy/doggy" $ proc "true" []
+            show processConfig `shouldBe`
+                "Raw command: true\n"
+                ++ "Run from: puppy/doggy"
+
+        it "Show displays environment (1 variable)" $ do
+            let processConfig = setEnv [("PUPPY", "DOGGY")] $ proc "true" []
+            show processConfig `shouldBe`
+                "Raw command: true\n"
+                ++ "Environment:\n"
+                ++ "PUPPY=DOGGY"
+
+        it "Show displays environment (multiple variables)" $ do
+            let processConfig =
+                    setEnv [ ("PUPPY", "DOGGY")
+                           , ("SOUND", "AWOO")
+                           , ("HOWLING", "RIGHT_NOW")
+                           ]
+                    $ proc "true" []
+            show processConfig `shouldBe`
+                "Raw command: true\n"
+                ++ "Environment:\n"
+                ++ "PUPPY=DOGGY\n"
+                ++ "SOUND=AWOO\n"
+                ++ "HOWLING=RIGHT_NOW"
+
+        it "Show displays working directory and environment" $ do
+            let processConfig =
+                    setEnv [ ("PUPPY", "DOGGY")
+                           , ("SOUND", "AWOO")
+                           ]
+                    $ setWorkingDir "puppy/doggy"
+                    $ proc "true" []
+            show processConfig `shouldBe`
+                "Raw command: true\n"
+                ++ "Run from: puppy/doggy\n"
+                ++ "Environment:\n"
+                ++ "PUPPY=DOGGY\n"
+                ++ "SOUND=AWOO"
+
+
+    describe "ExitCodeException" $ do
+        it "Show" $ do
+            -- Note that the `show` output ends with a newline, so functions
+            -- like `print` will output an extra blank line at the end of the
+            -- output.
+            let exitCodeException =
+                  ExitCodeException
+                      { eceExitCode = ExitFailure 1
+                      , eceProcessConfig = proc "cp" ["a", "b"]
+                      , eceStdout = fromString "Copied OK\n"
+                      , eceStderr = fromString "Uh oh!\n"
+                      }
+            show exitCodeException `shouldBe`
+                "Received ExitFailure 1 when running\n"
+                ++ "Raw command: cp a b\n"
+                ++ "\n"
+                ++ "Standard output:\n"
+                ++ "Copied OK\n"
+                ++ "\n"
+                ++ "Standard error:\n"
+                ++ "Uh oh!\n"
+
+        it "Show only stdout" $ do
+            let exitCodeException =
+                  ExitCodeException
+                      { eceExitCode = ExitFailure 1
+                      , eceProcessConfig = proc "show-puppy" []
+                      , eceStdout = fromString "No puppies found???\n"
+                      , eceStderr = fromString ""
+                      }
+            show exitCodeException `shouldBe`
+                "Received ExitFailure 1 when running\n"
+                ++ "Raw command: show-puppy\n"
+                ++ "\n"
+                ++ "Standard output:\n"
+                ++ "No puppies found???\n"
+
+        it "Show only stderr" $ do
+            let exitCodeException =
+                  ExitCodeException
+                      { eceExitCode = ExitFailure 1
+                      , eceProcessConfig = proc "show-puppy" []
+                      , eceStdout = fromString ""
+                      , eceStderr = fromString "No puppies found???\n"
+                      }
+            show exitCodeException `shouldBe`
+                "Received ExitFailure 1 when running\n"
+                ++ "Raw command: show-puppy\n"
+                ++ "Standard error:\n"
+                ++ "No puppies found???\n"
+
+        it "Show does not trim stdout/stderr" $ do
+            -- This looks weird, and I think it would be better to strip the
+            -- whitespace from the output.
+            let exitCodeException =
+                  ExitCodeException
+                      { eceExitCode = ExitFailure 1
+                      , eceProcessConfig = proc "detect-doggies" []
+                      , eceStdout = fromString "\n\npuppy\n\n \n"
+                      , eceStderr = fromString "\t \ndoggy\n \t\n"
+                      }
+            show exitCodeException `shouldBe`
+                "Received ExitFailure 1 when running\n"
+                ++ "Raw command: detect-doggies\n"
+                ++ "\n"
+                ++ "Standard output:\n"
+                ++ "\n\npuppy\n\n \n"
+                ++ "\n"
+                ++ "Standard error:\n"
+                ++ "\t \ndoggy\n \t\n"
+
+        it "Show displays weirdly with no newlines in stdout" $ do
+            -- Sometimes, commands don't output _any_ newlines!
+            let exitCodeException =
+                  ExitCodeException
+                      { eceExitCode = ExitFailure 1
+                      , eceProcessConfig = proc "detect-doggies" []
+                      , eceStdout = fromString "puppy"
+                      , eceStderr = fromString ""
+                      }
+            show exitCodeException `shouldBe`
+                "Received ExitFailure 1 when running\n"
+                ++ "Raw command: detect-doggies\n"
+                ++ "\n"
+                ++ "Standard output:\n"
+                ++ "puppy"
+
+        it "Show displays weirdly with no newlines in stdout or stderr" $ do
+            -- If the stderr isn't empty and stdout doesn't end with a newline,
+            -- the blank line between the two sections disappears.
+            let exitCodeException =
+                  ExitCodeException
+                      { eceExitCode = ExitFailure 1
+                      , eceProcessConfig = proc "detect-doggies" []
+                      , eceStdout = fromString "puppy"
+                      , eceStderr = fromString "doggy"
+                      }
+            show exitCodeException `shouldBe`
+                "Received ExitFailure 1 when running\n"
+                ++ "Raw command: detect-doggies\n"
+                ++ "\n"
+                ++ "Standard output:\n"
+                ++ "puppy\n"
+                ++ "Standard error:\n"
+                ++ "doggy"