diff --git a/package.yaml b/package.yaml index 76bdc96..c0de369 100644 --- a/package.yaml +++ b/package.yaml @@ -21,6 +21,7 @@ dependencies: - stm - transformers - unliftio-core +- text library: source-dirs: src diff --git a/src/System/Process/Typed/Internal.hs b/src/System/Process/Typed/Internal.hs index 47ae083..fe662c7 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,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'. diff --git a/test/System/Process/TypedSpec.hs b/test/System/Process/TypedSpec.hs index 45003f9..1786439 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,165 @@ 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 (1 variable)" $ do + let processConfig = setEnv [("PUPPY", "DOGGY")] $ proc "true" [] + show processConfig `shouldBe` + "Raw command: true\n" + ++ "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" + ++ "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" + ++ "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"