dap 0.1.0.0 → 0.2.0.0

raw patch · 12 files changed

+440/−309 lines, 12 filesdep +co-log-coredep ~aesondep ~bytestringdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: co-log-core

Dependency ranges changed: aeson, bytestring, mtl, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• dap.cabal +13/−10
• src/DAP.hs +3/−1
• src/DAP/Adaptor.hs +146/−106
• src/DAP/Event.hs +17/−17
• src/DAP/Internal.hs +1/−16
• src/DAP/Log.hs +46/−0
• src/DAP/Response.hs +43/−43
• src/DAP/Server.hs +117/−77
• src/DAP/Types.hs +42/−37
• src/DAP/Utils.hs +2/−1
• test/Main.hs +1/−1

@@ -1,5 +1,14 @@ # Revision history for dap +## Unreleased -- YYYY-mm-dd++* `Adaptor` has an additional type parameter denoting the type of the request+    we are responding to. Crucially, this will be `Request` when responding to a+    DAP request (e.g. in `send***` functions).+    On the other hand, this will be `()` for the `withAdaptor` continuation+    argument of `registerNewDebugSession` which unlifts `Adaptor` to `IO`+    because, when unlifting, we are not replying to any request.+ ## 0.1.0.0 -- YYYY-mm-dd  * First version. Released on an unsuspecting world.

@@ -1,13 +1,13 @@ name:               dap-version:            0.1.0.0+version:            0.2.0.0 description:        A library for the Debug Adaptor Protocol (DAP) synopsis:           A debug adaptor protocol library-bug-reports:        https://github.com/dap/issues+bug-reports:        https://github.com/haskell-debugger/dap/issues license:            BSD3 license-file:       LICENSE author:             David Johnson, Csaba Hruska-maintainer:         djohnson.m@gmail.com-copyright:          (c) 2023 David Johnson+maintainer:         code@dmj.io+copyright:          (c) 2025 David Johnson category:           Debuggers, Language build-type:         Simple tested-with:        GHC==9.2.7@@ -19,7 +19,6 @@ library   exposed-modules:     DAP-  other-modules:     DAP.Adaptor     DAP.Event     DAP.Internal@@ -27,22 +26,24 @@     DAP.Server     DAP.Types     DAP.Utils+    DAP.Log   build-depends:-    aeson                >= 2.0.3  && < 2.1,+    aeson                >= 2.0.3  && < 2.3,     aeson-pretty         >= 0.8.9  && < 0.9,     base                 < 5,-    bytestring           >= 0.11.4 && < 0.12,+    bytestring           >= 0.11.4 && < 0.13,     containers           >= 0.6.5  && < 0.7,     lifted-base          >= 0.2.3  && < 0.3,     monad-control        >= 1.0.3  && < 1.1,-    mtl                  >= 2.2.2  && < 2.3,+    mtl                  >= 2.2.2  && < 2.4,     network              >= 3.1.2  && < 3.2,     network-simple       >= 0.4.5  && < 0.5,-    text                 >= 1.2.5  && < 1.3,+    text                 >= 1.2.5  && < 2.2,     time                 >= 1.11.1 && < 1.12,     unordered-containers >= 0.2.19 && < 0.3,     stm                  >= 2.5.0  && < 2.6,-    transformers-base    >= 0.4.6  && < 0.5+    transformers-base    >= 0.4.6  && < 0.5,+    co-log-core          >= 0.3    && < 0.4   ghc-options:     -Wall   hs-source-dirs:@@ -67,6 +68,7 @@     DAP.Types     DAP.Event     DAP.Utils+    DAP.Log   build-depends:       aeson     , aeson-pretty@@ -86,6 +88,7 @@     , time     , transformers-base     , unordered-containers+    , co-log-core   default-language:     Haskell2010 

@@ -1,3 +1,4 @@+---------------------------------------------------------------------------- module DAP   ( module DAP.Adaptor   , module DAP.Event@@ -6,10 +7,11 @@   , module DAP.Server   , module DAP.Types   ) where-+---------------------------------------------------------------------------- import DAP.Adaptor import DAP.Event import DAP.Internal import DAP.Response import DAP.Server import DAP.Types+----------------------------------------------------------------------------

@@ -6,6 +6,7 @@ -- Stability   :  experimental -- Portability :  non-portable ----------------------------------------------------------------------------+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies         #-} {-# LANGUAGE OverloadedStrings          #-}@@ -13,6 +14,7 @@ {-# LANGUAGE DeriveAnyClass             #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-} ---------------------------------------------------------------------------- module DAP.Adaptor   ( -- * Message Construction@@ -50,87 +52,88 @@   -- * Internal function used to execute actions on behalf of the DAP server   -- from child threads (useful for handling asynchronous debugger events).   , runAdaptorWith+  , runAdaptor+  , withRequest+  , getHandle   ) where -----------------------------------------------------------------------------import           Control.Concurrent.MVar    ( modifyMVar_, MVar ) import           Control.Concurrent.Lifted  ( fork, killThread ) import           Control.Exception          ( throwIO ) import           Control.Concurrent.STM     ( atomically, readTVarIO, modifyTVar' ) import           Control.Monad              ( when, unless )-import           Control.Monad.Except       ( runExceptT, throwError )-import           Control.Monad.State        ( runStateT, gets, MonadIO(liftIO), gets, modify' )+import           Control.Monad.Except       ( runExceptT, throwError, mapExceptT )+import           Control.Monad.State        ( runStateT, gets, gets, modify' )+import           Control.Monad.IO.Class     ( liftIO )+import           Control.Monad.Reader       ( asks, ask, runReaderT, withReaderT ) import           Data.Aeson                 ( FromJSON, Result (..), fromJSON ) import           Data.Aeson.Encode.Pretty   ( encodePretty ) import           Data.Aeson.Types           ( object, Key, KeyValue((.=)), ToJSON )+import           Data.IORef                 ( readIORef, writeIORef ) import           Data.Text                  ( unpack, pack ) import           Network.Socket             ( SockAddr ) import           System.IO                  ( Handle ) import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Char8      as BS import qualified Data.HashMap.Strict        as H+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE ---------------------------------------------------------------------------- import           DAP.Types import           DAP.Utils+import           DAP.Log import           DAP.Internal -----------------------------------------------------------------------------logWarn :: BL8.ByteString -> Adaptor app ()+logWarn :: T.Text -> Adaptor app request () logWarn msg = logWithAddr WARN Nothing (withBraces msg) -----------------------------------------------------------------------------logError :: BL8.ByteString -> Adaptor app ()+logError :: T.Text -> Adaptor app request () logError msg = logWithAddr ERROR Nothing (withBraces msg) -----------------------------------------------------------------------------logInfo :: BL8.ByteString -> Adaptor app ()+logInfo :: T.Text -> Adaptor app request () logInfo msg = logWithAddr INFO Nothing (withBraces msg) ---------------------------------------------------------------------------- -- | Meant for internal consumption, used to signify a message has been -- SENT from the server-debugMessage :: BL8.ByteString -> Adaptor app ()-debugMessage msg = do-  shouldLog <- getDebugLogging-  addr <- getAddress-  liftIO-    $ when shouldLog-    $ logger DEBUG addr (Just SENT) msg+debugMessage :: DebugStatus -> BL8.ByteString -> Adaptor app request ()+debugMessage dir msg = do+#if MIN_VERSION_text(2,0,0)+  logWithAddr DEBUG (Just dir) (TE.decodeUtf8Lenient (BL8.toStrict msg))+#else+  logWithAddr DEBUG (Just dir) (TE.decodeUtf8 (BL8.toStrict msg))+#endif ---------------------------------------------------------------------------- -- | Meant for external consumption-logWithAddr :: Level -> Maybe DebugStatus -> BL8.ByteString -> Adaptor app ()+logWithAddr :: Level -> Maybe DebugStatus -> T.Text -> Adaptor app request () logWithAddr level status msg = do   addr <- getAddress-  liftIO (logger level addr status msg)+  logAction <- getLogAction+  liftIO (logger logAction level addr status msg) ---------------------------------------------------------------------------- -- | Meant for external consumption-logger :: Level -> SockAddr -> Maybe DebugStatus -> BL8.ByteString -> IO ()-logger level addr maybeDebug msg = do-  liftIO-    $ withGlobalLock-    $ BL8.putStrLn formatted-  where-    formatted-      = BL8.concat-      [ withBraces $ BL8.pack (show addr)-      , withBraces $ BL8.pack (show level)-      , maybe mempty (withBraces . BL8.pack . show) maybeDebug-      , msg-      ]+logger :: LogAction IO DAPLog -> Level -> SockAddr -> Maybe DebugStatus -> T.Text -> IO ()+logger logAction level addr maybeDebug msg =+  logAction <& DAPLog level maybeDebug addr msg -----------------------------------------------------------------------------getDebugLogging :: Adaptor app Bool-getDebugLogging = gets (debugLogging . serverConfig)+getServerCapabilities :: Adaptor app request Capabilities+getServerCapabilities = asks (serverCapabilities . serverConfig) -----------------------------------------------------------------------------getServerCapabilities :: Adaptor app Capabilities-getServerCapabilities = gets (serverCapabilities . serverConfig)+getAddress :: Adaptor app request SockAddr+getAddress = asks address -----------------------------------------------------------------------------getAddress :: Adaptor app SockAddr-getAddress = gets address+getLogAction :: Adaptor app request (LogAction IO DAPLog)+getLogAction = asks logAction -----------------------------------------------------------------------------getHandle :: Adaptor app Handle-getHandle = gets handle+getHandle :: Adaptor app r Handle+getHandle = asks handle -----------------------------------------------------------------------------getRequestSeqNum :: Adaptor app Seq-getRequestSeqNum = gets (requestSeqNum . request)+getRequestSeqNum :: Adaptor app Request Seq+getRequestSeqNum = asks (requestSeqNum . request) -----------------------------------------------------------------------------getDebugSessionId :: Adaptor app SessionId+getDebugSessionId :: Adaptor app request SessionId getDebugSessionId = do-  gets sessionId >>= \case+  var <- asks (sessionId)+  res <- liftIO $ readIORef var+  case res of     Nothing -> sessionNotFound     Just sessionId -> pure sessionId   where@@ -138,16 +141,17 @@       let err = "No Debug Session has started"       sendError (ErrorMessage (pack err)) Nothing -----------------------------------------------------------------------------setDebugSessionId :: SessionId -> Adaptor app ()-setDebugSessionId session = modify' $ \s -> s { sessionId = Just session }+setDebugSessionId :: SessionId -> Adaptor app request ()+setDebugSessionId session = do+  var <- asks sessionId+  liftIO $ writeIORef var (Just session) ---------------------------------------------------------------------------- registerNewDebugSession   :: SessionId   -> app-  -> IO ()-  -- ^ Action to run debugger (operates in a forked thread that gets killed when disconnect is set)-  -> ((Adaptor app () -> IO ()) -> IO ())-  -- ^ Long running operation, meant to be used as a sink for+  -> [(Adaptor app () () -> IO ()) -> IO ()]+  -- ^ Actions to run debugger (operates in a forked thread that gets killed when disconnect is set)+  -- Long running operation, meant to be used as a sink for   -- the debugger to emit events and for the adaptor to forward to the editor   -- This function should be in a 'forever' loop waiting on the read end of   -- a debugger channel.@@ -157,35 +161,37 @@   -- used when sending events to the editor from the debugger (or from any forked thread).   --   -- >-  -- > registerNewDebugSession sessionId appState loadDebugger $ \withAdaptor ->+  -- > registerNewDebugSession sessionId appState $ loadDebugger : [\withAdaptor ->   -- >   forever $ getDebuggerOutput >>= \output -> do   -- >     withAdaptor $ sendOutputEvent defaultOutputEvent { outputEventOutput = output }-  -- >+  -- >   ]   ---  -> Adaptor app ()-registerNewDebugSession k v debuggerExecution outputEventSink = do-  store <- gets appStore-  adaptorStateMVar <- gets adaptorStateMVar+  -> Adaptor app request ()+registerNewDebugSession k v debuggerConcurrentActions = do+  store <- asks appStore+  lcl <- ask+  let lcl' = lcl { request = () }+  let emptyState = AdaptorState MessageTypeEvent []   debuggerThreadState <- liftIO $     DebuggerThreadState-      <$> fork debuggerExecution-      <*> fork (outputEventSink (runAdaptorWith adaptorStateMVar))+      <$> sequence [fork $ action (runAdaptorWith lcl' emptyState) | action <- debuggerConcurrentActions]   liftIO . atomically $ modifyTVar' store (H.insert k (debuggerThreadState, v))+  logInfo $ T.pack $ "Registered new debug session: " <> unpack k   setDebugSessionId k-  logInfo $ BL8.pack $ "Registered new debug session: " <> unpack k+ -----------------------------------------------------------------------------updateDebugSession :: (app -> app) -> Adaptor app ()+updateDebugSession :: (app -> app) -> Adaptor app request () updateDebugSession updateFun = do   sessionId <- getDebugSessionId-  store <- gets appStore+  store <- asks appStore   liftIO . atomically $ modifyTVar' store (H.adjust (fmap updateFun) sessionId) -----------------------------------------------------------------------------getDebugSession :: Adaptor a a+getDebugSession :: Adaptor a r a getDebugSession = do   (_, _, app) <- getDebugSessionWithThreadIdAndSessionId   pure app -----------------------------------------------------------------------------getDebugSessionWithThreadIdAndSessionId :: Adaptor app (SessionId, DebuggerThreadState, app)+getDebugSessionWithThreadIdAndSessionId :: Adaptor app request (SessionId, DebuggerThreadState, app) getDebugSessionWithThreadIdAndSessionId = do   sessionId <- getDebugSessionId   appStore <- liftIO . readTVarIO =<< getAppStore@@ -205,27 +211,26 @@ -- | Whenever a debug Session ends (cleanly or otherwise) this function -- will remove the local debugger communication state from the global state -----------------------------------------------------------------------------destroyDebugSession :: Adaptor app ()+destroyDebugSession :: Adaptor app request () destroyDebugSession = do   (sessionId, DebuggerThreadState {..}, _) <- getDebugSessionWithThreadIdAndSessionId   store <- getAppStore   liftIO $ do-    killThread debuggerThread-    killThread debuggerOutputEventThread+    mapM_ killThread debuggerThreads     atomically $ modifyTVar' store (H.delete sessionId)-  logInfo $ BL8.pack $ "SessionId " <> unpack sessionId <> " ended"+  logInfo $ T.pack $ "SessionId " <> unpack sessionId <> " ended" -----------------------------------------------------------------------------getAppStore :: Adaptor app (AppStore app)-getAppStore = gets appStore+getAppStore :: Adaptor app request (AppStore app)+getAppStore = asks appStore -----------------------------------------------------------------------------getCommand :: Adaptor app Command-getCommand = command <$> gets request+getCommand :: Adaptor app Request Command+getCommand = command <$> asks request ---------------------------------------------------------------------------- -- | 'sendRaw' (internal use only) -- Sends a raw JSON payload to the editor. No "seq", "type" or "command" fields are set. -- The message is still encoded with the ProtocolMessage Header, byte count, and CRLF. ---sendRaw :: ToJSON value => value -> Adaptor app ()+sendRaw :: ToJSON value => value -> Adaptor app request () sendRaw value = do   handle        <- getHandle   address       <- getAddress@@ -237,7 +242,7 @@ -- i.e. "request_seq" and "command". -- We also have to be sure to reset the message payload -----------------------------------------------------------------------------send :: Adaptor app () -> Adaptor app ()+send :: Adaptor app Request () -> Adaptor app Request () send action = do   ()            <- action   cmd           <- getCommand@@ -253,16 +258,39 @@    -- "seq" and "type" must be set for all protocol messages   setField "type" messageType-  unless (messageType == MessageTypeEvent) $-    setField "seq" seqNum+  unless (messageType == MessageTypeEvent) (setField "seq" seqNum)    -- Once all fields are set, fetch the payload for sending   payload <- object <$> gets payload    -- Send payload to client from debug adaptor   writeToHandle address handle payload+  resetAdaptorStatePayload+----------------------------------------------------------------------------+-- | Write event to Handle+sendEvent+  :: Adaptor app request ()+  -> Adaptor app request ()+sendEvent action = do+  ()            <- action+  handle        <- getHandle+  messageType   <- gets messageType+  address       <- getAddress+  let errorMsg =+        "Use 'send' function when responding to a DAP request, "+        <> "'sendEvent' is for responding to events"+  case messageType of+    MessageTypeResponse ->+      sendError (ErrorMessage errorMsg) Nothing+    MessageTypeRequest ->+      sendError (ErrorMessage errorMsg) Nothing+    MessageTypeEvent ->+      setField "type" messageType -  -- Reset payload each time a send occurs+  -- Once all fields are set, fetch the payload for sending+  payload <- object <$> gets payload+  -- Send payload to client from debug adaptor+  writeToHandle address handle payload   resetAdaptorStatePayload ---------------------------------------------------------------------------- -- | Writes payload to the given 'Handle' using the local connection lock@@ -272,31 +300,34 @@   => SockAddr   -> Handle   -> event-  -> Adaptor app ()+  -> Adaptor app request () writeToHandle _ handle evt = do   let msg = encodeBaseProtocolMessage evt-  debugMessage ("\n" <> encodePretty evt)+  debugMessage SENT ("\n" <> encodePretty evt)   withConnectionLock (BS.hPutStr handle msg) ---------------------------------------------------------------------------- -- | Resets Adaptor's payload -----------------------------------------------------------------------------resetAdaptorStatePayload :: Adaptor app ()+resetAdaptorStatePayload :: Adaptor app request () resetAdaptorStatePayload = modify' $ \s -> s { payload = [] } -----------------------------------------------------------------------------sendSuccesfulResponse :: Adaptor app () -> Adaptor app ()+sendSuccesfulResponse :: Adaptor app Request () -> Adaptor app Request () sendSuccesfulResponse action = do  send $ do     setType MessageTypeResponse     setSuccess True     action -----------------------------------------------------------------------------sendSuccesfulEmptyResponse :: Adaptor app ()+sendSuccesfulEmptyResponse :: Adaptor app Request () sendSuccesfulEmptyResponse = sendSuccesfulResponse (pure ()) ---------------------------------------------------------------------------- -- | Sends successful event-sendSuccesfulEvent :: EventType -> Adaptor app () -> Adaptor app ()+sendSuccesfulEvent+  :: EventType+  -> Adaptor app request ()+  -> Adaptor app request () sendSuccesfulEvent event action = do-  send $ do+  sendEvent $ do     setEvent event     setType MessageTypeEvent     action@@ -308,7 +339,7 @@ sendError   :: ErrorMessage   -> Maybe Message-  -> Adaptor app a+  -> Adaptor app request a sendError errorMessage maybeMessage = do   throwError (errorMessage, maybeMessage) ----------------------------------------------------------------------------@@ -317,7 +348,7 @@ sendErrorResponse   :: ErrorMessage   -> Maybe Message-  -> Adaptor app ()+  -> Adaptor app Request () sendErrorResponse errorMessage maybeMessage = do   send $ do     setType MessageTypeResponse@@ -327,24 +358,24 @@ ---------------------------------------------------------------------------- setErrorMessage   :: ErrorMessage-  -> Adaptor app ()+  -> Adaptor app request () setErrorMessage v = setField "message" v ---------------------------------------------------------------------------- -- | Sends successful event setSuccess   :: Bool-  -> Adaptor app ()+  -> Adaptor app request () setSuccess = setField "success" ---------------------------------------------------------------------------- setBody   :: ToJSON value   => value-  -> Adaptor app ()+  -> Adaptor app request () setBody value = setField "body" value ---------------------------------------------------------------------------- setType   :: MessageType-  -> Adaptor app ()+  -> Adaptor app request () setType messageType = do   modify' $ \adaptorState ->     adaptorState@@ -353,14 +384,14 @@ ---------------------------------------------------------------------------- setEvent   :: EventType-  -> Adaptor app ()+  -> Adaptor app request () setEvent = setField "event" ---------------------------------------------------------------------------- setField   :: ToJSON value   => Key   -> value-  -> Adaptor app ()+  -> Adaptor app request () setField key value = do   currentPayload <- gets payload   modify' $ \adaptorState ->@@ -370,41 +401,50 @@ ---------------------------------------------------------------------------- withConnectionLock   :: IO ()-  -> Adaptor app ()+  -> Adaptor app request () withConnectionLock action = do-  lock <- gets handleLock+  lock <- asks handleLock   liftIO (withLock lock action) ---------------------------------------------------------------------------- -- | Attempt to parse arguments from the Request ---------------------------------------------------------------------------- getArguments   :: (Show value, FromJSON value)-  => Adaptor app value+  => Adaptor app Request value getArguments = do-  maybeArgs <- gets (args . request)+  maybeArgs <- asks (args . request)   let msg = "No args found for this message"   case maybeArgs of     Nothing -> do-      logError (BL8.pack msg)+      logError msg       liftIO $ throwIO (ExpectedArguments msg)     Just val ->       case fromJSON val of         Success r -> pure r-        x -> do-          logError (BL8.pack (show x))-          liftIO $ throwIO (ParseException (show x))-+        Error reason -> do+          logError (T.pack reason)+          liftIO $ throwIO (ParseException reason) ---------------------------------------------------------------------------- -- | Evaluates Adaptor action by using and updating the state in the MVar-runAdaptorWith :: MVar (AdaptorState app) -> Adaptor app () -> IO ()-runAdaptorWith adaptorStateMVar action = do-  modifyMVar_ adaptorStateMVar (flip runAdaptor (resetAdaptorStatePayload >> action))-+runAdaptorWith :: AdaptorLocal app request -> AdaptorState -> Adaptor app request () -> IO ()+runAdaptorWith 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+      AdaptorState _ p ->+        if null p+          then return ()+          else error $ "runAdaptorWith, unexpected payload:" <> show p ---------------------------------------------------------------------------- -- | Utility for evaluating a monad transformer stack-runAdaptor :: AdaptorState app -> Adaptor app () -> IO (AdaptorState app)-runAdaptor adaptorState (Adaptor client) =-  runStateT (runExceptT client) adaptorState >>= \case-    (Left (errorMessage, maybeMessage), nextState) ->-      runAdaptor nextState (sendErrorResponse errorMessage maybeMessage)-    (Right (), nextState) -> pure nextState+runAdaptor :: AdaptorLocal app Request -> AdaptorState -> Adaptor app Request () -> IO ()+runAdaptor lcl s (Adaptor client) =+  runStateT (runReaderT (runExceptT client) lcl) s >>= \case+    (Left (errorMessage, maybeMessage), s') ->+      runAdaptor lcl s' (sendErrorResponse errorMessage maybeMessage)+    (Right (), _) -> pure ()+----------------------------------------------------------------------------++withRequest :: Request -> Adaptor app Request a -> Adaptor app r a+withRequest r (Adaptor client) = Adaptor (mapExceptT (withReaderT (\lcl -> lcl { request = r })) client)

@@ -50,13 +50,13 @@ import           DAP.Types import           DAP.Adaptor -----------------------------------------------------------------------------sendBreakpointEvent :: BreakpointEvent -> Adaptor app ()+sendBreakpointEvent :: BreakpointEvent -> Adaptor app Request () sendBreakpointEvent = sendSuccesfulEvent EventTypeBreakpoint . setBody -----------------------------------------------------------------------------sendCapabilitiesEvent :: CapabilitiesEvent -> Adaptor app ()+sendCapabilitiesEvent :: CapabilitiesEvent -> Adaptor app Request () sendCapabilitiesEvent = sendSuccesfulEvent EventTypeCapabilities . setBody -----------------------------------------------------------------------------sendContinuedEvent :: ContinuedEvent -> Adaptor app ()+sendContinuedEvent :: ContinuedEvent -> Adaptor app Request () sendContinuedEvent = sendSuccesfulEvent EventTypeContinued . setBody ---------------------------------------------------------------------------- defaultContinuedEvent :: ContinuedEvent@@ -66,7 +66,7 @@   , continuedEventAllThreadsContinued = False   } -----------------------------------------------------------------------------sendExitedEvent :: ExitedEvent -> Adaptor app ()+sendExitedEvent :: ExitedEvent -> Adaptor app Request () sendExitedEvent = sendSuccesfulEvent EventTypeExited . setBody ---------------------------------------------------------------------------- defaultExitedEvent :: ExitedEvent@@ -75,10 +75,10 @@   { exitedEventExitCode = 0   } -----------------------------------------------------------------------------sendInitializedEvent :: Adaptor app ()+sendInitializedEvent :: Adaptor app Request () sendInitializedEvent = sendSuccesfulEvent EventTypeInitialized (pure ()) -----------------------------------------------------------------------------sendInvalidatedEvent :: InvalidatedEvent -> Adaptor app ()+sendInvalidatedEvent :: InvalidatedEvent -> Adaptor app Request () sendInvalidatedEvent = sendSuccesfulEvent EventTypeInvalidated . setBody ---------------------------------------------------------------------------- defaultInvalidatedEvent :: InvalidatedEvent@@ -90,10 +90,10 @@   }  -----------------------------------------------------------------------------sendLoadedSourceEvent :: LoadedSourceEvent -> Adaptor app ()+sendLoadedSourceEvent :: LoadedSourceEvent -> Adaptor app Request () sendLoadedSourceEvent = sendSuccesfulEvent EventTypeLoadedSource . setBody -----------------------------------------------------------------------------sendMemoryEvent :: MemoryEvent -> Adaptor app ()+sendMemoryEvent :: MemoryEvent -> Adaptor app Request () sendMemoryEvent = sendSuccesfulEvent EventTypeMemory . setBody ---------------------------------------------------------------------------- defaultMemoryEvent :: MemoryEvent@@ -104,10 +104,10 @@   , memoryEventCount            = 0   } -----------------------------------------------------------------------------sendModuleEvent :: ModuleEvent -> Adaptor app ()+sendModuleEvent :: ModuleEvent -> Adaptor app Request () sendModuleEvent = sendSuccesfulEvent EventTypeModule . setBody -----------------------------------------------------------------------------sendOutputEvent :: OutputEvent -> Adaptor app ()+sendOutputEvent :: OutputEvent -> Adaptor app request () sendOutputEvent = sendSuccesfulEvent EventTypeOutput . setBody ---------------------------------------------------------------------------- defaultOutputEvent :: OutputEvent@@ -123,7 +123,7 @@   , outputEventData               = Nothing   } -----------------------------------------------------------------------------sendProcessEvent :: ProcessEvent -> Adaptor app ()+sendProcessEvent :: ProcessEvent -> Adaptor app Request () sendProcessEvent = sendSuccesfulEvent EventTypeProcess . setBody ---------------------------------------------------------------------------- defaultProcessEvent :: ProcessEvent@@ -136,7 +136,7 @@   , processEventPointerSize     = Nothing   } -----------------------------------------------------------------------------sendProgressEndEvent :: ProgressEndEvent -> Adaptor app ()+sendProgressEndEvent :: ProgressEndEvent -> Adaptor app Request () sendProgressEndEvent = sendSuccesfulEvent EventTypeProgressEnd . setBody ---------------------------------------------------------------------------- defaultProgressEndEvent :: ProgressEndEvent@@ -146,7 +146,7 @@   , progressEndEventMessage     = Nothing   } -----------------------------------------------------------------------------sendProgressStartEvent :: ProgressStartEvent -> Adaptor app ()+sendProgressStartEvent :: ProgressStartEvent -> Adaptor app Request () sendProgressStartEvent = sendSuccesfulEvent EventTypeProgressStart . setBody ---------------------------------------------------------------------------- defaultProgressStartEvent :: ProgressStartEvent@@ -160,7 +160,7 @@   , progressStartEventPercentage  = Nothing   } -----------------------------------------------------------------------------sendProgressUpdateEvent :: ProgressUpdateEvent -> Adaptor app ()+sendProgressUpdateEvent :: ProgressUpdateEvent -> Adaptor app Request () sendProgressUpdateEvent = sendSuccesfulEvent EventTypeProgressUpdate . setBody ---------------------------------------------------------------------------- defaultProgressUpdateEvent :: ProgressUpdateEvent@@ -171,7 +171,7 @@   , progressUpdateEventPercentage = Nothing   } -----------------------------------------------------------------------------sendStoppedEvent :: StoppedEvent -> Adaptor app ()+sendStoppedEvent :: StoppedEvent -> Adaptor app Request () sendStoppedEvent = sendSuccesfulEvent EventTypeStopped . setBody ---------------------------------------------------------------------------- defaultStoppedEvent :: StoppedEvent@@ -186,7 +186,7 @@   , stoppedEventHitBreakpointIds  = []   } -----------------------------------------------------------------------------sendTerminatedEvent :: TerminatedEvent -> Adaptor app ()+sendTerminatedEvent :: TerminatedEvent -> Adaptor app Request () sendTerminatedEvent = sendSuccesfulEvent EventTypeTerminated . setBody ---------------------------------------------------------------------------- defaultTerminatedEvent :: TerminatedEvent@@ -195,7 +195,7 @@   { terminatedEventRestart = False   } -----------------------------------------------------------------------------sendThreadEvent :: ThreadEvent -> Adaptor app ()+sendThreadEvent :: ThreadEvent -> Adaptor app Request () sendThreadEvent = sendSuccesfulEvent EventTypeThread . setBody ---------------------------------------------------------------------------- defaultThreadEvent :: ThreadEvent

@@ -9,16 +9,9 @@ ---------------------------------------------------------------------------- module DAP.Internal   ( withLock-  , withGlobalLock   ) where -----------------------------------------------------------------------------import           Control.Concurrent         ( modifyMVar_, newMVar, MVar )-import           System.IO.Unsafe           ( unsafePerformIO )-------------------------------------------------------------------------------- | Used for logging in the presence of multiple threads.-lock :: MVar ()-{-# NOINLINE lock #-}-lock = unsafePerformIO $ newMVar ()+import           Control.Concurrent ---------------------------------------------------------------------------- -- | Used for performing actions (e.g. printing debug logs to stdout) -- Also used for writing to each connections Handle.@@ -28,12 +21,4 @@ -- withLock :: MVar () -> IO () -> IO () withLock mvar action = modifyMVar_ mvar $ \x -> x <$ action-------------------------------------------------------------------------------- | Used for performing actions (e.g. printing debug logs to stdout)--- Ensures operations occur one thread at a time.------ Used internally only----withGlobalLock :: IO () -> IO ()-withGlobalLock = withLock lock ----------------------------------------------------------------------------

@@ -0,0 +1,46 @@+module DAP.Log (+    DebugStatus (..)+  , DAPLog(..)+  , LogAction(..)+  , Level(..)+  , (<&)+  , cmap+  , cfilter+  , mkDebugMessage+  , renderDAPLog+) where++import Data.Text (Text)+import           Network.Socket                  ( SockAddr )+import Colog.Core+import qualified Data.Text as T+import DAP.Utils++----------------------------------------------------------------------------+data Level = DEBUG | INFO | WARN | ERROR+  deriving (Show, Eq)+----------------------------------------------------------------------------+data DebugStatus = SENT | RECEIVED+  deriving (Show, Eq)++data DAPLog =+  DAPLog {+      severity :: Level+    , mDebugStatus :: Maybe DebugStatus+    , addr     :: SockAddr+    , message  :: Text+    }+  | GenericMessage { severity :: Level, message :: Text }++mkDebugMessage :: Text -> DAPLog+mkDebugMessage  = GenericMessage DEBUG++renderDAPLog :: DAPLog -> Text+renderDAPLog (GenericMessage _ t) = t+renderDAPLog (DAPLog level maybeDebug log_addr msg) = T.concat+      [ withBraces $ T.pack (show log_addr)+      , withBraces $ T.pack (show level)+      , maybe mempty (withBraces . T.pack . show) maybeDebug+      , msg+      ]+

@@ -64,13 +64,13 @@ import           DAP.Types ---------------------------------------------------------------------------- -- | AttachResponse has no body by default-sendAttachResponse :: Adaptor app ()+sendAttachResponse :: Adaptor app Request () sendAttachResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | BreakpointLocationResponse has no body by default sendBreakpointLocationsResponse   :: [BreakpointLocation]-  -> Adaptor app ()+  -> Adaptor app Request () sendBreakpointLocationsResponse   = sendSuccesfulResponse   . setBody@@ -79,7 +79,7 @@ -- | 'SetDataBreakpointsResponse' sendSetDataBreakpointsResponse   :: [Breakpoint]-  -> Adaptor app ()+  -> Adaptor app Request () sendSetDataBreakpointsResponse   = sendSuccesfulResponse   . setBody@@ -88,7 +88,7 @@ -- | BreakpointResponse has no body by default sendSetBreakpointsResponse   :: [Breakpoint]-  -> Adaptor app ()+  -> Adaptor app Request () sendSetBreakpointsResponse   = sendSuccesfulResponse   . setBody@@ -97,7 +97,7 @@ -- | SetInstructionsBreakpointResponse has no body by default sendSetInstructionBreakpointsResponse   :: [Breakpoint]-  -> Adaptor app ()+  -> Adaptor app Request () sendSetInstructionBreakpointsResponse   = sendSuccesfulResponse   . setBody@@ -106,7 +106,7 @@ -- | SetFunctionBreakpointResponse has no body by default sendSetFunctionBreakpointsResponse   :: [Breakpoint]-  -> Adaptor app ()+  -> Adaptor app Request () sendSetFunctionBreakpointsResponse   = sendSuccesfulResponse   . setBody@@ -115,7 +115,7 @@ -- | SetExceptionBreakpointsResponse has no body by default sendSetExceptionBreakpointsResponse   :: [Breakpoint]-  -> Adaptor app ()+  -> Adaptor app Request () sendSetExceptionBreakpointsResponse   = sendSuccesfulResponse   . setBody@@ -124,147 +124,147 @@ -- | ContinueResponse sendContinueResponse   :: ContinueResponse-  -> Adaptor app ()+  -> Adaptor app Request () sendContinueResponse continueResponse = do   sendSuccesfulResponse (setBody continueResponse) ---------------------------------------------------------------------------- -- | ConfigurationDoneResponse sendConfigurationDoneResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendConfigurationDoneResponse = do   sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | LaunchResponse sendLaunchResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendLaunchResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | RestartResponse sendRestartResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendRestartResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | DisconnectResponse sendDisconnectResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendDisconnectResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | TerminateResponse sendTerminateResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendTerminateResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | NextResponse sendNextResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendNextResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | StepInResponse sendStepInResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendStepInResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | StepOutResponse sendStepOutResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendStepOutResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | StepBackResponse sendStepBackResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendStepBackResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | ReverseContinueResponse sendReverseContinueResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendReverseContinueResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | RestartFrameResponse sendRestartFrameResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendRestartFrameResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | InitializeReponse sendInitializeResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendInitializeResponse = do   capabilities <- getServerCapabilities   sendSuccesfulResponse (setBody capabilities) ---------------------------------------------------------------------------- -- | GotoResponse sendGotoResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendGotoResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | GotoTargetsResponse sendGotoTargetsResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendGotoTargetsResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | PauseResponse sendPauseResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendPauseResponse = sendSuccesfulEmptyResponse ---------------------------------------------------------------------------- -- | TerminateThreadsResponse sendTerminateThreadsResponse-  :: Adaptor app ()+  :: Adaptor app Request () sendTerminateThreadsResponse = sendSuccesfulEmptyResponse -----------------------------------------------------------------------------sendModulesResponse :: ModulesResponse -> Adaptor app ()+sendModulesResponse :: ModulesResponse -> Adaptor app Request () sendModulesResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendStackTraceResponse :: StackTraceResponse -> Adaptor app ()+sendStackTraceResponse :: StackTraceResponse -> Adaptor app Request () sendStackTraceResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendSourceResponse :: SourceResponse -> Adaptor app ()+sendSourceResponse :: SourceResponse -> Adaptor app Request () sendSourceResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendThreadsResponse :: [Thread] -> Adaptor app ()+sendThreadsResponse :: [Thread] -> Adaptor app Request () sendThreadsResponse = sendSuccesfulResponse . setBody . ThreadsResponse -----------------------------------------------------------------------------sendLoadedSourcesResponse :: [Source] -> Adaptor app ()+sendLoadedSourcesResponse :: [Source] -> Adaptor app Request () sendLoadedSourcesResponse = sendSuccesfulResponse . setBody . LoadedSourcesResponse -----------------------------------------------------------------------------sendWriteMemoryResponse :: WriteMemoryResponse -> Adaptor app ()+sendWriteMemoryResponse :: WriteMemoryResponse -> Adaptor app Request () sendWriteMemoryResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendReadMemoryResponse :: ReadMemoryResponse -> Adaptor app ()+sendReadMemoryResponse :: ReadMemoryResponse -> Adaptor app Request () sendReadMemoryResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendCompletionsResponse :: CompletionsResponse -> Adaptor app ()+sendCompletionsResponse :: CompletionsResponse -> Adaptor app Request () sendCompletionsResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendDataBreakpointInfoResponse :: DataBreakpointInfoResponse -> Adaptor app ()+sendDataBreakpointInfoResponse :: DataBreakpointInfoResponse -> Adaptor app Request () sendDataBreakpointInfoResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendDisassembleResponse :: DisassembleResponse -> Adaptor app ()+sendDisassembleResponse :: DisassembleResponse -> Adaptor app Request () sendDisassembleResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendEvaluateResponse :: EvaluateResponse -> Adaptor app ()+sendEvaluateResponse :: EvaluateResponse -> Adaptor app Request () sendEvaluateResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendExceptionInfoResponse :: ExceptionInfoResponse -> Adaptor app ()+sendExceptionInfoResponse :: ExceptionInfoResponse -> Adaptor app Request () sendExceptionInfoResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendScopesResponse :: ScopesResponse -> Adaptor app ()+sendScopesResponse :: ScopesResponse -> Adaptor app Request () sendScopesResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendSetExpressionResponse :: SetExpressionResponse -> Adaptor app ()+sendSetExpressionResponse :: SetExpressionResponse -> Adaptor app Request () sendSetExpressionResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendSetVariableResponse :: SetVariableResponse -> Adaptor app ()+sendSetVariableResponse :: SetVariableResponse -> Adaptor app Request () sendSetVariableResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendStepInTargetsResponse :: StepInTargetsResponse -> Adaptor app ()+sendStepInTargetsResponse :: StepInTargetsResponse -> Adaptor app Request () sendStepInTargetsResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendVariablesResponse :: VariablesResponse -> Adaptor app ()+sendVariablesResponse :: VariablesResponse -> Adaptor app Request () sendVariablesResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendRunInTerminalResponse :: RunInTerminalResponse -> Adaptor app ()+sendRunInTerminalResponse :: RunInTerminalResponse -> Adaptor app Request () sendRunInTerminalResponse = sendSuccesfulResponse . setBody -----------------------------------------------------------------------------sendStartDebuggingResponse :: Adaptor app ()+sendStartDebuggingResponse :: Adaptor app Request () sendStartDebuggingResponse = sendSuccesfulEmptyResponse ----------------------------------------------------------------------------

@@ -15,123 +15,155 @@ {-# LANGUAGE NamedFieldPuns             #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE ViewPatterns               #-} ---------------------------------------------------------------------------- module DAP.Server   ( runDAPServer+  , runDAPServerWithLogger   , readPayload+  , TerminateServer(..)   ) where -----------------------------------------------------------------------------import           Control.Concurrent.MVar    ( MVar )-import           Control.Monad              ( when )-import           Control.Concurrent.MVar    ( newMVar, newEmptyMVar, modifyMVar_-                                            , putMVar, readMVar )+import           Control.Monad              ( when, forever )+import           Control.Concurrent         ( ThreadId, myThreadId, throwTo )+import           Control.Concurrent.MVar    ( newMVar ) import           Control.Concurrent.STM     ( newTVarIO )-import           Control.Exception          ( SomeException+import           Control.Exception          ( Exception+                                            , SomeAsyncException(..)+                                            , SomeException                                             , IOException                                             , catch                                             , fromException+                                            , toException                                             , throwIO ) import           Control.Monad              ( void )-import           Control.Monad.State        ( gets ) import           Data.Aeson                 ( decodeStrict, eitherDecode, Value, FromJSON ) import           Data.Aeson.Encode.Pretty   ( encodePretty ) import           Data.ByteString            ( ByteString ) import           Data.Char                  ( isDigit )+import           Data.IORef                 ( newIORef ) import           Network.Simple.TCP         ( serve, HostPreference(Host) ) import           Network.Socket             ( socketToHandle, withSocketsDo, SockAddr ) import           System.IO                  ( hClose, hSetNewlineMode, Handle, Newline(CRLF)                                             , NewlineMode(NewlineMode, outputNL, inputNL)-                                            , IOMode(ReadWriteMode) )+                                            , IOMode(ReadWriteMode), stderr, hPrint) import           System.IO.Error            ( isEOFError )+import           System.Exit                ( exitWith, ExitCode(ExitSuccess) ) import           Text.Read                  ( readMaybe ) import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Char8      as BS+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Control.Monad.Reader ---------------------------------------------------------------------------- import           DAP.Types import           DAP.Internal import           DAP.Utils import           DAP.Adaptor+import           DAP.Log -----------------------------------------------------------------------------runDAPServer-  :: ServerConfig++stdoutLogger :: IO (LogAction IO T.Text)+stdoutLogger = do+  handleLock               <- newMVar ()+  return $ LogAction $ \msg -> do+    withLock handleLock $ do+      T.putStrLn msg++-- | An exception to throw if you want to stop the server execution from a+-- client. This is useful if you launch a new server per debugging session and+-- want to terminate it at the end.+data TerminateServer = TerminateServer+  deriving (Show, Exception)++runDAPServer :: ServerConfig -> (Command -> Adaptor app Request ()) -> IO ()+runDAPServer config communicate = do+  l <- stdoutLogger+  runDAPServerWithLogger (cmap renderDAPLog l) config communicate++runDAPServerWithLogger+  :: LogAction IO DAPLog+  -> ServerConfig   -- ^ Top-level Server configuration, global across all debug sessions-  -> (Command -> Adaptor app ())+  -> (Command -> Adaptor app Request ())   -- ^ A function to facilitate communication between DAP clients, debug adaptors and debuggers   -> IO ()-runDAPServer serverConfig@ServerConfig {..} communicate = withSocketsDo $ do-  when debugLogging $ putStrLn ("Running DAP server on " <> show port <> "...")+runDAPServerWithLogger rawLogAction serverConfig@ServerConfig {..} communicate = 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-  serve (Host host) (show port) $ \(socket, address) -> do-    when debugLogging $ do-      withGlobalLock $ do-        putStrLn $ "TCP connection established from " ++ show address-    handle <- socketToHandle socket ReadWriteMode-    hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF }-    request <- getRequest handle address serverConfig-    adaptorStateMVar <- initAdaptorState handle address appStore serverConfig request-    serviceClient communicate adaptorStateMVar `catch` exceptionHandler handle address debugLogging+  mainThread <- myThreadId+  let+    server = serve (Host host) (show port) $ \(socket, address) -> do+      logAction <& mkDebugMessage (T.pack ("TCP connection established from " ++ show address))+      handle <- socketToHandle socket ReadWriteMode+      hSetNewlineMode handle NewlineMode { inputNL = CRLF, outputNL = CRLF }+      adaptorStateMVar <- initAdaptorState logAction handle address appStore serverConfig+      serviceClient communicate adaptorStateMVar+        `catch` exceptionHandler logAction handle address debugLogging mainThread+  server `catch` \(SomeAsyncException e) ->+    case fromException $ toException e of+      Just TerminateServer -> exitWith ExitSuccess+      _                    -> throwIO e  -- | Initializes the Adaptor -- initAdaptorState-  :: Handle+  :: LogAction IO DAPLog+  -> Handle   -> SockAddr   -> AppStore app   -> ServerConfig-  -> Request-  -> IO (MVar (AdaptorState app))-initAdaptorState handle address appStore serverConfig request = do+  -> IO (AdaptorLocal app ())+initAdaptorState logAction handle address appStore serverConfig = do   handleLock               <- newMVar ()-  sessionId                <- pure Nothing-  adaptorStateMVar         <- newEmptyMVar-  putMVar adaptorStateMVar AdaptorState-    { messageType = MessageTypeResponse-    , payload = []-    , ..+  sessionId                <- newIORef Nothing+  let request = ()+  pure AdaptorLocal+    { ..     }-  pure adaptorStateMVar ---------------------------------------------------------------------------- -- | Communication loop between editor and adaptor -- Evaluates the current 'Request' located in the 'AdaptorState' -- Fetches, updates and recurses on the next 'Request' -- serviceClient-  :: (Command -> Adaptor app ())-  -> MVar (AdaptorState app)+  :: (Command -> Adaptor app Request ())+  -> AdaptorLocal app r   -> IO ()-serviceClient communicate adaptorStateMVar = do-  runAdaptorWith adaptorStateMVar $ do-    request <- gets request-    communicate (command request)--  -- HINT: getRequest is a blocking action so we use readMVar to leave MVar available-  AdaptorState { address, handle, serverConfig } <- readMVar adaptorStateMVar-  nextRequest <- getRequest handle address serverConfig-  modifyMVar_ adaptorStateMVar $ \s -> pure s { request = nextRequest }--  -- loop: serve the next request-  serviceClient communicate adaptorStateMVar-+serviceClient communicate lcl = forever $ runAdaptorWith lcl st $ do+    nextRequest <- getRequest+    withRequest nextRequest (communicate (command nextRequest))+  where+    st = AdaptorState MessageTypeResponse [] ------------------------------------------------------------------------------- | Handle exceptions from client threads, parse and log accordingly-exceptionHandler :: Handle -> SockAddr -> Bool -> SomeException -> IO ()-exceptionHandler handle address shouldLog (e :: SomeException) = do+-- | Handle exceptions from client threads, parse and log accordingly.+-- Detects if client failed with `TerminateServer` and kills the server accordingly by sending an exception to the main thread.+exceptionHandler :: LogAction IO DAPLog -> Handle -> SockAddr -> Bool -> ThreadId -> SomeException -> IO ()+exceptionHandler logAction handle address shouldLog serverThread (e :: SomeException) = do   let     dumpError+      | Just TerminateServer      <- fromException e+          = do+            logger logAction ERROR address Nothing+              $ withBraces+              $ T.pack ("Server terminated!")+            throwTo serverThread (SomeAsyncException TerminateServer)       | Just (ParseException msg) <- fromException e-          = logger ERROR address Nothing+          = logger logAction ERROR address Nothing             $ withBraces-            $ BL8.pack ("Parse Exception encountered: " <> msg)+            $ T.pack ("Parse Exception encountered: " <> msg)       | Just (err :: IOException) <- fromException e, isEOFError err-          = logger INFO address (Just SENT)+          = logger logAction INFO address (Just SENT)             $ withBraces "Client has ended its connection"       | otherwise-          = logger ERROR address Nothing+          = logger logAction ERROR address Nothing             $ withBraces-            $ BL8.pack ("Unknown Exception: " <> show e)+            $ T.pack ("Unknown Exception: " <> show e)+  hPrint stderr ("Handling" <> show e)   when shouldLog $ do     dumpError-    logger INFO address (Just SENT) (withBraces "Closing Connection")+    logger logAction INFO address (Just SENT) (withBraces "Closing Connection")   hClose handle ---------------------------------------------------------------------------- -- | Internal function for parsing a 'ProtocolMessage' header@@ -140,36 +172,43 @@ -- 'parseHeader' Attempts to parse 'Content-Length: <byte-count>' -- Helper function for parsing message headers -- e.g. ("Content-Length: 11\r\n")-getRequest :: Handle -> SockAddr -> ServerConfig -> IO Request-getRequest handle addr ServerConfig {..} = do-  headerBytes <- BS.hGetLine handle-  void (BS.hGetLine handle)-  parseHeader headerBytes >>= \case+getRequest :: Adaptor app r Request+getRequest = do+  handle <- getHandle+  header <- liftIO $ getHeaderHandle handle+  case header of     Left errorMessage -> do-      logger ERROR addr Nothing (BL8.pack errorMessage)-      throwIO (ParseException errorMessage)+      logError (T.pack errorMessage)+      liftIO $ throwIO (ParseException errorMessage)     Right count -> do-      body <- BS.hGet handle count-      when debugLogging $ do-        logger DEBUG addr (Just RECEIVED)+      body <- liftIO $ BS.hGet handle count+      debugMessage RECEIVED           ("\n" <> encodePretty (decodeStrict body :: Maybe Value))       case eitherDecode (BL8.fromStrict body) of         Left couldn'tDecodeBody -> do-          logger ERROR addr Nothing (BL8.pack couldn'tDecodeBody)-          throwIO (ParseException couldn'tDecodeBody)+          logError (T.pack couldn'tDecodeBody)+          liftIO $ throwIO (ParseException couldn'tDecodeBody)         Right request ->           pure request++getHeaderHandle :: Handle -> IO (Either String PayloadSize)+getHeaderHandle handle = do+  headerBytes <- BS.hGetLine handle+  void (BS.hGetLine handle)+  pure $ parseHeader headerBytes++ ---------------------------------------------------------------------------- -- | Parses the HeaderPart of all ProtocolMessages-parseHeader :: ByteString -> IO (Either String PayloadSize)-parseHeader bytes = do+parseHeader :: ByteString -> Either String PayloadSize+parseHeader bytes =   let byteSize = BS.takeWhile isDigit (BS.drop (BS.length "Content-Length: ") bytes)-  case readMaybe (BS.unpack byteSize) of-    Just contentLength ->-      pure (Right contentLength)-    Nothing ->-      pure $ Left ("Invalid payload: " <> BS.unpack bytes)-+  in case readMaybe (BS.unpack byteSize) of+        Just contentLength ->+          Right contentLength+        Nothing ->+          Left ("Invalid payload: " <> BS.unpack bytes)+---------------------------------------------------------------------------- -- | Helper function to parse a 'ProtocolMessage', extracting it's body. -- used for testing. --@@ -177,8 +216,9 @@ readPayload handle = do   headerBytes <- BS.hGetLine handle   void (BS.hGetLine handle)-  parseHeader headerBytes >>= \case+  case parseHeader headerBytes of     Left e -> pure (Left e)     Right count -> do       body <- BS.hGet handle count       pure $ eitherDecode (BL8.fromStrict body)+----------------------------------------------------------------------------

@@ -81,6 +81,7 @@   , TerminatedEvent                    (..)   , ThreadEvent                        (..)   , OutputEvent                        (..)+  , OutputEventCategory                (..)   , BreakpointEvent                    (..)   , ModuleEvent                        (..)   , LoadedSourceEvent                  (..)@@ -96,7 +97,9 @@     -- * Client   , Adaptor                            (..)   , AdaptorState                       (..)+  , AdaptorLocal(..)   , AppStore+  , MonadIO(..)     -- * Errors   , AdaptorException                   (..)   , ErrorMessage                       (..)@@ -194,23 +197,24 @@   , defaultValueFormat   , defaultVariable   , defaultVariablePresentationHint-    -- * Log level-  , Level (..)-  , DebugStatus (..)   -- * Debug Thread state   , DebuggerThreadState (..)   ) where ----------------------------------------------------------------------------+import           Control.Applicative             ( (<|>) ) import           Control.Monad.Base              ( MonadBase ) import           Control.Monad.Except            ( MonadError, ExceptT ) import           Control.Monad.Trans.Control     ( MonadBaseControl ) import           Control.Concurrent              ( ThreadId ) import           Control.Concurrent.MVar         ( MVar )-import           Control.Applicative             ( (<|>) )+import           Control.Monad.IO.Class          ( MonadIO )+import           Control.Monad.Reader            ( MonadReader, ReaderT )+import           Control.Monad.State             ( MonadState, StateT )+import           Data.IORef                      ( IORef ) import           Data.Typeable                   ( typeRep ) import           Control.Concurrent.STM          ( TVar ) import           Control.Exception               ( Exception )-import           Control.Monad.State             ( StateT, MonadState, MonadIO )+import           Control.Monad.Reader            ( ) import           Data.Aeson                      ( (.:), (.:?), withObject, withText, object                                                  , FromJSON(parseJSON), Value, KeyValue((.=))                                                  , ToJSON(toJSON), genericParseJSON, defaultOptions@@ -224,28 +228,31 @@ import           System.IO                       ( Handle ) import           Text.Read                       ( readMaybe ) import           Data.Text                       (Text)-import qualified Data.Text                       as T ( pack, unpack )+import qualified Data.Text                       as T ( pack, unpack , Text) import qualified Data.HashMap.Strict             as H+import Colog.Core ---------------------------------------------------------------------------- import           DAP.Utils                       ( capitalize, getName, genericParseJSONWithModifier, genericToJSONWithModifier )+import DAP.Log ---------------------------------------------------------------------------- -- | Core type for Debug Adaptor to send and receive messages in a type safe way. -- the state is 'AdaptorState' which holds configuration information, along with -- the current event / response being constructed and the type of the message. -- Of note: A 'StateT' is used because 'adaptorPayload' should not be shared -- with other threads.-newtype Adaptor store a =-    Adaptor (ExceptT (ErrorMessage, Maybe Message) (StateT (AdaptorState store) IO) a)+newtype Adaptor store r a =+    Adaptor (ExceptT (ErrorMessage, Maybe Message) (ReaderT (AdaptorLocal store r) (StateT AdaptorState IO)) a)   deriving newtype     ( Monad-    , MonadIO, Applicative, Functor, MonadState (AdaptorState store)+    , MonadIO, Applicative, Functor, MonadReader (AdaptorLocal store r)+    , MonadState AdaptorState     , MonadBaseControl IO     , MonadError (ErrorMessage, Maybe Message)     , MonadBase IO     ) ---------------------------------------------------------------------------- -- | The adaptor state is local to a single connection / thread-data AdaptorState app+data AdaptorState   = AdaptorState   { messageType  :: MessageType     -- ^ Current message type being created@@ -257,7 +264,12 @@     -- This should never be manually modified by the end user     -- The payload is accumulated automatically by usage of the API     ---  , appStore     :: AppStore app+    --+  }+----------------------------------------------------------------------------+-- | The adaptor local config+data AdaptorLocal app request = AdaptorLocal+  { appStore     :: AppStore app     -- ^ Global app store, accessible on a per session basis     -- Initialized during 'attach' sessions     --@@ -268,23 +280,22 @@   , handle              :: Handle     -- ^ Connection Handle     ---  , request             :: Request-    -- ^ Connection Request information     --   , address             :: SockAddr     -- ^ Address of Connection     ---  , sessionId           :: Maybe SessionId+  , sessionId           :: IORef (Maybe SessionId)     -- ^ Session ID     -- Local to the current connection's debugger session     ---  , adaptorStateMVar    :: MVar (AdaptorState app)-    -- ^ Shared state for serializable concurrency-    --   , handleLock          :: MVar ()     -- ^ A lock for writing to a Handle. One lock is created per connection     -- and exists for the duration of that connection+  , logAction          :: LogAction IO DAPLog+    -- ^ Where to send log output     --+  , request             :: request+    -- ^ Connection Request information, if we are responding to a request.   }  ----------------------------------------------------------------------------@@ -295,17 +306,15 @@ -- allows initalized debuggers to emit custom events -- when they receive messages from the debugger type AppStore app = TVar (H.HashMap SessionId (DebuggerThreadState, app))-+---------------------------------------------------------------------------- -- | 'DebuggerThreadState' -- State to hold both the thread that executes the debugger and the thread used -- to propagate output events from the debugger + debuggee to the editor (via the -- DAP server). data DebuggerThreadState   = DebuggerThreadState-  { debuggerThread :: ThreadId-  , debuggerOutputEventThread :: ThreadId+  { debuggerThreads :: [ThreadId]   }- ---------------------------------------------------------------------------- data ServerConfig   = ServerConfig@@ -318,9 +327,9 @@ -- | Used to signify a malformed message has been received data AdaptorException   = ParseException String-  | ExpectedArguments String-  | DebugSessionIdException String-  | DebuggerException String+  | ExpectedArguments T.Text+  | DebugSessionIdException T.Text+  | DebuggerException T.Text   deriving stock (Show, Eq)   deriving anyclass Exception ----------------------------------------------------------------------------@@ -876,10 +885,12 @@   | EventTypeProgressEnd   | EventTypeInvalidated   | EventTypeMemory+  | EventTypeCustom Text   deriving stock (Show, Eq, Read, Generic) ---------------------------------------------------------------------------- instance ToJSON EventType where-  toJSON = genericToJSONWithModifier+  toJSON (EventTypeCustom e) = toJSON e+  toJSON e = genericToJSONWithModifier e ---------------------------------------------------------------------------- data Command   = CommandCancel@@ -2295,11 +2306,11 @@   toJSON reason = genericToJSONWithModifier reason ---------------------------------------------------------------------------- data OutputEventCategory-  = Console-  | Important-  | Stdout-  | Stderr-  | Telemetry+  = OutputEventCategoryConsole+  | OutputEventCategoryImportant+  | OutputEventCategoryStdout+  | OutputEventCategoryStderr+  | OutputEventCategoryTelemetry   | OutputEventCategory Text   deriving stock (Show, Eq, Generic) ----------------------------------------------------------------------------@@ -2974,7 +2985,7 @@     -- ^     -- Deprecated: The code locations of the breakpoints.     ---  , setBreakpointsArgumentsSourceModified :: Bool+  , setBreakpointsArgumentsSourceModified :: Maybe Bool     -- ^     -- A value of true indicates that the underlying source has been modified     -- which results in new breakpoint locations.@@ -4019,9 +4030,3 @@ ---------------------------------------------------------------------------- instance FromJSON ThreadsArguments where    parseJSON _ = pure ThreadsArguments------------------------------------------------------------------------------data Level = DEBUG | INFO | WARN | ERROR-  deriving (Show, Eq)------------------------------------------------------------------------------data DebugStatus = SENT | RECEIVED-  deriving (Show, Eq)

@@ -32,6 +32,7 @@ import           Data.Typeable              ( Typeable, typeRep ) import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Char8      as BS+import qualified Data.Text as T ---------------------------------------------------------------------------- -- | Encodes DAP protocol message appropriately -- >@@ -110,6 +111,6 @@   } ---------------------------------------------------------------------------- -- | Log formatting util-withBraces :: BL8.ByteString -> BL8.ByteString+withBraces :: T.Text -> T.Text withBraces x  = "[" <> x <> "]" ----------------------------------------------------------------------------

@@ -106,7 +106,7 @@ -- mockServerTalk   :: Command-  -> Adaptor app ()+  -> Adaptor app Request () mockServerTalk CommandInitialize = do   sendInitializeResponse   sendInitializedEvent