dap 0.2.0.0 → 0.3.0.0

raw patch · 5 files changed

+171/−30 lines, 5 filesdep ~networknew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: network

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−1
• dap.cabal +3/−3
• src/DAP/Adaptor.hs +38/−0
• src/DAP/Server.hs +27/−10
• src/DAP/Types.hs +76/−16

@@ -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 

@@ -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

@@ -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

@@ -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: <byte-count>' -- 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

@@ -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) ----------------------------------------------------------------------------