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