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   (-- * About
   6    -- $about
   7    --
   8    -- * Internal class file structures
   9    Attribute (..),
  10    FieldType (..),
  11    -- * Signatures
  12    FieldSignature, MethodSignature (..), ReturnSignature (..),
  13    ArgumentSignature (..),
  14    -- * Stage types
  15    File, Direct,
  16    -- * Staged structures
  17    Pool, Link,
  18    Method (..), Field (..), Class (..),
  19    Constant (..),
  20    AccessFlag (..), AccessFlags,
  21    Attributes (..),
  22    defaultClass,
  23    -- * Misc
  24    HasSignature (..), HasAttributes (..),
  25    NameType (..),
  26    fieldNameType, methodNameType,
  27    lookupField, lookupMethod,
  28    toString,
  29    className,
  30    apsize, arsize, arlist
  31   )
  32   where
  33
  34 import Control.Monad
  35 import Control.Monad.Trans (lift)
  36 import Control.Applicative
  37 import qualified Control.Monad.State as St
  38 import Data.Binary
  39 import Data.Binary.IEEE754
  40 import Data.Binary.Get
  41 import Data.Binary.Put
  42 import Data.Char
  43 import Data.List
  44 import Data.Default
  45 import qualified Data.Set as S
  46 import qualified Data.Map as M
  47 import qualified Data.ByteString.Lazy as B
  48 import Codec.Binary.UTF8.String hiding (encode, decode)
  49
  50 -- $about
  51 --
  52 -- Java .class file uses constants pool, which stores almost all source-code-level
  53 -- constants (strings, integer literals etc), and also all identifiers (class,
  54 -- method, field names etc). All other structures contain indexes of constants in
  55 -- the pool instead of constants theirself.
  56 --
  57 -- It's not convient to use that indexes programmatically. So, .class file is represented
  58 -- at two stages: File and Direct. At File stage, all data structures contain only indexes,
  59 -- not constants theirself. When we read a class from a file, we get structure at File stage.
  60 -- We only can write File stage structure to file.
  61 --
  62 -- At Direct stage, structures conain constants, not indexes. Convertion functions (File <-> Direct)
  63 -- are located in the JVM.Converter module.
  64 --
  65
  66 -- | Read one-byte Char
  67 getChar8 :: Get Char
  68 getChar8 = do
  69   x <- getWord8
  70   return $ chr (fromIntegral x)
  71
  72 toString :: B.ByteString -> String
  73 toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
  74
  75 -- | File stage
  76 data File = File
  77
  78 -- | Direct representation stage
  79 data Direct = Direct
  80
  81 -- | Link to some object
  82 type family Link stage a
  83
  84 -- | At File stage, Link contain index of object in the constants pool.
  85 type instance Link File a = Word16
  86
  87 -- | At Direct stage, Link contain object itself.
  88 type instance Link Direct a = a
  89
  90 -- | Object (class, method, field …) access flags
  91 type family AccessFlags stage
  92
  93 -- | At File stage, access flags are represented as Word16
  94 type instance AccessFlags File = Word16
  95
  96 -- | At Direct stage, access flags are represented as set of flags.
  97 type instance AccessFlags Direct = S.Set AccessFlag
  98
  99 -- | Object (class, method, field) attributes
 100 data family Attributes stage
 101
 102 -- | At File stage, attributes are represented as list of Attribute structures.
 103 data instance Attributes File = AP {attributesList :: [Attribute]}
 104   deriving (Eq, Show)
 105
 106 instance Default (Attributes File) where
 107   def = AP []
 108
 109 -- | At Direct stage, attributes are represented as a Map.
 110 data instance Attributes Direct = AR (M.Map B.ByteString B.ByteString)
 111   deriving (Eq, Show)
 112
 113 instance Default (Attributes Direct) where
 114   def = AR M.empty
 115
 116 -- | Size of attributes set at Direct stage
 117 arsize :: Attributes Direct -> Int
 118 arsize (AR m) = M.size m
 119
 120 -- | Associative list of attributes at Direct stage
 121 arlist :: Attributes Direct -> [(B.ByteString, B.ByteString)]
 122 arlist (AR m) = M.assocs m
 123
 124 -- | Size of attributes set at File stage
 125 apsize :: Attributes File -> Int
 126 apsize (AP list) = length list
 127
 128 -- | Access flags. Used for classess, methods, variables.
 129 data AccessFlag =
 130     ACC_PUBLIC       -- ^ 0x0001 Visible for all
 131   | ACC_PRIVATE            -- ^ 0x0002 Visible only for defined class
 132   | ACC_PROTECTED        -- ^ 0x0004 Visible only for subclasses
 133   | ACC_STATIC       -- ^ 0x0008 Static method or variable
 134   | ACC_FINAL        -- ^ 0x0010 No further subclassing or assignments
 135   | ACC_SYNCHRONIZED -- ^ 0x0020 Uses monitors
 136   | ACC_VOLATILE           -- ^ 0x0040 Could not be cached
 137   | ACC_TRANSIENT        -- ^ 0x0080
 138   | ACC_NATIVE       -- ^ 0x0100 Implemented in other language
 139   | ACC_INTERFACE        -- ^ 0x0200 Class is interface
 140   | ACC_ABSTRACT           -- ^ 0x0400
 141   deriving (Eq, Show, Ord, Enum)
 142
 143 -- | Fields and methods have signatures.
 144 class (Binary (Signature a), Show (Signature a), Eq (Signature a))
 145     => HasSignature a where
 146   type Signature a
 147
 148 instance HasSignature Field where
 149   type Signature Field = FieldSignature
 150
 151 instance HasSignature Method where
 152   type Signature Method = MethodSignature
 153
 154 -- | Name and signature pair. Used for methods and fields.
 155 data NameType a = NameType {
 156   ntName :: B.ByteString,
 157   ntSignature :: Signature a }
 158
 159 instance (HasSignature a) => Show (NameType a) where
 160   show (NameType n t) = toString n ++ ": " ++ show t
 161
 162 deriving instance HasSignature a => Eq (NameType a)
 163
 164 instance HasSignature a => Binary (NameType a) where
 165   put (NameType n t) = putLazyByteString n >> put t
 166
 167   get = NameType <$> get <*> get
 168
 169 -- | Constant pool item
 170 data Constant stage =
 171     CClass (Link stage B.ByteString)
 172   | CField (Link stage B.ByteString) (Link stage (NameType Field))
 173   | CMethod (Link stage B.ByteString) (Link stage (NameType Method))
 174   | CIfaceMethod (Link stage B.ByteString) (Link stage (NameType Method))
 175   | CString (Link stage B.ByteString)
 176   | CInteger Word32
 177   | CFloat Float
 178   | CLong Word64
 179   | CDouble Double
 180   | CNameType (Link stage B.ByteString) (Link stage B.ByteString)
 181   | CUTF8 {getString :: B.ByteString}
 182   | CUnicode {getString :: B.ByteString}
 183
 184 -- | Name of the CClass. Error on any other constant.
 185 className ::  Constant Direct -> B.ByteString
 186 className (CClass s) = s
 187 className x = error $ "Not a class: " ++ show x
 188
 189 instance Show (Constant Direct) where
 190   show (CClass name) = "class " ++ toString name
 191   show (CField cls nt) = "field " ++ toString cls ++ "." ++ show nt
 192   show (CMethod cls nt) = "method " ++ toString cls ++ "." ++ show nt
 193   show (CIfaceMethod cls nt) = "interface method " ++ toString cls ++ "." ++ show nt
 194   show (CString s) = "String \"" ++ toString s ++ "\""
 195   show (CInteger x) = show x
 196   show (CFloat x) = show x
 197   show (CLong x) = show x
 198   show (CDouble x) = show x
 199   show (CNameType name tp) = toString name ++ ": " ++ toString tp
 200   show (CUTF8 s) = "UTF8 \"" ++ toString s ++ "\""
 201   show (CUnicode s) = "Unicode \"" ++ toString s ++ "\""
 202
 203 -- | Constant pool
 204 type Pool stage = M.Map Word16 (Constant stage)
 205
 206 -- | Generic .class file format
 207 data Class stage = Class {
 208   magic :: Word32,                   -- ^ Magic value: 0xCAFEBABE
 209   minorVersion :: Word16,
 210   majorVersion :: Word16,
 211   constsPoolSize :: Word16,          -- ^ Number of items in constants pool
 212   constsPool :: Pool stage,            -- ^ Constants pool itself
 213   accessFlags :: AccessFlags stage,             -- ^ See @JVM.Types.AccessFlag@
 214   thisClass :: Link stage B.ByteString,               -- ^ Constants pool item index for this class
 215   superClass :: Link stage B.ByteString,              -- ^ --/-- for super class, zero for java.lang.Object
 216   interfacesCount :: Word16,         -- ^ Number of implemented interfaces
 217   interfaces :: [Link stage B.ByteString],            -- ^ Constants pool item indexes for implemented interfaces
 218   classFieldsCount :: Word16,        -- ^ Number of class fileds
 219   classFields :: [Field stage],        -- ^ Class fields
 220   classMethodsCount :: Word16,       -- ^ Number of class methods
 221   classMethods :: [Method stage],      -- ^ Class methods
 222   classAttributesCount :: Word16,    -- ^ Number of class attributes
 223   classAttributes :: Attributes stage -- ^ Class attributes
 224   }
 225
 226 deriving instance Eq (Class File)
 227 deriving instance Eq (Class Direct)
 228 deriving instance Show (Class File)
 229 deriving instance Show (Class Direct)
 230
 231 deriving instance Eq (Constant File)
 232 deriving instance Eq (Constant Direct)
 233 deriving instance Show (Constant File)
 234
 235 -- | Default (empty) class file definition.
 236 defaultClass :: (Default (AccessFlags stage), Default (Link stage B.ByteString), Default (Attributes stage))
 237              => Class stage
 238 defaultClass = Class {
 239   magic = 0xCAFEBABE,
 240   minorVersion = 0,
 241   majorVersion = 50,
 242   constsPoolSize = 0,
 243   constsPool = def,
 244   accessFlags = def,
 245   thisClass = def,
 246   superClass = def,
 247   interfacesCount = 0,
 248   interfaces = [],
 249   classFieldsCount = 0,
 250   classFields = [],
 251   classMethodsCount = 0,
 252   classMethods = [],
 253   classAttributesCount = 0,
 254   classAttributes = def }
 255
 256 instance Binary (Class File) where
 257   put (Class {..}) = do
 258     put magic
 259     put minorVersion
 260     put majorVersion
 261     putPool constsPool
 262     put accessFlags
 263     put thisClass
 264     put superClass
 265     put interfacesCount
 266     forM_ interfaces put
 267     put classFieldsCount
 268     forM_ classFields put
 269     put classMethodsCount
 270     forM_ classMethods put
 271     put classAttributesCount
 272     forM_ (attributesList classAttributes) put
 273
 274   get = do
 275     magic <- get
 276     when (magic /= 0xCAFEBABE) $
 277       fail $ "Invalid .class file MAGIC value: " ++ show magic
 278     minor <- get
 279     major <- get
 280     when (major > 50) $
 281       fail $ "Too new .class file format: " ++ show major
 282     poolsize <- getWord16be
 283     pool <- getPool (poolsize - 1)
 284     af <-  get
 285     this <- get
 286     super <- get
 287     interfacesCount <- get
 288     ifaces <- replicateM (fromIntegral interfacesCount) get
 289     classFieldsCount <- getWord16be
 290     classFields <- replicateM (fromIntegral classFieldsCount) get
 291     classMethodsCount <- get
 292     classMethods <- replicateM (fromIntegral classMethodsCount) get
 293     asCount <- get
 294     as <- replicateM (fromIntegral $ asCount) get
 295     return $ Class magic minor major poolsize pool af this super
 296                interfacesCount ifaces classFieldsCount classFields
 297                classMethodsCount classMethods asCount (AP as)
 298
 299 -- | Field signature format
 300 data FieldType =
 301     SignedByte -- ^ B
 302   | CharByte   -- ^ C
 303   | DoubleType -- ^ D
 304   | FloatType  -- ^ F
 305   | IntType    -- ^ I
 306   | LongInt    -- ^ J
 307   | ShortInt   -- ^ S
 308   | BoolType   -- ^ Z
 309   | ObjectType String -- ^ L @{class name}@
 310   | Array (Maybe Int) FieldType -- ^ @[{type}@
 311   deriving (Eq)
 312
 313 instance Show FieldType where
 314   show SignedByte = "byte"
 315   show CharByte = "char"
 316   show DoubleType = "double"
 317   show FloatType = "float"
 318   show IntType = "int"
 319   show LongInt = "long"
 320   show ShortInt = "short"
 321   show BoolType = "bool"
 322   show (ObjectType s) = "Object " ++ s
 323   show (Array Nothing t) = show t ++ "[]"
 324   show (Array (Just n) t) = show t ++ "[" ++ show n ++ "]"
 325
 326 -- | Class field signature
 327 type FieldSignature = FieldType
 328
 329 -- | Try to read integer value from decimal representation
 330 getInt :: Get (Maybe Int)
 331 getInt = do
 332     s <- getDigits
 333     if null s
 334       then return Nothing
 335       else return $ Just (read s)
 336   where
 337     getDigits :: Get [Char]
 338     getDigits = do
 339       c <- lookAhead getChar8
 340       if isDigit c
 341         then do
 342              skip 1
 343              next <- getDigits
 344              return (c: next)
 345         else return []
 346
 347 putString :: String -> Put
 348 putString str = forM_ str put
 349
 350 instance Binary FieldType where
 351   put SignedByte = put 'B'
 352   put CharByte   = put 'C'
 353   put DoubleType = put 'D'
 354   put FloatType  = put 'F'
 355   put IntType    = put 'I'
 356   put LongInt    = put 'J'
 357   put ShortInt   = put 'S'
 358   put BoolType   = put 'Z'
 359   put (ObjectType name) = put 'L' >> putString name >> put ';'
 360   put (Array Nothing sig) = put '[' >> put sig
 361   put (Array (Just n) sig) = put '[' >> put (show n) >> put sig
 362
 363   get = do
 364     b <- getChar8
 365     case b of
 366       'B' -> return SignedByte
 367       'C' -> return CharByte
 368       'D' -> return DoubleType
 369       'F' -> return FloatType
 370       'I' -> return IntType
 371       'J' -> return LongInt
 372       'S' -> return ShortInt
 373       'Z' -> return BoolType
 374       'L' -> do
 375              name <- getToSemicolon
 376              return (ObjectType name)
 377       '[' -> do
 378              mbSize <- getInt
 379              sig <- get
 380              return (Array mbSize sig)
 381       _   -> fail $ "Unknown signature opening symbol: " ++ [b]
 382
 383 -- | Read string up to `;'
 384 getToSemicolon :: Get String
 385 getToSemicolon = do
 386   x <- get
 387   if x == ';'
 388     then return []
 389     else do
 390          next <- getToSemicolon
 391          return (x: next)
 392
 393 -- | Return value signature
 394 data ReturnSignature =
 395     Returns FieldType
 396   | ReturnsVoid
 397   deriving (Eq)
 398
 399 instance Show ReturnSignature where
 400   show (Returns t) = show t
 401   show ReturnsVoid = "Void"
 402
 403 instance Binary ReturnSignature where
 404   put (Returns sig) = put sig
 405   put ReturnsVoid   = put 'V'
 406
 407   get = do
 408     x <- lookAhead getChar8
 409     case x of
 410       'V' -> skip 1 >> return ReturnsVoid
 411       _   -> Returns <$> get
 412
 413 -- | Method argument signature
 414 type ArgumentSignature = FieldType
 415
 416 -- | Class method argument signature
 417 data MethodSignature =
 418     MethodSignature [ArgumentSignature] ReturnSignature
 419   deriving (Eq)
 420
 421 instance Show MethodSignature where
 422   show (MethodSignature args ret) = "(" ++ intercalate ", " (map show args) ++ ") returns " ++ show ret
 423
 424 instance Binary MethodSignature where
 425   put (MethodSignature args ret) = do
 426     put '('
 427     forM_ args put
 428     put ')'
 429     put ret
 430
 431   get =  do
 432     x <- getChar8
 433     when (x /= '(') $
 434       fail "Cannot parse method signature: no starting `(' !"
 435     args <- getArgs
 436     y <- getChar8
 437     when (y /= ')') $
 438       fail "Internal error: method signature without `)' !?"
 439     ret <- get
 440     return (MethodSignature args ret)
 441
 442 -- | Read arguments signatures (up to `)')
 443 getArgs :: Get [ArgumentSignature]
 444 getArgs = whileJust getArg
 445   where
 446     getArg :: Get (Maybe ArgumentSignature)
 447     getArg = do
 448       x <- lookAhead getChar8
 449       if x == ')'
 450         then return Nothing
 451         else Just <$> get
 452
 453 whileJust :: (Monad m) => m (Maybe a) -> m [a]
 454 whileJust m = do
 455   r <- m
 456   case r of
 457     Just x -> do
 458               next <- whileJust m
 459               return (x: next)
 460     Nothing -> return []
 461
 462 long (CLong _)   = True
 463 long (CDouble _) = True
 464 long _           = False
 465
 466 putPool :: Pool File -> Put
 467 putPool pool = do
 468     let list = M.elems pool
 469         d = length $ filter long list
 470     putWord16be $ fromIntegral (M.size pool + d + 1)
 471     forM_ list putC
 472   where
 473     putC (CClass i) = putWord8 7 >> put i
 474     putC (CField i j) = putWord8 9 >> put i >> put j
 475     putC (CMethod i j) = putWord8 10 >> put i >> put j
 476     putC (CIfaceMethod i j) = putWord8 11 >> put i >> put j
 477     putC (CString i) = putWord8 8 >> put i
 478     putC (CInteger x) = putWord8 3 >> put x
 479     putC (CFloat x)   = putWord8 4 >> putFloat32be x
 480     putC (CLong x)    = putWord8 5 >> put x
 481     putC (CDouble x)  = putWord8 6 >> putFloat64be x
 482     putC (CNameType i j) = putWord8 12 >> put i >> put j
 483     putC (CUTF8 bs) = do
 484                      putWord8 1
 485                      put (fromIntegral (B.length bs) :: Word16)
 486                      putLazyByteString bs
 487     putC (CUnicode bs) = do
 488                      putWord8 2
 489                      put (fromIntegral (B.length bs) :: Word16)
 490                      putLazyByteString bs
 491
 492 getPool :: Word16 -> Get (Pool File)
 493 getPool n = do
 494     items <- St.evalStateT go 1
 495     return $ M.fromList items
 496   where
 497     go :: St.StateT Word16 Get [(Word16, Constant File)]
 498     go = do
 499       i <- St.get
 500       if i > n
 501         then return []
 502         else do
 503           c <- lift getC
 504           let i' = if long c
 505                       then i+2
 506                       else i+1
 507           St.put i'
 508           next <- go
 509           return $ (i,c): next
 510
 511     getC = do
 512       !offset <- bytesRead
 513       tag <- getWord8
 514       case tag of
 515         1 -> do
 516           l <- get
 517           bs <- getLazyByteString (fromIntegral (l :: Word16))
 518           return $ CUTF8 bs
 519         2 -> do
 520           l <- get
 521           bs <- getLazyByteString (fromIntegral (l :: Word16))
 522           return $ CUnicode bs
 523         3  -> CInteger   <$> get
 524         4  -> CFloat     <$> getFloat32be
 525         5  -> CLong      <$> get
 526         6  -> CDouble    <$> getFloat64be
 527         7  -> CClass     <$> get
 528         8  -> CString    <$> get
 529         9  -> CField     <$> get <*> get
 530         10 -> CMethod    <$> get <*> get
 531         11 -> CIfaceMethod <$> get <*> get
 532         12 -> CNameType    <$> get <*> get
 533         _  -> fail $ "Unknown constants pool entry tag: " ++ show tag
 534 --         _ -> return $ CInteger 0
 535
 536 -- | Class field format
 537 data Field stage = Field {
 538   fieldAccessFlags :: AccessFlags stage,
 539   fieldName :: Link stage B.ByteString,
 540   fieldSignature :: Link stage FieldSignature,
 541   fieldAttributesCount :: Word16,
 542   fieldAttributes :: Attributes stage }
 543
 544 deriving instance Eq (Field File)
 545 deriving instance Eq (Field Direct)
 546 deriving instance Show (Field File)
 547 deriving instance Show (Field Direct)
 548
 549 lookupField :: B.ByteString -> Class Direct -> Maybe (Field Direct)
 550 lookupField name cls = look (classFields cls)
 551   where
 552     look [] = Nothing
 553     look (f:fs)
 554       | fieldName f == name = Just f
 555       | otherwise           = look fs
 556
 557 fieldNameType :: Field Direct -> NameType Field
 558 fieldNameType f = NameType (fieldName f) (fieldSignature f)
 559
 560 instance Binary (Field File) where
 561   put (Field {..}) = do
 562     put fieldAccessFlags
 563     put fieldName
 564     put fieldSignature
 565     put fieldAttributesCount
 566     forM_ (attributesList fieldAttributes) put
 567
 568   get = do
 569     af <- get
 570     ni <- getWord16be
 571     si <- get
 572     n <- getWord16be
 573     as <- replicateM (fromIntegral n) get
 574     return $ Field af ni si n (AP as)
 575
 576 -- | Class method format
 577 data Method stage = Method {
 578   methodAccessFlags :: AccessFlags stage,
 579   methodName :: Link stage B.ByteString,
 580   methodSignature :: Link stage MethodSignature,
 581   methodAttributesCount :: Word16,
 582   methodAttributes :: Attributes stage }
 583
 584 deriving instance Eq (Method File)
 585 deriving instance Eq (Method Direct)
 586 deriving instance Show (Method File)
 587 deriving instance Show (Method Direct)
 588
 589 methodNameType :: Method Direct -> NameType Method
 590 methodNameType m = NameType (methodName m) (methodSignature m)
 591
 592 lookupMethod :: B.ByteString -> Class Direct -> Maybe (Method Direct)
 593 lookupMethod name cls = look (classMethods cls)
 594   where
 595     look [] = Nothing
 596     look (f:fs)
 597       | methodName f == name = Just f
 598       | otherwise           = look fs
 599
 600 instance Binary (Method File) where
 601   put (Method {..}) = do
 602     put methodAccessFlags
 603     put methodName
 604     put methodSignature
 605     put methodAttributesCount
 606     forM_ (attributesList methodAttributes) put
 607
 608   get = do
 609     offset <- bytesRead
 610     af <- get
 611     ni <- get
 612     si <- get
 613     n <- get
 614     as <- replicateM (fromIntegral n) get
 615     return $ Method {
 616                methodAccessFlags = af,
 617                methodName = ni,
 618                methodSignature = si,
 619                methodAttributesCount = n,
 620                methodAttributes = AP as }
 621
 622 -- | Any (class/ field/ method/ ...) attribute format.
 623 -- Some formats specify special formats for @attributeValue@.
 624 data Attribute = Attribute {
 625   attributeName :: Word16,
 626   attributeLength :: Word32,
 627   attributeValue :: B.ByteString }
 628   deriving (Eq, Show)
 629
 630 instance Binary Attribute where
 631   put (Attribute {..}) = do
 632     put attributeName
 633     putWord32be attributeLength
 634     putLazyByteString attributeValue
 635
 636   get = do
 637     offset <- bytesRead
 638     name <- getWord16be
 639     len <- getWord32be
 640     value <- getLazyByteString (fromIntegral len)
 641     return $ Attribute name len value
 642
 643 class HasAttributes a where
 644   attributes :: a stage -> Attributes stage
 645
 646 instance HasAttributes Class where
 647   attributes = classAttributes
 648
 649 instance HasAttributes Field where
 650   attributes = fieldAttributes
 651
 652 instance HasAttributes Method where
 653   attributes = methodAttributes
 654