{-# LANGUAGE LambdaCase #-}

module Haskell.Debug.Adapter.Request where

import Control.Monad.IO.Class
import Data.Conduit
import Control.Lens
import Text.Parsec
import Data.Aeson
import qualified Data.ByteString.Lazy as B
import Control.Monad.State.Lazy
import qualified System.Log.Logger as L
import Control.Monad.Except

import qualified Haskell.DAP as DAP
import Haskell.Debug.Adapter.Type
import Haskell.Debug.Adapter.Utility
import Haskell.Debug.Adapter.Constant

-- |
--
run :: AppStores -> IO ()
run :: AppStores -> IO ()
run AppStores
appData = do
  String -> String -> IO ()
L.debugM String
_LOG_REQUEST String
"start request app"
  Either String ((), AppStores)
_ <- forall a.
AppStores -> AppContext a -> IO (Either String (a, AppStores))
runApp AppStores
appData AppContext ()
app
  String -> String -> IO ()
L.debugM String
_LOG_REQUEST String
"end request app"


-- |
--
app :: AppContext ()
app :: AppContext ()
app = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError String -> AppContext ()
errHdl forall a b. (a -> b) -> a -> b
$ do
  ()
_ <- forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit ConduitM () Void AppContext ()
pipeline
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

  where
    pipeline :: ConduitM () Void AppContext ()
    pipeline :: ConduitM () Void AppContext ()
pipeline = ConduitT () ByteString AppContext ()
src forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString WrapRequest AppContext ()
lbs2req forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT WrapRequest Void AppContext ()
sink

    errHdl :: String -> AppContext ()
errHdl String
msg = do
      String -> String -> AppContext ()
criticalEV String
_LOG_REQUEST String
msg
      Event -> AppContext ()
addEvent Event
CriticalExitEvent


---------------------------------------------------------------------------------
-- |
--
src :: ConduitT () B.ByteString AppContext ()
src :: ConduitT () ByteString AppContext ()
src = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
L.debugM String
_LOG_REQUEST forall a b. (a -> b) -> a -> b
$ String
"src start waiting."
  ByteString
bs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift AppContext ByteString
goApp
  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
  ConduitT () ByteString AppContext ()
src

  where
    goApp :: AppContext B.ByteString
    goApp :: AppContext ByteString
goApp = do
      ByteString
bs <- AppContext Int
getContentLength forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> AppContext ByteString
getContent
      ByteString -> AppContext ()
stdinLogging ByteString
bs
      forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs


-- |
--
getContent :: Int -> AppContext B.ByteString
getContent :: Int -> AppContext ByteString
getContent Int
l = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores Handle
inHandleAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
           forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> Int -> AppContext ByteString
readCharsL Int
l


-- |
--
getContentLength :: AppContext Int
getContentLength :: AppContext Int
getContentLength = ByteString -> AppContext Int
go ByteString
B.empty
  where
    go :: B.ByteString -> AppContext Int
    go :: ByteString -> AppContext Int
go ByteString
buf = ByteString -> AppContext ByteString
updateBuf ByteString
buf forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> AppContext Int
findLength

    updateBuf :: B.ByteString -> AppContext B.ByteString
    updateBuf :: ByteString -> AppContext ByteString
updateBuf ByteString
buf = do
      Handle
hdl <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores Handle
inHandleAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
      ByteString -> ByteString -> ByteString
B.append ByteString
buf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> AppContext ByteString
readCharL Handle
hdl

    findLength :: B.ByteString -> AppContext Int
    findLength :: ByteString -> AppContext Int
findLength ByteString
buf = case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse forall {u}. ParsecT String u Identity Int
parser String
"find ContentLength parser" (ByteString -> String
lbs2str ByteString
buf) of
      Left ParseError
_  -> ByteString -> AppContext Int
go ByteString
buf
      Right Int
l -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
l

    parser :: ParsecT String u Identity Int
parser = do
      forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
_CONTENT_LENGTH
      String
len <- forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
_TWO_CRLF)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read forall a b. (a -> b) -> a -> b
$ String
len


---------------------------------------------------------------------------------
-- |
--
lbs2req :: ConduitT B.ByteString WrapRequest AppContext ()
lbs2req :: ConduitT ByteString WrapRequest AppContext ()
lbs2req = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
L.debugM String
_LOG_REQUEST forall a b. (a -> b) -> a -> b
$ String
"lbs2req start waiting."
  forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe ByteString
Nothing  -> do
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"unexpectHed Nothing."
    Just ByteString
reqBS -> do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
L.debugM String
_LOG_REQUEST forall a b. (a -> b) -> a -> b
$ String
"lbs2req get data. " forall a. [a] -> [a] -> [a]
++ ByteString -> String
lbs2str ByteString
reqBS
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ByteString -> AppContext (Maybe WrapRequest)
goApp ByteString
reqBS) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe WrapRequest
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just WrapRequest
rq -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield WrapRequest
rq
      ConduitT ByteString WrapRequest AppContext ()
lbs2req

  where
    goApp :: B.ByteString -> AppContext (Maybe WrapRequest)
    goApp :: ByteString -> AppContext (Maybe WrapRequest)
goApp ByteString
reqBS = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError forall {a}.
String -> StateT AppStores (ExceptT String IO) (Maybe a)
errHdl forall a b. (a -> b) -> a -> b
$ do
      Request
req <- ByteString -> AppContext Request
decodeRequest ByteString
reqBS
      WrapRequest
reqW <- ByteString -> Request -> AppContext WrapRequest
createWrapRequest ByteString
reqBS Request
req
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just WrapRequest
reqW

    -- |
    --
    errHdl :: String -> StateT AppStores (ExceptT String IO) (Maybe a)
errHdl String
msg = do
      String -> String -> AppContext ()
warnEV String
_LOG_REQUEST String
msg
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- |
--
decodeRequest :: B.ByteString -> AppContext DAP.Request
decodeRequest :: ByteString -> AppContext Request
decodeRequest ByteString
bs = forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs

-- |
--
createWrapRequest :: B.ByteString -> DAP.Request -> AppContext WrapRequest
createWrapRequest :: ByteString -> Request -> AppContext WrapRequest
createWrapRequest ByteString
bs Request
req
  | String
"initialize" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitializeRequest -> Request InitializeRequest
InitializeRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"launch"     forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. LaunchRequest -> Request LaunchRequest
LaunchRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"disconnect" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. DisconnectRequest -> Request DisconnectRequest
DisconnectRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"pause" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. PauseRequest -> Request PauseRequest
PauseRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"terminate" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerminateRequest -> Request TerminateRequest
TerminateRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"setBreakpoints" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetBreakpointsRequest -> Request SetBreakpointsRequest
SetBreakpointsRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"setFunctionBreakpoints" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetFunctionBreakpointsRequest
-> Request SetFunctionBreakpointsRequest
SetFunctionBreakpointsRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"setExceptionBreakpoints" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetExceptionBreakpointsRequest
-> Request SetExceptionBreakpointsRequest
SetExceptionBreakpointsRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"configurationDone" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigurationDoneRequest -> Request ConfigurationDoneRequest
ConfigurationDoneRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"threads" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadsRequest -> Request ThreadsRequest
ThreadsRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"stackTrace" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackTraceRequest -> Request StackTraceRequest
StackTraceRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"scopes" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopesRequest -> Request ScopesRequest
ScopesRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"variables" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. VariablesRequest -> Request VariablesRequest
VariablesRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"source" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceRequest -> Request SourceRequest
SourceRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"continue" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContinueRequest -> Request ContinueRequest
ContinueRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"next" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. NextRequest -> Request NextRequest
NextRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"stepIn" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. StepInRequest -> Request StepInRequest
StepInRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"evaluate" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluateRequest -> Request EvaluateRequest
EvaluateRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | String
"completions" forall a. Eq a => a -> a -> Bool
== Request -> String
DAP.commandRequest Request
req = forall a. Request a -> WrapRequest
WrapRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompletionsRequest -> Request CompletionsRequest
CompletionsRequest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs))
  | Bool
otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"unsupported request command. " forall a. [a] -> [a] -> [a]
++ ByteString -> String
lbs2str ByteString
bs


---------------------------------------------------------------------------------
-- |
--
sink :: ConduitT WrapRequest Void AppContext ()
sink :: ConduitT WrapRequest Void AppContext ()
sink = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
L.debugM String
_LOG_REQUEST forall a b. (a -> b) -> a -> b
$ String
"sink start waiting."
  forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe WrapRequest
Nothing  -> do
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"unexpected Nothing."
      forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just WrapRequest
req -> do
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ WrapRequest -> AppContext ()
goApp WrapRequest
req
      ConduitT WrapRequest Void AppContext ()
sink

  where
    -- |
    --
    goApp :: WrapRequest -> AppContext ()
    goApp :: WrapRequest -> AppContext ()
goApp = WrapRequest -> AppContext ()
addRequest