{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, CPP, DeriveAnyClass,
   DeriveGeneric, DerivingVia, LambdaCase, RecordWildCards, ViewPatterns,
   DataKinds #-}
module Main where

import System.Process
import System.Environment
import Control.Exception (bracket, uninterruptibleMask, bracketOnError)
import Control.Exception.Backtrace

import DAP

import Development.Debug.Adapter.Init
import Development.Debug.Adapter.Handles
import Development.Debug.Adapter.Server
import Colog.Core

import System.IO
  ( hFlush
  , hClose
  , hPutStrLn
  , hSetBuffering
  , BufferMode(..)
  , Handle

  , IOMode(ReadWriteMode)
  )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import GHC.IO.Handle.FD
import Data.Functor.Contravariant
import Network.Socket hiding (Debug)

import qualified GHCi.Server as GHCi
import qualified GHCi.Signals as GHCi
import qualified GHCi.Utils as GHCi
import qualified GHCi.Message as GHCi

import GHC.Debugger.Monad (RunDebuggerSettings(..))
import Development.Debug.Options (HdbOptions(..))
import Development.Debug.Options.Parser (parseHdbOptions)
import Development.Debug.Adapter.Proxy
import Development.Debug.Interactive
import GHC.Stack.Annotation (annotateCallStackIO)
import GHC.Utils.Logger (defaultLogActionWithHandles)
import Development.Debug.Session.Setup (hieDebugRunner)
import GHC.Debugger.Debuggee (mkCliInterpreterSettings)
import GHC.Debugger.Session (initUniqSupplyIO)

#if MIN_VERSION_ghc(9,15,0)
import GHC.Debugger.Runtime.Interpreter.Custom (dbgInterpCmdHandler)
#endif

--------------------------------------------------------------------------------

main :: IO ()
main = do
  setBacktraceMechanismState CostCentreBacktrace False
  setBacktraceMechanismState HasCallStackBacktrace True

  allArgs <- getArgs
  hdbOpts <- case allArgs of
    [writeFd, readFd, "--external-interpreter"] ->
         -- Special case to detect --external-interpreter in the third
         -- position. If we could specify -opti options to put *before* the
         -- descriptors we could get rid of this.
         pure (HdbExternalInterpreter (read writeFd) (read readFd) Error)
    _ -> parseHdbOptions
  case hdbOpts of
    HdbDAPServer{port, internalInterpreter, disableIpeBacktraces} -> do
      setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces)
      config <- getConfig port
      -- the same program invoked with `external-interpreter` serves as the external interpreter
      hdbProgram <- getExecutablePath

      -- See Note [UniqueSupply is process global]
      initUniqSupplyIO

      let servConf = DAPServerConf
            { getDebugRunner = hieDebugRunner
            , hdbProgram
            , dapServerConfig = config
            }
      redirectRealStdout internalInterpreter $ \realStdout -> do
        hSetBuffering realStdout LineBuffering
        l <- contramap DAPLog <$> mainLogger hdbOpts.verbosity realStdout
        runDAPServerWithLogger (contramap DAPLibraryLog l) config
          (talk l servConf internalInterpreter)
          (ack l )
    HdbCLI{..} -> do
        setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces)

        -- See Note [UniqueSupply is process global]
        initUniqSupplyIO

        l <- mainLogger hdbOpts.verbosity stdout
        cliInterpSettings <- mkCliInterpreterSettings internalInterpreter debuggeeStdin
        let runConf = RunDebuggerSettings
              { supportsANSIStyling = True -- todo: check!!
              , supportsANSIHyperlinks = False
              , interpreterSettings = cliInterpSettings }
        runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs cradleFile
          runConf debugInteractive
    HdbProxy{port} -> do
        setBacktraceMechanismState IPEBacktrace True
        l <- mainLogger hdbOpts.verbosity stdout
        runInTerminalHdbProxy (contramap RunProxyClientLog l) port
    HdbExternalInterpreter{writeFd, readFd} -> do
      inh  <- GHCi.readGhcHandle (show readFd)
      outh <- GHCi.readGhcHandle (show writeFd)
      runExternalInterpreterServer inh outh hdbOpts.verbosity
    HdbExternalInterpreterPort{port} -> do
      pid <- getCurrentPid
      withExternalInterpreterPort (fromIntegral port) $ \h -> do
        hPutStrLn h (show pid)
        hFlush h
        runExternalInterpreterServer h h hdbOpts.verbosity
  where
    runExternalInterpreterServer inh outh verbosity = do
      GHCi.installSignalHandlers
      pipe <- GHCi.mkPipeFromHandles inh outh
      let verbose = verbosity <= Info -- Debug || Info
#if MIN_VERSION_ghc(9,14,2)
      uninterruptibleMask $ \restore -> do
        GHCi.servWithCustom verbose hook pipe restore dbgInterpCmdHandler
#else
      uninterruptibleMask $ GHCi.serv verbose hook pipe
#endif
      where hook = return -- empty hook
        -- we cannot allow any async exceptions while communicating, because
        -- we will lose sync in the protocol, hence uninterruptibleMask.

    withExternalInterpreterPort :: PortNumber -> (Handle -> IO a) -> IO a
    withExternalInterpreterPort port k = do
      bracket (mkHandleFromPortSock "127.0.0.1" port) hClose $ \ h -> do
        annotateCallStackIO $ k h

    mkHandleFromPortSock :: HostName -> PortNumber -> IO Handle
    mkHandleFromPortSock host port = do
      let hints = defaultHints { addrSocketType = Stream }
      addr:_ <- getAddrInfo (Just hints) (Just host) (Just (show port))

      Control.Exception.bracketOnError
        (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
        close
        (\sock -> do
            -- Don't delay, avoids batching
            setSocketOption sock NoDelay 1
            connect sock (addrAddress addr)
            h <- socketToHandle sock ReadWriteMode
            hSetBuffering h NoBuffering
            return h)

    -- When using the internal interpreter in DAP mode, we can't write to
    -- stdout directly because there will also be a thread forwarding the
    -- debuggee stdout by capturing it from stdout (and we'd get into a loop
    -- trying to forward what we're writing).
    --
    -- The redirection we use requires hDuplicateTo which isn't supported on
    -- Windows (ghc#22146), so using the internal interpreter on Windows
    -- currently unsupported.
    --
    -- When using the external interpreter, the debuggee output is read from
    -- its process handle directly, so this is unnecessary.
    redirectRealStdout internalInterpreter k
      | internalInterpreter =
        withInterceptedStdoutForwarding
          (\interceptedOut -> T.hPutStrLn stderr ("[INTERCEPTED STDOUT] " <> interceptedOut))
          (\realStdout -> k realStdout)
      | otherwise = k stdout



--------------------------------------------------------------------------------
-- * Logging
--------------------------------------------------------------------------------

data MainLog
  = InteractiveLog InteractiveLog
  | RunProxyClientLog (WithSeverity T.Text)
  | DAPLog DAPLog

-- | Given the severity threshold from which we start logging, create a base
-- logger for consuming the top-level debugger logs ('MainLog').
-- Outputs to given handle.
mainLogger :: Severity -> Handle -> IO (LogAction IO MainLog)
mainLogger threshold h = do
  l <- handleLogger h
  let logGhcLog = defaultLogActionWithHandles h h
  pure $ LogAction $ \case
    InteractiveLog (ISessionSetupLog sessionLog) -> logSessionLog l threshold sessionLog
    InteractiveLog (IDebuggerLog debuggerLog)    -> logDebuggerLog logGhcLog l threshold debuggerLog
    RunProxyClientLog sev_msg -> defaultLog l threshold sev_msg
    DAPLog dapLog -> logDAPLog logGhcLog l threshold <& dapLog