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 - 1) 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 instance Binary FieldType where
 141   put SignedByte = put 'B'
 142   put CharByte   = put 'C'
 143   put DoubleType = put 'D'
 144   put FloatType  = put 'F'
 145   put IntType    = put 'I'
 146   put LongInt    = put 'J'
 147   put ShortInt   = put 'S'
 148   put BoolType   = put 'Z'
 149   put (ObjectType name) = put 'L' >> put name
 150   put (Array Nothing sig) = put '[' >> put sig
 151   put (Array (Just n) sig) = put '[' >> put (show n) >> put sig
 152
 153   get = do
 154     b <- getChar8
 155     case b of
 156       'B' -> return SignedByte
 157       'C' -> return CharByte
 158       'D' -> return DoubleType
 159       'F' -> return FloatType
 160       'I' -> return IntType
 161       'J' -> return LongInt
 162       'S' -> return ShortInt
 163       'Z' -> return BoolType
 164       'L' -> do
 165              name <- getToSemicolon
 166              return (ObjectType name)
 167       '[' -> do
 168              mbSize <- getInt
 169              sig <- get
 170              return (Array mbSize sig)
 171       _   -> fail $ "Unknown signature opening symbol: " ++ [b]
 172
 173 -- | Read string up to `;'
 174 getToSemicolon :: Get String
 175 getToSemicolon = do
 176   x <- get
 177   if x == ';'
 178     then return []
 179     else do
 180          next <- getToSemicolon
 181          return (x: next)
 182
 183 -- | Return value signature
 184 data ReturnSignature =
 185     Returns FieldType
 186   | ReturnsVoid
 187   deriving (Eq)
 188
 189 instance Show ReturnSignature where
 190   show (Returns t) = show t
 191   show ReturnsVoid = "Void"
 192
 193 instance Binary ReturnSignature where
 194   put (Returns sig) = put sig
 195   put ReturnsVoid   = put 'V'
 196
 197   get = do
 198     x <- lookAhead getChar8
 199     case x of
 200       'V' -> skip 1 >> return ReturnsVoid
 201       _   -> Returns <$> get
 202
 203 -- | Method argument signature
 204 type ArgumentSignature = FieldType
 205
 206 -- | Class method argument signature
 207 data MethodSignature =
 208     MethodSignature [ArgumentSignature] ReturnSignature
 209   deriving (Eq)
 210
 211 instance Show MethodSignature where
 212   show (MethodSignature args ret) = "(" ++ intercalate ", " (map show args) ++ ") returns " ++ show ret
 213
 214 instance Binary MethodSignature where
 215   put (MethodSignature args ret) = do
 216     put '('
 217     forM_ args put
 218     put ')'
 219     put ret
 220
 221   get =  do
 222     x <- getChar8
 223     when (x /= '(') $
 224       fail "Cannot parse method signature: no starting `(' !"
 225     args <- getArgs
 226     y <- getChar8
 227     when (y /= ')') $
 228       fail "Internal error: method signature without `)' !?"
 229     ret <- get
 230     return (MethodSignature args ret)
 231
 232 -- | Read arguments signatures (up to `)')
 233 getArgs :: Get [ArgumentSignature]
 234 getArgs = whileJust getArg
 235   where
 236     getArg :: Get (Maybe ArgumentSignature)
 237     getArg = do
 238       x <- lookAhead getChar8
 239       if x == ')'
 240         then return Nothing
 241         else Just <$> get
 242
 243 whileJust :: (Monad m) => m (Maybe a) -> m [a]
 244 whileJust m = do
 245   r <- m
 246   case r of
 247     Just x -> do
 248               next <- whileJust m
 249               return (x: next)
 250     Nothing -> return []
 251
 252 -- | Constant pool item format
 253 data CpInfo =
 254     CONSTANT_Class {nameIndex :: Word16}                                          -- ^ 7
 255   | CONSTANT_Fieldref {classIndex :: Word16, nameAndTypeIndex :: Word16}                -- ^ 9
 256   | CONSTANT_Methodref  {classIndex :: Word16, nameAndTypeIndex :: Word16}        -- ^ 10
 257   | CONSTANT_InterfaceMethodref {classIndex :: Word16, nameAndTypeIndex :: Word16}-- ^ 11
 258   | CONSTANT_String {stringIndex :: Word16}                                       -- ^ 8
 259   | CONSTANT_Integer {fourBytes :: Word32}                                            -- ^ 3
 260   | CONSTANT_Float Float                                                          -- ^ 4
 261   | CONSTANT_Long Word64                                                          -- ^ 5
 262   | CONSTANT_Double Double                                                        -- ^ 6
 263   | CONSTANT_NameAndType {nameIndex :: Word16, signatureIndex :: Word16}                -- ^ 12
 264   | CONSTANT_Utf8 {stringLength :: Word16, stringBytes :: B.ByteString}               -- ^ 1
 265   | CONSTANT_Unicode {stringLength :: Word16, stringBytes :: B.ByteString}          -- ^ 2
 266   deriving (Eq, Show)
 267
 268 instance Binary CpInfo where
 269   put (CONSTANT_Class i) = putWord8 7 >> put i
 270   put (CONSTANT_Fieldref i j) = putWord8 9 >> put i >> put j
 271   put (CONSTANT_Methodref i j) = putWord8 10 >> put i >> put j
 272   put (CONSTANT_InterfaceMethodref i j) = putWord8 11 >> put i >> put j
 273   put (CONSTANT_String i) = putWord8 8 >> put i
 274   put (CONSTANT_Integer x) = putWord8 3 >> put x
 275   put (CONSTANT_Float x)   = putWord8 4 >> putFloat32be x
 276   put (CONSTANT_Long x)    = putWord8 5 >> put x
 277   put (CONSTANT_Double x)  = putWord8 6 >> putFloat64be x
 278   put (CONSTANT_NameAndType i j) = putWord8 12 >> put i >> put j
 279   put (CONSTANT_Utf8 l bs) = putWord8 1 >> put l >> putLazyByteString bs
 280   put (CONSTANT_Unicode l bs) = putWord8 2 >> put l >> putLazyByteString bs
 281
 282   get = do
 283     !offset <- bytesRead
 284     tag <- getWord8
 285     case tag of
 286       1 -> do
 287         l <- get
 288         bs <- getLazyByteString (fromIntegral l)
 289         return $ CONSTANT_Utf8 l bs
 290       2 -> do
 291         l <- get
 292         bs <- getLazyByteString (fromIntegral l)
 293         return $ CONSTANT_Unicode l bs
 294       3  -> CONSTANT_Integer   <$> get
 295       4  -> CONSTANT_Float     <$> getFloat32be
 296       5  -> CONSTANT_Long      <$> get
 297       6  -> CONSTANT_Double    <$> getFloat64be
 298       7  -> CONSTANT_Class     <$> get
 299       8  -> CONSTANT_String    <$> get
 300       9  -> CONSTANT_Fieldref  <$> get <*> get
 301       10 -> CONSTANT_Methodref <$> get <*> get
 302       11 -> CONSTANT_InterfaceMethodref <$> get <*> get
 303       12 -> CONSTANT_NameAndType <$> get <*> get
 304       _  -> fail $ "Unknown constants pool entry tag: " ++ show tag
 305
 306 -- | Class field format
 307 data FieldInfo = FieldInfo {
 308   fieldAccessFlags :: Word16,
 309   fieldNameIndex :: Word16,
 310   fieldSignatureIndex :: Word16,
 311   fieldAttributesCount :: Word16,
 312   fieldAttributes :: [AttributeInfo] }
 313   deriving (Eq, Show)
 314
 315 instance Binary FieldInfo where
 316   put (FieldInfo {..}) = do
 317     put fieldAccessFlags
 318     put fieldNameIndex
 319     put fieldSignatureIndex
 320     put fieldAttributesCount
 321     forM_ fieldAttributes put
 322
 323   get = do
 324     af <- get
 325     ni <- get
 326     si <- get
 327     n <- get
 328     as <- replicateM (fromIntegral n) get
 329     return $ FieldInfo af ni si n as
 330
 331 -- | Class method format
 332 data MethodInfo = MethodInfo {
 333   methodAccessFlags :: Word16,
 334   methodNameIndex :: Word16,
 335   methodSignatureIndex :: Word16,
 336   methodAttributesCount :: Word16,
 337   methodAttributes :: [AttributeInfo] }
 338   deriving (Eq, Show)
 339
 340 instance Binary MethodInfo where
 341   put (MethodInfo {..}) = do
 342     put methodAccessFlags
 343     put methodNameIndex
 344     put methodSignatureIndex
 345     put methodAttributesCount
 346     forM_ methodAttributes put
 347
 348   get = do
 349     offset <- bytesRead
 350     af <- get
 351     ni <- get
 352     si <- get
 353     n <- get
 354     as <- replicateM (fromIntegral n) get
 355     return $ MethodInfo af ni si n as
 356
 357 -- | Any (class/ field/ method/ ...) attribute format.
 358 -- Some formats specify special formats for @attributeValue@.
 359 data AttributeInfo = AttributeInfo {
 360   attributeName :: Word16,
 361   attributeLength :: Word32,
 362   attributeValue :: B.ByteString }
 363   deriving (Eq, Show)
 364
 365 instance Binary AttributeInfo where
 366   put (AttributeInfo {..}) = do
 367     put attributeName
 368     putWord32be attributeLength
 369     putLazyByteString attributeValue
 370
 371   get = do
 372     offset <- bytesRead
 373     name <- get
 374     len <- getWord32be
 375     value <- getLazyByteString (fromIntegral len)
 376     return $ AttributeInfo name len value
 377
 378