mirrors/unicorn
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Haskell bindings: use ExceptT instead of deprecated EitherT (#1034)

Browse Source
This commit is contained in:
Brian McKenna 2018-10-26 02:54:35 +11:00 committed by Nguyen Anh Quynh
parent 400a0ab309
commit 873fffc505
4 changed files with 58 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
bindings/haskell/src/Unicorn.hs
View File

@ -53,9 +53,9 @@ module Unicorn
, version
) where
import Control.Monad (liftM)
import Control.Monad (join, liftM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Either (hoistEither, left, right, runEitherT)
import Control.Monad.Trans.Except (throwE, runExceptT)
import Data.ByteString (ByteString, pack)
import Foreign
import Prelude hiding (until)
@ -73,7 +73,7 @@ runEmulator :: Emulator a -- ^ The emulation code to execute
-> IO (Either Error a) -- ^ A result on success, or an 'Error' on
-- failure
runEmulator =
runEitherT
runExceptT
-- | Create a new instance of the Unicorn engine.
open :: Architecture -- ^ CPU architecture
@ -88,7 +88,7 @@ open arch mode = do
lift $ mkEngine ucPtr
else
-- Otherwise return the error
left err
throwE err
-- | Query internal status of the Unicorn engine.
query :: Engine -- ^ 'Unicorn' engine handle
@ -97,9 +97,9 @@ query :: Engine -- ^ 'Unicorn' engine handle
query uc queryType = do
(err, result) <- lift $ ucQuery uc queryType
if err == ErrOk then
right result
pure result
else
left err
throwE err
-- | Emulate machine code for a specific duration of time.
start :: Engine -- ^ 'Unicorn' engine handle
@ -117,9 +117,9 @@ start :: Engine -- ^ 'Unicorn' engine handle
start uc begin until timeout count = do
err <- lift $ ucEmuStart uc begin until (maybeZ timeout) (maybeZ count)
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
where maybeZ = maybe 0 id
-- | Stop emulation (which was started by 'start').
@ -131,9 +131,9 @@ stop :: Engine -- ^ 'Unicorn' engine handle
stop uc = do
err <- lift $ ucEmuStop uc
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-------------------------------------------------------------------------------
-- Register operations
@ -148,9 +148,9 @@ regWrite :: Reg r
regWrite uc reg value = do
err <- lift $ ucRegWrite uc reg value
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-- | Read register value.
regRead :: Reg r
@ -161,9 +161,9 @@ regRead :: Reg r
regRead uc reg = do
(err, val) <- lift $ ucRegRead uc reg
if err == ErrOk then
right val
pure val
else
left err
throwE err
-- | Write multiple register values.
regWriteBatch :: Reg r
@ -174,9 +174,9 @@ regWriteBatch :: Reg r
regWriteBatch uc regs vals = do
err <- lift $ ucRegWriteBatch uc regs vals (length regs)
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-- | Read multiple register values.
regReadBatch :: Reg r
@ -187,16 +187,15 @@ regReadBatch :: Reg r
regReadBatch uc regs = do
-- Allocate an array of the given size
let size = length regs
result <- lift . allocaArray size $ \array -> do
join . 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)
liftM pure (peekArray size array)
else
-- Otherwise return the error
return $ Left err
hoistEither result
return $ throwE err
-------------------------------------------------------------------------------
-- Memory operations
@ -210,9 +209,9 @@ memWrite :: Engine -- ^ 'Unicorn' engine handle
memWrite uc address bytes = do
err <- lift $ ucMemWrite uc address bytes
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-- | Read memory contents.
memRead :: Engine -- ^ 'Unicorn' engine handle
@ -223,16 +222,15 @@ 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 $ \array -> do
join . lift . allocaArray size $ \array -> do
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 array)
liftM (pure . pack) (peekArray size array)
else
-- Otherwise return the error
return $ Left err
hoistEither result
return $ throwE err
-- | Map a range of memory.
memMap :: Engine -- ^ 'Unicorn' engine handle
@ -248,9 +246,9 @@ memMap :: Engine -- ^ 'Unicorn' engine handle
memMap uc address size perms = do
err <- lift $ ucMemMap uc address size perms
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-- | Unmap a range of memory.
memUnmap :: Engine -- ^ 'Unicorn' engine handle
@ -264,9 +262,9 @@ memUnmap :: Engine -- ^ 'Unicorn' engine handle
memUnmap uc address size = do
err <- lift $ ucMemUnmap uc address size
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-- | Change permissions on a range of memory.
memProtect :: Engine -- ^ 'Unicorn' engine handle
@ -283,9 +281,9 @@ memProtect :: Engine -- ^ 'Unicorn' engine handle
memProtect uc address size perms = do
err <- lift $ ucMemProtect uc address size perms
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-- | Retrieve all memory regions mapped by 'memMap'.
memRegions :: Engine -- ^ 'Unicorn' engine handle
@ -294,9 +292,9 @@ memRegions uc = do
(err, regionPtr, count) <- lift $ ucMemRegions uc
if err == ErrOk then do
regions <- lift $ peekArray count regionPtr
right regions
pure regions
else
left err
throwE err
-------------------------------------------------------------------------------
-- Context operations
@ -314,7 +312,7 @@ contextAllocate uc = do
-- Return a CPU context if ucContextAlloc completed successfully
lift $ mkContext contextPtr
else
left err
throwE err
-- | Save a copy of the internal CPU context.
contextSave :: Engine -- ^ 'Unicorn' engine handle
@ -323,9 +321,9 @@ contextSave :: Engine -- ^ 'Unicorn' engine handle
contextSave uc context = do
err <- lift $ ucContextSave uc context
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-- | Restore the current CPU context from a saved copy.
contextRestore :: Engine -- ^ 'Unicorn' engine handle
@ -334,9 +332,9 @@ contextRestore :: Engine -- ^ 'Unicorn' engine handle
contextRestore uc context = do
err <- lift $ ucContextRestore uc context
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-------------------------------------------------------------------------------
-- Misc.

46
bindings/haskell/src/Unicorn/Hook.hs
View File

@ -39,7 +39,7 @@ module Unicorn.Hook
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Either (hoistEither, left, right)
import Control.Monad.Trans.Except (ExceptT (..), throwE)
import Foreign
import Unicorn.Internal.Core
@ -60,12 +60,11 @@ codeHookAdd :: Storable a
-> Word64 -- ^ End address
-> Emulator Hook -- ^ The hook handle on success, or an 'Error'
-- on failure
codeHookAdd uc callback userData begin end = do
result <- lift . alloca $ \userDataPtr -> do
codeHookAdd uc callback userData begin end =
ExceptT . alloca $ \userDataPtr -> do
poke userDataPtr userData
funPtr <- marshalCodeHook callback
getResult $ ucHookAdd uc HookCode funPtr userDataPtr begin end
hoistEither result
-- | Register a callback for an interrupt hook event.
interruptHookAdd :: Storable a
@ -77,12 +76,11 @@ interruptHookAdd :: Storable a
-> Word64 -- ^ End address
-> Emulator Hook -- ^ The hook handle on success, or 'Error'
-- on failure
interruptHookAdd uc callback userData begin end = do
result <- lift . alloca $ \userDataPtr -> do
interruptHookAdd uc callback userData begin end =
ExceptT . alloca $ \userDataPtr -> do
poke userDataPtr userData
funPtr <- marshalInterruptHook callback
getResult $ ucHookAdd uc HookIntr funPtr userDataPtr begin end
hoistEither result
-- | Register a callback for a block hook event.
blockHookAdd :: Storable a
@ -94,12 +92,11 @@ blockHookAdd :: Storable a
-> Word64 -- ^ End address
-> Emulator Hook -- ^ The hook handle on success, or an 'Error'
-- on failure
blockHookAdd uc callback userData begin end = do
result <- lift . alloca $ \userDataPtr -> do
blockHookAdd uc callback userData begin end =
ExceptT . alloca $ \userDataPtr -> do
poke userDataPtr userData
funPtr <- marshalBlockHook callback
getResult $ ucHookAdd uc HookBlock funPtr userDataPtr begin end
hoistEither result
-- | Register a callback for an IN instruction hook event (X86).
inHookAdd :: Storable a
@ -111,13 +108,12 @@ inHookAdd :: Storable a
-> Word64 -- ^ End address
-> Emulator Hook -- ^ The hook handle on success, or an 'Error' on
-- failure
inHookAdd uc callback userData begin end = do
result <- lift . alloca $ \userDataPtr -> do
inHookAdd uc callback userData begin end =
ExceptT . alloca $ \userDataPtr -> do
poke userDataPtr userData
funPtr <- marshalInHook callback
getResult $ ucInsnHookAdd uc HookInsn funPtr userDataPtr begin end
X86.In
hoistEither result
-- | Register a callback for an OUT instruction hook event (X86).
outHookAdd :: Storable a
@ -129,13 +125,12 @@ outHookAdd :: Storable a
-> Word64 -- ^ End address
-> Emulator Hook -- ^ The hook handle on success, or an 'Error' on
-- failure
outHookAdd uc callback userData begin end = do
result <- lift . alloca $ \userDataPtr -> do
outHookAdd uc callback userData begin end =
ExceptT . alloca $ \userDataPtr -> do
poke userDataPtr userData
funPtr <- marshalOutHook callback
getResult $ ucInsnHookAdd uc HookInsn funPtr userDataPtr begin end
X86.Out
hoistEither result
-- | Register a callback for a SYSCALL instruction hook event (X86).
syscallHookAdd :: Storable a
@ -147,13 +142,12 @@ syscallHookAdd :: Storable a
-> Word64 -- ^ End address
-> Emulator Hook -- ^ The hook handle on success, or an 'Error'
-- on failure
syscallHookAdd uc callback userData begin end = do
result <- lift . alloca $ \userDataPtr -> do
syscallHookAdd uc callback userData begin end =
ExceptT . alloca $ \userDataPtr -> do
poke userDataPtr userData
funPtr <- marshalSyscallHook callback
getResult $ ucInsnHookAdd uc HookInsn funPtr userDataPtr begin end
X86.Syscall
hoistEither result
-- | Register a callback for a valid memory access event.
memoryHookAdd :: Storable a
@ -167,12 +161,11 @@ memoryHookAdd :: Storable a
-> Word64 -- ^ End address
-> Emulator Hook -- ^ The hook handle on success, or an 'Error'
-- on failure
memoryHookAdd uc memHookType callback userData begin end = do
result <- lift . alloca $ \userDataPtr -> do
memoryHookAdd uc memHookType callback userData begin end =
ExceptT . alloca $ \userDataPtr -> do
poke userDataPtr userData
funPtr <- marshalMemoryHook callback
getResult $ ucHookAdd uc memHookType funPtr userDataPtr begin end
hoistEither result
-- | Register a callback for an invalid memory access event.
memoryEventHookAdd :: Storable a
@ -188,12 +181,11 @@ memoryEventHookAdd :: Storable a
-> Word64 -- ^ End address
-> Emulator Hook -- ^ The hook handle on success, or
-- an 'Error' on failure
memoryEventHookAdd uc memEventHookType callback userData begin end = do
result <- lift . alloca $ \userDataPtr -> do
memoryEventHookAdd uc memEventHookType callback userData begin end =
ExceptT . alloca $ \userDataPtr -> do
poke userDataPtr userData
funPtr <- marshalMemoryEventHook callback
getResult $ ucHookAdd uc memEventHookType funPtr userDataPtr begin end
hoistEither result
-- | Unregister (remove) a hook callback.
hookDel :: Engine -- ^ 'Unicorn' engine handle
@ -202,9 +194,9 @@ hookDel :: Engine -- ^ 'Unicorn' engine handle
hookDel uc hook = do
err <- lift $ ucHookDel uc hook
if err == ErrOk then
right ()
pure ()
else
left err
throwE err
-------------------------------------------------------------------------------
-- Helper functions

4
bindings/haskell/src/Unicorn/Internal/Core.chs
View File

@ -14,7 +14,7 @@ way cabal handles ordering of chs files.
module Unicorn.Internal.Core where
import Control.Monad
import Control.Monad.Trans.Either (EitherT)
import Control.Monad.Trans.Except (ExceptT)
import Foreign
{# context lib = "unicorn" #}
@ -48,7 +48,7 @@ mkEngine ptr =
-- | The emulator runs in the IO monad and allows for the handling of errors
-- "under the hood".
type Emulator a = EitherT Error IO a
type Emulator a = ExceptT Error IO a
-- | An architecture-dependent register.
class Enum a => Reg a

1
bindings/haskell/unicorn.cabal
View File

@ -33,7 +33,6 @@ library
build-depends: base >=4 && <5
, bytestring >= 0.9.1
, transformers < 0.6
, either >= 4.4
hs-source-dirs: src
c-sources: src/cbits/unicorn_wrapper.c
include-dirs: src/include