packages feed

linux-ptrace (empty) → 0.1

raw patch · 9 files changed

+434/−0 lines, 9 filesdep +basedep +bytestringdep +mmapsetup-changed

Dependencies added: base, bytestring, mmap, posix-waitpid, process, template-haskell, unix

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2010 Richard Smith++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Linux/Ptrace.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE PatternGuards #-}++module System.Linux.Ptrace (+  TracedProcess, pid,+  RemotePtr, castRemotePtr,++  traceProcess,+  continue,+  detach,++  peekBytes,+  pokeBytes,++  peek+  -- poke+) where++import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Monoid+import Foreign.ForeignPtr+import Foreign.Storable hiding (peek, poke)+import System.Linux.Ptrace.Syscall+import System.Posix.Signals+import System.Posix.Types+import System.Posix.Waitpid+import System.IO.MMap++data TracedProcess = TracedProcess {+  pid :: CPid+}++-- | Attach to an existing process+traceProcess :: CPid -> IO TracedProcess+traceProcess pid = do+  ptrace_attach pid+  m <- waitpid pid []+  case m of+    Just (pid', Stopped sig) | pid == pid', sig == sigSTOP+      -> return $ TracedProcess pid+    _ -> error $ "traceProcess: waitpid returned " ++ show m++-- | Attach to a new process+--traceForkExec :: IO () -> FilePath -> [String] -> IO TracedProcess+--traceForkExec setup file argv = do+--  pid <- fork (setup >> ptrace_traceme >> execvp file argv)+--  waitpid pid+--  return $ TracedProcess pid++-- | Continue a process until it hits a signal+-- FIXME: return info about the signal+continue :: TracedProcess -> IO ()+continue TracedProcess { pid = pid } = do+  ptrace_cont pid Nothing+  m <- waitpid pid []+  case m of+    Just (pid', Stopped sig) | pid == pid' -> return ()+    _ -> error $ "traceProcess: waitpid returned " ++ show m++detach :: TracedProcess -> IO ()+detach proc = ptrace_detach (pid proc) Nothing++peek :: Storable a => TracedProcess -> RemotePtr a -> IO a+peek proc addr = do+  result <- peekBytes proc addr (sizeOf (valueOf addr))+  let (ptr, off, size) = BS.toForeignPtr result+  withForeignPtr ptr (\p -> peekByteOff p off)+ where+  valueOf :: RemotePtr a -> a+  valueOf = undefined++-- FIXME: Is it more efficient to keep /proc/pid/mem open and read that?+--        Probably depends on the length of the read. Profile. I suspect that+--        3 words is the point at which /proc/pid/mem is faster (2 syscalls+--        rather than 3).+peekBytes :: TracedProcess -> RemotePtr a -> Int -> IO BS.ByteString+peekBytes _ _ 0 = return BS.empty+peekBytes proc addr size = (BS.take size . BS.drop extraBytes . joinWords) `fmap` mapM (ptrace_peekdata (pid proc)) readPtrs+ where+  wordSize = fromIntegral $ sizeOf addr+  alignedAddr = addr .&. complement (wordSize - 1)+  extraBytes = fromIntegral $ addr - alignedAddr+  totalBytes = fromIntegral $ size + extraBytes+  readPtrs = map fromIntegral [alignedAddr, alignedAddr+wordSize .. alignedAddr+totalBytes-1]+  joinWords = BS.pack . (extractBytes =<<)+  -- Assuming little-endian :O Could use peekByteOff instead?+  extractBytes n = map (fromIntegral . (0xff .&.) . (n `shiftR`)) [0, 8 .. fromIntegral $ 8*wordSize-1]++-- FIXME: Is it more efficient to keep /proc/<...>/mem open and write to that?+--        Does the kernel even support that?+pokeBytes :: TracedProcess -> RemotePtr a -> BS.ByteString -> IO ()+pokeBytes proc addr bs = do+  s <- start+  e <- end+  doWrite (s `mappend` bs `mappend` e)+ where+  size = BS.length bs+  wordSize = sizeOf addr+  alignedAddr = addr .&. complement (fromIntegral wordSize - 1)+  startBytes = fromIntegral $ addr - alignedAddr+  endBytes = -(size + startBytes) .&. complement (wordSize - 1)+  totalBytes = size + startBytes + endBytes+  start = peekBytes proc alignedAddr startBytes+  end = peekBytes proc (alignedAddr + fromIntegral startBytes) endBytes++  writePtrs = map fromIntegral [alignedAddr, alignedAddr+fromIntegral wordSize .. alignedAddr+fromIntegral totalBytes-1]+  splitWords = map extractWord . chunksOf wordSize+  -- Assuming little-endian :O Could use pokeByteOff instead?+  extractWord = BS.foldl' (\n w -> n `shiftL` 8 .|. fromIntegral w) 0+  doWrite = sequence_ . zipWith (ptrace_pokedata (pid proc)) writePtrs . splitWords++-- FIXME: does mmapping this file actually work?+unsafeMapBytes :: TracedProcess -> RemotePtr a -> Int -> IO BS.ByteString+unsafeMapBytes proc addr size = mmapFileByteString ("/proc/" ++ show (pid proc) ++ "/mem") $ Just (fromIntegral addr, size)++unsafeMapBytesL :: TracedProcess -> RemotePtr a -> Int -> IO BSL.ByteString+unsafeMapBytesL proc addr size = mmapFileByteStringLazy ("/proc/" ++ show (pid proc) ++ "/mem") $ Just (fromIntegral addr, fromIntegral size)++chunksOf :: Int -> BS.ByteString -> [BS.ByteString]+chunksOf n bs | BS.null bs = []+              | otherwise = let (chunk, bs') = BS.splitAt n bs in chunk:chunksOf n bs'
+ System/Linux/Ptrace/GenStruct.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}++module System.Linux.Ptrace.GenStruct where++import Control.Monad+import Foreign+import Language.Haskell.TH++genStruct :: String -> [String] -> Q Type -> Q [Dec]+genStruct name ctors elemType = do+  let name' = mkName name+  elemType' <- elemType+  varsAndTypes <- mapM (\n -> varStrictType (mkName n) (strictType notStrict elemType)) ctors+  let typeDecl = DataD [{-context-}] name' [{-tyvars-}] [RecC name' varsAndTypes] [{-deriving-}''Show]+  -- Could evaluate this now, but what happens if we're cross-compiling? Is CInt the target's size, or ours?+  let elemSize = [|sizeOf (undefined :: $(elemType))|]++  -- This exposes at least two GHC bugs:+  -- 1) It's rejected because GHC thinks $(conT name') is a type variable+  -- 2) The error message reverses the order of member definitions+  --storableInst <-+  --  [d|instance Storable $(conT name') where+  --       sizeOf _ = $(litP . integerL $ length ctors) * $(elemSize)+  --       alignment _ = alignment (undefined :: $(elemType))+  --       peek p = foldl (\e k -> [| $e `ap` peekByteOff p (k * $(elemSize)) |]) [|return $(conE name')|] [0..length ctors-1]+  --  |]++  -- This exposes another GHC bug:+  -- 3) We can't capture Storable in a type quotation since it's a class name.+  --storableInst <- instanceD (cxt []) [t|Storable $(conT name')|] ...++  -- Work around instanceD's nasty interface+  let fixDecs :: Q [Dec] -> Q [DecQ]+      fixDecs decs = (fmap.fmap) return decs++  -- Eek, can't substitute this below: TH lifting is not referentially transparent+  let numCtors = length ctors++  storableInst <- instanceD (cxt []) (appT (conT ''Storable) (conT name')) =<<+    fixDecs [d|+      sizeOf _ = numCtors * $(elemSize)+      alignment _ = alignment (undefined :: $(elemType))+      peek p = $(foldl (\e k -> [| $e `ap` peekByteOff p (k * $(elemSize)) |]) [|return $(conE name')|] [0..length ctors-1])+      poke p v = sequence_ $(listE $ map (\(n,c) -> [| pokeByteOff p (n * $(elemSize)) ($(varE (mkName c)) v) |]) $ zip [0::Int ..] ctors)+      |]++  return [typeDecl, storableInst]
+ System/Linux/Ptrace/Syscall.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving #-}++-- | Sadly, only the OS thread which performed the ptrace_attach is allowed+-- to mess with the traced process. This means that users of this module will+-- need to forkOS or runInBoundThread in order to get reliable behaviour.++module System.Linux.Ptrace.Syscall (+  RemotePtr(),+  castRemotePtr,++  ptrace_traceme,+  ptrace_attach,+  ptrace_peektext, ptrace_peekdata, ptrace_peekuser,+  ptrace_poketext, ptrace_pokedata, ptrace_pokeuser,+  ptrace_cont, ptrace_syscall, ptrace_singlestep, ptrace_detach,+  ptrace_kill,+  --ptrace_getregs,+  --ptrace_setregs,+  --ptrace_getfpregs,+  --ptrace_setfpregs,+  ptrace_setoptions,+  ptrace_geteventmsg,+  --ptrace_getsiginfo,+  --ptrace_setsiginfo+) where++import Foreign+import Foreign.C+import Data.Bits+import Data.List (foldl')+import Data.Maybe+import System.Linux.Ptrace.Types+import System.Posix.Signals (Signal, nullSignal)+import System.Posix.Types (CPid)+import System.Process++newtype RemotePtr a = RemotePtr WordPtr deriving (Eq, Ord, Show, Num, Bits, Storable, Enum, Real, Integral)+castRemotePtr (RemotePtr a) = RemotePtr a+++type DataArg = WordPtr++foreign import ccall unsafe "ptrace" c_ptrace :: CInt -> CPid -> RemotePtr a -> DataArg -> IO CLong+++data Event = EventFork | EventVFork | EventClone | EventExec | EventVForkDone | EventExit deriving (Eq, Show)++event :: CLong -> Event+event 1 = EventFork+event 2 = EventVFork+event 3 = EventClone+event 4 = EventExec+event 5 = EventVForkDone+event 6 = EventExit+event n = error $ "ptrace: unexpected event code " ++ show n+++handlePtraceResult :: IO CLong -> IO ()+handlePtraceResult = throwErrnoIfMinus1_ "ptrace"++throwErrnoIfSet :: IO a -> IO a+throwErrnoIfSet act = do+  resetErrno+  r <- act+  e <- getErrno+  if e /= eOK then throwErrno "ptrace" else return r+++-- | Invoke the ptrace system call with various arguments.+ptrace4 n pid addr data_ = handlePtraceResult $ c_ptrace n pid addr data_+ptrace2 n pid = ptrace4 n pid 0 0+ptrace1 n = ptrace2 n 0++-- | Perform one of the PTRACE_PEEK* operations.+-- FIXME: better handling of EFAULT/EIO here (invalid read/write in other process's memory)+ptracePeek n pid addr = fromIntegral `fmap` (throwErrnoIfSet $ c_ptrace n pid addr 0)+-- | Perform one of the PTRACE_POKE* operations.+-- FIXME: better handling of EFAULT/EIO here (invalid read/write in other process's memory)+ptracePoke n pid addr val = alloca (\ptr -> poke ptr val >> ptrace4 n pid addr (ptrToWordPtr ptr))++-- | Perform one of the PTRACE_GET* operations.+ptraceGet n pid = alloca (\ptr -> ptrace4 n pid 0 (ptrToWordPtr ptr) >> peek ptr)+-- | Perform one of the PTRACE_SET* operations.+ptraceSet n pid val = ptracePoke n pid 0 val++-- | Resume a traced process.+ptraceResume n pid sig = ptrace4 n pid 0 (maybe 0 fromIntegral sig)+++-- | Attach the parent process to this process.+ptrace_traceme :: IO ()+ptrace_traceme = ptrace1 0++-- | Attach to a process.+-- FIXME: handle EPERM. return IO Bool?+ptrace_attach :: CPid -> IO ()+ptrace_attach = ptrace2 16++-- | Read a word from the traced process.+ptrace_peektext, ptrace_peekdata, ptrace_peekuser ::+  CPid -> RemotePtr Word -> IO Word+ptrace_peektext = ptracePeek 1+ptrace_peekdata = ptracePeek 2+ptrace_peekuser = ptracePeek 3++-- | Write a word to the traced process.+ptrace_poketext, ptrace_pokedata, ptrace_pokeuser ::+  CPid -> RemotePtr Word -> Word -> IO ()+ptrace_poketext = ptracePoke 4+ptrace_pokedata = ptracePoke 5+-- FIXME: EBUSY can come out when setting debug registers+ptrace_pokeuser = ptracePoke 6++-- | Continue the traced process, possibly with a signal.+ptrace_cont, ptrace_syscall, ptrace_singlestep, ptrace_detach ::+  CPid -> Maybe Signal -> IO ()+ptrace_cont = ptraceResume 7+ptrace_syscall = ptraceResume 24+ptrace_singlestep = ptraceResume 9+ptrace_detach = ptraceResume 17++-- | Send the traced process a SIGKILL.+ptrace_kill :: CPid -> IO ()+ptrace_kill pid = ptrace2 8 pid+++ptrace_getregs :: CPid -> IO Regs+ptrace_getregs pid | sizeOf (0 :: RemotePtr ()) == 4 = X86 `fmap` ptraceGet 12 pid+                   | sizeOf (0 :: RemotePtr ()) == 8 = X86_64 `fmap` ptraceGet 12 pid++-- Rely on caller to pass in right sort of registers.+ptrace_setregs :: CPid -> Regs -> IO ()+ptrace_setregs pid (X86 regs) = ptraceSet 13 pid regs+ptrace_setregs pid (X86_64 regs) = ptraceSet 13 pid regs+++ptrace_getfpregs :: CPid -> IO Cuser_fpregs_struct+ptrace_getfpregs pid = ptraceGet 14 pid+ptrace_setfpregs :: CPid -> Cuser_fpregs_struct -> IO ()+ptrace_setfpregs pid regs = ptraceSet 15 pid regs+++-- x86 only. On x86_64, getfpregs returns this stuff.+--ptrace_getfpxregs pid = ptraceGet 18 pid+--ptrace_setfpxregs pid regs = ptraceSet 19 pid regs+++data Option = TraceSysGood | TraceFork | TraceVFork | TraceClone | TraceExec | TraceVForkDone | TraceExit++optionCode :: Option -> DataArg+optionCode TraceSysGood = 0x01+optionCode TraceFork = 0x02+optionCode TraceVFork = 0x04+optionCode TraceClone = 0x08+optionCode TraceExec = 0x10+optionCode TraceVForkDone = 0x20+optionCode TraceExit = 0x40++optionsCode :: [Option] -> DataArg+optionsCode = foldl' (.|.) 0 . map optionCode++ptrace_setoptions :: CPid -> [Option] -> IO ()+ptrace_setoptions pid opts = ptrace4 0x4200 pid 0 (optionsCode opts)+++ptrace_geteventmsg :: CPid -> IO CULong+ptrace_geteventmsg pid = ptraceGet 0x4201 pid+++ptrace_getsiginfo :: CPid -> IO Csiginfo_t+ptrace_getsiginfo pid = ptraceGet 0x4202 pid+ptrace_setsiginfo :: CPid -> Csiginfo_t -> IO ()+ptrace_setsiginfo pid siginfo = ptraceSet 0x4203 pid siginfo++-- undocumented!++-- On x86 or for x86 processes on x86_64, get/set the TLS area.+-- ptrace_set_thread_area, ptrace_get_thread_area++-- On x86_64, get/set the TLS area+-- ptrace_arch_prctl "works just like arch_prctl except that the arguments are reversed"
+ System/Linux/Ptrace/Types.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module System.Linux.Ptrace.Types (Regs(..), X86Regs, X86_64Regs, Cuser_fpregs_struct, Csiginfo_t) where++-- Wrapping of various types.++import Data.Word+import Foreign.Storable+import System.Linux.Ptrace.X86Regs (X86Regs)+import System.Linux.Ptrace.X86_64Regs (X86_64Regs)++data Regs = X86 X86Regs | X86_64 X86_64Regs deriving Show++-- FIXME: see sys/user.h+newtype Cuser_fpregs_struct = CUFS Word deriving Storable++-- FIXME: see bits/siginfo.h+newtype Csiginfo_t = CSI Word deriving Storable
+ System/Linux/Ptrace/X86Regs.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}++module System.Linux.Ptrace.X86Regs where++import Data.Word+import Foreign.Storable+import System.Linux.Ptrace.GenStruct++-- see user_regs_struct in <sys/user.h>++x86_regs = ["ebx","ecx","edx","esi","edi","ebp","eax","xds","xes","xfs","xgs","orig_eax","eip","xcs","eflags","esp","xss"]+-- Can't reuse x86_regs here. Damn those stage restrictions.+genStruct "X86Regs" ["ebx","ecx","edx","esi","edi","ebp","eax","xds","xes","xfs","xgs","orig_eax","eip","xcs","eflags","esp","xss"] [t|Word32|]
+ System/Linux/Ptrace/X86_64Regs.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}++module System.Linux.Ptrace.X86_64Regs where++import Data.Word+import Foreign.Storable+import System.Linux.Ptrace.GenStruct++-- see user_regs_struct in <sys/user.h>++x86_64_regs = ["r15","r14","r13","r12","rbp","rbx","r11","r10","r9","r8","rax","rcx","rdx","rsi","rdi","orig_rax","rip","cs","eflags","rsp","ss","fs_base","gs_base","ds","es","fs","gs"]+-- Can't reuse x86_64_regs here. Damn those stage restrictions.+genStruct "X86_64Regs" ["r15","r14","r13","r12","rbp","rbx","r11","r10","r9","r8","rax","rcx","rdx","rsi","rdi","orig_rax","rip","cs","eflags","rsp","ss","fs_base","gs_base","ds","es","fs","gs"] [t|Word64|]
+ linux-ptrace.cabal view
@@ -0,0 +1,15 @@+name:                linux-ptrace+version:             0.1+synopsis:            Wrapping of Linux' ptrace(2).+description:         An interface for using ptrace to inspect the state of other processes, under Linux.+category:            System+license:             MIT+license-file:        LICENSE+author:              Richard Smith+maintainer:          zygoloid@metafoo.co.uk+build-type:          Simple+cabal-version:       >= 1.6+build-depends:       base == 4.*, posix-waitpid == 1.*, unix, bytestring == 0.9.*, process, template-haskell, mmap == 0.*+exposed-modules:     System.Linux.Ptrace, System.Linux.Ptrace.Syscall, System.Linux.Ptrace.Types, System.Linux.Ptrace.X86Regs, System.Linux.Ptrace.X86_64Regs+other-modules:       System.Linux.Ptrace.GenStruct+extensions:          TemplateHaskell, GeneralizedNewtypeDeriving, ForeignFunctionInterface, PatternGuards