-----------------------------------------------------------------------------
-- |
-- Module      :  DAP.Adaptor
-- Copyright   :  (C) 2023 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
----------------------------------------------------------------------------
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
  , runAdaptor
  , withRequest
  , getHandle
  ) where
----------------------------------------------------------------------------
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, 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 :: T.Text -> Adaptor app request ()
logWarn :: forall app request. Text -> Adaptor app request ()
logWarn Text
msg = Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
forall app request.
Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
logWithAddr Level
WARN Maybe DebugStatus
forall a. Maybe a
Nothing (Text -> Text
withBraces Text
msg)
----------------------------------------------------------------------------
logError :: T.Text -> Adaptor app request ()
logError :: forall app request. Text -> Adaptor app request ()
logError Text
msg = Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
forall app request.
Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
logWithAddr Level
ERROR Maybe DebugStatus
forall a. Maybe a
Nothing (Text -> Text
withBraces Text
msg)
----------------------------------------------------------------------------
logInfo :: T.Text -> Adaptor app request ()
logInfo :: forall app request. Text -> Adaptor app request ()
logInfo Text
msg = Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
forall app request.
Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
logWithAddr Level
INFO Maybe DebugStatus
forall a. Maybe a
Nothing (Text -> Text
withBraces Text
msg)
----------------------------------------------------------------------------
-- | Meant for internal consumption, used to signify a message has been
-- SENT from the server
debugMessage :: DebugStatus -> BL8.ByteString -> Adaptor app request ()
debugMessage :: forall app request.
DebugStatus -> ByteString -> Adaptor app request ()
debugMessage DebugStatus
dir ByteString
msg = do
#if MIN_VERSION_text(2,0,0)
  Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
forall app request.
Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
logWithAddr Level
DEBUG (DebugStatus -> Maybe DebugStatus
forall a. a -> Maybe a
Just DebugStatus
dir) (ByteString -> Text
TE.decodeUtf8Lenient (ByteString -> ByteString
BL8.toStrict ByteString
msg))
#else
  logWithAddr DEBUG (Just dir) (TE.decodeUtf8 (BL8.toStrict msg))
#endif
----------------------------------------------------------------------------
-- | Meant for external consumption
logWithAddr :: Level -> Maybe DebugStatus -> T.Text -> Adaptor app request ()
logWithAddr :: forall app request.
Level -> Maybe DebugStatus -> Text -> Adaptor app request ()
logWithAddr Level
level Maybe DebugStatus
status Text
msg = do
  addr <- Adaptor app request SockAddr
forall app request. Adaptor app request SockAddr
getAddress
  logAction <- getLogAction
  liftIO (logger logAction level addr status msg)
----------------------------------------------------------------------------
-- | Meant for external consumption
logger :: LogAction IO DAPLog -> Level -> SockAddr -> Maybe DebugStatus -> T.Text -> IO ()
logger :: LogAction IO DAPLog
-> Level -> SockAddr -> Maybe DebugStatus -> Text -> IO ()
logger LogAction IO DAPLog
logAction Level
level SockAddr
addr Maybe DebugStatus
maybeDebug Text
msg =
  LogAction IO DAPLog
logAction LogAction IO DAPLog -> DAPLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Level -> Maybe DebugStatus -> SockAddr -> Text -> DAPLog
DAPLog Level
level Maybe DebugStatus
maybeDebug SockAddr
addr Text
msg
----------------------------------------------------------------------------
getServerCapabilities :: Adaptor app request Capabilities
getServerCapabilities :: forall app request. Adaptor app request Capabilities
getServerCapabilities = (AdaptorLocal app request -> Capabilities)
-> Adaptor app request Capabilities
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ServerConfig -> Capabilities
serverCapabilities (ServerConfig -> Capabilities)
-> (AdaptorLocal app request -> ServerConfig)
-> AdaptorLocal app request
-> Capabilities
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdaptorLocal app request -> ServerConfig
forall app request. AdaptorLocal app request -> ServerConfig
serverConfig)
----------------------------------------------------------------------------
getAddress :: Adaptor app request SockAddr
getAddress :: forall app request. Adaptor app request SockAddr
getAddress = (AdaptorLocal app request -> SockAddr)
-> Adaptor app request SockAddr
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AdaptorLocal app request -> SockAddr
forall app request. AdaptorLocal app request -> SockAddr
address
----------------------------------------------------------------------------
getLogAction :: Adaptor app request (LogAction IO DAPLog)
getLogAction :: forall app request. Adaptor app request (LogAction IO DAPLog)
getLogAction = (AdaptorLocal app request -> LogAction IO DAPLog)
-> Adaptor app request (LogAction IO DAPLog)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AdaptorLocal app request -> LogAction IO DAPLog
forall app request. AdaptorLocal app request -> LogAction IO DAPLog
logAction
----------------------------------------------------------------------------
getHandle :: Adaptor app r Handle
getHandle :: forall app r. Adaptor app r Handle
getHandle = (AdaptorLocal app r -> Handle) -> Adaptor app r Handle
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AdaptorLocal app r -> Handle
forall app request. AdaptorLocal app request -> Handle
handle
----------------------------------------------------------------------------
getRequestSeqNum :: Adaptor app Request Seq
getRequestSeqNum :: forall app. Adaptor app Request Seq
getRequestSeqNum = (AdaptorLocal app Request -> Seq) -> Adaptor app Request Seq
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Request -> Seq
requestSeqNum (Request -> Seq)
-> (AdaptorLocal app Request -> Request)
-> AdaptorLocal app Request
-> Seq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdaptorLocal app Request -> Request
forall app request. AdaptorLocal app request -> request
request)
----------------------------------------------------------------------------
getDebugSessionId :: Adaptor app request SessionId
getDebugSessionId :: forall app request. Adaptor app request Text
getDebugSessionId = do
  var <- (AdaptorLocal app request -> IORef (Maybe Text))
-> Adaptor app request (IORef (Maybe Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (AdaptorLocal app request -> IORef (Maybe Text)
forall app request. AdaptorLocal app request -> IORef (Maybe Text)
sessionId)
  res <- liftIO $ readIORef var
  case res of
    Maybe Text
Nothing -> Adaptor app request Text
forall {app} {request} {a}. Adaptor app request a
sessionNotFound
    Just Text
sessionId -> Text -> Adaptor app request Text
forall a. a -> Adaptor app request a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sessionId
  where
    sessionNotFound :: Adaptor app request a
sessionNotFound = do
      let err :: String
err = String
"No Debug Session has started"
      ErrorMessage -> Maybe Message -> Adaptor app request a
forall app request a.
ErrorMessage -> Maybe Message -> Adaptor app request a
sendError (Text -> ErrorMessage
ErrorMessage (String -> Text
pack String
err)) Maybe Message
forall a. Maybe a
Nothing
----------------------------------------------------------------------------
setDebugSessionId :: SessionId -> Adaptor app request ()
setDebugSessionId :: forall app request. Text -> Adaptor app request ()
setDebugSessionId Text
session = do
  var <- (AdaptorLocal app request -> IORef (Maybe Text))
-> Adaptor app request (IORef (Maybe Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AdaptorLocal app request -> IORef (Maybe Text)
forall app request. AdaptorLocal app request -> IORef (Maybe Text)
sessionId
  liftIO $ writeIORef var (Just session)
----------------------------------------------------------------------------
registerNewDebugSession
  :: SessionId
  -> app
  -> [(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.
  --
  -- 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 request ()
registerNewDebugSession :: forall app request.
Text
-> app
-> [(Adaptor app () () -> IO ()) -> IO ()]
-> Adaptor app request ()
registerNewDebugSession Text
k app
v [(Adaptor app () () -> IO ()) -> IO ()]
debuggerConcurrentActions = do
  store <- (AdaptorLocal app request -> AppStore app)
-> Adaptor app request (AppStore app)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AdaptorLocal app request -> AppStore app
forall app request. AdaptorLocal app request -> AppStore app
appStore
  lcl <- ask
  let lcl' = AdaptorLocal app request
lcl { request = () }
  let emptyState = MessageType -> [Pair] -> AdaptorState
AdaptorState MessageType
MessageTypeEvent []
  debuggerThreadState <- liftIO $
    DebuggerThreadState
      <$> 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

----------------------------------------------------------------------------
updateDebugSession :: (app -> app) -> Adaptor app request ()
updateDebugSession :: forall app request. (app -> app) -> Adaptor app request ()
updateDebugSession app -> app
updateFun = do
  sessionId <- Adaptor app request Text
forall app request. Adaptor app request Text
getDebugSessionId
  store <- asks appStore
  liftIO . atomically $ modifyTVar' store (H.adjust (fmap updateFun) sessionId)
----------------------------------------------------------------------------
getDebugSession :: Adaptor a r a
getDebugSession :: forall a r. Adaptor a r a
getDebugSession = do
  (_, _, app) <- Adaptor a r (Text, DebuggerThreadState, a)
forall app request.
Adaptor app request (Text, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId
  pure app
----------------------------------------------------------------------------
getDebugSessionWithThreadIdAndSessionId :: Adaptor app request (SessionId, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId :: forall app request.
Adaptor app request (Text, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId = do
  sessionId <- Adaptor app request Text
forall app request. Adaptor app request Text
getDebugSessionId
  appStore <- liftIO . readTVarIO =<< getAppStore
  case H.lookup sessionId appStore of
    Maybe (DebuggerThreadState, app)
Nothing -> do
      Text -> Adaptor app request (Text, DebuggerThreadState, app)
forall {app} {request} {a}. Text -> Adaptor app request a
appNotFound Text
sessionId
    Just (DebuggerThreadState
tid, app
app) ->
      (Text, DebuggerThreadState, app)
-> Adaptor app request (Text, DebuggerThreadState, app)
forall a. a -> Adaptor app request a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
sessionId, DebuggerThreadState
tid, app
app)
  where
    appNotFound :: Text -> Adaptor app request a
appNotFound Text
sessionId = do
      let err :: String
err = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"SessionID: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
sessionId
            , String
"has no corresponding Debugger registered"
            ]
      ErrorMessage -> Maybe Message -> Adaptor app request a
forall app request a.
ErrorMessage -> Maybe Message -> Adaptor app request a
sendError (Text -> ErrorMessage
ErrorMessage (String -> Text
pack String
err)) Maybe Message
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 request ()
destroyDebugSession :: forall app request. Adaptor app request ()
destroyDebugSession = do
  (sessionId, DebuggerThreadState {..}, _) <- Adaptor app request (Text, DebuggerThreadState, app)
forall app request.
Adaptor app request (Text, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId
  store <- getAppStore
  liftIO $ do
    mapM_ killThread debuggerThreads
    atomically $ modifyTVar' store (H.delete sessionId)
  logInfo $ T.pack $ "SessionId " <> unpack sessionId <> " ended"
----------------------------------------------------------------------------
getAppStore :: Adaptor app request (AppStore app)
getAppStore :: forall app request. Adaptor app request (AppStore app)
getAppStore = (AdaptorLocal app request -> AppStore app)
-> Adaptor app request (AppStore app)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AdaptorLocal app request -> AppStore app
forall app request. AdaptorLocal app request -> AppStore app
appStore
----------------------------------------------------------------------------
getCommand :: Adaptor app Request Command
getCommand :: forall app. Adaptor app Request Command
getCommand = Request -> Command
command (Request -> Command)
-> Adaptor app Request Request -> Adaptor app Request Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AdaptorLocal app Request -> Request)
-> Adaptor app Request Request
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AdaptorLocal app Request -> Request
forall app request. AdaptorLocal app request -> 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 request ()
sendRaw :: forall value app request.
ToJSON value =>
value -> Adaptor app request ()
sendRaw value
value = do
  handle        <- Adaptor app request Handle
forall app r. Adaptor app r Handle
getHandle
  address       <- getAddress
  writeToHandle address handle 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 Request () -> Adaptor app Request ()
send :: forall app. Adaptor app Request () -> Adaptor app Request ()
send Adaptor app Request ()
action = do
  ()            <- Adaptor app Request ()
action
  cmd           <- getCommand
  handle        <- getHandle
  messageType   <- gets messageType
  address       <- getAddress
  requestSeqNum <- getRequestSeqNum
  let seqNum    =  Seq
requestSeqNum Seq -> Seq -> Seq
forall a. Num a => a -> a -> a
+ Seq
1

  -- Additional fields are required to be set for 'response' or 'reverse_request' messages.
  when (messageType == MessageTypeResponse) (setField "request_seq" requestSeqNum)
  when (messageType `elem` [MessageTypeResponse, MessageTypeRequest]) (setField "command" cmd)

  -- "seq" and "type" must be set for all protocol messages
  setField "type" messageType
  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 :: forall app request.
Adaptor app request () -> Adaptor app request ()
sendEvent Adaptor app request ()
action = do
  ()            <- Adaptor app request ()
action
  handle        <- getHandle
  messageType   <- gets messageType
  address       <- getAddress
  let errorMsg =
        Text
"Use 'send' function when responding to a DAP request, "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'sendEvent' is for responding to events"
  case messageType of
    MessageType
MessageTypeResponse ->
      ErrorMessage -> Maybe Message -> Adaptor app request ()
forall app request a.
ErrorMessage -> Maybe Message -> Adaptor app request a
sendError (Text -> ErrorMessage
ErrorMessage Text
errorMsg) Maybe Message
forall a. Maybe a
Nothing
    MessageType
MessageTypeRequest ->
      ErrorMessage -> Maybe Message -> Adaptor app request ()
forall app request a.
ErrorMessage -> Maybe Message -> Adaptor app request a
sendError (Text -> ErrorMessage
ErrorMessage Text
errorMsg) Maybe Message
forall a. Maybe a
Nothing
    MessageType
MessageTypeEvent ->
      Key -> MessageType -> Adaptor app request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"type" MessageType
messageType

  -- 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
----------------------------------------------------------------------------
writeToHandle
  :: ToJSON event
  => SockAddr
  -> Handle
  -> event
  -> Adaptor app request ()
writeToHandle :: forall event app request.
ToJSON event =>
SockAddr -> Handle -> event -> Adaptor app request ()
writeToHandle SockAddr
_ Handle
handle event
evt = do
  let msg :: ByteString
msg = event -> ByteString
forall a. ToJSON a => a -> ByteString
encodeBaseProtocolMessage event
evt
  DebugStatus -> ByteString -> Adaptor app request ()
forall app request.
DebugStatus -> ByteString -> Adaptor app request ()
debugMessage DebugStatus
SENT (ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> event -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty event
evt)
  IO () -> Adaptor app request ()
forall app request. IO () -> Adaptor app request ()
withConnectionLock (Handle -> ByteString -> IO ()
BS.hPutStr Handle
handle ByteString
msg)
----------------------------------------------------------------------------
-- | Resets Adaptor's payload
----------------------------------------------------------------------------
resetAdaptorStatePayload :: Adaptor app request ()
resetAdaptorStatePayload :: forall app request. Adaptor app request ()
resetAdaptorStatePayload = (AdaptorState -> AdaptorState) -> Adaptor app request ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((AdaptorState -> AdaptorState) -> Adaptor app request ())
-> (AdaptorState -> AdaptorState) -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ \AdaptorState
s -> AdaptorState
s { payload = [] }
----------------------------------------------------------------------------
sendSuccesfulResponse :: Adaptor app Request () -> Adaptor app Request ()
sendSuccesfulResponse :: forall app. Adaptor app Request () -> Adaptor app Request ()
sendSuccesfulResponse Adaptor app Request ()
action = do
 Adaptor app Request () -> Adaptor app Request ()
forall app. Adaptor app Request () -> Adaptor app Request ()
send (Adaptor app Request () -> Adaptor app Request ())
-> Adaptor app Request () -> Adaptor app Request ()
forall a b. (a -> b) -> a -> b
$ do
    MessageType -> Adaptor app Request ()
forall app request. MessageType -> Adaptor app request ()
setType MessageType
MessageTypeResponse
    Bool -> Adaptor app Request ()
forall app request. Bool -> Adaptor app request ()
setSuccess Bool
True
    Adaptor app Request ()
action
----------------------------------------------------------------------------
sendSuccesfulEmptyResponse :: Adaptor app Request ()
sendSuccesfulEmptyResponse :: forall app. Adaptor app Request ()
sendSuccesfulEmptyResponse = Adaptor app Request () -> Adaptor app Request ()
forall app. Adaptor app Request () -> Adaptor app Request ()
sendSuccesfulResponse (() -> Adaptor app Request ()
forall a. a -> Adaptor app Request a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
----------------------------------------------------------------------------
-- | Sends successful event
sendSuccesfulEvent
  :: EventType
  -> Adaptor app request ()
  -> Adaptor app request ()
sendSuccesfulEvent :: forall app request.
EventType -> Adaptor app request () -> Adaptor app request ()
sendSuccesfulEvent EventType
event Adaptor app request ()
action = do
  Adaptor app request () -> Adaptor app request ()
forall app request.
Adaptor app request () -> Adaptor app request ()
sendEvent (Adaptor app request () -> Adaptor app request ())
-> Adaptor app request () -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ do
    EventType -> Adaptor app request ()
forall app request. EventType -> Adaptor app request ()
setEvent EventType
event
    MessageType -> Adaptor app request ()
forall app request. MessageType -> Adaptor app request ()
setType MessageType
MessageTypeEvent
    Adaptor app request ()
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 request a
sendError :: forall app request a.
ErrorMessage -> Maybe Message -> Adaptor app request a
sendError ErrorMessage
errorMessage Maybe Message
maybeMessage = do
  (ErrorMessage, Maybe Message) -> Adaptor app request a
forall a. (ErrorMessage, Maybe Message) -> Adaptor app request a
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 Request ()
sendErrorResponse :: forall app. ErrorMessage -> Maybe Message -> Adaptor app Request ()
sendErrorResponse ErrorMessage
errorMessage Maybe Message
maybeMessage = do
  Adaptor app Request () -> Adaptor app Request ()
forall app. Adaptor app Request () -> Adaptor app Request ()
send (Adaptor app Request () -> Adaptor app Request ())
-> Adaptor app Request () -> Adaptor app Request ()
forall a b. (a -> b) -> a -> b
$ do
    MessageType -> Adaptor app Request ()
forall app request. MessageType -> Adaptor app request ()
setType MessageType
MessageTypeResponse
    Bool -> Adaptor app Request ()
forall app request. Bool -> Adaptor app request ()
setSuccess Bool
False
    ErrorMessage -> Adaptor app Request ()
forall app request. ErrorMessage -> Adaptor app request ()
setErrorMessage ErrorMessage
errorMessage
    ErrorResponse -> Adaptor app Request ()
forall value app request.
ToJSON value =>
value -> Adaptor app request ()
setBody (Maybe Message -> ErrorResponse
ErrorResponse Maybe Message
maybeMessage)
----------------------------------------------------------------------------
setErrorMessage
  :: ErrorMessage
  -> Adaptor app request ()
setErrorMessage :: forall app request. ErrorMessage -> Adaptor app request ()
setErrorMessage ErrorMessage
v = Key -> ErrorMessage -> Adaptor app request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"message" ErrorMessage
v
----------------------------------------------------------------------------
-- | Sends successful event
setSuccess
  :: Bool
  -> Adaptor app request ()
setSuccess :: forall app request. Bool -> Adaptor app request ()
setSuccess = Key -> Bool -> Adaptor app request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"success"
----------------------------------------------------------------------------
setBody
  :: ToJSON value
  => value
  -> Adaptor app request ()
setBody :: forall value app request.
ToJSON value =>
value -> Adaptor app request ()
setBody value
value = Key -> value -> Adaptor app request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"body" value
value
----------------------------------------------------------------------------
setType
  :: MessageType
  -> Adaptor app request ()
setType :: forall app request. MessageType -> Adaptor app request ()
setType MessageType
messageType = do
  (AdaptorState -> AdaptorState) -> Adaptor app request ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((AdaptorState -> AdaptorState) -> Adaptor app request ())
-> (AdaptorState -> AdaptorState) -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ \AdaptorState
adaptorState ->
    AdaptorState
adaptorState
    { messageType = messageType
    }
----------------------------------------------------------------------------
setEvent
  :: EventType
  -> Adaptor app request ()
setEvent :: forall app request. EventType -> Adaptor app request ()
setEvent = Key -> EventType -> Adaptor app request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"event"
----------------------------------------------------------------------------
setField
  :: ToJSON value
  => Key
  -> value
  -> Adaptor app request ()
setField :: forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
key value
value = do
  currentPayload <- (AdaptorState -> [Pair]) -> Adaptor app request [Pair]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AdaptorState -> [Pair]
payload
  modify' $ \AdaptorState
adaptorState ->
    AdaptorState
adaptorState
    { payload = (key .= value) : currentPayload
    }
----------------------------------------------------------------------------
withConnectionLock
  :: IO ()
  -> Adaptor app request ()
withConnectionLock :: forall app request. IO () -> Adaptor app request ()
withConnectionLock IO ()
action = do
  lock <- (AdaptorLocal app request -> MVar ())
-> Adaptor app request (MVar ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AdaptorLocal app request -> MVar ()
forall app request. AdaptorLocal app request -> MVar ()
handleLock
  liftIO (withLock lock action)
----------------------------------------------------------------------------
-- | Attempt to parse arguments from the Request
----------------------------------------------------------------------------
getArguments
  :: (Show value, FromJSON value)
  => Adaptor app Request value
getArguments :: forall value app.
(Show value, FromJSON value) =>
Adaptor app Request value
getArguments = do
  maybeArgs <- (AdaptorLocal app Request -> Maybe Value)
-> Adaptor app Request (Maybe Value)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Request -> Maybe Value
args (Request -> Maybe Value)
-> (AdaptorLocal app Request -> Request)
-> AdaptorLocal app Request
-> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdaptorLocal app Request -> Request
forall app request. AdaptorLocal app request -> request
request)
  let msg = Text
"No args found for this message"
  case maybeArgs of
    Maybe Value
Nothing -> do
      Text -> Adaptor app Request ()
forall app request. Text -> Adaptor app request ()
logError Text
msg
      IO value -> Adaptor app Request value
forall a. IO a -> Adaptor app Request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO value -> Adaptor app Request value)
-> IO value -> Adaptor app Request value
forall a b. (a -> b) -> a -> b
$ AdaptorException -> IO value
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (Text -> AdaptorException
ExpectedArguments Text
msg)
    Just Value
val ->
      case Value -> Result value
forall a. FromJSON a => Value -> Result a
fromJSON Value
val of
        Success value
r -> value -> Adaptor app Request value
forall a. a -> Adaptor app Request a
forall (f :: * -> *) a. Applicative f => a -> f a
pure value
r
        Error String
reason -> do
          Text -> Adaptor app Request ()
forall app request. Text -> Adaptor app request ()
logError (String -> Text
T.pack String
reason)
          IO value -> Adaptor app Request value
forall a. IO a -> Adaptor app Request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO value -> Adaptor app Request value)
-> IO value -> Adaptor app Request value
forall a b. (a -> b) -> a -> b
$ AdaptorException -> IO value
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> AdaptorException
ParseException String
reason)
----------------------------------------------------------------------------
-- | Evaluates Adaptor action by using and updating the state in the MVar
runAdaptorWith :: AdaptorLocal app request -> AdaptorState -> Adaptor app request () -> IO ()
runAdaptorWith :: forall app request.
AdaptorLocal app request
-> AdaptorState -> Adaptor app request () -> IO ()
runAdaptorWith AdaptorLocal app request
lcl AdaptorState
st (Adaptor ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app request) (StateT AdaptorState IO))
  ()
action) = do
  (es,final_st) <- StateT AdaptorState IO (Either (ErrorMessage, Maybe Message) ())
-> AdaptorState
-> IO (Either (ErrorMessage, Maybe Message) (), AdaptorState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT
  (AdaptorLocal app request)
  (StateT AdaptorState IO)
  (Either (ErrorMessage, Maybe Message) ())
-> AdaptorLocal app request
-> StateT AdaptorState IO (Either (ErrorMessage, Maybe Message) ())
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app request) (StateT AdaptorState IO))
  ()
-> ReaderT
     (AdaptorLocal app request)
     (StateT AdaptorState IO)
     (Either (ErrorMessage, Maybe Message) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app request) (StateT AdaptorState IO))
  ()
action) AdaptorLocal app request
lcl) AdaptorState
st
  case es of
    Left (ErrorMessage, Maybe Message)
err -> String -> IO ()
forall a. HasCallStack => String -> a
error (String
"runAdaptorWith, unhandled exception:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ErrorMessage, Maybe Message) -> String
forall a. Show a => a -> String
show (ErrorMessage, Maybe Message)
err)
    Right () -> case AdaptorState
final_st of
      AdaptorState MessageType
_ [Pair]
p ->
        if [Pair] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
p
          then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"runAdaptorWith, unexpected payload:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Pair] -> String
forall a. Show a => a -> String
show [Pair]
p
----------------------------------------------------------------------------
-- | Utility for evaluating a monad transformer stack
runAdaptor :: AdaptorLocal app Request -> AdaptorState -> Adaptor app Request () -> IO ()
runAdaptor :: forall app.
AdaptorLocal app Request
-> AdaptorState -> Adaptor app Request () -> IO ()
runAdaptor AdaptorLocal app Request
lcl AdaptorState
s (Adaptor ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app Request) (StateT AdaptorState IO))
  ()
client) =
  StateT AdaptorState IO (Either (ErrorMessage, Maybe Message) ())
-> AdaptorState
-> IO (Either (ErrorMessage, Maybe Message) (), AdaptorState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT
  (AdaptorLocal app Request)
  (StateT AdaptorState IO)
  (Either (ErrorMessage, Maybe Message) ())
-> AdaptorLocal app Request
-> StateT AdaptorState IO (Either (ErrorMessage, Maybe Message) ())
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app Request) (StateT AdaptorState IO))
  ()
-> ReaderT
     (AdaptorLocal app Request)
     (StateT AdaptorState IO)
     (Either (ErrorMessage, Maybe Message) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app Request) (StateT AdaptorState IO))
  ()
client) AdaptorLocal app Request
lcl) AdaptorState
s IO (Either (ErrorMessage, Maybe Message) (), AdaptorState)
-> ((Either (ErrorMessage, Maybe Message) (), AdaptorState)
    -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (Left (ErrorMessage
errorMessage, Maybe Message
maybeMessage), AdaptorState
s') ->
      AdaptorLocal app Request
-> AdaptorState -> Adaptor app Request () -> IO ()
forall app.
AdaptorLocal app Request
-> AdaptorState -> Adaptor app Request () -> IO ()
runAdaptor AdaptorLocal app Request
lcl AdaptorState
s' (ErrorMessage -> Maybe Message -> Adaptor app Request ()
forall app. ErrorMessage -> Maybe Message -> Adaptor app Request ()
sendErrorResponse ErrorMessage
errorMessage Maybe Message
maybeMessage)
    (Right (), AdaptorState
_) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
----------------------------------------------------------------------------

withRequest :: Request -> Adaptor app Request a -> Adaptor app r a
withRequest :: forall app a r. Request -> Adaptor app Request a -> Adaptor app r a
withRequest Request
r (Adaptor ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app Request) (StateT AdaptorState IO))
  a
client) = ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app r) (StateT AdaptorState IO))
  a
-> Adaptor app r a
forall store r a.
ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal store r) (StateT AdaptorState IO))
  a
-> Adaptor store r a
Adaptor ((ReaderT
   (AdaptorLocal app Request)
   (StateT AdaptorState IO)
   (Either (ErrorMessage, Maybe Message) a)
 -> ReaderT
      (AdaptorLocal app r)
      (StateT AdaptorState IO)
      (Either (ErrorMessage, Maybe Message) a))
-> ExceptT
     (ErrorMessage, Maybe Message)
     (ReaderT (AdaptorLocal app Request) (StateT AdaptorState IO))
     a
-> ExceptT
     (ErrorMessage, Maybe Message)
     (ReaderT (AdaptorLocal app r) (StateT AdaptorState IO))
     a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT ((AdaptorLocal app r -> AdaptorLocal app Request)
-> ReaderT
     (AdaptorLocal app Request)
     (StateT AdaptorState IO)
     (Either (ErrorMessage, Maybe Message) a)
-> ReaderT
     (AdaptorLocal app r)
     (StateT AdaptorState IO)
     (Either (ErrorMessage, Maybe Message) a)
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\AdaptorLocal app r
lcl -> AdaptorLocal app r
lcl { request = r })) ExceptT
  (ErrorMessage, Maybe Message)
  (ReaderT (AdaptorLocal app Request) (StateT AdaptorState IO))
  a
client)