Haskell bindings update (#767)

* haskell: Properly handle invalid memory access

* haskell: source cleanup

* haskell: added support for batch reg read/write

bindings/haskell/.gitignore

@@ -21,3 +21,4 @@ SampleMips
 SampleSparc
 SampleX86
 Shellcode
+SampleBatchReg

bindings/haskell/samples/SampleBatchReg.hs

@@ -0,0 +1,99 @@
+import Unicorn
+import Unicorn.Hook
+import qualified Unicorn.CPU.X86 as X86
+
+import Control.Monad.Trans.Class (lift)
+import qualified Data.ByteString as BS
+import Data.Int
+import Data.List (intercalate)
+import Data.Word
+import qualified Numeric as N (showHex)
+import System.IO (hPutStrLn, stderr)
+
+syscallABI :: [X86.Register]
+syscallABI = [ X86.Rax
+             , X86.Rdi
+             , X86.Rsi
+             , X86.Rdx
+             , X86.R10
+             , X86.R8
+             , X86.R9
+             ]
+
+vals :: [Int64]
+vals = [ 200
+       , 10
+       , 11
+       , 12
+       , 13
+       , 14
+       , 15
+       ]
+
+ucPerror :: Error
+         -> IO ()
+ucPerror err =
+    hPutStrLn stderr $ "Error " ++ ": " ++ strerror err
+
+base :: Word64
+base = 0x10000
+
+-- mov rax, 100; mov rdi, 1; mov rsi, 2; mov rdx, 3; mov r10, 4; mov r8, 5; mov r9, 6; syscall
+code :: BS.ByteString
+code = BS.pack [ 0x48, 0xc7, 0xc0, 0x64, 0x00, 0x00, 0x00, 0x48, 0xc7, 0xc7
+               , 0x01, 0x00, 0x00, 0x00, 0x48, 0xc7, 0xc6, 0x02, 0x00, 0x00
+               , 0x00, 0x48, 0xc7, 0xc2, 0x03, 0x00, 0x00, 0x00, 0x49, 0xc7
+               , 0xc2, 0x04, 0x00, 0x00, 0x00, 0x49, 0xc7, 0xc0, 0x05, 0x00
+               , 0x00, 0x00, 0x49, 0xc7, 0xc1, 0x06, 0x00, 0x00, 0x00, 0x0f
+               , 0x05
+               ]
+
+-- Pretty-print integral as hex
+showHex :: (Integral a, Show a) => a -> String
+showHex i =
+    N.showHex (fromIntegral i :: Word64) ""
+
+-- Write a string (with a newline character) to standard output in the emulator
+emuPutStrLn :: String -> Emulator ()
+emuPutStrLn =
+    lift . putStrLn
+
+hookSyscall :: SyscallHook ()
+hookSyscall uc _ = do
+    runEmulator $ do
+        readVals <- regReadBatch uc syscallABI
+        emuPutStrLn $ "syscall: {"
+                      ++ intercalate ", " (map show readVals)
+                      ++ "}"
+    return ()
+
+hookCode :: CodeHook ()
+hookCode _ addr size _ = do
+    putStrLn $ "HOOK_CODE: 0x" ++ showHex addr ++ ", 0x" ++
+               maybe "0" showHex size
+
+main :: IO ()
+main = do
+    result <- runEmulator $ do
+        uc <- open ArchX86 [Mode64]
+
+        -- regWriteBatch
+        emuPutStrLn "regWriteBatch {200, 10, 11, 12, 13, 14, 15}"
+        regWriteBatch uc syscallABI vals
+
+        readVals <- regReadBatch uc syscallABI
+    
+        emuPutStrLn $ "regReadBatch = {"
+                      ++ intercalate ", " (map show readVals)
+                      ++ "}"
+
+        -- syscall
+        emuPutStrLn "running syscall shellcode"
+        syscallHookAdd uc hookSyscall () 1 0
+        memMap uc base (0x1000) [ProtAll]
+        memWrite uc base code
+        let codeLen = fromIntegral $ BS.length code
+        start uc base (base + codeLen) Nothing Nothing
+    case result of
+        Right _  -> return ()
+        Left err -> ucPerror err

bindings/haskell/samples/SampleX86.hs

@@ -98,7 +98,7 @@ hookCode :: CodeHook ()
 hookCode uc addr size _ = do
     runEmulator $ do
         emuPutStrLn $ ">>> Tracing instruction at 0x" ++ showHex addr ++
-                      ", instruction size = 0x" ++ (maybe "0" showHex size)
+                      ", instruction size = 0x" ++ maybe "0" showHex size
 
         eflags <- regRead uc X86.Eflags
         emuPutStrLn $ ">>> --- EFLAGS is 0x" ++ showHex eflags

bindings/haskell/src/Unicorn.hs

@@ -25,6 +25,8 @@ module Unicorn
       -- * Register operations
     , regWrite
     , regRead
+    , regWriteBatch
+    , regReadBatch
 
       -- * Memory operations
     , MemoryPermission(..)
@@ -140,13 +142,11 @@ stop uc = do
 -- | Write to register.
 regWrite :: Reg r
          => Engine      -- ^ 'Unicorn' engine handle
-         -> r           -- ^ Register ID to write to
+         -> r           -- ^ Register to write to
          -> Int64       -- ^ Value to write to register
          -> Emulator () -- ^ An 'Error' on failure
-regWrite uc regId value = do
+regWrite uc reg value = do
-    err <- lift . alloca $ \ptr -> do
+    err <- lift $ ucRegWrite uc reg value
-        poke ptr value
-        ucRegWrite uc regId ptr
     if err == ErrOk then
         right ()
     else
@@ -155,16 +155,49 @@ regWrite uc regId value = do
 -- | Read register value.
 regRead :: Reg r
         => Engine           -- ^ 'Unicorn' engine handle
-        -> r                -- ^ Register ID to read from
+        -> r                -- ^ Register to read from
         -> Emulator Int64   -- ^ The value read from the register on success,
                             -- or an 'Error' on failure
-regRead uc regId = do
+regRead uc reg = do
-    (err, val) <- lift $ ucRegRead uc regId
+    (err, val) <- lift $ ucRegRead uc reg
     if err == ErrOk then
         right val
     else
         left err
 
+-- | Write multiple register values.
+regWriteBatch :: Reg r
+              => Engine         -- ^ 'Unicorn' engine handle
+              -> [r]            -- ^ List of registers to write to
+              -> [Int64]        -- ^ List of values to write to the registers
+              -> Emulator ()    -- ^ An 'Error' on failure
+regWriteBatch uc regs vals = do
+    err <- lift $ ucRegWriteBatch uc regs vals (length regs)
+    if err == ErrOk then
+        right ()
+    else
+        left err
+
+-- | Read multiple register values.
+regReadBatch ::  Reg r
+             => Engine              -- ^ 'Unicorn' engine handle
+             -> [r]                 -- ^ List of registers to read from
+             -> Emulator [Int64]    -- ^ A list of register values on success,
+                                    -- or an 'Error' on failure
+regReadBatch uc regs = do
+    -- Allocate an array of the given size
+    let size = length regs
+    result <- lift . allocaArray size $ \array -> do
+        err <- ucRegReadBatch uc regs array size
+        if err == ErrOk then
+            -- If ucRegReadBatch completed successfully, pack the contents of
+            -- the array into a list and return it
+            liftM Right (peekArray size array)
+        else
+            -- Otherwise return the error
+            return $ Left err
+    hoistEither result
+
 -------------------------------------------------------------------------------
 -- Memory operations
 -------------------------------------------------------------------------------
@@ -190,12 +223,12 @@ memRead :: Engine                       -- ^ 'Unicorn' engine handle
                                         -- an 'Error' on failure
 memRead uc address size = do
     -- Allocate an array of the given size
-    result <- lift . allocaArray size $ \ptr -> do
+    result <- lift . allocaArray size $ \array -> do
-        err <- ucMemRead uc address ptr size
+        err <- ucMemRead uc address array size
         if err == ErrOk then
             -- If ucMemRead completed successfully, pack the contents of the
             -- array into a ByteString and return it
-            liftM (Right . pack) (peekArray size ptr)
+            liftM (Right . pack) (peekArray size array)
         else
             -- Otherwise return the error
             return $ Left err

bindings/haskell/src/Unicorn/Internal/Hook.chs

@@ -314,7 +314,7 @@ marshalMemoryHook memoryHook =
             maybeValue = case memAccess of
                              MemRead  -> Nothing
                              MemWrite -> Just $ fromIntegral value
-                             _        -> undefined  -- XX Handle this?
+                             _        -> error "Invalid memory access"
         memoryHook uc memAccess address (fromIntegral size) maybeValue userData
 
 -- | Callback function for hooking memory reads.
@@ -390,7 +390,7 @@ marshalMemoryEventHook eventMemoryHook =
                              MemReadProt      -> Nothing
                              MemWriteUnmapped -> Just $ fromIntegral value
                              MemWriteProt     -> Just $ fromIntegral value
-                             _                -> undefined  -- XX Handle this?
+                             _                -> error "Invalid memory access"
         res <- eventMemoryHook uc memAccess address (fromIntegral size)
                                maybeValue userData
         return $ boolToInt res

bindings/haskell/src/Unicorn/Internal/Unicorn.chs

@@ -28,6 +28,8 @@ module Unicorn.Internal.Unicorn
     , ucEmuStop
     , ucRegWrite
     , ucRegRead
+    , ucRegWriteBatch
+    , ucRegReadBatch
     , ucMemWrite
     , ucMemRead
     , ucMemMap
@@ -154,7 +156,8 @@ mkContext ptr =
    , `Word64'
    , `Word64'
    , `Int'
-   , `Int'} -> `Error'
+   , `Int'
+   } -> `Error'
 #}
 
 {# fun uc_emu_stop as ^
@@ -166,19 +169,37 @@ mkContext ptr =
 -- Register operations
 -------------------------------------------------------------------------------
 
-{# fun uc_reg_write as ^
+{# fun uc_reg_write_wrapper as ucRegWrite
    `Reg r' =>
    { `Engine'
    , enumToNum `r'
-   , castPtr `Ptr Int64'
+   , withIntegral* `Int64'
    } -> `Error'
 #}
 
-{# fun uc_reg_read as ^
+{# fun uc_reg_read_wrapper as ucRegRead
    `Reg r' =>
    { `Engine'
    , enumToNum `r'
-   , allocaInt64ToVoid- `Int64' castPtrAndPeek*
+   , alloca- `Int64' castPtrAndPeek*
+   } -> `Error'
+#}
+
+{# fun uc_reg_write_batch_wrapper as ucRegWriteBatch
+   `Reg r' =>
+   { `Engine'
+   , withEnums* `[r]'
+   , integralListToArray* `[Int64]'
+   , `Int'
+   } -> `Error'
+#}
+
+{# fun uc_reg_read_batch_wrapper as ucRegReadBatch
+   `Reg r' =>
+   { `Engine'
+   , withEnums* `[r]'
+   , castPtr `Ptr Int64'
+   , `Int'
    } -> `Error'
 #}
 
@@ -197,7 +218,8 @@ mkContext ptr =
    { `Engine'
    , `Word64'
    , castPtr `Ptr Word8'
-   , `Int'} -> `Error'
+   , `Int'
+   } -> `Error'
 #}
 
 {# fun uc_mem_map as ^
@@ -205,7 +227,8 @@ mkContext ptr =
    , `Word64'
    , `Int'
    , combineEnums `[MemoryPermission]'
-   } -> `Error' #}
+   } -> `Error'
+#}
 
 {# fun uc_mem_unmap as ^
    { `Engine'
@@ -296,13 +319,32 @@ expandMemPerms perms =
         checkRWE _ [] =
             []
 
-allocaInt64ToVoid :: (Ptr () -> IO b)
+withIntegral :: (Integral a, Num b, Storable b)
-                  -> IO b
+             => a
-allocaInt64ToVoid f =
+             -> (Ptr b -> IO c)
-    alloca $ \(ptr :: Ptr Int64) -> poke ptr 0 >> f (castPtr ptr)
+             -> IO c
+withIntegral =
+    with . fromIntegral
 
-withByteStringLen :: ByteString
+withByteStringLen :: Integral a
-                  -> ((Ptr (), CULong) -> IO a)
+                  => ByteString
-                  -> IO a
+                  -> ((Ptr (), a) -> IO b)
+                  -> IO b
 withByteStringLen bs f =
     useAsCStringLen bs $ \(ptr, len) -> f (castPtr ptr, fromIntegral len)
+
+withEnums :: Enum a
+          => [a]
+          -> (Ptr b -> IO c)
+          -> IO c
+withEnums l f =
+    let ints :: [CInt] = map enumToNum l in
+    withArray ints $ \ptr -> f (castPtr ptr)
+
+integralListToArray :: (Integral a, Storable b, Num b)
+                    => [a]
+                    -> (Ptr b -> IO c)
+                    -> IO c
+integralListToArray l f =
+    let l' = map fromIntegral l in
+    withArray l' $ \array -> f array

bindings/haskell/src/cbits/unicorn_wrapper.c

@@ -1,3 +1,5 @@
+#include <stdlib.h>
+
 #include "unicorn_wrapper.h"
 
 void uc_close_wrapper(uc_engine *uc) {
@@ -7,6 +9,42 @@ void uc_close_wrapper(uc_engine *uc) {
 void uc_close_dummy(uc_engine *uc) {
 }
 
+uc_err uc_reg_write_wrapper(uc_engine *uc, int regid, const int64_t *value) {
+    return uc_reg_write(uc, regid, (const void*) value);
+}
+
+uc_err uc_reg_read_wrapper(uc_engine *uc, int regid, int64_t *value) {
+    return uc_reg_read(uc, regid, (void*) value);
+}
+
+uc_err uc_reg_write_batch_wrapper(uc_engine *uc, int *regs, int64_t *vals, int count) {
+    void **valsPtr = malloc(sizeof(void*) * count);
+    int i;
+
+    for (i = 0; i < count; ++i) {
+        valsPtr[i] = (void*) &vals[i];
+    }
+
+    uc_err ret = uc_reg_write_batch(uc, regs, (void *const*) valsPtr, count);
+    free(valsPtr);
+
+    return ret;
+}
+
+uc_err uc_reg_read_batch_wrapper(uc_engine *uc, int *regs, int64_t *vals, int count) {
+    void **valsPtr = malloc(sizeof(void*) * count);
+    int i;
+
+    for (i = 0; i < count; ++i) {
+        valsPtr[i] = (void*) &vals[i];
+    }
+
+    uc_err ret = uc_reg_read_batch(uc, regs, valsPtr, count);
+    free(valsPtr);
+
+    return ret;
+}
+
 void uc_free_wrapper(void *mem) {
     uc_free(mem);
 }

bindings/haskell/src/include/unicorn_wrapper.h

@@ -1,6 +1,7 @@
 #ifndef UNICORN_WRAPPER_H
 #define UNICORN_WRAPPER_H
 
+#include <stdint.h>
 #include <unicorn/unicorn.h>
 
 /*
@@ -13,6 +14,14 @@ void uc_close_wrapper(uc_engine *uc);
  */
 void uc_close_dummy(uc_engine *uc);
 
+/*
+ * Wrappers for register read/write functions that accept int64_t pointers.
+ */
+uc_err uc_reg_write_wrapper(uc_engine *uc, int regid, const int64_t *value);
+uc_err uc_reg_read_wrapper(uc_engine *uc, int regid, int64_t *value);
+uc_err uc_reg_write_batch_wrapper(uc_engine *uc, int *regs, int64_t *vals, int count);
+uc_err uc_reg_read_batch_wrapper(uc_engine *uc, int *regs, int64_t *vals, int count);
+
 /*
  * Wrap Unicorn's uc_free function and ignore the returned error code.
  */