eval: feed stdin from an empty temporary file to avoid hangs

ghcide/src/Development/IDE/Main.hs

@@ -7,6 +7,7 @@ module Development.IDE.Main
 ,isLSP
 ,commandP
 ,defaultMain
+,emptyStdin
 ,testing
 ,Log(..)
 ) where
@@ -87,9 +88,12 @@ import           Development.IDE.Types.Options            (IdeGhcSession,
 import           Development.IDE.Types.Shake              (WithHieDb,
                                                            toNoFileKey)
 import           GHC.Conc                                 (getNumProcessors)
+import           GHC.IO.Device                            (IODeviceType (Stream))
 import           GHC.IO.Encoding                          (setLocaleEncoding)
 import           GHC.IO.Handle                            (hDuplicate,
                                                            hDuplicateTo)
+import           GHC.IO.Handle.FD                         (fdToHandle,
+                                                           fdToHandle')
 import           HIE.Bios.Cradle                          (findCradle)
 import qualified HieDb.Run                                as HieDb
 import           Ide.Logger                               (Pretty (pretty),
@@ -122,12 +126,15 @@ import           System.Exit                              (ExitCode (ExitFailure
 import           System.FilePath                          (takeExtension,
                                                            takeFileName, (</>))
 import           System.IO                                (BufferMode (LineBuffering, NoBuffering),
-                                                           Handle, hFlush,
+                                                           Handle,
+                                                           IOMode (ReadMode),
+                                                           hClose, hFlush,
                                                            hPutStrLn,
                                                            hSetBuffering,
                                                            hSetEncoding, stderr,
                                                            stdin, stdout, utf8)
-import           System.Process                           (readProcessWithExitCode)
+import           System.Process                           (createPipeFd,
+                                                           readProcessWithExitCode)
 import           System.Random                            (newStdGen)
 import           System.Time.Extra                        (Seconds, offsetTime,
                                                            showDuration)
@@ -251,7 +258,14 @@ defaultArguments recorder projectRoot plugins = Arguments
         , argsGetHieDbLoc = getHieDbLoc
         , argsDebouncer = newAsyncDebouncer
         , argsThreads = Nothing
-        , argsHandleIn = pure stdin
+        , argsHandleIn = do
+                -- Move stdin to another file descriptor and point stdin at an
+                -- empty pipe. This guards against code in the server process
+                -- (e.g., the eval plugin) consuming or blocking on the JSON-RPC
+                -- message stream.
+                newStdin <- hDuplicate stdin
+                emptyStdin
+                return newStdin
         , argsHandleOut = do
                 -- Move stdout to another file descriptor and duplicate stderr
                 -- to stdout. This guards against stray prints from corrupting the JSON-RPC
@@ -271,6 +285,19 @@ defaultArguments recorder projectRoot plugins = Arguments
         , argsDisableInitialCwdShift = False
         }
 
+-- | Point 'stdin' at the read end of a closed pipe. Code running in the server
+-- process (e.g., expressions evaluated by the eval plugin) then reads "end of
+-- file", instead of consuming JSON-RPC messages or blocking on the same handle
+-- the server reads them from.
+emptyStdin :: IO ()
+emptyStdin = do
+    (readFd, writeFd) <- createPipeFd
+    hClose =<< fdToHandle writeFd
+    -- Not 'createPipe': on Windows, it returns a duplex handle, which
+    -- 'hDuplicateTo'' cannot duplicate onto the file handle 'stdin'.
+    readEnd <- fdToHandle' readFd (Just Stream) False "<empty stdin>" ReadMode False
+    readEnd `hDuplicateTo` stdin
+    hClose readEnd
 
 testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments
 testing recorder projectRoot plugins =

hls-test-utils/src/Test/Hls.hs

@@ -845,7 +845,7 @@ runSessionWithTestConfig TestConfig{..} session =
     keepAlive (pipeIn, pipeOut) $ do
       server <- async $
           IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde)
-              arguments { argsHandleIn = pure inR , argsHandleOut = pure outW }
+              arguments { argsHandleIn = emptyStdin >> pure inR , argsHandleOut = pure outW }
       result <- runSessionWithHandles inW outR sconf' testConfigCaps clientRoot (session root)
       hClose inW
       timeout 3 (wait server) >>= \case

plugins/hls-eval-plugin/README.md

@@ -180,11 +180,11 @@ N + M + 1 :: Nat
 "Other"
 ```
 
-IO expressions can also be evaluated but their output to stdout/stderr is NOT captured:
+IO expressions can also be evaluated and their output to `stdout`/`stderr` is captured:
 
 ```
 >>> print "foo"
-()
+"foo"
 ```
 
 ### Properties

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs

@@ -28,8 +28,9 @@ import           GHC                         (ExecOptions, ExecResult (..),
 import           Ide.Logger                  (Recorder, WithPriority, logWith)
 import qualified Ide.Logger                  as Log
 
-import           Ide.Plugin.Eval.Types       (EvalExpr (..), Language (Plain),
-                                              Loc, Located (..), Log (..),
+import           Ide.Plugin.Eval.Types       (CapturePhase (..), EvalExpr (..),
+                                              Language (Plain), Loc,
+                                              Located (..), Log (..),
                                               Section (sectionLanguage), Txt,
                                               locate, locate0)
 import           Ide.Plugin.Eval.Util        (gStrictTry)
@@ -117,7 +118,7 @@ execStmtCaptureResult ::
 execStmtCaptureResult recorder stmt opts = do
     (result, (output, execResultE)) <-
       withCaptureResult recorder $
-        withCaptureStdHandles opts $
+        withCaptureStdHandles recorder opts $
            gStrictTry (execStmt stmt opts)
     case execResultE of
       Left exc ->
@@ -146,7 +147,8 @@ execStmtCaptureResult recorder stmt opts = do
       where
         trimmed = dropWhileEnd (== '\n') output
 
--- 'System.IO.Extra.withTempFile' is specialized to 'IO'.
+-- Like 'System.IO.Extra.withTempFile', but polymorphic (needs to run in 'Ghc'
+-- and 'IO'), and also returns the file's contents.
 withTempFile :: (MonadIO m, MonadMask m) => (FilePath -> m b) -> m (String, b)
 withTempFile k = do
     bracket
@@ -187,23 +189,44 @@ withCaptureResult recorder action = withTempFile $ \resultTemp -> do
 -- may leak. base provides no per-thread standard handles, so this is
 -- unavoidable with this approach.
 withCaptureStdHandles ::
-     ExecOptions
+     Recorder (WithPriority Log)
+  -> ExecOptions
   -> Ghc a
   -> Ghc (String, a)
-withCaptureStdHandles opts action = withTempFile $ \outputTemp -> do
+withCaptureStdHandles recorder opts action = withTempFile $ \outputTemp -> do
     bracket
-      (execStmt (captureSetup outputTemp) opts)
+      (execStmtCheck recorder (captureSetup outputTemp) opts)
       -- Restore the handles no matter how the statement terminated.
-      (\_ -> execStmt captureTeardown opts)
+      (\_ -> execStmtCheck recorder captureTeardown opts)
       (\_ -> action)
 
+-- | Run an internal handle-redirection statement and log on failure.
+execStmtCheck ::
+     Recorder (WithPriority Log)
+  -> CapturePhase
+  -> ExecOptions
+  -> Ghc ()
+execStmtCheck recorder phase opts = do
+    result <- execStmt stmt opts
+    case result of
+      ExecComplete (Left err) _ ->
+        logWith recorder Log.Warning $ LogEvalCaptureStdHandles phase (show err)
+      _ -> pure ()
+  where
+    stmt = case phase of
+      CaptureSetup    x -> x
+      CaptureTeardown x -> x
+
 -- Open a temporary file and redirect the interpreted @stdout@/@stderr@ to
 -- it, saving the original handles in interactive bindings so 'captureTeardown'
 -- can restore them. Bound to a tuple (rather than evaluated as a bare
 -- expression) so GHCi does not pass it to the interactive print function.
-captureSetup :: FilePath -> String
+--
+-- @stdin@ is left alone: the server has already pointed it at an empty pipe
+-- (see 'Development.IDE.Main.emptyStdin'), so reads hit end of file.
+captureSetup :: FilePath -> CapturePhase
 -- Squeeze into one line (executed by GHCi).
-captureSetup outputTemp = unwords
+captureSetup outputTemp = CaptureSetup $ unwords
     [ "(__hls_captureHandle, __hls_savedStdout, __hls_savedStderr) <- do {"
     , "  __hls_h <- System.IO.openFile", show outputTemp, "System.IO.WriteMode;"
     , "  System.IO.hSetBuffering __hls_h System.IO.LineBuffering;"
@@ -217,9 +240,9 @@ captureSetup outputTemp = unwords
 
 -- Flush, restore the original handles and close the temporary file so the
 -- host can read back the captured output.
-captureTeardown :: String
+captureTeardown :: CapturePhase
 -- Squeeze into one line (executed by GHCi).
-captureTeardown = unwords
+captureTeardown = CaptureTeardown $ unwords
     [ "__hls_restored <- do {"
     , "  System.IO.hFlush System.IO.stdout;"
     , "  System.IO.hFlush System.IO.stderr;"

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs

@@ -10,6 +10,7 @@
 
 module Ide.Plugin.Eval.Types
     ( Log(..),
+      CapturePhase(..),
       locate,
       locate0,
       EvalExpr (..),
@@ -76,6 +77,27 @@ data Log
     | LogEvalImport String
     | LogEvalDeclaration String
     | LogEvalFailedSettingInteractivePrintFunction
+    | LogEvalCaptureStdHandles CapturePhase String
+
+-- | Phases required to capture standard handles
+--
+-- Phases of the @eval@ plugin:
+-- - fire up a GHCi session
+-- - inject code into the GHCi session
+-- - run the code
+-- - capture the output
+--
+-- The code injected into the GHCi session contains a setup and a teardown
+-- preparing and closing the involved handles, see 'captureSetup' and
+-- 'captureTeardown'.
+data CapturePhase =
+    CaptureSetup    String
+  | CaptureTeardown String
+
+instance Pretty CapturePhase where
+    pretty = \case
+        CaptureSetup{}    -> "setup"
+        CaptureTeardown{} -> "teardown"
 
 instance Pretty Log where
     pretty = \case
@@ -108,6 +130,9 @@ instance Pretty Log where
         LogEvalFailedSettingInteractivePrintFunction -> pretty $
                "Return value will not be captured: "
             ++ "Failed setting the interactive print function."
+        LogEvalCaptureStdHandles phase err ->
+            "Redirecting stdout/stderr failed during capture" <+> pretty phase
+            <> ":" <+> pretty err
 
 -- | A thing with a location attached.
 data Located l a = Located {location :: l, located :: a}

plugins/hls-eval-plugin/test/Main.hs

@@ -128,8 +128,9 @@ tests =
       evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a"
       evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id" "-- id :: forall a. a -> a"
   , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"
-  , goldenWithEval "Support IO expressions, capture and show stdout/stderr output" "TIO" "hs"
-  , goldenWithEval "Support IO expressions, close handles on errors" "TIOError" "hs"
+  , goldenWithEval "Support IO expressions (stdout), capture and show stdout output" "TIOStdout" "hs"
+  , goldenWithEval "Support IO expressions (stderr), capture and show stderr output" "TIOStderr" "hs"
+  , goldenWithEval "Support IO expressions (stdin)" "TIOStdin" "hs"
   , goldenWithEvalAndFs "Property checking" cabalProjectFS "TProperty" "hs"
   , knownBrokenInWindowsBeforeGHC912 "The output has path separators in it, which on Windows look different. Just skip it there" $
       goldenWithEvalAndFs' "Property checking with exception" cabalProjectFS "TPropertyError" "hs" $

plugins/hls-eval-plugin/test/testdata/TIOStderr.expected.hs

@@ -0,0 +1,25 @@
+-- 1. Support IO expressions
+--
+-- 2. Capture and show stderr
+module TIOStderr where
+
+import           Control.Exception
+import           System.IO         (hPutStrLn, stderr)
+
+{- Capture stderr.
+
+>>> hPutStrLn stderr "Doh"
+Doh
+-}
+
+{- We do not see the error value constructor.
+
+>>> throwIO (TypeError "Doh")
+Doh
+-}
+
+{- Capture stderr after an exception.
+
+>>> hPutStrLn stderr "Doh"
+Doh
+-}

plugins/hls-eval-plugin/test/testdata/TIOStderr.hs

@@ -0,0 +1,22 @@
+-- 1. Support IO expressions
+--
+-- 2. Capture and show stderr
+module TIOStderr where
+
+import           Control.Exception
+import           System.IO         (hPutStrLn, stderr)
+
+{- Capture stderr.
+
+>>> hPutStrLn stderr "Doh"
+-}
+
+{- We do not see the error value constructor.
+
+>>> throwIO (TypeError "Doh")
+-}
+
+{- Capture stderr after an exception.
+
+>>> hPutStrLn stderr "Doh"
+-}

plugins/hls-eval-plugin/test/testdata/TIOStdin.expected.hs

@@ -0,0 +1,14 @@
+-- 1. Support `stdin`
+module TIOStdin where
+
+{- `stdin` is empty, so reads see end of file instead of blocking the server.
+
+>>> getLine >>= print
+<stdin>: hGetLine: end of file
+-}
+
+{- Reading `stdin` works repeatedly.
+
+>>> getLine >>= print
+<stdin>: hGetLine: end of file
+-}

plugins/hls-eval-plugin/test/testdata/TIOStdin.hs

@@ -0,0 +1,12 @@
+-- 1. Support `stdin`
+module TIOStdin where
+
+{- `stdin` is empty, so reads see end of file instead of blocking the server.
+
+>>> getLine >>= print
+-}
+
+{- Reading `stdin` works repeatedly.
+
+>>> getLine >>= print
+-}

plugins/hls-eval-plugin/test/testdata/TIO.hs → plugins/hls-eval-plugin/test/testdata/TIOStdout.expected.hs

@@ -1,7 +1,7 @@
 -- 1. Support IO expressions
 --
 -- 2. Capture and show stdout
-module TIO where
+module TIOStdout where
 
 import           Control.Concurrent (threadDelay)
 
@@ -10,4 +10,13 @@ import           Control.Concurrent (threadDelay)
 Has a delay in order to show progress reporting.
 
 >>> threadDelay 2000000 >> print "ABC" >> return "XYZ"
+"ABC"
+"XYZ"
+-}
+
+{- Check that capturing `stdout` works repeatedly.
+
+>>> print "ABC" >> return "XYZ"
+"ABC"
+"XYZ"
 -}

plugins/hls-eval-plugin/test/testdata/TIO.expected.hs → plugins/hls-eval-plugin/test/testdata/TIOStdout.hs

@@ -1,7 +1,7 @@
 -- 1. Support IO expressions
 --
 -- 2. Capture and show stdout
-module TIO where
+module TIOStdout where
 
 import           Control.Concurrent (threadDelay)
 
@@ -10,6 +10,9 @@ import           Control.Concurrent (threadDelay)
 Has a delay in order to show progress reporting.
 
 >>> threadDelay 2000000 >> print "ABC" >> return "XYZ"
-"ABC"
-"XYZ"
+-}
+
+{- Check that capturing `stdout` works repeatedly.
+
+>>> print "ABC" >> return "XYZ"
 -}