diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index fa3faed..8806806 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -103,8 +103,16 @@ executable hdb Development.Debug.Adapter.Exit, Development.Debug.Adapter.Handles, Development.Debug.Adapter, + + Development.Debug.Adapter.Proxy, + Development.Debug.Interactive, + Development.Debug.Session.Setup, + + Development.Debug.Options, + Development.Debug.Options.Parser, + Paths_haskell_debugger autogen-modules: Paths_haskell_debugger build-depends: @@ -112,6 +120,7 @@ executable hdb exceptions, aeson, bytestring, containers, filepath, process, mtl, unix, + unordered-containers >= 0.2.19 && < 0.3, haskell-debugger, hie-bios, @@ -122,9 +131,11 @@ executable hdb prettyprinter, directory >= 1.3.9 && < 1.4, + network >= 3.2.8, + network-run >= 0.4.4, async >= 2.2.5 && < 2.3, text >= 2.1 && < 2.3, - dap >= 0.2 && < 1, + dap >= 0.3 && < 1, haskeline >= 0.8 && < 1, optparse-applicative >= 0.18 && < 0.20 @@ -136,11 +147,11 @@ executable hdb test-suite haskell-debugger-test import: warnings default-language: Haskell2010 - -- other-modules: -- other-extensions: type: exitcode-stdio-1.0 hs-source-dirs: test/haskell/ main-is: Main.hs + other-modules: Test.DAP.RunInTerminal, Test.DAP, Test.Utils build-depends: base >=4.14, haskell-debugger, @@ -149,8 +160,15 @@ test-suite haskell-debugger-test filepath, process, temporary >= 1.3, + + unordered-containers, + aeson-pretty >= 0.8.10, async >= 2.2.5, + dap, network, aeson, network-run, + random >= 1.3.1, + tasty >= 1.5.3, tasty-golden >= 2.3.5, + tasty-hunit >= 0.10.2, regex >= 1.1 build-tool-depends: haskell-debugger:hdb ghc-options: -threaded diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs index 6fbf470..73d50bd 100644 --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -84,7 +84,10 @@ setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do setBreakpoint FunctionBreak{function} bp_status = do logger <- getLogger resolveFunctionBreakpoint function >>= \case - Left e -> error (showPprUnsafe e) + Left e -> do + liftIO $ logOutput logger $ text $ + "Failed to resolve function breakpoint " ++ function ++ ".\n" ++ showPprUnsafe e ++ "\nIgnoring..." + return BreakNotFound Right (modl, mod_info, fun_str) -> do let modBreaks = GHC.modInfoModBreaks mod_info applyBreak (bix, spn) = do diff --git a/haskell-debugger/GHC/Debugger/Evaluation.hs b/haskell-debugger/GHC/Debugger/Evaluation.hs index 9cee045..af8ab3e 100644 --- a/haskell-debugger/GHC/Debugger/Evaluation.hs +++ b/haskell-debugger/GHC/Debugger/Evaluation.hs @@ -11,7 +11,6 @@ {-# LANGUAGE ViewPatterns #-} module GHC.Debugger.Evaluation where -import GHC.Utils.Trace import GHC.Utils.Outputable import Control.Monad.IO.Class import Control.Monad.Catch @@ -120,8 +119,9 @@ debugExecution recorder entryFile entry args = do findUnitIdOfEntryFile fp = do afp <- normalise <$> liftIO (makeAbsolute fp) modSums <- getAllLoadedModules - case List.find ((Just afp ==) . fmap normalise . GHC.ml_hs_file . GHC.ms_location ) modSums of - Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp + let normalisedModLoc = fmap normalise . GHC.ml_hs_file . GHC.ms_location + case List.find ((Just afp ==) . normalisedModLoc) modSums of + Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp ++ "\nCandidates were:\n" ++ unlines (map (show . normalisedModLoc) modSums) Just summary -> pure summary -- | Resume execution of the stopped debuggee program diff --git a/hdb/Development/Debug/Adapter.hs b/hdb/Development/Debug/Adapter.hs index aeca9eb..dc95a44 100644 --- a/hdb/Development/Debug/Adapter.hs +++ b/hdb/Development/Debug/Adapter.hs @@ -1,7 +1,9 @@ module Development.Debug.Adapter where import Control.Concurrent.MVar +import Control.Concurrent.Chan import qualified Data.IntSet as IS +import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.Text as T import System.FilePath @@ -29,6 +31,12 @@ data DebugAdaptorState = DAS , entryPoint :: String , entryArgs :: [String] , projectRoot :: FilePath + , syncProxyIn :: Chan BS.ByteString + -- ^ Read input to the debuggee from the proxy + , syncProxyOut :: Chan BS.ByteString + -- ^ Write output from the debuggee to the proxy + , syncProxyErr :: Chan BS.ByteString + -- ^ Write stderr from the debuggee to the proxy } type BreakpointId = Int diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 3d5e7fe..3deac59 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -9,8 +9,12 @@ -- | TODO: This module should be called Launch. module Development.Debug.Adapter.Init where +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.Monad.Except import Control.Monad.Trans @@ -88,8 +92,9 @@ newtype InitFailed = InitFailed String deriving Show -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise -initDebugger :: Recorder (WithSeverity InitLog) -> LaunchArgs -> ExceptT InitFailed DebugAdaptor () -initDebugger l LaunchArgs{ __sessionId +initDebugger :: Recorder (WithSeverity InitLog) -> Bool -> LaunchArgs -> ExceptT InitFailed DebugAdaptor () +initDebugger l supportsRunInTerminal + LaunchArgs{ __sessionId , projectRoot = givenRoot , entryFile = entryFileMaybe , entryPoint = fromMaybe "main" -> entryPoint @@ -98,6 +103,9 @@ initDebugger l LaunchArgs{ __sessionId } = do syncRequests <- liftIO newEmptyMVar syncResponses <- liftIO newEmptyMVar + syncProxyIn <- liftIO newChan + syncProxyOut <- liftIO newChan + syncProxyErr <- liftIO newChan entryFile <- case entryFileMaybe of Nothing -> throwError $ InitFailed "Missing \"entryFile\" key in debugger configuration" @@ -134,10 +142,12 @@ initDebugger l LaunchArgs{ __sessionId let absEntryFile = normalise $ projectRoot entryFile lift $ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..} - [ debuggerThread l finished_init writeDebuggerOutput projectRoot flags extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses + [ debuggerThread l finished_init writeDebuggerOutput projectRoot flags + extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses , handleDebuggerOutput readDebuggerOutput - , stdoutCaptureThread - , stderrCaptureThread + , stdinForwardThread supportsRunInTerminal syncProxyIn + , stdoutCaptureThread supportsRunInTerminal syncProxyOut + , stderrCaptureThread supportsRunInTerminal syncProxyErr ] -- Do not return until the initialization is finished @@ -150,25 +160,50 @@ initDebugger l LaunchArgs{ __sessionId -- Instead of signalInitialized, respond with error and exit. lift $ exitCleanupWithMsg readDebuggerOutput e --- | This thread captures stdout from the debugger and sends it to the client. +-- | 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 debugger emits. Therefore you should never directly +-- will capture ANY stdout the debuggee emits. Therefore you should never directly -- write to stdout, but always write to the appropiate handle. -stdoutCaptureThread :: (DebugAdaptorCont () -> IO ()) -> IO () -stdoutCaptureThread withAdaptor = do +stdoutCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stdoutCaptureThread runInTerminal syncOut withAdaptor = do withInterceptedStdout $ \_ interceptedStdout -> do forever $ do line <- liftIO $ T.hGetLine interceptedStdout + when runInTerminal $ + writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") + + -- Always output to Debug Console withAdaptor $ Output.stdout line -- | Like 'stdoutCaptureThread' but for stderr -stderrCaptureThread :: (DebugAdaptorCont () -> IO ()) -> IO () -stderrCaptureThread withAdaptor = do +stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stderrCaptureThread runInTerminal syncErr withAdaptor = do withInterceptedStderr $ \_ interceptedStderr -> do forever $ do line <- liftIO $ T.hGetLine interceptedStderr + when runInTerminal $ + writeChan syncErr $ T.encodeUtf8 (line <> "\n") + + -- Always output to Debug Console withAdaptor $ Output.stderr line +stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stdinForwardThread runInTerminal syncIn _withAdaptor = do + when runInTerminal $ do + -- 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 + -- | The main debugger thread launches a GHC.Debugger session. -- -- Then, forever: diff --git a/hdb/Development/Debug/Adapter/Proxy.hs b/hdb/Development/Debug/Adapter/Proxy.hs new file mode 100644 index 0000000..f212dba --- /dev/null +++ b/hdb/Development/Debug/Adapter/Proxy.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings, DerivingStrategies #-} +-- | Run the proxy mode, which forwards stdin/stdout to/from the DAP server and +-- is displayed in a terminal in the DAP client using 'runInTerminal' +module Development.Debug.Adapter.Proxy + ( serverSideHdbProxy + , runInTerminalHdbProxy + , ProxyLog(..) + ) where + +import DAP + +import System.IO +import System.Exit (exitSuccess) +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 + +import qualified Data.Text as T +import Network.Socket hiding (Debug) +import Network.Run.TCP +import qualified Network.Socket.ByteString as NBS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.HashMap.Strict as H + +import GHC.Debugger.Logger +import Development.Debug.Adapter + +newtype ProxyLog = ProxyLog T.Text + deriving newtype Pretty + +-- | Connect to a running @hdb proxy@ process on the given port +-- connectToHdbProxy :: Recorder (WithVerbosity x) -> Int -> DebugAdaptor () +-- connectToHdbProxy = _ + +-- | Fork a new thread to run the server-side of the proxy. +-- +-- 1. To setup: +-- Ask the DAP client to launch a process running @hdb proxy --port @ +-- by sending a 'runInTerminal' DAP reverse request. This is done outside of +-- this function by signaling the given MVar (this is the case because we cannot use `network` with `DebugAdaptor` +-- +-- 2. In a loop, +-- 2.1 Read stdin from the socket and push it to a Chan +-- 2.1 Read from a stdout Chan and write to the socket +serverSideHdbProxy :: Recorder (WithSeverity ProxyLog) + -> DebugAdaptor () +serverSideHdbProxy l = do + DAS { syncProxyIn = dbIn + , syncProxyOut = dbOut + , syncProxyErr = dbErr } <- getDebugSession + + sock <- liftIO $ do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } + addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") + -- Bind on "0" to let the OS pick a free port + openTCPServerSocket addr + + port <- liftIO $ socketPort sock + + _ <- liftIO $ forkIO $ ignoreIOException $ do + runTCPServerWithSocket sock $ \scket -> do + + logWith l Info $ ProxyLog $ T.pack $ "Connected to client on port " ++ show port ++ "...!" + + -- -- Read stdout from chan and write to socket + _ <- forkIO $ ignoreIOException $ do + forever $ do + bs <- readChan dbOut + logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket: " ++ BS8.unpack bs + NBS.sendAll scket bs + + -- Read stderr from chan and write to socket + _ <- forkIO $ ignoreIOException $ do + forever $ do + bs <- readChan dbErr + logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs + NBS.sendAll scket bs + + -- Read stdin from socket and write to chan + let loop = do + bs <- NBS.recv scket 4096 + if BS8.null bs + then do + logWith l Debug $ ProxyLog $ T.pack "Connection to client was closed." + close scket + else do + logWith l Debug $ ProxyLog $ T.pack $ "Read from socket: " ++ BS8.unpack bs + writeChan dbIn bs >> loop + in ignoreIOException loop + + sendRunProxyInTerminal port + + where + ignoreIOException a = catch a $ \(e::IOException) -> + logWith l Info $ ProxyLog $ T.pack $ "Ignoring connection broken to proxy client: " ++ show e + +-- | The proxy code running on the terminal in which the @hdb proxy@ process is launched. +-- +-- This client-side proxy is responsible for +-- 1. Connecting to the given proxy-server port +-- 2. Forwarding stdin to the port it is connected to +-- 3. Read from the network the output and write it to stdout +runInTerminalHdbProxy :: Recorder (WithSeverity ProxyLog) -> Int -> IO () +runInTerminalHdbProxy l port = do + logWith l Info $ ProxyLog $ T.pack $ "Running in terminal on port " ++ show port ++ "...!" + hSetBuffering stdin LineBuffering + + dbg_inv <- lookupEnv "DEBUGGEE_INVOCATION" + case dbg_inv of + Nothing -> pure () + Just inv -> + putStrLn $ "Running the debugger input/output proxy for the following debuggee execution:\n\n\n " ++ inv ++ "\n\n" + + catch ( + runTCPClient "127.0.0.1" (show port) $ \sock -> do + -- Forward stdin to sock + _ <- forkIO $ + catch (forever $ do + str <- BS8.hGetLine stdin + NBS.sendAll sock (str <> BS8.pack "\n") + ) $ \(e::IOException) -> return () -- connection dropped, just exit. + + -- Forward stdout from sock + catch (forever $ do + msg <- NBS.recv sock 4096 + if BS8.null msg + then do + logWith l Info $ ProxyLog $ T.pack "Exiting..." + close sock + exitSuccess + else BS8.hPut stdout msg >> hFlush stdout + ) $ \(e::IOException) -> return () -- connection dropped, just exit. + + ) $ \(e::IOException) -> do + hPutStrLn stderr "Failed to connect to debugger server proxy -- did the debuggee compile and start running successfully?" + +-- | Send a 'runInTerminal' reverse request to the DAP client +-- with the @hdb proxy@ invocation +sendRunProxyInTerminal :: PortNumber -> DebugAdaptor () +sendRunProxyInTerminal port = do + DAS { entryFile + , entryPoint + , entryArgs + , projectRoot } <- getDebugSession + let debuggee_inv = T.pack $ makeRelative projectRoot entryFile ++ ":" ++ entryPoint ++ + (if null entryArgs then "" else " ") ++ unwords entryArgs + sendRunInTerminalReverseRequest + RunInTerminalRequestArguments + { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated + , runInTerminalRequestArgumentsTitle = Just debuggee_inv + , runInTerminalRequestArgumentsCwd = "" + , runInTerminalRequestArgumentsArgs = ["hdb", "proxy", "--port", T.pack (show port)] + , runInTerminalRequestArgumentsEnv = Just (H.singleton "DEBUGGEE_INVOCATION" debuggee_inv) + , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False + } diff --git a/hdb/Development/Debug/Options.hs b/hdb/Development/Debug/Options.hs new file mode 100644 index 0000000..8f81c80 --- /dev/null +++ b/hdb/Development/Debug/Options.hs @@ -0,0 +1,42 @@ +-- | Options supported by the debugger +-- +-- For parsing see 'Development.Debug.Options.Parser' +module Development.Debug.Options + ( HdbOptions(..) ) where + +import GHC.Debugger.Logger + +-- | The options `hdb` is invoked in the command line with +data HdbOptions + -- | @server --port @ + = HdbDAPServer + { port :: Int + , verbosity :: Verbosity + } + -- | @cli [--entry-point=] [--extra-ghc-args=""] [] -- []@ + | HdbCLI + { entryPoint :: String + , entryFile :: FilePath + , entryArgs :: [String] + , extraGhcArgs :: [String] + , verbosity :: Verbosity + } + + -- | @proxy --port @ + -- + -- The proxy command serves as a middle man between the user and the debugger. + -- It is used implicitly by DAP mode: upon initialization, the debugger + -- server asks the DAP client to @runInTerminal@ the @hdb proxy --port ...@ + -- command at a port determined by the debugger server. + -- + -- The proxy mode will forward stdin to the debugger server and will be + -- forwarded the debuggee's stdout. This essentially enables the user to + -- observe and interact with the execution of the debugger, in a standalone + -- terminal. + -- + -- See #44 for the original ticket + | HdbProxy + { port :: Int + , verbosity :: Verbosity + } + diff --git a/hdb/Development/Debug/Options/Parser.hs b/hdb/Development/Debug/Options/Parser.hs new file mode 100644 index 0000000..d7193f8 --- /dev/null +++ b/hdb/Development/Debug/Options/Parser.hs @@ -0,0 +1,117 @@ +-- | Options parser using optparse-applicative for the debugger options in +-- 'Development.Debug.Options' +module Development.Debug.Options.Parser + ( -- * Command line options parsing + parseHdbOptions + ) where + +import Options.Applicative hiding (command) + +import Data.Version +import qualified Options.Applicative +import qualified Paths_haskell_debugger as P + +import GHC.Debugger.Logger +import Development.Debug.Options + +-------------------------------------------------------------------------------- +-- Options parser +-------------------------------------------------------------------------------- + +-- | Parser for 'HdbDAPServer' options +serverParser :: Parser HdbOptions +serverParser = HdbDAPServer + <$> option auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> help "DAP server port" ) + <*> verbosityParser (Verbosity Debug) + +-- | Parser for 'HdbCLI' options +cliParser :: Parser HdbOptions +cliParser = HdbCLI + <$> strOption + ( long "entry-point" + <> short 'e' + <> metavar "ENTRY_POINT" + <> value "main" + <> help "The name of the function that is called to start execution (default: main)" ) + <*> argument str + ( metavar "ENTRY_FILE" + <> help "The relative path from the project root to the file with the entry point for execution" ) + <*> many + ( argument str + ( metavar "ENTRY_ARGS..." + <> help "The arguments passed to the entryPoint. If the entryPoint is main, these arguments are passed as environment arguments (as in getArgs) rather than direct function arguments." + ) + ) + <*> option (words <$> str) + ( long "extra-ghc-args" + <> metavar "GHC_ARGS" + <> value [] + <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" ) + <*> verbosityParser (Verbosity Warning) + +-- | Parser for 'HdbProxy' options +proxyParser :: Parser HdbOptions +proxyParser = HdbProxy + <$> option auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> help "proxy port to which the debugger connects" ) + <*> verbosityParser (Verbosity Warning) + +-- | Combined parser for HdbOptions +hdbOptionsParser :: Parser HdbOptions +hdbOptionsParser = hsubparser + ( Options.Applicative.command "server" + ( info serverParser + ( progDesc "Start the Haskell debugger in DAP server mode" ) ) + <> Options.Applicative.command "cli" + ( info cliParser + ( progDesc "Debug a Haskell program in CLI mode" ) ) + <> Options.Applicative.command "proxy" + ( info proxyParser + ( progDesc "Internal mode used by the DAP server to proxy the stdin/stdout to the DAP client's terminal" ) ) + ) + <|> cliParser -- Default to CLI mode if no subcommand + +-- | Parser for --version flag +versioner :: Parser (a -> a) +versioner = simpleVersioner $ "Haskell Debugger, version " ++ showVersion P.version + +-- | Parser for --verbosity 0 +-- +-- The default verbosity differs by mode (#86): +-- - DAP server mode: DEBUG +-- - CLI mode: WARNING +verbosityParser :: Verbosity -> Parser Verbosity +verbosityParser vdef = option verb + ( long "verbosity" + <> short 'v' + <> metavar "VERBOSITY" + <> value vdef + <> help "Logger verbosity in [0..3] interval, where 0 is silent and 3 is debug" + ) + where + verb = Verbosity <$> (verbNum =<< auto) + verbNum n = case n :: Int of + 0 -> pure Error + 1 -> pure Warning + 2 -> pure Info + 3 -> pure Debug + _ -> readerAbort (ErrorMsg "Verbosity must be a value in [0..3]") + +-- | Main parser info +hdbParserInfo :: ParserInfo HdbOptions +hdbParserInfo = info (hdbOptionsParser <**> versioner <**> helper) + ( fullDesc + <> header "Haskell debugger supporting both CLI and DAP modes" ) + +-- | Parse command line arguments +parseHdbOptions :: IO HdbOptions +parseHdbOptions = customExecParser + defaultPrefs{prefShowHelpOnError = True, prefShowHelpOnEmpty = True} + hdbParserInfo diff --git a/hdb/Main.hs b/hdb/Main.hs index 33e38fa..77a8049 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -2,9 +2,13 @@ module Main where import System.Environment +import System.Process import Data.Maybe -import Data.Version +import Data.Aeson +import Data.IORef import Text.Read +import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Except import DAP @@ -17,125 +21,19 @@ import Development.Debug.Adapter.Evaluation import Development.Debug.Adapter.Exit import Development.Debug.Adapter.Handles import GHC.Debugger.Logger -import Development.Debug.Adapter - -import Development.Debug.Interactive +import Prettyprinter import System.IO (hSetBuffering, BufferMode(LineBuffering)) import qualified DAP.Log as DAP import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Handle.FD -import Options.Applicative hiding (command) -import qualified Options.Applicative - -import qualified Paths_haskell_debugger as P - --- | The options `hdb` is invoked in the command line with -data HdbOptions - -- | @server --port @ - = HdbDAPServer - { port :: Int - , verbosity :: Verbosity - } - -- | @[--entry-point=] [--extra-ghc-args=""] [] -- []@ - | HdbCLI - { entryPoint :: String - , entryFile :: FilePath - , entryArgs :: [String] - , extraGhcArgs :: [String] - , verbosity :: Verbosity - } - --------------------------------------------------------------------------------- --- Options parser --------------------------------------------------------------------------------- - --- | Parser for HdbDAPServer options -serverParser :: Parser HdbOptions -serverParser = HdbDAPServer - <$> option auto - ( long "port" - <> short 'p' - <> metavar "PORT" - <> help "DAP server port" ) - <*> verbosityParser (Verbosity Debug) - --- | Parser for HdbCLI options -cliParser :: Parser HdbOptions -cliParser = HdbCLI - <$> strOption - ( long "entry-point" - <> short 'e' - <> metavar "ENTRY_POINT" - <> value "main" - <> help "The name of the function that is called to start execution (default: main)" ) - <*> argument str - ( metavar "ENTRY_FILE" - <> help "The relative path from the project root to the file with the entry point for execution" ) - <*> many - ( argument str - ( metavar "ENTRY_ARGS..." - <> help "The arguments passed to the entryPoint. If the entryPoint is main, these arguments are passed as environment arguments (as in getArgs) rather than direct function arguments." - ) - ) - <*> option (words <$> str) - ( long "extra-ghc-args" - <> metavar "GHC_ARGS" - <> value [] - <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" ) - <*> verbosityParser (Verbosity Warning) - - --- | Combined parser for HdbOptions -hdbOptionsParser :: Parser HdbOptions -hdbOptionsParser = hsubparser - ( Options.Applicative.command "server" - ( info serverParser - ( progDesc "Start the Haskell debugger in DAP server mode" ) ) - <> Options.Applicative.command "cli" - ( info cliParser - ( progDesc "Debug a Haskell program in CLI mode" ) ) - ) - <|> cliParser -- Default to CLI mode if no subcommand - --- | Parser for --version flag -versioner :: Parser (a -> a) -versioner = simpleVersioner $ "Haskell Debugger, version " ++ showVersion P.version - --- | Parser for --verbosity 0 --- --- The default verbosity differs by mode (#86): --- - DAP server mode: DEBUG --- - CLI mode: WARNING -verbosityParser :: Verbosity -> Parser Verbosity -verbosityParser vdef = option verb - ( long "verbosity" - <> short 'v' - <> metavar "VERBOSITY" - <> value vdef - <> help "Logger verbosity in [0..3] interval, where 0 is silent and 3 is debug" - ) - where - verb = Verbosity <$> (verbNum =<< auto) - verbNum n = case n :: Int of - 0 -> pure Error - 1 -> pure Warning - 2 -> pure Info - 3 -> pure Debug - _ -> readerAbort (ErrorMsg "Verbosity must be a value in [0..3]") --- | Main parser info -hdbParserInfo :: ParserInfo HdbOptions -hdbParserInfo = info (hdbOptionsParser <**> versioner <**> helper) - ( fullDesc - <> header "Haskell debugger supporting both CLI and DAP modes" ) - --- | Parse command line arguments -parseHdbOptions :: IO HdbOptions -parseHdbOptions = customExecParser - defaultPrefs{prefShowHelpOnError = True, prefShowHelpOnEmpty = True} - hdbParserInfo +import Development.Debug.Options (HdbOptions(..)) +import Development.Debug.Options.Parser (parseHdbOptions) +import Development.Debug.Adapter +import Development.Debug.Adapter.Proxy +import Development.Debug.Interactive -------------------------------------------------------------------------------- @@ -158,14 +56,20 @@ main = do l <- handleLogger realStdout let dapLogger = cmap DAP.renderDAPLog $ timeStampLogger l let runLogger = loggerFinal hdbOpts l - runDAPServerWithLogger (toCologAction dapLogger) config $ - talk runLogger + init_var <- liftIO (newIORef False{-not supported by default-}) + pid_var <- liftIO (newIORef Nothing) + runDAPServerWithLogger (toCologAction dapLogger) config + (talk runLogger init_var pid_var) + (ack runLogger pid_var) HdbCLI{..} -> do l <- handleLogger stdout let runLogger = cmapWithSev InteractiveLog $ loggerFinal hdbOpts l runIDM runLogger entryPoint entryFile entryArgs extraGhcArgs $ debugInteractive runLogger - + HdbProxy{port} -> do + l <- handleLogger stdout + let runLogger = cmapWithSev RunProxyClientLog $ loggerFinal hdbOpts l + runInTerminalHdbProxy runLogger port -- | Fetch config from environment, fallback to sane defaults getConfig :: Int -> IO ServerConfig @@ -218,30 +122,56 @@ getConfig port = do data MainLog = InitLog InitLog + | LaunchLog T.Text | InteractiveLog InteractiveLog + | RunProxyServerLog ProxyLog + | RunProxyClientLog ProxyLog instance Pretty MainLog where pretty = \ case InitLog msg -> pretty msg + LaunchLog msg -> pretty msg InteractiveLog msg -> pretty msg + RunProxyServerLog msg -> pretty ("Proxy Server:" :: String) <+> pretty msg + RunProxyClientLog msg -> pretty ("Proxy Client:" :: String) <+> pretty msg -- | Main function where requests are received and Events + Responses are returned. -- The core logic of communicating between the client <-> adaptor <-> debugger -- is implemented in this function. -talk :: Recorder (WithSeverity MainLog) -> Command -> DebugAdaptor () +talk :: Recorder (WithSeverity MainLog) + -> IORef Bool + -- ^ Whether the client supports runInTerminal + -> IORef (Maybe Int) + -- ^ The PID of the runInTerminal proxy process + -> Command -> DebugAdaptor () -------------------------------------------------------------------------------- -talk l = \ case +talk l support_rit_var pid_var = \ case CommandInitialize -> do - -- InitializeRequestArguments{..} <- getArguments + InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments + liftIO $ writeIORef support_rit_var (fromMaybe False supportsRunInTerminalRequest) sendInitializeResponse + -------------------------------------------------------------------------------- CommandLaunch -> do launch_args <- getArguments - merror <- runExceptT $ initDebugger (cmapWithSev InitLog l) launch_args + + supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var + + merror <- runExceptT $ initDebugger (cmapWithSev InitLog l) supportsRunInTerminalRequest launch_args case merror of Right () -> do sendLaunchResponse -- ack sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session + + -- Run the proxy in a separate terminal to accept stdin / forward stdout + -- if it is supported + when supportsRunInTerminalRequest $ do + -- Run proxy thread, server side, and + -- send the 'runInTerminal' request + serverSideHdbProxy (cmapWithSev RunProxyServerLog l) + + logWith l Info $ LaunchLog $ T.pack "Debugger launched successfully." + Left (InitFailed err) -> do sendErrorResponse (ErrorMessage (T.pack err)) Nothing exitCleanly @@ -278,13 +208,33 @@ talk l = \ case ---------------------------------------------------------------------------- CommandEvaluate -> commandEvaluate ---------------------------------------------------------------------------- - CommandTerminate -> commandTerminate + CommandTerminate -> do + commandTerminate CommandDisconnect -> commandDisconnect ---------------------------------------------------------------------------- CommandModules -> sendModulesResponse (ModulesResponse [] Nothing) CommandSource -> undefined - CommandPause -> undefined + CommandPause -> pure () -- TODO (CustomCommand "mycustomcommand") -> undefined + (CustomCommand "runInTerminal") -> do + -- Ignore result of runInTerminal (reverse request) response. + -- If it fails, we simply continue without that functionality. + pure () + other -> do + sendErrorResponse (ErrorMessage (T.pack ("Unsupported command: " <> show other))) Nothing + exitCleanly ---------------------------------------------------------------------------- -- talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd) ---------------------------------------------------------------------------- + +-- | Receive reverse request responses (such as runInTerminal response) +ack :: Recorder (WithSeverity MainLog) + -> IORef (Maybe Int) + -- ^ Reference to PID of runInTerminal proxy process running + -> ReverseRequestResponse -> DebugAdaptorCont () +ack l ref rrr = case rrr.reverseRequestCommand of + ReverseCommandRunInTerminal -> do + when rrr.success $ do + logWith l Info $ LaunchLog $ T.pack "RunInTerminal was successful" + _ -> pure () + diff --git a/test/haskell/Main.hs b/test/haskell/Main.hs index 18d3e57..1e857ed 100644 --- a/test/haskell/Main.hs +++ b/test/haskell/Main.hs @@ -18,12 +18,21 @@ import Test.Tasty import Test.Tasty.Golden as G import Test.Tasty.Golden.Advanced as G +import Test.DAP.RunInTerminal +import Test.Utils + main :: IO () main = do goldens <- mapM (mkGoldenTest False) =<< findByExtension [".hdb-test"] "test/golden" defaultMain $ testGroup "Tests" - goldens + [ testGroup "Golden tests" goldens + , testGroup "Unit tests" unitTests + ] + +unitTests = + [ runInTerminalTests + ] -- | Receives as an argument the path to the @*.hdb-test@ which contains the -- shell invocation for running @@ -43,25 +52,6 @@ mkGoldenTest keepTmpDirs path = do ExitSuccess -> LBS.hGetContents hout ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c --- | Copy the contents of a test directory (with a `*.hdb-test` in the root) to --- a temporary location and return the path to the new location. -withHermeticDir :: Bool -- ^ Whether to keep the temp dir around for inspection - -> FilePath -- ^ Test dir - -> (FilePath -> IO r) -- ^ Continuation receives hermetic test dir (in temporary dir) - -> IO r -withHermeticDir keep src k = do - withTmpDir "hdb-test" $ \dest -> do - P.callCommand $ "cp -r " ++ src ++ " " ++ dest - k (dest takeBaseName src) - where - withTmpDir | keep = withPersistentSystemTempDirectory - | otherwise = withSystemTempDirectory - - withPersistentSystemTempDirectory :: String -> (FilePath -> IO r) -> IO r - withPersistentSystemTempDirectory template k' = do - dir <- flip createTempDirectory template =<< getCanonicalTemporaryDirectory - k' dir - -------------------------------------------------------------------------------- -- Tasty Golden Advanced wrapper -------------------------------------------------------------------------------- diff --git a/test/haskell/Test/DAP.hs b/test/haskell/Test/DAP.hs new file mode 100644 index 0000000..bb31da4 --- /dev/null +++ b/test/haskell/Test/DAP.hs @@ -0,0 +1,122 @@ +-- | Utils essentially copied from `dap`'s test suite +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +module Test.DAP where + +---------------------------------------------------------------------------- +import Control.Applicative +import Control.Concurrent +import Data.Aeson.Encode.Pretty +import Data.Aeson.Types +import Data.Aeson.KeyMap +import Control.Exception hiding (handle) +import qualified Data.ByteString.Lazy.Char8 as BL8 ( hPutStrLn ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 ( hPutStrLn ) +import qualified Data.HashMap.Strict as H +import Network.Run.TCP +import Network.Socket (socketToHandle) +import System.IO +import System.Exit +import Data.IORef +---------------------------------------------------------------------------- +import DAP.Utils +import DAP.Server +import DAP.Types (Command) +---------------------------------------------------------------------------- +import Test.Tasty.HUnit + +-- | Sends a DAP request to the given handle +sendDAPRequest :: ToJSON a => Handle -> Command -> a -> IO () +sendDAPRequest handle cmd args = do + send handle + [ "seq" .= (1 :: Int) + , "type" .= ("request" :: String) + , "command" .= cmd + , "arguments".= args + ] + +-- | Receive and decode DAP message +recvDAPResponse + :: FromJSON a + => Handle + -- ^ Handle to receive bytes from + -> IO a + -- ^ The decoded DAP message +recvDAPResponse h = do + readPayload h >>= \case + Left e -> fail e + Right actual -> + -- Read field "body" or "arguments" (for reverse requests) + case parseMaybe (withObject "response/rev request" $ \r -> (do + ("response" :: String) <- r .: "type" + True <- r .: "success" + r .: "body") <|> (do + ("request" :: String) <- r .: "type" + r .: "arguments") + ) actual of + Nothing -> fail $ "Failed to parse DAP response body: " ++ show actual + Just body -> + case parseMaybe parseJSON body of + Nothing -> fail $ "Failed to parse DAP response body content: " ++ show body + Just res -> pure res + +-------------------------------------------------------------------------------- + +-- | Sample host shared amongst client and server +-- +testHost :: String +testHost = "127.0.0.1" + +-- | Spawns a new mock client that connects to the mock server. +-- +withNewClient :: Int -- ^ Port + -> IORef Bool + -- ^ True if we've already connected once and therefore should no longer retry + -> (Handle -> IO ()) + -> IO () +withNewClient port retryVar continue = flip catch exceptionHandler $ + runTCPClient testHost (show port) $ \socket -> do + h <- socketToHandle socket ReadWriteMode + hSetNewlineMode h NewlineMode { inputNL = CRLF, outputNL = CRLF } + continue h `finally` hClose h + where + exceptionHandler :: SomeException -> IO () + exceptionHandler e = do + do_retry <- readIORef retryVar + if do_retry then do + threadDelay 100_000 -- 0.1s + -- Do it silently: + -- putStrLn "Retrying connection..." + withNewClient port retryVar continue + else do + putStrLn $ displayException e + exitWith (ExitFailure 22) + +-- | Helper to send JSON payloads to the server +-- +send :: Handle -> [Pair] -> IO () +send h message + = BS.hPutStr h $ encodeBaseProtocolMessage (object message) + +-- | Helper to receive JSON payloads to the client +-- checks if 'Handle' returns a subset expected payload +-- +shouldReceive + :: Handle + -- ^ Handle to receive bytes from + -> [Pair] + -- ^ Subset of JSON values that should be present in the payload + -> IO () +shouldReceive h expected = do + case object expected of + Object ex -> + readPayload h >>= \case + Left e -> fail e + Right actual + | toHashMapText ex `H.isSubmapOf` toHashMapText actual -> pure () + | otherwise -> encodePretty actual @=? encodePretty ex + _ -> fail "Invalid JSON" diff --git a/test/haskell/Test/DAP/RunInTerminal.hs b/test/haskell/Test/DAP/RunInTerminal.hs new file mode 100644 index 0000000..804640b --- /dev/null +++ b/test/haskell/Test/DAP/RunInTerminal.hs @@ -0,0 +1,279 @@ +-- | 'runInTerminal' tests +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE LambdaCase #-} +module Test.DAP.RunInTerminal (runInTerminalTests) where + +import Control.Concurrent +import DAP.Types +import DAP.Utils +import Data.Aeson +import Data.IORef +import Data.List (isInfixOf) +import System.FilePath +import System.IO +import System.Random +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +import Test.Utils +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LB8 +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified System.Process as P + +runInTerminalTests = + testGroup "DAP.RunInTerminal" + [ testCase "runInTerminal: proxy forwards stdin correctly" runInTerminal1 + ] + +rit_keep_tmp_dirs :: Bool +rit_keep_tmp_dirs = False + +runInTerminal1 = do + withHermeticDir rit_keep_tmp_dirs "test/unit/T44" $ \test_dir -> do + + -- Come up with a random port + testPort <- randomRIO (49152, 65534) :: IO Int + + -- Launch server process + (Just hin, Just hout, _, p) + <- P.createProcess (P.shell $ "hdb server --port " ++ show testPort) + {P.cwd = Just test_dir, P.std_out = P.CreatePipe, P.std_in = P.CreatePipe} + + -- Fork thread to print out output of server process + -- This is surprisingly needed, otherwise the server process + -- will be broken, perhaps because it blocks trying to write to stdout/stderr if the buffer is full? + forkIO $ do + hSetBuffering hout LineBuffering + let loop = do + eof <- hIsEOF hout + if eof + then return () + else do + _l <- hGetLine hout + -- putStrLn ("[server] " ++ l) + loop + loop + + retryVar <- newIORef True + -- Connect to the DAP server + withNewClient testPort retryVar $ \handle -> do + -- As soon as we get a connection, stop retrying + writeIORef retryVar False + + -- Initialize + sendDAPRequest handle CommandInitialize InitializeRequestArguments + { adapterID = "haskell-debugger" + , clientID = Just "mock-client" + , clientName = Just "Mock Client" + , columnsStartAt1 = Just True + , linesStartAt1 = Just True + , locale = Just "en" + , pathFormat = Just Path + , supportsArgsCanBeInterpretedByShell = Nothing + , supportsInvalidatedEvent = Nothing + , supportsMemoryEvent = Nothing + , supportsMemoryReferences = Nothing + , supportsProgressReporting = Nothing + , supportsRunInTerminalRequest = Just True + , supportsStartDebuggingRequest = Nothing + , supportsVariablePaging = Nothing + , supportsVariableType = Nothing + } + + -- Recv initalize response + _ <- shouldReceive handle [] + + -- Send launch request + send handle + [ "command" .= ("launch" :: String) + , "seq" .= (2 :: Int) + , "type" .= ("request" :: String) + , "arguments".= object + [ "entryFile" .= (test_dir "Main.hs" :: String) + , "entryPoint" .= ("main" :: String) + , "projectRoot" .= (test_dir :: String) + , "extraGhcArgs" .= ([] :: [String]) + , "entryArgs" .= ([] :: [String]) + , "request" .= ("launch" :: String) + ] + ] + + _ <- shouldReceive handle + ["type" .= ("event" :: String), "event" .= ("output" :: String)] + _ <- shouldReceive handle + ["type" .= ("event" :: String), "event" .= ("output" :: String)] + _ <- shouldReceive handle + [ "command" .= ("launch" :: String) + , "success" .= True] + _ <- shouldReceive handle + [ "event" .= ("initialized" :: String) + , "type" .= ("event" :: String) + ] + + -- Receive a runInTerminal request!! + r@RunInTerminalRequestArguments{} <- recvDAPResponse handle + (Just rit_in, Just rit_out, _, rit_p) + <- P.createProcess + (P.shell $ T.unpack $ + "/usr/bin/env " <> addRITEnv r.runInTerminalRequestArgumentsEnv <> " " <> T.unwords (r.runInTerminalRequestArgumentsArgs)) + {P.cwd = Just test_dir, P.std_in = P.CreatePipe, P.std_out = P.CreatePipe} + + -- Send a breakpoint request + sendDAPRequest handle CommandSetBreakpoints + SetBreakpointsArguments + { setBreakpointsArgumentsSource = Source + { sourceName = Just "Main.hs" + , sourcePath = Just $ T.pack $ test_dir "Main.hs" + , sourceSourceReference = Nothing + , sourcePresentationHint = Nothing + , sourceOrigin = Nothing + , sourceAdapterData = Nothing + , sourceChecksums = Nothing + , sourceSources = Nothing + } + , setBreakpointsArgumentsBreakpoints = Just [SourceBreakpoint {sourceBreakpointLine = 6, sourceBreakpointColumn = Nothing, sourceBreakpointCondition = Nothing, sourceBreakpointHitCondition = Nothing, sourceBreakpointLogMessage = Nothing}] + , setBreakpointsArgumentsLines = Just [6] + , setBreakpointsArgumentsSourceModified = Just False + } + + _ <- shouldReceive handle + [ "command" .= ("setBreakpoints" :: String) + , "success" .= True + , "type" .= ("response" :: String) + ] + + -- Send runInTerminal response + Just rit_pid <- P.getPid rit_p + send handle + [ "command" .= ("runInTerminal" :: String) + , "seq" .= (6 :: Int) + , "type" .= ("response" :: String) + , "success" .= True + , "body" .= object + [ "shellProcessId" .= (fromIntegral rit_pid :: Int) + ] + ] + + send handle + [ "seq" .= (1 :: Int) + , "type" .= ("request" :: String) + , "command" .= CommandConfigurationDone + ] + + _ <- shouldReceive handle + [ "command" .= ("configurationDone" :: String) + , "success" .= True + , "type" .= ("response" :: String) + ] + + -- The program should start running now, and hit the breakpoint. + -- It will also print "Hello". Since the order is not important, we just + -- match on the type == event and ignore if it's "stopped" or "output" + _ <- shouldReceive handle + [ "type" .= ("event" :: String) ] + _ <- shouldReceive handle + [ "type" .= ("event" :: String) ] + + -- Continue from "getLine" which will block waiting for input + goToNextLine handle + + let secret_in = "SOMETHING_SECRET" + + -- Time to write to the stdin of the rit process + hSetBuffering rit_in LineBuffering + hPutStrLn rit_in secret_in + + -- Only after writing should we receive the next "stopped" event + _ <- shouldReceive handle + ["type" .= ("event" :: String), "event" .= ("stopped" :: String)] + + -- To next line, which should be the "putStrLn" after the "getLine" + goToNextLine handle + -- It's both stopped and we receive the SOMETHING_SECRET printed out. Order not important. + _ <- shouldReceive handle + ["type" .= ("event" :: String)] + _ <- shouldReceive handle + ["type" .= ("event" :: String)] + + -- The contents of the rit_output should contain "hello" plus printing of what we wrote + out <- LBS.hGetContents rit_out + let out_str = LB8.unpack out + assertBool ("Expected output to contain 'hello', got: " ++ out_str) + ("hello" `isInfixOf` out_str) + assertBool ("Expected output to contain '" ++ secret_in ++ "' , got: " ++ out_str) + (secret_in `isInfixOf` out_str) + + -- Send disconnect + sendDAPRequest handle CommandDisconnect (DisconnectArguments {disconnectArgumentsRestart = False, disconnectArgumentsTerminateDebuggee = True, disconnectArgumentsSuspendDebuggee = False}) + _ <- shouldReceive handle + [ "command" .= ("disconnect" :: String) + , "success" .= True + , "type" .= ("response" :: String) + ] + _ <- shouldReceive handle + [ "event" .= ("terminated" :: String) + , "type" .= ("event" :: String) + ] + -- Kill the processes if they're still running + P.terminateProcess rit_p + P.terminateProcess p + + where + goToNextLine handle = do + _ <- sendDAPRequest handle CommandNext (Just (NextArguments {nextArgumentsThreadId = 0, nextArgumentsSingleThread = Nothing, nextArgumentsGranularity = Nothing})) + _ <- shouldReceive handle + [ "command" .= ("next" :: String) + , "success" .= True + , "type" .= ("response" :: String) + ] + return () + + addRITEnv :: Maybe (H.HashMap T.Text T.Text) -> T.Text + addRITEnv env = + case env of + Nothing -> "" + Just env -> T.unwords [k{-todo: escape-} <> "=" <> v | (k,v) <- H.toList env] +-------------------------------------------------------------------------------- +instance ToJSON InitializeRequestArguments where + toJSON InitializeRequestArguments{..} = object + [ "adapterID" .= adapterID + , "clientID" .= clientID + , "clientName" .= clientName + , "columnsStartAt1" .= columnsStartAt1 + , "linesStartAt1" .= linesStartAt1 + , "locale" .= locale + , "pathFormat" .= pathFormat + , "supportsArgsCanBeInterpretedByShell" .= supportsArgsCanBeInterpretedByShell + , "supportsInvalidatedEvent" .= supportsInvalidatedEvent + , "supportsMemoryEvent" .= supportsMemoryEvent + , "supportsMemoryReferences" .= supportsMemoryReferences + , "supportsProgressReporting" .= supportsProgressReporting + , "supportsRunInTerminalRequest" .= supportsRunInTerminalRequest + , "supportsStartDebuggingRequest" .= supportsStartDebuggingRequest + , "supportsVariablePaging" .= supportsVariablePaging + , "supportsVariableType" .= supportsVariableType + ] +instance ToJSON PathFormat where + toJSON Path = String "path" + toJSON URI = String "uri" + toJSON (PathFormat x) = String x +instance ToJSON SetBreakpointsArguments where + toJSON = genericToJSONWithModifier +instance ToJSON NextArguments where + toJSON = genericToJSONWithModifier +instance ToJSON DisconnectArguments where + toJSON = genericToJSONWithModifier +instance ToJSON SourceBreakpoint where + toJSON = genericToJSONWithModifier +instance ToJSON SteppingGranularity where + toJSON = genericToJSONWithModifier +instance FromJSON bps => FromJSON (Breakpoints bps) where + parseJSON = withObject "bkrps" $ \o -> + Breakpoints <$> o .: "breakpoints" +instance FromJSON Breakpoint where + parseJSON = genericParseJSONWithModifier + diff --git a/test/haskell/Test/Utils.hs b/test/haskell/Test/Utils.hs new file mode 100644 index 0000000..988a4f1 --- /dev/null +++ b/test/haskell/Test/Utils.hs @@ -0,0 +1,25 @@ +module Test.Utils where + +import System.FilePath +import System.IO.Temp +import qualified System.Process as P + +-- | Copy the contents of a test directory (with a `*.hdb-test` in the root) to +-- a temporary location and return the path to the new location. +withHermeticDir :: Bool -- ^ Whether to keep the temp dir around for inspection + -> FilePath -- ^ Test dir + -> (FilePath -> IO r) -- ^ Continuation receives hermetic test dir (in temporary dir) + -> IO r +withHermeticDir keep src k = do + withTmpDir "hdb-test" $ \dest -> do + P.callCommand $ "cp -r " ++ src ++ " " ++ dest + k (dest takeBaseName src) + where + withTmpDir | keep = withPersistentSystemTempDirectory + | otherwise = withSystemTempDirectory + + withPersistentSystemTempDirectory :: String -> (FilePath -> IO r) -> IO r + withPersistentSystemTempDirectory template k' = do + dir <- flip createTempDirectory template =<< getCanonicalTemporaryDirectory + k' dir + diff --git a/test/unit/T44/Main.hs b/test/unit/T44/Main.hs new file mode 100644 index 0000000..d5bb8a1 --- /dev/null +++ b/test/unit/T44/Main.hs @@ -0,0 +1,8 @@ +import System.IO + +main :: IO () +main = do + putStrLn "hello" + arg <- getLine + print arg + putStrLn "goodbye" diff --git a/vscode-extension/default.nix b/vscode-extension/default.nix index 99d5f79..513c75c 100644 --- a/vscode-extension/default.nix +++ b/vscode-extension/default.nix @@ -5,10 +5,10 @@ pkgs.buildNpmPackage { version = "0.8.0"; src = ./.; - npmDepsHash = "sha256-Sp5CCtw5kC82gjWL7x7aZ48+geJ/R+LJFMw8RkqsH6c="; + npmDepsHash = "sha256-rvPlvEsFygi/EYh0vcOBDAC4Sf5nzJIfaN8HjdsVXE0="; nativeBuildInputs = [ - pkgs.nodejs pkgs.vsce pkgs.cacert pkgs.nodePackages.rimraf + pkgs.nodejs pkgs.vsce pkgs.cacert pkgs.esbuild pkgs.pkg-config ]; diff --git a/vscode-extension/package-lock.json b/vscode-extension/package-lock.json index 97d0804..f4a5a51 100644 --- a/vscode-extension/package-lock.json +++ b/vscode-extension/package-lock.json @@ -1,12 +1,12 @@ { "name": "haskell-debugger-extension", - "version": "0.1.0.0", + "version": "0.8.0", "lockfileVersion": 3, "requires": true, "packages": { "": { "name": "haskell-debugger-extension", - "version": "0.1.0", + "version": "0.8.0", "license": "MIT", "devDependencies": { "@types/glob": "^7.2.0", @@ -50,9 +50,9 @@ } }, "node_modules/@eslint-community/eslint-utils": { - "version": "4.7.0", - "resolved": "https://registry.npmjs.org/@eslint-community/eslint-utils/-/eslint-utils-4.7.0.tgz", - "integrity": "sha512-dyybb3AcajC7uha6CvhdVRJqaKyn7w2YKqKyAN37NKYgZT36w+iRb0Dymmc5qEJ549c/S31cMMSFd75bteCpCw==", + "version": "4.9.0", + "resolved": "https://registry.npmjs.org/@eslint-community/eslint-utils/-/eslint-utils-4.9.0.tgz", + "integrity": "sha512-ayVFHdtZ+hsq1t2Dy24wCmGXGe4q9Gu3smhLYALJrr473ZH27MsnSL+LKUlimp4BWJqMDMLmPpx/Q9R3OAlL4g==", "dev": true, "license": "MIT", "dependencies": { @@ -228,16 +228,16 @@ "license": "MIT" }, "node_modules/@types/semver": { - "version": "7.7.0", - "resolved": "https://registry.npmjs.org/@types/semver/-/semver-7.7.0.tgz", - "integrity": "sha512-k107IF4+Xr7UHjwDc7Cfd6PRQfbdkiRabXGRjo07b4WyPahFBZCZ1sE+BNxYIJPPg73UkfOsVOLwqVc/6ETrIA==", + "version": "7.7.1", + "resolved": "https://registry.npmjs.org/@types/semver/-/semver-7.7.1.tgz", + "integrity": "sha512-FmgJfu+MOcQ370SD0ev7EI8TlCAfKYU+B4m5T3yXc1CiRN94g/SZPtsCkk506aUDtlMnFZvasDwHHUcZUEaYuA==", "dev": true, "license": "MIT" }, "node_modules/@types/vscode": { - "version": "1.99.1", - "resolved": "https://registry.npmjs.org/@types/vscode/-/vscode-1.99.1.tgz", - "integrity": "sha512-cQlqxHZ040ta6ovZXnXRxs3fJiTmlurkIWOfZVcLSZPcm9J4ikFpXuB7gihofGn5ng+kDVma5EmJIclfk0trPQ==", + "version": "1.104.0", + "resolved": "https://registry.npmjs.org/@types/vscode/-/vscode-1.104.0.tgz", + "integrity": "sha512-0KwoU2rZ2ecsTGFxo4K1+f+AErRsYW0fsp6A0zufzGuhyczc2IoKqYqcwXidKXmy2u8YB2GsYsOtiI9Izx3Tig==", "dev": true, "license": "MIT" }, @@ -452,9 +452,9 @@ "license": "ISC" }, "node_modules/acorn": { - "version": "8.14.1", - "resolved": "https://registry.npmjs.org/acorn/-/acorn-8.14.1.tgz", - "integrity": "sha512-OvQ/2pUDKmgfCg++xsTX1wGxfTaszcHVcTctW4UJB4hibJx2HXxxO5UmVgyjMa+ZDsiaf5wWLXYpRWMmBI0QHg==", + "version": "8.15.0", + "resolved": "https://registry.npmjs.org/acorn/-/acorn-8.15.0.tgz", + "integrity": "sha512-NZyJarBfL7nWwIq+FDL6Zp/yHEhePMNnnJ0y3qfieCrmNvYct8uvtiV41UvlSe6apAfk0fY1FbWx+NwfmpvtTg==", "dev": true, "license": "MIT", "bin": { @@ -637,9 +637,9 @@ "license": "ISC" }, "node_modules/brace-expansion": { - "version": "1.1.11", - "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-1.1.11.tgz", - "integrity": "sha512-iCuPHDFgrHX7H2vEI/5xpz07zSHB00TpugqhmYtVmMO6518mCuRMoOYFldEBl0g187ufozdaHgWKcYFb61qGiA==", + "version": "1.1.12", + "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-1.1.12.tgz", + "integrity": "sha512-9T9UjW3r0UW5c1Q7GTwllptXwhvYmEzFhzMfZ9H7FQWt+uZePjZPjBP/W1ZEyZ1twGWom5/56TF4lPcqjnDHcg==", "dev": true, "license": "MIT", "dependencies": { @@ -774,26 +774,26 @@ } }, "node_modules/cheerio": { - "version": "1.0.0", - "resolved": "https://registry.npmjs.org/cheerio/-/cheerio-1.0.0.tgz", - "integrity": "sha512-quS9HgjQpdaXOvsZz82Oz7uxtXiy6UIsIQcpBj7HRw2M63Skasm9qlDocAM7jNuaxdhpPU7c4kJN+gA5MCu4ww==", + "version": "1.1.2", + "resolved": "https://registry.npmjs.org/cheerio/-/cheerio-1.1.2.tgz", + "integrity": "sha512-IkxPpb5rS/d1IiLbHMgfPuS0FgiWTtFIm/Nj+2woXDLTZ7fOT2eqzgYbdMlLweqlHbsZjxEChoVK+7iph7jyQg==", "dev": true, "license": "MIT", "dependencies": { "cheerio-select": "^2.1.0", "dom-serializer": "^2.0.0", "domhandler": "^5.0.3", - "domutils": "^3.1.0", - "encoding-sniffer": "^0.2.0", - "htmlparser2": "^9.1.0", - "parse5": "^7.1.2", - "parse5-htmlparser2-tree-adapter": "^7.0.0", + "domutils": "^3.2.2", + "encoding-sniffer": "^0.2.1", + "htmlparser2": "^10.0.0", + "parse5": "^7.3.0", + "parse5-htmlparser2-tree-adapter": "^7.1.0", "parse5-parser-stream": "^7.1.2", - "undici": "^6.19.5", + "undici": "^7.12.0", "whatwg-mimetype": "^4.0.0" }, "engines": { - "node": ">=18.17" + "node": ">=20.18.1" }, "funding": { "url": "https://github.com/cheeriojs/cheerio?sponsor=1" @@ -930,9 +930,9 @@ } }, "node_modules/css-select": { - "version": "5.1.0", - "resolved": "https://registry.npmjs.org/css-select/-/css-select-5.1.0.tgz", - "integrity": "sha512-nwoRF1rvRRnnCqqY7updORDsuqKzqYJ28+oSMaJMMgOauh3fvwHqMS7EZpIPqK8GL+g9mKxF1vP/ZjSeNjEVHg==", + "version": "5.2.2", + "resolved": "https://registry.npmjs.org/css-select/-/css-select-5.2.2.tgz", + "integrity": "sha512-TizTzUddG/xYLA3NXodFM0fSbNizXjOKhqiQQwvhlspadZokn1KDy0NZFS0wuEubIYAV5/c1/lAr0TaaFXEXzw==", "dev": true, "license": "BSD-2-Clause", "dependencies": { @@ -947,9 +947,9 @@ } }, "node_modules/css-what": { - "version": "6.1.0", - "resolved": "https://registry.npmjs.org/css-what/-/css-what-6.1.0.tgz", - "integrity": "sha512-HTUrgRJ7r4dsZKU6GjmpfRK1O76h97Z8MfS1G0FozR+oF2kG6Vfe8JE6zwrkbxigziPHinCJ+gCPjA9EaBDtRw==", + "version": "6.2.2", + "resolved": "https://registry.npmjs.org/css-what/-/css-what-6.2.2.tgz", + "integrity": "sha512-u/O3vwbptzhMs3L1fQE82ZSLHQQfto5gyZzwteVIEyeaY5Fc7R4dapF/BvRoSYFeqfBk4m0V1Vafq5Pjv25wvA==", "dev": true, "license": "BSD-2-Clause", "engines": { @@ -960,9 +960,9 @@ } }, "node_modules/debug": { - "version": "4.4.0", - "resolved": "https://registry.npmjs.org/debug/-/debug-4.4.0.tgz", - "integrity": "sha512-6WTZ/IxCY/T6BALoZHaE4ctp9xm+Z5kY/pzYaCHRFeyVhojxlrm+46y68HA6hr0TcwEssoxNiDEUJQjfPZ/RYA==", + "version": "4.4.3", + "resolved": "https://registry.npmjs.org/debug/-/debug-4.4.3.tgz", + "integrity": "sha512-RGwwWnwQvkVfavKVt22FGLw+xYSdzARwm0ru6DhTVA3umU5hZc28V3kO4stgYryrTlLpuvgI9GiijltAjNbcqA==", "dev": true, "license": "MIT", "dependencies": { @@ -1024,9 +1024,9 @@ "license": "MIT" }, "node_modules/detect-libc": { - "version": "2.0.4", - "resolved": "https://registry.npmjs.org/detect-libc/-/detect-libc-2.0.4.tgz", - "integrity": "sha512-3UDv+G9CsCKO1WKMGw9fwq/SWJYbI0c5Y7LU1AXYoDdbhE2AHQ6N6Nb34sG8Fj7T5APy8qXDCKuuIHd1BR0tVA==", + "version": "2.1.2", + "resolved": "https://registry.npmjs.org/detect-libc/-/detect-libc-2.1.2.tgz", + "integrity": "sha512-Btj2BOOO83o3WyH59e8MgXsxEQVcarkUOpEYrubB0urwnN10yQ364rsiByU11nZlqWYZm05i/of7io4mzihBtQ==", "dev": true, "license": "Apache-2.0", "engines": { @@ -1151,9 +1151,9 @@ "license": "MIT" }, "node_modules/encoding-sniffer": { - "version": "0.2.0", - "resolved": "https://registry.npmjs.org/encoding-sniffer/-/encoding-sniffer-0.2.0.tgz", - "integrity": "sha512-ju7Wq1kg04I3HtiYIOrUrdfdDvkyO9s5XM8QAj/bN61Yo/Vb4vgJxy5vi4Yxk01gWHbrofpPtpxM8bKger9jhg==", + "version": "0.2.1", + "resolved": "https://registry.npmjs.org/encoding-sniffer/-/encoding-sniffer-0.2.1.tgz", + "integrity": "sha512-5gvq20T6vfpekVtqrYQsSCFZ1wEg5+wW0/QaZMWkFr6BqD3NfKs0rLCx4rrVlSWJeZb5NBJgVLswK/w2MWU+Gw==", "dev": true, "license": "MIT", "dependencies": { @@ -1165,9 +1165,9 @@ } }, "node_modules/end-of-stream": { - "version": "1.4.4", - "resolved": "https://registry.npmjs.org/end-of-stream/-/end-of-stream-1.4.4.tgz", - "integrity": "sha512-+uw1inIHVPQoaVuHzRyXd21icM+cnt4CzD5rW+NC1wjOUSTOs+Te7FOv7AhN7vS9x/oIyhLP5PR1H+phQAHu5Q==", + "version": "1.4.5", + "resolved": "https://registry.npmjs.org/end-of-stream/-/end-of-stream-1.4.5.tgz", + "integrity": "sha512-ooEGc6HP26xXq/N+GCGOT0JKCLDGrq2bQUZrQ7gyrJiZANJ/8YDTxTpQBXGMn+WbIQXNVpyWymm7KYVICQnyOg==", "dev": true, "license": "MIT", "dependencies": { @@ -2238,9 +2238,9 @@ } }, "node_modules/htmlparser2": { - "version": "9.1.0", - "resolved": "https://registry.npmjs.org/htmlparser2/-/htmlparser2-9.1.0.tgz", - "integrity": "sha512-5zfg6mHUoaer/97TxnGpxmbR7zJtPwIYFMZ/H5ucTlPZhKvtum05yiPK3Mgai3a0DyVxv7qYqoweaEd2nrYQzQ==", + "version": "10.0.0", + "resolved": "https://registry.npmjs.org/htmlparser2/-/htmlparser2-10.0.0.tgz", + "integrity": "sha512-TwAZM+zE5Tq3lrEHvOlvwgj1XLWQCtaaibSN11Q+gGBAS7Y1uZSWwXXRe4iF6OXnaq1riyQAPFOBtYc77Mxq0g==", "dev": true, "funding": [ "https://github.com/fb55/htmlparser2?sponsor=1", @@ -2253,8 +2253,21 @@ "dependencies": { "domelementtype": "^2.3.0", "domhandler": "^5.0.3", - "domutils": "^3.1.0", - "entities": "^4.5.0" + "domutils": "^3.2.1", + "entities": "^6.0.0" + } + }, + "node_modules/htmlparser2/node_modules/entities": { + "version": "6.0.1", + "resolved": "https://registry.npmjs.org/entities/-/entities-6.0.1.tgz", + "integrity": "sha512-aN97NXWF6AWBTahfVOIrB/NShkzi5H7F9r1s9mD3cDj4Ko5f2qhhVoYMibXF7GlLveb/D2ioWay8lxI97Ven3g==", + "dev": true, + "license": "BSD-2-Clause", + "engines": { + "node": ">=0.12" + }, + "funding": { + "url": "https://github.com/fb55/entities?sponsor=1" } }, "node_modules/iconv-lite": { @@ -2899,9 +2912,9 @@ "license": "MIT" }, "node_modules/node-abi": { - "version": "3.75.0", - "resolved": "https://registry.npmjs.org/node-abi/-/node-abi-3.75.0.tgz", - "integrity": "sha512-OhYaY5sDsIka7H7AtijtI9jwGYLyl29eQn/W623DiN/MIv5sUqc4g7BIDThX+gb7di9f6xK02nkp8sdfFWZLTg==", + "version": "3.78.0", + "resolved": "https://registry.npmjs.org/node-abi/-/node-abi-3.78.0.tgz", + "integrity": "sha512-E2wEyrgX/CqvicaQYU3Ze1PFGjc4QYPGsjUrlYkqAE0WjHEZwgOsGMPMzkMse4LjJbDmaEuDX3CM036j5K2DSQ==", "dev": true, "license": "MIT", "dependencies": { @@ -3088,9 +3101,9 @@ } }, "node_modules/parse5/node_modules/entities": { - "version": "6.0.0", - "resolved": "https://registry.npmjs.org/entities/-/entities-6.0.0.tgz", - "integrity": "sha512-aKstq2TDOndCn4diEyp9Uq/Flu2i1GlLkc6XIDQSDMuaFE3OPW5OphLCyQ5SpSJZTb4reN+kTcYru5yIfXoRPw==", + "version": "6.0.1", + "resolved": "https://registry.npmjs.org/entities/-/entities-6.0.1.tgz", + "integrity": "sha512-aN97NXWF6AWBTahfVOIrB/NShkzi5H7F9r1s9mD3cDj4Ko5f2qhhVoYMibXF7GlLveb/D2ioWay8lxI97Ven3g==", "dev": true, "license": "BSD-2-Clause", "engines": { @@ -3205,9 +3218,9 @@ } }, "node_modules/pump": { - "version": "3.0.2", - "resolved": "https://registry.npmjs.org/pump/-/pump-3.0.2.tgz", - "integrity": "sha512-tUPXtzlGM8FE3P0ZL6DVs/3P58k9nk8/jZeQCurTJylQA8qFYzHFfhBJkuqyE0FifOsQ0uKWekiZ5g8wtr28cw==", + "version": "3.0.3", + "resolved": "https://registry.npmjs.org/pump/-/pump-3.0.3.tgz", + "integrity": "sha512-todwxLMY7/heScKmntwQG8CXVkWUOdYxIvY2s0VWAAMh/nd8SoYiRaKjlr7+iCs984f2P8zvrfWcDDYVb73NfA==", "dev": true, "license": "MIT", "dependencies": { @@ -3447,9 +3460,9 @@ "license": "ISC" }, "node_modules/semver": { - "version": "7.7.1", - "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.1.tgz", - "integrity": "sha512-hlq8tAfn0m/61p4BVRcPzIGr6LKiMwo4VM6dGi6pt4qcRkmNzTcWq6eCEjEh+qXjkMDvPlOFFSGwQjoEa6gyMA==", + "version": "7.7.3", + "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.3.tgz", + "integrity": "sha512-SdsKMrI9TdgjdweUSR9MweHA4EJ8YxHn8DFaDisvhVlUOe4BF1tLD7GAj0lIqWVl+dPb/rExr0Btby5loQm20Q==", "dev": true, "license": "ISC", "bin": { @@ -3690,9 +3703,9 @@ } }, "node_modules/tar-fs": { - "version": "2.1.2", - "resolved": "https://registry.npmjs.org/tar-fs/-/tar-fs-2.1.2.tgz", - "integrity": "sha512-EsaAXwxmx8UB7FRKqeozqEPop69DXcmYwTQwXvyAPF352HJsPdkVhvTaDPYqfNgruveJIJy3TA2l+2zj8LJIJA==", + "version": "2.1.4", + "resolved": "https://registry.npmjs.org/tar-fs/-/tar-fs-2.1.4.tgz", + "integrity": "sha512-mDAjwmZdh7LTT6pNleZ05Yt65HC3E+NiQzl672vQG38jIrehtJk/J3mNwIg+vShQPcLF/LV7CMnDW6vjj6sfYQ==", "dev": true, "license": "MIT", "dependencies": { @@ -3727,9 +3740,9 @@ "license": "MIT" }, "node_modules/tmp": { - "version": "0.2.3", - "resolved": "https://registry.npmjs.org/tmp/-/tmp-0.2.3.tgz", - "integrity": "sha512-nZD7m9iCPC5g0pYmcaxogYKggSfLsdxl8of3Q/oIbqCqLLIO9IAF0GWjX1z9NZRHPiXv8Wex4yDCaZsgEw0Y8w==", + "version": "0.2.5", + "resolved": "https://registry.npmjs.org/tmp/-/tmp-0.2.5.tgz", + "integrity": "sha512-voyz6MApa1rQGUxT3E+BK7/ROe8itEx7vD8/HEvt4xwXucvQ5G5oeEiHkmHZJuBO21RpOf+YYm9MOivj709jow==", "dev": true, "license": "MIT", "engines": { @@ -3862,13 +3875,13 @@ "license": "MIT" }, "node_modules/undici": { - "version": "6.21.2", - "resolved": "https://registry.npmjs.org/undici/-/undici-6.21.2.tgz", - "integrity": "sha512-uROZWze0R0itiAKVPsYhFov9LxrPMHLMEQFszeI2gCN6bnIIZ8twzBCJcN2LJrBBLfrP0t1FW0g+JmKVl8Vk1g==", + "version": "7.16.0", + "resolved": "https://registry.npmjs.org/undici/-/undici-7.16.0.tgz", + "integrity": "sha512-QEg3HPMll0o3t2ourKwOeUAZ159Kn9mx5pnzHRQO8+Wixmh88YdZRiIwat0iNzNNXn0yoEtXJqFpyW7eM8BV7g==", "dev": true, "license": "MIT", "engines": { - "node": ">=18.17" + "node": ">=20.18.1" } }, "node_modules/uri-js": {