-----------------------------------------------------------------------------
-- |
-- Module      :  DAP.Adaptor
-- Copyright   :  (C) 2023 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE LambdaCase                 #-}
----------------------------------------------------------------------------
module DAP.Adaptor
  ( -- * Message Construction
    setBody
  , setField
    -- * Response
  , sendSuccesfulEmptyResponse
  , sendSuccesfulResponse
  , sendErrorResponse
  -- * Events
  , sendSuccesfulEvent
  -- * Server
  , getServerCapabilities
  , withConnectionLock
  -- * Request Arguments
  , getArguments
  , getRequestSeqNum
  -- * Debug Session
  , registerNewDebugSession
  , updateDebugSession
  , getDebugSession
  , getDebugSessionId
  , destroyDebugSession
  -- * Error handling
  , sendError
  -- * Logging
  , logWarn
  , logError
  , logInfo
  , logger
  , debugMessage
  -- * Internal use
  , send
  , sendRaw
  -- * Internal function used to execute actions on behalf of the DAP server
  -- from child threads (useful for handling asynchronous debugger events).
  , runAdaptorWith
  ) 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           Data.Aeson                 ( FromJSON, Result (..), fromJSON )
import           Data.Aeson.Encode.Pretty   ( encodePretty )
import           Data.Aeson.Types           ( object, Key, KeyValue((.=)), ToJSON )
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           DAP.Types
import           DAP.Utils
import           DAP.Internal
----------------------------------------------------------------------------
logWarn :: BL8.ByteString -> Adaptor app ()
logWarn :: forall app. ByteString -> Adaptor app ()
logWarn ByteString
msg = forall app.
Level -> Maybe DebugStatus -> ByteString -> Adaptor app ()
logWithAddr Level
WARN forall a. Maybe a
Nothing (ByteString -> ByteString
withBraces ByteString
msg)
----------------------------------------------------------------------------
logError :: BL8.ByteString -> Adaptor app ()
logError :: forall app. ByteString -> Adaptor app ()
logError ByteString
msg = forall app.
Level -> Maybe DebugStatus -> ByteString -> Adaptor app ()
logWithAddr Level
ERROR forall a. Maybe a
Nothing (ByteString -> ByteString
withBraces ByteString
msg)
----------------------------------------------------------------------------
logInfo :: BL8.ByteString -> Adaptor app ()
logInfo :: forall app. ByteString -> Adaptor app ()
logInfo ByteString
msg = forall app.
Level -> Maybe DebugStatus -> ByteString -> Adaptor app ()
logWithAddr Level
INFO forall a. Maybe a
Nothing (ByteString -> ByteString
withBraces ByteString
msg)
----------------------------------------------------------------------------
-- | Meant for internal consumption, used to signify a message has been
-- SENT from the server
debugMessage :: BL8.ByteString -> Adaptor app ()
debugMessage :: forall app. ByteString -> Adaptor app ()
debugMessage ByteString
msg = do
  Bool
shouldLog <- forall app. Adaptor app Bool
getDebugLogging
  SockAddr
addr <- forall app. Adaptor app SockAddr
getAddress
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldLog
    forall a b. (a -> b) -> a -> b
$ Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
DEBUG SockAddr
addr (forall a. a -> Maybe a
Just DebugStatus
SENT) ByteString
msg
----------------------------------------------------------------------------
-- | Meant for external consumption
logWithAddr :: Level -> Maybe DebugStatus -> BL8.ByteString -> Adaptor app ()
logWithAddr :: forall app.
Level -> Maybe DebugStatus -> ByteString -> Adaptor app ()
logWithAddr Level
level Maybe DebugStatus
status ByteString
msg = do
  SockAddr
addr <- forall app. Adaptor app SockAddr
getAddress
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
level SockAddr
addr Maybe DebugStatus
status ByteString
msg)
----------------------------------------------------------------------------
-- | Meant for external consumption
logger :: Level -> SockAddr -> Maybe DebugStatus -> BL8.ByteString -> IO ()
logger :: Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
level SockAddr
addr Maybe DebugStatus
maybeDebug ByteString
msg = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
withGlobalLock
    forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
BL8.putStrLn ByteString
formatted
  where
    formatted :: ByteString
formatted
      = [ByteString] -> ByteString
BL8.concat
      [ ByteString -> ByteString
withBraces forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BL8.pack (forall a. Show a => a -> [Char]
show SockAddr
addr)
      , ByteString -> ByteString
withBraces forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BL8.pack (forall a. Show a => a -> [Char]
show Level
level)
      , forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (ByteString -> ByteString
withBraces forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BL8.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) Maybe DebugStatus
maybeDebug
      , ByteString
msg
      ]
----------------------------------------------------------------------------
getDebugLogging :: Adaptor app Bool
getDebugLogging :: forall app. Adaptor app Bool
getDebugLogging = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ServerConfig -> Bool
debugLogging forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall app. AdaptorState app -> ServerConfig
serverConfig)
----------------------------------------------------------------------------
getServerCapabilities :: Adaptor app Capabilities
getServerCapabilities :: forall app. Adaptor app Capabilities
getServerCapabilities = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (ServerConfig -> Capabilities
serverCapabilities forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall app. AdaptorState app -> ServerConfig
serverConfig)
----------------------------------------------------------------------------
getAddress :: Adaptor app SockAddr
getAddress :: forall app. Adaptor app SockAddr
getAddress = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> SockAddr
address
----------------------------------------------------------------------------
getHandle :: Adaptor app Handle
getHandle :: forall app. Adaptor app Handle
getHandle = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> Handle
handle
----------------------------------------------------------------------------
getRequestSeqNum :: Adaptor app Seq
getRequestSeqNum :: forall app. Adaptor app Seq
getRequestSeqNum = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Request -> Seq
requestSeqNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall app. AdaptorState app -> Request
request)
----------------------------------------------------------------------------
getDebugSessionId :: Adaptor app SessionId
getDebugSessionId :: forall app. Adaptor app SessionId
getDebugSessionId = do
  forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> Maybe SessionId
sessionId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe SessionId
Nothing -> forall {app} {a}. Adaptor app a
sessionNotFound
    Just SessionId
sessionId -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SessionId
sessionId
  where
    sessionNotFound :: Adaptor app a
sessionNotFound = do
      let err :: [Char]
err = [Char]
"No Debug Session has started"
      forall app a. ErrorMessage -> Maybe Message -> Adaptor app a
sendError (SessionId -> ErrorMessage
ErrorMessage ([Char] -> SessionId
pack [Char]
err)) forall a. Maybe a
Nothing
----------------------------------------------------------------------------
setDebugSessionId :: SessionId -> Adaptor app ()
setDebugSessionId :: forall app. SessionId -> Adaptor app ()
setDebugSessionId SessionId
session = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \AdaptorState app
s -> AdaptorState app
s { sessionId :: Maybe SessionId
sessionId = forall a. a -> Maybe a
Just SessionId
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
  -- 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.
  --
  -- This event handler thread also takes an argument that allows any child thread to execute
  -- events on behalf of the DAP server (in 'Adaptor app ()'). This function should always be
  -- used when sending events to the editor from the debugger (or from any forked thread).
  --
  -- >
  -- > registerNewDebugSession sessionId appState loadDebugger $ \withAdaptor ->
  -- >   forever $ getDebuggerOutput >>= \output -> do
  -- >     withAdaptor $ sendOutputEvent defaultOutputEvent { outputEventOutput = output }
  -- >
  --
  -> Adaptor app ()
registerNewDebugSession :: forall app.
SessionId
-> app
-> IO ()
-> ((Adaptor app () -> IO ()) -> IO ())
-> Adaptor app ()
registerNewDebugSession SessionId
k app
v IO ()
debuggerExecution (Adaptor app () -> IO ()) -> IO ()
outputEventSink = do
  AppStore app
store <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> AppStore app
appStore
  MVar (AdaptorState app)
adaptorStateMVar <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> MVar (AdaptorState app)
adaptorStateMVar
  DebuggerThreadState
debuggerThreadState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    ThreadId -> ThreadId -> DebuggerThreadState
DebuggerThreadState
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork IO ()
debuggerExecution
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork ((Adaptor app () -> IO ()) -> IO ()
outputEventSink (forall app. MVar (AdaptorState app) -> Adaptor app () -> IO ()
runAdaptorWith MVar (AdaptorState app)
adaptorStateMVar))
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' AppStore app
store (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert SessionId
k (DebuggerThreadState
debuggerThreadState, app
v))
  forall app. SessionId -> Adaptor app ()
setDebugSessionId SessionId
k
  forall app. ByteString -> Adaptor app ()
logInfo forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BL8.pack forall a b. (a -> b) -> a -> b
$ [Char]
"Registered new debug session: " forall a. Semigroup a => a -> a -> a
<> SessionId -> [Char]
unpack SessionId
k
----------------------------------------------------------------------------
updateDebugSession :: (app -> app) -> Adaptor app ()
updateDebugSession :: forall app. (app -> app) -> Adaptor app ()
updateDebugSession app -> app
updateFun = do
  SessionId
sessionId <- forall app. Adaptor app SessionId
getDebugSessionId
  AppStore app
store <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> AppStore app
appStore
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' AppStore app
store (forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
H.adjust (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap app -> app
updateFun) SessionId
sessionId)
----------------------------------------------------------------------------
getDebugSession :: Adaptor a a
getDebugSession :: forall a. Adaptor a a
getDebugSession = do
  (SessionId
_, DebuggerThreadState
_, a
app) <- forall app. Adaptor app (SessionId, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId
  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
app
----------------------------------------------------------------------------
getDebugSessionWithThreadIdAndSessionId :: Adaptor app (SessionId, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId :: forall app. Adaptor app (SessionId, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId = do
  SessionId
sessionId <- forall app. Adaptor app SessionId
getDebugSessionId
  HashMap SessionId (DebuggerThreadState, app)
appStore <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> IO a
readTVarIO forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall app. Adaptor app (AppStore app)
getAppStore
  case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup SessionId
sessionId HashMap SessionId (DebuggerThreadState, app)
appStore of
    Maybe (DebuggerThreadState, app)
Nothing -> do
      forall {app} {a}. SessionId -> Adaptor app a
appNotFound SessionId
sessionId
    Just (DebuggerThreadState
tid, app
app) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionId
sessionId, DebuggerThreadState
tid, app
app)
  where
    appNotFound :: SessionId -> Adaptor app a
appNotFound SessionId
sessionId = do
      let err :: [Char]
err = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [Char]
"SessionID: " forall a. Semigroup a => a -> a -> a
<> SessionId -> [Char]
unpack SessionId
sessionId
            , [Char]
"has no corresponding Debugger registered"
            ]
      forall app a. ErrorMessage -> Maybe Message -> Adaptor app a
sendError (SessionId -> ErrorMessage
ErrorMessage ([Char] -> SessionId
pack [Char]
err)) forall a. Maybe a
Nothing
----------------------------------------------------------------------------
-- | 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 :: forall app. Adaptor app ()
destroyDebugSession = do
  (SessionId
sessionId, DebuggerThreadState {ThreadId
debuggerOutputEventThread :: DebuggerThreadState -> ThreadId
debuggerThread :: DebuggerThreadState -> ThreadId
debuggerOutputEventThread :: ThreadId
debuggerThread :: ThreadId
..}, app
_) <- forall app. Adaptor app (SessionId, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId
  AppStore app
store <- forall app. Adaptor app (AppStore app)
getAppStore
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). MonadBase IO m => ThreadId -> m ()
killThread ThreadId
debuggerThread
    forall (m :: * -> *). MonadBase IO m => ThreadId -> m ()
killThread ThreadId
debuggerOutputEventThread
    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' AppStore app
store (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete SessionId
sessionId)
  forall app. ByteString -> Adaptor app ()
logInfo forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
BL8.pack forall a b. (a -> b) -> a -> b
$ [Char]
"SessionId " forall a. Semigroup a => a -> a -> a
<> SessionId -> [Char]
unpack SessionId
sessionId forall a. Semigroup a => a -> a -> a
<> [Char]
" ended"
----------------------------------------------------------------------------
getAppStore :: Adaptor app (AppStore app)
getAppStore :: forall app. Adaptor app (AppStore app)
getAppStore = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> AppStore app
appStore
----------------------------------------------------------------------------
getCommand :: Adaptor app Command
getCommand :: forall app. Adaptor app Command
getCommand = Request -> Command
command forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> Request
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 :: forall value app. ToJSON value => value -> Adaptor app ()
sendRaw value
value = do
  Handle
handle        <- forall app. Adaptor app Handle
getHandle
  SockAddr
address       <- forall app. Adaptor app SockAddr
getAddress
  forall event app.
ToJSON event =>
SockAddr -> Handle -> event -> Adaptor app ()
writeToHandle SockAddr
address Handle
handle value
value
----------------------------------------------------------------------------
-- | Function for constructing a payload and writing bytes to a socket.
-- This function takes care of incrementing sequence numbers
-- and setting fields automatically that are required for 'response' messages.
-- i.e. "request_seq" and "command".
-- We also have to be sure to reset the message payload
----------------------------------------------------------------------------
send :: Adaptor app () -> Adaptor app ()
send :: forall app. Adaptor app () -> Adaptor app ()
send Adaptor app ()
action = do
  ()            <- Adaptor app ()
action
  Command
cmd           <- forall app. Adaptor app Command
getCommand
  Handle
handle        <- forall app. Adaptor app Handle
getHandle
  MessageType
messageType   <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> MessageType
messageType
  SockAddr
address       <- forall app. Adaptor app SockAddr
getAddress
  Seq
requestSeqNum <- forall app. Adaptor app Seq
getRequestSeqNum
  let seqNum :: Seq
seqNum    =  Seq
requestSeqNum forall a. Num a => a -> a -> a
+ Seq
1

  -- Additional fields are required to be set for 'response' or 'reverse_request' messages.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MessageType
messageType forall a. Eq a => a -> a -> Bool
== MessageType
MessageTypeResponse) (forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
"request_seq" Seq
requestSeqNum)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MessageType
messageType forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MessageType
MessageTypeResponse, MessageType
MessageTypeRequest]) (forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
"command" Command
cmd)

  -- "seq" and "type" must be set for all protocol messages
  forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
"type" MessageType
messageType
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (MessageType
messageType forall a. Eq a => a -> a -> Bool
== MessageType
MessageTypeEvent) forall a b. (a -> b) -> a -> b
$
    forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
"seq" Seq
seqNum

  -- Once all fields are set, fetch the payload for sending
  Value
payload <- [Pair] -> Value
object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> [Pair]
payload

  -- Send payload to client from debug adaptor
  forall event app.
ToJSON event =>
SockAddr -> Handle -> event -> Adaptor app ()
writeToHandle SockAddr
address Handle
handle Value
payload

  -- Reset payload each time a send occurs
  forall app. Adaptor app ()
resetAdaptorStatePayload
----------------------------------------------------------------------------
-- | Writes payload to the given 'Handle' using the local connection lock
----------------------------------------------------------------------------
writeToHandle
  :: ToJSON event
  => SockAddr
  -> Handle
  -> event
  -> Adaptor app ()
writeToHandle :: forall event app.
ToJSON event =>
SockAddr -> Handle -> event -> Adaptor app ()
writeToHandle SockAddr
_ Handle
handle event
evt = do
  let msg :: ByteString
msg = forall a. ToJSON a => a -> ByteString
encodeBaseProtocolMessage event
evt
  forall app. ByteString -> Adaptor app ()
debugMessage (ByteString
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. ToJSON a => a -> ByteString
encodePretty event
evt)
  forall app. IO () -> Adaptor app ()
withConnectionLock (Handle -> ByteString -> IO ()
BS.hPutStr Handle
handle ByteString
msg)
----------------------------------------------------------------------------
-- | Resets Adaptor's payload
----------------------------------------------------------------------------
resetAdaptorStatePayload :: Adaptor app ()
resetAdaptorStatePayload :: forall app. Adaptor app ()
resetAdaptorStatePayload = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \AdaptorState app
s -> AdaptorState app
s { payload :: [Pair]
payload = [] }
----------------------------------------------------------------------------
sendSuccesfulResponse :: Adaptor app () -> Adaptor app ()
sendSuccesfulResponse :: forall app. Adaptor app () -> Adaptor app ()
sendSuccesfulResponse Adaptor app ()
action = do
 forall app. Adaptor app () -> Adaptor app ()
send forall a b. (a -> b) -> a -> b
$ do
    forall app. MessageType -> Adaptor app ()
setType MessageType
MessageTypeResponse
    forall app. Bool -> Adaptor app ()
setSuccess Bool
True
    Adaptor app ()
action
----------------------------------------------------------------------------
sendSuccesfulEmptyResponse :: Adaptor app ()
sendSuccesfulEmptyResponse :: forall app. Adaptor app ()
sendSuccesfulEmptyResponse = forall app. Adaptor app () -> Adaptor app ()
sendSuccesfulResponse (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
----------------------------------------------------------------------------
-- | Sends successful event
sendSuccesfulEvent :: EventType -> Adaptor app () -> Adaptor app ()
sendSuccesfulEvent :: forall app. EventType -> Adaptor app () -> Adaptor app ()
sendSuccesfulEvent EventType
event Adaptor app ()
action = do
  forall app. Adaptor app () -> Adaptor app ()
send forall a b. (a -> b) -> a -> b
$ do
    forall app. EventType -> Adaptor app ()
setEvent EventType
event
    forall app. MessageType -> Adaptor app ()
setType MessageType
MessageTypeEvent
    Adaptor app ()
action
----------------------------------------------------------------------------
-- | Raises an error
-- Meant abort the current reqeust / response cycle, prematurely sending an 'ErrorResponse'
-- <https://microsoft.github.io/debug-adapter-protocol/specification#Base_Protocol_ErrorResponse>
--
sendError
  :: ErrorMessage
  -> Maybe Message
  -> Adaptor app a
sendError :: forall app a. ErrorMessage -> Maybe Message -> Adaptor app a
sendError ErrorMessage
errorMessage Maybe Message
maybeMessage = do
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ErrorMessage
errorMessage, Maybe Message
maybeMessage)
----------------------------------------------------------------------------
-- | Sends unsuccessful response
-- Only used internally within the Server module
sendErrorResponse
  :: ErrorMessage
  -> Maybe Message
  -> Adaptor app ()
sendErrorResponse :: forall app. ErrorMessage -> Maybe Message -> Adaptor app ()
sendErrorResponse ErrorMessage
errorMessage Maybe Message
maybeMessage = do
  forall app. Adaptor app () -> Adaptor app ()
send forall a b. (a -> b) -> a -> b
$ do
    forall app. MessageType -> Adaptor app ()
setType MessageType
MessageTypeResponse
    forall app. Bool -> Adaptor app ()
setSuccess Bool
False
    forall app. ErrorMessage -> Adaptor app ()
setErrorMessage ErrorMessage
errorMessage
    forall value app. ToJSON value => value -> Adaptor app ()
setBody (Maybe Message -> ErrorResponse
ErrorResponse Maybe Message
maybeMessage)
----------------------------------------------------------------------------
setErrorMessage
  :: ErrorMessage
  -> Adaptor app ()
setErrorMessage :: forall app. ErrorMessage -> Adaptor app ()
setErrorMessage ErrorMessage
v = forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
"message" ErrorMessage
v
----------------------------------------------------------------------------
-- | Sends successful event
setSuccess
  :: Bool
  -> Adaptor app ()
setSuccess :: forall app. Bool -> Adaptor app ()
setSuccess = forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
"success"
----------------------------------------------------------------------------
setBody
  :: ToJSON value
  => value
  -> Adaptor app ()
setBody :: forall value app. ToJSON value => value -> Adaptor app ()
setBody value
value = forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
"body" value
value
----------------------------------------------------------------------------
setType
  :: MessageType
  -> Adaptor app ()
setType :: forall app. MessageType -> Adaptor app ()
setType MessageType
messageType = do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \AdaptorState app
adaptorState ->
    AdaptorState app
adaptorState
    { messageType :: MessageType
messageType = MessageType
messageType
    }
----------------------------------------------------------------------------
setEvent
  :: EventType
  -> Adaptor app ()
setEvent :: forall app. EventType -> Adaptor app ()
setEvent = forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
"event"
----------------------------------------------------------------------------
setField
  :: ToJSON value
  => Key
  -> value
  -> Adaptor app ()
setField :: forall value app. ToJSON value => Key -> value -> Adaptor app ()
setField Key
key value
value = do
  [Pair]
currentPayload <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> [Pair]
payload
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \AdaptorState app
adaptorState ->
    AdaptorState app
adaptorState
    { payload :: [Pair]
payload = (Key
key forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= value
value) forall a. a -> [a] -> [a]
: [Pair]
currentPayload
    }
----------------------------------------------------------------------------
withConnectionLock
  :: IO ()
  -> Adaptor app ()
withConnectionLock :: forall app. IO () -> Adaptor app ()
withConnectionLock IO ()
action = do
  MVar ()
lock <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> MVar ()
handleLock
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar () -> IO () -> IO ()
withLock MVar ()
lock IO ()
action)
----------------------------------------------------------------------------
-- | Attempt to parse arguments from the Request
----------------------------------------------------------------------------
getArguments
  :: (Show value, FromJSON value)
  => Adaptor app value
getArguments :: forall value app. (Show value, FromJSON value) => Adaptor app value
getArguments = do
  Maybe Value
maybeArgs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Request -> Maybe Value
args forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall app. AdaptorState app -> Request
request)
  let msg :: [Char]
msg = [Char]
"No args found for this message"
  case Maybe Value
maybeArgs of
    Maybe Value
Nothing -> do
      forall app. ByteString -> Adaptor app ()
logError ([Char] -> ByteString
BL8.pack [Char]
msg)
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO ([Char] -> AdaptorException
ExpectedArguments [Char]
msg)
    Just Value
val ->
      case forall a. FromJSON a => Value -> Result a
fromJSON Value
val of
        Success value
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure value
r
        Result value
x -> do
          forall app. ByteString -> Adaptor app ()
logError ([Char] -> ByteString
BL8.pack (forall a. Show a => a -> [Char]
show Result value
x))
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO ([Char] -> AdaptorException
ParseException (forall a. Show a => a -> [Char]
show Result value
x))

----------------------------------------------------------------------------
-- | Evaluates Adaptor action by using and updating the state in the MVar
runAdaptorWith :: MVar (AdaptorState app) -> Adaptor app () -> IO ()
runAdaptorWith :: forall app. MVar (AdaptorState app) -> Adaptor app () -> IO ()
runAdaptorWith MVar (AdaptorState app)
adaptorStateMVar Adaptor app ()
action = do
  forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (AdaptorState app)
adaptorStateMVar (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall app.
AdaptorState app -> Adaptor app () -> IO (AdaptorState app)
runAdaptor (forall app. Adaptor app ()
resetAdaptorStatePayload forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Adaptor app ()
action))

----------------------------------------------------------------------------
-- | Utility for evaluating a monad transformer stack
runAdaptor :: AdaptorState app -> Adaptor app () -> IO (AdaptorState app)
runAdaptor :: forall app.
AdaptorState app -> Adaptor app () -> IO (AdaptorState app)
runAdaptor AdaptorState app
adaptorState (Adaptor ExceptT
  (ErrorMessage, Maybe Message) (StateT (AdaptorState app) IO) ()
client) =
  forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
  (ErrorMessage, Maybe Message) (StateT (AdaptorState app) IO) ()
client) AdaptorState app
adaptorState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Left (ErrorMessage
errorMessage, Maybe Message
maybeMessage), AdaptorState app
nextState) ->
      forall app.
AdaptorState app -> Adaptor app () -> IO (AdaptorState app)
runAdaptor AdaptorState app
nextState (forall app. ErrorMessage -> Maybe Message -> Adaptor app ()
sendErrorResponse ErrorMessage
errorMessage Maybe Message
maybeMessage)
    (Right (), AdaptorState app
nextState) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure AdaptorState app
nextState