{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
module GHC.Debug.Client.Monad
  ( DebugMonad(..)
  , run
  , DebugM
  , Debuggee
  , traceWrite
  , runTrace
    -- * Running/Connecting to a debuggee
  , withDebuggeeRun
  , withDebuggeeConnect
  , withDebuggeeConnectTCP
  , debuggeeRun
  , debuggeeConnect
  , debuggeeConnectTCP
  , debuggeeConnectWithTracer
  , debuggeeConnectWithTracerTCP
  , debuggeeClose
  -- * Snapshot run
  , snapshotInit
  , snapshotInitWithTracer
  , snapshotRun
    -- * Logging
  , outputRequestLog
  ) where

import Control.Exception (finally)
import Data.Word (Word16)
import Network.Socket
import System.Process
import System.Environment
import GHC.Debug.Client.Monad.Class
import GHC.Debug.Types (Request(..))
import qualified GHC.Debug.Client.Monad.Simple as S
import System.IO
import Control.Tracer

type DebugM = S.DebugM

newtype Debuggee = Debuggee { Debuggee -> DebugEnv DebugM
debuggeeEnv :: DebugEnv DebugM }

runTrace :: Debuggee -> DebugM a -> IO a
runTrace :: forall a. Debuggee -> DebugM a -> IO a
runTrace (Debuggee DebugEnv DebugM
e) DebugM a
act = do
  (a
r, [String]
ws) <- DebugEnv DebugM -> DebugM a -> IO (a, [String])
forall a. DebugEnv DebugM -> DebugM a -> IO (a, [String])
forall (m :: * -> *) a.
DebugMonad m =>
DebugEnv m -> m a -> IO (a, [String])
runDebugTrace DebugEnv DebugM
e DebugM a
act
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
ws
  return a
r

traceWrite :: DebugMonad m => Show a => a -> m ()
traceWrite :: forall (m :: * -> *) a. (DebugMonad m, Show a) => a -> m ()
traceWrite = String -> m ()
forall (m :: * -> *). DebugMonad m => String -> m ()
traceMsg (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Run a @DebugM a@ in the given environment.
run :: Debuggee -> DebugM a -> IO a
run :: forall a. Debuggee -> DebugM a -> IO a
run (Debuggee DebugEnv DebugM
d) = DebugEnv DebugM -> DebugM a -> IO a
forall a. DebugEnv DebugM -> DebugM a -> IO a
forall (m :: * -> *) a. DebugMonad m => DebugEnv m -> m a -> IO a
runDebug DebugEnv DebugM
d

-- | Bracketed version of @debuggeeRun@. Runs a debuggee, connects to it, runs
-- the action, kills the process, then closes the debuggee.
withDebuggeeRun :: FilePath  -- ^ path to executable to run as the debuggee
                -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
                -> (Debuggee -> IO a)
                -> IO a
withDebuggeeRun :: forall a. String -> String -> (Debuggee -> IO a) -> IO a
withDebuggeeRun String
exeName String
socketName Debuggee -> IO a
action = do
    -- Start the process we want to debug
    CreateProcess
cp <- String -> String -> IO CreateProcess
debuggeeProcess String
exeName String
socketName
    CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
cp ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
 -> IO a)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
_ -> do
    -- Now connect to the socket the debuggeeProcess just started
      String -> (Debuggee -> IO a) -> IO a
forall a. String -> (Debuggee -> IO a) -> IO a
withDebuggeeConnect String
socketName Debuggee -> IO a
action

-- | Bracketed version of @debuggeeConnect@. Connects to a debuggee, runs the
-- action, then closes the debuggee.
withDebuggeeConnect :: FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
                    -> (Debuggee -> IO a)
                    -> IO a
withDebuggeeConnect :: forall a. String -> (Debuggee -> IO a) -> IO a
withDebuggeeConnect String
socketName Debuggee -> IO a
action = do
    Debuggee
new_env <- String -> IO Debuggee
debuggeeConnect String
socketName
    Debuggee -> IO a
action Debuggee
new_env
      IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally`
      Debuggee -> IO ()
debuggeeClose Debuggee
new_env

-- | Bracketed version of @debuggeeConnectTCP@. Connects to a debuggee, runs the
-- action, then closes the debuggee.
withDebuggeeConnectTCP
  :: String  -- ^ host of the tcp socket (e.g. @"127.0.0.1"@)
  -> Word16  -- ^ port of the tcp socket (e.g. @1235@)
  -> (Debuggee -> IO a)
  -> IO a
withDebuggeeConnectTCP :: forall a. String -> Word16 -> (Debuggee -> IO a) -> IO a
withDebuggeeConnectTCP String
host Word16
port Debuggee -> IO a
action = do
    Debuggee
new_env <- String -> Word16 -> IO Debuggee
debuggeeConnectTCP String
host Word16
port
    Debuggee -> IO a
action Debuggee
new_env
      IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally`
      Debuggee -> IO ()
debuggeeClose Debuggee
new_env

-- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done.
debuggeeRun :: FilePath  -- ^ path to executable to run as the debuggee
            -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
            -> IO Debuggee
debuggeeRun :: String -> String -> IO Debuggee
debuggeeRun String
exeName String
socketName = do
    -- Start the process we want to debug
    (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_ <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> IO CreateProcess
debuggeeProcess String
exeName String
socketName
    -- Now connect to the socket the debuggeeProcess just started
    String -> IO Debuggee
debuggeeConnect String
socketName

debuggeeConnect :: FilePath -> IO Debuggee
debuggeeConnect :: String -> IO Debuggee
debuggeeConnect = Tracer IO String -> String -> IO Debuggee
debuggeeConnectWithTracer Tracer IO String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer

debuggeeConnectTCP :: String -> Word16 -> IO Debuggee
debuggeeConnectTCP :: String -> Word16 -> IO Debuggee
debuggeeConnectTCP = Tracer IO String -> String -> Word16 -> IO Debuggee
debuggeeConnectWithTracerTCP Tracer IO String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer

-- | Connect to a debuggee on the given socket. Use @debuggeeClose@ when you're done.
debuggeeConnectWithTracer
                :: Tracer IO String
                -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
                -> IO Debuggee
debuggeeConnectWithTracer :: Tracer IO String -> String -> IO Debuggee
debuggeeConnectWithTracer Tracer IO String
tracer String
socketName = do
    Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
defaultProtocol
    Socket -> SockAddr -> IO ()
connect Socket
s (String -> SockAddr
SockAddrUnix String
socketName)
    Handle
hdl <- Socket -> IOMode -> IO Handle
socketToHandle Socket
s IOMode
ReadWriteMode
    Debuggee
new_env <- forall (m :: * -> *).
DebugMonad m =>
Tracer IO String -> Mode -> IO (DebugEnv m)
newEnv @DebugM Tracer IO String
tracer (Handle -> Mode
SocketMode Handle
hdl)
    return (DebugEnv DebugM -> Debuggee
Debuggee DebugEnv DebugM
Debuggee
new_env)

debuggeeConnectWithTracerTCP
  :: Tracer IO String
  -> String  -- ^ host of the tcp socket (e.g. @"127.0.0.1"@)
  -> Word16  -- ^ port of the tcp socket (e.g. @1235@)
  -> IO Debuggee
debuggeeConnectWithTracerTCP :: Tracer IO String -> String -> Word16 -> IO Debuggee
debuggeeConnectWithTracerTCP Tracer IO String
tracer String
host Word16
port = do
    AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defaultHints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
port)
    Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr)
    Socket -> SockAddr -> IO ()
connect Socket
s (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
    Handle
hdl <- Socket -> IOMode -> IO Handle
socketToHandle Socket
s IOMode
ReadWriteMode
    Debuggee
new_env <- forall (m :: * -> *).
DebugMonad m =>
Tracer IO String -> Mode -> IO (DebugEnv m)
newEnv @DebugM Tracer IO String
tracer (Handle -> Mode
SocketMode Handle
hdl)
    return (DebugEnv DebugM -> Debuggee
Debuggee DebugEnv DebugM
Debuggee
new_env)

-- | Create a debuggee by loading a snapshot created by 'snapshot'.
snapshotInit :: FilePath -> IO Debuggee
snapshotInit :: String -> IO Debuggee
snapshotInit = Tracer IO String -> String -> IO Debuggee
snapshotInitWithTracer Tracer IO String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer

snapshotInitWithTracer :: Tracer IO String -> FilePath -> IO Debuggee
snapshotInitWithTracer :: Tracer IO String -> String -> IO Debuggee
snapshotInitWithTracer Tracer IO String
tracer String
fp =
  DebugEnv DebugM -> Debuggee
Debuggee -> Debuggee
Debuggee (Debuggee -> Debuggee) -> IO Debuggee -> IO Debuggee
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
DebugMonad m =>
Tracer IO String -> Mode -> IO (DebugEnv m)
newEnv @DebugM Tracer IO String
tracer (String -> Mode
SnapshotMode String
fp)


-- | Start an analysis session using a snapshot. This will not connect to a
-- debuggee. The snapshot is created by 'snapshot'.
snapshotRun :: FilePath -> (Debuggee -> IO a) -> IO a
snapshotRun :: forall a. String -> (Debuggee -> IO a) -> IO a
snapshotRun String
fp Debuggee -> IO a
k = do
  Debuggee
denv <- String -> IO Debuggee
snapshotInit String
fp
  Debuggee -> IO a
k Debuggee
denv

-- | Close the connection to the debuggee.
debuggeeClose :: Debuggee -> IO ()
debuggeeClose :: Debuggee -> IO ()
debuggeeClose Debuggee
d = Debuggee -> DebugM () -> IO ()
forall a. Debuggee -> DebugM a -> IO a
run Debuggee
d (DebugM () -> IO ()) -> DebugM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request () -> DebugM ()
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request ()
RequestResume

debuggeeProcess :: FilePath -> FilePath -> IO CreateProcess
debuggeeProcess :: String -> String -> IO CreateProcess
debuggeeProcess String
exe String
sockName = do
  [(String, String)]
e <- IO [(String, String)]
getEnvironment
  return $
    (String -> [String] -> CreateProcess
proc String
exe []) { env = Just (("GHC_DEBUG_SOCKET", sockName) : e) }

outputRequestLog :: Debuggee -> IO ()
outputRequestLog :: Debuggee -> IO ()
outputRequestLog = forall (m :: * -> *). DebugMonad m => DebugEnv m -> IO ()
printRequestLog @DebugM (Debuggee -> IO ()) -> (Debuggee -> Debuggee) -> Debuggee -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Debuggee -> DebugEnv DebugM
Debuggee -> Debuggee
debuggeeEnv