{-# LANGUAGE LambdaCase #-}
module Haskell.Debug.Adapter.Response where
import Control.Monad.IO.Class
import Data.Conduit
import Control.Lens
import Data.Aeson
import Control.Concurrent (threadDelay)
import qualified Data.ByteString.Lazy as B
import Control.Concurrent.MVar
import Control.Monad.State.Lazy
import qualified System.Log.Logger as L
import Control.Monad.Except
import qualified System.IO as S
import qualified Data.List as L
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_RESPONSE String
"start response 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_RESPONSE String
"end response 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 () Response 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 Response ByteString AppContext ()
res2lbs forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString 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 () Response AppContext ()
src :: ConduitT () Response 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_RESPONSE forall a b. (a -> b) -> a -> b
$ String
"src start waiting."
Response
res <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift AppContext Response
goApp
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Response
res
ConduitT () Response AppContext ()
src
where
goApp :: AppContext Response
goApp :: AppContext Response
goApp = forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppStores -> IO Response
getResponse
getResponse :: AppStores -> IO Response
getResponse :: AppStores -> IO Response
getResponse AppStores
appDat = AppStores -> IO (Maybe Response)
takeResponse AppStores
appDat forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just Response
res -> forall (m :: * -> *) a. Monad m => a -> m a
return Response
res
Maybe Response
Nothing -> do
Int -> IO ()
threadDelay Int
_1_MILLI_SEC
AppStores -> IO Response
getResponse AppStores
appDat
takeResponse :: AppStores -> IO (Maybe Response)
takeResponse :: AppStores -> IO (Maybe Response)
takeResponse AppStores
appData = do
let ressMVar :: MVar [Response]
ressMVar = AppStores
appDataforall s a. s -> Getting a s a -> a
^.Lens' AppStores (MVar [Response])
resStoreAppStores
forall {a}. MVar [a] -> IO Bool
isExists MVar [Response]
ressMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Bool
True -> forall {a}. MVar [a] -> IO (Maybe a)
take1 MVar [Response]
ressMVar
where
isExists :: MVar [a] -> IO Bool
isExists MVar [a]
ressMVar = forall a. MVar a -> IO a
readMVar MVar [a]
ressMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
[a]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
take1 :: MVar [a] -> IO (Maybe a)
take1 MVar [a]
ressMVar = forall a. MVar a -> IO a
takeMVar MVar [a]
ressMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> do
forall a. MVar a -> a -> IO ()
putMVar MVar [a]
ressMVar []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
(a
x:[a]
xs) -> do
forall a. MVar a -> a -> IO ()
putMVar MVar [a]
ressMVar [a]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
res2lbs :: ConduitT Response B.ByteString AppContext ()
res2lbs :: ConduitT Response ByteString AppContext ()
res2lbs = 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_RESPONSE forall a b. (a -> b) -> a -> b
$ String
"res2lbs 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 Response
Nothing -> do
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"[CRITICAL][response][res2lbs] unexpectHed Nothing."
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Response
res -> 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_RESPONSE forall a b. (a -> b) -> a -> b
$ String
"res2lbs get data. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Response
res
ByteString
bs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Response -> AppContext ByteString
goApp Response
res
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield ByteString
bs
ConduitT Response ByteString AppContext ()
res2lbs
where
goApp :: Response -> AppContext B.ByteString
goApp :: Response -> AppContext ByteString
goApp = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode
sink :: ConduitT B.ByteString Void AppContext ()
sink :: ConduitT ByteString 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_RESPONSE forall a b. (a -> b) -> a -> b
$ String
"sink start start."
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
"[CRITICAL][response][sink] unexpectHed Nothing."
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
bs -> 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_RESPONSE forall a b. (a -> b) -> a -> b
$ String
"sink get data. " forall a. [a] -> [a] -> [a]
++ ByteString -> String
lbs2str ByteString
bs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ByteString -> AppContext ()
goApp ByteString
bs
String -> ConduitT ByteString Void AppContext ()
cont forall a b. (a -> b) -> a -> b
$ ByteString -> String
lbs2str ByteString
bs
where
goApp :: ByteString -> AppContext ()
goApp ByteString
bs = do
Handle
wHdl <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' AppStores Handle
outHandleAppStores forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *). MonadState s m => m s
get
ByteString -> AppContext ()
stdoutLogging ByteString
bs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
sendResponse Handle
wHdl ByteString
bs
cont :: String -> ConduitT ByteString Void AppContext ()
cont String
str
| forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf String
_KEY_DISCONNECT_RESPONCE String
str = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
L.infoM String
_LOG_RESPONSE forall a b. (a -> b) -> a -> b
$ String
"disconnect. end of response thread."
| Bool
otherwise = ConduitT ByteString Void AppContext ()
sink
_KEY_DISCONNECT_RESPONCE :: String
_KEY_DISCONNECT_RESPONCE :: String
_KEY_DISCONNECT_RESPONCE = String
"\"command\":\"disconnect\""
sendResponse :: S.Handle -> B.ByteString -> IO ()
sendResponse :: Handle -> ByteString -> IO ()
sendResponse Handle
hdl ByteString
str = do
Handle -> ByteString -> IO ()
B.hPut Handle
hdl forall a b. (a -> b) -> a -> b
$ String -> ByteString
str2lbs forall a b. (a -> b) -> a -> b
$ String
_CONTENT_LENGTH forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show (ByteString -> Int64
B.length ByteString
str))
Handle -> ByteString -> IO ()
B.hPut Handle
hdl forall a b. (a -> b) -> a -> b
$ String -> ByteString
str2lbs String
_TWO_CRLF
Handle -> ByteString -> IO ()
B.hPut Handle
hdl ByteString
str
Handle -> IO ()
S.hFlush Handle
hdl