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