Hs2lib-0.4.8: WinDll/COFF/Lib.hs
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Windll
-- Copyright : (c) Tamar Christina 2009 - 2010
-- License : BSD3
--
-- Maintainer : tamar@zhox.com
-- Stability : experimental
-- Portability : portable
--
-- Generates the .lib file for use in c++ compilers.
-- This version can only read and generate the short version of
-- the Import Library format. The Compiler should be able to generate
-- the rest. Or you can use libtool or lib yourself to generate one.
-- http://kishorekumar.net/pecoff_v8.1.htm
--
-----------------------------------------------------------------------------
module WinDll.COFF.Lib where
import Control.Applicative (many)
import Control.Monad (replicateM)
import Control.Monad (when, replicateM)
import Control.Monad.Trans (liftIO)
import Data.Bits
import Data.Char (ord, chr)
import Data.Serialize
import Data.Time.Clock (UTCTime)
import Data.Time.Format (formatTime, readTime)
import Data.Word
import System.Locale (defaultTimeLocale)
-- | The structure of a .LIB file in Haskell format
data LibFile = LibFile { fstLinker :: Section FirstMember -- ^ @entries@ First linker object
, sndLinker :: Section SecondMember -- ^ @entries@ second linker object
, long :: Section LongNames -- ^ @long@ Definition of Longnames ember
, objfiles :: [Section ImportLibrary] -- ^ @objfiles@ A list of OBJ File contents (COFF Format)
}
-- | The header file of a .LIB COFF format
data Header = Header { hdName :: Either String Int -- ^ 0 16 Name The name of the archive member, with a slash (/) appended
-- to terminate the name. If the first character is a slash,
-- the name has a special interpretation, as described in the
-- following table.
, hdDate :: UTCTime -- ^ 16 12 Date The date and time that the archive member was created: This
-- is the ASCII decimal representation of the number of seconds
-- since 1/1/1970 UCT.
, hdUserID :: String -- ^ 28 6 User ID An ASCII decimal representation of the user ID. This field
-- does not contain a meaningful value on Windows platforms because
-- Microsoft tools emit all blanks.
, hdGroupID :: String -- ^ 34 6 Group ID An ASCII decimal representation of the group ID. This field
-- does not contain a meaningful value on Windows platforms because
-- Microsoft tools emit all blanks.
, hdMode :: String -- ^ 40 8 Mode An ASCII octal representation of the members file mode. This is
-- the ST_MODE value from the C run-time function _wstat.
, hdSize :: Int -- ^ 48 10 Size An ASCII decimal representation of the total size of the archive
-- member, not including the size of the header.
}
-- | The first COFF linker member
data FirstMember = FirstMember { flkOffsets :: [Int] -- ^ 4 4*n Offsets An array of file offsets to archive member headers, in which n is equal
-- to the Number of Symbols field. Each number in the array is an unsigned
-- long stored in big-endian format. For each symbol that is named in the
-- string table, the corresponding element in the offsets array gives the
-- location of the archive member that contains the symbol.
, flkStrTbl :: [String] -- ^ * * String Table A series of null-terminated strings that name all the symbols in
-- the directory. Each string begins immediately after the null character
-- in the previous string. The number of strings must be equal to the
-- value of the Number of Symbols field.
}
data SecondMember = SecondMember { slkOffsets :: [Int] -- ^ 4 4*m Offsets An array of file offsets to archive member headers, arranged in
-- ascending order. Each offset is an unsigned long. The number m
-- is equal to the value of the Number of Members field.
, slkIndices :: [Int] -- ^ * 2*n Indices An array of 1-based indexes (unsigned short) that map symbol names
-- to archive member offsets. The number n is equal to the Number of
-- Symbols field. For each symbol that is named in the string table,
-- the corresponding element in the Indices array gives an index into
-- the offsets array. The offsets array, in turn, gives the location
-- of the archive member that contains the symbol.
, slkStrTbl :: [String] -- ^ * * String Table A series of null-terminated strings that name all of the symbols
-- in the directory. Each string begins immediately after the null
-- byte in the previous string. The number of strings must be equal
-- to the value of the Number of Symbols field. This table lists all
-- the symbol names in ascending lexical order.
}
-- | List of long names, These will be stored as a null-terminated string
newtype LongNames = LongNames { lnNames :: [String] }
-- | The import library declaration. This version only allows the short version
-- of the specification. and nothing more. The long version requires me to write
-- a symbol table and calculate some data from the dll. This is something best done
-- by vc++ so I'm not going to do it.
data ImportLibrary = ShortImport { siHeader :: ImportHeader
, siImportName :: String -- ^ Null-terminated import name string
, siDLLName :: String -- ^ Null-terminated DLL name string
}
-- | COFF Import Headers
data ImportHeader = ImportHeader { ihSig1 :: MachineType -- ^ 0 2 Sig1 Must be IMAGE_FILE_MACHINE_UNKNOWN. For more information, see section 3.3.1, "Machine Types."
, ihSig2 :: Int -- ^ 2 2 Sig2 Must be 0xFFFF.
, ihVersion :: (Int, Int) -- ^ 4 2 Version The structure version.
, ihMachine :: MachineType -- ^ 6 2 Machine The number that identifies the type of target machine. For more information, see section 3.3.1, "Machine Types."
, ihDateTime :: UTCTime -- ^ 8 4 Time-Date Stamp The time and date that the file was created.
, ihSize :: Int -- ^ 12 4 Size Of Data The size of the strings that follow the header.
, ihHint :: String -- ^ 16 2 Ordinal/Hint Either the ordinal or the hint for the import, determined by the value in the Name Type field.
, ihType :: ImportType -- ^ 18 2 bits Type The import type. For specific values and descriptions, see section 8.2, "Import Type."
, ihNameType :: ImportNameType -- ^ 3 bits Name Type The import name type. For specific values and descriptions, see section "8.3. Import Name Type."
, ihReserved :: Word16 -- ^ 11 bits Reserved Reserved, must be 0.
}
instance Serialize ImportHeader where
put ih = do put (ihSig1 ih)
put (toWord16 $ ihSig2 ih)
let (major,minor) = ihVersion ih
put (toWord8 major)
put (toWord8 minor)
put (ihMachine ih)
let time = formatTime defaultTimeLocale "%s" (ihDateTime ih)
put (read time :: Word32)
put (toWord32 $ ihSize ih)
mapM_ put (take 2 $ ihHint ih)
let bits0 = ihReserved ih
bits1 = case ihType ih of
IMPORT_CODE -> bits0
IMPORT_DATA -> bits0 `setBit` 14
IMPORT_CONST -> bits0 `setBit` 15
bits2 = case ihNameType ih of
IMPORT_ORDINAL -> bits1
IMPORT_NAME -> bits1 `setBit` 11
IMPORT_NAME_NOPREFIX -> bits1 `setBit` 12
IMPORT_NAME_UNDECORATE -> bits1 `setBit` 11 `setBit` 12
put bits2
get = do sig1 <- get
when (sig1 /= IMAGE_FILE_MACHINE_UNKNOWN) $
error "Import header sig1 error, expected IMAGE_FILE_MACHINE_UNKNOWN"
sig2 <- get :: Get Word16
when (sig2 /= 0xFFFF) $
error "Import Header bit signature mismatch"
major <- get :: Get Word8
minor <- get :: Get Word8
machine <- get
time <- get :: Get Word32
let time' = readTime defaultTimeLocale "%s" (show time)
size <- get :: Get Word32
hint <- get >>= \a -> get >>= \b -> return [a,b]
bits0 <- get :: Get Word16
let itype = case (bits0 `testBit` 14, bits0 `testBit` 15) of
(False, False) -> IMPORT_CODE
(True , False) -> IMPORT_DATA
(False, True ) -> IMPORT_CONST
iname = case (bits0 `testBit` 11, bits0 `testBit` 12) of
(False, False) -> IMPORT_ORDINAL
(True , False) -> IMPORT_NAME
(False, True ) -> IMPORT_NAME_NOPREFIX
(True , True ) -> IMPORT_NAME_UNDECORATE
return $ ImportHeader sig1 (fromWord16 sig2) (fromWord8 major, fromWord8 minor)
machine time' (fromWord32 size) hint itype iname 0
-- | The Machine field has one of the following values that specifies its CPU type.
-- An image file can be run only on the specified machine or on a system that emulates
-- the specified machine.
data MachineType = IMAGE_FILE_MACHINE_UNKNOWN -- ^ 0x0 The contents of this field are assumed to be applicable to any machine type
| IMAGE_FILE_MACHINE_AM33 -- ^ 0x1d3 Matsushita AM33
| IMAGE_FILE_MACHINE_AMD64 -- ^ 0x8664 x64
| IMAGE_FILE_MACHINE_ARM -- ^ 0x1c0 ARM little endian
| IMAGE_FILE_MACHINE_EBC -- ^ 0xebc EFI byte code
| IMAGE_FILE_MACHINE_I386 -- ^ 0x14c Intel 386 or later processors and compatible processors
| IMAGE_FILE_MACHINE_IA64 -- ^ 0x200 Intel Itanium processor family
| IMAGE_FILE_MACHINE_M32R -- ^ 0x9041 Mitsubishi M32R little endian
| IMAGE_FILE_MACHINE_MIPS16 -- ^ 0x266 MIPS16
| IMAGE_FILE_MACHINE_MIPSFPU -- ^ 0x366 MIPS with FPU
| IMAGE_FILE_MACHINE_MIPSFPU16 -- ^ 0x466 MIPS16 with FPU
| IMAGE_FILE_MACHINE_POWERPC -- ^ 0x1f0 Power PC little endian
| IMAGE_FILE_MACHINE_POWERPCFP -- ^ 0x1f1 Power PC with floating point support
| IMAGE_FILE_MACHINE_R4000 -- ^ 0x166 MIPS little endian
| IMAGE_FILE_MACHINE_SH3 -- ^ 0x1a2 Hitachi SH3
| IMAGE_FILE_MACHINE_SH3DSP -- ^ 0x1a3 Hitachi SH3 DSP
| IMAGE_FILE_MACHINE_SH4 -- ^ 0x1a6 Hitachi SH4
| IMAGE_FILE_MACHINE_SH5 -- ^ 0x1a8 Hitachi SH5
| IMAGE_FILE_MACHINE_THUMB -- ^ 0x1c2 Thumb
| IMAGE_FILE_MACHINE_WCEMIPSV2 -- ^ 0x169 MIPS little-endian WCE v2
deriving (Show, Eq)
-- | The following values are defined for the Type field in the import header.
data ImportType = IMPORT_CODE -- ^ 0 Executable code.
| IMPORT_DATA -- ^ 1 Data.
| IMPORT_CONST -- ^ 2 Specified as CONST in the .def file.
-- | The null-terminated import symbol name immediately follows its associated import header.
-- The following values are defined for the Name Type field in the import header.
-- They indicate how the name is to be used to generate the correct symbols that represent the import.
data ImportNameType = IMPORT_ORDINAL -- ^ 0 The import is by ordinal. This indicates that the value in
-- the Ordinal/Hint field of the import header is the imports
-- ordinal. If this constant is not specified, then the Ordinal/Hint
-- field should always be interpreted as the imports hint.
| IMPORT_NAME -- ^ 1 The import name is identical to the public symbol name.
| IMPORT_NAME_NOPREFIX -- ^ 2 The import name is the public symbol name, but skipping the
-- leading ?, @, or optionally _.
| IMPORT_NAME_UNDECORATE -- ^ 3 The import name is the public symbol name, but skipping the
-- leading ?, @, or optionally _, and truncating at the first @.
-- | Puts the string of length i. If the string is
-- too short the string is padded, if it's too long
-- the string is truncated.
putString :: Int -> String -> Put
putString i str = let nm = take i (str ++ repeat ' ')
in mapM_ put nm
-- | Reads a fixed length string back in. The string is post
-- processed to removed paddings
getString :: Int -> Get String
getString i = do str <- replicateM i get
return $ trim str
-- | Remove leading and trailing whitespace
trim :: String -> String
trim = reverse . dropWhile (==' ') . reverse . dropWhile (==' ')
-- | Write a NULL terminated string out
writeNullString :: String -> Put
writeNullString str = do mapM_ put str
put '\0'
-- | Read a NULL terminated string
readNullString :: Get String
readNullString = do x <- get
if x == '\0'
then return []
else do xs <- readNullString
return (x:xs)
-- * Some extra utilities function
toInt :: Functor f => f Word32 -> f Int
toInt = fmap fromIntegral
mapInt :: [Word32] -> [Int]
mapInt = map (fromIntegral :: Word32 -> Int)
toWord8 :: Integral a => a -> Word8
toWord8 = fromIntegral
toWord16 :: Integral a => a -> Word16
toWord16 = fromIntegral
toWord32 :: Integral a => a -> Word32
toWord32 = fromIntegral
fromWord8 :: Integral a => Word8 -> a
fromWord8 = fromIntegral
fromWord16 :: Integral a => Word16 -> a
fromWord16 = fromIntegral
fromWord32 :: Integral a => Word32 -> a
fromWord32 = fromIntegral
instance Serialize LibFile where
put lib = do mapM_ put "!<arch>\n"
put (fstLinker lib)
put (sndLinker lib)
put (long lib)
mapM_ put (objfiles lib)
get = do sig <- getString 08
when (sig /= "!<arch>\n") $
error "header value mismatched"
fstObj <- get
sndObj <- get
lngObj <- get
objFls <- many get
return $ LibFile fstObj sndObj lngObj objFls
instance Serialize Header where
put hd = do let name = case hdName hd of
Left str -> str ++ "/"
Right loc -> '/' : show loc
putString 16 name
let time = formatTime defaultTimeLocale "%s" (hdDate hd)
putString 12 time
putString 06 (hdUserID hd)
putString 06 (hdGroupID hd)
putString 08 (hdMode hd)
putString 10 (show (hdSize hd))
put (toWord8 0x60)
put (toWord8 0x0A)
get = do name <- getString 16
time <- getString 12
user <- getString 06
group <- getString 06
mode <- getString 08
size <- getString 10
byte1 <- get :: Get Word8
byte2 <- get :: Get Word8
let name' = case name of
'/':str -> Right (read str)
str -> Left str
let time' = readTime defaultTimeLocale "%s" time
when (byte1 /= 0x60 || byte2 /= 0x0A) $
error "signature bytes mismatch"
return $ Header name' time' user group mode (read size)
instance Serialize FirstMember where
put fm = do put (fromIntegral $ length $ flkOffsets fm :: Word32)
mapM_ (put . (fromIntegral :: Int -> Word32)) (flkOffsets fm)
mapM_ writeNullString (flkStrTbl fm)
get = do size <- toInt get
offsets <- replicateM size get :: Get [Word32]
strTble <- replicateM size readNullString
return $ FirstMember (mapInt offsets) strTble
instance Serialize SecondMember where
put fm = do put (fromIntegral $ length $ slkOffsets fm :: Word32)
mapM_ (put . (fromIntegral :: Int -> Word32)) (slkOffsets fm)
put (fromIntegral $ length $ slkIndices fm :: Word32)
mapM_ (put . (fromIntegral :: Int -> Word32)) (slkIndices fm)
mapM_ writeNullString (slkStrTbl fm)
get = do size1 <- toInt get
offsets <- replicateM size1 get :: Get [Word32]
size2 <- toInt get
indices <- replicateM size2 get :: Get [Word32]
strTble <- replicateM size2 readNullString
return $ SecondMember (mapInt offsets) (mapInt indices) strTble
instance Serialize LongNames where
put = mapM_ writeNullString . lnNames
get = fmap LongNames $ many readNullString
instance Serialize ImportLibrary where
put im = do put (siHeader im)
writeNullString (siImportName im)
writeNullString (siDLLName im)
get = do header <- get
impname <- readNullString
dllname <- readNullString
return $ ShortImport header impname dllname
instance Serialize ImportType where
put IMPORT_CODE = put (toWord8 0)
put IMPORT_DATA = put (toWord8 1)
put IMPORT_CONST = put (toWord8 2)
get = do val <- get :: Get Word8
return $ case val of
0 -> IMPORT_CODE
1 -> IMPORT_DATA
2 -> IMPORT_CONST
instance Serialize ImportNameType where
put IMPORT_ORDINAL = put (toWord8 0)
put IMPORT_NAME = put (toWord8 1)
put IMPORT_NAME_NOPREFIX = put (toWord8 2)
put IMPORT_NAME_UNDECORATE = put (toWord8 3)
get = do val <- get :: Get Word8
return $ case val of
0 -> IMPORT_ORDINAL
1 -> IMPORT_NAME
2 -> IMPORT_NAME_NOPREFIX
3 -> IMPORT_NAME_UNDECORATE
instance Serialize MachineType where
put IMAGE_FILE_MACHINE_UNKNOWN = put (toWord16 0x0 )
put IMAGE_FILE_MACHINE_AM33 = put (toWord16 0x1d3 )
put IMAGE_FILE_MACHINE_AMD64 = put (toWord16 0x8664)
put IMAGE_FILE_MACHINE_ARM = put (toWord16 0x1c0 )
put IMAGE_FILE_MACHINE_EBC = put (toWord16 0xebc )
put IMAGE_FILE_MACHINE_I386 = put (toWord16 0x14c )
put IMAGE_FILE_MACHINE_IA64 = put (toWord16 0x200 )
put IMAGE_FILE_MACHINE_M32R = put (toWord16 0x9041)
put IMAGE_FILE_MACHINE_MIPS16 = put (toWord16 0x266 )
put IMAGE_FILE_MACHINE_MIPSFPU = put (toWord16 0x366 )
put IMAGE_FILE_MACHINE_MIPSFPU16 = put (toWord16 0x466 )
put IMAGE_FILE_MACHINE_POWERPC = put (toWord16 0x1f0 )
put IMAGE_FILE_MACHINE_POWERPCFP = put (toWord16 0x1f1 )
put IMAGE_FILE_MACHINE_R4000 = put (toWord16 0x166 )
put IMAGE_FILE_MACHINE_SH3 = put (toWord16 0x1a2 )
put IMAGE_FILE_MACHINE_SH3DSP = put (toWord16 0x1a3 )
put IMAGE_FILE_MACHINE_SH4 = put (toWord16 0x1a6 )
put IMAGE_FILE_MACHINE_SH5 = put (toWord16 0x1a8 )
put IMAGE_FILE_MACHINE_THUMB = put (toWord16 0x1c2 )
put IMAGE_FILE_MACHINE_WCEMIPSV2 = put (toWord16 0x169 )
get = do val <- get :: Get Word16
return $ case val of
0x0 -> IMAGE_FILE_MACHINE_UNKNOWN
0x1d3 -> IMAGE_FILE_MACHINE_AM33
0x8664 -> IMAGE_FILE_MACHINE_AMD64
0x1c0 -> IMAGE_FILE_MACHINE_ARM
0xebc -> IMAGE_FILE_MACHINE_EBC
0x14c -> IMAGE_FILE_MACHINE_I386
0x200 -> IMAGE_FILE_MACHINE_IA64
0x9041 -> IMAGE_FILE_MACHINE_M32R
0x266 -> IMAGE_FILE_MACHINE_MIPS16
0x366 -> IMAGE_FILE_MACHINE_MIPSFPU
0x466 -> IMAGE_FILE_MACHINE_MIPSFPU16
0x1f0 -> IMAGE_FILE_MACHINE_POWERPC
0x1f1 -> IMAGE_FILE_MACHINE_POWERPCFP
0x166 -> IMAGE_FILE_MACHINE_R4000
0x1a2 -> IMAGE_FILE_MACHINE_SH3
0x1a3 -> IMAGE_FILE_MACHINE_SH3DSP
0x1a6 -> IMAGE_FILE_MACHINE_SH4
0x1a8 -> IMAGE_FILE_MACHINE_SH5
0x1c2 -> IMAGE_FILE_MACHINE_THUMB
0x169 -> IMAGE_FILE_MACHINE_WCEMIPSV2