diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,18 @@ # Revision history for haskell-debugger +## 0.8.0.0 -- 2025-09-19 + +* Allow defaults for all settings except `entryFile` and return a proper error in that case +* Fix bug that crashed debugger when attempting to load newtype constructor closure +* Fix bug that broke displaying newtype variables +* (Vscode) Allow the debugger to be run without a launch.json file +* Don't display functions as a forceable thunk, instead just the type +* Add `--version` flag + ## 0.7.0.0 -- 2025-09-10 * Fix line buffering of debuggee output (thus, stepping through a print line, will indeed print it to the console now). + * In fact, this was only caused by not building with `--enable-executable-dynamic` ## 0.6.0.0 -- 2025-09-10 diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -1,6 +1,6 @@ cabal-version: 3.12 name: haskell-debugger -version: 0.8.0.0 +version: 0.9.0.0 synopsis: A step-through machine-interface debugger for GHC Haskell @@ -93,8 +93,7 @@ executable hdb import: warnings main-is: Main.hs - other-modules: Development.Debug.Adapter.Flags, - Development.Debug.Adapter.Breakpoints, + other-modules: Development.Debug.Adapter.Breakpoints, Development.Debug.Adapter.Stepping, Development.Debug.Adapter.Stopped, Development.Debug.Adapter.Evaluation, @@ -104,7 +103,16 @@ Development.Debug.Adapter.Exit, Development.Debug.Adapter.Handles, Development.Debug.Adapter, + + Development.Debug.Adapter.Proxy, + Development.Debug.Interactive, + + Development.Debug.Session.Setup, + + Development.Debug.Options, + Development.Debug.Options.Parser, + Paths_haskell_debugger autogen-modules: Paths_haskell_debugger build-depends: @@ -112,6 +120,7 @@ exceptions, aeson, bytestring, containers, filepath, process, mtl, unix, + unordered-containers >= 0.2.19 && < 0.3, haskell-debugger, hie-bios, @@ -122,9 +131,11 @@ prettyprinter, directory >= 1.3.9 && < 1.4, + network >= 3.2.8, + network-run >= 0.4.4, async >= 2.2.5 && < 2.3, text >= 2.1 && < 2.3, - dap >= 0.2 && < 1, + dap >= 0.3 && < 1, haskeline >= 0.8 && < 1, optparse-applicative >= 0.18 && < 0.20 @@ -136,11 +147,28 @@ test-suite haskell-debugger-test import: warnings default-language: Haskell2010 - -- other-modules: -- other-extensions: type: exitcode-stdio-1.0 hs-source-dirs: test/haskell/ main-is: Main.hs + other-modules: Test.DAP.RunInTerminal, Test.DAP, Test.Utils build-depends: base >=4.14, - haskell-debugger + haskell-debugger, + bytestring, text, + containers, + filepath, + process, + temporary >= 1.3, + + unordered-containers, + aeson-pretty >= 0.8.10, async >= 2.2.5, + dap, network, aeson, network-run, + random >= 1.3.1, + + tasty >= 1.5.3, + tasty-golden >= 2.3.5, + tasty-hunit >= 0.10.2, + regex >= 1.1 + build-tool-depends: haskell-debugger:hdb + ghc-options: -threaded diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs --- a/haskell-debugger/GHC/Debugger.hs +++ b/haskell-debugger/GHC/Debugger.hs @@ -5,7 +5,6 @@ import System.Exit import Control.Monad.IO.Class -import GHC.Types.Name.Occurrence (sizeOccEnv) import GHC.Debugger.Breakpoint import GHC.Debugger.Evaluation diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -10,7 +10,6 @@ import Data.Bits (xor) import GHC -import GHC.Types.Name.Occurrence (sizeOccEnv) import GHC.ByteCode.Breakpoints import GHC.Utils.Error (logOutput) import GHC.Driver.DynFlags as GHC @@ -76,42 +75,29 @@ Just (bix, spn) -> do let bid = BreakpointId { bi_tick_mod = ms_mod modl , bi_tick_index = bix } -#if MIN_VERSION_ghc(9,14,2) (changed, ibis) <- registerBreakpoint bid bp_status ModuleBreakpointKind -#else - changed <- registerBreakpoint bid bp_status ModuleBreakpointKind -#endif return $ BreakFound { changed = changed , sourceSpan = realSrcSpanToSourceSpan spn -#if MIN_VERSION_ghc(9,14,2) , breakId = ibis -#else - , breakId = bid -#endif } setBreakpoint FunctionBreak{function} bp_status = do logger <- getLogger resolveFunctionBreakpoint function >>= \case - Left e -> error (showPprUnsafe e) + Left e -> do + liftIO $ logOutput logger $ text $ + "Failed to resolve function breakpoint " ++ function ++ ".\n" ++ showPprUnsafe e ++ "\nIgnoring..." + return BreakNotFound Right (modl, mod_info, fun_str) -> do let modBreaks = GHC.modInfoModBreaks mod_info applyBreak (bix, spn) = do let bid = BreakpointId { bi_tick_mod = modl , bi_tick_index = bix } -#if MIN_VERSION_ghc(9,14,2) (changed, ibis) <- registerBreakpoint bid bp_status FunctionBreakpointKind -#else - changed <- registerBreakpoint bid bp_status FunctionBreakpointKind -#endif return $ BreakFound { changed = changed , sourceSpan = realSrcSpanToSourceSpan spn -#if MIN_VERSION_ghc(9,14,2) , breakId = ibis -#else - , breakId = bid -#endif } case maybe [] (findBreakForBind fun_str . imodBreaks_modBreaks) modBreaks of [] -> do diff --git a/haskell-debugger/GHC/Debugger/Evaluation.hs b/haskell-debugger/GHC/Debugger/Evaluation.hs --- a/haskell-debugger/GHC/Debugger/Evaluation.hs +++ b/haskell-debugger/GHC/Debugger/Evaluation.hs @@ -11,11 +11,13 @@ {-# LANGUAGE ViewPatterns #-} module GHC.Debugger.Evaluation where +import GHC.Utils.Outputable import Control.Monad.IO.Class import Control.Monad.Catch import qualified Data.List as List import Data.Maybe import System.FilePath +import System.Directory import qualified Prettyprinter as Pretty import GHC @@ -27,7 +29,6 @@ import GHC.Driver.Env as GHC import GHC.Runtime.Debugger.Breakpoints as GHC import qualified GHC.Unit.Module.ModSummary as GHC -import GHC.ByteCode.Breakpoints import GHC.Types.Name.Occurrence (mkVarOccFS) import GHC.Types.Name.Reader as RdrName (mkOrig) import GHC.Utils.Outputable as GHC @@ -116,9 +117,11 @@ findUnitIdOfEntryFile :: GhcMonad m => FilePath -> m GHC.ModSummary findUnitIdOfEntryFile fp = do + afp <- normalise <$> liftIO (makeAbsolute fp) modSums <- getAllLoadedModules - case List.find ((Just fp ==) . fmap normalise . GHC.ml_hs_file . GHC.ms_location ) modSums of - Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp + let normalisedModLoc = fmap normalise . GHC.ml_hs_file . GHC.ms_location + case List.find ((Just afp ==) . normalisedModLoc) modSums of + Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp ++ "\nCandidates were:\n" ++ unlines (map (show . normalisedModLoc) modSums) Just summary -> pure summary -- | Resume execution of the stopped debuggee program @@ -196,11 +199,7 @@ -- TODO: force the exception to display string with Backtrace? return EvalStopped{breakId = Nothing} ExecBreak {breakNames = _, breakPointId} -> -#if MIN_VERSION_ghc(9,14,2) return EvalStopped{breakId = breakPointId} -#else - return EvalStopped{breakId = toBreakpointId <$> breakPointId} -#endif -- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'. inspectName :: Name -> Debugger (Maybe VarInfo) diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -210,11 +210,7 @@ = BreakFound { changed :: !Bool -- ^ Did the status of the found breakpoint change? -#if MIN_VERSION_ghc(9,14,2) , breakId :: [GHC.InternalBreakpointId] -#else - , breakId :: GHC.BreakpointId -#endif -- ^ Internal breakpoint identifier (module + ix) (TODO: Don't expose GHC) , sourceSpan :: SourceSpan -- ^ Source span for interface @@ -233,11 +229,7 @@ data EvalResult = EvalCompleted { resultVal :: String, resultType :: String } | EvalException { resultVal :: String, resultType :: String } -#if MIN_VERSION_ghc(9,14,2) | EvalStopped { breakId :: Maybe GHC.InternalBreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} } -#else - | EvalStopped { breakId :: Maybe GHC.BreakpointId {-^ Did we stop at an exception (@Nothing@) or at a breakpoint (@Just@)? -} } -#endif -- | Evaluation failed for some reason other than completed/completed-with-exception/stopped. | EvalAbortedWith String deriving (Show, Generic) @@ -291,8 +283,6 @@ instance FromJSON VarInfo instance FromJSON VarFields -#if MIN_VERSION_ghc(9,14,2) - instance Show GHC.InternalBreakpointId where show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix @@ -306,20 +296,3 @@ parseJSON = withObject "InternalBreakpointId" $ \v -> GHC.InternalBreakpointId <$> (Module <$> (stringToUnit <$> v .: "module_unit") <*> (mkModuleName <$> v .: "module_name")) <*> v .: "ix" -#else - -instance Show GHC.BreakpointId where - show (GHC.BreakpointId m ix) = "BreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix - -instance ToJSON GHC.BreakpointId where - toJSON (GHC.BreakpointId (Module unit mn) ix) = - object [ "module_name" .= moduleNameString mn - , "module_unit" .= unitString unit - , "ix" .= ix - ] -instance FromJSON GHC.BreakpointId where - parseJSON = withObject "BreakpointId" $ \v -> GHC.BreakpointId - <$> (Module <$> (stringToUnit <$> v .: "module_unit") <*> (mkModuleName <$> v .: "module_name")) - <*> v .: "ix" - -#endif diff --git a/haskell-debugger/GHC/Debugger/Logger.hs b/haskell-debugger/GHC/Debugger/Logger.hs --- a/haskell-debugger/GHC/Debugger/Logger.hs +++ b/haskell-debugger/GHC/Debugger/Logger.hs @@ -22,6 +22,9 @@ cmap, cmapIO, cmapWithSev, + -- * Verbosity + Verbosity(..), + applyVerbosity, -- * Pretty printing of logs renderPrettyWithSeverity, @@ -39,7 +42,7 @@ import Control.Monad.IO.Class import Control.Monad ((>=>)) -import Colog.Core (Severity(..), WithSeverity(..)) +import Colog.Core (Severity(..), WithSeverity(..), filterBySeverity) import qualified Colog.Core as Colog import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Text (Text) @@ -66,8 +69,16 @@ Recorder { logger_ = \_ -> pure () } +-- | Logging verbosity, where all Severities matching or exceeding the threshold are printed +newtype Verbosity = Verbosity { threshold :: Severity } + +-- | Make this logger never report messages whose severity is below the given verbosity severity. +applyVerbosity :: Verbosity -> Recorder (WithSeverity a) -> Recorder (WithSeverity a) +applyVerbosity Verbosity{threshold} rc + = fromCologAction $ filterBySeverity threshold getSeverity (toCologAction rc) + logWith :: (HasCallStack, MonadIO m) => Recorder (WithSeverity msg) -> Severity -> msg -> m () -logWith (Recorder logger_) sev msg = logger_ $ WithSeverity msg sev +logWith Recorder{logger_} sev msg = logger_ $ WithSeverity msg sev cmap :: (a -> b) -> Recorder b -> Recorder a cmap = contramap diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -182,11 +182,7 @@ -- 'BreakpointStatus' being set. -- -- Returns @True@ when the breakpoint status is changed. -#if MIN_VERSION_ghc(9,14,2) registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger (Bool, [GHC.InternalBreakpointId]) -#else -registerBreakpoint :: GHC.BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool -#endif registerBreakpoint bp@GHC.BreakpointId { GHC.bi_tick_mod = mod , GHC.bi_tick_index = bid } status kind = do @@ -194,13 +190,9 @@ -- Set breakpoint in GHC session let breakpoint_count = breakpointStatusInt status hsc_env <- GHC.getSession -#if MIN_VERSION_ghc(9,14,2) internal_break_ids <- getInternalBreaksOf bp forM_ internal_break_ids $ \ibi -> do GHC.setupBreakpoint (hscInterp hsc_env) ibi breakpoint_count -#else - GHC.setupBreakpoint (hscInterp hsc_env) bp breakpoint_count -#endif -- Register breakpoint in Debugger state brksRef <- asks activeBreakpoints @@ -240,21 +232,13 @@ -- no races since the debugger execution is run in a single thread liftIO $ writeIORef brksRef newBrks -#if MIN_VERSION_ghc(9,14,2) return (changed, internal_break_ids) -#else - return changed -#endif -- | Get a list with all currently active breakpoints on the given module (by path) -- -- If the path argument is @Nothing@, get all active function breakpoints instead -#if MIN_VERSION_ghc(9,14,2) getActiveBreakpoints :: Maybe FilePath -> Debugger [GHC.InternalBreakpointId] -#else -getActiveBreakpoints :: Maybe FilePath -> Debugger [GHC.BreakpointId] -#endif getActiveBreakpoints mfile = do m <- asks activeBreakpoints >>= liftIO . readIORef case mfile of @@ -262,11 +246,7 @@ mms <- getModuleByPath file case mms of Right ms -> -#if MIN_VERSION_ghc(9,14,2) concat <$> mapM getInternalBreaksOf -#else - return -#endif [ GHC.BreakpointId mod bix | (mod, im) <- moduleEnvToList m , mod == ms_mod ms @@ -277,11 +257,7 @@ displayWarnings [e] return [] Nothing -> do -#if MIN_VERSION_ghc(9,14,2) concat <$> mapM getInternalBreaksOf -#else - return -#endif [ GHC.BreakpointId mod bix | (mod, im) <- moduleEnvToList m , (bix, (status, kind)) <- IM.assocs im @@ -452,7 +428,6 @@ -------------------------------------------------------------------------------- -#if MIN_VERSION_ghc(9,14,2) -- | Find all the internal breakpoints that use the given source-level breakpoint id getInternalBreaksOf :: BreakpointId -> Debugger [InternalBreakpointId] getInternalBreaksOf bi = do @@ -460,4 +435,3 @@ return $ fromMaybe [] {- still not found after refresh -} $ lookupBreakpointOccurrences bs bi -#endif diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase, NamedFieldPuns #-} +{-# LANGUAGE OrPatterns, GADTs, LambdaCase, NamedFieldPuns #-} module GHC.Debugger.Runtime where import Data.IORef @@ -9,6 +9,7 @@ import GHC.Types.FieldLabel import GHC.Tc.Utils.TcType import GHC.Runtime.Eval +import GHC.Runtime.Heap.Inspect import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Runtime.Term.Cache @@ -21,8 +22,9 @@ -- scratch and stored in the cache. obtainTerm :: TermKey -> Debugger Term obtainTerm key = do - tc_ref <- asks termCache - tc <- liftIO $ readIORef tc_ref + hsc_env <- getSession + tc_ref <- asks termCache + tc <- liftIO $ readIORef tc_ref case lookupTermCache key tc of -- cache miss: reconstruct, then store. Nothing -> @@ -37,17 +39,8 @@ getTerm = \case FromId i -> GHC.obtainTermFromId (depth i) False{-don't force-} i FromPath k pf -> do - term <- getTerm k >>= \case - -- When the key points to a Suspension, the real thing should - -- already be forced. It's just that the shallow depth meant we - -- returned a Suspension nonetheless while recursing in `getTerm`. - t@Suspension{} -> do - t' <- seqTerm t - -- update term cache with intermediate values? - -- insertTermCache k t' - return t' - t -> return t - return $ case term of + term <- getTerm k + liftIO $ expandTerm hsc_env $ case term of Term{dc=Right dc, subTerms} -> case pf of PositionalIndex ix -> subTerms !! (ix-1) LabeledField fl -> @@ -59,11 +52,24 @@ _ -> error "Unexpected term for the given TermKey" in do term <- getTerm key - liftIO $ writeIORef tc_ref (insertTermCache key term tc) + liftIO $ modifyIORef tc_ref (insertTermCache key term) return term -- cache hit Just hit -> return hit + +-- | Before returning a 'Term' we want to expand its heap representation up to the 'defaultDepth' +-- +-- For 'Id's, this is done by 'GHC.obtainTermFromId'. For other 'TermKey's this +-- function should be used +expandTerm :: HscEnv -> Term -> IO Term +expandTerm hsc_env term = case term of + Term{val, ty} -> cvObtainTerm hsc_env defaultDepth False ty val + (NewtypeWrap{}; RefWrap{}) -> do + -- TODO: we don't do anything clever here yet + return term + -- For other terms there's no point in trying to expand + (Suspension{}; Prim{}) -> return term -- | A boring type is one for which we don't care about the structure and would -- rather see "whole" when being inspected. Strings and literals are a good diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -29,7 +29,6 @@ import qualified Crypto.Hash.SHA1 as H import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as B -import Data.Function import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map import qualified Data.List as L @@ -87,7 +86,9 @@ -- If we don't end up with a target for the current file in the end, then -- we will report it as an error for that file let abs_fp = rootDir cfp - let special_target = mkSimpleTarget df abs_fp + -- Canonicalize! Why? Because the targets we get from the cradle are normalised and if we don't normalise the "special target" then they aren't deduplicated properly. + canon_fp <- liftIO $ Directory.canonicalizePath abs_fp + let special_target = mkSimpleTarget df canon_fp pure $ (df, special_target : targets) NonEmpty.:| [] where initMulti unitArgFiles = @@ -96,10 +97,11 @@ initOne args initOne this_opts = do (dflags', targets') <- addCmdOpts this_opts dflags - let targets = HIE.makeTargetsAbsolute root targets' - root = case workingDirectory dflags' of + let root = case workingDirectory dflags' of Nothing -> compRoot Just wdir -> compRoot wdir + root_canon <- liftIO $ Directory.canonicalizePath root + let targets = HIE.makeTargetsAbsolute root_canon targets' cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts let dflags'' = setWorkingDirectory root $ diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs --- a/haskell-debugger/GHC/Debugger/Stopped.hs +++ b/haskell-debugger/GHC/Debugger/Stopped.hs @@ -196,12 +196,8 @@ case GHC.resumeBreakpointId r of Nothing -> return [] Just ibi -> do -#if MIN_VERSION_ghc(9,14,2) curr_modl <- liftIO $ bi_tick_mod . getBreakSourceId ibi <$> readIModBreaks (hsc_HUG hsc_env) ibi -#else - let curr_modl = ibi_tick_mod ibi -#endif things <- typeEnvElts <$> getTopEnv curr_modl mapM (\tt -> do nameStr <- display (getName tt) @@ -212,12 +208,8 @@ case GHC.resumeBreakpointId r of Nothing -> return [] Just ibi -> do -#if MIN_VERSION_ghc(9,14,2) curr_modl <- liftIO $ bi_tick_mod . getBreakSourceId ibi <$> readIModBreaks (hsc_HUG hsc_env) ibi -#else - let curr_modl = ibi_tick_mod ibi -#endif names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl mapM (\n-> do nameStr <- display n diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -43,6 +43,9 @@ termToVarInfo key term -- | Construct the VarInfos of the fields ('VarFields') of the given 'TermKey'/'Term' +-- +-- This is used to come up with terms for the fields of an already `seq`ed +-- variable which was expanded. termVarFields :: TermKey -> Term -> Debugger VarFields termVarFields top_key top_term = diff --git a/hdb/Development/Debug/Adapter.hs b/hdb/Development/Debug/Adapter.hs --- a/hdb/Development/Debug/Adapter.hs +++ b/hdb/Development/Debug/Adapter.hs @@ -1,7 +1,9 @@ module Development.Debug.Adapter where import Control.Concurrent.MVar +import Control.Concurrent.Chan import qualified Data.IntSet as IS +import qualified Data.ByteString as BS import qualified Data.Map as Map import qualified Data.Text as T import System.FilePath @@ -24,15 +26,17 @@ { syncRequests :: MVar D.Command , syncResponses :: MVar D.Response , nextFreshBreakpointId :: !BreakpointId -#if MIN_VERSION_ghc(9,14,2) , breakpointMap :: Map.Map GHC.InternalBreakpointId BreakpointSet -#else - , breakpointMap :: Map.Map GHC.BreakpointId BreakpointSet -#endif , entryFile :: FilePath , entryPoint :: String , entryArgs :: [String] , projectRoot :: FilePath + , syncProxyIn :: Chan BS.ByteString + -- ^ Read input to the debuggee from the proxy + , syncProxyOut :: Chan BS.ByteString + -- ^ Write output from the debuggee to the proxy + , syncProxyErr :: Chan BS.ByteString + -- ^ Write stderr from the debuggee to the proxy } type BreakpointId = Int diff --git a/hdb/Development/Debug/Adapter/Breakpoints.hs b/hdb/Development/Debug/Adapter/Breakpoints.hs --- a/hdb/Development/Debug/Adapter/Breakpoints.hs +++ b/hdb/Development/Debug/Adapter/Breakpoints.hs @@ -116,7 +116,6 @@ BreakFoundNoLoc _ch -> pure [ DAP.defaultBreakpoint { DAP.breakpointVerified = True } ] BreakFound _ch iid ss -> do source <- fileToSource ss.file -#if MIN_VERSION_ghc(9,14,2) bids <- mapM registerNewBreakpoint iid pure $ map (\bid -> DAP.defaultBreakpoint { DAP.breakpointVerified = True @@ -127,25 +126,9 @@ , DAP.breakpointEndColumn = Just ss.endCol , DAP.breakpointId = Just bid }) bids -#else - bid <- registerNewBreakpoint iid - pure [ DAP.defaultBreakpoint - { DAP.breakpointVerified = True - , DAP.breakpointSource = Just source - , DAP.breakpointLine = Just ss.startLine - , DAP.breakpointEndLine = Just ss.endLine - , DAP.breakpointColumn = Just ss.startCol - , DAP.breakpointEndColumn = Just ss.endCol - , DAP.breakpointId = Just bid - } ] -#endif -- | Adds new BreakpointId for a givent StgPoint -#if MIN_VERSION_ghc(9,14,2) registerNewBreakpoint :: GHC.InternalBreakpointId -> DebugAdaptor BreakpointId -#else -registerNewBreakpoint :: GHC.BreakpointId -> DebugAdaptor BreakpointId -#endif registerNewBreakpoint breakpoint = do bkpId <- getFreshBreakpointId updateDebugSession $ \das@DAS{..} -> das {breakpointMap = Map.insertWith mappend breakpoint (IS.singleton bkpId) breakpointMap} diff --git a/hdb/Development/Debug/Adapter/Flags.hs b/hdb/Development/Debug/Adapter/Flags.hs deleted file mode 100644 --- a/hdb/Development/Debug/Adapter/Flags.hs +++ /dev/null @@ -1,281 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module Development.Debug.Adapter.Flags where - -import Control.Applicative ((<|>)) -import Control.Exception (handleJust) -import Control.Monad -import Control.Monad.Except -import Control.Monad.IO.Class -import Control.Monad.Trans.Maybe -import Data.Bifunctor -import Data.Function -import Data.Functor ((<&>)) -import Data.Maybe -import Data.Version -import Data.Void -import System.Directory hiding (findFile) -import System.FilePath -import System.IO.Error -import Text.ParserCombinators.ReadP (readP_to_S) -import Prettyprinter - -import qualified HIE.Bios as HIE -import qualified HIE.Bios.Config as Config -import qualified HIE.Bios.Cradle as HIE -import qualified HIE.Bios.Environment as HIE -import qualified HIE.Bios.Types as HIE -import qualified Hie.Cabal.Parser as Implicit -import qualified Hie.Locate as Implicit -import qualified Hie.Yaml as Implicit - -import GHC.Debugger.Logger - -data FlagsLog - = HieBiosLog HIE.Log - | LogCradle (HIE.Cradle Void) - -instance Pretty FlagsLog where - pretty = \ case - HieBiosLog msg -> pretty msg - LogCradle crdl -> "Determined Cradle:" <+> viaShow crdl - --- | Flags inferred by @hie-bios@ to invoke GHC -data HieBiosFlags = HieBiosFlags - { ghcInvocation :: [String] - , libdir :: FilePath - , units :: [String] - , rootDir :: FilePath - -- ^ Root dir as reported by the 'Cradle' - , componentDir :: FilePath - -- ^ Root dir of the loaded 'ComponentOptions'. - -- Important for multi-package cabal projects, as packages are not in the - -- root of the cradle, but in some sub-directory. - } - -hieBiosCradle :: Recorder (WithSeverity FlagsLog) {-^ Logger -} - -> FilePath {-^ Project root -} - -> FilePath {-^ Entry file relative to root -} - -> IO (Either String (HIE.Cradle Void)) -hieBiosCradle logger root relTarget = runExceptT $ do - let target = root relTarget - explicitCradle <- HIE.findCradle target & liftIO - cradle <- maybe (loadImplicitCradle hieBiosLogger target) - (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO - logWith logger Info $ LogCradle cradle - pure cradle - where - hieBiosLogger = toCologAction $ cmapWithSev HieBiosLog logger - -hieBiosRuntimeGhcVersion :: Recorder (WithSeverity FlagsLog) - -> HIE.Cradle Void - -> IO (Either String Version) -hieBiosRuntimeGhcVersion _logger cradle = runExceptT $ do - out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version" - case versionMaybe out of - Nothing -> throwError $ "Failed to parse GHC version: " <> out - Just ver -> pure ver - --- | Make 'HieBiosFlags' from the given target file -hieBiosFlags :: Recorder (WithSeverity FlagsLog) {-^ Logger -} - -> HIE.Cradle Void {-^ Project cradle the entry file belongs to -} - -> FilePath {-^ Project root -} - -> FilePath {-^ Entry file relative to root -} - -> IO (Either String HieBiosFlags) -hieBiosFlags _logger cradle root relTarget = runExceptT $ do - let target = root relTarget - libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir" - - -- To determine the flags we MUST set the current directory to the root - -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does) - -- (HIE.getCompilerOptions depends on CWD being the proper root dir) - let compilerOpts = liftIO $ withCurrentDirectory root $ -#if MIN_VERSION_hie_bios(0,14,0) - HIE.getCompilerOptions target (HIE.LoadWithContext [target]) cradle -#else - HIE.getCompilerOptions target [] cradle -#endif - componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle" -#if __GLASGOW_HASKELL__ >= 913 - -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading - -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch. - -- ["-fwrite-if-simplified-core"] ++ -#endif - - let (units', flags') = extractUnits (HIE.componentOptions componentOpts) - return HieBiosFlags - { ghcInvocation = flags' ++ ghcDebuggerFlags - , libdir = libdir - , units = units' - , rootDir = HIE.cradleRootDir cradle - , componentDir = HIE.componentRoot componentOpts - } - -unwrapCradleResult :: MonadError String m => [Char] -> HIE.CradleLoadResult a -> m a -unwrapCradleResult m = \case - HIE.CradleNone -> throwError $ "HIE.CradleNone\n" ++ m - HIE.CradleFail err -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m - HIE.CradleSuccess x -> return x - -extractUnits :: [String] -> ([String], [String]) -extractUnits = go [] [] - where - -- TODO: we should likely use the 'processCmdLineP' instead - go units rest ("-unit" : x : xs) = go (x : units) rest xs - go units rest (x : xs) = go units (x : rest) xs - go units rest [] = (reverse units, reverse rest) - --- | Flags specific to haskell-debugger to append to all GHC invocations. -ghcDebuggerFlags :: [String] -ghcDebuggerFlags = - [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt - ] - - --- ---------------------------------------------------------------------------- --- Utilities --- ---------------------------------------------------------------------------- - -versionMaybe :: String -> Maybe Version -versionMaybe xs = case reverse $ readP_to_S parseVersion xs of - [] -> Nothing - (x:_) -> Just (fst x) - --- ---------------------------------------------------------------------------- --- Implicit cradle discovery logic mirroring the one used by HLS. --- The code itself is copy-pasted from HLS. --- Obviously, we want to reuse the logic without having to depend on HLS. --- We should factor out a common sub-component from HLS and use it here as well. --- ---------------------------------------------------------------------------- - -loadImplicitCradle :: Show a => LogAction IO (WithSeverity HIE.Log) -> FilePath -> IO (HIE.Cradle a) -loadImplicitCradle l wfile = do - is_dir <- doesDirectoryExist wfile - let wdir | is_dir = wfile - | otherwise = takeDirectory wfile - cfg <- runMaybeT (implicitConfig wdir) - case cfg of - Just bc -> HIE.getCradle l absurd bc - Nothing -> return $ HIE.defaultCradle l wdir - --- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies -implicitConfig :: FilePath -> MaybeT IO (Config.CradleConfig a, FilePath) -implicitConfig = (fmap . first) (Config.CradleConfig noDeps) . inferCradleTree - where - noDeps :: [FilePath] - noDeps = [] - - -inferCradleTree :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath) -inferCradleTree start_dir = - maybeItsBios - -- If we have both a config file (cabal.project/stack.yaml) and a work dir - -- (dist-newstyle/.stack-work), prefer that - <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir)) - <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir) - -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal - <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle) - -- If we have a stack.yaml, use stack - <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle) - -- If we have a cabal file, use cabal - <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle) - - where - maybeItsBios = (\wdir -> (Config.Bios (Config.Program $ wdir ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir - - cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir) - --- | Generate a stack cradle given a filepath. --- --- Since we assume there was proof that this file belongs to a stack cradle --- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files. --- We do not look for package.yaml, as we assume the corresponding .cabal has --- been generated already. --- --- We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then --- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to --- component names. -stackCradle :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath) -stackCradle fp = do - pkgs <- Implicit.stackYamlPkgs fp - pkgsWithComps <- liftIO $ catMaybes <$> mapM (Implicit.nestedPkg fp) pkgs - let yaml = fp "stack.yaml" - pure $ (,fp) $ case pkgsWithComps of - [] -> Config.Stack (Config.StackType Nothing (Just yaml)) - ps -> Config.StackMulti mempty $ do - Implicit.Package n cs <- ps - c <- cs - let (prefix, comp) = Implicit.stackComponent n c - pure (prefix, Config.StackType (Just comp) (Just yaml)) - --- | By default, we generate a simple cabal cradle which is equivalent to the --- following hie.yaml: --- --- @ --- cradle: --- cabal: --- @ --- --- Note, this only works reliable for reasonably modern cabal versions >= 3.2. -simpleCabalCradle :: FilePath -> (Config.CradleTree a, FilePath) -simpleCabalCradle fp = (Config.Cabal $ Config.CabalType Nothing Nothing, fp) - -cabalExecutable :: MaybeT IO FilePath -cabalExecutable = MaybeT $ findExecutable "cabal" - -stackExecutable :: MaybeT IO FilePath -stackExecutable = MaybeT $ findExecutable "stack" - -biosWorkDir :: FilePath -> MaybeT IO FilePath -biosWorkDir = findFileUpwards (".hie-bios" ==) - -cabalWorkDir :: FilePath -> MaybeT IO () -cabalWorkDir wdir = do - check <- liftIO $ doesDirectoryExist (wdir "dist-newstyle") - unless check $ fail "No dist-newstyle" - -stackWorkDir :: FilePath -> MaybeT IO () -stackWorkDir wdir = do - check <- liftIO $ doesDirectoryExist (wdir ".stack-work") - unless check $ fail "No .stack-work" - -cabalConfigDir :: FilePath -> MaybeT IO FilePath -cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local") - -cabalFileDir :: FilePath -> MaybeT IO FilePath -cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal") - -stackConfigDir :: FilePath -> MaybeT IO FilePath -stackConfigDir = findFileUpwards isStack - where - isStack name = name == "stack.yaml" - --- | Searches upwards for the first directory containing a file to match --- the predicate. -findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath -findFileUpwards p dir = do - cnts <- - liftIO - $ handleJust - -- Catch permission errors - (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing) - pure - (findFile p dir) - - case cnts of - [] | dir' == dir -> fail "No cabal files" - | otherwise -> findFileUpwards p dir' - _ : _ -> return dir - where dir' = takeDirectory dir - --- | Sees if any file in the directory matches the predicate -findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath] -findFile p dir = do - b <- doesDirectoryExist dir - if b then getFiles >>= filterM doesPredFileExist else return [] - where - getFiles = filter p <$> getDirectoryContents dir - doesPredFileExist file = doesFileExist $ dir file diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -9,16 +9,18 @@ -- | TODO: This module should be called Launch. module Development.Debug.Adapter.Init where +import GHC.IO.Handle +import System.Process +import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T import qualified System.Process as P import Control.Monad.Except import Control.Monad.Trans import Data.Function import Data.Functor import Data.Maybe -import Data.Version (Version(..), showVersion, makeVersion) -import Control.Monad.IO.Class import System.IO import GHC.IO.Encoding import Control.Monad.Catch @@ -32,7 +34,6 @@ import Development.Debug.Adapter import Development.Debug.Adapter.Exit -import Development.Debug.Adapter.Flags import GHC.Debugger.Logger import qualified Development.Debug.Adapter.Output as Output @@ -43,6 +44,7 @@ import DAP import Development.Debug.Adapter.Handles +import Development.Debug.Session.Setup -------------------------------------------------------------------------------- -- * Logging @@ -84,14 +86,15 @@ -- * Launch Debugger -------------------------------------------------------------------------------- --- | Exception type for when initialization fails +-- | Exception type for when hie-bios initialization fails newtype InitFailed = InitFailed String deriving Show -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise -initDebugger :: Recorder (WithSeverity InitLog) -> LaunchArgs -> ExceptT InitFailed DebugAdaptor () -initDebugger l LaunchArgs{ __sessionId +initDebugger :: Recorder (WithSeverity InitLog) -> Bool -> LaunchArgs -> ExceptT InitFailed DebugAdaptor () +initDebugger l supportsRunInTerminal + LaunchArgs{ __sessionId , projectRoot = givenRoot , entryFile = entryFileMaybe , entryPoint = fromMaybe "main" -> entryPoint @@ -100,6 +103,9 @@ } = do syncRequests <- liftIO newEmptyMVar syncResponses <- liftIO newEmptyMVar + syncProxyIn <- liftIO newChan + syncProxyOut <- liftIO newChan + syncProxyErr <- liftIO newChan entryFile <- case entryFileMaybe of Nothing -> throwError $ InitFailed "Missing \"entryFile\" key in debugger configuration" @@ -108,31 +114,10 @@ projectRoot <- maybe (liftIO getCurrentDirectory) pure givenRoot let hieBiosLogger = cmapWithSev FlagsLog l - cradle <- liftIO (hieBiosCradle hieBiosLogger projectRoot entryFile) >>= - \ case - Left e -> throwError $ InitFailed e - Right c -> pure c - - lift $ Output.console $ T.pack "Checking GHC version against debugger version..." - -- GHC is found in PATH (by hie-bios as well). - actualVersion <- liftIO (hieBiosRuntimeGhcVersion hieBiosLogger cradle) >>= - \ case - Left e -> throwError $ InitFailed e - Right c -> pure c - -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1): - when (compileTimeGhcWithoutPatchVersion /= forgetPatchVersion actualVersion) $ do - throwError $ InitFailed $ - "Aborting...! The GHC version must be the same which " ++ - "ghc-debug-adapter was compiled against (" ++ - showVersion compileTimeGhcWithoutPatchVersion++ - "). Instead, got " ++ (showVersion actualVersion) ++ "." - - lift $ Output.console $ T.pack "Discovering session flags with hie-bios..." - mflags <- liftIO (hieBiosFlags hieBiosLogger cradle projectRoot entryFile) - case mflags of - Left e -> throwError $ InitFailed e - Right flags -> do - + liftIO (runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile)) >>= \case + Left e -> throwError $ InitFailed e + Right (Left e) -> lift $ exitWithMsg e + Right (Right flags) -> do let nextFreshBreakpointId = 0 breakpointMap = mempty defaultRunConf = Debugger.RunDebuggerSettings @@ -157,10 +142,12 @@ let absEntryFile = normalise $ projectRoot entryFile lift $ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..} - [ debuggerThread l finished_init writeDebuggerOutput projectRoot flags extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses + [ debuggerThread l finished_init writeDebuggerOutput projectRoot flags + extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses , handleDebuggerOutput readDebuggerOutput - , stdoutCaptureThread - , stderrCaptureThread + , stdinForwardThread supportsRunInTerminal syncProxyIn + , stdoutCaptureThread supportsRunInTerminal syncProxyOut + , stderrCaptureThread supportsRunInTerminal syncProxyErr ] -- Do not return until the initialization is finished @@ -171,27 +158,52 @@ -- This can happen if compilation fails and the compiler exits cleanly. -- -- Instead of signalInitialized, respond with error and exit. - throwError $ InitFailed e + lift $ exitCleanupWithMsg readDebuggerOutput e --- | This thread captures stdout from the debugger and sends it to the client. +-- | This thread captures stdout from the debuggee and sends it to the client. -- NOTE, redirecting the stdout handle is a process-global operation. So this thread --- will capture ANY stdout the debugger emits. Therefore you should never directly +-- will capture ANY stdout the debuggee emits. Therefore you should never directly -- write to stdout, but always write to the appropiate handle. -stdoutCaptureThread :: (DebugAdaptorCont () -> IO ()) -> IO () -stdoutCaptureThread withAdaptor = do +stdoutCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stdoutCaptureThread runInTerminal syncOut withAdaptor = do withInterceptedStdout $ \_ interceptedStdout -> do forever $ do line <- liftIO $ T.hGetLine interceptedStdout + when runInTerminal $ + writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") + + -- Always output to Debug Console withAdaptor $ Output.stdout line -- | Like 'stdoutCaptureThread' but for stderr -stderrCaptureThread :: (DebugAdaptorCont () -> IO ()) -> IO () -stderrCaptureThread withAdaptor = do +stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stderrCaptureThread runInTerminal syncErr withAdaptor = do withInterceptedStderr $ \_ interceptedStderr -> do forever $ do line <- liftIO $ T.hGetLine interceptedStderr + when runInTerminal $ + writeChan syncErr $ T.encodeUtf8 (line <> "\n") + + -- Always output to Debug Console withAdaptor $ Output.stderr line +stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stdinForwardThread runInTerminal syncIn _withAdaptor = do + when runInTerminal $ do + -- We need to hijack stdin to write to it + + -- 1. Create a new pipe from writeEnd->readEnd + (readEnd, writeEnd) <- createPipe + + -- 2. Substitute the read-end of the pipe by stdin + _ <- hDuplicateTo readEnd stdin + hClose readEnd -- we'll never need to read from readEnd + + forever $ do + i <- readChan syncIn + -- 3. Write to write-end of the pipe + BS.hPut writeEnd i >> hFlush writeEnd + -- | The main debugger thread launches a GHC.Debugger session. -- -- Then, forever: @@ -278,15 +290,3 @@ -- Cleanly exit when readDebuggerOutput is closed or thread is killed. return () -compileTimeGhcWithoutPatchVersion :: Version -compileTimeGhcWithoutPatchVersion = - let - versionNumber = __GLASGOW_HASKELL__ :: Int - (major, minor) = divMod versionNumber 100 - in - makeVersion [major, minor] - -forgetPatchVersion :: Version -> Version -forgetPatchVersion v = case versionBranch v of - (major:minor:_patches) -> makeVersion [major, minor] - _ -> v diff --git a/hdb/Development/Debug/Adapter/Proxy.hs b/hdb/Development/Debug/Adapter/Proxy.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/Proxy.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings, DerivingStrategies #-} +-- | Run the proxy mode, which forwards stdin/stdout to/from the DAP server and +-- is displayed in a terminal in the DAP client using 'runInTerminal' +module Development.Debug.Adapter.Proxy + ( serverSideHdbProxy + , runInTerminalHdbProxy + , ProxyLog(..) + ) where + +import DAP + +import System.IO +import System.Exit (exitSuccess) +import System.Environment +import System.FilePath +import Control.Exception.Base +import Control.Monad +import Control.Monad.IO.Class +import Control.Concurrent +import qualified Data.List.NonEmpty as NE + +import qualified Data.Text as T +import Network.Socket hiding (Debug) +import Network.Run.TCP +import qualified Network.Socket.ByteString as NBS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.HashMap.Strict as H + +import GHC.Debugger.Logger +import Development.Debug.Adapter + +newtype ProxyLog = ProxyLog T.Text + deriving newtype Pretty + +-- | Connect to a running @hdb proxy@ process on the given port +-- connectToHdbProxy :: Recorder (WithVerbosity x) -> Int -> DebugAdaptor () +-- connectToHdbProxy = _ + +-- | Fork a new thread to run the server-side of the proxy. +-- +-- 1. To setup: +-- Ask the DAP client to launch a process running @hdb proxy --port @ +-- by sending a 'runInTerminal' DAP reverse request. This is done outside of +-- this function by signaling the given MVar (this is the case because we cannot use `network` with `DebugAdaptor` +-- +-- 2. In a loop, +-- 2.1 Read stdin from the socket and push it to a Chan +-- 2.1 Read from a stdout Chan and write to the socket +serverSideHdbProxy :: Recorder (WithSeverity ProxyLog) + -> MVar () + -> DebugAdaptor () +serverSideHdbProxy l client_conn_signal = do + DAS { syncProxyIn = dbIn + , syncProxyOut = dbOut + , syncProxyErr = dbErr } <- getDebugSession + + sock <- liftIO $ do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } + addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") + -- Bind on "0" to let the OS pick a free port + openTCPServerSocket addr + + port <- liftIO $ socketPort sock + + _ <- liftIO $ forkIO $ ignoreIOException $ do + runTCPServerWithSocket sock $ \scket -> do + + logWith l Info $ ProxyLog $ T.pack $ "Connected to client on port " ++ show port ++ "...!" + putMVar client_conn_signal () -- signal ready (see #95) + + -- -- Read stdout from chan and write to socket + _ <- forkIO $ ignoreIOException $ do + forever $ do + bs <- readChan dbOut + logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket: " ++ BS8.unpack bs + NBS.sendAll scket bs + + -- Read stderr from chan and write to socket + _ <- forkIO $ ignoreIOException $ do + forever $ do + bs <- readChan dbErr + logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs + NBS.sendAll scket bs + + -- Read stdin from socket and write to chan + let loop = do + bs <- NBS.recv scket 4096 + if BS8.null bs + then do + logWith l Debug $ ProxyLog $ T.pack "Connection to client was closed." + close scket + else do + logWith l Debug $ ProxyLog $ T.pack $ "Read from socket: " ++ BS8.unpack bs + writeChan dbIn bs >> loop + in ignoreIOException loop + + sendRunProxyInTerminal port + + where + ignoreIOException a = catch a $ \(e::IOException) -> + logWith l Info $ ProxyLog $ T.pack $ "Ignoring connection broken to proxy client: " ++ show e + +-- | The proxy code running on the terminal in which the @hdb proxy@ process is launched. +-- +-- This client-side proxy is responsible for +-- 1. Connecting to the given proxy-server port +-- 2. Forwarding stdin to the port it is connected to +-- 3. Read from the network the output and write it to stdout +runInTerminalHdbProxy :: Recorder (WithSeverity ProxyLog) -> Int -> IO () +runInTerminalHdbProxy l port = do + logWith l Info $ ProxyLog $ T.pack $ "Running in terminal on port " ++ show port ++ "...!" + hSetBuffering stdin LineBuffering + + dbg_inv <- lookupEnv "DEBUGGEE_INVOCATION" + case dbg_inv of + Nothing -> pure () + Just inv -> + putStrLn $ "Running the debugger input/output proxy for the following debuggee execution:\n\n\n " ++ inv ++ "\n\n" + + catch ( + runTCPClient "127.0.0.1" (show port) $ \sock -> do + -- Forward stdin to sock + _ <- forkIO $ + catch (forever $ do + str <- BS8.hGetLine stdin + NBS.sendAll sock (str <> BS8.pack "\n") + ) $ \(e::IOException) -> return () -- connection dropped, just exit. + + -- Forward stdout from sock + catch (forever $ do + msg <- NBS.recv sock 4096 + if BS8.null msg + then do + logWith l Info $ ProxyLog $ T.pack "Exiting..." + close sock + exitSuccess + else BS8.hPut stdout msg >> hFlush stdout + ) $ \(e::IOException) -> return () -- connection dropped, just exit. + + ) $ \(e::IOException) -> do + hPutStrLn stderr "Failed to connect to debugger server proxy -- did the debuggee compile and start running successfully?" + +-- | Send a 'runInTerminal' reverse request to the DAP client +-- with the @hdb proxy@ invocation +sendRunProxyInTerminal :: PortNumber -> DebugAdaptor () +sendRunProxyInTerminal port = do + DAS { entryFile + , entryPoint + , entryArgs + , projectRoot } <- getDebugSession + let debuggee_inv = T.pack $ makeRelative projectRoot entryFile ++ ":" ++ entryPoint ++ + (if null entryArgs then "" else " ") ++ unwords entryArgs + sendRunInTerminalReverseRequest + RunInTerminalRequestArguments + { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated + , runInTerminalRequestArgumentsTitle = Just debuggee_inv + , runInTerminalRequestArgumentsCwd = "" + , runInTerminalRequestArgumentsArgs = ["hdb", "proxy", "--port", T.pack (show port)] + , runInTerminalRequestArgumentsEnv = Just (H.singleton "DEBUGGEE_INVOCATION" debuggee_inv) + , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False + } diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -6,14 +6,15 @@ import System.Directory import System.Console.Haskeline import System.Console.Haskeline.Completion +import System.FilePath +import Control.Monad.Except import Control.Monad.State import Control.Monad.Reader import Control.Monad.RWS import Options.Applicative import Options.Applicative.BashCompletion -import Development.Debug.Adapter.Flags -- use different namespace for common things -import Development.Debug.Adapter.Handles +import Development.Debug.Session.Setup import GHC.Debugger.Logger import GHC.Debugger.Interface.Messages @@ -34,38 +35,39 @@ FlagsLog msg -> pretty msg -- | Run it -runIDM :: String -- ^ entryPoint +runIDM :: Recorder (WithSeverity InteractiveLog) + -> String -- ^ entryPoint -> FilePath -- ^ entryFile -> [String] -- ^ entryArgs -> [String] -- ^ extraGhcArgs -> InteractiveDM a -> IO a -runIDM entryPoint entryFile entryArgs extraGhcArgs act = do +runIDM logger entryPoint entryFile entryArgs extraGhcArgs act = do projectRoot <- getCurrentDirectory - l <- handleLogger stdout - let - loggerWithSev = cmap renderPrettyWithSeverity (fromCologAction l) - let hieBiosLogger = cmapWithSev FlagsLog loggerWithSev - cradle <- hieBiosCradle hieBiosLogger projectRoot entryFile >>= - \case - Left e -> exitWithMsg e - Right c -> pure c - mflags <- hieBiosFlags hieBiosLogger cradle projectRoot entryFile - case mflags of - Left e -> exitWithMsg e - Right HieBiosFlags{..} -> do + + let hieBiosLogger = cmapWithSev FlagsLog logger + runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile) >>= \case + Left e -> exitWithMsg e + Right (Left e) -> exitWithMsg e + Right (Right flags) + | HieBiosFlags{..} <- flags + -> do + let defaultRunConf = RunDebuggerSettings - { supportsANSIStyling = True + { supportsANSIStyling = True -- todo: check!! , supportsANSIHyperlinks = False } + let finalGhcInvocation = ghcInvocation ++ extraGhcArgs - runDebugger stdout rootDir componentDir libdir units finalGhcInvocation entryFile defaultRunConf $ + let absEntryFile = normalise $ projectRoot entryFile + + runDebugger stdout rootDir componentDir libdir units finalGhcInvocation absEntryFile defaultRunConf $ fmap fst $ evalRWST (runInputT (setComplete noCompletion defaultSettings) act) (entryFile, entryPoint, entryArgs) Nothing where - exitWithMsg str = do - putStrLn str + exitWithMsg txt = do + putStrLn txt exitWith (ExitFailure 33) -- completeF = completeWordWithPrev Nothing filenameWordBreakChars $ @@ -223,6 +225,10 @@ ( info (DoEval . unwords <$> many (argument str ( metavar "EXPRESSION" <> help "Expression to evaluate in the current context" ))) ( progDesc "Evaluate an expression in the current context" ) ) + <> + Options.Applicative.command "exit" + ( info (pure TerminateProcess) + ( progDesc "Terminate and exit the debugger session" ) ) ) -- | Main parser info diff --git a/hdb/Development/Debug/Options.hs b/hdb/Development/Debug/Options.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Options.hs @@ -0,0 +1,42 @@ +-- | Options supported by the debugger +-- +-- For parsing see 'Development.Debug.Options.Parser' +module Development.Debug.Options + ( HdbOptions(..) ) where + +import GHC.Debugger.Logger + +-- | The options `hdb` is invoked in the command line with +data HdbOptions + -- | @server --port @ + = HdbDAPServer + { port :: Int + , verbosity :: Verbosity + } + -- | @cli [--entry-point=] [--extra-ghc-args=""] [] -- []@ + | HdbCLI + { entryPoint :: String + , entryFile :: FilePath + , entryArgs :: [String] + , extraGhcArgs :: [String] + , verbosity :: Verbosity + } + + -- | @proxy --port @ + -- + -- The proxy command serves as a middle man between the user and the debugger. + -- It is used implicitly by DAP mode: upon initialization, the debugger + -- server asks the DAP client to @runInTerminal@ the @hdb proxy --port ...@ + -- command at a port determined by the debugger server. + -- + -- The proxy mode will forward stdin to the debugger server and will be + -- forwarded the debuggee's stdout. This essentially enables the user to + -- observe and interact with the execution of the debugger, in a standalone + -- terminal. + -- + -- See #44 for the original ticket + | HdbProxy + { port :: Int + , verbosity :: Verbosity + } + diff --git a/hdb/Development/Debug/Options/Parser.hs b/hdb/Development/Debug/Options/Parser.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Options/Parser.hs @@ -0,0 +1,117 @@ +-- | Options parser using optparse-applicative for the debugger options in +-- 'Development.Debug.Options' +module Development.Debug.Options.Parser + ( -- * Command line options parsing + parseHdbOptions + ) where + +import Options.Applicative hiding (command) + +import Data.Version +import qualified Options.Applicative +import qualified Paths_haskell_debugger as P + +import GHC.Debugger.Logger +import Development.Debug.Options + +-------------------------------------------------------------------------------- +-- Options parser +-------------------------------------------------------------------------------- + +-- | Parser for 'HdbDAPServer' options +serverParser :: Parser HdbOptions +serverParser = HdbDAPServer + <$> option auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> help "DAP server port" ) + <*> verbosityParser (Verbosity Debug) + +-- | Parser for 'HdbCLI' options +cliParser :: Parser HdbOptions +cliParser = HdbCLI + <$> strOption + ( long "entry-point" + <> short 'e' + <> metavar "ENTRY_POINT" + <> value "main" + <> help "The name of the function that is called to start execution (default: main)" ) + <*> argument str + ( metavar "ENTRY_FILE" + <> help "The relative path from the project root to the file with the entry point for execution" ) + <*> many + ( argument str + ( metavar "ENTRY_ARGS..." + <> help "The arguments passed to the entryPoint. If the entryPoint is main, these arguments are passed as environment arguments (as in getArgs) rather than direct function arguments." + ) + ) + <*> option (words <$> str) + ( long "extra-ghc-args" + <> metavar "GHC_ARGS" + <> value [] + <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" ) + <*> verbosityParser (Verbosity Warning) + +-- | Parser for 'HdbProxy' options +proxyParser :: Parser HdbOptions +proxyParser = HdbProxy + <$> option auto + ( long "port" + <> short 'p' + <> metavar "PORT" + <> help "proxy port to which the debugger connects" ) + <*> verbosityParser (Verbosity Warning) + +-- | Combined parser for HdbOptions +hdbOptionsParser :: Parser HdbOptions +hdbOptionsParser = hsubparser + ( Options.Applicative.command "server" + ( info serverParser + ( progDesc "Start the Haskell debugger in DAP server mode" ) ) + <> Options.Applicative.command "cli" + ( info cliParser + ( progDesc "Debug a Haskell program in CLI mode" ) ) + <> Options.Applicative.command "proxy" + ( info proxyParser + ( progDesc "Internal mode used by the DAP server to proxy the stdin/stdout to the DAP client's terminal" ) ) + ) + <|> cliParser -- Default to CLI mode if no subcommand + +-- | Parser for --version flag +versioner :: Parser (a -> a) +versioner = simpleVersioner $ "Haskell Debugger, version " ++ showVersion P.version + +-- | Parser for --verbosity 0 +-- +-- The default verbosity differs by mode (#86): +-- - DAP server mode: DEBUG +-- - CLI mode: WARNING +verbosityParser :: Verbosity -> Parser Verbosity +verbosityParser vdef = option verb + ( long "verbosity" + <> short 'v' + <> metavar "VERBOSITY" + <> value vdef + <> help "Logger verbosity in [0..3] interval, where 0 is silent and 3 is debug" + ) + where + verb = Verbosity <$> (verbNum =<< auto) + verbNum n = case n :: Int of + 0 -> pure Error + 1 -> pure Warning + 2 -> pure Info + 3 -> pure Debug + _ -> readerAbort (ErrorMsg "Verbosity must be a value in [0..3]") + +-- | Main parser info +hdbParserInfo :: ParserInfo HdbOptions +hdbParserInfo = info (hdbOptionsParser <**> versioner <**> helper) + ( fullDesc + <> header "Haskell debugger supporting both CLI and DAP modes" ) + +-- | Parse command line arguments +parseHdbOptions :: IO HdbOptions +parseHdbOptions = customExecParser + defaultPrefs{prefShowHelpOnError = True, prefShowHelpOnEmpty = True} + hdbParserInfo diff --git a/hdb/Development/Debug/Session/Setup.hs b/hdb/Development/Debug/Session/Setup.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Session/Setup.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Development.Debug.Session.Setup + ( + -- * Setting up a hie-bios session + HieBiosFlags(..) + , hieBiosSetup + + -- * Logging + , FlagsLog(..) + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (handleJust) +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Data.Bifunctor +import Data.Function +import Data.Functor ((<&>)) +import Data.Maybe +import Data.Version +import Data.Void +import System.Directory hiding (findFile) +import System.FilePath +import System.IO.Error +import Text.ParserCombinators.ReadP (readP_to_S) +import Prettyprinter + +import qualified Data.Text as T + +import qualified HIE.Bios as HIE +import qualified HIE.Bios.Config as Config +import qualified HIE.Bios.Cradle as HIE +import qualified HIE.Bios.Environment as HIE +import qualified HIE.Bios.Types as HIE +import qualified Hie.Cabal.Parser as Implicit +import qualified Hie.Locate as Implicit +import qualified Hie.Yaml as Implicit + +import GHC.Debugger.Logger + +data FlagsLog + = HieBiosLog HIE.Log + | LogCradle (HIE.Cradle Void) + | LogSetupMsg T.Text + +instance Pretty FlagsLog where + pretty = \ case + HieBiosLog msg -> pretty msg + LogCradle crdl -> "Determined Cradle:" <+> viaShow crdl + LogSetupMsg txt -> pretty txt + +-- | Flags inferred by @hie-bios@ to invoke GHC +data HieBiosFlags = HieBiosFlags + { ghcInvocation :: [String] + , libdir :: FilePath + , units :: [String] + , rootDir :: FilePath + -- ^ Root dir as reported by the 'Cradle' + , componentDir :: FilePath + -- ^ Root dir of the loaded 'ComponentOptions'. + -- Important for multi-package cabal projects, as packages are not in the + -- root of the cradle, but in some sub-directory. + } + +-- | Prepare a GHC session using hie-bios from scratch +hieBiosSetup :: Recorder (WithSeverity FlagsLog) + -> FilePath -- ^ project root + -> FilePath -- ^ entry file + -> ExceptT String IO (Either String HieBiosFlags) +hieBiosSetup logger projectRoot entryFile = do + + cradle <- hieBiosCradle logger projectRoot entryFile & ExceptT + + -- GHC is found in PATH (by hie-bios as well). + logT "Checking GHC version against debugger version..." + _version <- hieBiosRuntimeGhcVersion logger cradle + + logT "Discovering session flags with hie-bios..." + r <- hieBiosFlags logger cradle projectRoot entryFile & liftIO + + logT "Session setup with hie-bios was successful." + return r + + where + logT = logWith logger Info . LogSetupMsg . T.pack + +-- | Try implicit-hie and the builtin search to come up with a @'HIE.Cradle'@ +hieBiosCradle :: Recorder (WithSeverity FlagsLog) {-^ Logger -} + -> FilePath {-^ Project root -} + -> FilePath {-^ Entry file relative to root -} + -> IO (Either String (HIE.Cradle Void)) +hieBiosCradle logger root relTarget = runExceptT $ do + let target = root relTarget + explicitCradle <- HIE.findCradle target & liftIO + cradle <- maybe (loadImplicitCradle hieBiosLogger target) + (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO + logWith logger Info $ LogCradle cradle + pure cradle + where + hieBiosLogger = toCologAction $ cmapWithSev HieBiosLog logger + +-- | Fetch the runtime GHC version, according to hie-bios, and check it is the +-- same as the compile time GHC version +hieBiosRuntimeGhcVersion :: Recorder (WithSeverity FlagsLog) + -> HIE.Cradle Void + -> ExceptT String IO Version +hieBiosRuntimeGhcVersion _logger cradle = do + out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version" + + case versionMaybe out of + Nothing -> throwError $ "Failed to parse GHC version: " <> out + Just actualVersion -> do + + -- Compare the GLASGOW_HASKELL version (e.g. 913) with the actualVersion (e.g. 9.13.1): + when (compileTimeGhcWithoutPatchVersion /= forgetPatchVersion actualVersion) $ do + throwError $ + "Aborting...! The GHC version must be the same which " ++ + "ghc-debug-adapter was compiled against (" ++ + showVersion compileTimeGhcWithoutPatchVersion++ + "). Instead, got " ++ (showVersion actualVersion) ++ "." + + pure actualVersion + +-- | Make 'HieBiosFlags' from the given target file +hieBiosFlags :: Recorder (WithSeverity FlagsLog) {-^ Logger -} + -> HIE.Cradle Void {-^ Project cradle the entry file belongs to -} + -> FilePath {-^ Project root -} + -> FilePath {-^ Entry file relative to root -} + -> IO (Either String HieBiosFlags) +hieBiosFlags _logger cradle root relTarget = runExceptT $ do + let target = root relTarget + libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir" + + -- To determine the flags we MUST set the current directory to the root + -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does) + -- (HIE.getCompilerOptions depends on CWD being the proper root dir) + let compilerOpts = liftIO $ withCurrentDirectory root $ +#if MIN_VERSION_hie_bios(0,14,0) + HIE.getCompilerOptions target (HIE.LoadWithContext [target]) cradle +#else + HIE.getCompilerOptions target [] cradle +#endif + componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle" +#if __GLASGOW_HASKELL__ >= 913 + -- fwrite-if-simplified-core requires a recent bug fix regarding GHCi loading + -- ROMES:TODO: Re-enable as soon as I'm using Matthew's patch. + -- ["-fwrite-if-simplified-core"] ++ +#endif + + let (units', flags') = extractUnits (HIE.componentOptions componentOpts) + return HieBiosFlags + { ghcInvocation = flags' ++ ghcDebuggerFlags + , libdir = libdir + , units = units' + , rootDir = HIE.cradleRootDir cradle + , componentDir = HIE.componentRoot componentOpts + } + +unwrapCradleResult :: MonadError String m => [Char] -> HIE.CradleLoadResult a -> m a +unwrapCradleResult m = \case + HIE.CradleNone -> throwError $ "HIE.CradleNone\n" ++ m + HIE.CradleFail err -> throwError $ unlines (HIE.cradleErrorStderr err) ++ "\n" ++ m + HIE.CradleSuccess x -> return x + +extractUnits :: [String] -> ([String], [String]) +extractUnits = go [] [] + where + -- TODO: we should likely use the 'processCmdLineP' instead + go units rest ("-unit" : x : xs) = go (x : units) rest xs + go units rest (x : xs) = go units (x : rest) xs + go units rest [] = (reverse units, reverse rest) + +-- | Flags specific to haskell-debugger to append to all GHC invocations. +ghcDebuggerFlags :: [String] +ghcDebuggerFlags = + [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt + ] + + +-- ---------------------------------------------------------------------------- +-- Utilities +-- ---------------------------------------------------------------------------- + +versionMaybe :: String -> Maybe Version +versionMaybe xs = case reverse $ readP_to_S parseVersion xs of + [] -> Nothing + (x:_) -> Just (fst x) + +-- ---------------------------------------------------------------------------- +-- Implicit cradle discovery logic mirroring the one used by HLS. +-- The code itself is copy-pasted from HLS. +-- Obviously, we want to reuse the logic without having to depend on HLS. +-- We should factor out a common sub-component from HLS and use it here as well. +-- ---------------------------------------------------------------------------- + +loadImplicitCradle :: Show a => LogAction IO (WithSeverity HIE.Log) -> FilePath -> IO (HIE.Cradle a) +loadImplicitCradle l wfile = do + is_dir <- doesDirectoryExist wfile + let wdir | is_dir = wfile + | otherwise = takeDirectory wfile + cfg <- runMaybeT (implicitConfig wdir) + case cfg of + Just bc -> HIE.getCradle l absurd bc + Nothing -> return $ HIE.defaultCradle l wdir + +-- | Wraps up the cradle inferred by @inferCradleTree@ as a @CradleConfig@ with no dependencies +implicitConfig :: FilePath -> MaybeT IO (Config.CradleConfig a, FilePath) +implicitConfig = (fmap . first) (Config.CradleConfig noDeps) . inferCradleTree + where + noDeps :: [FilePath] + noDeps = [] + + +inferCradleTree :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath) +inferCradleTree start_dir = + maybeItsBios + -- If we have both a config file (cabal.project/stack.yaml) and a work dir + -- (dist-newstyle/.stack-work), prefer that + <|> (cabalExecutable >> cabalConfigDir start_dir >>= \dir -> cabalWorkDir dir >> pure (simpleCabalCradle dir)) + <|> (stackExecutable >> stackConfigDir start_dir >>= \dir -> stackWorkDir dir >> stackCradle dir) + -- If we have a cabal.project OR we have a .cabal and dist-newstyle, prefer cabal + <|> (cabalExecutable >> (cabalConfigDir start_dir <|> cabalFileAndWorkDir) <&> simpleCabalCradle) + -- If we have a stack.yaml, use stack + <|> (stackExecutable >> stackConfigDir start_dir >>= stackCradle) + -- If we have a cabal file, use cabal + <|> (cabalExecutable >> cabalFileDir start_dir <&> simpleCabalCradle) + + where + maybeItsBios = (\wdir -> (Config.Bios (Config.Program $ wdir ".hie-bios") Nothing Nothing, wdir)) <$> biosWorkDir start_dir + + cabalFileAndWorkDir = cabalFileDir start_dir >>= (\dir -> cabalWorkDir dir >> pure dir) + +-- | Generate a stack cradle given a filepath. +-- +-- Since we assume there was proof that this file belongs to a stack cradle +-- we look immediately for the relevant @*.cabal@ and @stack.yaml@ files. +-- We do not look for package.yaml, as we assume the corresponding .cabal has +-- been generated already. +-- +-- We parse the @stack.yaml@ to find relevant @*.cabal@ file locations, then +-- we parse the @*.cabal@ files to generate a mapping from @hs-source-dirs@ to +-- component names. +stackCradle :: FilePath -> MaybeT IO (Config.CradleTree a, FilePath) +stackCradle fp = do + pkgs <- Implicit.stackYamlPkgs fp + pkgsWithComps <- liftIO $ catMaybes <$> mapM (Implicit.nestedPkg fp) pkgs + let yaml = fp "stack.yaml" + pure $ (,fp) $ case pkgsWithComps of + [] -> Config.Stack (Config.StackType Nothing (Just yaml)) + ps -> Config.StackMulti mempty $ do + Implicit.Package n cs <- ps + c <- cs + let (prefix, comp) = Implicit.stackComponent n c + pure (prefix, Config.StackType (Just comp) (Just yaml)) + +-- | By default, we generate a simple cabal cradle which is equivalent to the +-- following hie.yaml: +-- +-- @ +-- cradle: +-- cabal: +-- @ +-- +-- Note, this only works reliable for reasonably modern cabal versions >= 3.2. +simpleCabalCradle :: FilePath -> (Config.CradleTree a, FilePath) +simpleCabalCradle fp = (Config.Cabal $ Config.CabalType Nothing Nothing, fp) + +cabalExecutable :: MaybeT IO FilePath +cabalExecutable = MaybeT $ findExecutable "cabal" + +stackExecutable :: MaybeT IO FilePath +stackExecutable = MaybeT $ findExecutable "stack" + +biosWorkDir :: FilePath -> MaybeT IO FilePath +biosWorkDir = findFileUpwards (".hie-bios" ==) + +cabalWorkDir :: FilePath -> MaybeT IO () +cabalWorkDir wdir = do + check <- liftIO $ doesDirectoryExist (wdir "dist-newstyle") + unless check $ fail "No dist-newstyle" + +stackWorkDir :: FilePath -> MaybeT IO () +stackWorkDir wdir = do + check <- liftIO $ doesDirectoryExist (wdir ".stack-work") + unless check $ fail "No .stack-work" + +cabalConfigDir :: FilePath -> MaybeT IO FilePath +cabalConfigDir = findFileUpwards (\fp -> fp == "cabal.project" || fp == "cabal.project.local") + +cabalFileDir :: FilePath -> MaybeT IO FilePath +cabalFileDir = findFileUpwards (\fp -> takeExtension fp == ".cabal") + +stackConfigDir :: FilePath -> MaybeT IO FilePath +stackConfigDir = findFileUpwards isStack + where + isStack name = name == "stack.yaml" + +-- | Searches upwards for the first directory containing a file to match +-- the predicate. +findFileUpwards :: (FilePath -> Bool) -> FilePath -> MaybeT IO FilePath +findFileUpwards p dir = do + cnts <- + liftIO + $ handleJust + -- Catch permission errors + (\(e :: IOError) -> if isPermissionError e then Just [] else Nothing) + pure + (findFile p dir) + + case cnts of + [] | dir' == dir -> fail "No cabal files" + | otherwise -> findFileUpwards p dir' + _ : _ -> return dir + where dir' = takeDirectory dir + +-- | Sees if any file in the directory matches the predicate +findFile :: (FilePath -> Bool) -> FilePath -> IO [FilePath] +findFile p dir = do + b <- doesDirectoryExist dir + if b then getFiles >>= filterM doesPredFileExist else return [] + where + getFiles = filter p <$> getDirectoryContents dir + doesPredFileExist file = doesFileExist $ dir file + +-------------------------------------------------------------------------------- + +compileTimeGhcWithoutPatchVersion :: Version +compileTimeGhcWithoutPatchVersion = + let + versionNumber = __GLASGOW_HASKELL__ :: Int + (major, minor) = divMod versionNumber 100 + in + makeVersion [major, minor] + +forgetPatchVersion :: Version -> Version +forgetPatchVersion v = case versionBranch v of + (major:minor:_patches) -> makeVersion [major, minor] + _ -> v diff --git a/hdb/Main.hs b/hdb/Main.hs --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -2,11 +2,15 @@ module Main where import System.Environment +import System.Process import Data.Maybe -import Data.Version +import Data.Aeson +import Data.IORef import Text.Read -import Control.Monad.Except +import Control.Concurrent +import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Except import DAP @@ -18,98 +22,19 @@ import Development.Debug.Adapter.Exit import Development.Debug.Adapter.Handles import GHC.Debugger.Logger -import Development.Debug.Adapter - -import Development.Debug.Interactive +import Prettyprinter import System.IO (hSetBuffering, BufferMode(LineBuffering)) import qualified DAP.Log as DAP import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Handle.FD -import Options.Applicative hiding (command) -import qualified Options.Applicative -import qualified Paths_haskell_debugger as P - --- | The options `hdb` is invoked in the command line with -data HdbOptions - -- | @server --port @ - = HdbDAPServer - { port :: Int - } - -- | @[--entry-point=] [--extra-ghc-args=""] [] -- []@ - | HdbCLI - { entryPoint :: String - , entryFile :: FilePath - , entryArgs :: [String] - , extraGhcArgs :: [String] - } - --------------------------------------------------------------------------------- --- Options parser --------------------------------------------------------------------------------- - --- | Parser for HdbDAPServer options -serverParser :: Parser HdbOptions -serverParser = HdbDAPServer - <$> option auto - ( long "port" - <> short 'p' - <> metavar "PORT" - <> help "DAP server port" ) - --- | Parser for HdbCLI options -cliParser :: Parser HdbOptions -cliParser = HdbCLI - <$> strOption - ( long "entry-point" - <> short 'e' - <> metavar "ENTRY_POINT" - <> value "main" - <> help "The name of the function that is called to start execution (default: main)" ) - <*> argument str - ( metavar "ENTRY_FILE" - <> help "The relative path from the project root to the file with the entry point for execution" ) - <*> many - ( argument str - ( metavar "ENTRY_ARGS..." - <> help "The arguments passed to the entryPoint. If the entryPoint is main, these arguments are passed as environment arguments (as in getArgs) rather than direct function arguments." - ) - ) - <*> option (words <$> str) - ( long "extra-ghc-args" - <> metavar "GHC_ARGS" - <> value [] - <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" ) - --- | Combined parser for HdbOptions -hdbOptionsParser :: Parser HdbOptions -hdbOptionsParser = hsubparser - ( Options.Applicative.command "server" - ( info serverParser - ( progDesc "Start the Haskell debugger in DAP server mode" ) ) - <> Options.Applicative.command "cli" - ( info cliParser - ( progDesc "Debug a Haskell program in CLI mode" ) ) - ) - <|> cliParser -- Default to CLI mode if no subcommand - --- | Parser for --version flag -versioner :: Parser (a -> a) -versioner = simpleVersioner $ "Haskell Debugger, version " ++ showVersion P.version - --- | Main parser info -hdbParserInfo :: ParserInfo HdbOptions -hdbParserInfo = info (hdbOptionsParser <**> versioner <**> helper) - ( fullDesc - <> header "Haskell debugger supporting both CLI and DAP modes" ) - --- | Parse command line arguments -parseHdbOptions :: IO HdbOptions -parseHdbOptions = customExecParser - defaultPrefs{prefShowHelpOnError = True, prefShowHelpOnEmpty = True} - hdbParserInfo +import Development.Debug.Options (HdbOptions(..)) +import Development.Debug.Options.Parser (parseHdbOptions) +import Development.Debug.Adapter +import Development.Debug.Adapter.Proxy +import Development.Debug.Interactive -------------------------------------------------------------------------------- @@ -120,28 +45,33 @@ main :: IO () main = do hdbOpts <- parseHdbOptions + let + timeStampLogger = cmapIO renderWithTimestamp . fromCologAction + loggerWithSev = cmap renderPrettyWithSeverity + loggerFinal opts = applyVerbosity opts.verbosity . loggerWithSev . timeStampLogger case hdbOpts of HdbDAPServer{port} -> do config <- getConfig port withInterceptedStdoutForwarding defaultStdoutForwardingAction $ \realStdout -> do hSetBuffering realStdout LineBuffering l <- handleLogger realStdout - let - timeStampLogger :: Recorder T.Text - timeStampLogger = cmapIO renderWithTimestamp (fromCologAction l) - loggerWithSev :: Recorder (WithSeverity MainLog) - loggerWithSev = cmap renderPrettyWithSeverity timeStampLogger - runDAPServerWithLogger (toCologAction $ cmap DAP.renderDAPLog timeStampLogger) config (talk loggerWithSev) + let dapLogger = cmap DAP.renderDAPLog $ timeStampLogger l + let runLogger = loggerFinal hdbOpts l + init_var <- liftIO (newIORef False{-not supported by default-}) + pid_var <- liftIO (newIORef Nothing) + ccon_var <- liftIO newEmptyMVar + runDAPServerWithLogger (toCologAction dapLogger) config + (talk runLogger init_var pid_var ccon_var) + (ack runLogger pid_var) HdbCLI{..} -> do - l <- handleLogger stdout - let - timeStampLogger :: Recorder T.Text - timeStampLogger = cmapIO renderWithTimestamp (fromCologAction l) - loggerWithSev :: Recorder (WithSeverity MainLog) - loggerWithSev = cmap renderPrettyWithSeverity timeStampLogger - runIDM entryPoint entryFile entryArgs extraGhcArgs $ - debugInteractive (cmapWithSev InteractiveLog loggerWithSev) - + l <- handleLogger stdout + let runLogger = cmapWithSev InteractiveLog $ loggerFinal hdbOpts l + runIDM runLogger entryPoint entryFile entryArgs extraGhcArgs $ + debugInteractive runLogger + HdbProxy{port} -> do + l <- handleLogger stdout + let runLogger = cmapWithSev RunProxyClientLog $ loggerFinal hdbOpts l + runInTerminalHdbProxy runLogger port -- | Fetch config from environment, fallback to sane defaults getConfig :: Int -> IO ServerConfig @@ -194,29 +124,64 @@ data MainLog = InitLog InitLog + | LaunchLog T.Text | InteractiveLog InteractiveLog + | RunProxyServerLog ProxyLog + | RunProxyClientLog ProxyLog instance Pretty MainLog where pretty = \ case InitLog msg -> pretty msg + LaunchLog msg -> pretty msg + InteractiveLog msg -> pretty msg + RunProxyServerLog msg -> pretty ("Proxy Server:" :: String) <+> pretty msg + RunProxyClientLog msg -> pretty ("Proxy Client:" :: String) <+> pretty msg -- | 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 :: Recorder (WithSeverity MainLog) -> Command -> DebugAdaptor () +talk :: Recorder (WithSeverity MainLog) + -> IORef Bool + -- ^ Whether the client supports runInTerminal + -> IORef (Maybe Int) + -- ^ The PID of the runInTerminal proxy process + -> MVar () + -- ^ A var to block on waiting for the proxy client to connect, if a proxy + -- connection is expected. See #95. + -> Command -> DebugAdaptor () -------------------------------------------------------------------------------- -talk l = \ case +talk l support_rit_var pid_var client_proxy_signal = \ case CommandInitialize -> do - -- InitializeRequestArguments{..} <- getArguments + InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments + let runInTerminal = fromMaybe False supportsRunInTerminalRequest + liftIO $ writeIORef support_rit_var runInTerminal sendInitializeResponse + + -- If runInTerminal is not supported by the client, signal readiness right away + when (not runInTerminal) $ + liftIO $ putMVar client_proxy_signal () + -------------------------------------------------------------------------------- CommandLaunch -> do launch_args <- getArguments - merror <- runExceptT $ initDebugger (cmapWithSev InitLog l) launch_args + + supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var + + merror <- runExceptT $ initDebugger (cmapWithSev InitLog l) supportsRunInTerminalRequest launch_args case merror of Right () -> do sendLaunchResponse -- ack sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session + + -- Run the proxy in a separate terminal to accept stdin / forward stdout + -- if it is supported + when supportsRunInTerminalRequest $ do + -- Run proxy thread, server side, and + -- send the 'runInTerminal' request + serverSideHdbProxy (cmapWithSev RunProxyServerLog l) client_proxy_signal + + logWith l Info $ LaunchLog $ T.pack "Debugger launched successfully." + Left (InitFailed err) -> do sendErrorResponse (ErrorMessage (T.pack err)) Nothing exitCleanly @@ -237,6 +202,9 @@ CommandConfigurationDone -> do sendConfigurationDoneResponse -- now that it has been configured, start executing until it halts, then send an event + + -- wait for the proxy client to connect before starting the execution (#95) + () <- liftIO $ takeMVar client_proxy_signal startExecution >>= handleEvalResult False ---------------------------------------------------------------------------- CommandThreads -> commandThreads @@ -253,13 +221,33 @@ ---------------------------------------------------------------------------- CommandEvaluate -> commandEvaluate ---------------------------------------------------------------------------- - CommandTerminate -> commandTerminate + CommandTerminate -> do + commandTerminate CommandDisconnect -> commandDisconnect ---------------------------------------------------------------------------- CommandModules -> sendModulesResponse (ModulesResponse [] Nothing) CommandSource -> undefined - CommandPause -> undefined + CommandPause -> pure () -- TODO (CustomCommand "mycustomcommand") -> undefined + (CustomCommand "runInTerminal") -> do + -- Ignore result of runInTerminal (reverse request) response. + -- If it fails, we simply continue without that functionality. + pure () + other -> do + sendErrorResponse (ErrorMessage (T.pack ("Unsupported command: " <> show other))) Nothing + exitCleanly ---------------------------------------------------------------------------- -- talk cmd = logInfo $ BL8.pack ("GOT cmd " <> show cmd) ---------------------------------------------------------------------------- + +-- | Receive reverse request responses (such as runInTerminal response) +ack :: Recorder (WithSeverity MainLog) + -> IORef (Maybe Int) + -- ^ Reference to PID of runInTerminal proxy process running + -> ReverseRequestResponse -> DebugAdaptorCont () +ack l ref rrr = case rrr.reverseRequestCommand of + ReverseCommandRunInTerminal -> do + when rrr.success $ do + logWith l Info $ LaunchLog $ T.pack "RunInTerminal was successful" + _ -> pure () + diff --git a/test/haskell/Main.hs b/test/haskell/Main.hs --- a/test/haskell/Main.hs +++ b/test/haskell/Main.hs @@ -1,4 +1,121 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes #-} module Main (main) where +import Text.RE.TDFA.Text.Lazy +import Text.Printf +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import qualified Data.Text.Lazy.IO as LT +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified System.Process as P +import System.FilePath +import System.IO.Temp +import System.Exit +import System.IO +import Control.Exception + +import Test.Tasty +import Test.Tasty.Golden as G +import Test.Tasty.Golden.Advanced as G + +import Test.DAP.RunInTerminal +import Test.Utils + main :: IO () -main = putStrLn "Test suite not yet implemented." +main = do + goldens <- mapM (mkGoldenTest False) =<< findByExtension [".hdb-test"] "test/golden" + defaultMain $ + testGroup "Tests" + [ testGroup "Golden tests" goldens + , testGroup "Unit tests" unitTests + ] + +unitTests = + [ runInTerminalTests + ] + +-- | Receives as an argument the path to the @*.hdb-test@ which contains the +-- shell invocation for running +mkGoldenTest :: Bool -> FilePath -> IO TestTree +mkGoldenTest keepTmpDirs path = do + let testName = takeBaseName path + let goldenPath = replaceExtension path ".hdb-stdout" + return (goldenVsStringComparing testName goldenPath action) + where + action :: IO LBS.ByteString + action = do + script <- readFile path + withHermeticDir keepTmpDirs (takeDirectory path) $ \test_dir -> do + (_, Just hout, _, p) + <- P.createProcess (P.shell script){P.cwd = Just test_dir, P.std_out = P.CreatePipe} + P.waitForProcess p >>= \case + ExitSuccess -> LBS.hGetContents hout + ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c + +-------------------------------------------------------------------------------- +-- Tasty Golden Advanced wrapper +-------------------------------------------------------------------------------- + +-- | Compare a given string against the golden file's contents using the given normalising function +-- This is inlined from 'goldenVsString' and the accompanying functions. We +-- wanted the same but with a normalising function. +goldenVsStringComparing + :: TestName -- ^ test name + -> FilePath -- ^ path to the «golden» file (the file that contains correct output) + -> IO LBS.ByteString + -- ^ action that returns a string + -> TestTree + -- ^ the test verifies that the returned string is the same as the golden file contents +goldenVsStringComparing name ref act = do + + -- Normalise the output. The test file should already be saved normalised. + goldenTest name (LT.decodeUtf8 <$> readFileStrict ref) normalisingAct cmpNormalising upd + + where + upd = createDirectoriesAndWriteFile ref . LT.encodeUtf8 + + -- Normalise the action producing the output + normalisingAct = do + tmpDir <- getCanonicalTemporaryDirectory + replaceRE <- compileSearchReplace (tmpDir ++ ".*" ++ takeBaseName (takeDirectory ref) {- the folder in which the test is run, inside the canonical temp dir-}) + "" + + let normalising (LT.decodeUtf8 -> txt) = txt *=~/ replaceRE + + normalising <$> act + + readFileStrict :: FilePath -> IO LBS.ByteString + readFileStrict path = do + s <- LBS.readFile path + evaluate $ forceLbs s + return s + + forceLbs :: LBS.ByteString -> () + forceLbs = LBS.foldr seq () + +-------------------------------------------------------------------------------- +-- Normalisation +-------------------------------------------------------------------------------- + + -- | Compare the golden test against the actual output after normalisation + cmpNormalising :: LT.Text -> LT.Text -> IO (Maybe String) + cmpNormalising x y = do + + let + msg = printf "Test output was different from '%s'. It was:\n" ref <> (LT.unpack y) + + if x == y + then return Nothing + else do + -- Call diff to show the difference + withSystemTempFile "x.txt" $ \xf xH -> do + withSystemTempFile "y.txt" $ \yf yH -> do + LT.hPutStr xH x + LT.hPutStr yH y + hFlush xH + hFlush yH + hClose xH + hClose yH + (_exitCode, out, err) <- P.readProcessWithExitCode "diff" ["-u", xf, yf] "" + return $ Just $ msg ++ "\nDiff output:\n" ++ out ++ err + diff --git a/test/haskell/Test/DAP.hs b/test/haskell/Test/DAP.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/DAP.hs @@ -0,0 +1,122 @@ +-- | Utils essentially copied from `dap`'s test suite +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +module Test.DAP where + +---------------------------------------------------------------------------- +import Control.Applicative +import Control.Concurrent +import Data.Aeson.Encode.Pretty +import Data.Aeson.Types +import Data.Aeson.KeyMap +import Control.Exception hiding (handle) +import qualified Data.ByteString.Lazy.Char8 as BL8 ( hPutStrLn ) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 ( hPutStrLn ) +import qualified Data.HashMap.Strict as H +import Network.Run.TCP +import Network.Socket (socketToHandle) +import System.IO +import System.Exit +import Data.IORef +---------------------------------------------------------------------------- +import DAP.Utils +import DAP.Server +import DAP.Types (Command) +---------------------------------------------------------------------------- +import Test.Tasty.HUnit + +-- | Sends a DAP request to the given handle +sendDAPRequest :: ToJSON a => Handle -> Command -> a -> IO () +sendDAPRequest handle cmd args = do + send handle + [ "seq" .= (1 :: Int) + , "type" .= ("request" :: String) + , "command" .= cmd + , "arguments".= args + ] + +-- | Receive and decode DAP message +recvDAPResponse + :: FromJSON a + => Handle + -- ^ Handle to receive bytes from + -> IO a + -- ^ The decoded DAP message +recvDAPResponse h = do + readPayload h >>= \case + Left e -> fail e + Right actual -> + -- Read field "body" or "arguments" (for reverse requests) + case parseMaybe (withObject "response/rev request" $ \r -> (do + ("response" :: String) <- r .: "type" + True <- r .: "success" + r .: "body") <|> (do + ("request" :: String) <- r .: "type" + r .: "arguments") + ) actual of + Nothing -> fail $ "Failed to parse DAP response body: " ++ show actual + Just body -> + case parseMaybe parseJSON body of + Nothing -> fail $ "Failed to parse DAP response body content: " ++ show body + Just res -> pure res + +-------------------------------------------------------------------------------- + +-- | Sample host shared amongst client and server +-- +testHost :: String +testHost = "127.0.0.1" + +-- | Spawns a new mock client that connects to the mock server. +-- +withNewClient :: Int -- ^ Port + -> IORef Bool + -- ^ True if we've already connected once and therefore should no longer retry + -> (Handle -> IO ()) + -> IO () +withNewClient port retryVar continue = flip catch exceptionHandler $ + runTCPClient testHost (show port) $ \socket -> do + h <- socketToHandle socket ReadWriteMode + hSetNewlineMode h NewlineMode { inputNL = CRLF, outputNL = CRLF } + continue h `finally` hClose h + where + exceptionHandler :: SomeException -> IO () + exceptionHandler e = do + do_retry <- readIORef retryVar + if do_retry then do + threadDelay 100_000 -- 0.1s + -- Do it silently: + -- putStrLn "Retrying connection..." + withNewClient port retryVar continue + else do + putStrLn $ displayException e + exitWith (ExitFailure 22) + +-- | Helper to send JSON payloads to the server +-- +send :: Handle -> [Pair] -> IO () +send h message + = BS.hPutStr h $ encodeBaseProtocolMessage (object message) + +-- | Helper to receive JSON payloads to the client +-- checks if 'Handle' returns a subset expected payload +-- +shouldReceive + :: Handle + -- ^ Handle to receive bytes from + -> [Pair] + -- ^ Subset of JSON values that should be present in the payload + -> IO () +shouldReceive h expected = do + case object expected of + Object ex -> + readPayload h >>= \case + Left e -> fail e + Right actual + | toHashMapText ex `H.isSubmapOf` toHashMapText actual -> pure () + | otherwise -> encodePretty actual @=? encodePretty ex + _ -> fail "Invalid JSON" diff --git a/test/haskell/Test/DAP/RunInTerminal.hs b/test/haskell/Test/DAP/RunInTerminal.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/DAP/RunInTerminal.hs @@ -0,0 +1,279 @@ +-- | 'runInTerminal' tests +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE LambdaCase #-} +module Test.DAP.RunInTerminal (runInTerminalTests) where + +import Control.Concurrent +import DAP.Types +import DAP.Utils +import Data.Aeson +import Data.IORef +import Data.List (isInfixOf) +import System.FilePath +import System.IO +import System.Random +import Test.DAP +import Test.Tasty +import Test.Tasty.HUnit +import Test.Utils +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LB8 +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified System.Process as P + +runInTerminalTests = + testGroup "DAP.RunInTerminal" + [ testCase "runInTerminal: proxy forwards stdin correctly" runInTerminal1 + ] + +rit_keep_tmp_dirs :: Bool +rit_keep_tmp_dirs = False + +runInTerminal1 = do + withHermeticDir rit_keep_tmp_dirs "test/unit/T44" $ \test_dir -> do + + -- Come up with a random port + testPort <- randomRIO (49152, 65534) :: IO Int + + -- Launch server process + (Just hin, Just hout, _, p) + <- P.createProcess (P.shell $ "hdb server --port " ++ show testPort) + {P.cwd = Just test_dir, P.std_out = P.CreatePipe, P.std_in = P.CreatePipe} + + -- Fork thread to print out output of server process + -- This is surprisingly needed, otherwise the server process + -- will be broken, perhaps because it blocks trying to write to stdout/stderr if the buffer is full? + forkIO $ do + hSetBuffering hout LineBuffering + let loop = do + eof <- hIsEOF hout + if eof + then return () + else do + _l <- hGetLine hout + -- putStrLn ("[server] " ++ l) + loop + loop + + retryVar <- newIORef True + -- Connect to the DAP server + withNewClient testPort retryVar $ \handle -> do + -- As soon as we get a connection, stop retrying + writeIORef retryVar False + + -- Initialize + sendDAPRequest handle CommandInitialize InitializeRequestArguments + { adapterID = "haskell-debugger" + , clientID = Just "mock-client" + , clientName = Just "Mock Client" + , columnsStartAt1 = Just True + , linesStartAt1 = Just True + , locale = Just "en" + , pathFormat = Just Path + , supportsArgsCanBeInterpretedByShell = Nothing + , supportsInvalidatedEvent = Nothing + , supportsMemoryEvent = Nothing + , supportsMemoryReferences = Nothing + , supportsProgressReporting = Nothing + , supportsRunInTerminalRequest = Just True + , supportsStartDebuggingRequest = Nothing + , supportsVariablePaging = Nothing + , supportsVariableType = Nothing + } + + -- Recv initalize response + _ <- shouldReceive handle [] + + -- Send launch request + send handle + [ "command" .= ("launch" :: String) + , "seq" .= (2 :: Int) + , "type" .= ("request" :: String) + , "arguments".= object + [ "entryFile" .= (test_dir "Main.hs" :: String) + , "entryPoint" .= ("main" :: String) + , "projectRoot" .= (test_dir :: String) + , "extraGhcArgs" .= ([] :: [String]) + , "entryArgs" .= ([] :: [String]) + , "request" .= ("launch" :: String) + ] + ] + + _ <- shouldReceive handle + ["type" .= ("event" :: String), "event" .= ("output" :: String)] + _ <- shouldReceive handle + ["type" .= ("event" :: String), "event" .= ("output" :: String)] + _ <- shouldReceive handle + [ "command" .= ("launch" :: String) + , "success" .= True] + _ <- shouldReceive handle + [ "event" .= ("initialized" :: String) + , "type" .= ("event" :: String) + ] + + -- Receive a runInTerminal request!! + r@RunInTerminalRequestArguments{} <- recvDAPResponse handle + (Just rit_in, Just rit_out, _, rit_p) + <- P.createProcess + (P.shell $ T.unpack $ + "/usr/bin/env " <> addRITEnv r.runInTerminalRequestArgumentsEnv <> " " <> T.unwords (r.runInTerminalRequestArgumentsArgs)) + {P.cwd = Just test_dir, P.std_in = P.CreatePipe, P.std_out = P.CreatePipe} + + -- Send a breakpoint request + sendDAPRequest handle CommandSetBreakpoints + SetBreakpointsArguments + { setBreakpointsArgumentsSource = Source + { sourceName = Just "Main.hs" + , sourcePath = Just $ T.pack $ test_dir "Main.hs" + , sourceSourceReference = Nothing + , sourcePresentationHint = Nothing + , sourceOrigin = Nothing + , sourceAdapterData = Nothing + , sourceChecksums = Nothing + , sourceSources = Nothing + } + , setBreakpointsArgumentsBreakpoints = Just [SourceBreakpoint {sourceBreakpointLine = 6, sourceBreakpointColumn = Nothing, sourceBreakpointCondition = Nothing, sourceBreakpointHitCondition = Nothing, sourceBreakpointLogMessage = Nothing}] + , setBreakpointsArgumentsLines = Just [6] + , setBreakpointsArgumentsSourceModified = Just False + } + + _ <- shouldReceive handle + [ "command" .= ("setBreakpoints" :: String) + , "success" .= True + , "type" .= ("response" :: String) + ] + + -- Send runInTerminal response + Just rit_pid <- P.getPid rit_p + send handle + [ "command" .= ("runInTerminal" :: String) + , "seq" .= (6 :: Int) + , "type" .= ("response" :: String) + , "success" .= True + , "body" .= object + [ "shellProcessId" .= (fromIntegral rit_pid :: Int) + ] + ] + + send handle + [ "seq" .= (1 :: Int) + , "type" .= ("request" :: String) + , "command" .= CommandConfigurationDone + ] + + _ <- shouldReceive handle + [ "command" .= ("configurationDone" :: String) + , "success" .= True + , "type" .= ("response" :: String) + ] + + -- The program should start running now, and hit the breakpoint. + -- It will also print "Hello". Since the order is not important, we just + -- match on the type == event and ignore if it's "stopped" or "output" + _ <- shouldReceive handle + [ "type" .= ("event" :: String) ] + _ <- shouldReceive handle + [ "type" .= ("event" :: String) ] + + -- Continue from "getLine" which will block waiting for input + goToNextLine handle + + let secret_in = "SOMETHING_SECRET" + + -- Time to write to the stdin of the rit process + hSetBuffering rit_in LineBuffering + hPutStrLn rit_in secret_in + + -- Only after writing should we receive the next "stopped" event + _ <- shouldReceive handle + ["type" .= ("event" :: String), "event" .= ("stopped" :: String)] + + -- To next line, which should be the "putStrLn" after the "getLine" + goToNextLine handle + -- It's both stopped and we receive the SOMETHING_SECRET printed out. Order not important. + _ <- shouldReceive handle + ["type" .= ("event" :: String)] + _ <- shouldReceive handle + ["type" .= ("event" :: String)] + + -- The contents of the rit_output should contain "hello" plus printing of what we wrote + out <- LBS.hGetContents rit_out + let out_str = LB8.unpack out + assertBool ("Expected output to contain 'hello', got: " ++ out_str) + ("hello" `isInfixOf` out_str) + assertBool ("Expected output to contain '" ++ secret_in ++ "' , got: " ++ out_str) + (secret_in `isInfixOf` out_str) + + -- Send disconnect + sendDAPRequest handle CommandDisconnect (DisconnectArguments {disconnectArgumentsRestart = False, disconnectArgumentsTerminateDebuggee = True, disconnectArgumentsSuspendDebuggee = False}) + _ <- shouldReceive handle + [ "command" .= ("disconnect" :: String) + , "success" .= True + , "type" .= ("response" :: String) + ] + _ <- shouldReceive handle + [ "event" .= ("terminated" :: String) + , "type" .= ("event" :: String) + ] + -- Kill the processes if they're still running + P.terminateProcess rit_p + P.terminateProcess p + + where + goToNextLine handle = do + _ <- sendDAPRequest handle CommandNext (Just (NextArguments {nextArgumentsThreadId = 0, nextArgumentsSingleThread = Nothing, nextArgumentsGranularity = Nothing})) + _ <- shouldReceive handle + [ "command" .= ("next" :: String) + , "success" .= True + , "type" .= ("response" :: String) + ] + return () + + addRITEnv :: Maybe (H.HashMap T.Text T.Text) -> T.Text + addRITEnv env = + case env of + Nothing -> "" + Just env -> T.unwords [k{-todo: escape-} <> "=" <> v | (k,v) <- H.toList env] +-------------------------------------------------------------------------------- +instance ToJSON InitializeRequestArguments where + toJSON InitializeRequestArguments{..} = object + [ "adapterID" .= adapterID + , "clientID" .= clientID + , "clientName" .= clientName + , "columnsStartAt1" .= columnsStartAt1 + , "linesStartAt1" .= linesStartAt1 + , "locale" .= locale + , "pathFormat" .= pathFormat + , "supportsArgsCanBeInterpretedByShell" .= supportsArgsCanBeInterpretedByShell + , "supportsInvalidatedEvent" .= supportsInvalidatedEvent + , "supportsMemoryEvent" .= supportsMemoryEvent + , "supportsMemoryReferences" .= supportsMemoryReferences + , "supportsProgressReporting" .= supportsProgressReporting + , "supportsRunInTerminalRequest" .= supportsRunInTerminalRequest + , "supportsStartDebuggingRequest" .= supportsStartDebuggingRequest + , "supportsVariablePaging" .= supportsVariablePaging + , "supportsVariableType" .= supportsVariableType + ] +instance ToJSON PathFormat where + toJSON Path = String "path" + toJSON URI = String "uri" + toJSON (PathFormat x) = String x +instance ToJSON SetBreakpointsArguments where + toJSON = genericToJSONWithModifier +instance ToJSON NextArguments where + toJSON = genericToJSONWithModifier +instance ToJSON DisconnectArguments where + toJSON = genericToJSONWithModifier +instance ToJSON SourceBreakpoint where + toJSON = genericToJSONWithModifier +instance ToJSON SteppingGranularity where + toJSON = genericToJSONWithModifier +instance FromJSON bps => FromJSON (Breakpoints bps) where + parseJSON = withObject "bkrps" $ \o -> + Breakpoints <$> o .: "breakpoints" +instance FromJSON Breakpoint where + parseJSON = genericParseJSONWithModifier + diff --git a/test/haskell/Test/Utils.hs b/test/haskell/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/haskell/Test/Utils.hs @@ -0,0 +1,25 @@ +module Test.Utils where + +import System.FilePath +import System.IO.Temp +import qualified System.Process as P + +-- | Copy the contents of a test directory (with a `*.hdb-test` in the root) to +-- a temporary location and return the path to the new location. +withHermeticDir :: Bool -- ^ Whether to keep the temp dir around for inspection + -> FilePath -- ^ Test dir + -> (FilePath -> IO r) -- ^ Continuation receives hermetic test dir (in temporary dir) + -> IO r +withHermeticDir keep src k = do + withTmpDir "hdb-test" $ \dest -> do + P.callCommand $ "cp -r " ++ src ++ " " ++ dest + k (dest takeBaseName src) + where + withTmpDir | keep = withPersistentSystemTempDirectory + | otherwise = withSystemTempDirectory + + withPersistentSystemTempDirectory :: String -> (FilePath -> IO r) -> IO r + withPersistentSystemTempDirectory template k' = do + dir <- flip createTempDirectory template =<< getCanonicalTemporaryDirectory + k' dir +