Merge pull request #5951 from commercialhaskell/fix5897

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

ChangeLog.md

@@ -25,6 +25,12 @@ Behavior changes:
   [Haskell Error Index](https://errors.haskell.org/) initiative, all Stack
   error messages generated by Stack itself begin with an unique code in the
   form `[S-nnnn]`, where `nnnn` is a four-digit number.
+* Test suite executables that seek input on the standard input channel (`stdin`)
+  will not throw an exception. Previously, they would thow an exception,
+  consistent with Cabal's 'exitcode-stdio-1.0' test suite interface
+  specification. Pass the flag `--no-tests-allow-stdin` to `stack build` to
+  enforce Cabal's specification. See
+  [#5897](https://github.com/commercialhaskell/stack/issues/5897)
 
 Other enhancements:
 

doc/build_command.md

@@ -329,6 +329,20 @@ Pass the flag to build your project with the GHC options `-Wall` and `-Werror`.
 Pass the flag to rebuild your project every time any local file changes (from
 project packages or from local dependencies). See also the `--file-watch` flag.
 
+### The `stack build --tests-allow-stdin` flag
+
+:octicons-tag-24: Unreleased
+
+Default: Enabled
+
+Cabal defines a test suite interface
+['exitcode-stdio-1.0'](https://hackage.haskell.org/package/Cabal-syntax-3.8.1.0/docs/Distribution-Types-TestSuiteInterface.html#v:TestSuiteExeV1.0)
+where the test suite takes the form of an executable and the executable takes
+nothing on the standard input channel (`stdin`). Pass this flag to override that
+specification and allow the executable to receive input on that channel. If you
+pass `--no-tests-allow-stdin` and the executable seeks input on the standard
+input channel, an exception will be thown.
+
 ## Composition
 
 To come back to the composable approach described above, consider this example

src/Stack/Build/Execute.hs

@@ -2024,16 +2024,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

src/Stack/Config/Build.hs

@@ -81,6 +81,7 @@ testOptsFromMonoid TestOptsMonoid{..} madditional =
     , toCoverage = fromFirstFalse toMonoidCoverage
     , toDisableRun = fromFirstFalse toMonoidDisableRun
     , toMaximumTimeSeconds = fromFirst (toMaximumTimeSeconds defaultTestOpts) toMonoidMaximumTimeSeconds
+    , toAllowStdin = fromFirstTrue toMonoidAllowStdin
     }
 
 benchmarkOptsFromMonoid :: BenchmarkOptsMonoid -> Maybe [String] -> BenchmarkOpts

src/Stack/Options/TestParser.hs

@@ -42,4 +42,8 @@ testOptsParser hide0 =
                     (long "test-suite-timeout" <>
                      help "Maximum test suite run time in seconds." <>
                      hide))
+        <*> firstBoolFlagsTrue
+                "tests-allow-stdin"
+                "allow standard input in test executables"
+                hide
    where hide = hideMods hide0

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 = defaultFirstTrue toMonoidAllowStdin
     }
 
 data TestOptsMonoid =
@@ -381,6 +383,7 @@ data TestOptsMonoid =
     , toMonoidCoverage :: !FirstFalse
     , toMonoidDisableRun :: !FirstFalse
     , toMonoidMaximumTimeSeconds :: !(First (Maybe Int))
+    , toMonoidAllowStdin :: !FirstTrue
     } 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 <- FirstTrue <$> o ..:? toMonoidTestsAllowStdinName
               pure TestOptsMonoid{..})
 
 toMonoidRerunTestsArgName :: Text
@@ -407,6 +411,9 @@ toMonoidDisableRunArgName = "no-run-tests"
 toMonoidMaximumTimeSecondsArgName :: Text
 toMonoidMaximumTimeSecondsArgName = "test-suite-timeout"
 
+toMonoidTestsAllowStdinName :: Text
+toMonoidTestsAllowStdinName = "tests-allow-stdin"
+
 instance Semigroup TestOptsMonoid where
   (<>) = mappenddefault
 

src/test/Stack/ConfigSpec.hs

@@ -174,14 +174,17 @@ spec = beforeAll setup $ do
       boptsKeepTmpFiles `shouldBe` True
       boptsForceDirty `shouldBe` True
       boptsTests `shouldBe` True
-      boptsTestOpts `shouldBe` TestOpts {toRerunTests = True
-                                         ,toAdditionalArgs = ["-fprof"]
-                                         ,toCoverage = True
-                                         ,toDisableRun = True
-                                         ,toMaximumTimeSeconds = Nothing}
+      boptsTestOpts `shouldBe` TestOpts { toRerunTests = True
+                                        , toAdditionalArgs = ["-fprof"]
+                                        , toCoverage = True
+                                        , toDisableRun = True
+                                        , toMaximumTimeSeconds = Nothing
+                                        , toAllowStdin = True
+                                        }
       boptsBenchmarks `shouldBe` True
-      boptsBenchmarkOpts `shouldBe` BenchmarkOpts {beoAdditionalArgs = Just "-O2"
-                                                   ,beoDisableRun = True}
+      boptsBenchmarkOpts `shouldBe` BenchmarkOpts { beoAdditionalArgs = Just "-O2"
+                                                  , beoDisableRun = True
+                                                  }
       boptsReconfigure `shouldBe` True
       boptsCabalVerbose `shouldBe` CabalVerbosity verbose