Skip to content

Commit 3e5dea6

Browse files
dmjiodmjio
authored
Added black box integration tests for DAP server. (#7)
- Created a test-suite executable that mocks client / server communication. This is basically an implementation of vscode-mock-debug, except without a mock runtime. - Removed 'seqRef'. Client / server communication (seems to be) always synchronous, events (seem to) not account for 'seqNum', and only a single response is permitted per request. Therefore, we can always use the 'seqNum' on the request in the response, incremented by one. - Fixed a bug where the 'requestSeqNum' was being used as the 'seqNum'. - Made all printing subject to a logging 'Bool' value. This ensures that test output is not interleaved with server output (since the tests run the server in a forked thread), but set 'debugLogging' to 'False'. - Added a helper function 'readPayload' for use in tests. - Re-added 'resetAdaptorStatePayload'. This is necessary for the new OutputEvent sink, otherwise it might send extra JSON from the parent thread it was forked from. - Added some tests for sequence numbers, events and some client connection load testing.
1 parent f400d44 commit 3e5dea6

File tree

6 files changed

+267
-50
lines changed

6 files changed

+267
-50
lines changed

‎dap/.ghci

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,2 +1,2 @@
1-
:set -isrc:exe
1+
:set -isrc:exe:test
22
:set -XOverloadedStrings

‎dap/dap.cabal

Lines changed: 39 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ cabal-version: >= 1.10
1616
extra-source-files:
1717
CHANGELOG.md
1818

19-
executable dap
19+
executable dap-estg
2020
main-is:
2121
Main.hs
2222
ghc-options:
@@ -78,3 +78,41 @@ library
7878
src
7979
default-language:
8080
Haskell2010
81+
82+
test-suite tests
83+
type:
84+
exitcode-stdio-1.0
85+
hs-source-dirs:
86+
test, src
87+
main-is:
88+
Main.hs
89+
other-modules:
90+
DAP.Response
91+
DAP.Internal
92+
DAP.Server
93+
DAP.Adaptor
94+
DAP.Server
95+
DAP.Types
96+
DAP.Event
97+
DAP.Utils
98+
build-depends:
99+
aeson
100+
, aeson-pretty
101+
, async
102+
, base < 5
103+
, bytestring
104+
, containers
105+
, lifted-base
106+
, monad-control
107+
, hspec
108+
, mtl
109+
, network
110+
, network-simple
111+
, stm
112+
, string-conversions
113+
, text
114+
, time
115+
, transformers-base
116+
, unordered-containers
117+
default-language:
118+
Haskell2010

‎dap/src/DAP/Adaptor.hs

Lines changed: 4 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -152,11 +152,6 @@ getAddress = gets address
152152
getHandle :: Adaptor app Handle
153153
getHandle = gets handle
154154
----------------------------------------------------------------------------
155-
getNextSeqNum :: Adaptor app Seq
156-
getNextSeqNum = do
157-
modify' $ \s -> s { seqRef = seqRef s + 1 }
158-
gets seqRef
159-
----------------------------------------------------------------------------
160155
getRequestSeqNum :: Adaptor app Seq
161156
getRequestSeqNum = gets (requestSeqNum . request)
162157
----------------------------------------------------------------------------
@@ -188,8 +183,8 @@ registerNewDebugSession k v debuggerExecution outputEventSink = do
188183
store <- gets appStore
189184
debuggerThreadState <-
190185
DebuggerThreadState
191-
<$> fork (debuggerExecution)
192-
<*> fork (outputEventSink)
186+
<$> fork (resetAdaptorStatePayload >> debuggerExecution)
187+
<*> fork (resetAdaptorStatePayload >> outputEventSink)
193188
liftIO . atomically $ modifyTVar' store (H.insert k (debuggerThreadState, v))
194189
setDebugSessionId k
195190
logInfo $ BL8.pack $ "Registered new debug session: " <> unpack k
@@ -205,7 +200,6 @@ getDebugSessionWithThreadIdAndSessionId = do
205200
appStore <- liftIO . readTVarIO =<< getAppStore
206201
case H.lookup sessionId appStore of
207202
Nothing -> do
208-
-- appNotFound sessionId
209203
sendError (ErrorMessage (pack "")) Nothing
210204
Just (tid, app) ->
211205
pure (sessionId, tid, app)
@@ -258,9 +252,9 @@ send action = do
258252
cmd <- getCommand
259253
handle <- getHandle
260254
messageType <- gets messageType
261-
seqNum <- getNextSeqNum
262255
address <- getAddress
263256
requestSeqNum <- getRequestSeqNum
257+
let seqNum = requestSeqNum + 1
264258

265259
-- Additional fields are required to be set for 'response' or 'reverse_request' messages.
266260
when (messageType == MessageTypeResponse) (setField "request_seq" requestSeqNum)
@@ -269,7 +263,7 @@ send action = do
269263
-- "seq" and "type" must be set for all protocol messages
270264
setField "type" messageType
271265
unless (messageType == MessageTypeEvent) $
272-
setField "seq" requestSeqNum
266+
setField "seq" seqNum
273267

274268
-- Once all fields are set, fetch the payload for sending
275269
payload <- object <$> gets payload

‎dap/src/DAP/Server.hs

Lines changed: 39 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@
1919
----------------------------------------------------------------------------
2020
module DAP.Server
2121
( runDAPServer
22+
, readPayload
2223
) where
2324
----------------------------------------------------------------------------
2425
import Control.Concurrent.MVar ( MVar )
@@ -34,7 +35,7 @@ import Control.Exception ( SomeException
3435
import Control.Monad ( forever, void )
3536
import Control.Monad.State ( evalStateT, runStateT, execStateT )
3637
import DAP.Internal ( withGlobalLock )
37-
import Data.Aeson ( decodeStrict, eitherDecode, Value )
38+
import Data.Aeson ( decodeStrict, eitherDecode, Value, FromJSON )
3839
import Data.Aeson.Encode.Pretty ( encodePretty )
3940
import Data.ByteString ( ByteString )
4041
import Data.Char ( isDigit )
@@ -60,15 +61,17 @@ runDAPServer
6061
-- ^ A function to facilitate communication between DAP clients, debug adaptors and debuggers
6162
-> IO ()
6263
runDAPServer serverConfig@ServerConfig {..} communicate = withSocketsDo $ do
63-
putStrLn ("Running DAP server on " <> show port <> "...")
64+
when debugLogging $ putStrLn ("Running DAP server on " <> show port <> "...")
6465
appStore <- newTVarIO mempty
6566
serve (Host host) (show port) $ \(socket, address) -> do
66-
withGlobalLock (putStrLn $ "TCP connection established from " ++ show address)
67+
when debugLogging $ do
68+
withGlobalLock $ do
69+
putStrLn $ "TCP connection established from " ++ show address
6770
handle <- socketToHandle socket ReadWriteMode
68-
hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF }
71+
hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF }
6972
request <- getRequest handle address serverConfig
7073
adaptorState <- initAdaptorState handle address appStore serverConfig request
71-
serviceClient communicate adaptorState `catch` exceptionHandler handle address
74+
serviceClient communicate adaptorState `catch` exceptionHandler handle address debugLogging
7275

7376
-- | Initializes the Adaptor
7477
--
@@ -81,7 +84,6 @@ initAdaptorState
8184
-> IO (AdaptorState app)
8285
initAdaptorState handle address appStore serverConfig request = do
8386
handleLock <- newMVar ()
84-
seqRef <- pure 0
8587
variablesMap <- pure mempty
8688
sourceReferencesMap <- pure mempty
8789
sessionId <- pure Nothing
@@ -95,17 +97,6 @@ initAdaptorState handle address appStore serverConfig request = do
9597
, ..
9698
}
9799
----------------------------------------------------------------------------
98-
-- | Updates sequence number, puts the new request into the AdaptorState
99-
--
100-
updateAdaptorState
101-
:: AdaptorState app
102-
-> Request
103-
-> AdaptorState app
104-
updateAdaptorState state request = do
105-
state { request = request
106-
, seqRef = requestSeqNum request
107-
}
108-
----------------------------------------------------------------------------
109100
-- | Communication loop between editor and adaptor
110101
-- Evaluates the current 'Request' located in the 'AdaptorState'
111102
-- Fetches, updates and recurses on the next 'Request'
@@ -117,7 +108,7 @@ serviceClient
117108
serviceClient communicate adaptorState@AdaptorState { address, handle, serverConfig, request } = do
118109
nextState <- runAdaptor adaptorState $ communicate (command request)
119110
nextRequest <- getRequest handle address serverConfig
120-
serviceClient communicate (updateAdaptorState nextState nextRequest)
111+
serviceClient communicate nextState { request = nextRequest }
121112
where
122113
----------------------------------------------------------------------------
123114
-- | Utility for evaluating a monad transformer stack
@@ -130,23 +121,24 @@ serviceClient communicate adaptorState@AdaptorState { address, handle, serverCon
130121

131122
----------------------------------------------------------------------------
132123
-- | Handle exceptions from client threads, parse and log accordingly
133-
exceptionHandler :: Handle -> SockAddr -> SomeException -> IO ()
134-
exceptionHandler handle address (e :: SomeException) = do
124+
exceptionHandler :: Handle -> SockAddr -> Bool -> SomeException -> IO ()
125+
exceptionHandler handle address shouldLog (e :: SomeException) = do
135126
let
136127
dumpError
137128
| Just (ParseException msg) <- fromException e
138129
= logger ERROR address Nothing
139130
$ withBraces
140131
$ BL8.pack ("Parse Exception encountered: " <> msg)
141132
| Just (err :: IOException) <- fromException e, isEOFError err
142-
= logger ERROR address Nothing
143-
$ withBraces "Empty payload received"
133+
= logger INFO address (Just SENT)
134+
$ withBraces "Client has ended its connection"
144135
| otherwise
145136
= logger ERROR address Nothing
146137
$ withBraces
147138
$ BL8.pack ("Unknown Exception: " <> show e)
148-
dumpError
149-
logger ERROR address Nothing (withBraces "Closing Connection")
139+
when shouldLog $ do
140+
dumpError
141+
logger INFO address (Just SENT) (withBraces "Closing Connection")
150142
hClose handle
151143
----------------------------------------------------------------------------
152144
-- | Internal function for parsing a 'ProtocolMessage' header
@@ -174,14 +166,26 @@ getRequest handle addr ServerConfig {..} = do
174166
throwIO (ParseException couldn'tDecodeBody)
175167
Right request ->
176168
pure request
177-
where
178-
----------------------------------------------------------------------------
179-
-- | Parses the HeaderPart of all ProtocolMessages
180-
parseHeader :: ByteString -> IO (Either String PayloadSize)
181-
parseHeader bytes = do
182-
let byteSize = BS.takeWhile isDigit (BS.drop (BS.length "Content-Length: ") bytes)
183-
case readMaybe (BS.unpack byteSize) of
184-
Just contentLength ->
185-
pure (Right contentLength)
186-
Nothing ->
187-
pure $ Left ("Invalid payload: " <> BS.unpack bytes)
169+
----------------------------------------------------------------------------
170+
-- | Parses the HeaderPart of all ProtocolMessages
171+
parseHeader :: ByteString -> IO (Either String PayloadSize)
172+
parseHeader bytes = do
173+
let byteSize = BS.takeWhile isDigit (BS.drop (BS.length "Content-Length: ") bytes)
174+
case readMaybe (BS.unpack byteSize) of
175+
Just contentLength ->
176+
pure (Right contentLength)
177+
Nothing ->
178+
pure $ Left ("Invalid payload: " <> BS.unpack bytes)
179+
180+
-- | Helper function to parse a 'ProtocolMessage', extracting it's body.
181+
-- used for testing.
182+
--
183+
readPayload :: FromJSON json => Handle -> IO (Either String json)
184+
readPayload handle = do
185+
headerBytes <- BS.hGetLine handle
186+
void (BS.hGetLine handle)
187+
parseHeader headerBytes >>= \case
188+
Left e -> pure (Left e)
189+
Right count -> do
190+
body <- BS.hGet handle count
191+
pure $ eitherDecode (BL8.fromStrict body)

‎dap/src/DAP/Types.hs

Lines changed: 0 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -282,9 +282,6 @@ data AdaptorState app
282282
-- ^ Configuration information for the ServerConfig
283283
-- Identical across all debugging sessions
284284
--
285-
, seqRef :: !Seq
286-
-- ^ Thread local sequence number, updating as responses and events are set
287-
--
288285
, handle :: Handle
289286
-- ^ Connection Handle
290287
--

0 commit comments

Comments
 (0)