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