content: {-# 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 appData = do
    L.debugM _LOG_RESPONSE "start response app"
    _ <- runApp appData app
    L.debugM _LOG_RESPONSE "end response app"
  
  
  -- |
  --
  app :: AppContext ()
  app = flip catchError errHdl $ do
    _ <- runConduit pipeline
    return ()
  
    where
      pipeline :: ConduitM () Void AppContext ()
      pipeline = src .| res2lbs .| sink
  
      errHdl msg = do
        criticalEV _LOG_REQUEST msg
        addEvent CriticalExitEvent
  
  ---------------------------------------------------------------------------------
  -- |
  --
  src :: ConduitT () Response AppContext ()
  src = do
    liftIO $ L.debugM _LOG_RESPONSE $ "src start waiting."
    res <- lift goApp
    yield res
    src
  
  
    where
      goApp :: AppContext Response
      goApp = get >>= liftIO . getResponse
  
  -- |
  --
  getResponse :: AppStores -> IO Response
  getResponse appDat = takeResponse appDat >>= \case
    Just res -> return res
    Nothing -> do
      threadDelay _1_MILLI_SEC
      getResponse appDat
  
  
  -- |
  --
  takeResponse :: AppStores -> IO (Maybe Response)
  takeResponse appData = do
    let ressMVar = appData^.resStoreAppStores
    isExists ressMVar >>= \case
      False -> return Nothing
      True  -> take1 ressMVar
  
    where
      isExists ressMVar = readMVar ressMVar >>= \case
        [] -> return False
        _  -> return True
  
      take1 ressMVar = takeMVar ressMVar >>= \case
        [] -> do
          putMVar ressMVar []
          return Nothing
        (x:xs) -> do
          putMVar ressMVar xs
          return $ Just x
  
  
  ---------------------------------------------------------------------------------
  -- |
  --
  res2lbs :: ConduitT Response B.ByteString AppContext ()
  res2lbs = do
    liftIO $ L.debugM _LOG_RESPONSE $ "res2lbs start waiting."
    await >>= \case
      Nothing -> do
        throwError $ "[CRITICAL][response][res2lbs] unexpectHed Nothing."
        return ()
      Just res -> do
        liftIO $ L.debugM _LOG_RESPONSE $ "res2lbs get data. " ++ show res
        bs <- lift $ goApp res
        yield bs
        res2lbs
  
    where
      goApp :: Response -> AppContext B.ByteString
      goApp = return . encode
  
  
  ---------------------------------------------------------------------------------
  -- |
  --
  sink :: ConduitT B.ByteString Void AppContext ()
  sink = do
    liftIO $ L.debugM _LOG_RESPONSE $ "sink start start."
    await >>= \case
      Nothing  -> do
        throwError $ "[CRITICAL][response][sink] unexpectHed Nothing."
        return ()
      Just bs -> do
        liftIO $ L.debugM _LOG_RESPONSE $ "sink get data. " ++ lbs2str bs
        lift $ goApp bs
        cont $ lbs2str bs
  
    where
      goApp bs = do
        wHdl <- view outHandleAppStores <$> get
        stdoutLogging bs
        liftIO $ sendResponse wHdl bs
  
      cont str
        | L.isInfixOf _KEY_DISCONNECT_RESPONCE str = do
          liftIO $ L.infoM _LOG_RESPONSE $ "disconnect. end of response thread."
        | otherwise = sink
  
  -- |
  --
  _KEY_DISCONNECT_RESPONCE :: String
  _KEY_DISCONNECT_RESPONCE = "\"command\":\"disconnect\""
  
  
  -- |
  --
  sendResponse :: S.Handle -> B.ByteString -> IO ()
  sendResponse hdl str = do
    B.hPut hdl $ str2lbs $ _CONTENT_LENGTH ++ (show (B.length str))
    B.hPut hdl $ str2lbs _TWO_CRLF
    B.hPut hdl str
    S.hFlush hdl
  
  