diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 6fc3c6f4f0..f06708dc9b 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/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 "" ReadMode False + readEnd `hDuplicateTo` stdin + hClose readEnd testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments testing recorder projectRoot plugins = diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 0c2ac37125..9adda2d661 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/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 diff --git a/plugins/hls-eval-plugin/README.md b/plugins/hls-eval-plugin/README.md index 46343191d9..122e477693 100644 --- a/plugins/hls-eval-plugin/README.md +++ b/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 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index afd723863f..84a0a9f107 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/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;" diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 7d83419f40..86588c323f 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/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} diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 78e1f21589..40f3b4587e 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/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" $ diff --git a/plugins/hls-eval-plugin/test/testdata/TIOError.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIOError.expected.hs deleted file mode 100644 index 8e0de471be..0000000000 --- a/plugins/hls-eval-plugin/test/testdata/TIOError.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ --- 1. Support IO expressions --- --- 2. Capture and show stderr -module TIOError where - -import Control.Exception - -{- ->>> throwIO (TypeError "Doh") -Doh --} diff --git a/plugins/hls-eval-plugin/test/testdata/TIOError.hs b/plugins/hls-eval-plugin/test/testdata/TIOError.hs deleted file mode 100644 index 6b39667e3b..0000000000 --- a/plugins/hls-eval-plugin/test/testdata/TIOError.hs +++ /dev/null @@ -1,10 +0,0 @@ --- 1. Support IO expressions --- --- 2. Capture and show stderr -module TIOError where - -import Control.Exception - -{- ->>> throwIO (TypeError "Doh") --} diff --git a/plugins/hls-eval-plugin/test/testdata/TIOStderr.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIOStderr.expected.hs new file mode 100644 index 0000000000..371e446d0d --- /dev/null +++ b/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 +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TIOStderr.hs b/plugins/hls-eval-plugin/test/testdata/TIOStderr.hs new file mode 100644 index 0000000000..d6c1750173 --- /dev/null +++ b/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" +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TIOStdin.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIOStdin.expected.hs new file mode 100644 index 0000000000..2a14ad7132 --- /dev/null +++ b/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 +: hGetLine: end of file +-} + +{- Reading `stdin` works repeatedly. + +>>> getLine >>= print +: hGetLine: end of file +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TIOStdin.hs b/plugins/hls-eval-plugin/test/testdata/TIOStdin.hs new file mode 100644 index 0000000000..f64b996443 --- /dev/null +++ b/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 +-} diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.hs b/plugins/hls-eval-plugin/test/testdata/TIOStdout.expected.hs similarity index 65% rename from plugins/hls-eval-plugin/test/testdata/TIO.hs rename to plugins/hls-eval-plugin/test/testdata/TIOStdout.expected.hs index 455c19d5b8..778c69646f 100644 --- a/plugins/hls-eval-plugin/test/testdata/TIO.hs +++ b/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" -} diff --git a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs b/plugins/hls-eval-plugin/test/testdata/TIOStdout.hs similarity index 69% rename from plugins/hls-eval-plugin/test/testdata/TIO.expected.hs rename to plugins/hls-eval-plugin/test/testdata/TIOStdout.hs index 0be985ae3c..52301a5e4b 100644 --- a/plugins/hls-eval-plugin/test/testdata/TIO.expected.hs +++ b/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" -} diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index 9b3bffb901..a74cfd896a 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -37,20 +37,19 @@ tests = [] , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsLspCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do - doc <- openDoc "TIO.hs" "haskell" + doc <- openDoc "TIOStdout.hs" "haskell" lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) (codeLensResponse, createdProgressTokens, activeProgressTokens) <- expectProgressMessagesTill (responseForId SMethod_TextDocumentCodeLens lspId) - ["Setting up testdata (for TIO.hs)"] + ["Setting up testdata (for TIOStdout.hs)"] ["Processing", "Indexing"] [] [] - -- this is a test so exceptions result in fails let response = getMessageResult codeLensResponse case response of - InL [evalLens] -> do + InL [evalLens, _evalLens] -> do let command = evalLens ^?! L.command . _Just _ <- sendRequest SMethod_WorkspaceExecuteCommand $ @@ -90,6 +89,7 @@ data ProgressMessage | ProgressBegin ProgressToken WorkDoneProgressBegin | ProgressReport ProgressToken WorkDoneProgressReport | ProgressEnd ProgressToken WorkDoneProgressEnd + deriving (Show) data InterestingMessage a = InterestingMessage a