From 685a67a0f33ffa9328647137c693789ff7fe7d62 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Tue, 8 Apr 2025 12:03:05 -0700 Subject: [PATCH 1/2] Improve whitespace in `ExitCodeException` `Show` instance Split off of #83. Before, `ProcessConfig`'s `Show` output would include a trailing newline. This has been fixed, so that derived `Show` output does not include newlines in weird places. Before: ghci> data Foo = Foo { a :: Int, b :: ProcessConfig () () (), c :: String } deriving Show ghci> Foo 1 (proc "echo" ["puppy"]) "doggy" Foo {a = 1, b = Raw command: echo puppy , c = "doggy"} After ghci> Foo 1 (proc "echo" ["puppy"]) "doggy" Foo {a = 1, b = Raw command: echo puppy, c = "doggy"} Whitespace for the `ExitCodeException` `Show` instance has also been adjusted, to place the output closer to the relevant headers. Before: ghci> readProcess_ $ proc "sh" ["-c", "echo this is stdout; echo this is stderr >&2; false"] *** Exception: Received ExitFailure 1 when running Raw command: sh -c "echo this is stdout; echo this is stderr >&2; false" Standard output: this is stdout Standard error: this is stderr After: *** Exception: Received ExitFailure 1 when running Raw command: sh -c "echo this is stdout; echo this is stderr >&2; false" Standard output: this is stdout Standard error: this is stderr Note that because trailing whitespace is not accounted for, it is still possible to get unintuitive results depending on what exactly the subprocess prints: ghci> readProcess_ $ proc "sh" ["-c", "echo -n this is stdout; echo -n this is stderr >&2; false"] *** Exception: Received ExitFailure 1 when running Raw command: sh -c "echo -n this is stdout; echo -n this is stderr >&2; false" Standard output: this is stdout Standard error: this is stderr --- src/System/Process/Typed/Internal.hs | 81 ++++++++----- test/System/Process/TypedSpec.hs | 175 ++++++++++++++++++++++++++- 2 files changed, 222 insertions(+), 34 deletions(-) diff --git a/src/System/Process/Typed/Internal.hs b/src/System/Process/Typed/Internal.hs index 47ae083..4b53cdd 100644 --- a/src/System/Process/Typed/Internal.hs +++ b/src/System/Process/Typed/Internal.hs @@ -88,29 +88,37 @@ 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 env' -> + ["\nModified environment:"] + ++ do (key, value) <- env' + ["\n", key, "=", value] + instance (stdin ~ (), stdout ~ (), stderr ~ ()) => IsString (ProcessConfig stdin stdout stderr) where fromString s @@ -607,20 +615,29 @@ 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 stdout = L8.unpack $ eceStdout ece + stderr = L8.unpack $ eceStderr ece + stdout' = if L.null (eceStdout ece) + then [] + else [ "\n\nStandard output:\n" + , stdout + ] + stderr' = if L.null (eceStderr ece) + then [] + else [ "\nStandard error:\n" + , 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'. diff --git a/test/System/Process/TypedSpec.hs b/test/System/Process/TypedSpec.hs index 45003f9..7f89225 100644 --- a/test/System/Process/TypedSpec.hs +++ b/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,176 @@ 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 "Show ProcessConfig" $ do + it "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 "displays working directory" $ do + let processConfig = setWorkingDir "puppy/doggy" $ proc "true" [] + show processConfig `shouldBe` + "Raw command: true\n" + ++ "Run from: puppy/doggy" + + it "displays environment (inherited)" $ do + let processConfig = setEnvInherit $ proc "true" [] + show processConfig `shouldBe` + "Raw command: true" + + it "displays environment (cleared)" $ do + let processConfig = setEnv [] $ proc "true" [] + show processConfig `shouldBe` + "Raw command: true\n" + ++ "Modified environment:" -- lol + + it "displays environment (1 variable)" $ do + let processConfig = setEnv [("PUPPY", "DOGGY")] $ proc "true" [] + show processConfig `shouldBe` + "Raw command: true\n" + ++ "Modified environment:\n" + ++ "PUPPY=DOGGY" + + it "displays environment (multiple variables)" $ do + let processConfig = + setEnv [ ("PUPPY", "DOGGY") + , ("SOUND", "AWOO") + , ("HOWLING", "RIGHT_NOW") + ] + $ proc "true" [] + show processConfig `shouldBe` + "Raw command: true\n" + ++ "Modified environment:\n" + ++ "PUPPY=DOGGY\n" + ++ "SOUND=AWOO\n" + ++ "HOWLING=RIGHT_NOW" + + it "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" + ++ "Modified environment:\n" + ++ "PUPPY=DOGGY\n" + ++ "SOUND=AWOO" + + + describe "Show ExitCodeException" $ do + it "shows ExitCodeException" $ 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" + + context "without stderr" $ do + it "shows ExitCodeException" $ 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" + + context "without stdout" $ do + it "shows ExitCodeException" $ 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 "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" + + context "without newlines in stdout" $ do + it "shows ExitCodeException" $ 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" + + context "without newlines in stdout or stderr" $ do + it "shows ExitCodeException" $ 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" From 3907dec8fd692738926fd4e9a71fdb6a1ab6c2c8 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Tue, 8 Apr 2025 13:06:18 -0700 Subject: [PATCH 2/2] Trim trailing newlines in `ExitCodeException` `Show` instance Needs #88. Previously, output was assumed to end with a newline, leading to poor `ExitCodeException` rendering (see the "Standard error" header below): ghci> readProcess_ $ proc "sh" ["-c", "nix path-info --json nixpkgs#agda && false"] *** Exception: Received ExitFailure 1 when running Raw command: sh -c "nix path-info --json nixpkgs#agda && false" Standard output: [{"path":"/nix/store/sj2z0h5ywlflqv50dfphwia6p0ij0mlj-agdaWithPackages-2.6.4.3","valid":false}]Standard error: these 5 paths will be fetched (18.30 MiB download, 133.19 MiB unpacked): /nix/store/5q0kb0nqnqcfs7a0ncsjq4fdppwirpxa-Agda-2.6.4.3-bin /nix/store/xmximjjnkn0hm4gw7akc9f20ydz6msmk-Agda-2.6.4.3-data /nix/store/sj2z0h5ywlflqv50dfphwia6p0ij0mlj-agdaWithPackages-2.6.4.3 /nix/store/b49sa2q0yb3fd14ppzh6j6rm8vvgr9n6-ghc-9.6.6-with-packages /nix/store/vharimf7f2glj4fyhiglzws0qyv4xrry-libraries Now, trailing newlines are removed and the correct number of newlines are inserted in order to make the `Show` instance display legibly: ghci> readProcess_ $ proc "sh" ["-c", "nix path-info --json nixpkgs#agda && false"] *** Exception: Received ExitFailure 1 when running Raw command: sh -c "nix path-info --json nixpkgs#agda && false" Standard output: [{"path":"/nix/store/sj2z0h5ywlflqv50dfphwia6p0ij0mlj-agdaWithPackages-2.6.4.3","valid":false}] Standard error: these 5 paths will be fetched (18.30 MiB download, 133.19 MiB unpacked): /nix/store/5q0kb0nqnqcfs7a0ncsjq4fdppwirpxa-Agda-2.6.4.3-bin /nix/store/xmximjjnkn0hm4gw7akc9f20ydz6msmk-Agda-2.6.4.3-data /nix/store/sj2z0h5ywlflqv50dfphwia6p0ij0mlj-agdaWithPackages-2.6.4.3 /nix/store/b49sa2q0yb3fd14ppzh6j6rm8vvgr9n6-ghc-9.6.6-with-packages /nix/store/vharimf7f2glj4fyhiglzws0qyv4xrry-libraries Also, derived `Show` instances will behave correctly now. Previously, the `Show` instance would often end with a newline, leading to clumsy output: ghci> e stdout stderr = ExitCodeException { ... } ghci> data Foo = Foo { a :: Int, b :: ExitCodeException, c :: String } deriving Show ghci> Foo 1 (e "\n" "") "hello" Foo {a = 1, b = Received ExitFailure 1 when running Raw command: echo Standard output: , c = "hello"} Now: ghci> Foo 1 (e "\n" "") "hello" Foo {a = 1, b = Received ExitFailure 1 when running Raw command: echo Standard output: , c = "hello"} --- src/System/Process/Typed/Internal.hs | 19 +++++--- test/System/Process/TypedSpec.hs | 67 ++++++++++++++++++++++------ 2 files changed, 67 insertions(+), 19 deletions(-) diff --git a/src/System/Process/Typed/Internal.hs b/src/System/Process/Typed/Internal.hs index 4b53cdd..d9b9c3a 100644 --- a/src/System/Process/Typed/Internal.hs +++ b/src/System/Process/Typed/Internal.hs @@ -17,6 +17,7 @@ import qualified Control.Exception as E import Control.Exception hiding (bracket, finally, handle) import Control.Monad (void) import qualified System.Process as P +import Data.List (dropWhileEnd) import Data.Typeable (Typeable) import System.IO (Handle, hClose, IOMode(ReadWriteMode), withBinaryFile) import Control.Concurrent.Async (async) @@ -616,16 +617,24 @@ data ExitCodeException = ExitCodeException instance Exception ExitCodeException instance Show ExitCodeException where show ece = - let stdout = L8.unpack $ eceStdout ece - stderr = L8.unpack $ eceStderr ece - stdout' = if L.null (eceStdout ece) + let stdout = trimTrailingAsciiNewlines $ L8.unpack $ eceStdout ece + stderr = trimTrailingAsciiNewlines $ L8.unpack $ eceStderr ece + + isAsciiNewline char = case char of + '\n' -> True + '\r' -> True + _ -> False + trimTrailingAsciiNewlines = dropWhileEnd isAsciiNewline + + + stdout' = if null stdout then [] else [ "\n\nStandard output:\n" , stdout ] - stderr' = if L.null (eceStderr ece) + stderr' = if null stderr then [] - else [ "\nStandard error:\n" + else [ "\n\nStandard error:\n" , stderr ] in concat $ diff --git a/test/System/Process/TypedSpec.hs b/test/System/Process/TypedSpec.hs index 7f89225..e6c59f9 100644 --- a/test/System/Process/TypedSpec.hs +++ b/test/System/Process/TypedSpec.hs @@ -234,9 +234,6 @@ spec = do describe "Show ExitCodeException" $ do it "shows ExitCodeException" $ 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 @@ -252,7 +249,7 @@ spec = do ++ "Copied OK\n" ++ "\n" ++ "Standard error:\n" - ++ "Uh oh!\n" + ++ "Uh oh!" context "without stderr" $ do it "shows ExitCodeException" $ do @@ -268,7 +265,7 @@ spec = do ++ "Raw command: show-puppy\n" ++ "\n" ++ "Standard output:\n" - ++ "No puppies found???\n" + ++ "No puppies found???" context "without stdout" $ do it "shows ExitCodeException" $ do @@ -282,12 +279,55 @@ spec = do show exitCodeException `shouldBe` "Received ExitFailure 1 when running\n" ++ "Raw command: show-puppy\n" + ++ "\n" ++ "Standard error:\n" - ++ "No puppies found???\n" + ++ "No puppies found???" + + it "trims newlines from stdout/stderr" $ do + -- This keeps the `Show` output looking nice regardless of how many + -- newlines (if any) the command outputs. + -- + -- This also makes sure that the `Show` output doesn't end with a + -- spurious trailing newline, making it easier to compose `Show` + -- instances together. + let exitCodeException = + ExitCodeException + { eceExitCode = ExitFailure 1 + , eceProcessConfig = proc "detect-doggies" [] + , eceStdout = fromString "puppy\n\n" + , eceStderr = fromString "doggy\r\n" + } + show exitCodeException `shouldBe` + "Received ExitFailure 1 when running\n" + ++ "Raw command: detect-doggies\n" + ++ "\n" + ++ "Standard output:\n" + ++ "puppy\n" + ++ "\n" + ++ "Standard error:\n" + ++ "doggy" + + it "adds newlines to stdout/stderr" $ do + -- This keeps the `Show` output looking nice when the output + -- doesn't include a trailing newline. + 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" + ++ "\n" + ++ "Standard error:\n" + ++ "doggy" - it "does not trim stdout/stderr" $ do - -- This looks weird, and I think it would be better to strip the - -- whitespace from the output. + it "trims newlines but not other whitespace from stdout/stderr" $ do let exitCodeException = ExitCodeException { eceExitCode = ExitFailure 1 @@ -300,10 +340,10 @@ spec = do ++ "Raw command: detect-doggies\n" ++ "\n" ++ "Standard output:\n" - ++ "\n\npuppy\n\n \n" - ++ "\n" + ++ "\n\npuppy\n\n " + ++ "\n\n" ++ "Standard error:\n" - ++ "\t \ndoggy\n \t\n" + ++ "\t \ndoggy\n \t" context "without newlines in stdout" $ do it "shows ExitCodeException" $ do @@ -324,8 +364,6 @@ spec = do context "without newlines in stdout or stderr" $ do it "shows ExitCodeException" $ 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 @@ -339,5 +377,6 @@ spec = do ++ "\n" ++ "Standard output:\n" ++ "puppy\n" + ++ "\n" ++ "Standard error:\n" ++ "doggy"