{-# 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