JVM/Converter.hs

   1 {-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, RecordWildCards, OverloadedStrings #-}
   2 -- | Functions to convert from low-level .class format representation and
   3 -- high-level Java classes, methods etc representation
   4 module JVM.Converter
   5   (parseClass, parseClassFile,
   6    convertClass, classFile,
   7    encodeClass,
   8    methodByName,
   9    attrByName,
  10    methodCode
  11   )
  12   where
  13
  14 import Control.Monad.Exception
  15 import Data.List
  16 import Data.Word
  17 import Data.Bits
  18 import Data.Binary
  19 import qualified Data.ByteString.Lazy as B
  20 import qualified Data.Set as S
  21 import qualified Data.Map as M
  22
  23 import JVM.ClassFile
  24 import JVM.Common
  25 import JVM.Exceptions
  26
  27 -- | Parse .class file data
  28 parseClass :: B.ByteString -> Class Direct
  29 parseClass bstr = convertClass $ decode bstr
  30
  31 -- | Parse class data from file
  32 parseClassFile :: FilePath -> IO (Class Direct)
  33 parseClassFile path = convertClass `fmap` decodeFile path
  34
  35 encodeClass :: (Class Direct) -> B.ByteString
  36 encodeClass cls = encode $ classFile cls
  37
  38 convertClass :: Class File -> Class Direct
  39 convertClass (Class {..}) =
  40   let pool = constantPoolArray constsPool
  41       superName = className $ pool ! superClass
  42   in Class {
  43       magic = 0xCAFEBABE,
  44       minorVersion = 0,
  45       majorVersion = 50,
  46       constsPoolSize = fromIntegral (M.size pool),
  47       constsPool = pool,
  48       accessFlags = convertAccess accessFlags,
  49       thisClass = className $ pool ! thisClass,
  50       superClass = if superClass == 0 then "" else superName,
  51       interfacesCount = interfacesCount,
  52       interfaces = map (\i -> className $ pool ! i) interfaces,
  53       classFieldsCount = classFieldsCount,
  54       classFields = map (convertField pool) classFields,
  55       classMethodsCount = classMethodsCount,
  56       classMethods = map (convertMethod pool) classMethods,
  57       classAttributesCount = classAttributesCount,
  58       classAttributes = convertAttrs pool classAttributes }
  59
  60 classFile :: Class Direct -> Class File
  61 classFile (Class {..}) = Class {
  62     magic = 0xCAFEBABE,
  63     minorVersion = 0,
  64     majorVersion = 50,
  65     constsPoolSize = fromIntegral (M.size poolInfo + 1),
  66     constsPool = poolInfo,
  67     accessFlags = access2word16 accessFlags,
  68     thisClass = force "this" $ poolClassIndex poolInfo thisClass,
  69     superClass = force "super" $ poolClassIndex poolInfo superClass,
  70     interfacesCount = fromIntegral (length interfaces),
  71     interfaces = map (force "ifaces" . poolIndex poolInfo) interfaces,
  72     classFieldsCount = fromIntegral (length classFields),
  73     classFields = map (fieldInfo poolInfo) classFields,
  74     classMethodsCount = fromIntegral (length classMethods),
  75     classMethods = map (methodInfo poolInfo) classMethods,
  76     classAttributesCount = fromIntegral $ arsize classAttributes,
  77     classAttributes = to (arlist classAttributes) }
  78   where
  79     poolInfo = toCPInfo constsPool
  80     to :: [(B.ByteString, B.ByteString)] -> Attributes File
  81     to pairs = AP (map (attrInfo poolInfo) pairs)
  82
  83 toCPInfo :: Pool Direct -> Pool File
  84 toCPInfo pool = result
  85   where
  86     result = M.map cpInfo pool
  87
  88     cpInfo :: Constant Direct -> Constant File
  89     cpInfo (CClass name) = CClass (force "class" $ poolIndex result name)
  90     cpInfo (CField cls name) =
  91       CField (force "field a" $ poolClassIndex result cls) (force "field b" $ poolNTIndex result name)
  92     cpInfo (CMethod cls name) =
  93       CMethod (force "method a" $ poolClassIndex result cls) (force ("method b: " ++ show name) $ poolNTIndex result name)
  94     cpInfo (CIfaceMethod cls name) =
  95       CIfaceMethod (force "iface method a" $ poolIndex result cls) (force "iface method b" $ poolNTIndex result name)
  96     cpInfo (CString s) = CString (force "string" $ poolIndex result s)
  97     cpInfo (CInteger x) = CInteger x
  98     cpInfo (CFloat x) = CFloat x
  99     cpInfo (CLong x) = CLong (fromIntegral x)
 100     cpInfo (CDouble x) = CDouble x
 101     cpInfo (CNameType n t) =
 102       CNameType (force "name" $ poolIndex result n) (force "type" $ poolIndex result t)
 103     cpInfo (CUTF8 s) = CUTF8 s
 104     cpInfo (CUnicode s) = CUnicode s
 105
 106 -- | Find index of given string in the list of constants
 107 poolIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16
 108 poolIndex list name = case findIndex test (M.elems list) of
 109                         Nothing -> throw (NoItemInPool name)
 110                         Just i ->  return $ fromIntegral $ i+1
 111   where
 112     test (CUTF8 s)    | s == name = True
 113     test (CUnicode s) | s == name = True
 114     test _                                  = False
 115
 116 -- | Find index of given string in the list of constants
 117 poolClassIndex :: (Throws NoItemInPool e) => Pool File -> B.ByteString -> EM e Word16
 118 poolClassIndex list name = case findIndex checkString (M.elems list) of
 119                         Nothing -> throw (NoItemInPool name)
 120                         Just i ->  case findIndex (checkClass $ fromIntegral $ i+1) (M.elems list) of
 121                                      Nothing -> throw (NoItemInPool $ i+1)
 122                                      Just j  -> return $ fromIntegral $ j+1
 123   where
 124     checkString (CUTF8 s)    | s == name = True
 125     checkString (CUnicode s) | s == name = True
 126     checkString _                                  = False
 127
 128     checkClass i (CClass x) | i == x = True
 129     checkClass _ _                           = False
 130
 131 poolNTIndex list x@(NameType n t) = do
 132     ni <- poolIndex list n
 133     ti <- poolIndex list (byteString t)
 134     case findIndex (check ni ti) (M.elems list) of
 135       Nothing -> throw (NoItemInPool x)
 136       Just i  -> return $ fromIntegral (i+1)
 137   where
 138     check ni ti (CNameType n' t')
 139       | (ni == n') && (ti == t') = True
 140     check _ _ _                  = False
 141
 142 fieldInfo :: Pool File -> Field Direct -> Field File
 143 fieldInfo pool (Field {..}) = Field {
 144     fieldAccessFlags = access2word16 fieldAccessFlags,
 145     fieldName = force "field name" $ poolIndex pool fieldName,
 146     fieldSignature = force "signature" $ poolIndex pool (encode fieldSignature),
 147     fieldAttributesCount = fromIntegral (arsize fieldAttributes),
 148     fieldAttributes = to (arlist fieldAttributes) }
 149   where
 150     to :: [(B.ByteString, B.ByteString)] -> Attributes File
 151     to pairs = AP (map (attrInfo pool) pairs)
 152
 153 methodInfo :: Pool File -> Method Direct -> Method File
 154 methodInfo pool (Method {..}) = Method {
 155     methodAccessFlags = access2word16 methodAccessFlags,
 156     methodName = force "method name" $ poolIndex pool methodName,
 157     methodSignature = force "method sig" $ poolIndex pool (encode methodSignature),
 158     methodAttributesCount = fromIntegral (arsize methodAttributes),
 159     methodAttributes = to (arlist methodAttributes) }
 160   where
 161     to :: [(B.ByteString, B.ByteString)] -> Attributes File
 162     to pairs = AP (map (attrInfo pool) pairs)
 163
 164 attrInfo :: Pool File -> (B.ByteString, B.ByteString) -> Attribute
 165 attrInfo pool (name, value) = Attribute {
 166   attributeName = force "attr name" $ poolIndex pool name,
 167   attributeLength = fromIntegral (B.length value),
 168   attributeValue = value }
 169
 170 constantPoolArray :: Pool File -> Pool Direct
 171 constantPoolArray ps = pool
 172   where
 173     pool :: Pool Direct
 174     pool = M.map convert ps
 175
 176     n = fromIntegral $ M.size ps
 177
 178     convertNameType :: (HasSignature a, Binary (Signature a)) => Word16 -> NameType a
 179     convertNameType i =
 180       let (CNameType n s) = pool ! i
 181       in  NameType n (decode s)
 182
 183     convert (CClass i) = CClass $ getString $ pool ! i
 184     convert (CField i j) = CField (className $ pool ! i) (convertNameType j)
 185     convert (CMethod i j) = CMethod (className $ pool ! i) (convertNameType j)
 186     convert (CIfaceMethod i j) = CIfaceMethod (className $ pool ! i) (convertNameType j)
 187     convert (CString i) = CString $ getString $ pool ! i
 188     convert (CInteger x) = CInteger x
 189     convert (CFloat x)   = CFloat x
 190     convert (CLong x)    = CLong (fromIntegral x)
 191     convert (CDouble x)  = CDouble x
 192     convert (CNameType i j) = CNameType (getString $ pool ! i) (getString $ pool ! j)
 193     convert (CUTF8 bs) = CUTF8 bs
 194     convert (CUnicode bs) = CUnicode bs
 195
 196 convertAccess :: AccessFlags File -> AccessFlags Direct
 197 convertAccess w = S.fromList $ concat $ zipWith (\i f -> if testBit w i then [f] else []) [0..] $ [
 198    ACC_PUBLIC,
 199    ACC_PRIVATE,
 200    ACC_PROTECTED,
 201    ACC_STATIC,
 202    ACC_FINAL,
 203    ACC_SYNCHRONIZED,
 204    ACC_VOLATILE,
 205    ACC_TRANSIENT,
 206    ACC_NATIVE,
 207    ACC_INTERFACE,
 208    ACC_ABSTRACT ]
 209
 210 access2word16 :: AccessFlags Direct -> AccessFlags File
 211 access2word16 fs = bitsOr $ map toBit $ S.toList fs
 212   where
 213     bitsOr = foldl (.|.) 0
 214     toBit f = 1 `shiftL` (fromIntegral $ fromEnum f)
 215
 216 convertField :: Pool Direct -> Field File -> Field Direct
 217 convertField pool (Field {..}) = Field {
 218   fieldAccessFlags = convertAccess fieldAccessFlags,
 219   fieldName = getString $ pool ! fieldName,
 220   fieldSignature = decode $ getString $ pool ! fieldSignature,
 221   fieldAttributesCount = fromIntegral (apsize fieldAttributes),
 222   fieldAttributes = convertAttrs pool fieldAttributes }
 223
 224 convertMethod :: Pool Direct -> Method File -> Method Direct
 225 convertMethod pool (Method {..}) = Method {
 226   methodAccessFlags = convertAccess methodAccessFlags,
 227   methodName = getString $ pool ! methodName,
 228   methodSignature = decode $ getString $ pool ! methodSignature,
 229   methodAttributesCount = fromIntegral (apsize methodAttributes),
 230   methodAttributes = convertAttrs pool methodAttributes }
 231
 232 convertAttrs :: Pool Direct -> Attributes File -> Attributes Direct
 233 convertAttrs pool (AP attrs) = AR (M.fromList $ map go attrs)
 234   where
 235     go :: Attribute -> (B.ByteString, B.ByteString)
 236     go (Attribute {..}) = (getString $ pool ! attributeName,
 237                            attributeValue)
 238
 239 -- | Try to get class method by name
 240 methodByName :: Class Direct -> B.ByteString -> Maybe (Method Direct)
 241 methodByName cls name =
 242   find (\m -> methodName m == name) (classMethods cls)
 243
 244 -- | Try to get object attribute by name
 245 attrByName :: (HasAttributes a) => a Direct -> B.ByteString -> Maybe B.ByteString
 246 attrByName x name =
 247   let (AR m) = attributes x
 248   in  M.lookup name m
 249
 250 -- | Try to get Code for class method (no Code for interface methods)
 251 methodCode :: Class Direct
 252            -> B.ByteString       -- ^ Method name
 253            -> Maybe B.ByteString
 254 methodCode cls name = do
 255   method <- methodByName cls name
 256   attrByName method "Code"
 257