Run proxy program with runInTerminal to allow stdin

haskell-debugger.cabal

@@ -103,15 +103,24 @@ executable hdb
                       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:
         base, ghc,
         exceptions, aeson, bytestring,
         containers, filepath,
         process, mtl, unix,
+        unordered-containers >= 0.2.19 && < 0.3,
 
         haskell-debugger,
         hie-bios,
@@ -122,9 +131,11 @@ executable hdb
         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,11 @@ executable hdb
 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,
@@ -149,8 +160,15 @@ test-suite haskell-debugger-test
         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

haskell-debugger/GHC/Debugger/Breakpoint.hs

@@ -84,7 +84,10 @@ setBreakpoint ModuleBreak{path, lineNum, columnNum} bp_status = do
 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

haskell-debugger/GHC/Debugger/Evaluation.hs

@@ -11,7 +11,6 @@
 {-# LANGUAGE ViewPatterns #-}
 module GHC.Debugger.Evaluation where
 
-import GHC.Utils.Trace
 import GHC.Utils.Outputable
 import Control.Monad.IO.Class
 import Control.Monad.Catch
@@ -120,8 +119,9 @@ debugExecution recorder entryFile entry args = do
     findUnitIdOfEntryFile fp = do
       afp <- normalise <$> liftIO (makeAbsolute fp)
       modSums <- getAllLoadedModules
-      case List.find ((Just afp ==) . 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

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
@@ -29,6 +31,12 @@ data DebugAdaptorState = DAS
       , 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

hdb/Development/Debug/Adapter/Init.hs

@@ -9,8 +9,12 @@
 -- | 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
@@ -88,8 +92,9 @@ 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
@@ -98,6 +103,9 @@ initDebugger l LaunchArgs{ __sessionId
                          } = 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"
@@ -134,10 +142,12 @@ initDebugger l LaunchArgs{ __sessionId
 
       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
@@ -150,25 +160,50 @@ initDebugger l LaunchArgs{ __sessionId
           -- Instead of signalInitialized, respond with error and exit.
           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:

hdb/Development/Debug/Adapter/Proxy.hs

@@ -0,0 +1,159 @@
+{-# 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 <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)
+                   -> DebugAdaptor ()
+serverSideHdbProxy l = 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 ++ "...!"
+
+      -- -- 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
+      }