{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultilineStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NondecreasingIndentation #-}
module GHC.Debugger.Debuggee where

import System.Process
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Function
import Data.Maybe
import Prelude hiding (mod)
import Network.Socket hiding (Debug)
import System.Process.Internals (mkProcessHandle)
import Text.Read (readMaybe)
import System.Environment (getExecutablePath)
import Data.Text (Text)

import GHC
import GHC.Driver.Env as GHC
import GHC.Driver.Monad
import GHC.Driver.Hooks
import GHC.Driver.Ppr
import GHC.Runtime.Interpreter as GHCi
import GHC.Types.Error
import qualified GHC.Utils.Logger as GHC

import GHC.Debugger.Session

import Colog.Core as Logger

import GHCi.Message (mkPipeFromHandles)
import System.IO (hGetLine, IOMode(..), openFile, Handle)
import qualified GHC.Linker.Loader as Loader
import GHC.Stack.Annotation
import GHC.Platform.Ways
#if MIN_VERSION_ghc(9,15,0)
import GHC.Data.FastString.Env (emptyFsEnv)
#endif
import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger`

data InterpreterSettings = InterpreterSettings
      { InterpreterSettings -> DynFlags -> DynFlags
interpreterFlags :: DynFlags -> DynFlags
      , InterpreterSettings
-> forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
interpreterSetup :: forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
      }

mkInternalInterpreterFlags :: DynFlags -> DynFlags
mkExternalInterpreterFlags :: String -> DynFlags -> DynFlags
(DynFlags -> DynFlags
mkInternalInterpreterFlags, String -> DynFlags -> DynFlags
mkExternalInterpreterFlags) = (Bool -> String -> DynFlags -> DynFlags
mkInterpreterFlags Bool
True String
"", Bool -> String -> DynFlags -> DynFlags
mkInterpreterFlags Bool
False)
  where
    mkInterpreterFlags :: Bool -> String -> DynFlags -> DynFlags
    mkInterpreterFlags :: Bool -> String -> DynFlags -> DynFlags
mkInterpreterFlags Bool
preferInternalInterpreter String
externalInterpreterProg DynFlags
df = DynFlags
df
      -- Enable the external interpreter by default! See #169
      -- See Note [Custom external interpreter]
      DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& Bool -> DynFlags -> DynFlags
enableExternalInterpreter Bool
preferInternalInterpreter
      -- Ext interp is the same program as this, with "--external-interpreter"
      -- (this is ignored on GHC 9.14, see Note [Custom external interpreter])
      DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& String -> DynFlags -> DynFlags
setPgmI String
externalInterpreterProg
      -- ideally, we'd set "external-interpreter" *before* the file
      -- descriptors. since there's no way to do that yet, we just have
      -- some logic in main to detect [writefd, readfd, --external-interpreter]
      DynFlags -> (DynFlags -> DynFlags) -> DynFlags
forall a b. a -> (a -> b) -> b
& String -> DynFlags -> DynFlags
addOptI String
"--external-interpreter"


mkInternalInterpreterSetup :: LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
mkInternalInterpreterSetup :: forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
mkInternalInterpreterSetup LogAction IO DebuggerLog
_ DynFlags
dflags Ghc a
mainGhcThread = do
  Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
    InconsistentInterpreterFlags -> Ghc ()
forall a e. (HasCallStack, Exception e) => e -> a
throw (InconsistentInterpreterFlags -> Ghc ())
-> InconsistentInterpreterFlags -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> InconsistentInterpreterFlags
InconsistentInterpreterFlags (String -> InconsistentInterpreterFlags)
-> String -> InconsistentInterpreterFlags
forall a b. (a -> b) -> a -> b
$ String
"Used ghc flag  -fexternal-interpreter together with --internal-interpreter haskell-debugger flag."
  Ghc a
mainGhcThread

newtype InconsistentInterpreterFlags = InconsistentInterpreterFlags String
instance Show InconsistentInterpreterFlags where
  show :: InconsistentInterpreterFlags -> String
show (InconsistentInterpreterFlags String
t) = String
"Interpreter flags are inconsistent: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t
instance Exception InconsistentInterpreterFlags


mkExternalInterpreterFromIOSetup :: IO Interp -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
mkExternalInterpreterFromIOSetup :: forall a.
IO Interp -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
mkExternalInterpreterFromIOSetup IO Interp
m LogAction IO DebuggerLog
_l DynFlags
dflags Ghc a
mainGhcThread = do
  Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
    InconsistentInterpreterFlags -> Ghc ()
forall a e. (HasCallStack, Exception e) => e -> a
throw (InconsistentInterpreterFlags -> Ghc ())
-> InconsistentInterpreterFlags -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> InconsistentInterpreterFlags
InconsistentInterpreterFlags (String -> InconsistentInterpreterFlags)
-> String -> InconsistentInterpreterFlags
forall a b. (a -> b) -> a -> b
$ String
"Used ghc flag  -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag."
  extInterp <- IO Interp -> Ghc Interp
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Interp
m
  modifySession $ \HscEnv
h -> HscEnv
h
    { hsc_interp = Just extInterp -- set it directly!
    }

  mainGhcThread

type CreatedProcess = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

-- | Takes @std_in, std_out, std_err@ fields for @createProcess@ and a callback for the result.
mkExternalInterpreterSubProcessSetup
  :: StdStream -> StdStream -> StdStream
  -> (CreatedProcess -> IO ())
  -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
mkExternalInterpreterSubProcessSetup :: forall a.
StdStream
-> StdStream
-> StdStream
-> (CreatedProcess -> IO ())
-> LogAction IO DebuggerLog
-> DynFlags
-> Ghc a
-> Ghc a
mkExternalInterpreterSubProcessSetup StdStream
std_in StdStream
std_out StdStream
std_err CreatedProcess -> IO ()
putHandles LogAction IO DebuggerLog
_l DynFlags
dflags Ghc a
mainGhcThread = do
  Bool -> Ghc () -> Ghc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalInterpreter DynFlags
dflags) (Ghc () -> Ghc ()) -> Ghc () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ do
    InconsistentInterpreterFlags -> Ghc ()
forall a e. (HasCallStack, Exception e) => e -> a
throw (InconsistentInterpreterFlags -> Ghc ())
-> InconsistentInterpreterFlags -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> InconsistentInterpreterFlags
InconsistentInterpreterFlags (String -> InconsistentInterpreterFlags)
-> String -> InconsistentInterpreterFlags
forall a b. (a -> b) -> a -> b
$ String
"Used ghc flag  -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag."

  (HscEnv -> HscEnv) -> Ghc ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> Ghc ()) -> (HscEnv -> HscEnv) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h -> HscEnv
h
    { hsc_hooks = (hsc_hooks h)
        { createIservProcessHook = Just $ \CreateProcess
cp -> do
            -- See Note [External interpreter buffering]
            p@(_, _, _, ph) <-
              CreateProcess -> IO CreatedProcess
createProcess CreateProcess
cp
                { std_in
                , std_out
                , std_err
                -- Override executable path
                -- See Note [Custom external interpreter]
#if MIN_VERSION_ghc(9,15,0)
#else
                , cmdspec = case cmdspec cp of
                    ShellCommand (String -> [String]
words -> [String]
ws) -> String -> CmdSpec
ShellCommand (String -> CmdSpec) -> String -> CmdSpec
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ DynFlags -> String
getPgmI DynFlags
dflags String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
ws
                    RawCommand String
_fp [String]
args -> String -> [String] -> CmdSpec
RawCommand (DynFlags -> String
getPgmI DynFlags
dflags) [String]
args
#endif
                }
            putHandles p
            return ph
        }
    }
  Ghc a
mainGhcThread

-- | Make an 'ExtInterpInstance' based on an external interpreter process
-- running as 'hdb external-interpreter --port $port'.
--
-- The process is expected to connect to '$port' and send its own PID as the
-- first line on the socket before the GHCi wire protocol begins.
--
-- The given 'Socket' should be listening on '$port'.
--
-- Note: no attempt is made to capture the standard input/output/error.
extInterpFromListeningSocket :: Socket -> IO Interp
extInterpFromListeningSocket :: Socket -> IO Interp
extInterpFromListeningSocket Socket
sock0 = do
  port <- Socket -> IO PortNumber
socketPort Socket
sock0
  putStrLn $ "Connected to " ++ show port
  Control.Exception.bracketOnError
    (accept sock0)
    (\ (Socket
sock,SockAddr
_) -> Socket -> IO ()
close Socket
sock0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Socket -> IO ()
close Socket
sock)
    (\ (Socket
sock,SockAddr
_) -> do
      bi_h <- Socket -> IOMode -> IO Handle
socketToHandle Socket
sock IOMode
ReadWriteMode

      pidLine <- annotateCallStackIO $ hGetLine bi_h

      pid <- case readMaybe pidLine :: Maybe Int of
        Just Int
pid -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
pid
        Maybe Int
Nothing  -> String -> IO Int
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail (String -> IO Int) -> String -> IO Int
forall a b. (a -> b) -> a -> b
$ String
"invalid external interpreter PID on socket: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
pidLine
      ph <- mkProcessHandle (fromIntegral pid) False
      interpPipe <- mkPipeFromHandles bi_h bi_h
      lock <- newMVar ()
      let process = InterpProcess
                      { interpHandle :: ProcessHandle
interpHandle = ProcessHandle
ph
                      , Pipe
interpPipe :: Pipe
interpPipe :: Pipe
interpPipe
                      , interpLock :: MVar ()
interpLock   = MVar ()
lock
                      }

      pending_frees <- newMVar []
      let inst = ExtInterpInstance
            { instProcess :: InterpProcess
instProcess           = InterpProcess
process
            , instPendingFrees :: MVar [HValueRef]
instPendingFrees      = MVar [HValueRef]
pending_frees
            , instExtra :: ()
instExtra             = ()
            }
          conf = IServConfig
            { iservConfProgram :: String
iservConfProgram  = String
"the process is already running, we should never need to run it again"
            , iservConfOpts :: [String]
iservConfOpts     = []
              -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger]
            , iservConfDynamic :: Bool
iservConfDynamic  = Bool
hostIsDynamic
            , iservConfProfiled :: Bool
iservConfProfiled = Bool
hostIsProfiled
            , iservConfHook :: Maybe (CreateProcess -> IO ProcessHandle)
iservConfHook     = Maybe (CreateProcess -> IO ProcessHandle)
forall a. Maybe a
Nothing -- it's already running!
            , iservConfTrace :: IO ()
iservConfTrace    = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            }

      lookup_cache <- mkInterpSymbolCache
      s            <- newMVar $ InterpRunning inst
      loader       <- Loader.uninitializedLoader
#if MIN_VERSION_ghc(9,15,0)
      fs_cache     <- newMVar emptyFsEnv
      return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache)
#else
      return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)
#endif
      )

mkCliInterpreterSettings :: Bool -> Maybe FilePath -> IO InterpreterSettings
mkCliInterpreterSettings :: Bool -> Maybe String -> IO InterpreterSettings
mkCliInterpreterSettings Bool
internalInterpreter Maybe String
debuggeeStdin = do
  if Bool
internalInterpreter then InterpreterSettings -> IO InterpreterSettings
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InterpreterSettings -> IO InterpreterSettings)
-> InterpreterSettings -> IO InterpreterSettings
forall a b. (a -> b) -> a -> b
$ InterpreterSettings { interpreterFlags :: DynFlags -> DynFlags
interpreterFlags  = DynFlags -> DynFlags
mkInternalInterpreterFlags
    , interpreterSetup :: forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
interpreterSetup = LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a
mkInternalInterpreterSetup } else do
  stdinStream <- case Maybe String
debuggeeStdin of
    Just String
fp -> Handle -> StdStream
UseHandle (Handle -> StdStream) -> IO Handle -> IO StdStream
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IOMode -> IO Handle
System.IO.openFile String
fp IOMode
ReadMode
    Maybe String
Nothing -> StdStream -> IO StdStream
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StdStream
Inherit
  -- the same program invoked with `external-interpreter` serves as the external interpreter
  thisProg <- getExecutablePath
  pure InterpreterSettings { interpreterFlags = mkExternalInterpreterFlags thisProg
    , interpreterSetup = mkExternalInterpreterSubProcessSetup stdinStream Inherit Inherit (const $ pure ())
    }

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

-- | A debugger log. May include debuggee ouput.
data DebuggerLog
  = DebuggerLog !Logger.Severity !DebuggerMessage
  | GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc
  | DebuggerSessionLog !Logger.Severity !Text

-- | A debugger log message
data DebuggerMessage
  = LogSDoc !DynFlags !SDoc
  | LogFailedToCompileBuiltinModule !GHC.ModuleName
  | LogSkippingViewModuleNoPkg !GHC.ModuleName String [String]

instance Show DebuggerMessage where
  show :: DebuggerMessage -> String
show = \ case
    LogFailedToCompileBuiltinModule ModuleName
mn ->
      String
"Failed to compile built-in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
mn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" module! Ignoring these custom debug views."
    LogSkippingViewModuleNoPkg ModuleName
mn String
pkg [String]
uids ->
      String
"Skipping compilation of built-in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
moduleNameString ModuleName
mn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" module because package "
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
pkg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" wasn't found in dependencies " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
uids
    LogSDoc DynFlags
dflags SDoc
doc -> DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
doc


ghcLogAction :: LogAction IO DebuggerLog -> GHC.LogAction
ghcLogAction :: LogAction IO DebuggerLog -> LogAction
ghcLogAction LogAction IO DebuggerLog
l = \LogFlags
logflags MessageClass
mclass SrcSpan
srcSpan SDoc
sdoc -> do
    LogAction IO DebuggerLog -> LogAction IO DebuggerLog
forall (m :: * -> *) msg.
MonadIO m =>
LogAction IO msg -> LogAction m msg
liftLogIO LogAction IO DebuggerLog
l LogAction IO DebuggerLog -> DebuggerLog -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& LogFlags -> MessageClass -> SrcSpan -> SDoc -> DebuggerLog
GHCLog LogFlags
logflags MessageClass
mclass SrcSpan
srcSpan SDoc
sdoc

msgClassSeverity :: MessageClass -> Logger.Severity
msgClassSeverity :: MessageClass -> Severity
msgClassSeverity = \case
  MessageClass
MCOutput -> Severity
Info
  MessageClass
MCFatal -> Severity
Logger.Error
  MessageClass
MCInteractive -> Severity
Info
  MessageClass
MCDump -> Severity
Debug
  MessageClass
MCInfo -> Severity
Info
  MCDiagnostic Severity
SevIgnore ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_ -> Severity
Debug -- ?
  MCDiagnostic Severity
SevWarning ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_ -> Severity
Logger.Warning
  MCDiagnostic Severity
SevError ResolvedDiagnosticReason
_ Maybe DiagnosticCode
_ -> Severity
Logger.Error