runInTerminal support

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

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,

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

src/DAP/Server.hs

@@ -76,19 +76,24 @@ 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
   -> ServerConfig
   -- ^ 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: <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 @@ 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

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