diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,13 +1,39 @@ # Revision history for dap -## Unreleased -- YYYY-mm-dd +## 0.3.0.0 -- 2025-10-03 +### Main library changes + +* Adds support for sending a `runInTerminal` reverse request using + `sendRunInTerminalReverseRequest`. (#15) +* And adds support for receiving responses to reverse requests via the new + argument to `runDAPServerWithLogger` -- a function which receives a + `ReverseRequestResponse`. +* Make `InitializeRequestArguments` comply to the protocol (#17) + +## 0.2.0.0 -- 2025-05-05 + +### Main library changes + * `Adaptor` has an additional type parameter denoting the type of the request we are responding to. Crucially, this will be `Request` when responding to a DAP request (e.g. in `send***` functions). On the other hand, this will be `()` for the `withAdaptor` continuation argument of `registerNewDebugSession` which unlifts `Adaptor` to `IO` because, when unlifting, we are not replying to any request. + +### Merged MRs +* Create main.yml workflow by @dmjio in https://github.com/haskell-debugger/dap/pull/1 +* Remove pedantic by @dmjio in https://github.com/haskell-debugger/dap/pull/2 +* Add badge by @dmjio in https://github.com/haskell-debugger/dap/pull/3 +* Api unlock custom event by @csabahruska in https://github.com/haskell-debugger/dap/pull/4 +* Expose OutputEventCategory and fix JSON rendering by @alt-romes in https://github.com/haskell-debugger/dap/pull/8 +* Fix race conditions due to MVar usage by @alt-romes and @mpickering in https://github.com/haskell-debugger/dap/pull/5 +* Refactoring to use logging framework by @alt-romes in https://github.com/haskell-debugger/dap/pull/10 +* Allow a client to explicitly terminate the server by @alt-romes in https://github.com/haskell-debugger/dap/pull/11 +* Allow setBreakpointsArgumentsSourceModified to be null by @alt-romes in https://github.com/haskell-debugger/dap/pull/13 + +**Full Changelog**: https://github.com/haskell-debugger/dap/commits/0.2.0.0 ## 0.1.0.0 -- YYYY-mm-dd diff --git a/dap.cabal b/dap.cabal --- 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 @@ -36,7 +36,7 @@ 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, @@ -94,4 +94,4 @@ source-repository head type: git - location: git://github.com/haskell-debugger/dap.git + location: https://github.com/haskell-debugger/dap.git diff --git a/src/DAP/Adaptor.hs b/src/DAP/Adaptor.hs --- a/src/DAP/Adaptor.hs +++ b/src/DAP/Adaptor.hs @@ -26,12 +26,16 @@ , sendErrorResponse -- * Events , sendSuccesfulEvent + -- * Reverse Requests + , sendReverseRequest + , sendRunInTerminalReverseRequest -- * Server , getServerCapabilities , withConnectionLock -- * Request Arguments , getArguments , getRequestSeqNum + , getReverseRequestResponseBody -- * Debug Session , registerNewDebugSession , updateDebugSession @@ -293,6 +297,21 @@ 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 @@ -413,6 +432,25 @@ => Adaptor app Request value getArguments = do maybeArgs <- asks (args . request) + 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) +---------------------------------------------------------------------------- +-- | 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 diff --git a/src/DAP/Server.hs b/src/DAP/Server.hs --- a/src/DAP/Server.hs +++ b/src/DAP/Server.hs @@ -76,10 +76,13 @@ 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 @@ -- ^ 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 @@ 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 @@ -- 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 @@ -- '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 @@ ("\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 --- a/src/DAP/Types.hs +++ b/src/DAP/Types.hs @@ -72,6 +72,8 @@ , PathFormat (..) -- * Command , Command (..) + -- * Reverse Command + , ReverseCommand (..) -- * Event , EventType (..) -- ** Events @@ -99,13 +101,14 @@ , AdaptorState (..) , AdaptorLocal(..) , AppStore - , MonadIO(..) + , MonadIO -- * Errors , AdaptorException (..) , ErrorMessage (..) , ErrorResponse (..) -- * Request , Request (..) + , ReverseRequestResponse (..) -- * Misc. , PayloadSize , Seq @@ -121,6 +124,7 @@ , LoadedSourcesResponse (..) , ModulesResponse (..) , ReadMemoryResponse (..) + , RunInTerminalResponse (..) , ScopesResponse (..) , SetExpressionResponse (..) , SetVariableResponse (..) @@ -153,6 +157,8 @@ , RestartArguments (..) , RestartFrameArguments (..) , ReverseContinueArguments (..) + , RunInTerminalRequestArguments (..) + , RunInTerminalRequestArgumentsKind (..) , ScopesArguments (..) , SetBreakpointsArguments (..) , SetDataBreakpointsArguments (..) @@ -172,7 +178,6 @@ , ThreadsArguments (..) , VariablesArguments (..) , WriteMemoryArguments (..) - , RunInTerminalResponse (..) -- * defaults , defaultBreakpoint , defaultBreakpointLocation @@ -219,7 +224,7 @@ , 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 ) @@ -361,11 +366,36 @@ ---------------------------------------------------------------------------- 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 @@ -894,8 +924,6 @@ ---------------------------------------------------------------------------- data Command = CommandCancel - | CommandRunInTerminal - | CommandStartDebugging | CommandInitialize | CommandConfigurationDone | CommandLaunch @@ -954,6 +982,24 @@ 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 @@ -1095,6 +1141,8 @@ ---------------------------------------------------------------------------- instance ToJSON RunInTerminalResponse where toJSON = genericToJSONWithModifier +instance FromJSON RunInTerminalResponse where + parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- data ModulesResponse = ModulesResponse @@ -2688,6 +2736,9 @@ | RunInTerminalRequestArgumentsKindExternal deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- +instance ToJSON RunInTerminalRequestArgumentsKind where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- instance FromJSON RunInTerminalRequestArgumentsKind where parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- @@ -2728,6 +2779,9 @@ -- } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- +instance ToJSON RunInTerminalRequestArguments where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- instance FromJSON RunInTerminalRequestArguments where parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- @@ -2790,11 +2844,11 @@ -- ^ -- The ISO-639 locale of the client using this adapter, e.g. en-US or de-CH. -- - , linesStartAt1 :: Bool + , linesStartAt1 :: Maybe Bool -- ^ -- If true all line numbers are 1-based (default). -- - , columnsStartAt1 :: Bool + , columnsStartAt1 :: Maybe Bool -- ^ -- If true all column numbers are 1-based (default). -- @@ -2804,42 +2858,48 @@ -- is the native format. -- Values: 'path', 'uri', etc. -- - , supportsVariableType :: Bool + , supportsVariableType :: Maybe Bool -- ^ -- Client supports the `type` attribute for variables. -- - , supportsVariablePaging :: Bool + , supportsVariablePaging :: Maybe Bool -- ^ -- Client supports the paging of variables. -- - , supportsRunInTerminalRequest :: Bool + , supportsRunInTerminalRequest :: Maybe Bool -- ^ -- Client supports the `runInTerminal` request. -- - , supportsMemoryReferences :: Bool + , supportsMemoryReferences :: Maybe Bool -- ^ -- Client supports memory references. -- - , supportsProgressReporting :: Bool + , supportsProgressReporting :: Maybe Bool -- ^ -- Client supports progress reporting. -- - , supportsInvalidatedEvent :: Bool + , supportsInvalidatedEvent :: Maybe Bool -- ^ -- Client supports the `invalidated` event. -- - , supportsMemoryEvent :: Bool + , supportsMemoryEvent :: Maybe Bool -- ^ -- Client supports the `memory` event. -- - , supportsArgsCanBeInterpretedByShell :: Bool + , supportsArgsCanBeInterpretedByShell :: Maybe Bool -- ^ -- Client supports the `argsCanBeInterpretedByShell` attribute on the -- `runInTerminal` request. -- - , supportsStartDebuggingRequest :: Bool + , supportsStartDebuggingRequest :: Maybe Bool -- ^ -- Client supports the `startDebugging` request. + -- + , supportsANSIStyling :: Maybe Bool + -- ^ + -- The client will interpret ANSI escape sequences in the display of + -- `OutputEvent.output` and `Variable.value` fields when + -- `Capabilities.supportsANSIStyling` is also enabled. -- } deriving stock (Show, Eq, Generic) ----------------------------------------------------------------------------