From b034cc3ec5734e5b0c44e595397c3ea099e9231e Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Mon, 6 Jul 2026 14:54:22 +0200 Subject: [PATCH] [Fix #266] Add InterpreterSettings/DAPDebuggee interface --- haskell-debugger.cabal | 2 + haskell-debugger/GHC/Debugger/Debuggee.hs | 267 ++++++++++++++++++ haskell-debugger/GHC/Debugger/Monad.hs | 221 +-------------- haskell-debugger/GHC/Debugger/Session.hs | 7 +- hdb-dap/Development/Debug/Adapter.hs | 5 +- .../Development/Debug/Adapter/DAPDebuggee.hs | 222 +++++++++++++++ hdb-dap/Development/Debug/Adapter/Init.hs | 241 +++------------- hdb-dap/Development/Debug/Adapter/Proxy.hs | 28 +- hdb-dap/Development/Debug/Adapter/Server.hs | 14 +- hdb/Development/Debug/Interactive.hs | 1 + hdb/Main.hs | 16 +- test/golden/T130/T130.ghc-1001.hdb-stdout | 1 - test/golden/T130/T130.ghc-914.hdb-stdout | 1 - test/golden/T130/T130.hdb-test | 2 +- ...dout => T154.external.ghc-1001.hdb-stdout} | 0 ...tdout => T154.external.ghc-914.hdb-stdout} | 0 ...tdout => T154.external.ghc-915.hdb-stdout} | 0 .../{T154.hdb-test => T154.external.hdb-test} | 0 ...dout => T169.internal.ghc-1001.hdb-stdout} | 0 ...tdout => T169.internal.ghc-914.hdb-stdout} | 0 ...tdout => T169.internal.ghc-915.hdb-stdout} | 0 .../{T169.hdb-test => T169.internal.hdb-test} | 0 22 files changed, 571 insertions(+), 457 deletions(-) create mode 100644 haskell-debugger/GHC/Debugger/Debuggee.hs create mode 100644 hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs rename test/golden/T154/{T154.ghc-1001.hdb-stdout => T154.external.ghc-1001.hdb-stdout} (100%) rename test/golden/T154/{T154.ghc-914.hdb-stdout => T154.external.ghc-914.hdb-stdout} (100%) rename test/golden/T154/{T154.ghc-915.hdb-stdout => T154.external.ghc-915.hdb-stdout} (100%) rename test/golden/T154/{T154.hdb-test => T154.external.hdb-test} (100%) rename test/golden/T169/{T169.ghc-1001.hdb-stdout => T169.internal.ghc-1001.hdb-stdout} (100%) rename test/golden/T169/{T169.ghc-914.hdb-stdout => T169.internal.ghc-914.hdb-stdout} (100%) rename test/golden/T169/{T169.ghc-915.hdb-stdout => T169.internal.ghc-915.hdb-stdout} (100%) rename test/golden/T169/{T169.hdb-test => T169.internal.hdb-test} (100%) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 45e3b55b..c0ecd65a 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -104,6 +104,7 @@ library GHC.Debugger.Runtime.Interpreter.Custom, GHC.Debugger.Monad, + GHC.Debugger.Debuggee, GHC.Debugger.Utils, GHC.Debugger.Utils.Orphans, @@ -163,6 +164,7 @@ library dap-server Development.Debug.Adapter.Stopped, Development.Debug.Adapter.Evaluation, Development.Debug.Adapter.ExceptionInfo, + Development.Debug.Adapter.DAPDebuggee, Development.Debug.Adapter.Init, Development.Debug.Adapter.Interface, Development.Debug.Adapter.Output, diff --git a/haskell-debugger/GHC/Debugger/Debuggee.hs b/haskell-debugger/GHC/Debugger/Debuggee.hs new file mode 100644 index 00000000..50b0638e --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Debuggee.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultilineStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NondecreasingIndentation #-} +module GHC.Debugger.Debuggee where + +import System.Process +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Data.Function +import Data.Functor.Contravariant +import Data.Maybe +import Prelude hiding (mod) +import Data.Text (Text) +import Network.Socket hiding (Debug) +import System.Process.Internals (mkProcessHandle) +import Text.Read (readMaybe) + +import GHC +import GHC.Driver.Env as GHC +import GHC.Driver.Monad +import GHC.Driver.Hooks +import GHC.Driver.Ppr +import GHC.Runtime.Interpreter as GHCi +import GHC.Types.Error +import qualified GHC.Utils.Logger as GHC + +import GHC.Debugger.Session +import GHC.Debugger.Utils + +import Colog.Core as Logger + +import GHCi.Message (mkPipeFromHandles) +import System.IO (hGetLine, IOMode(..), openFile, Handle) +import qualified GHC.Linker.Loader as Loader +import GHC.Stack.Annotation +import GHC.Platform.Ways +#if MIN_VERSION_ghc(9,15,0) +import GHC.Data.FastString.Env (emptyFsEnv) +#endif +import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger` +import System.Environment (getExecutablePath) + +data InterpreterSettings = InterpreterSettings + { interpreterFlags :: DynFlags -> DynFlags + , interpreterSetup :: forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a + } + +mkInternalInterpreterFlags :: DynFlags -> DynFlags +mkExternalInterpreterFlags :: String -> DynFlags -> DynFlags +(mkInternalInterpreterFlags, mkExternalInterpreterFlags) = (mkInterpreterFlags True "", mkInterpreterFlags False) + where + mkInterpreterFlags :: Bool -> String -> DynFlags -> DynFlags + mkInterpreterFlags preferInternalInterpreter externalInterpreterProg df = df + -- Enable the external interpreter by default! See #169 + -- See Note [Custom external interpreter] + & enableExternalInterpreter preferInternalInterpreter + -- Ext interp is the same program as this, with "--external-interpreter" + -- (this is ignored on GHC 9.14, see Note [Custom external interpreter]) + & setPgmI externalInterpreterProg + -- ideally, we'd set "external-interpreter" *before* the file + -- descriptors. since there's no way to do that yet, we just have + -- some logic in main to detect [writefd, readfd, --external-interpreter] + & addOptI "--external-interpreter" + + +mkInternalInterpreterSetup :: LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a +mkInternalInterpreterSetup _ dflags mainGhcThread = do + when (gopt Opt_ExternalInterpreter dflags) $ do + throw $ InconsistentInterpreterFlags $ "Used ghc flag -fexternal-interpreter together with --internal-interpreter haskell-debugger flag." + mainGhcThread + +newtype InconsistentInterpreterFlags = InconsistentInterpreterFlags String +instance Show InconsistentInterpreterFlags where + show (InconsistentInterpreterFlags t) = "Interpreter flags are inconsistent: " ++ t +instance Exception InconsistentInterpreterFlags + + +mkExternalInterpreterFromIOSetup :: IO Interp -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a +mkExternalInterpreterFromIOSetup m _l dflags mainGhcThread = do + unless (gopt Opt_ExternalInterpreter dflags) $ do + throw $ InconsistentInterpreterFlags $ "Used ghc flag -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag." + -- we supply our custom external interpreter process, which is + -- already running and connected to the user's terminal. + extInterp <- liftIO + $ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process" + $ m + modifySession $ \h -> h + { hsc_interp = Just extInterp -- set it directly! + } + + -- Ext interp is running in user terminal, no need to forward output to logger + mainGhcThread + + +mkExternalInterpreterFromStdInSetup :: StdStream -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a +mkExternalInterpreterFromStdInSetup givenStdStream l dflags mainGhcThread = do + unless (gopt Opt_ExternalInterpreter dflags) $ do + throw $ InconsistentInterpreterFlags $ "Used ghc flag -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag." + + (putHandles,fwdThread) <- liftIO $ externalInterpFwdThread l + -- Make sure to override the function which creates the external + -- interpreter, because we need to keep track of the standard handles + modifySession $ \h -> h + { hsc_hooks = (hsc_hooks h) + { createIservProcessHook = Just $ \cp -> do + -- See Note [External interpreter buffering] + (_, Just o, Just e, ph) <- + createProcess cp + { std_in = givenStdStream + , std_out = CreatePipe + , std_err = CreatePipe + -- Override executable path + -- See Note [Custom external interpreter] +#if MIN_VERSION_ghc(9,15,0) +#else + , cmdspec = case cmdspec cp of + ShellCommand (words -> ws) -> ShellCommand $ unwords $ getPgmI dflags : drop 1 ws + RawCommand _fp args -> RawCommand (getPgmI dflags) args +#endif + } + putHandles (o, e) + return ph + } + } + let + -- We launched the external interpreter as a child process, so forward its output to the logger. + withUnliftGhc $ \ unlift -> annotateCallStackIO $ do + withAsync (annotateCallStackIO $ void $ fwdThread) $ \ fwd_thr -> do + liftIO $ annotateCallStackIO $ link fwd_thr + annotateCallStackIO $ unlift mainGhcThread + +externalInterpFwdThread :: LogAction IO DebuggerLog -> + IO ((Handle, Handle) -> IO (), IO ()) +externalInterpFwdThread l = do + iserv_handles <- liftIO newEmptyMVar + -- The external interpreter is spawned lazily, so we block waiting for + -- the handles to be available in a new thread. + let + fwdThread = takeMVar iserv_handles >>= \ (serv_out, serv_err) -> + concurrently_ + (forwardHandleToLogger serv_err (contramap LogDebuggeeErr l)) + (forwardHandleToLogger serv_out (contramap LogDebuggeeOut l)) + return (putMVar iserv_handles, fwdThread) + +-- | Make an 'ExtInterpInstance' based on an external interpreter process that +-- was launched by the DAP client via 'runInTerminal'. The process sends its +-- own PID as the first line on the socket before the GHCi wire protocol +-- begins. +extInterpFromTerminalProcess :: Socket -> IO Interp +extInterpFromTerminalProcess sock0 = do + port <- socketPort sock0 + putStrLn $ "Connected to " ++ show port + Control.Exception.bracketOnError + (accept sock0) + (\ (sock,_) -> close sock0 >> close sock) + (\ (sock,_) -> do + bi_h <- socketToHandle sock ReadWriteMode + + pidLine <- annotateCallStackIO $ hGetLine bi_h + + pid <- case readMaybe pidLine :: Maybe Int of + Just pid -> pure pid + Nothing -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine + ph <- mkProcessHandle (fromIntegral pid) False + interpPipe <- mkPipeFromHandles bi_h bi_h + lock <- newMVar () + let process = InterpProcess + { interpHandle = ph + , interpPipe + , interpLock = lock + } + + pending_frees <- newMVar [] + let inst = ExtInterpInstance + { instProcess = process + , instPendingFrees = pending_frees + , instExtra = () + } + conf = IServConfig + { iservConfProgram = "the process is already running, we should never need to run it again" + , iservConfOpts = [] + -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger] + , iservConfDynamic = hostIsDynamic + , iservConfProfiled = hostIsProfiled + , iservConfHook = Nothing -- it's already running! + , iservConfTrace = pure () + } + + lookup_cache <- mkInterpSymbolCache + s <- newMVar $ InterpRunning inst + loader <- Loader.uninitializedLoader +#if MIN_VERSION_ghc(9,15,0) + fs_cache <- newMVar emptyFsEnv + return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache) +#else + return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache) +#endif + ) + +mkCliInterpreterSettings :: Bool -> Maybe FilePath -> IO InterpreterSettings +mkCliInterpreterSettings internalInterpreter debuggeeStdin = do + if internalInterpreter then pure $ InterpreterSettings { interpreterFlags = mkInternalInterpreterFlags + , interpreterSetup = mkInternalInterpreterSetup } else do + stdinStream <- case debuggeeStdin of + Just fp -> UseHandle <$> System.IO.openFile fp ReadMode + Nothing -> pure Inherit + -- the same program invoked with `external-interpreter` serves as the external interpreter + thisProg <- getExecutablePath + pure InterpreterSettings { interpreterFlags = mkExternalInterpreterFlags thisProg + , interpreterSetup = mkExternalInterpreterFromStdInSetup stdinStream + } + +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- + +-- | A debugger log. May include debuggee ouput. +data DebuggerLog + = DebuggerLog !Logger.Severity !DebuggerMessage + | GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc + | LogDebuggeeOut !Text + | LogDebuggeeErr !Text + +-- | A debugger log message +data DebuggerMessage + = LogSDoc !DynFlags !SDoc + | LogFailedToCompileDebugViewModule !GHC.ModuleName + | LogSkippingViewModuleNoPkg !GHC.ModuleName String [String] + +instance Show DebuggerMessage where + show = \ case + LogFailedToCompileDebugViewModule mn -> + "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views." + LogSkippingViewModuleNoPkg mn pkg uids -> + "Skipping compilation of built-in " ++ moduleNameString mn ++ " module because package " + ++ show pkg ++ " wasn't found in dependencies " ++ show uids + LogSDoc dflags doc -> showSDoc dflags doc + + +ghcLogAction :: LogAction IO DebuggerLog -> GHC.LogAction +ghcLogAction l = \logflags mclass srcSpan sdoc -> do + liftLogIO l <& GHCLog logflags mclass srcSpan sdoc + +msgClassSeverity :: MessageClass -> Logger.Severity +msgClassSeverity = \case + MCOutput -> Info + MCFatal -> Logger.Error + MCInteractive -> Info + MCDump -> Debug + MCInfo -> Info + MCDiagnostic SevIgnore _ _ -> Debug -- ? + MCDiagnostic SevWarning _ _ -> Logger.Warning + MCDiagnostic SevError _ _ -> Logger.Error diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 6aad63e2..b3330c6b 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -15,9 +15,7 @@ module GHC.Debugger.Monad where -import System.Process import Control.Concurrent -import Control.Concurrent.Async import Control.Exception import qualified Data.Foldable as Foldable import Control.Monad @@ -25,7 +23,6 @@ import Control.Monad.Catch as MC import Control.Monad.IO.Class import Control.Monad.Reader import Data.Function -import Data.Functor.Contravariant import Data.IORef import Data.Maybe import qualified Data.Set as Set @@ -34,12 +31,8 @@ import Prelude hiding (mod) #ifdef MIN_VERSION_unix import System.Posix.Signals #endif -import Data.Text (Text) import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty -import Network.Socket hiding (Debug) -import System.Process.Internals (mkProcessHandle) -import Text.Read (readMaybe) import GHC import GHC.Data.StringBuffer @@ -48,7 +41,6 @@ import GHC.Driver.Config.Logger import GHC.Driver.DynFlags as GHC import GHC.Driver.Env as GHC import GHC.Driver.Monad -import GHC.Driver.Hooks import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Main @@ -76,24 +68,18 @@ import GHC.Debugger.Session import GHC.Debugger.Session.Builtin import GHC.Debugger.Session.Interactive import GHC.Debugger.Runtime.Compile.Cache -import GHC.Debugger.Utils import qualified GHC.Debugger.Breakpoint.Map as BM import qualified GHC.Debugger.Runtime.Thread.Map as TM import Colog.Core as Logger import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache) -import GHCi.Message (mkPipeFromHandles) -import System.IO (hGetLine, IOMode(..)) -import qualified GHC.Linker.Loader as Loader import GHC.Stack.Annotation import GHC.Platform.Ways -#if MIN_VERSION_ghc(9,15,0) -import GHC.Data.FastString.Env (emptyFsEnv) -#endif import GHC.Unit.Home.Graph import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger` import System.Directory (getCurrentDirectory) +import GHC.Debugger.Debuggee -- | A debugger action. newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a } @@ -195,15 +181,7 @@ instance Outputable BreakpointAction where ppr = text . show data RunDebuggerSettings = RunDebuggerSettings { supportsANSIStyling :: Bool , supportsANSIHyperlinks :: Bool - , preferInternalInterpreter :: Bool - , externalInterpreterCustomProc :: Either StdStream PortNumber - -- ^ Right: use a custom given existing process for the external - -- interpreter listening at given port. (This is used when we want to - -- launch the external interpreter attached to a user's terminal). - -- - -- Left: we launch our own external interpreter process through - -- GHC's spawnIServ using the given StdStream as the stdin. - , externalInterpreterProg :: FilePath + , interpreterSettings :: InterpreterSettings } -- | Run a 'Debugger' action on a session constructed by a 'DebugRunner' @@ -297,17 +275,7 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f `GHC.gopt_set` GHC.Opt_UseBytecodeRatherThanObjects `GHC.gopt_set` GHC.Opt_InsertBreakpoints - -- Enable the external interpreter by default! See #169 - -- See Note [Custom external interpreter] - & enableExternalInterpreter conf.preferInternalInterpreter - -- Ext interp is the same program as this, with "--external-interpreter" - -- (this is ignored on GHC 9.14, see Note [Custom external interpreter]) - & setPgmI conf.externalInterpreterProg - -- ideally, we'd set "external-interpreter" *before* the file - -- descriptors. since there's no way to do that yet, we just have - -- some logic in main to detect [writefd, readfd, --external-interpreter] - & addOptI "--external-interpreter" - + & interpreterFlags conf.interpreterSettings -- Really important to force -dynamic if host is dynamic -- See Note [Dynamic Debuggee for dynamic debugger] & enableDynamicDebuggee @@ -335,59 +303,7 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns) return dflags2 - -- Make sure to override the function which creates the external - -- interpreter, because we need to keep track of the standard handles - iserv_handles <- liftIO newEmptyMVar - case conf.externalInterpreterCustomProc of - -- Left: GHC will launch the external interpreter itself on demand if - -- using external interpreter, and we just provide the stdin stream - Left givenStdStream -> - modifySession $ \h -> h - { hsc_hooks = (hsc_hooks h) - { createIservProcessHook = Just $ \cp -> do - -- See Note [External interpreter buffering] - (_, Just o, Just e, ph) <- - createProcess cp - { std_in = givenStdStream - , std_out = CreatePipe - , std_err = CreatePipe - -- Override executable path - -- See Note [Custom external interpreter] -#if MIN_VERSION_ghc(9,15,0) -#else - , cmdspec = case cmdspec cp of - ShellCommand (words -> ws) -> ShellCommand $ unwords $ conf.externalInterpreterProg : drop 1 ws - RawCommand _fp args -> RawCommand conf.externalInterpreterProg args -#endif - } - putMVar iserv_handles (o, e) - return ph - } - } - - -- Right: we supply our custom external interpreter process, which is - -- already running and connected to the user's terminal. - Right port -> do - extInterp <- liftIO - $ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process" - $ extInterpFromTerminalProcess port - modifySession $ \h -> h - { hsc_interp = Just extInterp -- set it directly! - } - - let - externalInterpFwdThread :: IO () - externalInterpFwdThread = when (GHC.gopt GHC.Opt_ExternalInterpreter dflags2) $ do - -- The external interpreter is spawned lazily, so we block waiting for - -- the handles to be available in a new thread. - withAsync (takeMVar iserv_handles) $ \async_handles -> do - (serv_out, serv_err) <- wait async_handles - concurrently_ - (forwardHandleToLogger serv_err (contramap LogDebuggeeErr l)) - (forwardHandleToLogger serv_out (contramap LogDebuggeeOut l)) - - mainGhcThread :: Ghc a - mainGhcThread = do + interpreterSetup conf.interpreterSettings l dflags2 $ do -- Initializes interpreter! _ <- GHC.setSessionDynFlags dflags2 @@ -475,16 +391,6 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f then Nothing else Just hdv_uid) - case conf.externalInterpreterCustomProc of - Left _ -> do - -- We launched the external interpreter ourselves, so forward its output to the logger. - withUnliftGhc $ \ unlift -> annotateCallStackIO $ do - withAsync (annotateCallStackIO $ void externalInterpFwdThread) $ \ fwd_thr -> do - liftIO $ annotateCallStackIO $ link fwd_thr - annotateCallStackIO $ unlift mainGhcThread - Right _ -> - -- Ext interp is running in user terminal, no need to forward output to logger - mainGhcThread findOrLoadHaskellDebuggerView :: LogAction IO DebuggerLog -> Ways @@ -663,84 +569,6 @@ parseDynamicFlagsWithRootDir rootDir logger dflags cmdline = do dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1 return (dflags2, leftovers, warns) --- | Make an 'ExtInterpInstance' based on an external interpreter process that --- was launched by the DAP client via 'runInTerminal'. The process sends its --- own PID as the first line on the socket before the GHCi wire protocol --- begins. -extInterpFromTerminalProcess :: PortNumber -> IO Interp -extInterpFromTerminalProcess port = do - putStrLn $ "Trying to connect to " ++ show port - Control.Exception.bracketOnError - (openListener port >>= accept) - (\ (sock,_) -> close sock) - (\ (sock,_) -> do - bi_h <- socketToHandle sock ReadWriteMode - - pidLine <- annotateCallStackIO $ hGetLine bi_h - - pid <- case readMaybe pidLine :: Maybe Int of - Just pid -> pure pid - Nothing -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine - ph <- mkProcessHandle (fromIntegral pid) False - interpPipe <- mkPipeFromHandles bi_h bi_h - lock <- newMVar () - let process = InterpProcess - { interpHandle = ph - , interpPipe - , interpLock = lock - } - - pending_frees <- newMVar [] - let inst = ExtInterpInstance - { instProcess = process - , instPendingFrees = pending_frees - , instExtra = () - } - conf = IServConfig - { iservConfProgram = "the process is already running, we should never need to run it again" - , iservConfOpts = [] - -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger] - , iservConfDynamic = hostIsDynamic - , iservConfProfiled = hostIsProfiled - , iservConfHook = Nothing -- it's already running! - , iservConfTrace = pure () - } - - lookup_cache <- mkInterpSymbolCache - s <- newMVar $ InterpRunning inst - loader <- Loader.uninitializedLoader -#if MIN_VERSION_ghc(9,15,0) - fs_cache <- newMVar emptyFsEnv - return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache) -#else - return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache) -#endif - ) - -openListener :: PortNumber -> IO Socket -openListener port = do - addr <- socketAddressFromPort port - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - -- Must set before bind! - setSocketOption sock ReuseAddr 1 - - bind sock (addrAddress addr) - listen sock maxListenQueue - - return sock - -socketAddressFromPort :: PortNumber -> IO AddrInfo -socketAddressFromPort port = do - let - hints = defaultHints - { addrSocketType = Stream - , addrFlags = [AI_PASSIVE] -- For wildcard IP (0.0.0.0 or ::) - , addrFamily = AF_UNSPEC -- Allow IPv4 or IPv6 - } - addrs <- getAddrInfo (Just hints) Nothing (Just (show port)) - case addrs of - addr : _ -> pure addr - [] -> fail ("Could not resolve address for external interpreter port " ++ show port) {- Note [Custom external interpreter] @@ -1081,49 +909,8 @@ deepseqTerm hsc_env t = case t of _ -> do seqTerm hsc_env t --------------------------------------------------------------------------------- --- * Logging --------------------------------------------------------------------------------- - --- | A debugger log. May include debuggee ouput. -data DebuggerLog - = DebuggerLog !Logger.Severity !DebuggerMessage - | GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc - | LogDebuggeeOut !Text - | LogDebuggeeErr !Text - --- | A debugger log message -data DebuggerMessage - = LogSDoc !DynFlags !SDoc - | LogFailedToCompileDebugViewModule !GHC.ModuleName - | LogSkippingViewModuleNoPkg !GHC.ModuleName String [String] - -instance Show DebuggerMessage where - show = \ case - LogFailedToCompileDebugViewModule mn -> - "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views." - LogSkippingViewModuleNoPkg mn pkg uids -> - "Skipping compilation of built-in " ++ moduleNameString mn ++ " module because package " - ++ show pkg ++ " wasn't found in dependencies " ++ show uids - LogSDoc dflags doc -> showSDoc dflags doc - logSDoc :: Logger.Severity -> SDoc -> Debugger () logSDoc sev doc = do dflags <- getDynFlags l <- asks dbgLogger l <& DebuggerLog sev (LogSDoc dflags doc) - -ghcLogAction :: LogAction IO DebuggerLog -> GHC.LogAction -ghcLogAction l = \logflags mclass srcSpan sdoc -> do - liftLogIO l <& GHCLog logflags mclass srcSpan sdoc - -msgClassSeverity :: MessageClass -> Logger.Severity -msgClassSeverity = \case - MCOutput -> Info - MCFatal -> Logger.Error - MCInteractive -> Info - MCDump -> Debug - MCInfo -> Info - MCDiagnostic SevIgnore _ _ -> Debug -- ? - MCDiagnostic SevWarning _ _ -> Logger.Warning - MCDiagnostic SevError _ _ -> Logger.Error diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index b697d5ff..ec67d602 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -38,7 +38,7 @@ module GHC.Debugger.Session ( withUnliftGhc, annotateCallStackGhc, lookupUnitPackageQualifier, - fixHomeUnitsDynFlagsForIIDecl, + fixHomeUnitsDynFlagsForIIDecl, getPgmI, ) where @@ -77,7 +77,6 @@ import GHC.Unit.Types import qualified GHC.Unit.State as State import GHC.Driver.Env import GHC.Types.SrcLoc -import GHC.Settings (ToolSettings(..)) import Language.Haskell.Syntax.Module.Name import qualified Data.Foldable as Foldable import qualified GHC.Unit.Home.Graph as HUG @@ -102,6 +101,7 @@ import GHC.Plugins (SourceError, try, RawPkgQual (..), HasCallStack, FastString, import GHC.Types.SourceText (StringLiteral(..), SourceText (..)) import GHC.Stack.Annotation import GHC.Stack (callStack) +import GHC.Settings (ToolSettings(..)) -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m @@ -644,6 +644,9 @@ setPgmI, addOptI :: String -> DynFlags -> DynFlags setPgmI f = alterToolSettings $ \s -> s { toolSettings_pgm_i = f } addOptI f = alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } +getPgmI :: DynFlags -> String +getPgmI df = toolSettings_pgm_i (toolSettings df) + alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } diff --git a/hdb-dap/Development/Debug/Adapter.hs b/hdb-dap/Development/Debug/Adapter.hs index d8b34246..1edf53dd 100644 --- a/hdb-dap/Development/Debug/Adapter.hs +++ b/hdb-dap/Development/Debug/Adapter.hs @@ -14,7 +14,7 @@ import System.FilePath import DAP import qualified GHC import qualified GHC.Debugger.Interface.Messages as D (Command, Response, RemoteThreadId, VariableReference) -import Network.Socket (PortNumber) +import Network.Socket (PortNumber, Socket) import GHC.Debugger.Interface.Messages (AbsFilePath, unAbs, (/>)) type DebugAdaptor = Adaptor DebugAdaptorState Request @@ -38,7 +38,7 @@ data DebugAdaptorState = DAS , entryPoint :: String , entryArgs :: [String] , projectRoot :: AbsFilePath - , runInTerminalProc :: RunInTerminalProc + , waitForDebuggee :: IO () -- ^ Potentially a process launched via 'runInTerminal'. } @@ -74,6 +74,7 @@ data RunInTerminalProc -- When 'NoRunInTerminal' but using external-interpreter, we'll still -- launch the external interpreter but in the default GHC way using the -- file descriptors directly. + , socket :: Socket } -- | We launched @hdb proxy ...@ on the user's terminal. diff --git a/hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs b/hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs new file mode 100644 index 00000000..720bd4a4 --- /dev/null +++ b/hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NondecreasingIndentation #-} + +-- | TODO: This module should be called Launch. +module Development.Debug.Adapter.DAPDebuggee where + +#if !MIN_VERSION_ghc(9,15,0) +-- no longer needs to be imported from here in 9.15 +import GHC.Conc.Sync (labelThread) +#endif + +import GHC.IO.Handle +import System.Process +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T +import Control.Monad.Trans +import System.IO +import Control.Monad.Catch +import Control.Exception (throwIO, IOException) +import Control.Concurrent +import Control.Monad +import Data.Functor.Contravariant + +import Development.Debug.Adapter +import Colog.Core as Logger +import qualified Development.Debug.Adapter.Output as Output + + +import DAP +import Development.Debug.Adapter.Handles +import Development.Debug.Session.Setup +import Development.Debug.Adapter.Proxy +import Network.Socket (socketPort, close) +import GHC.Debugger.Debuggee as Debugger + +data DAPDebuggee = DAPDebuggee + { dapdInterpreterSettings :: InterpreterSettings + , dapdWaitForDebuggee :: IO () + , dapdThreads :: [(DebugAdaptorCont () -> IO ()) -> IO ()] + -- ^ Additional threads to register for this session depending on the process + -- we're running through `runInTerminal` (see 'interpreterInit'). + , dapdAfterRegister :: DebugAdaptor () + -- ^ additional commands to run after registering the session. + } + + +internalNoInTerminalDAPD :: Applicative f => f DAPDebuggee +internalNoInTerminalDAPD + -- Not using the terminal proxy, but we still want to output our own + -- stdout/err (from the internal interpreter) as console events. + = do + let interpSettings = InterpreterSettings + { interpreterFlags = mkInternalInterpreterFlags + , interpreterSetup = mkInternalInterpreterSetup + } + pure $ + DAPDebuggee + interpSettings + (pure ()) + [ stdoutCaptureThread Nothing, stderrCaptureThread Nothing ] + (pure ()) + +externalNoInTerminalDAPD :: Applicative f => FilePath -> f DAPDebuggee +externalNoInTerminalDAPD hdbProg = do + let interpSettings = InterpreterSettings + { interpreterFlags = mkExternalInterpreterFlags hdbProg + , interpreterSetup = mkExternalInterpreterFromStdInSetup CreatePipe + } + pure $ + DAPDebuggee + interpSettings + (pure ()) + [] + (pure ()) + +externalInTerminalDAPD :: MonadIO m => FilePath -> m DAPDebuggee +externalInTerminalDAPD hdbProg + -- No additional bookkeeping is needed in this case because GHC will + -- naturally have to wait for the external interpreter in order to start execution + = liftIO $ do + -- We keep the socket open so we claim the port. + bracketOnError openSocketAvailablePort Network.Socket.close $ \ sock -> do + extInterpPort <- liftIO $ socketPort sock + let interpSettings = InterpreterSettings { + interpreterFlags = mkExternalInterpreterFlags hdbProg + , interpreterSetup = mkExternalInterpreterFromIOSetup $ extInterpFromTerminalProcess sock + } + pure $ + DAPDebuggee + interpSettings + (pure ()) + -- When session is killed the socket is closed too. + [\ _ -> forever (threadDelay 100_000_000) `finally` Network.Socket.close sock] + (sendRunInTerminalReverseRequest + RunInTerminalRequestArguments + { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated + , runInTerminalRequestArgumentsTitle = Nothing + , runInTerminalRequestArgumentsCwd = "" + , runInTerminalRequestArgumentsArgs = + [T.pack hdbProg, "external-interpreter", "--port", T.pack (show extInterpPort)] + , runInTerminalRequestArgumentsEnv = Nothing + , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False + }) + +internalInTerminalDAPD :: LogAction IO DAPSessionLog -> FilePath -> Adaptor DebugAdaptorState r DAPDebuggee +internalInTerminalDAPD l hdbProg = do + (syncProxyIn, syncProxyOut, syncProxyErr) + <- liftIO $ (,,) <$> newChan <*> newChan <*> newChan + proxyClientReady <- liftIO $ newEmptyMVar + + (serverPort, serverProxyThread) <- liftIO $ + mkServerSideHdbProxy (contramap RunProxyServerLog l) + syncProxyIn syncProxyOut syncProxyErr proxyClientReady + let interpSettings = InterpreterSettings + { interpreterFlags = mkInternalInterpreterFlags + , interpreterSetup = mkInternalInterpreterSetup + } + waitForDebuggee = + -- Only start executing after proxy client connects succesfully (#95) + takeMVar proxyClientReady + pure $ DAPDebuggee + interpSettings + waitForDebuggee + [ const serverProxyThread + -- Setup capturing of the process' own stdout and forwarding of the process' own stdin, + -- but only because we're using the internal interpreter! + , stdinForwardThread syncProxyIn + , stdoutCaptureThread (Just syncProxyOut) + , stderrCaptureThread (Just syncProxyErr) + ] + + -- When using the internal interpreter and 'runInTerminal' is supported + -- (the 'RunProxyInTerminal' case), we ask the DAP client to launch the + -- `hdb proxy` attached to the user's terminal. The proxy forwards + -- input/output from the user terminal to the debugger+debuggee shared process + (sendRunProxyInTerminal hdbProg serverPort) + +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- + +data DAPSessionLog + = DAPSessionSetupLog (WithSeverity SessionSetupLog) + | DAPDebuggerLog Debugger.DebuggerLog + | RunProxyServerLog (WithSeverity T.Text) + + +-------------------------------------------------------------------------------- +-- * Capturing stdout, stderr, and writing to self stdin +-------------------------------------------------------------------------------- + +-- | Hijack the current process stdin and forward to it the messages from the given channel +stdinForwardThread :: Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stdinForwardThread syncIn _withAdaptor = do + tid <- myThreadId + labelThread tid "Stdin Forward Thread" + + -- We need to hijack stdin to write to it + + -- 1. Create a new pipe from writeEnd->readEnd + (readEnd, writeEnd) <- createPipe + + -- 2. Substitute the read-end of the pipe by stdin + _ <- hDuplicateTo readEnd stdin + hClose readEnd -- we'll never need to read from readEnd + + forever $ do + i <- readChan syncIn + -- 3. Write to write-end of the pipe + BS.hPut writeEnd i >> hFlush writeEnd + +-- | This thread captures stdout from the debuggee and sends it to the client. +-- NOTE, redirecting the stdout handle is a process-global operation. So this thread +-- will capture ANY stdout the debuggee emits. Therefore you should never directly +-- write to stdout, but always write to the appropiate handle. +stdoutCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () +stdoutCaptureThread msyncOut withAdaptor = do + tid <- myThreadId + labelThread tid "Stdout Capture Thread" + withInterceptedStdout $ \_ interceptedStdout -> do + forever $ do + line <- liftIO $ T.hGetLine interceptedStdout + case msyncOut of + Nothing -> pure () + Just syncOut -> writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") + + -- Always output to Debug Console + catch + (withAdaptor $ Output.stdout line) + (\(_ :: IOException) -> + throwIO (FailedToWriteToAdaptor line)) + +-- | Like 'stdoutCaptureThread' but for stderr +stderrCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () +stderrCaptureThread msyncErr withAdaptor = do + tid <- myThreadId + labelThread tid "Stderr Capture Thread" + withInterceptedStderr $ \_ interceptedStderr -> do + forever $ do + line <- liftIO $ T.hGetLine interceptedStderr + case msyncErr of + Nothing -> pure () + Just syncErr -> writeChan syncErr $ T.encodeUtf8 (line <> "\n") + + -- Always output to Debug Console + catch + (withAdaptor $ Output.stderr line) + (\(_ :: IOException) -> + throwIO (FailedToWriteToAdaptor line)) + +newtype FailedToWriteToAdaptor = FailedToWriteToAdaptor T.Text +instance Show FailedToWriteToAdaptor where + show (FailedToWriteToAdaptor t) = "Failed to write to debug adapter: " ++ T.unpack t +instance Exception FailedToWriteToAdaptor diff --git a/hdb-dap/Development/Debug/Adapter/Init.hs b/hdb-dap/Development/Debug/Adapter/Init.hs index 9059f513..1c227d7a 100644 --- a/hdb-dap/Development/Debug/Adapter/Init.hs +++ b/hdb-dap/Development/Debug/Adapter/Init.hs @@ -5,9 +5,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NondecreasingIndentation #-} -- | TODO: This module should be called Launch. -module Development.Debug.Adapter.Init where +module Development.Debug.Adapter.Init + ( module Development.Debug.Adapter.Init + , DAPSessionLog(..) + ) + where #if !MIN_VERSION_ghc(9,15,0) -- no longer needs to be imported from here in 9.15 @@ -15,11 +20,7 @@ import GHC.Conc.Sync (labelThread) #endif import GHC.IO.Handle -import System.Process -import qualified Data.ByteString as BS import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Encoding as T import qualified System.Process as P import Control.Exception (displayExceptionWithInfo) import Control.Monad.Except @@ -31,9 +32,7 @@ import Data.UUID.V4 qualified as UUID import System.IO import GHC.IO.Encoding import Control.Monad.Catch -import Control.Exception (throwIO, IOException) import Control.Concurrent -import Control.Monad import Data.Aeson as Aeson import GHC.Generics import System.Directory @@ -54,10 +53,9 @@ import GHC.Debugger.Interface.Messages hiding (Command, Response) import DAP import Development.Debug.Adapter.Handles import Development.Debug.Session.Setup -import Development.Debug.Adapter.Proxy -import Network.Socket (socketPort) -import qualified Network.Socket as Socket -import GHC.Debugger.Monad (RunDebuggerSettings(externalInterpreterCustomProc)) +import GHC.Debugger.Monad (RunDebuggerSettings(..)) +import GHC.Debugger.Debuggee as Debugger +import Development.Debug.Adapter.DAPDebuggee -------------------------------------------------------------------------------- -- * Client @@ -84,15 +82,6 @@ data LaunchArgs } deriving stock (Show, Eq, Generic) deriving anyclass FromJSON --------------------------------------------------------------------------------- --- * Logging --------------------------------------------------------------------------------- - -data DAPSessionLog - = DAPSessionSetupLog (WithSeverity SessionSetupLog) - | DAPDebuggerLog Debugger.DebuggerLog - | RunProxyServerLog (WithSeverity T.Text) - -------------------------------------------------------------------------------- -- * Launch Debugger -------------------------------------------------------------------------------- @@ -104,12 +93,15 @@ data DAPServerConf = DAPServerConf , dapServerConfig :: ServerConfig } +data InterpreterChoice = InterpreterChoice { runInTerminal :: Bool, internal :: Bool } + + -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise -initDebugger :: LogAction IO DAPSessionLog -> DAPServerConf -> Bool -> Bool +initDebugger :: LogAction IO DAPSessionLog -> DAPServerConf -> InterpreterChoice -> LaunchArgs -> DebugAdaptor () -initDebugger l servConf supportsRunInTerminal preferInternalInterpreter +initDebugger l servConf interpChoice LaunchArgs{ __sessionId , projectRoot = givenRoot , entryFile = entryFileMaybe @@ -159,50 +151,22 @@ initDebugger l servConf supportsRunInTerminal preferInternalInterpreter stackFrameMap = mempty variablesMap = mempty - mkRunInTerminalProc - | not supportsRunInTerminal - = pure NoRunInTerminal - | not preferInternalInterpreter - = do - sock <- openSocketAvailablePort - port <- socketPort sock - -- Close socket again to make sure we can open the server socket - -- later again. - Socket.close sock - pure RunExternalInterpreterInTerminal - { extInterpPort = port - } - | otherwise - = do - (syncProxyIn, syncProxyOut, syncProxyErr) - <- (,,) <$> newChan <*> newChan <*> newChan - proxyClientReady <- newEmptyMVar - pure RunProxyInTerminal{..} - - runInTerminalProc <- liftIO mkRunInTerminalProc - - dbgLog <- liftIO $ - createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc - let hdbProg = hdbProgram servConf - - (runInTerminalThreads, afterRegisterActions) <- - mkRunInTerminalThreads l hdbProg runInTerminalProc preferInternalInterpreter + dbgLog <- liftIO $ createDebuggerLogger l dapLogger writeDAPOutput + + dapd <- initDAPDebuggee l (hdbProgram servConf) interpChoice let defaultRunConf = Debugger.RunDebuggerSettings { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap , supportsANSIHyperlinks = False -- VSCode does not support this - , preferInternalInterpreter - , externalInterpreterCustomProc = case runInTerminalProc of - RunExternalInterpreterInTerminal{extInterpPort} - -> Right extInterpPort - _ -> Left CreatePipe -- if not runInTerminal, just create a new pipe for stdin - , externalInterpreterProg = hdbProgram servConf + , interpreterSettings = dapdInterpreterSettings dapd } absEntryFile = projectRoot /> entryFile - daState = DAS{entryFile=absEntryFile,..} + daState = DAS{entryFile=absEntryFile,waitForDebuggee = dapdWaitForDebuggee dapd,..} + -- TODO: is nextRandom threadsafe? sessionId <- liftIO $ maybe (("debug-session:" <>) . T.show <$> UUID.nextRandom) (pure . T.pack) __sessionId + registerNewDebugSession sessionId daState $ [ \withAdaptor -> do -- The info here is already taken into account in debugRunner. @@ -218,68 +182,24 @@ initDebugger l servConf supportsRunInTerminal preferInternalInterpreter LogAction (\msg -> withAdaptor (Output.neutral msg)) ] ++ - runInTerminalThreads + dapdThreads dapd - afterRegisterActions + dapdAfterRegister dapd --- | Additional threads to register for this session depending on the process --- we're running through `runInTerminal` (see 'RunInTerminalProc'). -mkRunInTerminalThreads +initDAPDebuggee :: LogAction IO DAPSessionLog -> FilePath - -> RunInTerminalProc - -> Bool -- ^ Use internal interpreter - -> DebugAdaptor ([(DebugAdaptorCont () -> IO ()) -> IO ()], DebugAdaptor ()) - -- ^ Threads to register in this debug session and additional commands to - -- run after registering the session. - -mkRunInTerminalThreads _ _ NoRunInTerminal useInternalInterp - -- Not using the terminal proxy, but we still want to output our own - -- stdout/err (from the internal interpreter) as console events. - | True <- useInternalInterp - = pure ([ stdoutCaptureThread Nothing, stderrCaptureThread Nothing ], pure ()) - - | otherwise - = pure ([], pure ()) - -mkRunInTerminalThreads _ hdbProg RunExternalInterpreterInTerminal{..} _ - -- No additional bookkeeping is needed in this case because GHC will - -- naturally have to wait for the external interpreter in order to start execution - = do - pure ([], - sendRunInTerminalReverseRequest - RunInTerminalRequestArguments - { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated - , runInTerminalRequestArgumentsTitle = Nothing - , runInTerminalRequestArgumentsCwd = "" - , runInTerminalRequestArgumentsArgs = - [T.pack hdbProg, "external-interpreter", "--port", T.pack (show extInterpPort)] - , runInTerminalRequestArgumentsEnv = Nothing - , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False - }) - -mkRunInTerminalThreads l hdbProg RunProxyInTerminal{..} _ - = do - (serverPort, serverProxyThread) <- - mkServerSideHdbProxy (contramap RunProxyServerLog l) - syncProxyIn syncProxyOut syncProxyErr proxyClientReady - - pure ( - [ ($ serverProxyThread) - - -- Setup capturing of the process' own stdout and forwarding of the process' own stdin, - -- but only because we're using the internal interpreter! - , stdinForwardThread syncProxyIn - , stdoutCaptureThread (Just syncProxyOut) - , stderrCaptureThread (Just syncProxyErr) - ], - - -- When using the internal interpreter and 'runInTerminal' is supported - -- (the 'RunProxyInTerminal' case), we ask the DAP client to launch the - -- `hdb proxy` attached to the user's terminal. The proxy forwards - -- input/output from the user terminal to the debugger+debuggee shared process - sendRunProxyInTerminal hdbProg serverPort - ) + -> InterpreterChoice + -> DebugAdaptor DAPDebuggee +initDAPDebuggee _ _ InterpreterChoice{runInTerminal = False, internal = True} + = internalNoInTerminalDAPD +initDAPDebuggee _ hdbProg InterpreterChoice{runInTerminal = False, internal = False} + = externalNoInTerminalDAPD hdbProg +initDAPDebuggee _ hdbProg InterpreterChoice{internal = False, runInTerminal = True} + = externalInTerminalDAPD hdbProg +initDAPDebuggee l hdbProg InterpreterChoice{runInTerminal = True, internal = True} + = internalInTerminalDAPD l hdbProg + -- | The main debugger thread launches a GHC.Debugger session. -- @@ -338,9 +258,8 @@ createDebuggerLogger :: LogAction IO DAPSessionLog -> LogAction IO T.Text -- ^ Logger that writes to to DAP output -> Handle -- ^ Handle to DAP output - -> RunInTerminalProc -> IO (LogAction IO Debugger.DebuggerLog) -createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc = do +createDebuggerLogger l dapLogger writeDAPOutput = do return $ -- (1) (all output is logged to normal logger) contramap DAPDebuggerLog l <> @@ -351,91 +270,7 @@ createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc = do dapLogger <& T.pack (show msg) Debugger.GHCLog logflags msg_class srcSpan msg -> defaultLogActionWithHandles writeDAPOutput writeDAPOutput logflags msg_class srcSpan msg - Debugger.LogDebuggeeOut txt -> debuggeeOut dapLogger msyncProxyOut txt - Debugger.LogDebuggeeErr txt -> debuggeeOut dapLogger msyncProxyErr txt + Debugger.LogDebuggeeOut txt -> dapLogger <& txt + Debugger.LogDebuggeeErr txt -> dapLogger <& txt _ -> pure () -- don't log other messages, already logged to (1) ) - where - debuggeeOut l' mproxyChan txt = do - -- (2) - l' <& txt - -- (3) - case mproxyChan of - Nothing -> pure () - Just proxyChan -> - writeChan proxyChan $ - T.encodeUtf8 (txt <> "\n") - - (msyncProxyOut, msyncProxyErr) - | RunProxyInTerminal{syncProxyOut, syncProxyErr} <- runInTerminalProc - = (Just syncProxyOut, Just syncProxyErr) - | otherwise - = (Nothing, Nothing) - --------------------------------------------------------------------------------- --- * Capturing stdout, stderr, and writing to self stdin --------------------------------------------------------------------------------- - --- | Hijack the current process stdin and forward to it the messages from the given channel -stdinForwardThread :: Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () -stdinForwardThread syncIn _withAdaptor = do - tid <- myThreadId - labelThread tid "Stdin Forward Thread" - - -- We need to hijack stdin to write to it - - -- 1. Create a new pipe from writeEnd->readEnd - (readEnd, writeEnd) <- createPipe - - -- 2. Substitute the read-end of the pipe by stdin - _ <- hDuplicateTo readEnd stdin - hClose readEnd -- we'll never need to read from readEnd - - forever $ do - i <- readChan syncIn - -- 3. Write to write-end of the pipe - BS.hPut writeEnd i >> hFlush writeEnd - --- | This thread captures stdout from the debuggee and sends it to the client. --- NOTE, redirecting the stdout handle is a process-global operation. So this thread --- will capture ANY stdout the debuggee emits. Therefore you should never directly --- write to stdout, but always write to the appropiate handle. -stdoutCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () -stdoutCaptureThread msyncOut withAdaptor = do - tid <- myThreadId - labelThread tid "Stdout Capture Thread" - withInterceptedStdout $ \_ interceptedStdout -> do - forever $ do - line <- liftIO $ T.hGetLine interceptedStdout - case msyncOut of - Nothing -> pure () - Just syncOut -> writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") - - -- Always output to Debug Console - catch - (withAdaptor $ Output.stdout line) - (\(_ :: IOException) -> - throwIO (FailedToWriteToAdaptor line)) - --- | Like 'stdoutCaptureThread' but for stderr -stderrCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () -stderrCaptureThread msyncErr withAdaptor = do - tid <- myThreadId - labelThread tid "Stderr Capture Thread" - withInterceptedStderr $ \_ interceptedStderr -> do - forever $ do - line <- liftIO $ T.hGetLine interceptedStderr - case msyncErr of - Nothing -> pure () - Just syncErr -> writeChan syncErr $ T.encodeUtf8 (line <> "\n") - - -- Always output to Debug Console - catch - (withAdaptor $ Output.stderr line) - (\(_ :: IOException) -> - throwIO (FailedToWriteToAdaptor line)) - -newtype FailedToWriteToAdaptor = FailedToWriteToAdaptor T.Text -instance Show FailedToWriteToAdaptor where - show (FailedToWriteToAdaptor t) = "Failed to write to debug adapter: " ++ T.unpack t -instance Exception FailedToWriteToAdaptor diff --git a/hdb-dap/Development/Debug/Adapter/Proxy.hs b/hdb-dap/Development/Debug/Adapter/Proxy.hs index a10a1639..f7d9e762 100644 --- a/hdb-dap/Development/Debug/Adapter/Proxy.hs +++ b/hdb-dap/Development/Debug/Adapter/Proxy.hs @@ -30,7 +30,6 @@ import System.Environment import System.FilePath import Control.Exception.Base import Control.Monad -import Control.Monad.IO.Class import Control.Concurrent import qualified Data.List.NonEmpty as NE @@ -61,13 +60,13 @@ mkServerSideHdbProxy :: LogAction IO (WithSeverity T.Text) -> Chan BS8.ByteString -> Chan BS8.ByteString -> MVar () - -> Adaptor DebugAdaptorState r (PortNumber, Adaptor DebugAdaptorState s ()) -mkServerSideHdbProxy l dbIn dbOut dbErr client_conn_signal = do + -> IO (PortNumber, IO ()) +mkServerSideHdbProxy l dbIn dbOut dbErr client_conn_signal = + bracketOnError openSocketAvailablePort close $ \ sock -> do - sock <- liftIO $ openSocketAvailablePort - port <- liftIO $ socketPort sock + port <- socketPort sock - return $ (port,) $ liftIO $ do + return $ (port,) $ do ignoreIOException $ do myThreadId >>= \tid -> labelThread tid "Debug/Adapter/Proxy: TCP Server" runTCPServerWithSocket' sock $ \scket -> do @@ -135,10 +134,21 @@ labelMe name = do -- | Open a socket on an available port openSocketAvailablePort :: IO Socket openSocketAvailablePort = do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } - addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV] ++ [AI_PASSIVE] -- For wildcard IP (0.0.0.0 or ::) + , addrSocketType = Stream + + , addrFamily = AF_UNSPEC -- Allow IPv4 or IPv6 + } + addr <- NE.head <$> getAddrInfo (Just hints) Nothing (Just "0") -- Bind on "0" to let the OS pick a free port - openTCPServerSocket addr + + sock <- Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + -- Must set before bind! + setSocketOption sock ReuseAddr 1 + + bind sock (addrAddress addr) + listen sock maxListenQueue + return sock -- | The proxy code running on the terminal in which the @hdb proxy@ process is launched. -- diff --git a/hdb-dap/Development/Debug/Adapter/Server.hs b/hdb-dap/Development/Debug/Adapter/Server.hs index 5e2e238d..1486da2f 100644 --- a/hdb-dap/Development/Debug/Adapter/Server.hs +++ b/hdb-dap/Development/Debug/Adapter/Server.hs @@ -13,7 +13,6 @@ module Development.Debug.Adapter.Server import System.Environment import Data.Maybe import Text.Read -import Control.Concurrent import Control.Monad import Control.Monad.IO.Class @@ -39,8 +38,8 @@ import Data.Functor.Contravariant import Development.Debug.Adapter -import GHC.Debugger.Monad import qualified GHC.Utils.Logger as GHC +import GHC.Debugger.Debuggee (DebuggerLog(..)) ------------------------------------------------------------------------- @@ -145,7 +144,7 @@ talk l servConf prefer_internal_interpreter = \ case #endif initDebugger (contramap DAPSessionLog l) servConf - runInTerminal prefer_internal_interpreter + InterpreterChoice {runInTerminal, internal = prefer_internal_interpreter} launch_args sendLaunchResponse -- ack @@ -171,13 +170,8 @@ talk l servConf prefer_internal_interpreter = \ case CommandConfigurationDone -> do sendConfigurationDoneResponse - DAS{runInTerminalProc} <- getDebugSession - case runInTerminalProc of - RunProxyInTerminal{proxyClientReady} -> liftIO $ do - -- Only start executing after proxy client connects succesfully (#95) - takeMVar proxyClientReady - _ -> - pure () + DAS{waitForDebuggee} <- getDebugSession + liftIO $ waitForDebuggee -- Configuration is finished. Start executing until it halts. startExecution >>= handleEvalResult False diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index 02f2984d..07cbc713 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -22,6 +22,7 @@ import GHC.Debugger import Control.Monad import Data.List (intercalate) import qualified Data.Maybe as Maybe +import GHC.Debugger.Debuggee (DebuggerLog) data RunOptions = RunOptions { runEntryFile :: AbsFilePath diff --git a/hdb/Main.hs b/hdb/Main.hs index 2e69ab23..ddebf0f8 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -22,8 +22,8 @@ import System.IO , hSetBuffering , BufferMode(..) , Handle - , openFile - , IOMode(ReadMode, ReadWriteMode) + + , IOMode(ReadWriteMode) ) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -44,6 +44,7 @@ import Development.Debug.Interactive import GHC.Stack.Annotation (annotateCallStackIO) import GHC.Utils.Logger (defaultLogActionWithHandles) import Development.Debug.Session.Setup (hieDebugRunner) +import GHC.Debugger.Debuggee (mkCliInterpreterSettings) #if MIN_VERSION_ghc(9,15,0) import GHC.Debugger.Runtime.Interpreter.Custom (dbgInterpCmdHandler) @@ -84,18 +85,11 @@ main = do HdbCLI{..} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) l <- mainLogger hdbOpts.verbosity stdout - stdinStream <- case debuggeeStdin of - Just fp -> UseHandle <$> System.IO.openFile fp ReadMode - Nothing -> pure Inherit - -- the same program invoked with `external-interpreter` serves as the external interpreter - thisProg <- getExecutablePath + cliInterpSettings <- mkCliInterpreterSettings internalInterpreter debuggeeStdin let runConf = RunDebuggerSettings { supportsANSIStyling = True -- todo: check!! , supportsANSIHyperlinks = False - , preferInternalInterpreter = internalInterpreter - , externalInterpreterCustomProc = Left stdinStream - , externalInterpreterProg = thisProg - } + , interpreterSettings = cliInterpSettings } runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs cradleFile runConf debugInteractive HdbProxy{port} -> do diff --git a/test/golden/T130/T130.ghc-1001.hdb-stdout b/test/golden/T130/T130.ghc-1001.hdb-stdout index 33031342..28630da3 100644 --- a/test/golden/T130/T130.ghc-1001.hdb-stdout +++ b/test/golden/T130/T130.ghc-1001.hdb-stdout @@ -1,2 +1 @@ Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) -While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) diff --git a/test/golden/T130/T130.ghc-914.hdb-stdout b/test/golden/T130/T130.ghc-914.hdb-stdout index 33031342..28630da3 100644 --- a/test/golden/T130/T130.ghc-914.hdb-stdout +++ b/test/golden/T130/T130.ghc-914.hdb-stdout @@ -1,2 +1 @@ Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) -While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) diff --git a/test/golden/T130/T130.hdb-test b/test/golden/T130/T130.hdb-test index f978e65a..69efd6f0 100644 --- a/test/golden/T130/T130.hdb-test +++ b/test/golden/T130/T130.hdb-test @@ -5,7 +5,7 @@ # which is not supported by this debugger version. # (Note: drop the output because the callstack is hard to normalize) -if ($HDB app/Main.hs 2>&1 | grep "Cannot use unsupported") < T130.hdb-stdin; then +if ($HDB app/Main.hs 2>&1 | grep -v 'While handling' | grep "Cannot use unsupported") < T130.hdb-stdin; then exit 0 fi diff --git a/test/golden/T154/T154.ghc-1001.hdb-stdout b/test/golden/T154/T154.external.ghc-1001.hdb-stdout similarity index 100% rename from test/golden/T154/T154.ghc-1001.hdb-stdout rename to test/golden/T154/T154.external.ghc-1001.hdb-stdout diff --git a/test/golden/T154/T154.ghc-914.hdb-stdout b/test/golden/T154/T154.external.ghc-914.hdb-stdout similarity index 100% rename from test/golden/T154/T154.ghc-914.hdb-stdout rename to test/golden/T154/T154.external.ghc-914.hdb-stdout diff --git a/test/golden/T154/T154.ghc-915.hdb-stdout b/test/golden/T154/T154.external.ghc-915.hdb-stdout similarity index 100% rename from test/golden/T154/T154.ghc-915.hdb-stdout rename to test/golden/T154/T154.external.ghc-915.hdb-stdout diff --git a/test/golden/T154/T154.hdb-test b/test/golden/T154/T154.external.hdb-test similarity index 100% rename from test/golden/T154/T154.hdb-test rename to test/golden/T154/T154.external.hdb-test diff --git a/test/golden/T169/T169.ghc-1001.hdb-stdout b/test/golden/T169/T169.internal.ghc-1001.hdb-stdout similarity index 100% rename from test/golden/T169/T169.ghc-1001.hdb-stdout rename to test/golden/T169/T169.internal.ghc-1001.hdb-stdout diff --git a/test/golden/T169/T169.ghc-914.hdb-stdout b/test/golden/T169/T169.internal.ghc-914.hdb-stdout similarity index 100% rename from test/golden/T169/T169.ghc-914.hdb-stdout rename to test/golden/T169/T169.internal.ghc-914.hdb-stdout diff --git a/test/golden/T169/T169.ghc-915.hdb-stdout b/test/golden/T169/T169.internal.ghc-915.hdb-stdout similarity index 100% rename from test/golden/T169/T169.ghc-915.hdb-stdout rename to test/golden/T169/T169.internal.ghc-915.hdb-stdout diff --git a/test/golden/T169/T169.hdb-test b/test/golden/T169/T169.internal.hdb-test similarity index 100% rename from test/golden/T169/T169.hdb-test rename to test/golden/T169/T169.internal.hdb-test