-----------------------------------------------------------------------------
-- |
-- Module      :  DAP.Server
-- Copyright   :  (C) 2023 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE LambdaCase                 #-}
----------------------------------------------------------------------------
module DAP.Server
  ( runDAPServer
  , readPayload
  ) where
----------------------------------------------------------------------------
import           Control.Concurrent.MVar    ( MVar )
import           Control.Monad              ( when )
import           Control.Concurrent.MVar    ( newMVar, newEmptyMVar, modifyMVar_
                                            , putMVar, readMVar )
import           Control.Concurrent.STM     ( newTVarIO )
import           Control.Exception          ( SomeException
                                            , IOException
                                            , catch
                                            , fromException
                                            , throwIO )
import           Control.Monad              ( void )
import           Control.Monad.State        ( gets )
import           Data.Aeson                 ( decodeStrict, eitherDecode, Value, FromJSON )
import           Data.Aeson.Encode.Pretty   ( encodePretty )
import           Data.ByteString            ( ByteString )
import           Data.Char                  ( isDigit )
import           Network.Simple.TCP         ( serve, HostPreference(Host) )
import           Network.Socket             ( socketToHandle, withSocketsDo, SockAddr )
import           System.IO                  ( hClose, hSetNewlineMode, Handle, Newline(CRLF)
                                            , NewlineMode(NewlineMode, outputNL, inputNL)
                                            , IOMode(ReadWriteMode) )
import           System.IO.Error            ( isEOFError )
import           Text.Read                  ( readMaybe )
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.ByteString.Char8      as BS
----------------------------------------------------------------------------
import           DAP.Types
import           DAP.Internal
import           DAP.Utils
import           DAP.Adaptor
----------------------------------------------------------------------------
runDAPServer
  :: ServerConfig
  -- ^ Top-level Server configuration, global across all debug sessions
  -> (Command -> Adaptor app ())
  -- ^ A function to facilitate communication between DAP clients, debug adaptors and debuggers
  -> IO ()
runDAPServer :: forall app. ServerConfig -> (Command -> Adaptor app ()) -> IO ()
runDAPServer serverConfig :: ServerConfig
serverConfig@ServerConfig {Bool
PayloadSize
String
Capabilities
debugLogging :: ServerConfig -> Bool
serverCapabilities :: ServerConfig -> Capabilities
port :: ServerConfig -> PayloadSize
host :: ServerConfig -> String
debugLogging :: Bool
serverCapabilities :: Capabilities
port :: PayloadSize
host :: String
..} Command -> Adaptor app ()
communicate = forall a. IO a -> IO a
withSocketsDo forall a b. (a -> b) -> a -> b
$ do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugLogging forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Running DAP server on " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show PayloadSize
port forall a. Semigroup a => a -> a -> a
<> String
"...")
  TVar (HashMap SessionId (DebuggerThreadState, app))
appStore <- forall a. a -> IO (TVar a)
newTVarIO forall a. Monoid a => a
mempty
  forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
serve (String -> HostPreference
Host String
host) (forall a. Show a => a -> String
show PayloadSize
port) forall a b. (a -> b) -> a -> b
$ \(Socket
socket, SockAddr
address) -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugLogging forall a b. (a -> b) -> a -> b
$ do
      IO () -> IO ()
withGlobalLock forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"TCP connection established from " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SockAddr
address
    Handle
handle <- Socket -> IOMode -> IO Handle
socketToHandle Socket
socket IOMode
ReadWriteMode
    Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
handle NewlineMode { inputNL :: Newline
inputNL = Newline
CRLF, outputNL :: Newline
outputNL = Newline
CRLF }
    Request
request <- Handle -> SockAddr -> ServerConfig -> IO Request
getRequest Handle
handle SockAddr
address ServerConfig
serverConfig
    MVar (AdaptorState app)
adaptorStateMVar <- forall app.
Handle
-> SockAddr
-> AppStore app
-> ServerConfig
-> Request
-> IO (MVar (AdaptorState app))
initAdaptorState Handle
handle SockAddr
address TVar (HashMap SessionId (DebuggerThreadState, app))
appStore ServerConfig
serverConfig Request
request
    forall app.
(Command -> Adaptor app ()) -> MVar (AdaptorState app) -> IO ()
serviceClient Command -> Adaptor app ()
communicate MVar (AdaptorState app)
adaptorStateMVar forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` Handle -> SockAddr -> Bool -> SomeException -> IO ()
exceptionHandler Handle
handle SockAddr
address Bool
debugLogging

-- | Initializes the Adaptor
--
initAdaptorState
  :: Handle
  -> SockAddr
  -> AppStore app
  -> ServerConfig
  -> Request
  -> IO (MVar (AdaptorState app))
initAdaptorState :: forall app.
Handle
-> SockAddr
-> AppStore app
-> ServerConfig
-> Request
-> IO (MVar (AdaptorState app))
initAdaptorState Handle
handle SockAddr
address AppStore app
appStore ServerConfig
serverConfig Request
request = do
  MVar ()
handleLock               <- forall a. a -> IO (MVar a)
newMVar ()
  Maybe SessionId
sessionId                <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  MVar (AdaptorState app)
adaptorStateMVar         <- forall a. IO (MVar a)
newEmptyMVar
  forall a. MVar a -> a -> IO ()
putMVar MVar (AdaptorState app)
adaptorStateMVar AdaptorState
    { messageType :: MessageType
messageType = MessageType
MessageTypeResponse
    , payload :: [Pair]
payload = []
    , Maybe SessionId
Handle
AppStore app
MVar ()
MVar (AdaptorState app)
SockAddr
Request
ServerConfig
handleLock :: MVar ()
adaptorStateMVar :: MVar (AdaptorState app)
sessionId :: Maybe SessionId
address :: SockAddr
request :: Request
handle :: Handle
serverConfig :: ServerConfig
appStore :: AppStore app
adaptorStateMVar :: MVar (AdaptorState app)
sessionId :: Maybe SessionId
handleLock :: MVar ()
request :: Request
serverConfig :: ServerConfig
appStore :: AppStore app
address :: SockAddr
handle :: Handle
..
    }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar (AdaptorState app)
adaptorStateMVar
----------------------------------------------------------------------------
-- | Communication loop between editor and adaptor
-- Evaluates the current 'Request' located in the 'AdaptorState'
-- Fetches, updates and recurses on the next 'Request'
--
serviceClient
  :: (Command -> Adaptor app ())
  -> MVar (AdaptorState app)
  -> IO ()
serviceClient :: forall app.
(Command -> Adaptor app ()) -> MVar (AdaptorState app) -> IO ()
serviceClient Command -> Adaptor app ()
communicate MVar (AdaptorState app)
adaptorStateMVar = do
  forall app. MVar (AdaptorState app) -> Adaptor app () -> IO ()
runAdaptorWith MVar (AdaptorState app)
adaptorStateMVar forall a b. (a -> b) -> a -> b
$ do
    Request
request <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall app. AdaptorState app -> Request
request
    Command -> Adaptor app ()
communicate (Request -> Command
command Request
request)

  -- HINT: getRequest is a blocking action so we use readMVar to leave MVar available
  AdaptorState { SockAddr
address :: SockAddr
address :: forall app. AdaptorState app -> SockAddr
address, Handle
handle :: Handle
handle :: forall app. AdaptorState app -> Handle
handle, ServerConfig
serverConfig :: ServerConfig
serverConfig :: forall app. AdaptorState app -> ServerConfig
serverConfig } <- forall a. MVar a -> IO a
readMVar MVar (AdaptorState app)
adaptorStateMVar
  Request
nextRequest <- Handle -> SockAddr -> ServerConfig -> IO Request
getRequest Handle
handle SockAddr
address ServerConfig
serverConfig
  forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (AdaptorState app)
adaptorStateMVar forall a b. (a -> b) -> a -> b
$ \AdaptorState app
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure AdaptorState app
s { request :: Request
request = Request
nextRequest }

  -- loop: serve the next request
  forall app.
(Command -> Adaptor app ()) -> MVar (AdaptorState app) -> IO ()
serviceClient Command -> Adaptor app ()
communicate MVar (AdaptorState app)
adaptorStateMVar

----------------------------------------------------------------------------
-- | Handle exceptions from client threads, parse and log accordingly
exceptionHandler :: Handle -> SockAddr -> Bool -> SomeException -> IO ()
exceptionHandler :: Handle -> SockAddr -> Bool -> SomeException -> IO ()
exceptionHandler Handle
handle SockAddr
address Bool
shouldLog (SomeException
e :: SomeException) = do
  let
    dumpError :: IO ()
dumpError
      | Just (ParseException String
msg) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
          = Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
ERROR SockAddr
address forall a. Maybe a
Nothing
            forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
withBraces
            forall a b. (a -> b) -> a -> b
$ String -> ByteString
BL8.pack (String
"Parse Exception encountered: " forall a. Semigroup a => a -> a -> a
<> String
msg)
      | Just (IOException
err :: IOException) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e, IOException -> Bool
isEOFError IOException
err
          = Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
INFO SockAddr
address (forall a. a -> Maybe a
Just DebugStatus
SENT)
            forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
withBraces ByteString
"Client has ended its connection"
      | Bool
otherwise
          = Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
ERROR SockAddr
address forall a. Maybe a
Nothing
            forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
withBraces
            forall a b. (a -> b) -> a -> b
$ String -> ByteString
BL8.pack (String
"Unknown Exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SomeException
e)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldLog forall a b. (a -> b) -> a -> b
$ do
    IO ()
dumpError
    Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
INFO SockAddr
address (forall a. a -> Maybe a
Just DebugStatus
SENT) (ByteString -> ByteString
withBraces ByteString
"Closing Connection")
  Handle -> IO ()
hClose Handle
handle
----------------------------------------------------------------------------
-- | Internal function for parsing a 'ProtocolMessage' header
-- This function also dispatches on 'talk'
--
-- 'parseHeader' Attempts to parse 'Content-Length: <byte-count>'
-- Helper function for parsing message headers
-- e.g. ("Content-Length: 11\r\n")
getRequest :: Handle -> SockAddr -> ServerConfig -> IO Request
getRequest :: Handle -> SockAddr -> ServerConfig -> IO Request
getRequest Handle
handle SockAddr
addr ServerConfig {Bool
PayloadSize
String
Capabilities
debugLogging :: Bool
serverCapabilities :: Capabilities
port :: PayloadSize
host :: String
debugLogging :: ServerConfig -> Bool
serverCapabilities :: ServerConfig -> Capabilities
port :: ServerConfig -> PayloadSize
host :: ServerConfig -> String
..} = do
  ByteString
headerBytes <- Handle -> IO ByteString
BS.hGetLine Handle
handle
  forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handle -> IO ByteString
BS.hGetLine Handle
handle)
  ByteString -> IO (Either String PayloadSize)
parseHeader ByteString
headerBytes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left String
errorMessage -> do
      Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
ERROR SockAddr
addr forall a. Maybe a
Nothing (String -> ByteString
BL8.pack String
errorMessage)
      forall e a. Exception e => e -> IO a
throwIO (String -> AdaptorException
ParseException String
errorMessage)
    Right PayloadSize
count -> do
      ByteString
body <- Handle -> PayloadSize -> IO ByteString
BS.hGet Handle
handle PayloadSize
count
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugLogging forall a b. (a -> b) -> a -> b
$ do
        Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
DEBUG SockAddr
addr (forall a. a -> Maybe a
Just DebugStatus
RECEIVED)
          (ByteString
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. ToJSON a => a -> ByteString
encodePretty (forall a. FromJSON a => ByteString -> Maybe a
decodeStrict ByteString
body :: Maybe Value))
      case forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
BL8.fromStrict ByteString
body) of
        Left String
couldn'tDecodeBody -> do
          Level -> SockAddr -> Maybe DebugStatus -> ByteString -> IO ()
logger Level
ERROR SockAddr
addr forall a. Maybe a
Nothing (String -> ByteString
BL8.pack String
couldn'tDecodeBody)
          forall e a. Exception e => e -> IO a
throwIO (String -> AdaptorException
ParseException String
couldn'tDecodeBody)
        Right Request
request ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
request
----------------------------------------------------------------------------
-- | Parses the HeaderPart of all ProtocolMessages
parseHeader :: ByteString -> IO (Either String PayloadSize)
parseHeader :: ByteString -> IO (Either String PayloadSize)
parseHeader ByteString
bytes = do
  let byteSize :: ByteString
byteSize = (Char -> Bool) -> ByteString -> ByteString
BS.takeWhile Char -> Bool
isDigit (PayloadSize -> ByteString -> ByteString
BS.drop (ByteString -> PayloadSize
BS.length ByteString
"Content-Length: ") ByteString
bytes)
  case forall a. Read a => String -> Maybe a
readMaybe (ByteString -> String
BS.unpack ByteString
byteSize) of
    Just PayloadSize
contentLength ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right PayloadSize
contentLength)
    Maybe PayloadSize
Nothing ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (String
"Invalid payload: " forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS.unpack ByteString
bytes)

-- | Helper function to parse a 'ProtocolMessage', extracting it's body.
-- used for testing.
--
readPayload :: FromJSON json => Handle -> IO (Either String json)
readPayload :: forall json. FromJSON json => Handle -> IO (Either String json)
readPayload Handle
handle = do
  ByteString
headerBytes <- Handle -> IO ByteString
BS.hGetLine Handle
handle
  forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handle -> IO ByteString
BS.hGetLine Handle
handle)
  ByteString -> IO (Either String PayloadSize)
parseHeader ByteString
headerBytes forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left String
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left String
e)
    Right PayloadSize
count -> do
      ByteString
body <- Handle -> PayloadSize -> IO ByteString
BS.hGet Handle
handle PayloadSize
count
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
BL8.fromStrict ByteString
body)