From 967022f5e795674ba2d408160a969a1d2985f7f7 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 29 Sep 2025 10:16:23 +0100 Subject: [PATCH 1/5] Relax bounds on network --- dap.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dap.cabal b/dap.cabal index 36b206b..2d67187 100644 --- a/dap.cabal +++ b/dap.cabal @@ -36,7 +36,7 @@ library lifted-base >= 0.2.3 && < 0.3, monad-control >= 1.0.3 && < 1.1, mtl >= 2.2.2 && < 2.4, - network >= 3.1.2 && < 3.2, + network >= 3.1.2 && < 3.3, network-simple >= 0.4.5 && < 0.5, text >= 1.2.5 && < 2.2, time >= 1.11.1 && < 1.12, From 9457d408c6d837c1954b669c5e58e0b4ba5f7d7f Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 26 Sep 2025 16:48:26 +0100 Subject: [PATCH 2/5] feature: Add Reverse Requests support Exposes 'sendRunInTerminalReverseRequest' helper too. --- src/DAP/Adaptor.hs | 18 ++++++++++++++++++ src/DAP/Types.hs | 32 +++++++++++++++++++++++++++++--- 2 files changed, 47 insertions(+), 3 deletions(-) diff --git a/src/DAP/Adaptor.hs b/src/DAP/Adaptor.hs index f1f3dc7..7d46000 100644 --- a/src/DAP/Adaptor.hs +++ b/src/DAP/Adaptor.hs @@ -26,6 +26,9 @@ module DAP.Adaptor , sendErrorResponse -- * Events , sendSuccesfulEvent + -- * Reverse Requests + , sendReverseRequest + , sendRunInTerminalReverseRequest -- * Server , getServerCapabilities , withConnectionLock @@ -293,6 +296,21 @@ sendEvent action = do writeToHandle address handle payload resetAdaptorStatePayload ---------------------------------------------------------------------------- +-- | Write reverse request to Handle +sendReverseRequest + :: ReverseCommand + -> Adaptor app Request () +sendReverseRequest rcmd = send $ do + setField "type" MessageTypeRequest + setField "command" rcmd +---------------------------------------------------------------------------- +-- | Send runInTerminal reverse request +sendRunInTerminalReverseRequest :: RunInTerminalRequestArguments -> Adaptor app Request () +sendRunInTerminalReverseRequest args = do + setField "arguments" args + sendReverseRequest ReverseCommandRunInTerminal + +---------------------------------------------------------------------------- -- | Writes payload to the given 'Handle' using the local connection lock ---------------------------------------------------------------------------- writeToHandle diff --git a/src/DAP/Types.hs b/src/DAP/Types.hs index ba76da8..f4a9700 100644 --- a/src/DAP/Types.hs +++ b/src/DAP/Types.hs @@ -72,6 +72,8 @@ module DAP.Types , PathFormat (..) -- * Command , Command (..) + -- * Reverse Command + , ReverseCommand (..) -- * Event , EventType (..) -- ** Events @@ -121,6 +123,7 @@ module DAP.Types , LoadedSourcesResponse (..) , ModulesResponse (..) , ReadMemoryResponse (..) + , RunInTerminalResponse (..) , ScopesResponse (..) , SetExpressionResponse (..) , SetVariableResponse (..) @@ -153,6 +156,8 @@ module DAP.Types , RestartArguments (..) , RestartFrameArguments (..) , ReverseContinueArguments (..) + , RunInTerminalRequestArguments (..) + , RunInTerminalRequestArgumentsKind (..) , ScopesArguments (..) , SetBreakpointsArguments (..) , SetDataBreakpointsArguments (..) @@ -172,7 +177,6 @@ module DAP.Types , ThreadsArguments (..) , VariablesArguments (..) , WriteMemoryArguments (..) - , RunInTerminalResponse (..) -- * defaults , defaultBreakpoint , defaultBreakpointLocation @@ -894,8 +898,6 @@ instance ToJSON EventType where ---------------------------------------------------------------------------- data Command = CommandCancel - | CommandRunInTerminal - | CommandStartDebugging | CommandInitialize | CommandConfigurationDone | CommandLaunch @@ -954,6 +956,24 @@ instance ToJSON Command where toJSON (CustomCommand x) = toJSON x toJSON cmd = genericToJSONWithModifier cmd ---------------------------------------------------------------------------- +data ReverseCommand + = ReverseCommandRunInTerminal + | ReverseCommandStartDebugging + deriving stock (Show, Eq, Read, Generic) +---------------------------------------------------------------------------- +instance FromJSON ReverseCommand where + parseJSON = withText name $ \command -> + case readMaybe (name <> capitalize (T.unpack command)) of + Just cmd -> + pure cmd + Nothing -> + fail $ "Unknown reverse command: " ++ show command + where + name = show (typeRep (Proxy @ReverseCommand)) +---------------------------------------------------------------------------- +instance ToJSON ReverseCommand where + toJSON cmd = genericToJSONWithModifier cmd +---------------------------------------------------------------------------- data ErrorMessage = ErrorMessageCancelled | ErrorMessageNotStopped @@ -2688,6 +2708,9 @@ data RunInTerminalRequestArgumentsKind | RunInTerminalRequestArgumentsKindExternal deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- +instance ToJSON RunInTerminalRequestArgumentsKind where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- instance FromJSON RunInTerminalRequestArgumentsKind where parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- @@ -2728,6 +2751,9 @@ data RunInTerminalRequestArguments -- } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- +instance ToJSON RunInTerminalRequestArguments where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- instance FromJSON RunInTerminalRequestArguments where parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- From 9be07ef28269406c98bc37f5e65a217330a709d9 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 2 Oct 2025 11:36:51 +0100 Subject: [PATCH 3/5] Support for receiving reverse request responses Extends the entrypoint runDAPWithLogger function to accept a function which is called on `ReverseRequestResponse`s, a response to a reverse request. This allows the DAP server to e.g. capture the PID of the process invoked via `runInTerminal`. --- src/DAP/Adaptor.hs | 20 ++++++++++++++++++++ src/DAP/Server.hs | 37 +++++++++++++++++++++++++++---------- src/DAP/Types.hs | 32 ++++++++++++++++++++++++++++++-- 3 files changed, 77 insertions(+), 12 deletions(-) diff --git a/src/DAP/Adaptor.hs b/src/DAP/Adaptor.hs index 7d46000..bc2c836 100644 --- a/src/DAP/Adaptor.hs +++ b/src/DAP/Adaptor.hs @@ -35,6 +35,7 @@ module DAP.Adaptor -- * Request Arguments , getArguments , getRequestSeqNum + , getReverseRequestResponseBody -- * Debug Session , registerNewDebugSession , updateDebugSession @@ -443,6 +444,25 @@ getArguments = do logError (T.pack reason) liftIO $ throwIO (ParseException reason) ---------------------------------------------------------------------------- +-- | Attempt to parse arguments from a ReverseRequestResponse (not in env) +---------------------------------------------------------------------------- +getReverseRequestResponseBody + :: (Show value, FromJSON value) + => ReverseRequestResponse -> Adaptor app r value +getReverseRequestResponseBody resp = do + let maybeArgs = body resp + let msg = "No args found for this message" + case maybeArgs of + Nothing -> do + logError msg + liftIO $ throwIO (ExpectedArguments msg) + Just val -> + case fromJSON val of + Success r -> pure r + Error reason -> do + logError (T.pack reason) + liftIO $ throwIO (ParseException reason) +---------------------------------------------------------------------------- -- | Evaluates Adaptor action by using and updating the state in the MVar runAdaptorWith :: AdaptorLocal app request -> AdaptorState -> Adaptor app request () -> IO () runAdaptorWith lcl st (Adaptor action) = do diff --git a/src/DAP/Server.hs b/src/DAP/Server.hs index 17362e8..3aa1608 100644 --- a/src/DAP/Server.hs +++ b/src/DAP/Server.hs @@ -76,10 +76,13 @@ stdoutLogger = do data TerminateServer = TerminateServer deriving (Show, Exception) +-- | Simpler version of 'runDAPServerWithLogger'. +-- +-- If you don't need a custom logger or to observe reverse request responses. runDAPServer :: ServerConfig -> (Command -> Adaptor app Request ()) -> IO () runDAPServer config communicate = do l <- stdoutLogger - runDAPServerWithLogger (cmap renderDAPLog l) config communicate + runDAPServerWithLogger (cmap renderDAPLog l) config communicate (const (pure ())) runDAPServerWithLogger :: LogAction IO DAPLog @@ -87,8 +90,10 @@ runDAPServerWithLogger -- ^ Top-level Server configuration, global across all debug sessions -> (Command -> Adaptor app Request ()) -- ^ A function to facilitate communication between DAP clients, debug adaptors and debuggers + -> (ReverseRequestResponse -> Adaptor app () ()) + -- ^ A function to receive reverse-request-responses from DAP clients -> IO () -runDAPServerWithLogger rawLogAction serverConfig@ServerConfig {..} communicate = withSocketsDo $ do +runDAPServerWithLogger rawLogAction serverConfig@ServerConfig {..} communicate ackResp = withSocketsDo $ do let logAction = cfilter (\msg -> if debugLogging then True else severity msg /= DEBUG) rawLogAction logAction <& (mkDebugMessage $ (T.pack ("Running DAP server on " <> show port <> "..."))) appStore <- newTVarIO mempty @@ -99,7 +104,7 @@ runDAPServerWithLogger rawLogAction serverConfig@ServerConfig {..} communicate = handle <- socketToHandle socket ReadWriteMode hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF } adaptorStateMVar <- initAdaptorState logAction handle address appStore serverConfig - serviceClient communicate adaptorStateMVar + serviceClient communicate ackResp adaptorStateMVar `catch` exceptionHandler logAction handle address debugLogging mainThread server `catch` \(SomeAsyncException e) -> case fromException $ toException e of @@ -127,13 +132,20 @@ initAdaptorState logAction handle address appStore serverConfig = do -- Evaluates the current 'Request' located in the 'AdaptorState' -- Fetches, updates and recurses on the next 'Request' -- +-- Similarly, if the client responded to a reverse request then we execute the +-- acknowledge action (which, notably, is not an @'Adaptor' _ 'Request'@ +-- because there's no 'Request' to reply to) serviceClient :: (Command -> Adaptor app Request ()) + -> (ReverseRequestResponse -> Adaptor app r ()) -> AdaptorLocal app r -> IO () -serviceClient communicate lcl = forever $ runAdaptorWith lcl st $ do - nextRequest <- getRequest - withRequest nextRequest (communicate (command nextRequest)) +serviceClient communicate ackResp lcl = forever $ runAdaptorWith lcl st $ do + either_nextRequest <- getRequest + case either_nextRequest of + Right nextRequest -> + withRequest nextRequest (communicate (command nextRequest)) + Left rrr -> ackResp rrr where st = AdaptorState MessageTypeResponse [] ---------------------------------------------------------------------------- @@ -172,7 +184,7 @@ exceptionHandler logAction handle address shouldLog serverThread (e :: SomeExcep -- 'parseHeader' Attempts to parse 'Content-Length: ' -- Helper function for parsing message headers -- e.g. ("Content-Length: 11\r\n") -getRequest :: Adaptor app r Request +getRequest :: Adaptor app r (Either ReverseRequestResponse Request) getRequest = do handle <- getHandle header <- liftIO $ getHeaderHandle handle @@ -186,10 +198,15 @@ getRequest = do ("\n" <> encodePretty (decodeStrict body :: Maybe Value)) case eitherDecode (BL8.fromStrict body) of Left couldn'tDecodeBody -> do - logError (T.pack couldn'tDecodeBody) - liftIO $ throwIO (ParseException couldn'tDecodeBody) + -- As a fallback, try to parse a reverse request response + case eitherDecode (BL8.fromStrict body) of + Right rrr -> pure (Left rrr) + Left _ -> do + -- No luck, report fail to parse command: + logError (T.pack couldn'tDecodeBody) + liftIO $ throwIO (ParseException couldn'tDecodeBody) Right request -> - pure request + pure (Right request) getHeaderHandle :: Handle -> IO (Either String PayloadSize) getHeaderHandle handle = do diff --git a/src/DAP/Types.hs b/src/DAP/Types.hs index f4a9700..e611c7c 100644 --- a/src/DAP/Types.hs +++ b/src/DAP/Types.hs @@ -101,13 +101,14 @@ module DAP.Types , AdaptorState (..) , AdaptorLocal(..) , AppStore - , MonadIO(..) + , MonadIO -- * Errors , AdaptorException (..) , ErrorMessage (..) , ErrorResponse (..) -- * Request , Request (..) + , ReverseRequestResponse (..) -- * Misc. , PayloadSize , Seq @@ -223,7 +224,7 @@ import Data.Aeson ( (.:), (.:?), withObject, with , FromJSON(parseJSON), Value, KeyValue((.=)) , ToJSON(toJSON), genericParseJSON, defaultOptions ) -import Data.Aeson.Types ( Pair, typeMismatch ) +import Data.Aeson.Types ( Pair, typeMismatch, Parser ) import Data.Proxy ( Proxy(Proxy) ) import Data.String ( IsString(..) ) import Data.Time ( UTCTime ) @@ -365,11 +366,36 @@ data Request ---------------------------------------------------------------------------- instance FromJSON Request where parseJSON = withObject "Request" $ \o -> do + "request" <- (o .: "type") :: Parser String Request <$> o .:? "arguments" <*> o .: "seq" <*> o .: "command" ---------------------------------------------------------------------------- +data ReverseRequestResponse + = ReverseRequestResponse + { body :: Maybe Value + -- ^ Request arguments + -- + , reverseRequestResponseSeqNum :: Seq + -- ^ Request sequence number + -- + , reverseRequestCommand :: ReverseCommand + -- ^ Command of Request + -- + , success :: Bool + -- ^ Whether the reverse request was successful + } deriving stock (Show) +---------------------------------------------------------------------------- +instance FromJSON ReverseRequestResponse where + parseJSON = withObject "ReverseRequestResponse" $ \o -> do + "response" <- (o .: "type") :: Parser String + ReverseRequestResponse + <$> o .:? "body" + <*> o .: "seq" + <*> o .: "command" + <*> o .: "success" +---------------------------------------------------------------------------- data Breakpoint = Breakpoint { breakpointId :: Maybe Int @@ -1115,6 +1141,8 @@ data RunInTerminalResponse ---------------------------------------------------------------------------- instance ToJSON RunInTerminalResponse where toJSON = genericToJSONWithModifier +instance FromJSON RunInTerminalResponse where + parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- data ModulesResponse = ModulesResponse From 28150d80e7c87833c22f0d0695b8f118adb58c2d Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 3 Oct 2025 11:40:39 +0100 Subject: [PATCH 4/5] Update CHANGELOG for 0.3.0.0 --- CHANGELOG.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0758bde..8d884cb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for dap +## 0.3.0.0 -- 2025-10-03 + +### Main library changes + +* Adds support for sending a `runInTerminal` reverse request using + `sendRunInTerminalReverseRequest`. +* And adds support for receiving responses to reverse requests via the new + argument to `runDAPServerWithLogger` -- a function which receives a + `ReverseRequestResponse`. + ## 0.2.0.0 -- 2025-05-05 ### Main library changes From dd8a13362fcc043a5b26b2eb01b27a75885958d0 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Fri, 3 Oct 2025 11:40:58 +0100 Subject: [PATCH 5/5] Bump version to 0.3.0.0 --- dap.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dap.cabal b/dap.cabal index 2d67187..54697bd 100644 --- a/dap.cabal +++ b/dap.cabal @@ -1,5 +1,5 @@ name: dap -version: 0.2.0.0 +version: 0.3.0.0 description: A library for the Debug Adaptor Protocol (DAP) synopsis: A debug adaptor protocol library bug-reports: https://github.com/haskell-debugger/dap/issues