-----------------------------------------------------------------------------
-- |
-- 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                 #-}
{-# LANGUAGE ViewPatterns               #-}
----------------------------------------------------------------------------
module DAP.Server
  ( runDAPServer
  , runDAPServerWithLogger
  , readPayload
  , TerminateServer(..)
  ) where
----------------------------------------------------------------------------
import           Control.Monad              ( when, forever )
import           Control.Concurrent         ( ThreadId, myThreadId, throwTo )
import           Control.Concurrent.MVar    ( newMVar )
import           Control.Concurrent.STM     ( newTVarIO )
import           Control.Exception          ( Exception
                                            , SomeAsyncException(..)
                                            , SomeException
                                            , IOException
                                            , catch
                                            , fromException
                                            , toException
                                            , throwIO )
import           Control.Monad              ( void )
import           Data.Aeson                 ( decodeStrict, eitherDecode, Value, FromJSON )
import           Data.Aeson.Encode.Pretty   ( encodePretty )
import           Data.ByteString            ( ByteString )
import           Data.Char                  ( isDigit )
import           Data.IORef                 ( newIORef )
import           Network.Simple.TCP         ( serve, HostPreference(Host) )
import           Network.Socket             ( socketToHandle, withSocketsDo, SockAddr )
import           System.IO                  ( hClose, hSetNewlineMode, Handle, Newline(CRLF)
                                            , NewlineMode(NewlineMode, outputNL, inputNL)
                                            , IOMode(ReadWriteMode), stderr, hPrint)
import           System.IO.Error            ( isEOFError )
import           System.Exit                ( exitWith, ExitCode(ExitSuccess) )
import           Text.Read                  ( readMaybe )
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.ByteString.Char8      as BS
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Control.Monad.Reader
----------------------------------------------------------------------------
import           DAP.Types
import           DAP.Internal
import           DAP.Utils
import           DAP.Adaptor
import           DAP.Log
----------------------------------------------------------------------------

stdoutLogger :: IO (LogAction IO T.Text)
stdoutLogger :: IO (LogAction IO Text)
stdoutLogger = do
  MVar ()
handleLock               <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  LogAction IO Text -> IO (LogAction IO Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogAction IO Text -> IO (LogAction IO Text))
-> LogAction IO Text -> IO (LogAction IO Text)
forall a b. (a -> b) -> a -> b
$ (Text -> IO ()) -> LogAction IO Text
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ((Text -> IO ()) -> LogAction IO Text)
-> (Text -> IO ()) -> LogAction IO Text
forall a b. (a -> b) -> a -> b
$ \Text
msg -> do
    MVar () -> IO () -> IO ()
withLock MVar ()
handleLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Text -> IO ()
T.putStrLn Text
msg

-- | An exception to throw if you want to stop the server execution from a
-- client. This is useful if you launch a new server per debugging session and
-- want to terminate it at the end.
data TerminateServer = TerminateServer
  deriving (PayloadSize -> TerminateServer -> ShowS
[TerminateServer] -> ShowS
TerminateServer -> String
(PayloadSize -> TerminateServer -> ShowS)
-> (TerminateServer -> String)
-> ([TerminateServer] -> ShowS)
-> Show TerminateServer
forall a.
(PayloadSize -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: PayloadSize -> TerminateServer -> ShowS
showsPrec :: PayloadSize -> TerminateServer -> ShowS
$cshow :: TerminateServer -> String
show :: TerminateServer -> String
$cshowList :: [TerminateServer] -> ShowS
showList :: [TerminateServer] -> ShowS
Show, Show TerminateServer
Typeable TerminateServer
(Typeable TerminateServer, Show TerminateServer) =>
(TerminateServer -> SomeException)
-> (SomeException -> Maybe TerminateServer)
-> (TerminateServer -> String)
-> Exception TerminateServer
SomeException -> Maybe TerminateServer
TerminateServer -> String
TerminateServer -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: TerminateServer -> SomeException
toException :: TerminateServer -> SomeException
$cfromException :: SomeException -> Maybe TerminateServer
fromException :: SomeException -> Maybe TerminateServer
$cdisplayException :: TerminateServer -> String
displayException :: TerminateServer -> String
Exception)

-- | Simpler version of 'runDAPServerWithLogger'.
--
-- If you don't need a custom logger or to observe reverse request responses.
runDAPServer :: ServerConfig -> (Command -> Adaptor app Request ()) -> IO ()
runDAPServer :: forall app.
ServerConfig -> (Command -> Adaptor app Request ()) -> IO ()
runDAPServer ServerConfig
config Command -> Adaptor app Request ()
communicate = do
  LogAction IO Text
l <- IO (LogAction IO Text)
stdoutLogger
  LogAction IO DAPLog
-> ServerConfig
-> (Command -> Adaptor app Request ())
-> (ReverseRequestResponse -> Adaptor app () ())
-> IO ()
forall app.
LogAction IO DAPLog
-> ServerConfig
-> (Command -> Adaptor app Request ())
-> (ReverseRequestResponse -> Adaptor app () ())
-> IO ()
runDAPServerWithLogger ((DAPLog -> Text) -> LogAction IO Text -> LogAction IO DAPLog
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap DAPLog -> Text
renderDAPLog LogAction IO Text
l) ServerConfig
config Command -> Adaptor app Request ()
communicate (Adaptor app () () -> ReverseRequestResponse -> Adaptor app () ()
forall a b. a -> b -> a
const (() -> Adaptor app () ()
forall a. a -> Adaptor app () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))

runDAPServerWithLogger
  :: LogAction IO DAPLog
  -> ServerConfig
  -- ^ Top-level Server configuration, global across all debug sessions
  -> (Command -> Adaptor app Request ())
  -- ^ A function to facilitate communication between DAP clients, debug adaptors and debuggers
  -> (ReverseRequestResponse -> Adaptor app () ())
  -- ^ A function to receive reverse-request-responses from DAP clients
  -> IO ()
runDAPServerWithLogger :: forall app.
LogAction IO DAPLog
-> ServerConfig
-> (Command -> Adaptor app Request ())
-> (ReverseRequestResponse -> Adaptor app () ())
-> IO ()
runDAPServerWithLogger LogAction IO DAPLog
rawLogAction serverConfig :: ServerConfig
serverConfig@ServerConfig {Bool
PayloadSize
String
Capabilities
host :: String
port :: PayloadSize
serverCapabilities :: Capabilities
debugLogging :: Bool
debugLogging :: ServerConfig -> Bool
serverCapabilities :: ServerConfig -> Capabilities
port :: ServerConfig -> PayloadSize
host :: ServerConfig -> String
..} Command -> Adaptor app Request ()
communicate ReverseRequestResponse -> Adaptor app () ()
ackResp = IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  let logAction :: LogAction IO DAPLog
logAction = (DAPLog -> Bool) -> LogAction IO DAPLog -> LogAction IO DAPLog
forall (m :: * -> *) msg.
Applicative m =>
(msg -> Bool) -> LogAction m msg -> LogAction m msg
cfilter (\DAPLog
msg -> if Bool
debugLogging then Bool
True else DAPLog -> Level
severity DAPLog
msg Level -> Level -> Bool
forall a. Eq a => a -> a -> Bool
/= Level
DEBUG) LogAction IO DAPLog
rawLogAction
  LogAction IO DAPLog
logAction LogAction IO DAPLog -> DAPLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& (Text -> DAPLog
mkDebugMessage (Text -> DAPLog) -> Text -> DAPLog
forall a b. (a -> b) -> a -> b
$ (String -> Text
T.pack (String
"Running DAP server on " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PayloadSize -> String
forall a. Show a => a -> String
show PayloadSize
port String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"...")))
  TVar (HashMap Text (DebuggerThreadState, app))
appStore <- HashMap Text (DebuggerThreadState, app)
-> IO (TVar (HashMap Text (DebuggerThreadState, app)))
forall a. a -> IO (TVar a)
newTVarIO HashMap Text (DebuggerThreadState, app)
forall a. Monoid a => a
mempty
  ThreadId
mainThread <- IO ThreadId
myThreadId
  let
    server :: IO a
server = HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> IO a
forall (m :: * -> *) a.
MonadIO m =>
HostPreference -> String -> ((Socket, SockAddr) -> IO ()) -> m a
serve (String -> HostPreference
Host String
host) (PayloadSize -> String
forall a. Show a => a -> String
show PayloadSize
port) (((Socket, SockAddr) -> IO ()) -> IO a)
-> ((Socket, SockAddr) -> IO ()) -> IO a
forall a b. (a -> b) -> a -> b
$ \(Socket
socket, SockAddr
address) -> do
      LogAction IO DAPLog
logAction LogAction IO DAPLog -> DAPLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Text -> DAPLog
mkDebugMessage (String -> Text
T.pack (String
"TCP connection established from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SockAddr -> String
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 }
      AdaptorLocal app ()
adaptorStateMVar <- LogAction IO DAPLog
-> Handle
-> SockAddr
-> TVar (HashMap Text (DebuggerThreadState, app))
-> ServerConfig
-> IO (AdaptorLocal app ())
forall app.
LogAction IO DAPLog
-> Handle
-> SockAddr
-> AppStore app
-> ServerConfig
-> IO (AdaptorLocal app ())
initAdaptorState LogAction IO DAPLog
logAction Handle
handle SockAddr
address TVar (HashMap Text (DebuggerThreadState, app))
appStore ServerConfig
serverConfig
      (Command -> Adaptor app Request ())
-> (ReverseRequestResponse -> Adaptor app () ())
-> AdaptorLocal app ()
-> IO ()
forall app r.
(Command -> Adaptor app Request ())
-> (ReverseRequestResponse -> Adaptor app r ())
-> AdaptorLocal app r
-> IO ()
serviceClient Command -> Adaptor app Request ()
communicate ReverseRequestResponse -> Adaptor app () ()
ackResp AdaptorLocal app ()
adaptorStateMVar
        IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` LogAction IO DAPLog
-> Handle -> SockAddr -> Bool -> ThreadId -> SomeException -> IO ()
exceptionHandler LogAction IO DAPLog
logAction Handle
handle SockAddr
address Bool
debugLogging ThreadId
mainThread
  IO ()
forall {a}. IO a
server IO () -> (SomeAsyncException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeAsyncException e
e) ->
    case SomeException -> Maybe TerminateServer
forall e. Exception e => SomeException -> Maybe e
fromException (SomeException -> Maybe TerminateServer)
-> SomeException -> Maybe TerminateServer
forall a b. (a -> b) -> a -> b
$ e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e of
      Just TerminateServer
TerminateServer -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
      Maybe TerminateServer
_                    -> e -> IO ()
forall e a. Exception e => e -> IO a
throwIO e
e

-- | Initializes the Adaptor
--
initAdaptorState
  :: LogAction IO DAPLog
  -> Handle
  -> SockAddr
  -> AppStore app
  -> ServerConfig
  -> IO (AdaptorLocal app ())
initAdaptorState :: forall app.
LogAction IO DAPLog
-> Handle
-> SockAddr
-> AppStore app
-> ServerConfig
-> IO (AdaptorLocal app ())
initAdaptorState LogAction IO DAPLog
logAction Handle
handle SockAddr
address AppStore app
appStore ServerConfig
serverConfig = do
  MVar ()
handleLock               <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  IORef (Maybe Text)
sessionId                <- Maybe Text -> IO (IORef (Maybe Text))
forall a. a -> IO (IORef a)
newIORef Maybe Text
forall a. Maybe a
Nothing
  let request :: ()
request = ()
  AdaptorLocal app () -> IO (AdaptorLocal app ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AdaptorLocal
    { ()
Handle
MVar ()
AppStore app
IORef (Maybe Text)
LogAction IO DAPLog
SockAddr
ServerConfig
logAction :: LogAction IO DAPLog
handle :: Handle
address :: SockAddr
appStore :: AppStore app
serverConfig :: ServerConfig
handleLock :: MVar ()
sessionId :: IORef (Maybe Text)
request :: ()
request :: ()
logAction :: LogAction IO DAPLog
handleLock :: MVar ()
sessionId :: IORef (Maybe Text)
address :: SockAddr
handle :: Handle
serverConfig :: ServerConfig
appStore :: AppStore app
..
    }
----------------------------------------------------------------------------
-- | Communication loop between editor and adaptor
-- Evaluates the current 'Request' located in the 'AdaptorState'
-- Fetches, updates and recurses on the next 'Request'
--
-- Similarly, if the client responded to a reverse request then we execute the
-- acknowledge action (which, notably, is not an @'Adaptor' _ 'Request'@
-- because there's no 'Request' to reply to)
serviceClient
  :: (Command -> Adaptor app Request ())
  -> (ReverseRequestResponse -> Adaptor app r ())
  -> AdaptorLocal app r
  -> IO ()
serviceClient :: forall app r.
(Command -> Adaptor app Request ())
-> (ReverseRequestResponse -> Adaptor app r ())
-> AdaptorLocal app r
-> IO ()
serviceClient Command -> Adaptor app Request ()
communicate ReverseRequestResponse -> Adaptor app r ()
ackResp AdaptorLocal app r
lcl = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ AdaptorLocal app r -> AdaptorState -> Adaptor app r () -> IO ()
forall app request.
AdaptorLocal app request
-> AdaptorState -> Adaptor app request () -> IO ()
runAdaptorWith AdaptorLocal app r
lcl AdaptorState
st (Adaptor app r () -> IO ()) -> Adaptor app r () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Either ReverseRequestResponse Request
either_nextRequest <- Adaptor app r (Either ReverseRequestResponse Request)
forall app r. Adaptor app r (Either ReverseRequestResponse Request)
getRequest
    case Either ReverseRequestResponse Request
either_nextRequest of
      Right Request
nextRequest ->
        Request -> Adaptor app Request () -> Adaptor app r ()
forall app a r. Request -> Adaptor app Request a -> Adaptor app r a
withRequest Request
nextRequest (Command -> Adaptor app Request ()
communicate (Request -> Command
command Request
nextRequest))
      Left ReverseRequestResponse
rrr -> ReverseRequestResponse -> Adaptor app r ()
ackResp ReverseRequestResponse
rrr
  where
    st :: AdaptorState
st = MessageType -> [Pair] -> AdaptorState
AdaptorState MessageType
MessageTypeResponse []
----------------------------------------------------------------------------
-- | Handle exceptions from client threads, parse and log accordingly.
-- Detects if client failed with `TerminateServer` and kills the server accordingly by sending an exception to the main thread.
exceptionHandler :: LogAction IO DAPLog -> Handle -> SockAddr -> Bool -> ThreadId -> SomeException -> IO ()
exceptionHandler :: LogAction IO DAPLog
-> Handle -> SockAddr -> Bool -> ThreadId -> SomeException -> IO ()
exceptionHandler LogAction IO DAPLog
logAction Handle
handle SockAddr
address Bool
shouldLog ThreadId
serverThread (SomeException
e :: SomeException) = do
  let
    dumpError :: IO ()
dumpError
      | Just TerminateServer
TerminateServer      <- SomeException -> Maybe TerminateServer
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
          = do
            LogAction IO DAPLog
-> Level -> SockAddr -> Maybe DebugStatus -> Text -> IO ()
logger LogAction IO DAPLog
logAction Level
ERROR SockAddr
address Maybe DebugStatus
forall a. Maybe a
Nothing
              (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
withBraces
              (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"Server terminated!")
            ThreadId -> SomeAsyncException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
serverThread (TerminateServer -> SomeAsyncException
forall e. Exception e => e -> SomeAsyncException
SomeAsyncException TerminateServer
TerminateServer)
      | Just (ParseException String
msg) <- SomeException -> Maybe AdaptorException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
          = LogAction IO DAPLog
-> Level -> SockAddr -> Maybe DebugStatus -> Text -> IO ()
logger LogAction IO DAPLog
logAction Level
ERROR SockAddr
address Maybe DebugStatus
forall a. Maybe a
Nothing
            (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
withBraces
            (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"Parse Exception encountered: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg)
      | Just (IOException
err :: IOException) <- SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e, IOException -> Bool
isEOFError IOException
err
          = LogAction IO DAPLog
-> Level -> SockAddr -> Maybe DebugStatus -> Text -> IO ()
logger LogAction IO DAPLog
logAction Level
INFO SockAddr
address (DebugStatus -> Maybe DebugStatus
forall a. a -> Maybe a
Just DebugStatus
SENT)
            (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
withBraces Text
"Client has ended its connection"
      | Bool
otherwise
          = LogAction IO DAPLog
-> Level -> SockAddr -> Maybe DebugStatus -> Text -> IO ()
logger LogAction IO DAPLog
logAction Level
ERROR SockAddr
address Maybe DebugStatus
forall a. Maybe a
Nothing
            (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
withBraces
            (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"Unknown Exception: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
  Handle -> String -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr (String
"Handling" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldLog (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO ()
dumpError
    LogAction IO DAPLog
-> Level -> SockAddr -> Maybe DebugStatus -> Text -> IO ()
logger LogAction IO DAPLog
logAction Level
INFO SockAddr
address (DebugStatus -> Maybe DebugStatus
forall a. a -> Maybe a
Just DebugStatus
SENT) (Text -> Text
withBraces Text
"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 :: Adaptor app r (Either ReverseRequestResponse Request)
getRequest :: forall app r. Adaptor app r (Either ReverseRequestResponse Request)
getRequest = do
  Handle
handle <- Adaptor app r Handle
forall app r. Adaptor app r Handle
getHandle
  Either String PayloadSize
header <- IO (Either String PayloadSize)
-> Adaptor app r (Either String PayloadSize)
forall a. IO a -> Adaptor app r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String PayloadSize)
 -> Adaptor app r (Either String PayloadSize))
-> IO (Either String PayloadSize)
-> Adaptor app r (Either String PayloadSize)
forall a b. (a -> b) -> a -> b
$ Handle -> IO (Either String PayloadSize)
getHeaderHandle Handle
handle
  case Either String PayloadSize
header of
    Left String
errorMessage -> do
      Text -> Adaptor app r ()
forall app request. Text -> Adaptor app request ()
logError (String -> Text
T.pack String
errorMessage)
      IO (Either ReverseRequestResponse Request)
-> Adaptor app r (Either ReverseRequestResponse Request)
forall a. IO a -> Adaptor app r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ReverseRequestResponse Request)
 -> Adaptor app r (Either ReverseRequestResponse Request))
-> IO (Either ReverseRequestResponse Request)
-> Adaptor app r (Either ReverseRequestResponse Request)
forall a b. (a -> b) -> a -> b
$ AdaptorException -> IO (Either ReverseRequestResponse Request)
forall e a. Exception e => e -> IO a
throwIO (String -> AdaptorException
ParseException String
errorMessage)
    Right PayloadSize
count -> do
      ByteString
body <- IO ByteString -> Adaptor app r ByteString
forall a. IO a -> Adaptor app r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Adaptor app r ByteString)
-> IO ByteString -> Adaptor app r ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> PayloadSize -> IO ByteString
BS.hGet Handle
handle PayloadSize
count
      DebugStatus -> ByteString -> Adaptor app r ()
forall app request.
DebugStatus -> ByteString -> Adaptor app request ()
debugMessage DebugStatus
RECEIVED
          (ByteString
"\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Maybe Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict ByteString
body :: Maybe Value))
      case ByteString -> Either String Request
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
BL8.fromStrict ByteString
body) of
        Left String
couldn'tDecodeBody -> do
          -- As a fallback, try to parse a reverse request response
          case ByteString -> Either String ReverseRequestResponse
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
BL8.fromStrict ByteString
body) of
            Right ReverseRequestResponse
rrr -> Either ReverseRequestResponse Request
-> Adaptor app r (Either ReverseRequestResponse Request)
forall a. a -> Adaptor app r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReverseRequestResponse -> Either ReverseRequestResponse Request
forall a b. a -> Either a b
Left ReverseRequestResponse
rrr)
            Left String
_ -> do
              -- No luck, report fail to parse command:
              Text -> Adaptor app r ()
forall app request. Text -> Adaptor app request ()
logError (String -> Text
T.pack String
couldn'tDecodeBody)
              IO (Either ReverseRequestResponse Request)
-> Adaptor app r (Either ReverseRequestResponse Request)
forall a. IO a -> Adaptor app r a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ReverseRequestResponse Request)
 -> Adaptor app r (Either ReverseRequestResponse Request))
-> IO (Either ReverseRequestResponse Request)
-> Adaptor app r (Either ReverseRequestResponse Request)
forall a b. (a -> b) -> a -> b
$ AdaptorException -> IO (Either ReverseRequestResponse Request)
forall e a. Exception e => e -> IO a
throwIO (String -> AdaptorException
ParseException String
couldn'tDecodeBody)
        Right Request
request ->
          Either ReverseRequestResponse Request
-> Adaptor app r (Either ReverseRequestResponse Request)
forall a. a -> Adaptor app r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Request -> Either ReverseRequestResponse Request
forall a b. b -> Either a b
Right Request
request)

getHeaderHandle :: Handle -> IO (Either String PayloadSize)
getHeaderHandle :: Handle -> IO (Either String PayloadSize)
getHeaderHandle Handle
handle = do
  ByteString
headerBytes <- Handle -> IO ByteString
BS.hGetLine Handle
handle
  IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handle -> IO ByteString
BS.hGetLine Handle
handle)
  Either String PayloadSize -> IO (Either String PayloadSize)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String PayloadSize -> IO (Either String PayloadSize))
-> Either String PayloadSize -> IO (Either String PayloadSize)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String PayloadSize
parseHeader ByteString
headerBytes


----------------------------------------------------------------------------
-- | Parses the HeaderPart of all ProtocolMessages
parseHeader :: ByteString -> Either String PayloadSize
parseHeader :: ByteString -> Either String PayloadSize
parseHeader ByteString
bytes =
  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)
  in case String -> Maybe PayloadSize
forall a. Read a => String -> Maybe a
readMaybe (ByteString -> String
BS.unpack ByteString
byteSize) of
        Just PayloadSize
contentLength ->
          PayloadSize -> Either String PayloadSize
forall a b. b -> Either a b
Right PayloadSize
contentLength
        Maybe PayloadSize
Nothing ->
          String -> Either String PayloadSize
forall a b. a -> Either a b
Left (String
"Invalid payload: " String -> ShowS
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
  IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handle -> IO ByteString
BS.hGetLine Handle
handle)
  case ByteString -> Either String PayloadSize
parseHeader ByteString
headerBytes of
    Left String
e -> Either String json -> IO (Either String json)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String json
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
      Either String json -> IO (Either String json)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String json -> IO (Either String json))
-> Either String json -> IO (Either String json)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String json
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
BL8.fromStrict ByteString
body)
----------------------------------------------------------------------------