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