diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for ghc-debug-stub +## 0.5.0.0 -- 2023-06-06 + +* Add support for debugging over a TCP socket (`withGhcDebugTCP`) + ## 0.4.0.0 -- 2022-12-14 * Fix compatability with HEAD/9.4/9.2 diff --git a/cbits/stub.cpp b/cbits/stub.cpp --- a/cbits/stub.cpp +++ b/cbits/stub.cpp @@ -778,7 +778,57 @@ */ extern "C" -void start(const char* socket_path) { +void start_over_tcp(const char* socket_addr, uint16_t port) { + trace("starting with socket: %s:%d\n", socket_addr, port); + struct sockaddr_in local, remote; + int family; + + // try ipv4 + if (inet_pton(AF_INET, socket_addr, &local.sin_addr) == 1) { + family = AF_INET; + } else { + // try ipv6 + if (inet_pton(AF_INET6, socket_addr, &local.sin_addr) == 1) { + family = AF_INET6; + } else { + barf("invalid socket address: \"%s\"", socket_addr); + } + } + + // Open the socket for listening + int listenHdl = socket(family, SOCK_STREAM, 0); + if (listenHdl == -1) { + barf("socket failed"); + } + + // Bind the socket to an address + local.sin_family = family; + local.sin_port = htons(port); + if (bind(listenHdl, (struct sockaddr *) &local, sizeof(local)) != 0) { + barf("bind failed"); + } + + // Listen for connections + if (listen(listenHdl, 1) != 0) { + barf("listen failed"); + } + fflush(stdout); + + while (true) { + // Wait for client connection + socklen_t len = sizeof(remote); + int commHdl = accept(listenHdl, (struct sockaddr *) &remote, &len); + if (commHdl == -1) { + barf("accept failed %s", strerror(errno)); + } + + // Handle and on disconnect listen for more connections + handle_connection(commHdl); + } +} + +extern "C" +void start_over_un(const char* socket_path) { trace("starting with socket path: %s\n", socket_path); struct sockaddr_un local, remote; @@ -813,7 +863,7 @@ if (commHdl == -1) { barf("accept failed %s", strerror(errno)); } - + // Handle and on disconnect listen for more connections handle_connection(commHdl); } diff --git a/ghc-debug-stub.cabal b/ghc-debug-stub.cabal --- a/ghc-debug-stub.cabal +++ b/ghc-debug-stub.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-debug-stub -version: 0.4.0.0 +version: 0.5.0.0 synopsis: Functions for instrumenting your application so the heap can be analysed with ghc-debug-common. description: Functions for instrumenting your application so the heap can @@ -26,8 +26,8 @@ build-depends: base >=4.16 && < 5 , directory ^>= 1.3 , filepath ^>= 1.4 - , ghc-prim ^>= 0.8 - , ghc-debug-convention == 0.4.0.0 + , ghc-prim >= 0.8 && < 0.11 + , ghc-debug-convention == 0.5.0.0 default-language: Haskell2010 cxx-sources: cbits/stub.cpp, cbits/socket.cpp, cbits/trace.cpp cxx-options: -std=gnu++11 -pthread -O3 -g3 -DTHREADED_RTS diff --git a/src/GHC/Debug/Stub.hs b/src/GHC/Debug/Stub.hs --- a/src/GHC/Debug/Stub.hs +++ b/src/GHC/Debug/Stub.hs @@ -14,12 +14,23 @@ can be attached to. The location of the socket is controlled by the @GHC_DEBUG_SOCKET@ environment variable. -} -module GHC.Debug.Stub (withGhcDebug, saveClosures, Box(..), pause, resume) where +module GHC.Debug.Stub + ( withGhcDebug + , withGhcDebugUnix + , withGhcDebugTCP + , SocketAddr (..) + , withGhcDebugX + , saveClosures + , Box(..) + , pause + , resume + ) where import Control.Applicative import Control.Concurrent import Control.Monad import Data.Maybe (fromMaybe) +import Data.Word import Foreign.C.Types import Foreign.C.String import Foreign.Marshal.Array @@ -36,15 +47,19 @@ import GHC.Debug.Convention (socketDirectory) -foreign import ccall safe "start" - start_c :: CString -> IO () +foreign import ccall safe "start_over_tcp" + start_over_tcp_c :: CString -> Word16 -> IO () +foreign import ccall safe "start_over_un" + start_over_un_c :: CString -> IO () + foreign import ccall safe "unistd.h getpid" getpid_c :: IO CInt --- | Start listening for remote debugging. You should wrap your main thread --- in this as it performs some cleanup on exit. If not used on the Main thread, --- user interupt (Ctrl-C) may skip the cleanup step. +-- | Start listening on a unix domain for remote debugging. +-- You should wrap your main thread in this as it performs some cleanup on exit. +-- If not used on the Main thread, user interupt (Ctrl-C) may skip the cleanup +-- step. -- -- By default the socket is created by referring to 'socketDirectory' which is -- in your XDG data directory. @@ -53,8 +68,11 @@ -- environment variable. withGhcDebug :: IO a -> IO a withGhcDebug main = do - -- Pick a socket file path. - socketPath <- do + defaultSocketPath <- getDefaultSocketPath + socketPath <- fromMaybe defaultSocketPath <$> lookupEnv "GHC_DEBUG_SOCKET" + withGhcDebugUnix socketPath main + where + getDefaultSocketPath = do socketOverride <- fromMaybe "" <$> lookupEnv "GHC_DEBUG_SOCKET" if not (null socketOverride) then return socketOverride @@ -65,11 +83,18 @@ let socketName = pid ++ "-" ++ name return (dir socketName) +-- | Similar to 'withGhcDebug', but with an explicit socket path +-- +-- The file directory will be created automatically if it does not exist. +-- +-- > main = withGhcDebugUnix "/tmp/ghc-debug" $ do ... +withGhcDebugUnix :: String -> IO a -> IO a +withGhcDebugUnix socketPath main = do createDirectoryIfMissing True (takeDirectory socketPath) hPutStrLn stderr $ "Starting ghc-debug on socket: " ++ socketPath -- Start a thread to handle requests - _threadId <- forkIO $ withCString socketPath start_c + _threadId <- forkIO $ withCString socketPath start_over_un_c -- Run the main thread with cleanup main @@ -77,6 +102,29 @@ (removeFile socketPath <|> putStrLn ("ghc-debug: failed to cleanup socket: " ++ socketPath) ) + +-- | Start listening on a tcp for remote debugging. +-- +-- > main = withGhcDebugTCP "127.0.0.1" 1235 $ do ... +withGhcDebugTCP :: String -> Word16 -> IO a -> IO a +withGhcDebugTCP host port main = do + hPutStrLn stderr $ "Starting ghc-debug on tcp: " ++ host ++ ":" ++ (show port) + + -- Start a thread to handle requests + _threadId <- forkIO $ withCString host $ \host_c -> + start_over_tcp_c host_c port + + -- Run the main thread + main + +data SocketAddr + = SocketAddrIp !String !Word16 + | SocketAddrUnix !String + deriving (Show, Eq) + +withGhcDebugX :: SocketAddr -> IO a -> IO a +withGhcDebugX (SocketAddrUnix socketPath) = withGhcDebugUnix socketPath +withGhcDebugX (SocketAddrIp host port) = withGhcDebugTCP host port -- | Break program execution for debugging. foreign import ccall safe "pause_mutator"