Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 3e5dea6

Browse files
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 (JustSENT)
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)

AltStyle によって変換されたページ (->オリジナル) /