From 61077748fea575bffa1326a30378340a25c51635 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Fri, 16 Aug 2024 10:10:04 -0700 Subject: [PATCH] Improve `ExitCodeException` `Show` instance Before, the arrangement of newlines in the `ExitCodeException` `Show` instance grouped stdout closer to the stderr header than the stdout header: 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 If there was no trailing newline for the stdout, the output would be formatted with no newline between the end of the stdout and the start of the stderr header: 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, the output is grouped more consistently and displays nicely regardless of trailing or leading newlines in the output: 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 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 The `Show` instance for `ProcessConfig` has also been touched up, removing edge cases like an empty "Modified environment" header: ghci> putStrLn $ show $ setEnv [] $ proc "sh" [] Raw command: sh Modified environment: Extraneous trailing newlines in `Show` instances have also been removed. --- src/System/Process/Typed/Internal.hs | 83 ++++++++++------ test/System/Process/TypedSpec.hs | 141 ++++++++++++++++++++++++++- 2 files changed, 191 insertions(+), 33 deletions(-) diff --git a/src/System/Process/Typed/Internal.hs b/src/System/Process/Typed/Internal.hs index 47ae083..4ba505c 100644 --- a/src/System/Process/Typed/Internal.hs +++ b/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,26 @@ 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 decodeStrip = T.unpack . T.strip . TL.toStrict . TLE.decodeUtf8With lenientDecode + stdout = decodeStrip $ eceStdout ece + stderr = decodeStrip $ eceStderr ece + stdout' = if null stdout + then [] + else ["\n\nStandard output:\n", stdout] + stderr' = if null stderr + then [] + else ["\n\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..27ac758 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 @@ -170,3 +170,142 @@ spec = do it "empty param are showed" $ let expected = "Raw command: podman exec --detach-keys \"\" ctx bash\n" 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 + 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!" + + 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???" + + 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" + ++ "\n" + ++ "Standard error:\n" + ++ "No puppies found???" + + it "Show trims 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 "\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" + ++ "puppy\n" + ++ "\n" + ++ "Standard error:\n" + ++ "doggy" + + it "Show displays correctly 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"