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"