-- This file is part of Bindings-bfd.
--
-- Copyright (C) 2010,2011 Mick Nelso
--
-- Bindings-bfd is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Lesser General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Bindings-bfd is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Lesser General Public License for more details.

-- You should have received a copy of the GNU Lesser General Public License
-- along with Bindings-bfd.  If not, see <http://www.gnu.org/licenses/>.

-- | This is the top-level module containing operations that can be performed
-- on a Binary Format Descriptor (BFD).  A BFD is opened on the binary file
-- to be queried\/manipulated and serves an opaque pointer. 

module Bindings.Bfd (
   -- * Types
     Bfd (ptr)
   -- * Initialization
   , initialize
   -- * File Operations
   , targetsAndFormats
   , open
   , close
   , closeAllDone
   -- * Setting the Format
   , checkFormat
   -- * Attributes
   , getDisasm
   , getFilename
   , Bindings.Bfd.getFlags
   , getFormat
   , getHasMap
   , getIsCacheable
   , getIsTargetDefaulted
   , getIsThinArchive
   , getMachine
   , getMyArchive
   , getOctetsPerByte
   , getTarget
   -- ** For Object Files
   , getStartAddress
   , getSymbolCount
   -- ** Sections
   , getSectionCount
   , getSectionByName
   , getSectionByVma
   , getSections
   -- ** Symbol Tables
   , getSymbolTable
   , getDynamicSymbolTable
   -- ** Relocations
   , getDynamicRelocations
   -- *
   , demangle
   -- * Internal
   , Bfd'
   , Bindings.Bfd.mk
) where

import Control.Exception ( catch )
import Control.Monad     ( foldM )

import Data.Bits  ( (.&.), bit )
import Data.Word  ( Word )

import Foreign.C        ( CString, CInt, CUInt, newCString, peekCString
                        , withCString )
import Foreign.Marshal  ( free, mallocArray, peekArray, toBool )
import Foreign.Ptr      ( Ptr, nullPtr, wordPtrToPtr )
import Foreign.Storable ( Storable, alignment, peek, peekByteOff, poke, sizeOf )

import Prelude hiding ( catch )

import Bindings.Bfd.Disasm                        ( Disasm )
import Bindings.Bfd.Exception                     ( BfdException
                                                  , throwExceptionIfFalse
                                                  , throwExceptionIfNull )
import Bindings.Bfd.Flags         as BfdFlags     ( Flags ( HasReloc ) )
import Bindings.Bfd.Format                        ( Format ( Object ) )
import Bindings.Bfd.Misc                          ( Vma, Vma' )
import Bindings.Bfd.Relocation                    ( Relocation )
import Bindings.Bfd.Section       as Section      ( Section, SectionName
                                                  , getNext, getSize, getVma )
import Bindings.Bfd.SymbolTable   as SymbolTable  ( SymbolTable, mk, tablePtr )
import Bindings.Bfd.Target        as Target       ( Target, TargetName
                                                  , canonicalizeDynamicReloc
                                                  , canonicalizeDynamicSymtab
                                                  , canonicalizeSymtab
                                                  , getDynamicRelocUpperBound
                                                  , getDynamicSymtabUpperBound
                                                  , getName, getSymtabUpperBound
                                                  , listSupported )

#include <bfd.h>


-- PUBLIC ######################################################################

-- Types =======================================================================

-- | The opaque pointer to the Binary File Descriptor.
data Bfd = Bfd {
                       ptr       :: Ptr Bfd'
                     , filePath  :: CString
                     , target    :: CString
                     , mode      :: CString
           }
     deriving (Show)

-- Initialization ==============================================================

-- | Initialize the library.  You need to call 'initialize' once, before using 
-- any of the functions in this library.
initialize
   :: IO ()
initialize = c_bfd_init

-- File Operations =============================================================

-- | Returns a list of tuples representing the possible combinations of 
-- 'TargetName' and 'Format' that are valid for this file on this platform.
--
-- /Possible Exceptions:/  Same as 'open'.
targetsAndFormats 
   :: FilePath                   -- ^ file to query
   -> IO [(TargetName, Format)]
targetsAndFormats file =
   do
      ts <- Target.listSupported
      let
         perms = [ (t,f) | t <- ts, f <- enumFrom Object ]
      foldM g [] perms
   where
      g xs r@(t,f) =
         do
            bfd   <- open file (Just t) "r"
            xvec1 <- getTarget bfd
            tn1   <- Target.getName xvec1
            ok    <- catch (checkFormat bfd f) ((\_ -> return False) :: BfdException -> IO Bool)
            _     <- close bfd
            case ok of
               True  -> 
                  do
                     xvec2 <- getTarget bfd
                     tn2   <- Target.getName xvec2
                     if tn1 == tn2 
                         then return $ r : xs
                         else return xs
               False -> return xs

-- | Opens the file 'FilePath' with the given target 'TargetName' and open mode 
-- (as defined by the Unix fopen(3) function) and returns a 'Bfd' object on 
-- success. FIXME: and marks it cacheable. 
--
-- If the target is 'Nothing' then the environment variable /GNUTARGET/ is
-- checked for a target name; if this is NULL or not defined then it chooses the
-- the default target if set (see 'setDefault') and sets an internal flag in
-- the 'Bfd' object indicating that the target was defaulted (see 
-- 'isTargetDefaulted'), or if not set, the first entry in the target list for 
-- the platform.  Passing the string \"default\" as the 'TargetName' or setting 
-- the environment variable to \"default\" also causes the above behavior.
--
-- /Important:/ Before you use the returned 'Bfd' object from a file you have
-- opened, you must call 'checkFormat' to 1) validate that the supplied 
-- 'TargetName' is appropriate for the opened file, and 2) set the 'Format' for
-- the 'Bfd'.  So for most intents and purposes, opening a file is a two-step
-- process.
--
-- /Possible Exceptions:/  'NoMemory' (if any allocation fails), 'SystemCall' 
-- (if open failed), and 'InvalidTarget' (if supplied target is unknown).
open
   :: FilePath          -- ^ file to open
   -> Maybe TargetName  -- ^ target
   -> String            -- ^ open mode (\"r\", \"r+\", \"w\", \"w+\", \"a\", \"a+\")
   -> IO Bfd
open fp targ mode0 =
   do
      fp'   <- newCString fp
      targ' <- 
         case targ of
            Just t  -> newCString t
            Nothing -> return nullPtr
      mode' <- newCString mode0
      let
         cmd = c_bfd_fopen fp' targ' mode' (-1)
      bfd <- throwExceptionIfNull "open" fp (show targ) cmd
      return $ Bfd bfd fp' targ' mode'

-- | Close a 'Bfd' and if all went well, return 'True'.  If the 'Bfd' was open
-- for writing, then pending operations are completed and the file written out
-- and closed.  If the created file is executable, then chmod(3) is called to
-- mark it as such.
close
   :: Bfd
   -> IO Bool
close bfd = 
   do
      r <- c_bfd_close $ ptr bfd
      free $ filePath bfd
      free $ target bfd
      free $ mode bfd
      return $ toBool r

-- | Close a 'Bfd' and if all went well, return 'True'.  Differs from 'close'
-- in that it does not complete any pending operations.  This function would be
-- used if the application had just used a 'Bfd' for swapping and didn't want to
-- use any of the writing code.  If the created file is executable, then 
-- chmod(3) is called to mark it as such.
closeAllDone
   :: Bfd
   -> IO Bool
closeAllDone bfd =
   do
      r <- c_bfd_close_all_done $ ptr bfd
      free $ filePath bfd
      free $ target bfd
      free $ mode bfd
      return $ toBool r

-- Setting the Format ==========================================================

-- | The second part of opening a file (see 'open').  Validates that the 
-- 'TargetName' is appropriate for the opened file and if not, silently picks
-- a more suitable 'TargetName', and also sets the 'Format' of the 'Bfd' object
-- representing the opened file.
--
-- /Important:/ You must call this function before using the vast majority of
-- these functions operating on the 'Bfd' as it updates critical data structures.
--
-- /Possible Exceptions:/ 'InvalidOperation' (if the file was opened write-only),
checkFormat
   :: Bfd
   -> Format
   -> IO Bool
checkFormat bfd format =
   do
      res <- c_bfd_check_format (ptr bfd) $ fromIntegral $ fromEnum format
      throwExceptionIfFalse "checkFormat" (show format) (return $ toBool res)
{-
checkFormatMatches
   :: Bfd
   -> Format
   -> IO [TargetName]
-}

-- Attributes ==================================================================

-- | Returns the disassembler associated with the 'Bfd'.
getDisasm
   :: Bfd
   -> IO Disasm
getDisasm bfd = c_disassembler $ ptr bfd

-- | Returns the 'FilePath' of the file associated with the 'Bfd'. 
getFilename
   :: Bfd
   -> IO FilePath
getFilename bfd =
   do
      fn <- peekByteOff (ptr bfd) (#offset struct bfd, filename)
      return $ unBfd'Filename fn

-- | Returns a 'List' of the 'Bfd's set 'Flags'.
getFlags
   :: Bfd
   -> IO [BfdFlags.Flags]
getFlags bfd =
   do
      flags <- peekByteOff (ptr bfd) (#offset struct bfd, flags)
      let
         flags' = filter f $ enumFrom HasReloc
            where
               f e = unBfd'Flags flags .&. (bit $ fromEnum e) /= 0
      return flags'

-- | Returns the 'Format' of the 'Bfd'.
getFormat
   :: Bfd
   -> IO Format
getFormat bfd =
   do
      format <- peekByteOff (ptr bfd) (#offset struct bfd, format)
      return $ unBfd'Format format

-- | Returns 'True' if the 'Bfd' has an archive map.  Otherwise 'False'.
getHasMap
   :: Bfd
   -> IO Bool
getHasMap bfd =
   do
      hm <- c__bfd_peek_has_armap $ ptr bfd
      return $ toBool hm

-- | Returns 'True' if the 'Bfd' is cacheable.  Otherwise 'False'.
getIsCacheable
   :: Bfd
   -> IO Bool
getIsCacheable bfd =
   do
      c <- c__bfd_peek_cacheable $ ptr bfd
      return $ toBool c

getIsTargetDefaulted
   :: Bfd
   -> IO Bool
getIsTargetDefaulted bfd =
   do
      td <- c__bfd_peek_target_defaulted $ ptr bfd
      return $ toBool td

-- | Returns 'True' if the 'Bfd' is a thin archive.  Otherwise 'False'.
getIsThinArchive
   :: Bfd
   -> IO Bool
getIsThinArchive bfd =
   do
      ita <- c__bfd_peek_is_thin_archive $ ptr bfd
      return $ toBool ita

getMachine
   :: Bfd
   -> IO Int
getMachine bfd = 
   do
      m <- c_bfd_get_mach $ ptr bfd
      return $ fromIntegral m

-- | Returns either a 'Bfd' or 'Nothing'.  FIXME
--
-- /Note:/ Do not pass the returned 'Bfd' to 'close' or 'closeAllDone' or a 
-- memory leak will occur.
getMyArchive
   :: Bfd
   -> IO (Maybe Bfd)
getMyArchive bfd =
   do
      ma <- peekByteOff (ptr bfd) (#offset struct bfd, my_archive)
      return $ case unBfd'MyArchive ma == nullPtr of
         True  -> Nothing
         False -> Just $ Bfd (unBfd'MyArchive ma) nullPtr nullPtr nullPtr

getOctetsPerByte
   :: Bfd
   -> IO Int
getOctetsPerByte bfd =
   do
      opb <- c_bfd_octets_per_byte $ ptr bfd
      return $ fromIntegral opb

-- | Returns the 'Target' of the 'Bfd'.
getTarget
   :: Bfd
   -> IO Target
getTarget bfd = 
   do
      xv <- peekByteOff (ptr bfd) (#offset struct bfd, xvec)
      return $ unBfd'XVec xv

-- For Object Files ------------------------------------------------------------

-- | Return the start address.  Only valid for 'Object' files.
getStartAddress
   :: Bfd
   -> IO Vma
getStartAddress bfd =
   do
      addr <- peekByteOff (ptr bfd) (#offset struct bfd, start_address)
      return $ unBfd'StartAddress addr

-- | Return the symbol count used for input and output.  Only valid for 'Object'
-- files.
-- FIXME:  returns 0 when there are symbols and in main/main too!
getSymbolCount
   :: Bfd
   -> IO Int
getSymbolCount bfd =
   do
      sc <- peekByteOff (ptr bfd) (#offset struct bfd, symcount)
      return $ unBfd'SymbolCount sc

-- Sections --------------------------------------------------------------------

-- | Returns the number of 'Section's in the 'Bfd'.
getSectionCount
   :: Bfd
   -> IO Int
getSectionCount bfd =
   do 
      c <- peekByteOff (ptr bfd) (#offset struct bfd, section_count)
      return $ unBfd'SectionCount c

getSectionByName
   :: Bfd
   -> SectionName
   -> IO Section
getSectionByName bfd sn = withCString sn (\s -> c_bfd_get_section_by_name (ptr bfd) s) 

getSectionByVma
   :: Bfd
   -> Int
   -> IO (Maybe Section)
getSectionByVma bfd vma =
   do
      sects <- getSections bfd
      foldM f Nothing sects
   where
      f xs@(Just _ ) _  = return xs
      f    (Nothing) xi =
         do
            sectVma  <- getVma xi
            sectSize <- getSize xi
            case vma >= sectVma && vma < sectVma + sectSize of
               True  -> return $ Just xi
               False -> return $ Nothing

getSections
   :: Bfd
   -> IO [Section]
getSections bfd =
   do
      (Sections first) <- peekByteOff (ptr bfd) (#offset struct bfd, sections)
      getSections' first []
   where
      getSections' sect rs
         | sect == nullPtr = return $ reverse rs
         | otherwise       =
              do
                 next <- getNext sect
                 getSections' next (sect : rs)

#if 0
createSections
   :: Bfd
   -> IO [(Section, Vma)]
createSections bfd = 
   do
      sects         <- getSections bfd
      extSect       <- Section.mk "externs" 5
      (_, sectList) <- foldM f (0,[]) $ sects ++ [extSect]
      return $ reverse sectList
   where
      f (vma,xs') sect =
         do
            (vma',snvma) <- createSection sect vma
            return (vma', snvma : xs')
#endif

-- Symbol Tables ---------------------------------------------------------------

getSymbolTable
   :: Bfd
   -> IO SymbolTable
getSymbolTable bfd =
   do
      xvec  <- getTarget bfd
      bound <- getSymtabUpperBound xvec bfd
      let
         ptrs = bound `quot` (#const sizeof(struct bfd_symbol *))
      pps <- mallocArray ptrs
      count <- canonicalizeSymtab xvec bfd pps
      return $ SymbolTable.mk pps count

getDynamicSymbolTable
   :: Bfd
   -> IO SymbolTable
getDynamicSymbolTable bfd =
   do
      xvec  <- getTarget bfd
      bound <- getDynamicSymtabUpperBound xvec bfd
      let
         ptrs = fromIntegral bound `quot` (#const sizeof(struct bfd_symbol *))
      pps <- mallocArray ptrs
      count <- canonicalizeDynamicSymtab xvec bfd pps
      return $ SymbolTable.mk pps count

#if 0
getSyntheticSymbolTable
   :: Bfd
   -> SymbolTable    -- static
   -> SymbolTable    -- dynamic
   -> IO SymbolTable
getSyntheticSymbolTable bfd sst dst =
   do
      xvec  <- getTarget bfd
      ssyms <- malloc
      count <- getSyntheticSymtab xvec bfd sst dst ssyms
      return $ SymbolTable.mk ssyms count
#endif

-- Relocations -----------------------------------------------------------------

getDynamicRelocations
   :: Bfd
   -> SymbolTable
   -> IO [Relocation]
getDynamicRelocations bfd st =
   do
      xvec  <- getTarget bfd
      bound <- getDynamicRelocUpperBound xvec bfd
      let
         ptrs = fromIntegral bound `quot` (#const sizeof(arelent *))
      ppr <- mallocArray ptrs
      count <- canonicalizeDynamicReloc xvec bfd ppr $ tablePtr st
      prs <- peekArray count ppr
      mapM peek prs

-- =============================================================================

demangle
   :: Bfd
   -> String
   -> IO String
demangle bfd str =
   do
      s <- withCString str (\s -> c_bfd_demangle (ptr bfd) s 3)
      case s == nullPtr of
         True  -> return ""
         False ->
            do
               s' <- peekCString s
               return s'

-- Internal ====================================================================

data Bfd' = Filename      String
          | XVec          Target
          | Format        Format
          | Flags         Int
          | Sections      Section
          | SectionCount  Int
          | StartAddress  Int
          | SymbolCount   Int
          | MyArchive    (Ptr Bfd')
     deriving (Show)

instance Storable Bfd' where
   sizeOf _ = #size struct bfd
   alignment = sizeOf
   peekByteOff buf off
      | off == (#offset struct bfd, filename) =
         do
            val <- (#peek struct bfd, filename) buf :: IO CString
            str <- peekCString val
            return $ Filename str
      | off == (#offset struct bfd, xvec) = 
         do
            val <- (#peek struct bfd, xvec) buf :: IO Word
            return $ XVec $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd, format) =
         do
            val <- (#peek struct bfd, format) buf :: IO CUInt
            return $ Format $ toEnum $ fromIntegral val
      | off == (#offset struct bfd, flags) =
         do
            val <- (#peek struct bfd, flags) buf :: IO CUInt
            return $ Bindings.Bfd.Flags $ fromIntegral val
      | off == (#offset struct bfd, sections) =
         do
            val <- (#peek struct bfd, sections) buf
            return $ Sections val
      | off == (#offset struct bfd, section_count) =
         do
            val <- (#peek struct bfd, section_count) buf :: IO CUInt
            return $ SectionCount $ fromIntegral val
      | off == (#offset struct bfd, start_address) =
         do
            val <- (#peek struct bfd, start_address) buf :: IO Vma'
            return $ StartAddress $ fromIntegral val
      | off == (#offset struct bfd, symcount) =
         do
            val <- (#peek struct bfd, symcount) buf :: IO CUInt
            return $ SymbolCount $ fromIntegral val
      | off == (#offset struct bfd, my_archive) =
         do
            val <- (#peek struct bfd, my_archive) buf :: IO (Ptr Bfd')
            return $ MyArchive val
      | otherwise = error $ "internal error: Bfd.peekByteOff " ++ show off
   poke _ _ = return ()

mk
   :: Ptr Bfd'
   -> Bfd
mk p = Bfd p nullPtr nullPtr nullPtr

-- PRIVATE #####################################################################

unBfd'Filename
   :: Bfd'
   -> String
unBfd'Filename (Filename fn) = fn
unBfd'Filename _             = error "unBfd'Filename"

unBfd'XVec
   :: Bfd'
   -> Target
unBfd'XVec (XVec p) = p
unBfd'XVec _        = error "unBfd'XVec"

unBfd'Format
   :: Bfd'
   -> Format
unBfd'Format (Format f) = f
unBfd'Format _          = error "unBfd'Format"

unBfd'Flags
   :: Bfd'
   -> Int
unBfd'Flags (Bindings.Bfd.Flags m) = m
unBfd'Flags _                      = error "unBfd'Flags"

unBfd'SectionCount
   :: Bfd'
   -> Int
unBfd'SectionCount (SectionCount c) = c
unBfd'SectionCount _                = error "unBfd'SectionCount"

unBfd'StartAddress
   :: Bfd'
   -> Vma
unBfd'StartAddress (StartAddress a) = a
unBfd'StartAddress _                = error "unBfd'StartAddress"

unBfd'SymbolCount
   :: Bfd'
   -> Int
unBfd'SymbolCount (SymbolCount c) = c
unBfd'SymbolCount _               = error "unBfd'SymbolCount"

unBfd'MyArchive
   :: Bfd'
   -> (Ptr Bfd')
unBfd'MyArchive (MyArchive ma) = ma
unBfd'MyArchive _              = error "unBfd'MyArchive"


foreign import ccall unsafe "bfd.h bfd_init" c_bfd_init
   :: IO ()

foreign import ccall unsafe "bfd.h bfd_fopen" c_bfd_fopen
   :: CString
   -> CString
   -> CString
   -> CInt
   -> IO (Ptr Bfd')

foreign import ccall unsafe "bfd.h bfd_close" c_bfd_close
   :: Ptr Bfd'
   -> IO CInt

foreign import ccall unsafe "bfd.h bfd_close_all_done" c_bfd_close_all_done
   :: Ptr Bfd'
   -> IO CInt

foreign import ccall unsafe "bfd.h bfd_check_format" c_bfd_check_format
   :: Ptr Bfd'
   -> CInt
   -> IO CInt

foreign import ccall unsafe "bfd.h bfd_get_mach" c_bfd_get_mach
   :: Ptr Bfd'
   -> IO CInt

foreign import ccall unsafe "bfd.h bfd_octets_per_byte" c_bfd_octets_per_byte
   :: Ptr Bfd'
   -> IO CUInt

foreign import ccall unsafe "bfd.h bfd_get_section_by_name" c_bfd_get_section_by_name
   :: Ptr Bfd'
   -> CString
   -> IO Section

foreign import ccall unsafe "bfd.h bfd_demangle" c_bfd_demangle
   :: Ptr Bfd'
   -> CString
   -> CInt
   -> IO CString

foreign import ccall unsafe "dis-asm.h disassembler" c_disassembler
   :: Ptr Bfd'
   -> IO Disasm

foreign import ccall unsafe "bfd.h _bfd_peek_target_defaulted" c__bfd_peek_target_defaulted
   :: Ptr Bfd'
   -> IO CInt

foreign import ccall unsafe "bfd.h _bfd_peek_cacheable" c__bfd_peek_cacheable
   :: Ptr Bfd'
   -> IO CInt

foreign import ccall unsafe "bfd.h _bfd_peek_has_armap" c__bfd_peek_has_armap
   :: Ptr Bfd'
   -> IO CInt

foreign import ccall unsafe "bfd.h _bfd_peek_is_thin_archive" c__bfd_peek_is_thin_archive
   :: Ptr Bfd'
   -> IO CInt