module System.Win32.DebugApi where
import Control.Exception( bracket_ )
import Data.Word ( Word8, Word32 )
import Foreign ( Ptr, nullPtr, ForeignPtr, mallocForeignPtrBytes
, peekByteOff, plusPtr, allocaBytes, castPtr, poke
, withForeignPtr, Storable, sizeOf, peek, pokeByteOff )
import System.IO ( fixIO )
import System.Win32.Types ( HANDLE, BOOL, WORD, DWORD, failIf_, failWith
, getLastError, failIf, LPTSTR, withTString )
type PID = DWORD
type TID = DWORD
type DebugEventId = (PID, TID)
type ForeignAddress = Word32
type PHANDLE = Ptr ()
type THANDLE = Ptr ()
type ThreadInfo = (THANDLE, ForeignAddress, ForeignAddress)
type ImageInfo = (HANDLE, ForeignAddress, DWORD, DWORD, ForeignAddress)
type ExceptionInfo = (Bool, Bool, ForeignAddress)
data Exception
= UnknownException
| AccessViolation Bool ForeignAddress
| ArrayBoundsExceeded
| Breakpoint
| DataTypeMisalignment
| FltDenormalOperand
| FltDivideByZero
| FltInexactResult
| FltInvalidOperation
| FltOverflow
| FltStackCheck
| FltUnderflow
| IllegalInstruction
| InPageError
| IntDivideByZero
| IntOverflow
| InvalidDisposition
| NonContinuable
| PrivilegedInstruction
| SingleStep
| StackOverflow
deriving (Show)
data DebugEventInfo
= UnknownDebugEvent
| Exception ExceptionInfo Exception
| CreateThread ThreadInfo
| CreateProcess PHANDLE ImageInfo ThreadInfo
| ExitThread TID
| ExitProcess PID
| LoadDll ImageInfo
| UnloadDll TID
| DebugString ForeignAddress Bool WORD
deriving (Show)
type DebugEvent = (DebugEventId, DebugEventInfo)
peekDebugEvent :: Ptr a -> IO DebugEvent
peekDebugEvent p = do
code <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
pid <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
tid <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
r <- rest (code::DWORD) (plusPtr p ((12)))
return ((pid,tid), r)
where
dwZero = 0 :: DWORD
wZero = 0 :: WORD
rest (1) p = do
chance <- ((\hsc_ptr -> peekByteOff hsc_ptr 80)) p
flags <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
addr <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p
code <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
e <- case code::DWORD of
(3221225477) -> return $ AccessViolation False 0
(3221225612) -> return ArrayBoundsExceeded
(2147483651) -> return Breakpoint
(2147483650) -> return DataTypeMisalignment
(3221225613) -> return FltDenormalOperand
(3221225614) -> return FltDivideByZero
(3221225615) -> return FltInexactResult
(3221225616) -> return FltInvalidOperation
(3221225617) -> return FltOverflow
(3221225618) -> return FltStackCheck
(3221225619) -> return FltUnderflow
(3221225501) -> return IllegalInstruction
(3221225478) -> return InPageError
(3221225620) -> return IntDivideByZero
(3221225621) -> return IntOverflow
(3221225510) -> return InvalidDisposition
(3221225509) -> return NonContinuable
(3221225622) -> return PrivilegedInstruction
(2147483652) -> return SingleStep
(3221225725) -> return StackOverflow
_ -> return UnknownException
return $ Exception (chance/=dwZero, flags==dwZero, addr) e
rest (2) p = do
handle <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
local <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
start <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
return $ CreateThread (handle, local, start)
rest (3) p = do
file <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
proc <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
thread <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
imgbase <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p
dbgoff <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
dbgsize <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) p
local <- ((\hsc_ptr -> peekByteOff hsc_ptr 24)) p
start <- ((\hsc_ptr -> peekByteOff hsc_ptr 28)) p
imgname <- ((\hsc_ptr -> peekByteOff hsc_ptr 32)) p
return $ CreateProcess proc
(file, imgbase, dbgoff, dbgsize, imgname)
(thread, local, start)
rest (4) p =
((\hsc_ptr -> peekByteOff hsc_ptr 0)) p >>= return.ExitThread
rest (5) p =
((\hsc_ptr -> peekByteOff hsc_ptr 0)) p >>= return.ExitProcess
rest (6) p = do
file <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
imgbase <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
dbgoff <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p
dbgsize <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p
imgname <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p
return $
LoadDll (file, imgbase, dbgoff, dbgsize, imgname)
rest (8) p = do
dat <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p
unicode <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p
length <- ((\hsc_ptr -> peekByteOff hsc_ptr 6)) p
return $ DebugString dat (unicode/=wZero) length
rest (7) p =
((\hsc_ptr -> peekByteOff hsc_ptr 0)) p >>= return.UnloadDll
rest _ _ = return UnknownDebugEvent
waitForDebugEvent :: Maybe Int -> IO (Maybe DebugEvent)
waitForDebugEvent timeout = allocaBytes ((96)) $ \buf -> do
res <- c_WaitForDebugEvent buf $ maybe (4294967295) fromIntegral timeout
if res
then peekDebugEvent buf >>= return.Just
else getLastError >>= \e -> case e of
(6) -> return Nothing
(121) -> return Nothing
_ -> die e
where
die res = failWith "WaitForDebugEvent" res
getDebugEvents :: Int -> IO [DebugEvent]
getDebugEvents timeout = waitForDebugEvent (Just timeout) >>= getMore
where
getMore e = case e of
Nothing -> return []
Just e -> do
rest <- waitForDebugEvent (Just 0) >>= getMore
return $ e:rest
continueDebugEvent :: DebugEventId -> Bool -> IO ()
continueDebugEvent (pid,tid) cont =
failIf_ not "ContinueDebugEvent" $ c_ContinueDebugEvent pid tid cont'
where
cont' = if cont
then (65538)
else (2147549185)
debugActiveProcess :: PID -> IO ()
debugActiveProcess pid =
failIf_ not "debugActiveProcess: DebugActiveProcess" $
c_DebugActiveProcess pid
peekProcessMemory :: PHANDLE -> ForeignAddress -> Int -> Ptr a -> IO ()
peekProcessMemory proc addr size buf =
failIf_ not "peekProcessMemory: ReadProcessMemory" $
c_ReadProcessMemory proc (plusPtr nullPtr $ fromIntegral addr) (castPtr buf) (fromIntegral size) nullPtr
readProcessMemory :: PHANDLE -> ForeignAddress -> Int -> IO (ForeignPtr a)
readProcessMemory proc addr size = do
res <- mallocForeignPtrBytes size
withForeignPtr res $ peekProcessMemory proc addr size
return res
pokeProcessMemory :: PHANDLE -> ForeignAddress -> Int -> Ptr a -> IO ()
pokeProcessMemory proc addr size buf =
failIf_ not "pokeProcessMemory: WriteProcessMemory" $
c_WriteProcessMemory proc (plusPtr nullPtr $ fromIntegral addr) (castPtr buf) (fromIntegral size) nullPtr
withProcessMemory :: PHANDLE -> ForeignAddress -> Int -> (Ptr a -> IO b) -> IO b
withProcessMemory proc addr size act = allocaBytes size $ \buf -> do
peekProcessMemory proc addr size buf
res <- act buf
pokeProcessMemory proc addr size buf
return res
peekP :: (Storable a) => PHANDLE -> ForeignAddress -> IO a
peekP proc addr = fixIO $ \res -> withProcessMemory proc addr (sizeOf res) peek
pokeP :: (Storable a) => PHANDLE -> ForeignAddress -> a -> IO ()
pokeP proc addr v = withProcessMemory proc addr (sizeOf v) $ \buf -> poke buf v
suspendThread :: THANDLE -> IO DWORD
suspendThread t =
failIf (==01) "SuspendThread" $ c_SuspendThread t
resumeThread :: THANDLE -> IO DWORD
resumeThread t =
failIf (==01) "ResumeThread" $ c_ResumeThread t
withSuspendedThread :: THANDLE -> IO a -> IO a
withSuspendedThread t = bracket_ (suspendThread t) (resumeThread t)
getThreadContext :: THANDLE -> Ptr a -> IO ()
getThreadContext t buf =
failIf_ not "GetThreadContext" $ c_GetThreadContext t (castPtr buf)
setThreadContext :: THANDLE -> Ptr a -> IO ()
setThreadContext t buf =
failIf_ not "SetThreadContext" $ c_SetThreadContext t (castPtr buf)
useAllRegs :: Ptr a -> IO ()
useAllRegs buf = ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf v
where
v = (65567) :: DWORD
withThreadContext :: THANDLE -> (Ptr a -> IO b) -> IO b
withThreadContext t act =
allocaBytes ((716))
$ \buf -> bracket_
(useAllRegs buf >> getThreadContext t buf)
(useAllRegs buf >> setThreadContext t buf)
(act buf)
eax, ebx, ecx, edx :: Int
esi, edi :: Int
ebp, eip, esp :: Int
segCs, segDs, segEs, segFs, segGs :: Int
eFlags :: Int
eax = ((176))
ebx = ((164))
ecx = ((172))
edx = ((168))
esi = ((160))
edi = ((156))
ebp = ((180))
eip = ((184))
esp = ((196))
segCs = ((188))
segDs = ((152))
segEs = ((148))
segFs = ((144))
segGs = ((140))
eFlags = ((192))
dr :: Int -> Int
dr n = case n of
0 -> ((4))
1 -> ((8))
2 -> ((12))
3 -> ((16))
6 -> ((20))
7 -> ((24))
_ -> undefined
setReg :: Ptr a -> Int -> DWORD -> IO ()
setReg = pokeByteOff
getReg :: Ptr a -> Int -> IO DWORD
getReg = peekByteOff
modReg :: Ptr a -> Int -> (DWORD->DWORD) -> IO DWORD
modReg buf r f = do
old <- getReg buf r
setReg buf r (f old)
return old
makeModThreadContext :: [(Int, DWORD->DWORD)] -> Ptr a -> IO [DWORD]
makeModThreadContext act buf = mapM (uncurry $ modReg buf) act
modifyThreadContext :: THANDLE -> [(Int, DWORD->DWORD)] -> IO [DWORD]
modifyThreadContext t a = withThreadContext t $ makeModThreadContext a
outputDebugString :: String -> IO ()
outputDebugString s = withTString s $ \s -> c_OutputDebugString s
foreign import stdcall "windows.h SuspendThread"
c_SuspendThread :: THANDLE -> IO DWORD
foreign import stdcall "windows.h ResumeThread"
c_ResumeThread :: THANDLE -> IO DWORD
foreign import stdcall "windows.h WaitForDebugEvent"
c_WaitForDebugEvent :: Ptr () -> DWORD -> IO BOOL
foreign import stdcall "windows.h ContinueDebugEvent"
c_ContinueDebugEvent :: DWORD -> DWORD -> DWORD -> IO BOOL
foreign import stdcall "windows.h DebugActiveProcess"
c_DebugActiveProcess :: DWORD -> IO Bool
foreign import stdcall "windows.h ReadProcessMemory" c_ReadProcessMemory ::
PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL
foreign import stdcall "windows.h WriteProcessMemory" c_WriteProcessMemory ::
PHANDLE -> Ptr () -> Ptr Word8 -> DWORD -> Ptr DWORD -> IO BOOL
foreign import stdcall "windows.h GetThreadContext"
c_GetThreadContext :: THANDLE -> Ptr () -> IO BOOL
foreign import stdcall "windows.h SetThreadContext"
c_SetThreadContext :: THANDLE -> Ptr () -> IO BOOL
foreign import stdcall "windows.h OutputDebugStringW"
c_OutputDebugString :: LPTSTR -> IO ()
foreign import stdcall "windows.h IsDebuggerPresent"
isDebuggerPresent :: IO BOOL
foreign import stdcall "windows.h DebugBreak"
debugBreak :: IO ()