Skip to content

Commit 41558e8

Browse files
alt-romesalt-romes
authored
Merge pull request #16 from haskell-debugger/wip/romes/things-for-0.3
runInTerminal support
2 parents 3a7404e + dd8a133 commit 41558e8

File tree

5 files changed

+136
-17
lines changed

5 files changed

+136
-17
lines changed

‎CHANGELOG.md‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,15 @@
11
# Revision history for dap
22

3+
## 0.3.0.0 -- 2025-10-03
4+
5+
### Main library changes
6+
7+
* Adds support for sending a `runInTerminal` reverse request using
8+
`sendRunInTerminalReverseRequest`.
9+
* And adds support for receiving responses to reverse requests via the new
10+
argument to `runDAPServerWithLogger` -- a function which receives a
11+
`ReverseRequestResponse`.
12+
313
## 0.2.0.0 -- 2025-05-05
414

515
### Main library changes

‎dap.cabal‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: dap
2-
version: 0.2.0.0
2+
version: 0.3.0.0
33
description: A library for the Debug Adaptor Protocol (DAP)
44
synopsis: A debug adaptor protocol library
55
bug-reports: https://github.com/haskell-debugger/dap/issues
@@ -36,7 +36,7 @@ library
3636
lifted-base >= 0.2.3 && < 0.3,
3737
monad-control >= 1.0.3 && < 1.1,
3838
mtl >= 2.2.2 && < 2.4,
39-
network >= 3.1.2 && < 3.2,
39+
network >= 3.1.2 && < 3.3,
4040
network-simple >= 0.4.5 && < 0.5,
4141
text >= 1.2.5 && < 2.2,
4242
time >= 1.11.1 && < 1.12,

‎src/DAP/Adaptor.hs‎

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,12 +26,16 @@ module DAP.Adaptor
2626
, sendErrorResponse
2727
-- * Events
2828
, sendSuccesfulEvent
29+
-- * Reverse Requests
30+
, sendReverseRequest
31+
, sendRunInTerminalReverseRequest
2932
-- * Server
3033
, getServerCapabilities
3134
, withConnectionLock
3235
-- * Request Arguments
3336
, getArguments
3437
, getRequestSeqNum
38+
, getReverseRequestResponseBody
3539
-- * Debug Session
3640
, registerNewDebugSession
3741
, updateDebugSession
@@ -293,6 +297,21 @@ sendEvent action = do
293297
writeToHandle address handle payload
294298
resetAdaptorStatePayload
295299
----------------------------------------------------------------------------
300+
-- | Write reverse request to Handle
301+
sendReverseRequest
302+
:: ReverseCommand
303+
-> Adaptor app Request ()
304+
sendReverseRequest rcmd = send $ do
305+
setField "type" MessageTypeRequest
306+
setField "command" rcmd
307+
----------------------------------------------------------------------------
308+
-- | Send runInTerminal reverse request
309+
sendRunInTerminalReverseRequest :: RunInTerminalRequestArguments -> Adaptor app Request ()
310+
sendRunInTerminalReverseRequest args = do
311+
setField "arguments" args
312+
sendReverseRequest ReverseCommandRunInTerminal
313+
314+
----------------------------------------------------------------------------
296315
-- | Writes payload to the given 'Handle' using the local connection lock
297316
----------------------------------------------------------------------------
298317
writeToHandle
@@ -425,6 +444,25 @@ getArguments = do
425444
logError (T.pack reason)
426445
liftIO $ throwIO (ParseException reason)
427446
----------------------------------------------------------------------------
447+
-- | Attempt to parse arguments from a ReverseRequestResponse (not in env)
448+
----------------------------------------------------------------------------
449+
getReverseRequestResponseBody
450+
:: (Show value, FromJSON value)
451+
=> ReverseRequestResponse -> Adaptor app r value
452+
getReverseRequestResponseBody resp = do
453+
let maybeArgs = body resp
454+
let msg = "No args found for this message"
455+
case maybeArgs of
456+
Nothing -> do
457+
logError msg
458+
liftIO $ throwIO (ExpectedArguments msg)
459+
Just val ->
460+
case fromJSON val of
461+
Success r -> pure r
462+
Error reason -> do
463+
logError (T.pack reason)
464+
liftIO $ throwIO (ParseException reason)
465+
----------------------------------------------------------------------------
428466
-- | Evaluates Adaptor action by using and updating the state in the MVar
429467
runAdaptorWith :: AdaptorLocal app request -> AdaptorState -> Adaptor app request () -> IO ()
430468
runAdaptorWith lcl st (Adaptor action) = do

‎src/DAP/Server.hs‎

Lines changed: 27 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -76,19 +76,24 @@ stdoutLogger = do
7676
data TerminateServer = TerminateServer
7777
deriving (Show, Exception)
7878

79+
-- | Simpler version of 'runDAPServerWithLogger'.
80+
--
81+
-- If you don't need a custom logger or to observe reverse request responses.
7982
runDAPServer :: ServerConfig -> (Command -> Adaptor app Request ()) -> IO ()
8083
runDAPServer config communicate = do
8184
l <- stdoutLogger
82-
runDAPServerWithLogger (cmap renderDAPLog l) config communicate
85+
runDAPServerWithLogger (cmap renderDAPLog l) config communicate (const (pure ()))
8386

8487
runDAPServerWithLogger
8588
:: LogAction IO DAPLog
8689
-> ServerConfig
8790
-- ^ Top-level Server configuration, global across all debug sessions
8891
-> (Command -> Adaptor app Request ())
8992
-- ^ A function to facilitate communication between DAP clients, debug adaptors and debuggers
93+
-> (ReverseRequestResponse -> Adaptor app () ())
94+
-- ^ A function to receive reverse-request-responses from DAP clients
9095
-> IO ()
91-
runDAPServerWithLogger rawLogAction serverConfig@ServerConfig {..} communicate = withSocketsDo $ do
96+
runDAPServerWithLogger rawLogAction serverConfig@ServerConfig {..} communicate ackResp = withSocketsDo $ do
9297
let logAction = cfilter (\msg -> if debugLogging then True else severity msg /= DEBUG) rawLogAction
9398
logAction <& (mkDebugMessage $ (T.pack ("Running DAP server on " <> show port <> "...")))
9499
appStore <- newTVarIO mempty
@@ -99,7 +104,7 @@ runDAPServerWithLogger rawLogAction serverConfig@ServerConfig {..} communicate =
99104
handle <- socketToHandle socket ReadWriteMode
100105
hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF }
101106
adaptorStateMVar <- initAdaptorState logAction handle address appStore serverConfig
102-
serviceClient communicate adaptorStateMVar
107+
serviceClient communicate ackResp adaptorStateMVar
103108
`catch` exceptionHandler logAction handle address debugLogging mainThread
104109
server `catch` \(SomeAsyncException e) ->
105110
case fromException $ toException e of
@@ -127,13 +132,20 @@ initAdaptorState logAction handle address appStore serverConfig = do
127132
-- Evaluates the current 'Request' located in the 'AdaptorState'
128133
-- Fetches, updates and recurses on the next 'Request'
129134
--
135+
-- Similarly, if the client responded to a reverse request then we execute the
136+
-- acknowledge action (which, notably, is not an @'Adaptor' _ 'Request'@
137+
-- because there's no 'Request' to reply to)
130138
serviceClient
131139
:: (Command -> Adaptor app Request ())
140+
-> (ReverseRequestResponse -> Adaptor app r ())
132141
-> AdaptorLocal app r
133142
-> IO ()
134-
serviceClient communicate lcl = forever $ runAdaptorWith lcl st $ do
135-
nextRequest <- getRequest
136-
withRequest nextRequest (communicate (command nextRequest))
143+
serviceClient communicate ackResp lcl = forever $ runAdaptorWith lcl st $ do
144+
either_nextRequest <- getRequest
145+
case either_nextRequest of
146+
Right nextRequest ->
147+
withRequest nextRequest (communicate (command nextRequest))
148+
Left rrr -> ackResp rrr
137149
where
138150
st = AdaptorState MessageTypeResponse []
139151
----------------------------------------------------------------------------
@@ -172,7 +184,7 @@ exceptionHandler logAction handle address shouldLog serverThread (e :: SomeExcep
172184
-- 'parseHeader' Attempts to parse 'Content-Length: <byte-count>'
173185
-- Helper function for parsing message headers
174186
-- e.g. ("Content-Length: 11\r\n")
175-
getRequest :: Adaptor app r Request
187+
getRequest :: Adaptor app r (Either ReverseRequestResponse Request)
176188
getRequest = do
177189
handle <- getHandle
178190
header <- liftIO $ getHeaderHandle handle
@@ -186,10 +198,15 @@ getRequest = do
186198
("\n" <> encodePretty (decodeStrict body :: Maybe Value))
187199
case eitherDecode (BL8.fromStrict body) of
188200
Left couldn'tDecodeBody -> do
189-
logError (T.pack couldn'tDecodeBody)
190-
liftIO $ throwIO (ParseException couldn'tDecodeBody)
201+
-- As a fallback, try to parse a reverse request response
202+
case eitherDecode (BL8.fromStrict body) of
203+
Right rrr -> pure (Left rrr)
204+
Left _ -> do
205+
-- No luck, report fail to parse command:
206+
logError (T.pack couldn'tDecodeBody)
207+
liftIO $ throwIO (ParseException couldn'tDecodeBody)
191208
Right request ->
192-
pure request
209+
pure (Right request)
193210

194211
getHeaderHandle :: Handle -> IO (Either String PayloadSize)
195212
getHeaderHandle handle = do

‎src/DAP/Types.hs‎

Lines changed: 59 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -72,6 +72,8 @@ module DAP.Types
7272
, PathFormat (..)
7373
-- * Command
7474
, Command (..)
75+
-- * Reverse Command
76+
, ReverseCommand (..)
7577
-- * Event
7678
, EventType (..)
7779
-- ** Events
@@ -99,13 +101,14 @@ module DAP.Types
99101
, AdaptorState (..)
100102
, AdaptorLocal(..)
101103
, AppStore
102-
, MonadIO(..)
104+
, MonadIO
103105
-- * Errors
104106
, AdaptorException (..)
105107
, ErrorMessage (..)
106108
, ErrorResponse (..)
107109
-- * Request
108110
, Request (..)
111+
, ReverseRequestResponse (..)
109112
-- * Misc.
110113
, PayloadSize
111114
, Seq
@@ -121,6 +124,7 @@ module DAP.Types
121124
, LoadedSourcesResponse (..)
122125
, ModulesResponse (..)
123126
, ReadMemoryResponse (..)
127+
, RunInTerminalResponse (..)
124128
, ScopesResponse (..)
125129
, SetExpressionResponse (..)
126130
, SetVariableResponse (..)
@@ -153,6 +157,8 @@ module DAP.Types
153157
, RestartArguments (..)
154158
, RestartFrameArguments (..)
155159
, ReverseContinueArguments (..)
160+
, RunInTerminalRequestArguments (..)
161+
, RunInTerminalRequestArgumentsKind (..)
156162
, ScopesArguments (..)
157163
, SetBreakpointsArguments (..)
158164
, SetDataBreakpointsArguments (..)
@@ -172,7 +178,6 @@ module DAP.Types
172178
, ThreadsArguments (..)
173179
, VariablesArguments (..)
174180
, WriteMemoryArguments (..)
175-
, RunInTerminalResponse (..)
176181
-- * defaults
177182
, defaultBreakpoint
178183
, defaultBreakpointLocation
@@ -219,7 +224,7 @@ import Data.Aeson ( (.:), (.:?), withObject, with
219224
, FromJSON(parseJSON), Value, KeyValue((.=))
220225
, ToJSON(toJSON), genericParseJSON, defaultOptions
221226
)
222-
import Data.Aeson.Types ( Pair, typeMismatch )
227+
import Data.Aeson.Types ( Pair, typeMismatch, Parser )
223228
import Data.Proxy ( Proxy(Proxy) )
224229
import Data.String ( IsString(..) )
225230
import Data.Time ( UTCTime )
@@ -361,11 +366,36 @@ data Request
361366
----------------------------------------------------------------------------
362367
instance FromJSON Request where
363368
parseJSON = withObject "Request" $ \o -> do
369+
"request" <- (o .: "type") :: Parser String
364370
Request
365371
<$> o .:? "arguments"
366372
<*> o .: "seq"
367373
<*> o .: "command"
368374
----------------------------------------------------------------------------
375+
data ReverseRequestResponse
376+
= ReverseRequestResponse
377+
{ body :: Maybe Value
378+
-- ^ Request arguments
379+
--
380+
, reverseRequestResponseSeqNum :: Seq
381+
-- ^ Request sequence number
382+
--
383+
, reverseRequestCommand :: ReverseCommand
384+
-- ^ Command of Request
385+
--
386+
, success :: Bool
387+
-- ^ Whether the reverse request was successful
388+
} deriving stock (Show)
389+
----------------------------------------------------------------------------
390+
instance FromJSON ReverseRequestResponse where
391+
parseJSON = withObject "ReverseRequestResponse" $ \o -> do
392+
"response" <- (o .: "type") :: Parser String
393+
ReverseRequestResponse
394+
<$> o .:? "body"
395+
<*> o .: "seq"
396+
<*> o .: "command"
397+
<*> o .: "success"
398+
----------------------------------------------------------------------------
369399
data Breakpoint
370400
= Breakpoint
371401
{ breakpointId :: Maybe Int
@@ -894,8 +924,6 @@ instance ToJSON EventType where
894924
----------------------------------------------------------------------------
895925
data Command
896926
= CommandCancel
897-
| CommandRunInTerminal
898-
| CommandStartDebugging
899927
| CommandInitialize
900928
| CommandConfigurationDone
901929
| CommandLaunch
@@ -954,6 +982,24 @@ instance ToJSON Command where
954982
toJSON (CustomCommand x) = toJSON x
955983
toJSON cmd = genericToJSONWithModifier cmd
956984
----------------------------------------------------------------------------
985+
data ReverseCommand
986+
= ReverseCommandRunInTerminal
987+
| ReverseCommandStartDebugging
988+
deriving stock (Show, Eq, Read, Generic)
989+
----------------------------------------------------------------------------
990+
instance FromJSON ReverseCommand where
991+
parseJSON = withText name $ \command ->
992+
case readMaybe (name <> capitalize (T.unpack command)) of
993+
Just cmd ->
994+
pure cmd
995+
Nothing ->
996+
fail $ "Unknown reverse command: " ++ show command
997+
where
998+
name = show (typeRep (Proxy @ReverseCommand))
999+
----------------------------------------------------------------------------
1000+
instance ToJSON ReverseCommand where
1001+
toJSON cmd = genericToJSONWithModifier cmd
1002+
----------------------------------------------------------------------------
9571003
data ErrorMessage
9581004
= ErrorMessageCancelled
9591005
| ErrorMessageNotStopped
@@ -1095,6 +1141,8 @@ data RunInTerminalResponse
10951141
----------------------------------------------------------------------------
10961142
instance ToJSON RunInTerminalResponse where
10971143
toJSON = genericToJSONWithModifier
1144+
instance FromJSON RunInTerminalResponse where
1145+
parseJSON = genericParseJSONWithModifier
10981146
----------------------------------------------------------------------------
10991147
data ModulesResponse
11001148
= ModulesResponse
@@ -2688,6 +2736,9 @@ data RunInTerminalRequestArgumentsKind
26882736
| RunInTerminalRequestArgumentsKindExternal
26892737
deriving stock (Show, Eq, Generic)
26902738
----------------------------------------------------------------------------
2739+
instance ToJSON RunInTerminalRequestArgumentsKind where
2740+
toJSON = genericToJSONWithModifier
2741+
----------------------------------------------------------------------------
26912742
instance FromJSON RunInTerminalRequestArgumentsKind where
26922743
parseJSON = genericParseJSONWithModifier
26932744
----------------------------------------------------------------------------
@@ -2728,6 +2779,9 @@ data RunInTerminalRequestArguments
27282779
--
27292780
} deriving stock (Show, Eq, Generic)
27302781
----------------------------------------------------------------------------
2782+
instance ToJSON RunInTerminalRequestArguments where
2783+
toJSON = genericToJSONWithModifier
2784+
----------------------------------------------------------------------------
27312785
instance FromJSON RunInTerminalRequestArguments where
27322786
parseJSON = genericParseJSONWithModifier
27332787
----------------------------------------------------------------------------

0 commit comments

Comments
 (0)