{-# 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 appData = do
  L.debugM _LOG_REQUEST "start request app"
  _ <- runApp appData app
  L.debugM _LOG_REQUEST "end request app"


-- |
--
app :: AppContext ()
app = flip catchError errHdl $ do
  _ <- runConduit pipeline
  return ()

  where
    pipeline :: ConduitM () Void AppContext ()
    pipeline = src .| lbs2req .| sink

    errHdl msg = do
      criticalEV _LOG_REQUEST msg
      addEvent CriticalExitEvent


---------------------------------------------------------------------------------
-- |
--
src :: ConduitT () B.ByteString AppContext ()
src = do
  liftIO $ L.debugM _LOG_REQUEST $ "src start waiting."
  bs <- lift goApp
  yield bs
  src

  where
    goApp :: AppContext B.ByteString
    goApp = do
      bs <- getContentLength >>= getContent
      stdinLogging bs
      return bs


-- |
--
getContent :: Int -> AppContext B.ByteString
getContent l = view inHandleAppStores <$> get
           >>= flip readCharsL l


-- |
--
getContentLength :: AppContext Int
getContentLength = go B.empty
  where
    go :: B.ByteString -> AppContext Int
    go buf = updateBuf buf >>= findLength

    updateBuf :: B.ByteString -> AppContext B.ByteString
    updateBuf buf = do
      hdl <- view inHandleAppStores <$> get
      B.append buf <$> readCharL hdl

    findLength :: B.ByteString -> AppContext Int
    findLength buf = case parse parser "find ContentLength parser" (lbs2str buf) of
      Left _  -> go buf
      Right l -> return l

    parser = do
      string _CONTENT_LENGTH
      len <- manyTill digit (string _TWO_CRLF)
      return . read $ len


---------------------------------------------------------------------------------
-- |
--
lbs2req :: ConduitT B.ByteString WrapRequest AppContext ()
lbs2req = do
  liftIO $ L.debugM _LOG_REQUEST $ "lbs2req start waiting."
  await >>= \case
    Nothing  -> do
      throwError $ "unexpectHed Nothing."
    Just reqBS -> do
      liftIO $ L.debugM _LOG_REQUEST $ "lbs2req get data. " ++ lbs2str reqBS
      lift (goApp reqBS) >>= \case
        Nothing -> return ()
        Just rq -> yield rq
      lbs2req

  where
    goApp :: B.ByteString -> AppContext (Maybe WrapRequest)
    goApp reqBS = flip catchError errHdl $ do
      req <- decodeRequest reqBS
      reqW <- createWrapRequest reqBS req
      return $ Just reqW

    -- |
    --
    errHdl msg = do
      warnEV _LOG_REQUEST msg
      return Nothing

-- |
--
decodeRequest :: B.ByteString -> AppContext DAP.Request
decodeRequest bs = liftEither $ eitherDecode bs

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


---------------------------------------------------------------------------------
-- |
--
sink :: ConduitT WrapRequest Void AppContext ()
sink = do
  liftIO $ L.debugM _LOG_REQUEST $ "sink start waiting."
  await >>= \case
    Nothing  -> do
      throwError $ "unexpected Nothing."
      return ()
    Just req -> do
      lift $ goApp req
      sink

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