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 diff --git a/dap.cabal b/dap.cabal index 36b206b..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 @@ -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, diff --git a/src/DAP/Adaptor.hs b/src/DAP/Adaptor.hs index f1f3dc7..bc2c836 100644 --- a/src/DAP/Adaptor.hs +++ b/src/DAP/Adaptor.hs @@ -26,12 +26,16 @@ module DAP.Adaptor , sendErrorResponse -- * Events , sendSuccesfulEvent + -- * Reverse Requests + , sendReverseRequest + , sendRunInTerminalReverseRequest -- * Server , getServerCapabilities , withConnectionLock -- * Request Arguments , getArguments , getRequestSeqNum + , getReverseRequestResponseBody -- * Debug Session , registerNewDebugSession , updateDebugSession @@ -293,6 +297,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 @@ -425,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 ba76da8..e611c7c 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 @@ -99,13 +101,14 @@ module DAP.Types , AdaptorState (..) , AdaptorLocal(..) , AppStore - , MonadIO(..) + , MonadIO -- * Errors , AdaptorException (..) , ErrorMessage (..) , ErrorResponse (..) -- * Request , Request (..) + , ReverseRequestResponse (..) -- * Misc. , PayloadSize , Seq @@ -121,6 +124,7 @@ module DAP.Types , LoadedSourcesResponse (..) , ModulesResponse (..) , ReadMemoryResponse (..) + , RunInTerminalResponse (..) , ScopesResponse (..) , SetExpressionResponse (..) , SetVariableResponse (..) @@ -153,6 +157,8 @@ module DAP.Types , RestartArguments (..) , RestartFrameArguments (..) , ReverseContinueArguments (..) + , RunInTerminalRequestArguments (..) + , RunInTerminalRequestArgumentsKind (..) , ScopesArguments (..) , SetBreakpointsArguments (..) , SetDataBreakpointsArguments (..) @@ -172,7 +178,6 @@ module DAP.Types , ThreadsArguments (..) , VariablesArguments (..) , WriteMemoryArguments (..) - , RunInTerminalResponse (..) -- * defaults , defaultBreakpoint , defaultBreakpointLocation @@ -219,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 ) @@ -361,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 @@ -894,8 +924,6 @@ instance ToJSON EventType where ---------------------------------------------------------------------------- data Command = CommandCancel - | CommandRunInTerminal - | CommandStartDebugging | CommandInitialize | CommandConfigurationDone | CommandLaunch @@ -954,6 +982,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 @@ -1095,6 +1141,8 @@ data RunInTerminalResponse ---------------------------------------------------------------------------- instance ToJSON RunInTerminalResponse where toJSON = genericToJSONWithModifier +instance FromJSON RunInTerminalResponse where + parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- data ModulesResponse = ModulesResponse @@ -2688,6 +2736,9 @@ data RunInTerminalRequestArgumentsKind | RunInTerminalRequestArgumentsKindExternal deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- +instance ToJSON RunInTerminalRequestArgumentsKind where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- instance FromJSON RunInTerminalRequestArgumentsKind where parseJSON = genericParseJSONWithModifier ---------------------------------------------------------------------------- @@ -2728,6 +2779,9 @@ data RunInTerminalRequestArguments -- } deriving stock (Show, Eq, Generic) ---------------------------------------------------------------------------- +instance ToJSON RunInTerminalRequestArguments where + toJSON = genericToJSONWithModifier +---------------------------------------------------------------------------- instance FromJSON RunInTerminalRequestArguments where parseJSON = genericParseJSONWithModifier ----------------------------------------------------------------------------