haskell-debugger-0.14.0.0: hdb-dap/Development/Debug/Adapter/Server.hs
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Development.Debug.Adapter.Server
(
module Development.Debug.Adapter.Server,
LogAction(..),
)
where
import System.Environment
import Data.Maybe
import Text.Read
import Control.Monad
import Control.Monad.IO.Class
import Control.Concurrent (ThreadId, myThreadId)
import GHC.Conc.Sync (threadLabel)
import DAP
import Development.Debug.Adapter.Init
import Development.Debug.Adapter.Breakpoints
import Development.Debug.Adapter.Stepping
import Development.Debug.Adapter.Stopped
import Development.Debug.Adapter.Evaluation
import Development.Debug.Adapter.ExceptionInfo
import Development.Debug.Adapter.Exit
import Development.Debug.Adapter.Exit.Helpers
import Colog.Core
import Data.Time
import qualified DAP.Log as DAP
import Data.Text (Text)
import qualified Data.Text as T
import Data.Functor.Contravariant
import Development.Debug.Adapter
import qualified GHC.Utils.Logger as GHC
import GHC.Debugger.Debuggee (DebuggerLog(..))
import qualified GHC.Plugins as GHC
-------------------------------------------------------------------------
-- * DAP lib config
-------------------------------------------------------------------------
-- | Fetch config from environment, fallback to sane defaults
getConfig :: Int -> IO ServerConfig
getConfig port = do
let
hostDefault = "0.0.0.0"
portDefault = port
capabilities = Capabilities
{ supportsConfigurationDoneRequest = True
, supportsFunctionBreakpoints = True
, supportsConditionalBreakpoints = True
, supportsHitConditionalBreakpoints = True
, supportsEvaluateForHovers = False
-- Exception Breakpoints:
, exceptionBreakpointFilters = [ defaultExceptionBreakpointsFilter
{ exceptionBreakpointsFilterLabel = "All exceptions"
, exceptionBreakpointsFilterFilter = BREAK_ON_EXCEPTION
}
, defaultExceptionBreakpointsFilter
{ exceptionBreakpointsFilterLabel = "Uncaught exceptions"
, exceptionBreakpointsFilterFilter = BREAK_ON_ERROR
}
]
, supportsStepBack = False
, supportsSetVariable = False
, supportsRestartFrame = False
, supportsGotoTargetsRequest = False
, supportsStepInTargetsRequest = False
, supportsCompletionsRequest = False
, completionTriggerCharacters = []
, supportsModulesRequest = False
, additionalModuleColumns = [ defaultColumnDescriptor
{ columnDescriptorAttributeName = "Extra"
, columnDescriptorLabel = "Label"
}
]
, supportedChecksumAlgorithms = []
, supportsRestartRequest = False
, supportsExceptionOptions = True
, supportsValueFormattingOptions = True
, supportsExceptionInfoRequest = True
, supportTerminateDebuggee = False -- for now, when debugger is disconnected, we always kill the debuggee
, supportSuspendDebuggee = False
, supportsDelayedStackTraceLoading = False
, supportsLoadedSourcesRequest = False
, supportsLogPoints = True
, supportsTerminateThreadsRequest = False
, supportsSetExpression = False
, supportsTerminateRequest = True
, supportsDataBreakpoints = False
, supportsReadMemoryRequest = False
, supportsWriteMemoryRequest = False
, supportsDisassembleRequest = False
, supportsCancelRequest = False
-- Display which breakpoints are valid when user intends to set
-- breakpoint on given line:
, supportsBreakpointLocationsRequest = True
, supportsClipboardContext = False
, supportsSteppingGranularity = False
, supportsInstructionBreakpoints = False
, supportsExceptionFilterOptions = False
, supportsSingleThreadExecutionRequests = False
}
ServerConfig
<$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST"
<*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT"
<*> pure capabilities
<*> pure True
--------------------------------------------------------------------------------
-- * Talk
--------------------------------------------------------------------------------
-- | Main function where requests are received and Events + Responses are returned.
-- The core logic of communicating between the client <-> adaptor <-> debugger
-- is implemented in this function.
talk :: LogAction IO DAPLog
-> DAPServerConf
-> Bool
-- ^ Prefer internal interpreter
-> Command -> DebugAdaptor ()
--------------------------------------------------------------------------------
talk l servConf prefer_internal_interpreter = \ case
CommandInitialize -> do
sendInitializeResponse
--------------------------------------------------------------------------------
CommandLaunch -> do
launch_args <- getArguments
clientCaps <- getClientCapabilities
#ifdef mingw32_HOST_OS
-- On Windows, runInTerminal is currently unsupported
-- See #199
let runInTerminal = False
#else
let runInTerminal = fromMaybe False $ supportsRunInTerminalRequest =<< clientCaps
#endif
initDebugger (cmapM (\ (sId,x) -> DAPSessionLog sId <$> myThreadId <*> pure x) l) servConf
InterpreterChoice {runInTerminal, internal = prefer_internal_interpreter}
launch_args
sendLaunchResponse -- ack
sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session
liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info)
--------------------------------------------------------------------------------
CommandAttach -> do
sendTerminatedEvent (TerminatedEvent False)
destroyDebugSession
sendError (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing
--------------------------------------------------------------------------------
CommandBreakpointLocations -> commandBreakpointLocations
CommandSetBreakpoints -> commandSetBreakpoints
CommandSetFunctionBreakpoints -> commandSetFunctionBreakpoints
CommandSetExceptionBreakpoints -> commandSetExceptionBreakpoints
CommandExceptionInfo -> commandExceptionInfo
CommandSetDataBreakpoints -> undefined
CommandSetInstructionBreakpoints -> undefined
----------------------------------------------------------------------------
CommandLoadedSources -> undefined
----------------------------------------------------------------------------
CommandConfigurationDone -> do
sendConfigurationDoneResponse
DAS{waitForDebuggee} <- getDebugSession
liftIO $ waitForDebuggee
-- Configuration is finished. Start executing until it halts.
startExecution >>= handleEvalResult False
----------------------------------------------------------------------------
CommandThreads -> commandThreads
CommandStackTrace -> commandStackTrace
CommandScopes -> commandScopes
CommandVariables -> commandVariables
----------------------------------------------------------------------------
CommandContinue -> commandContinue
----------------------------------------------------------------------------
CommandNext -> commandNext
----------------------------------------------------------------------------
CommandStepIn -> commandStepIn
CommandStepOut -> commandStepOut
----------------------------------------------------------------------------
CommandEvaluate -> commandEvaluate
----------------------------------------------------------------------------
CommandTerminate -> commandTerminate
CommandDisconnect -> commandDisconnect
----------------------------------------------------------------------------
CommandModules -> sendModulesResponse (ModulesResponse [] Nothing)
CommandSource -> undefined
CommandPause -> pure () -- TODO
(CustomCommand "mycustomcommand") -> undefined
other -> do
terminateWithError ("Unsupported command: " <> show other)
-- | Receive reverse request responses (such as runInTerminal response)
ack :: LogAction IO DAPLog
-> ReverseRequestResponse -> DebugAdaptorCont ()
ack l rrr = case rrr.reverseRequestCommand of
ReverseCommandRunInTerminal -> do
RunInTerminalResponse{} <- getReverseRequestResponseBody rrr
-- TODO: keep track of body.shellProcessId to then kill the proxy when the
-- session is terminated:
-- [stdout] [127.0.0.1:54427][DEBUG][RECEIVED]
-- {
-- "body": {
-- "shellProcessId": 2092
-- },
-- "command": "runInTerminal",
-- "seq": 14,
-- "success": true,
-- "type": "response"
-- }
when rrr.success $ do
liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info)
_ -> pure ()
-- | Starts a DAP server for haskell debugging.
--
-- INVARIANT: The initUniqSupply has already been initialized.
--
-- Users of hdb-as-a-library will have to call `initUniqSupply` at their leisure,
-- special care needed if they supply any loaded units/modules to us via the `DebugRunner`,
-- as those will contain `Unique`s.
--
-- See Note [UniqueSupply is process global].
runHDBServer :: LogAction IO DAPLog -> DAPServerConf -> IO ()
runHDBServer l servConf@DAPServerConf{ dapServerConfig = config } = do
runDAPServerWithLogger (contramap DAPLibraryLog l) config
(talk l servConf False)
(ack l )
--------------------------------------------------------------------------------
-- * Logging
--------------------------------------------------------------------------------
data DAPLog
= DAPSessionLog !SessionId !ThreadId DAPSessionLog
| DAPLaunchLog (WithSeverity T.Text)
| DAPLibraryLog DAP.DAPLog
logSessionLog :: Show a => LogAction IO Text -> Severity -> WithSeverity a -> IO ()
logSessionLog l threshold (WithSeverity msg sev)
| sev >= threshold =
l <& (renderSeverity sev <> T.pack (show msg))
| otherwise = pure ()
logDebuggerLog :: GHC.LogAction -> LogAction IO Text -> Severity -> DebuggerLog -> IO ()
logDebuggerLog logGhcLog l threshold = \case
DebuggerLog sev msg ->
when (sev >= threshold) $
l <&
(renderSeverity sev <> T.pack (show msg))
GHCLog logflags msg_class srcSpan msg ->
logGhcLog logflags msg_class srcSpan msg
DebuggerSessionLog sev msg ->
when (sev >= threshold) $
l <&
(renderSeverity sev <> msg)
defaultLog :: LogAction IO Text -> Severity -> WithSeverity Text -> IO ()
defaultLog l threshold (WithSeverity msg sev)
| sev >= threshold =
l <& (renderSeverity sev <> msg)
| otherwise = pure ()
renderSessionId :: Text -> Text
renderSessionId sId = "[SESSID=" <> sId <> "]"
renderThreadLabel :: ThreadId -> IO Text
renderThreadLabel thId = do
let dropThreadId t = fromMaybe t $ T.stripPrefix "ThreadId " t
lbl <- maybe (dropThreadId $ T.show thId) T.pack <$> threadLabel thId
pure $ "[THREAD=" <> lbl <> "]"
renderWithDAPPrefix :: Text -> ThreadId -> Text -> IO Text
renderWithDAPPrefix sessionId thId msg = do
lbl <- renderThreadLabel thId
renderWithTimestamp (renderSessionId sessionId <> lbl <> msg)
-- | Main log action for the HDB DAP server. Takes a log action for ghc messages, a
-- Text log action for everything else, and a severity threshold.
logDAPLog :: GHC.LogAction -> LogAction IO Text -> Severity -> LogAction IO DAPLog
logDAPLog logGhcLog l threshold = LogAction $ \case
DAPSessionLog sessionId threadId msg -> do
let l1 = cmapM (renderWithDAPPrefix sessionId threadId) l
logGhcLog1 f mc sp sdoc = do
prefix <- renderWithDAPPrefix sessionId threadId ""
logGhcLog f mc sp (GHC.text (T.unpack prefix) GHC.<> sdoc)
case msg of
(DAPSessionSetupLog sessionLog) -> logSessionLog l1 threshold sessionLog
(DAPDebuggerLog debuggerLog) -> logDebuggerLog logGhcLog1 l1 threshold debuggerLog
(RunProxyServerLog sev_msg) -> defaultLog l1 threshold sev_msg
DAPLaunchLog sev_msg -> defaultLog (cmapM renderWithTimestamp l) threshold sev_msg
DAPLibraryLog t | convert t.severity >= threshold ->
l <& DAP.renderDAPLog t
| otherwise -> pure ()
where
convert DAP.DEBUG = Debug
convert DAP.INFO = Info
convert DAP.WARN = Warning
convert DAP.ERROR = Error
renderSeverity :: Severity -> Text
renderSeverity = \case
Debug -> "[DEBUG] "
Info -> "[INFO] "
Warning -> "[WARNING] "
Error -> "[ERROR] "
renderWithTimestamp :: Text -> IO Text
renderWithTimestamp msg = do
t <- getCurrentTime
let timeStamp = utcTimeToText t
pure $ "[" <> timeStamp <> "] " <> msg
where
utcTimeToText utcTime = T.pack $
formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime