{-# LANGUAGE PartialTypeSignatures , FlexibleContexts, StandaloneDeriving, DeriveGeneric, BangPatterns, Strict, ExistentialQuantification #-}

module Binary.Generic where

import Base
import Data.Symbol
import Data.X86.Instruction

import Conventions

import Disassembler.Disassembler

import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import qualified Data.ByteString.Lazy as BS

import Data.Word 
import Data.List (intercalate, find)
import qualified Data.Serialize as Cereal hiding (get,put)
import Debug.Trace

import GHC.Generics


-- |  Information on the sections in the binary
data SectionsInfo = SectionsInfo {
  SectionsInfo -> [(String, String, Word64, Word64, Word64)]
si_sections    :: ![(String,String,Word64,Word64,Word64)], -- ^ Sections: segment names, section names, addresses, sizes, and alignment.
  SectionsInfo -> Word64
si_min_address :: !Word64,
  SectionsInfo -> Word64
si_max_address :: !Word64
 }
 deriving (Int -> SectionsInfo -> ShowS
[SectionsInfo] -> ShowS
SectionsInfo -> String
(Int -> SectionsInfo -> ShowS)
-> (SectionsInfo -> String)
-> ([SectionsInfo] -> ShowS)
-> Show SectionsInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SectionsInfo -> ShowS
showsPrec :: Int -> SectionsInfo -> ShowS
$cshow :: SectionsInfo -> String
show :: SectionsInfo -> String
$cshowList :: [SectionsInfo] -> ShowS
showList :: [SectionsInfo] -> ShowS
Show,(forall x. SectionsInfo -> Rep SectionsInfo x)
-> (forall x. Rep SectionsInfo x -> SectionsInfo)
-> Generic SectionsInfo
forall x. Rep SectionsInfo x -> SectionsInfo
forall x. SectionsInfo -> Rep SectionsInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SectionsInfo -> Rep SectionsInfo x
from :: forall x. SectionsInfo -> Rep SectionsInfo x
$cto :: forall x. Rep SectionsInfo x -> SectionsInfo
to :: forall x. Rep SectionsInfo x -> SectionsInfo
Generic,SectionsInfo -> SectionsInfo -> Bool
(SectionsInfo -> SectionsInfo -> Bool)
-> (SectionsInfo -> SectionsInfo -> Bool) -> Eq SectionsInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SectionsInfo -> SectionsInfo -> Bool
== :: SectionsInfo -> SectionsInfo -> Bool
$c/= :: SectionsInfo -> SectionsInfo -> Bool
/= :: SectionsInfo -> SectionsInfo -> Bool
Eq)

instance Cereal.Serialize SectionsInfo



data SymbolTable = SymbolTable {
  SymbolTable -> IntMap Symbol
symboltable_symbols :: !(IM.IntMap Symbol),
  SymbolTable -> Set String
symboltable_exterbals :: !(S.Set String)
  }
  deriving ((forall x. SymbolTable -> Rep SymbolTable x)
-> (forall x. Rep SymbolTable x -> SymbolTable)
-> Generic SymbolTable
forall x. Rep SymbolTable x -> SymbolTable
forall x. SymbolTable -> Rep SymbolTable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SymbolTable -> Rep SymbolTable x
from :: forall x. SymbolTable -> Rep SymbolTable x
$cto :: forall x. Rep SymbolTable x -> SymbolTable
to :: forall x. Rep SymbolTable x -> SymbolTable
Generic,SymbolTable -> SymbolTable -> Bool
(SymbolTable -> SymbolTable -> Bool)
-> (SymbolTable -> SymbolTable -> Bool) -> Eq SymbolTable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SymbolTable -> SymbolTable -> Bool
== :: SymbolTable -> SymbolTable -> Bool
$c/= :: SymbolTable -> SymbolTable -> Bool
/= :: SymbolTable -> SymbolTable -> Bool
Eq)

instance Show SymbolTable where
  show :: SymbolTable -> String
show (SymbolTable IntMap Symbol
tbl Set String
globals) = (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Int, Symbol) -> String) -> [(Int, Symbol)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Symbol) -> String
forall {a}. Integral a => (a, Symbol) -> String
show_entry ([(Int, Symbol)] -> [String]) -> [(Int, Symbol)] -> [String]
forall a b. (a -> b) -> a -> b
$ IntMap Symbol -> [(Int, Symbol)]
forall a. IntMap a -> [(Int, a)]
IM.assocs IntMap Symbol
tbl) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
show_global ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Set String -> [String]
forall a. Set a -> [a]
S.toList Set String
globals)
   where
    show_entry :: (a, Symbol) -> String
show_entry (a
a0,PointerToLabel String
f Bool
b)           = a -> String
forall {a}. Integral a => a -> String
showHex a
a0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> ShowS
show_in_ex Bool
b String
"label"
    show_entry (a
a0,PointerToObject String
l Bool
b)          = a -> String
forall {a}. Integral a => a -> String
showHex a
a0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> ShowS
show_in_ex Bool
b String
"object"
    show_entry (a
a0,AddressOfObject String
l Bool
b)          = a -> String
forall {a}. Integral a => a -> String
showHex a
a0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" === " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> ShowS
show_in_ex Bool
b String
"object"
    show_entry (a
a0,AddressOfLabel String
f Bool
b)           = a -> String
forall {a}. Integral a => a -> String
showHex a
a0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" === " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> ShowS
show_in_ex Bool
b String
"label"
    show_entry (a
a0,Relocated_ResolvedObject String
l Word64
a) = a -> String
forall {a}. Integral a => a -> String
showHex a
a0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") --> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (external object, but internally resolved)"

    show_global :: ShowS
show_global String
f = String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (global)"

    show_in_ex :: Bool -> ShowS
show_in_ex Bool
True  String
ty = String
" (external " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")" 
    show_in_ex Bool
False String
ty = String
" (internal " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ty String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")" 

instance Cereal.Serialize SymbolTable


data Relocation = 
  Relocation Word64 Word64 -- ^ 8: At address a0, address a1 has been written, i.e., qword ptr[a0] == a1
  deriving ((forall x. Relocation -> Rep Relocation x)
-> (forall x. Rep Relocation x -> Relocation) -> Generic Relocation
forall x. Rep Relocation x -> Relocation
forall x. Relocation -> Rep Relocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Relocation -> Rep Relocation x
from :: forall x. Relocation -> Rep Relocation x
$cto :: forall x. Rep Relocation x -> Relocation
to :: forall x. Rep Relocation x -> Relocation
Generic,Relocation -> Relocation -> Bool
(Relocation -> Relocation -> Bool)
-> (Relocation -> Relocation -> Bool) -> Eq Relocation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Relocation -> Relocation -> Bool
== :: Relocation -> Relocation -> Bool
$c/= :: Relocation -> Relocation -> Bool
/= :: Relocation -> Relocation -> Bool
Eq,Eq Relocation
Eq Relocation =>
(Relocation -> Relocation -> Ordering)
-> (Relocation -> Relocation -> Bool)
-> (Relocation -> Relocation -> Bool)
-> (Relocation -> Relocation -> Bool)
-> (Relocation -> Relocation -> Bool)
-> (Relocation -> Relocation -> Relocation)
-> (Relocation -> Relocation -> Relocation)
-> Ord Relocation
Relocation -> Relocation -> Bool
Relocation -> Relocation -> Ordering
Relocation -> Relocation -> Relocation
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Relocation -> Relocation -> Ordering
compare :: Relocation -> Relocation -> Ordering
$c< :: Relocation -> Relocation -> Bool
< :: Relocation -> Relocation -> Bool
$c<= :: Relocation -> Relocation -> Bool
<= :: Relocation -> Relocation -> Bool
$c> :: Relocation -> Relocation -> Bool
> :: Relocation -> Relocation -> Bool
$c>= :: Relocation -> Relocation -> Bool
>= :: Relocation -> Relocation -> Bool
$cmax :: Relocation -> Relocation -> Relocation
max :: Relocation -> Relocation -> Relocation
$cmin :: Relocation -> Relocation -> Relocation
min :: Relocation -> Relocation -> Relocation
Ord)

instance Show Relocation where
  show :: Relocation -> String
show (Relocation Word64
a0 Word64
a1)  = Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
a0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall {a}. Integral a => a -> String
showHex Word64
a1

instance Cereal.Serialize Relocation


class BinaryClass a where
  binary_read_bytestring :: a -> Word64 -> Int -> Maybe BS.ByteString
  binary_read_ro_data :: a -> Word64 -> Int -> Maybe [Word8]
  binary_read_data :: a -> Word64 -> Int -> Maybe [Word8]
  binary_get_sections_info :: a -> SectionsInfo
  binary_get_symbols :: a -> SymbolTable
  binary_get_relocations :: a -> S.Set Relocation
  binary_pp :: a -> String
  binary_entry :: a -> Word64
  binary_text_section_size :: a -> Int
  binary_dir_name :: a -> String
  binary_file_name :: a -> String


data Binary = forall b . BinaryClass b => Binary b


instance BinaryClass Binary where
  binary_read_bytestring :: Binary -> Word64 -> Int -> Maybe ByteString
binary_read_bytestring (Binary b
b) = b -> Word64 -> Int -> Maybe ByteString
forall a. BinaryClass a => a -> Word64 -> Int -> Maybe ByteString
binary_read_bytestring b
b
  binary_read_ro_data :: Binary -> Word64 -> Int -> Maybe [Word8]
binary_read_ro_data (Binary b
b) = b -> Word64 -> Int -> Maybe [Word8]
forall a. BinaryClass a => a -> Word64 -> Int -> Maybe [Word8]
binary_read_ro_data b
b
  binary_read_data :: Binary -> Word64 -> Int -> Maybe [Word8]
binary_read_data (Binary b
b) = b -> Word64 -> Int -> Maybe [Word8]
forall a. BinaryClass a => a -> Word64 -> Int -> Maybe [Word8]
binary_read_data b
b
  binary_get_sections_info :: Binary -> SectionsInfo
binary_get_sections_info (Binary b
b) = b -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info b
b
  binary_get_symbols :: Binary -> SymbolTable
binary_get_symbols (Binary b
b) = b -> SymbolTable
forall a. BinaryClass a => a -> SymbolTable
binary_get_symbols b
b
  binary_get_relocations :: Binary -> Set Relocation
binary_get_relocations (Binary b
b) = b -> Set Relocation
forall a. BinaryClass a => a -> Set Relocation
binary_get_relocations b
b
  binary_pp :: Binary -> String
binary_pp (Binary b
b) = b -> String
forall a. BinaryClass a => a -> String
binary_pp b
b
  binary_entry :: Binary -> Word64
binary_entry (Binary b
b) = b -> Word64
forall a. BinaryClass a => a -> Word64
binary_entry b
b
  binary_text_section_size :: Binary -> Int
binary_text_section_size (Binary b
b) = b -> Int
forall a. BinaryClass a => a -> Int
binary_text_section_size b
b
  binary_dir_name :: Binary -> String
binary_dir_name (Binary b
b) = b -> String
forall a. BinaryClass a => a -> String
binary_dir_name b
b
  binary_file_name :: Binary -> String
binary_file_name (Binary b
b) = b -> String
forall a. BinaryClass a => a -> String
binary_file_name b
b

binary_get_symbol_table :: a -> IntMap Symbol
binary_get_symbol_table a
bin =
  case a -> SymbolTable
forall a. BinaryClass a => a -> SymbolTable
binary_get_symbols a
bin of
    (SymbolTable IntMap Symbol
tbl Set String
globals) -> IntMap Symbol
tbl


binary_get_global_symbols :: a -> Set String
binary_get_global_symbols a
bin =
  case a -> SymbolTable
forall a. BinaryClass a => a -> SymbolTable
binary_get_symbols a
bin of
    (SymbolTable IntMap Symbol
tbl Set String
globals) -> Set String
globals

symbol_to_name :: Symbol -> String
symbol_to_name (PointerToLabel String
f Bool
b)           = String
f
symbol_to_name (PointerToObject String
l Bool
b)          = String
l
symbol_to_name (AddressOfObject String
l Bool
b)          = String
l
symbol_to_name (AddressOfLabel String
f Bool
b)           = String
f
symbol_to_name (Relocated_ResolvedObject String
l Word64
a) = String
l



-- | Is the immediate roughly in range to be an address?
is_roughly_an_address ::
  BinaryClass bin => 
     bin     -- ^ The binary
  -> Word64  -- ^ An address
  -> Bool
is_roughly_an_address :: forall bin. BinaryClass bin => bin -> Word64 -> Bool
is_roughly_an_address bin
bin Word64
a = 
  let !si :: SectionsInfo
si = bin -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info bin
bin in
    Word64
a Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= SectionsInfo -> Word64
si_min_address SectionsInfo
si Bool -> Bool -> Bool
&& Word64
a Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= SectionsInfo -> Word64
si_max_address SectionsInfo
si

-- | Find a section for an address (see @`SectionsInfo`@)
find_section_for_address ::
  BinaryClass bin => 
     bin     -- ^ The binary
  -> Word64 -- ^ An address
  -> Maybe (String, String, Word64, Word64,Word64)
find_section_for_address :: forall bin.
BinaryClass bin =>
bin -> Word64 -> Maybe (String, String, Word64, Word64, Word64)
find_section_for_address bin
bin Word64
a =
  if bin -> Word64 -> Bool
forall bin. BinaryClass bin => bin -> Word64 -> Bool
is_roughly_an_address bin
bin Word64
a then
    ((String, String, Word64, Word64, Word64) -> Bool)
-> [(String, String, Word64, Word64, Word64)]
-> Maybe (String, String, Word64, Word64, Word64)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word64 -> (String, String, Word64, Word64, Word64) -> Bool
forall {a} {a} {b} {e}.
(Ord a, Num a) =>
a -> (a, b, a, a, e) -> Bool
address_in_section Word64
a) (SectionsInfo -> [(String, String, Word64, Word64, Word64)]
si_sections (SectionsInfo -> [(String, String, Word64, Word64, Word64)])
-> SectionsInfo -> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ bin -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info bin
bin)
  else
    Maybe (String, String, Word64, Word64, Word64)
forall a. Maybe a
Nothing
 where
  address_in_section :: a -> (a, b, a, a, e) -> Bool
address_in_section a
a (a
_,b
_,a
a0,a
si,e
_) = a
a0 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
a Bool -> Bool -> Bool
&& a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
a0 a -> a -> a
forall a. Num a => a -> a -> a
+ a
si



-- | Reading from a read-only data section.
--
-- Reads maximally up to 8 bytes. Returns @Nothing@ if the given address is out-of-range.
read_from_ro_datasection ::
  BinaryClass bin => 
     bin           -- ^ The binary
  -> Word64        -- ^ An address
  -> Int           -- ^ Size, i.e., the number of bytes to read
  -> Maybe Word64
read_from_ro_datasection :: forall bin. BinaryClass bin => bin -> Word64 -> Int -> Maybe Word64
read_from_ro_datasection bin
bin Word64
a Int
si = [Word8] -> Word64
bytes_to_word ([Word8] -> Word64) -> Maybe [Word8] -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> bin -> Word64 -> Int -> Maybe [Word8]
forall a. BinaryClass a => a -> Word64 -> Int -> Maybe [Word8]
binary_read_ro_data bin
bin Word64
a Int
si





-- | Find a section ending at address (see @`SectionsInfo`@)
find_section_ending_at ::
  BinaryClass bin => 
     bin           -- ^ The binary
   -> Word64       -- ^ An address
   -> Maybe (String, String, Word64, Word64, Word64)
find_section_ending_at :: forall bin.
BinaryClass bin =>
bin -> Word64 -> Maybe (String, String, Word64, Word64, Word64)
find_section_ending_at bin
bin Word64
a = ((String, String, Word64, Word64, Word64) -> Bool)
-> [(String, String, Word64, Word64, Word64)]
-> Maybe (String, String, Word64, Word64, Word64)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Word64 -> (String, String, Word64, Word64, Word64) -> Bool
forall {a} {a} {b} {e}.
(Eq a, Num a) =>
a -> (a, b, a, a, e) -> Bool
address_ends_at_section Word64
a) (SectionsInfo -> [(String, String, Word64, Word64, Word64)]
si_sections (SectionsInfo -> [(String, String, Word64, Word64, Word64)])
-> SectionsInfo -> [(String, String, Word64, Word64, Word64)]
forall a b. (a -> b) -> a -> b
$ bin -> SectionsInfo
forall a. BinaryClass a => a -> SectionsInfo
binary_get_sections_info bin
bin)
 where
  address_ends_at_section :: a -> (a, b, a, a, e) -> Bool
address_ends_at_section a
a (a
_,b
_,a
a0,a
si,e
_) = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a0 a -> a -> a
forall a. Num a => a -> a -> a
+ a
si







-- TODO
-- | Fetching an instruction
-- Returns @Nothing@ if the given address is out-of-range.
fetch_instruction ::
  BinaryClass bin => 
     bin
  -> Word64  -- ^ An address
  -> Maybe Instruction
fetch_instruction :: forall bin. BinaryClass bin => bin -> Word64 -> Maybe Instruction
fetch_instruction bin
bin Word64
a =
  case bin -> Word64 -> Int -> Maybe ByteString
forall a. BinaryClass a => a -> Word64 -> Int -> Maybe ByteString
binary_read_bytestring bin
bin Word64
a Int
20 of
     Maybe ByteString
Nothing -> Maybe Instruction
forall a. Maybe a
Nothing
     Just ByteString
bytes -> Word64 -> ByteString -> Maybe Instruction
disassemble0 Word64
a ByteString
bytes {--
  --case IM.lookup (fromIntegral a) instructions of
  --  Just i -> return $ Just i -- memoized
  --  Nothing -> case binary_read_bytestring bin a 20 of -- maximum instruction length == 15
 --                Nothing -> Nothing
   --              Just bytes -> (disassemble0 a bytes) -- >>= memoize_instr 
 where
  memoize_instr Nothing = return Nothing
  memoize_instr (Just instr) = do
    modifyIORef' ioref (IM.insert (fromIntegral a) instr)
    return $ Just instr--}





-- | Returns true iff an instruction can be fetched from the address.
address_has_instruction ::
  BinaryClass bin => 
     bin
  -> Word64  -- ^ An address
  -> Bool
address_has_instruction :: forall bin. BinaryClass bin => bin -> Word64 -> Bool
address_has_instruction bin
bin Word64
a = do
  case bin -> Word64 -> Maybe (String, String, Word64, Word64, Word64)
forall bin.
BinaryClass bin =>
bin -> Word64 -> Maybe (String, String, Word64, Word64, Word64)
find_section_for_address bin
bin Word64
a of
    Maybe (String, String, Word64, Word64, Word64)
Nothing                      -> Bool
False
    Just (String
segment,String
section,Word64
_,Word64
_,Word64
_) -> 
      if (String
segment,String
section) (String, String) -> [(String, String)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(String, String)]
sections_with_instructions then do
        case bin -> Word64 -> Maybe Instruction
forall bin. BinaryClass bin => bin -> Word64 -> Maybe Instruction
fetch_instruction bin
bin Word64
a of
          Maybe Instruction
Nothing -> Bool
False
          Maybe Instruction
_       -> Bool
True
      else
        Bool
False