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