-----------------------------------------------------------------------------
-- |
-- 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
  -- * Reverse Requests
  , sendReverseRequest
  , sendRunInTerminalReverseRequest
  -- * Server
  , getServerCapabilities
  , withConnectionLock
  -- * Request Arguments
  , getArguments
  , getRequestSeqNum
  , getReverseRequestResponseBody
  -- * 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
  SockAddr
addr <- Adaptor app request SockAddr
forall app request. Adaptor app request SockAddr
getAddress
  LogAction IO DAPLog
logAction <- Adaptor app request (LogAction IO DAPLog)
forall app request. Adaptor app request (LogAction IO DAPLog)
getLogAction
  IO () -> Adaptor app request ()
forall a. IO a -> Adaptor app request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LogAction IO DAPLog
-> Level -> SockAddr -> Maybe DebugStatus -> Text -> IO ()
logger LogAction IO DAPLog
logAction Level
level SockAddr
addr Maybe DebugStatus
status Text
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
  IORef (Maybe Text)
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)
  Maybe Text
res <- IO (Maybe Text) -> Adaptor app request (Maybe Text)
forall a. IO a -> Adaptor app request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> Adaptor app request (Maybe Text))
-> IO (Maybe Text) -> Adaptor app request (Maybe Text)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Text) -> IO (Maybe Text)
forall a. IORef a -> IO a
readIORef IORef (Maybe Text)
var
  case Maybe Text
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
  IORef (Maybe Text)
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
  IO () -> Adaptor app request ()
forall a. IO a -> Adaptor app request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Adaptor app request ())
-> IO () -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe Text) -> Maybe Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Text)
var (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
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
  AppStore app
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
  AdaptorLocal app request
lcl <- Adaptor app request (AdaptorLocal app request)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let lcl' :: AdaptorLocal app ()
lcl' = AdaptorLocal app request
lcl { request = () }
  let emptyState :: AdaptorState
emptyState = MessageType -> [Pair] -> AdaptorState
AdaptorState MessageType
MessageTypeEvent []
  DebuggerThreadState
debuggerThreadState <- IO DebuggerThreadState -> Adaptor app request DebuggerThreadState
forall a. IO a -> Adaptor app request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DebuggerThreadState -> Adaptor app request DebuggerThreadState)
-> IO DebuggerThreadState
-> Adaptor app request DebuggerThreadState
forall a b. (a -> b) -> a -> b
$
    [ThreadId] -> DebuggerThreadState
DebuggerThreadState
      ([ThreadId] -> DebuggerThreadState)
-> IO [ThreadId] -> IO DebuggerThreadState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO ThreadId] -> IO [ThreadId]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [IO () -> IO ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (Adaptor app () () -> IO ()) -> IO ()
action (AdaptorLocal app () -> AdaptorState -> Adaptor app () () -> IO ()
forall app request.
AdaptorLocal app request
-> AdaptorState -> Adaptor app request () -> IO ()
runAdaptorWith AdaptorLocal app ()
lcl' AdaptorState
emptyState) | (Adaptor app () () -> IO ()) -> IO ()
action <- [(Adaptor app () () -> IO ()) -> IO ()]
debuggerConcurrentActions]
  IO () -> Adaptor app request ()
forall a. IO a -> Adaptor app request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Adaptor app request ())
-> (STM () -> IO ()) -> STM () -> Adaptor app request ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> Adaptor app request ())
-> STM () -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ AppStore app
-> (HashMap Text (DebuggerThreadState, app)
    -> HashMap Text (DebuggerThreadState, app))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' AppStore app
store (Text
-> (DebuggerThreadState, app)
-> HashMap Text (DebuggerThreadState, app)
-> HashMap Text (DebuggerThreadState, app)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
k (DebuggerThreadState
debuggerThreadState, app
v))
  Text -> Adaptor app request ()
forall app request. Text -> Adaptor app request ()
logInfo (Text -> Adaptor app request ()) -> Text -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Registered new debug session: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
k
  Text -> Adaptor app request ()
forall app request. Text -> Adaptor app request ()
setDebugSessionId Text
k

----------------------------------------------------------------------------
updateDebugSession :: (app -> app) -> Adaptor app request ()
updateDebugSession :: forall app request. (app -> app) -> Adaptor app request ()
updateDebugSession app -> app
updateFun = do
  Text
sessionId <- Adaptor app request Text
forall app request. Adaptor app request Text
getDebugSessionId
  AppStore app
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
  IO () -> Adaptor app request ()
forall a. IO a -> Adaptor app request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Adaptor app request ())
-> (STM () -> IO ()) -> STM () -> Adaptor app request ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> Adaptor app request ())
-> STM () -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ AppStore app
-> (HashMap Text (DebuggerThreadState, app)
    -> HashMap Text (DebuggerThreadState, app))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' AppStore app
store (((DebuggerThreadState, app) -> (DebuggerThreadState, app))
-> Text
-> HashMap Text (DebuggerThreadState, app)
-> HashMap Text (DebuggerThreadState, app)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
H.adjust ((app -> app)
-> (DebuggerThreadState, app) -> (DebuggerThreadState, app)
forall a b.
(a -> b) -> (DebuggerThreadState, a) -> (DebuggerThreadState, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap app -> app
updateFun) Text
sessionId)
----------------------------------------------------------------------------
getDebugSession :: Adaptor a r a
getDebugSession :: forall a r. Adaptor a r a
getDebugSession = do
  (Text
_, DebuggerThreadState
_, a
app) <- Adaptor a r (Text, DebuggerThreadState, a)
forall app request.
Adaptor app request (Text, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId
  a -> Adaptor a r a
forall a. a -> Adaptor a r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
app
----------------------------------------------------------------------------
getDebugSessionWithThreadIdAndSessionId :: Adaptor app request (SessionId, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId :: forall app request.
Adaptor app request (Text, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId = do
  Text
sessionId <- Adaptor app request Text
forall app request. Adaptor app request Text
getDebugSessionId
  HashMap Text (DebuggerThreadState, app)
appStore <- IO (HashMap Text (DebuggerThreadState, app))
-> Adaptor app request (HashMap Text (DebuggerThreadState, app))
forall a. IO a -> Adaptor app request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap Text (DebuggerThreadState, app))
 -> Adaptor app request (HashMap Text (DebuggerThreadState, app)))
-> (TVar (HashMap Text (DebuggerThreadState, app))
    -> IO (HashMap Text (DebuggerThreadState, app)))
-> TVar (HashMap Text (DebuggerThreadState, app))
-> Adaptor app request (HashMap Text (DebuggerThreadState, app))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (HashMap Text (DebuggerThreadState, app))
-> IO (HashMap Text (DebuggerThreadState, app))
forall a. TVar a -> IO a
readTVarIO (TVar (HashMap Text (DebuggerThreadState, app))
 -> Adaptor app request (HashMap Text (DebuggerThreadState, app)))
-> Adaptor
     app request (TVar (HashMap Text (DebuggerThreadState, app)))
-> Adaptor app request (HashMap Text (DebuggerThreadState, app))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Adaptor
  app request (TVar (HashMap Text (DebuggerThreadState, app)))
forall app request. Adaptor app request (AppStore app)
getAppStore
  case Text
-> HashMap Text (DebuggerThreadState, app)
-> Maybe (DebuggerThreadState, app)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
sessionId HashMap Text (DebuggerThreadState, app)
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
  (Text
sessionId, DebuggerThreadState {[ThreadId]
debuggerThreads :: [ThreadId]
debuggerThreads :: DebuggerThreadState -> [ThreadId]
..}, app
_) <- Adaptor app request (Text, DebuggerThreadState, app)
forall app request.
Adaptor app request (Text, DebuggerThreadState, app)
getDebugSessionWithThreadIdAndSessionId
  AppStore app
store <- Adaptor app request (AppStore app)
forall app request. Adaptor app request (AppStore app)
getAppStore
  IO () -> Adaptor app request ()
forall a. IO a -> Adaptor app request a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Adaptor app request ())
-> IO () -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ do
    (ThreadId -> IO ()) -> [ThreadId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
forall (m :: * -> *). MonadBase IO m => ThreadId -> m ()
killThread [ThreadId]
debuggerThreads
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ AppStore app
-> (HashMap Text (DebuggerThreadState, app)
    -> HashMap Text (DebuggerThreadState, app))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' AppStore app
store (Text
-> HashMap Text (DebuggerThreadState, app)
-> HashMap Text (DebuggerThreadState, app)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete Text
sessionId)
  Text -> Adaptor app request ()
forall app request. Text -> Adaptor app request ()
logInfo (Text -> Adaptor app request ()) -> Text -> Adaptor app request ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"SessionId " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
sessionId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" 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
handle        <- Adaptor app request Handle
forall app r. Adaptor app r Handle
getHandle
  SockAddr
address       <- Adaptor app request SockAddr
forall app request. Adaptor app request SockAddr
getAddress
  SockAddr -> Handle -> value -> Adaptor app request ()
forall event app request.
ToJSON event =>
SockAddr -> Handle -> event -> Adaptor app request ()
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 Request () -> Adaptor app Request ()
send :: forall app. Adaptor app Request () -> Adaptor app Request ()
send Adaptor app Request ()
action = do
  ()            <- Adaptor app Request ()
action
  Command
cmd           <- Adaptor app Request Command
forall app. Adaptor app Request Command
getCommand
  Handle
handle        <- Adaptor app Request Handle
forall app r. Adaptor app r Handle
getHandle
  MessageType
messageType   <- (AdaptorState -> MessageType) -> Adaptor app Request MessageType
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AdaptorState -> MessageType
messageType
  SockAddr
address       <- Adaptor app Request SockAddr
forall app request. Adaptor app request SockAddr
getAddress
  Seq
requestSeqNum <- Adaptor app Request Seq
forall app. Adaptor app Request Seq
getRequestSeqNum
  let seqNum :: Seq
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.
  Bool -> Adaptor app Request () -> Adaptor app Request ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MessageType
messageType MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
MessageTypeResponse) (Key -> Seq -> Adaptor app Request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"request_seq" Seq
requestSeqNum)
  Bool -> Adaptor app Request () -> Adaptor app Request ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MessageType
messageType MessageType -> [MessageType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MessageType
MessageTypeResponse, MessageType
MessageTypeRequest]) (Key -> Command -> Adaptor app Request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"command" Command
cmd)

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

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

  -- Send payload to client from debug adaptor
  SockAddr -> Handle -> Value -> Adaptor app Request ()
forall event app request.
ToJSON event =>
SockAddr -> Handle -> event -> Adaptor app request ()
writeToHandle SockAddr
address Handle
handle Value
payload
  Adaptor app Request ()
forall app request. Adaptor app request ()
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
handle        <- Adaptor app request Handle
forall app r. Adaptor app r Handle
getHandle
  MessageType
messageType   <- (AdaptorState -> MessageType) -> Adaptor app request MessageType
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AdaptorState -> MessageType
messageType
  SockAddr
address       <- Adaptor app request SockAddr
forall app request. Adaptor app request SockAddr
getAddress
  let errorMsg :: Text
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
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
  Value
payload <- [Pair] -> Value
object ([Pair] -> Value)
-> Adaptor app request [Pair] -> Adaptor app request Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AdaptorState -> [Pair]) -> Adaptor app request [Pair]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AdaptorState -> [Pair]
payload
  -- Send payload to client from debug adaptor
  SockAddr -> Handle -> Value -> Adaptor app request ()
forall event app request.
ToJSON event =>
SockAddr -> Handle -> event -> Adaptor app request ()
writeToHandle SockAddr
address Handle
handle Value
payload
  Adaptor app request ()
forall app request. Adaptor app request ()
resetAdaptorStatePayload
----------------------------------------------------------------------------
-- | Write reverse request to Handle
sendReverseRequest
  :: ReverseCommand
  -> Adaptor app Request ()
sendReverseRequest :: forall app. ReverseCommand -> Adaptor app Request ()
sendReverseRequest ReverseCommand
rcmd = 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
  Key -> MessageType -> Adaptor app Request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"type" MessageType
MessageTypeRequest
  Key -> ReverseCommand -> Adaptor app Request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"command" ReverseCommand
rcmd
----------------------------------------------------------------------------
-- | Send runInTerminal reverse request
sendRunInTerminalReverseRequest :: RunInTerminalRequestArguments -> Adaptor app Request ()
sendRunInTerminalReverseRequest :: forall app. RunInTerminalRequestArguments -> Adaptor app Request ()
sendRunInTerminalReverseRequest RunInTerminalRequestArguments
args = do
  Key -> RunInTerminalRequestArguments -> Adaptor app Request ()
forall value app request.
ToJSON value =>
Key -> value -> Adaptor app request ()
setField Key
"arguments" RunInTerminalRequestArguments
args
  ReverseCommand -> Adaptor app Request ()
forall app. ReverseCommand -> Adaptor app Request ()
sendReverseRequest ReverseCommand
ReverseCommandRunInTerminal

----------------------------------------------------------------------------
-- | 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
  [Pair]
currentPayload <- (AdaptorState -> [Pair]) -> Adaptor app request [Pair]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets AdaptorState -> [Pair]
payload
  (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
    { payload = (key .= value) : currentPayload
    }
----------------------------------------------------------------------------
withConnectionLock
  :: IO ()
  -> Adaptor app request ()
withConnectionLock :: forall app request. IO () -> Adaptor app request ()
withConnectionLock IO ()
action = do
  MVar ()
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
  IO () -> Adaptor app request ()
forall a. IO a -> Adaptor app request a
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 Request value
getArguments :: forall value app.
(Show value, FromJSON value) =>
Adaptor app Request value
getArguments = do
  Maybe Value
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
msg = Text
"No args found for this message"
  case Maybe Value
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. 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. Exception e => e -> IO a
throwIO (String -> AdaptorException
ParseException String
reason)
----------------------------------------------------------------------------
-- | Attempt to parse arguments from a ReverseRequestResponse (not in env)
----------------------------------------------------------------------------
getReverseRequestResponseBody
  :: (Show value, FromJSON value)
  => ReverseRequestResponse -> Adaptor app r value
getReverseRequestResponseBody :: forall value app r.
(Show value, FromJSON value) =>
ReverseRequestResponse -> Adaptor app r value
getReverseRequestResponseBody ReverseRequestResponse
resp = do
  let maybeArgs :: Maybe Value
maybeArgs = ReverseRequestResponse -> Maybe Value
body ReverseRequestResponse
resp
  let msg :: Text
msg = Text
"No args found for this message"
  case Maybe Value
maybeArgs of
    Maybe Value
Nothing -> do
      Text -> Adaptor app r ()
forall app request. Text -> Adaptor app request ()
logError Text
msg
      IO value -> Adaptor app r value
forall a. IO a -> Adaptor app r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO value -> Adaptor app r value)
-> IO value -> Adaptor app r value
forall a b. (a -> b) -> a -> b
$ AdaptorException -> IO value
forall e a. 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 r value
forall a. a -> Adaptor app r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure value
r
        Error String
reason -> do
          Text -> Adaptor app r ()
forall app request. Text -> Adaptor app request ()
logError (String -> Text
T.pack String
reason)
          IO value -> Adaptor app r value
forall a. IO a -> Adaptor app r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO value -> Adaptor app r value)
-> IO value -> Adaptor app r value
forall a b. (a -> b) -> a -> b
$ AdaptorException -> IO value
forall e a. 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
  (Either (ErrorMessage, Maybe Message) ()
es,AdaptorState
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 Either (ErrorMessage, Maybe Message) ()
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)