Make sure sendError sends ErrorResponse when serviceClient

`sendError` should throw an error which interrupts the request/response
cycle with an `ErrorResponse`.

However, the deadlock fix in 813e665
introduced a bug where we no longer ever send an ErrorResponse when
`sendError`, just crashing the client-connection thread with an `error`
instead.

There are two main situations in which we want to run an `Adaptor s r a`:

- When `r == ()`, when unlifting `Adaptor` for the threads registered in `registerNewDebugSession`
- When `r == Request`, which means we're responding to a `Request`.

In the former case, there's no well-defined meaning for the `sendError`
thrown error, since we're not responding to any `Request` -- so we just
`error` on those uncaught errors. OK.

In the latter case, there IS a well-defined meaning for the `sendError`
errors: reply with an `ErrorResponse` to the client.

Fixes #27

Author: alt-romes

src/DAP/Adaptor.hs

@@ -55,8 +55,8 @@ module DAP.Adaptor
   , sendRaw
   -- * Internal function used to execute actions on behalf of the DAP server
   -- from child threads (useful for handling asynchronous debugger events).
-  , runAdaptorWith
-  , runAdaptor
+  , runAdaptorPoly
+  , runAdaptorRequest
   , withRequest
   , getHandle
   ) where
@@ -178,7 +178,7 @@ registerNewDebugSession k v debuggerConcurrentActions = do
   let emptyState = AdaptorState MessageTypeEvent []
   debuggerThreadState <- liftIO $
     DebuggerThreadState
-      <$> sequence [fork $ action (runAdaptorWith lcl' emptyState) | action <- debuggerConcurrentActions]
+      <$> sequence [fork $ action (runAdaptorPoly lcl' emptyState) | action <- debuggerConcurrentActions]
   liftIO . atomically $ modifyTVar' store (H.insert k (debuggerThreadState, v))
   logInfo $ T.pack $ "Registered new debug session: " <> unpack k
   setDebugSessionId k
@@ -463,24 +463,29 @@ getReverseRequestResponseBody resp = 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
+-- | Run an Adaptor for any parametric 'request' (i.e. this function can be
+-- used regardless in a non-Request scenario).
+runAdaptorPoly :: AdaptorLocal app request -> AdaptorState -> Adaptor app request a -> IO a
+runAdaptorPoly lcl st (Adaptor action) = do
   (es,final_st) <- runStateT (runReaderT (runExceptT action) lcl) st
   case es of
     Left err -> error ("runAdaptorWith, unhandled exception:" <> show err)
-    Right () -> case final_st of
+    Right x -> case final_st of
       AdaptorState _ p ->
         if null p
-          then return ()
+          then return x
           else error $ "runAdaptorWith, unexpected payload:" <> show p
 ----------------------------------------------------------------------------
--- | Utility for evaluating a monad transformer stack
-runAdaptor :: AdaptorLocal app Request -> AdaptorState -> Adaptor app Request () -> IO ()
-runAdaptor lcl s (Adaptor client) =
+-- | Run an Adaptor in the context of replying to a 'Request' (notably, this
+-- should be used to run the Adaptor servicing the client ('serviceClient')).
+--
+-- When 'sendError' is used to throw an error in the Adaptor, we cancel the
+-- current pending request with an 'ErrorResponse'.
+runAdaptorRequest :: AdaptorLocal app Request -> AdaptorState -> Adaptor app Request () -> IO ()
+runAdaptorRequest lcl s (Adaptor client) =
   runStateT (runReaderT (runExceptT client) lcl) s >>= \case
     (Left (errorMessage, maybeMessage), s') ->
-      runAdaptor lcl s' (sendErrorResponse errorMessage maybeMessage)
+      runAdaptorRequest lcl s' (sendErrorResponse errorMessage maybeMessage)
     (Right (), _) -> pure ()
 ----------------------------------------------------------------------------
 

src/DAP/Server.hs

@@ -24,7 +24,7 @@ module DAP.Server
   , TerminateServer(..)
   ) where
 ----------------------------------------------------------------------------
-import           Control.Monad              ( when, forever )
+import           Control.Monad              ( when )
 import           Control.Concurrent         ( ThreadId, myThreadId, throwTo )
 import           Control.Concurrent.MVar    ( newMVar )
 import           Control.Concurrent.STM     ( newTVarIO )
@@ -137,15 +137,19 @@ initAdaptorState logAction handle address appStore serverConfig = do
 -- because there's no 'Request' to reply to)
 serviceClient
   :: (Command -> Adaptor app Request ())
-  -> (ReverseRequestResponse -> Adaptor app r ())
-  -> AdaptorLocal app r
+  -> (ReverseRequestResponse -> Adaptor app () ())
+  -> AdaptorLocal app ()
   -> IO ()
-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
+serviceClient communicate ackResp lcl = do
+  rrr_or_nextRequest <- runAdaptorPoly lcl st getRequest
+  case rrr_or_nextRequest of
+    Right nextRequest -> do
+      let lcl' = lcl{ request = nextRequest }
+      runAdaptorRequest lcl' st $
+        communicate (command nextRequest)
+    Left rrr ->
+      runAdaptorPoly lcl st $ ackResp rrr
+  serviceClient communicate ackResp lcl
   where
     st = AdaptorState MessageTypeResponse []
 ----------------------------------------------------------------------------