JVM/ClassFile.hs

   1 {-# LANGUAGE RecordWildCards, BangPatterns #-}
   2 -- | This module declares (low-level) data types for Java .class files
   3 -- structures, and Binary instances to read/write them.
   4 module JVM.ClassFile
   5   (ClassFile (..),
   6    CpInfo (..),
   7    FieldInfo (..),
   8    MethodInfo (..),
   9    AttributeInfo (..),
  10    FieldType,
  11    FieldSignature, MethodSignature (..), ReturnSignature (..)
  12   )
  13   where
  14
  15 import Control.Monad
  16 import Control.Applicative
  17 import Data.Binary
  18 import Data.Binary.IEEE754
  19 import Data.Binary.Get
  20 import Data.Binary.Put
  21 import Data.Char
  22 import Data.List
  23 import qualified Data.ByteString.Lazy as B
  24
  25 -- | Read one-byte Char
  26 getChar8 :: Get Char
  27 getChar8 = do
  28   x <- getWord8
  29   return $ chr (fromIntegral x)
  30
  31 -- | Generic .class file format
  32 data ClassFile = ClassFile {
  33   magic :: Word32,                   -- ^ Magic value: 0xCAFEBABE
  34   minorVersion :: Word16,
  35   majorVersion :: Word16,
  36   constsPoolSize :: Word16,          -- ^ Number of items in constants pool
  37   constsPool :: [CpInfo],            -- ^ Constants pool itself
  38   accessFlags :: Word16,             -- ^ See @JVM.Types.AccessFlag@
  39   thisClass :: Word16,               -- ^ Constants pool item index for this class
  40   superClass :: Word16,              -- ^ --/-- for super class, zero for java.lang.Object
  41   interfacesCount :: Word16,         -- ^ Number of implemented interfaces
  42   interfaces :: [Word16],            -- ^ Constants pool item indexes for implemented interfaces
  43   classFieldsCount :: Word16,        -- ^ Number of class fileds
  44   classFields :: [FieldInfo],        -- ^ Class fields
  45   classMethodsCount :: Word16,       -- ^ Number of class methods
  46   classMethods :: [MethodInfo],      -- ^ Class methods
  47   classAttributesCount :: Word16,    -- ^ Number of class attributes
  48   classAttributes :: [AttributeInfo] -- ^ Class attributes
  49   }
  50   deriving (Eq, Show)
  51
  52 instance Binary ClassFile where
  53   put (ClassFile {..}) = do
  54     put magic
  55     put minorVersion
  56     put majorVersion
  57     put constsPoolSize
  58     forM_ constsPool put
  59     put accessFlags
  60     put thisClass
  61     put superClass
  62     put interfacesCount
  63     forM_ interfaces put
  64     put classFieldsCount
  65     forM_ classFields put
  66     put classMethodsCount
  67     forM_ classMethods put
  68     put classAttributesCount
  69     forM_ classAttributes put
  70
  71   get = do
  72     magic <- get
  73     minor <- get
  74     major <- get
  75     poolsize <- get
  76     pool <- replicateM (fromIntegral poolsize - 1) get
  77     af <- get
  78     this <- get
  79     super <- get
  80     interfacesCount <- get
  81     ifaces <- replicateM (fromIntegral interfacesCount) get
  82     classFieldsCount <- get
  83     classFields <- replicateM (fromIntegral classFieldsCount) get
  84     classMethodsCount <- get
  85     classMethods <- replicateM (fromIntegral classMethodsCount) get
  86     asCount <- get
  87     as <- replicateM (fromIntegral $ asCount - 1) get
  88     return $ ClassFile magic minor major poolsize pool af this super
  89                interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as
  90
  91 -- | Field signature format
  92 data FieldType =
  93     SignedByte -- ^ B
  94   | CharByte   -- ^ C
  95   | DoubleType -- ^ D
  96   | FloatType  -- ^ F
  97   | IntType    -- ^ I
  98   | LongInt    -- ^ J
  99   | ShortInt   -- ^ S
 100   | BoolType   -- ^ Z
 101   | ObjectType String -- ^ L <class name>
 102   | Array (Maybe Int) FieldType -- ^ [<type>
 103   deriving (Eq)
 104
 105 instance Show FieldType where
 106   show SignedByte = "byte"
 107   show CharByte = "char"
 108   show DoubleType = "double"
 109   show FloatType = "float"
 110   show IntType = "int"
 111   show LongInt = "long"
 112   show ShortInt = "short"
 113   show BoolType = "bool"
 114   show (ObjectType s) = "Object " ++ s
 115   show (Array Nothing t) = show t ++ "[]"
 116   show (Array (Just n) t) = show t ++ "[" ++ show n ++ "]"
 117
 118 -- | Class field signature
 119 type FieldSignature = FieldType
 120
 121 -- | Try to read integer value from decimal representation
 122 getInt :: Get (Maybe Int)
 123 getInt = do
 124     s <- getDigits
 125     if null s
 126       then return Nothing
 127       else return $ Just (read s)
 128   where
 129     getDigits :: Get [Char]
 130     getDigits = do
 131       c <- lookAhead getChar8
 132       if isDigit c
 133         then do
 134              skip 1
 135              next <- getDigits
 136              return (c: next)
 137         else return []
 138
 139 instance Binary FieldType where
 140   put SignedByte = put 'B'
 141   put CharByte   = put 'C'
 142   put DoubleType = put 'D'
 143   put FloatType  = put 'F'
 144   put IntType    = put 'I'
 145   put LongInt    = put 'J'
 146   put ShortInt   = put 'S'
 147   put BoolType   = put 'Z'
 148   put (ObjectType name) = put 'L' >> put name
 149   put (Array Nothing sig) = put '[' >> put sig
 150   put (Array (Just n) sig) = put '[' >> put (show n) >> put sig
 151
 152   get = do
 153     b <- getChar8
 154     case b of
 155       'B' -> return SignedByte
 156       'C' -> return CharByte
 157       'D' -> return DoubleType
 158       'F' -> return FloatType
 159       'I' -> return IntType
 160       'J' -> return LongInt
 161       'S' -> return ShortInt
 162       'Z' -> return BoolType
 163       'L' -> do
 164              name <- getToSemicolon
 165              return (ObjectType name)
 166       '[' -> do
 167              mbSize <- getInt
 168              sig <- get
 169              return (Array mbSize sig)
 170       _   -> fail $ "Unknown signature opening symbol: " ++ [b]
 171
 172 -- | Read string up to `;'
 173 getToSemicolon :: Get String
 174 getToSemicolon = do
 175   x <- get
 176   if x == ';'
 177     then return []
 178     else do
 179          next <- getToSemicolon
 180          return (x: next)
 181
 182 -- | Return value signature
 183 data ReturnSignature =
 184     Returns FieldType
 185   | ReturnsVoid
 186   deriving (Eq)
 187
 188 instance Show ReturnSignature where
 189   show (Returns t) = show t
 190   show ReturnsVoid = "Void"
 191
 192 instance Binary ReturnSignature where
 193   put (Returns sig) = put sig
 194   put ReturnsVoid   = put 'V'
 195
 196   get = do
 197     x <- lookAhead getChar8
 198     case x of
 199       'V' -> skip 1 >> return ReturnsVoid
 200       _   -> Returns <$> get
 201
 202 -- | Method argument signature
 203 type ArgumentSignature = FieldType
 204
 205 -- | Class method argument signature
 206 data MethodSignature =
 207     MethodSignature [ArgumentSignature] ReturnSignature
 208   deriving (Eq)
 209
 210 instance Show MethodSignature where
 211   show (MethodSignature args ret) = "(" ++ intercalate ", " (map show args) ++ ") returns " ++ show ret
 212
 213 instance Binary MethodSignature where
 214   put (MethodSignature args ret) = do
 215     put '('
 216     forM_ args put
 217     put ')'
 218     put ret
 219
 220   get =  do
 221     x <- getChar8
 222     when (x /= '(') $
 223       fail "Cannot parse method signature: no starting `(' !"
 224     args <- getArgs
 225     y <- getChar8
 226     when (y /= ')') $
 227       fail "Internal error: method signature without `)' !?"
 228     ret <- get
 229     return (MethodSignature args ret)
 230
 231 -- | Read arguments signatures (up to `)')
 232 getArgs :: Get [ArgumentSignature]
 233 getArgs = whileJust getArg
 234   where
 235     getArg :: Get (Maybe ArgumentSignature)
 236     getArg = do
 237       x <- lookAhead getChar8
 238       if x == ')'
 239         then return Nothing
 240         else Just <$> get
 241
 242 whileJust :: (Monad m) => m (Maybe a) -> m [a]
 243 whileJust m = do
 244   r <- m
 245   case r of
 246     Just x -> do
 247               next <- whileJust m
 248               return (x: next)
 249     Nothing -> return []
 250
 251 -- | Constant pool item format
 252 data CpInfo =
 253     CONSTANT_Class {nameIndex :: Word16}                                          -- ^ 7
 254   | CONSTANT_Fieldref {classIndex :: Word16, nameAndTypeIndex :: Word16}                -- ^ 9
 255   | CONSTANT_Methodref  {classIndex :: Word16, nameAndTypeIndex :: Word16}        -- ^ 10
 256   | CONSTANT_InterfaceMethodref {classIndex :: Word16, nameAndTypeIndex :: Word16}-- ^ 11
 257   | CONSTANT_String {stringIndex :: Word16}                                       -- ^ 8
 258   | CONSTANT_Integer {fourBytes :: Word32}                                            -- ^ 3
 259   | CONSTANT_Float Float                                                          -- ^ 4
 260   | CONSTANT_Long Word64                                                          -- ^ 5
 261   | CONSTANT_Double Double                                                        -- ^ 6
 262   | CONSTANT_NameAndType {nameIndex :: Word16, signatureIndex :: Word16}                -- ^ 12
 263   | CONSTANT_Utf8 {stringLength :: Word16, stringBytes :: B.ByteString}               -- ^ 1
 264   | CONSTANT_Unicode {stringLength :: Word16, stringBytes :: B.ByteString}          -- ^ 2
 265   deriving (Eq, Show)
 266
 267 instance Binary CpInfo where
 268   put (CONSTANT_Class i) = putWord8 7 >> put i
 269   put (CONSTANT_Fieldref i j) = putWord8 9 >> put i >> put j
 270   put (CONSTANT_Methodref i j) = putWord8 10 >> put i >> put j
 271   put (CONSTANT_InterfaceMethodref i j) = putWord8 11 >> put i >> put j
 272   put (CONSTANT_String i) = putWord8 8 >> put i
 273   put (CONSTANT_Integer x) = putWord8 3 >> put x
 274   put (CONSTANT_Float x)   = putWord8 4 >> putFloat32be x
 275   put (CONSTANT_Long x)    = putWord8 5 >> put x
 276   put (CONSTANT_Double x)  = putWord8 6 >> putFloat64be x
 277   put (CONSTANT_NameAndType i j) = putWord8 12 >> put i >> put j
 278   put (CONSTANT_Utf8 l bs) = putWord8 1 >> put l >> putLazyByteString bs
 279   put (CONSTANT_Unicode l bs) = putWord8 2 >> put l >> putLazyByteString bs
 280
 281   get = do
 282     !offset <- bytesRead
 283     tag <- getWord8
 284     case tag of
 285       1 -> do
 286         l <- get
 287         bs <- getLazyByteString (fromIntegral l)
 288         return $ CONSTANT_Utf8 l bs
 289       2 -> do
 290         l <- get
 291         bs <- getLazyByteString (fromIntegral l)
 292         return $ CONSTANT_Unicode l bs
 293       3  -> CONSTANT_Integer   <$> get
 294       4  -> CONSTANT_Float     <$> getFloat32be
 295       5  -> CONSTANT_Long      <$> get
 296       6  -> CONSTANT_Double    <$> getFloat64be
 297       7  -> CONSTANT_Class     <$> get
 298       8  -> CONSTANT_String    <$> get
 299       9  -> CONSTANT_Fieldref  <$> get <*> get
 300       10 -> CONSTANT_Methodref <$> get <*> get
 301       11 -> CONSTANT_InterfaceMethodref <$> get <*> get
 302       12 -> CONSTANT_NameAndType <$> get <*> get
 303       _  -> fail $ "Unknown constants pool entry tag: " ++ show tag
 304
 305 -- | Class field format
 306 data FieldInfo = FieldInfo {
 307   fieldAccessFlags :: Word16,
 308   fieldNameIndex :: Word16,
 309   fieldSignatureIndex :: Word16,
 310   fieldAttributesCount :: Word16,
 311   fieldAttributes :: [AttributeInfo] }
 312   deriving (Eq, Show)
 313
 314 instance Binary FieldInfo where
 315   put (FieldInfo {..}) = do
 316     put fieldAccessFlags
 317     put fieldNameIndex
 318     put fieldSignatureIndex
 319     put fieldAttributesCount
 320     forM_ fieldAttributes put
 321
 322   get = do
 323     af <- get
 324     ni <- get
 325     si <- get
 326     n <- get
 327     as <- replicateM (fromIntegral n) get
 328     return $ FieldInfo af ni si n as
 329
 330 -- | Class method format
 331 data MethodInfo = MethodInfo {
 332   methodAccessFlags :: Word16,
 333   methodNameIndex :: Word16,
 334   methodSignatureIndex :: Word16,
 335   methodAttributesCount :: Word16,
 336   methodAttributes :: [AttributeInfo] }
 337   deriving (Eq, Show)
 338
 339 instance Binary MethodInfo where
 340   put (MethodInfo {..}) = do
 341     put methodAccessFlags
 342     put methodNameIndex
 343     put methodSignatureIndex
 344     put methodAttributesCount
 345     forM_ methodAttributes put
 346
 347   get = do
 348     offset <- bytesRead
 349     af <- get
 350     ni <- get
 351     si <- get
 352     n <- get
 353     as <- replicateM (fromIntegral n) get
 354     return $ MethodInfo af ni si n as
 355
 356 -- | Any (class/ field/ method/ ...) attribute format.
 357 -- Some formats specify special formats for @attributeValue@.
 358 data AttributeInfo = AttributeInfo {
 359   attributeName :: Word16,
 360   attributeLength :: Word32,
 361   attributeValue :: B.ByteString }
 362   deriving (Eq, Show)
 363
 364 instance Binary AttributeInfo where
 365   put (AttributeInfo {..}) = do
 366     put attributeName
 367     putWord32be attributeLength
 368     putLazyByteString attributeValue
 369
 370   get = do
 371     offset <- bytesRead
 372     name <- get
 373     len <- getWord32be
 374     value <- getLazyByteString (fromIntegral len)
 375     return $ AttributeInfo name len value
 376
 377