Fix #5897 Add --[no-]allow-stdin flag to stack test

commercialhaskell · Nov 5, 2022 · 99cb0f9 · 99cb0f9
1 parent b13e86a
commit 99cb0f9
Show file tree

Hide file tree

Showing 4 changed files with 22 additions and 4 deletions.
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -1997,16 +1997,22 @@ singleTest topts testsToRun ac ee task installedMap = do
 
                         mec <- withWorkingDir (toFilePath pkgDir) $
                           optionalTimeout $ proc (toFilePath exePath) args $ \pc0 -> do
-                            stdinBS <-
+                            changeStdin <-
                               if isTestTypeLib
                                 then do
                                   logPath <- buildLogPath package (Just stestName)
                                   ensureDir (parent logPath)
-                                  pure $ BL.fromStrict
+                                  pure $ setStdin
+                                       $ byteStringInput
+                                       $ BL.fromStrict
                                        $ encodeUtf8 $ fromString $
                                        show (logPath, mkUnqualComponentName (T.unpack testName))
-                                else pure mempty
-                            let pc = setStdin (byteStringInput stdinBS)
+                                else do
+                                  isTerminal <- view $ globalOptsL.to globalTerminal
+                                  if toAllowStdin topts && isTerminal
+                                    then pure id
+                                    else pure $ setStdin $ byteStringInput mempty
+                            let pc = changeStdin
                                    $ setStdout output
                                    $ setStderr output
                                      pc0

diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs
@@ -81,6 +81,7 @@ testOptsFromMonoid TestOptsMonoid{..} madditional =
     , toCoverage = fromFirstFalse toMonoidCoverage
     , toDisableRun = fromFirstFalse toMonoidDisableRun
     , toMaximumTimeSeconds = fromFirst (toMaximumTimeSeconds defaultTestOpts) toMonoidMaximumTimeSeconds
+    , toAllowStdin = fromFirstFalse toMonoidAllowStdin
     }
 
 benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> Maybe [String] -> BenchmarkOpts

diff --git a/src/Stack/Options/TestParser.hs b/src/Stack/Options/TestParser.hs
@@ -42,4 +42,8 @@ testOptsParser hide0 =
                     (long "test-suite-timeout" <>
                      help "Maximum test suite run time in seconds." <>
                      hide))
+        <*> firstBoolFlagsFalse
+                "allow-stdin"
+                "allow standard input in test executables"
+                hide
    where hide = hideMods hide0
diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs
@@ -363,6 +363,7 @@ data TestOpts =
            ,toCoverage :: !Bool -- ^ Generate a code coverage report
            ,toDisableRun :: !Bool -- ^ Disable running of tests
            ,toMaximumTimeSeconds :: !(Maybe Int) -- ^ test suite timeout in seconds
+           ,toAllowStdin :: !Bool -- ^ Whether to allow standard input
            } deriving (Eq,Show)
 
 defaultTestOpts :: TestOpts
@@ -372,6 +373,7 @@ defaultTestOpts = TestOpts
     , toCoverage = defaultFirstFalse toMonoidCoverage
     , toDisableRun = defaultFirstFalse toMonoidDisableRun
     , toMaximumTimeSeconds = Nothing
+    , toAllowStdin = defaultFirstFalse toMonoidAllowStdin
     }
 
 data TestOptsMonoid =
@@ -381,6 +383,7 @@ data TestOptsMonoid =
     , toMonoidCoverage :: !FirstFalse
     , toMonoidDisableRun :: !FirstFalse
     , toMonoidMaximumTimeSeconds :: !(First (Maybe Int))
+    , toMonoidAllowStdin :: !FirstFalse
     } deriving (Show, Generic)
 
 instance FromJSON (WithJSONWarnings TestOptsMonoid) where
@@ -390,6 +393,7 @@ instance FromJSON (WithJSONWarnings TestOptsMonoid) where
               toMonoidCoverage <- FirstFalse <$> o ..:? toMonoidCoverageArgName
               toMonoidDisableRun <- FirstFalse <$> o ..:? toMonoidDisableRunArgName
               toMonoidMaximumTimeSeconds <- First <$> o ..:? toMonoidMaximumTimeSecondsArgName
+              toMonoidAllowStdin <- FirstFalse <$> o ..:? toMonoidAllowStdinName
               pure TestOptsMonoid{..})
 
 toMonoidRerunTestsArgName :: Text
@@ -407,6 +411,9 @@ toMonoidDisableRunArgName = "no-run-tests"
 toMonoidMaximumTimeSecondsArgName :: Text
 toMonoidMaximumTimeSecondsArgName = "test-suite-timeout"
 
+toMonoidAllowStdinName :: Text
+toMonoidAllowStdinName = "allow-stdin"
+
 instance Semigroup TestOptsMonoid where
   (<>) = mappenddefault