JVM/ClassFile.hs

   1 {-# LANGUAGE RecordWildCards, BangPatterns, TypeFamilies, StandaloneDeriving, FlexibleContexts, FlexibleInstances, UndecidableInstances, TypeSynonymInstances #-}
   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   (Attribute (..),
   6    FieldType (..),
   7    FieldSignature, MethodSignature (..), ReturnSignature (..),
   8    ArgumentSignature (..),
   9    Pool, Link,
  10    Method (..), Field (..), Class (..),
  11    Constant (..),
  12    Pointers, Resolved,
  13    NameType (..),
  14    HasSignature (..), HasAttributes (..),
  15    AccessFlag (..), AccessFlags,
  16    Attributes (..),
  17    className
  18   )
  19   where
  20
  21 import Control.Monad
  22 import Control.Applicative
  23 import Data.Binary
  24 import Data.Binary.IEEE754
  25 import Data.Binary.Get
  26 import Data.Binary.Put
  27 import Data.Char
  28 import Data.List
  29 import qualified Data.Set as S
  30 import qualified Data.Map as M
  31 import qualified Data.ByteString.Lazy as B
  32 import Codec.Binary.UTF8.String hiding (encode, decode)
  33
  34 -- | Read one-byte Char
  35 getChar8 :: Get Char
  36 getChar8 = do
  37   x <- getWord8
  38   return $ chr (fromIntegral x)
  39
  40 toString :: B.ByteString -> String
  41 toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
  42
  43 type family Link s a
  44
  45 data Pointers = Pointers
  46
  47 data Resolved = Resolved
  48
  49 type instance Link Pointers a = Word16
  50
  51 type instance Link Resolved a = a
  52
  53 type family AccessFlags stage
  54
  55 type instance AccessFlags Pointers = Word16
  56
  57 type instance AccessFlags Resolved = S.Set AccessFlag
  58
  59 type family Attributes stage
  60
  61 type instance Attributes Pointers = [Attribute]
  62 type instance Attributes Resolved = M.Map B.ByteString B.ByteString
  63
  64 -- | Access flags. Used for classess, methods, variables.
  65 data AccessFlag =
  66     ACC_PUBLIC       -- ^ 0x0001 Visible for all
  67   | ACC_PRIVATE            -- ^ 0x0002 Visible only for defined class
  68   | ACC_PROTECTED        -- ^ 0x0004 Visible only for subclasses
  69   | ACC_STATIC       -- ^ 0x0008 Static method or variable
  70   | ACC_FINAL        -- ^ 0x0010 No further subclassing or assignments
  71   | ACC_SYNCHRONIZED -- ^ 0x0020 Uses monitors
  72   | ACC_VOLATILE           -- ^ 0x0040 Could not be cached
  73   | ACC_TRANSIENT        -- ^ 0x0080
  74   | ACC_NATIVE       -- ^ 0x0100 Implemented in other language
  75   | ACC_INTERFACE        -- ^ 0x0200 Class is interface
  76   | ACC_ABSTRACT           -- ^ 0x0400
  77   deriving (Eq, Show, Ord, Enum)
  78
  79 class HasSignature a where
  80   type Signature a
  81
  82 instance HasSignature Field where
  83   type Signature Field = FieldSignature
  84
  85 instance HasSignature Method where
  86   type Signature Method = MethodSignature
  87
  88 -- | Name and signature pair. Used for methods and fields.
  89 data NameType a = NameType {
  90   ntName :: B.ByteString,
  91   ntSignature :: Signature a }
  92
  93 instance Show (Signature a) => Show (NameType a) where
  94   show (NameType n t) = toString n ++ ": " ++ show t
  95
  96 deriving instance Eq (Signature a) => Eq (NameType a)
  97
  98 instance (Binary (Signature a)) => Binary (NameType a) where
  99   put (NameType n t) = putLazyByteString n >> put t
 100
 101   get = NameType <$> get <*> get
 102
 103 -- | Constant pool item
 104 data Constant stage =
 105     CClass B.ByteString
 106   | CField {refClass :: Link stage B.ByteString, fieldNameType :: Link stage (NameType Field)}
 107   | CMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)}
 108   | CIfaceMethod {refClass :: Link stage B.ByteString, nameType :: Link stage (NameType Method)}
 109   | CString (Link stage B.ByteString)
 110   | CInteger Word32
 111   | CFloat Float
 112   | CLong Integer
 113   | CDouble Double
 114   | CNameType (Link stage B.ByteString) (Link stage B.ByteString)
 115   | CUTF8 {getString :: B.ByteString}
 116   | CUnicode {getString :: B.ByteString}
 117
 118 className ::  Constant Resolved -> B.ByteString
 119 className (CClass s) = s
 120 className x = error $ "Not a class: " ++ show x
 121
 122 instance Show (Constant Resolved) where
 123   show (CClass name) = "class " ++ toString name
 124   show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt
 125   show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt
 126   show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt
 127   show (CString s) = "String \"" ++ toString s ++ "\""
 128   show (CInteger x) = show x
 129   show (CFloat x) = show x
 130   show (CLong x) = show x
 131   show (CDouble x) = show x
 132   show (CNameType name tp) = toString name ++ ": " ++ toString tp
 133   show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""
 134   show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""
 135
 136 -- | Constant pool
 137 type Pool stage = M.Map Word16 (Constant stage)
 138
 139 -- | Generic .class file format
 140 data Class stage = Class {
 141   magic :: Word32,                   -- ^ Magic value: 0xCAFEBABE
 142   minorVersion :: Word16,
 143   majorVersion :: Word16,
 144   constsPoolSize :: Word16,          -- ^ Number of items in constants pool
 145   constsPool :: Pool stage,            -- ^ Constants pool itself
 146   accessFlags :: AccessFlags stage,             -- ^ See @JVM.Types.AccessFlag@
 147   thisClass :: Link stage B.ByteString,               -- ^ Constants pool item index for this class
 148   superClass :: Link stage B.ByteString,              -- ^ --/-- for super class, zero for java.lang.Object
 149   interfacesCount :: Word16,         -- ^ Number of implemented interfaces
 150   interfaces :: [Link stage B.ByteString],            -- ^ Constants pool item indexes for implemented interfaces
 151   classFieldsCount :: Word16,        -- ^ Number of class fileds
 152   classFields :: [Field stage],        -- ^ Class fields
 153   classMethodsCount :: Word16,       -- ^ Number of class methods
 154   classMethods :: [Method stage],      -- ^ Class methods
 155   classAttributesCount :: Word16,    -- ^ Number of class attributes
 156   classAttributes :: Attributes stage -- ^ Class attributes
 157   }
 158
 159 deriving instance Eq (Constant Pointers)
 160 deriving instance Eq (Constant Resolved)
 161 deriving instance Show (Constant Pointers)
 162
 163 instance Binary (Class Pointers) where
 164   put (Class {..}) = do
 165     put magic
 166     put minorVersion
 167     put majorVersion
 168     put constsPoolSize
 169     forM_ (M.elems constsPool) put
 170     put accessFlags
 171     put thisClass
 172     put superClass
 173     put interfacesCount
 174     forM_ interfaces put
 175     put classFieldsCount
 176     forM_ classFields put
 177     put classMethodsCount
 178     forM_ classMethods put
 179     put classAttributesCount
 180     forM_ classAttributes put
 181
 182   get = do
 183     magic <- get
 184     minor <- get
 185     major <- get
 186     poolsize <- get
 187     pool <- replicateM (fromIntegral poolsize - 1) get
 188     af <- get
 189     this <- get
 190     super <- get
 191     interfacesCount <- get
 192     ifaces <- replicateM (fromIntegral interfacesCount) get
 193     classFieldsCount <- get
 194     classFields <- replicateM (fromIntegral classFieldsCount) get
 195     classMethodsCount <- get
 196     classMethods <- replicateM (fromIntegral classMethodsCount) get
 197     asCount <- get
 198     as <- replicateM (fromIntegral $ asCount) get
 199     let pool' = M.fromList $ zip [1..] pool
 200     return $ Class magic minor major poolsize pool' af this super
 201                interfacesCount ifaces classFieldsCount classFields classMethodsCount classMethods asCount as
 202
 203 -- | Field signature format
 204 data FieldType =
 205     SignedByte -- ^ B
 206   | CharByte   -- ^ C
 207   | DoubleType -- ^ D
 208   | FloatType  -- ^ F
 209   | IntType    -- ^ I
 210   | LongInt    -- ^ J
 211   | ShortInt   -- ^ S
 212   | BoolType   -- ^ Z
 213   | ObjectType String -- ^ L @{class name}@
 214   | Array (Maybe Int) FieldType -- ^ @[{type}@
 215   deriving (Eq)
 216
 217 instance Show FieldType where
 218   show SignedByte = "byte"
 219   show CharByte = "char"
 220   show DoubleType = "double"
 221   show FloatType = "float"
 222   show IntType = "int"
 223   show LongInt = "long"
 224   show ShortInt = "short"
 225   show BoolType = "bool"
 226   show (ObjectType s) = "Object " ++ s
 227   show (Array Nothing t) = show t ++ "[]"
 228   show (Array (Just n) t) = show t ++ "[" ++ show n ++ "]"
 229
 230 -- | Class field signature
 231 type FieldSignature = FieldType
 232
 233 -- | Try to read integer value from decimal representation
 234 getInt :: Get (Maybe Int)
 235 getInt = do
 236     s <- getDigits
 237     if null s
 238       then return Nothing
 239       else return $ Just (read s)
 240   where
 241     getDigits :: Get [Char]
 242     getDigits = do
 243       c <- lookAhead getChar8
 244       if isDigit c
 245         then do
 246              skip 1
 247              next <- getDigits
 248              return (c: next)
 249         else return []
 250
 251 putString :: String -> Put
 252 putString str = forM_ str put
 253
 254 instance Binary FieldType where
 255   put SignedByte = put 'B'
 256   put CharByte   = put 'C'
 257   put DoubleType = put 'D'
 258   put FloatType  = put 'F'
 259   put IntType    = put 'I'
 260   put LongInt    = put 'J'
 261   put ShortInt   = put 'S'
 262   put BoolType   = put 'Z'
 263   put (ObjectType name) = put 'L' >> putString name >> put ';'
 264   put (Array Nothing sig) = put '[' >> put sig
 265   put (Array (Just n) sig) = put '[' >> put (show n) >> put sig
 266
 267   get = do
 268     b <- getChar8
 269     case b of
 270       'B' -> return SignedByte
 271       'C' -> return CharByte
 272       'D' -> return DoubleType
 273       'F' -> return FloatType
 274       'I' -> return IntType
 275       'J' -> return LongInt
 276       'S' -> return ShortInt
 277       'Z' -> return BoolType
 278       'L' -> do
 279              name <- getToSemicolon
 280              return (ObjectType name)
 281       '[' -> do
 282              mbSize <- getInt
 283              sig <- get
 284              return (Array mbSize sig)
 285       _   -> fail $ "Unknown signature opening symbol: " ++ [b]
 286
 287 -- | Read string up to `;'
 288 getToSemicolon :: Get String
 289 getToSemicolon = do
 290   x <- get
 291   if x == ';'
 292     then return []
 293     else do
 294          next <- getToSemicolon
 295          return (x: next)
 296
 297 -- | Return value signature
 298 data ReturnSignature =
 299     Returns FieldType
 300   | ReturnsVoid
 301   deriving (Eq)
 302
 303 instance Show ReturnSignature where
 304   show (Returns t) = show t
 305   show ReturnsVoid = "Void"
 306
 307 instance Binary ReturnSignature where
 308   put (Returns sig) = put sig
 309   put ReturnsVoid   = put 'V'
 310
 311   get = do
 312     x <- lookAhead getChar8
 313     case x of
 314       'V' -> skip 1 >> return ReturnsVoid
 315       _   -> Returns <$> get
 316
 317 -- | Method argument signature
 318 type ArgumentSignature = FieldType
 319
 320 -- | Class method argument signature
 321 data MethodSignature =
 322     MethodSignature [ArgumentSignature] ReturnSignature
 323   deriving (Eq)
 324
 325 instance Show MethodSignature where
 326   show (MethodSignature args ret) = "(" ++ intercalate ", " (map show args) ++ ") returns " ++ show ret
 327
 328 instance Binary MethodSignature where
 329   put (MethodSignature args ret) = do
 330     put '('
 331     forM_ args put
 332     put ')'
 333     put ret
 334
 335   get =  do
 336     x <- getChar8
 337     when (x /= '(') $
 338       fail "Cannot parse method signature: no starting `(' !"
 339     args <- getArgs
 340     y <- getChar8
 341     when (y /= ')') $
 342       fail "Internal error: method signature without `)' !?"
 343     ret <- get
 344     return (MethodSignature args ret)
 345
 346 -- | Read arguments signatures (up to `)')
 347 getArgs :: Get [ArgumentSignature]
 348 getArgs = whileJust getArg
 349   where
 350     getArg :: Get (Maybe ArgumentSignature)
 351     getArg = do
 352       x <- lookAhead getChar8
 353       if x == ')'
 354         then return Nothing
 355         else Just <$> get
 356
 357 whileJust :: (Monad m) => m (Maybe a) -> m [a]
 358 whileJust m = do
 359   r <- m
 360   case r of
 361     Just x -> do
 362               next <- whileJust m
 363               return (x: next)
 364     Nothing -> return []
 365
 366 instance Binary (Constant Pointers) where
 367   put (CClass i) = putWord8 7 >> put i
 368   put (CField i j) = putWord8 9 >> put i >> put j
 369   put (CMethod i j) = putWord8 10 >> put i >> put j
 370   put (CIfaceMethod i j) = putWord8 11 >> put i >> put j
 371   put (CString i) = putWord8 8 >> put i
 372   put (CInteger x) = putWord8 3 >> put x
 373   put (CFloat x)   = putWord8 4 >> putFloat32be x
 374   put (CLong x)    = putWord8 5 >> put x
 375   put (CDouble x)  = putWord8 6 >> putFloat64be x
 376   put (CNameType i j) = putWord8 12 >> put i >> put j
 377   put (CUTF8 bs) = do
 378                    putWord8 1
 379                    put (fromIntegral (B.length bs) :: Word16)
 380                    putLazyByteString bs
 381   put (CUnicode bs) = do
 382                    putWord8 2
 383                    put (fromIntegral (B.length bs) :: Word16)
 384                    putLazyByteString bs
 385
 386   get = do
 387     !offset <- bytesRead
 388     tag <- getWord8
 389     case tag of
 390       1 -> do
 391         l <- get
 392         bs <- getLazyByteString (fromIntegral (l :: Word16))
 393         return $ CUTF8 bs
 394       2 -> do
 395         l <- get
 396         bs <- getLazyByteString (fromIntegral (l :: Word16))
 397         return $ CUnicode bs
 398       3  -> CInteger   <$> get
 399       4  -> CFloat     <$> getFloat32be
 400       5  -> CLong      <$> get
 401       6  -> CDouble    <$> getFloat64be
 402       7  -> CClass     <$> get
 403       8  -> CString    <$> get
 404       9  -> CField     <$> get <*> get
 405       10 -> CMethod    <$> get <*> get
 406       11 -> CIfaceMethod <$> get <*> get
 407       12 -> CNameType    <$> get <*> get
 408       _  -> fail $ "Unknown constants pool entry tag: " ++ show tag
 409
 410 -- | Class field format
 411 data Field stage = Field {
 412   fieldAccessFlags :: AccessFlags stage,
 413   fieldName :: Link stage B.ByteString,
 414   fieldSignature :: Link stage FieldSignature,
 415   fieldAttributesCount :: Word16,
 416   fieldAttributes :: Attributes stage }
 417
 418 deriving instance Eq (Field Pointers)
 419 deriving instance Eq (Field Resolved)
 420 deriving instance Show (Field Pointers)
 421 deriving instance Show (Field Resolved)
 422
 423 instance Binary (Field Pointers) where
 424   put (Field {..}) = do
 425     put fieldAccessFlags
 426     put fieldName
 427     put fieldSignature
 428     put fieldAttributesCount
 429     forM_ fieldAttributes put
 430
 431   get = do
 432     af <- get
 433     ni <- get
 434     si <- get
 435     n <- get
 436     as <- replicateM (fromIntegral n) get
 437     return $ Field af ni si n as
 438
 439 -- | Class method format
 440 data Method stage = Method {
 441   methodAccessFlags :: Attributes stage,
 442   methodName :: Link stage B.ByteString,
 443   methodSignature :: Link stage MethodSignature,
 444   methodAttributesCount :: Word16,
 445   methodAttributes :: Attributes stage }
 446
 447 deriving instance Eq (Method Pointers)
 448 deriving instance Eq (Method Resolved)
 449 deriving instance Show (Method Pointers)
 450 deriving instance Show (Method Resolved)
 451
 452 instance Binary (Method Pointers) where
 453   put (Method {..}) = do
 454     put methodAccessFlags
 455     put methodName
 456     put methodSignature
 457     put methodAttributesCount
 458     forM_ methodAttributes put
 459
 460   get = do
 461     offset <- bytesRead
 462     af <- get
 463     ni <- get
 464     si <- get
 465     n <- get
 466     as <- replicateM (fromIntegral n) get
 467     return $ Method af ni si n as
 468
 469 -- | Any (class/ field/ method/ ...) attribute format.
 470 -- Some formats specify special formats for @attributeValue@.
 471 data Attribute = Attribute {
 472   attributeName :: Word16,
 473   attributeLength :: Word32,
 474   attributeValue :: B.ByteString }
 475   deriving (Eq, Show)
 476
 477 instance Binary Attribute where
 478   put (Attribute {..}) = do
 479     put attributeName
 480     putWord32be attributeLength
 481     putLazyByteString attributeValue
 482
 483   get = do
 484     offset <- bytesRead
 485     name <- get
 486     len <- getWord32be
 487     value <- getLazyByteString (fromIntegral len)
 488     return $ Attribute name len value
 489
 490 class HasAttributes a where
 491   attributes :: a stage -> Attributes stage
 492
 493 instance HasAttributes Class where
 494   attributes = classAttributes
 495
 496 instance HasAttributes Field where
 497   attributes = fieldAttributes
 498
 499 instance HasAttributes Method where
 500   attributes = methodAttributes
 501