diff --git a/JarFind.hs b/JarFind.hs new file mode 100644 --- /dev/null +++ b/JarFind.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE BangPatterns #-} + +module JarFind +( Class(..) +, Member(..) +, Access(..) +, ClassFileSource(..) +, Location(..) +, parseClassFile +, parseFileSource +) where + +import Codec.Archive.Zip +import qualified Data.ByteString.Lazy as B +import Control.Monad +import Control.Applicative ((<$>)) +import Data.List +import Data.Bits +import Data.Maybe +import Data.Char + +import Data.Array.ST +import Data.Array.Unboxed + +import Data.Binary +import Data.Binary.Get + +import System.Console.GetOpt +import System.Environment + +import Text.Regex.TDFA + +data Class = Class { clsName :: String + , clsAccess :: Access + , clsIsInterface :: Bool + , clsMembers :: [Member] + } + deriving Show + +data Member = Method { mName :: String + , mAccess :: Access + , mSig :: String + } + | Field { mName :: String + , mAccess :: Access + , mSig :: String + } + deriving Show + +data Access = Public + | Private + | Protected + | Package + deriving Eq + +instance Show Access where + show Public = "public" + show Private = "private" + show Protected = "protected" + show Package = "" + +---------------------------------------------------------------- +-- CLASS FILE PARSING -- +---------------------------------------------------------------- + +-- Constant pool stuff + +data ConstantPool = ConstantPool + { cpPos :: UArray Word16 Word16 + , cpData :: B.ByteString + } + +getUTF8FromCP :: ConstantPool -> Word16 -> B.ByteString +getUTF8FromCP cp@(ConstantPool cpPos cpData) i = res + where pos = cpPos!i + begin = fromIntegral $ pos+3 + len = fromIntegral $ getWord16FromCP cp (pos+1) + res = B.take len (B.drop begin cpData) + +getWord16FromCP :: Integral a => ConstantPool -> a -> Word16 +getWord16FromCP (ConstantPool cpPos cpData) iData = + (do skip (fromIntegral iData); readWord16) `runGet` cpData + +-- The very class file parser + +readByte :: Get Word8 +readByte = get + +readWord16 :: Get Word16 +readWord16 = get + +readInt16 :: Get Int +readInt16 = fromIntegral `liftM` readWord16 + +readWord32 :: Get Word32 +readWord32 = get + +parseClassFile :: B.ByteString -> Class +parseClassFile = runGet $ do + skip (4 + 2 + 2) -- magic, minor_version, major_version + cpSize <- readWord16 + cp <- parseConstantPool cpSize + accessFlags <- readWord16 + thisClass <- readWord16 + let classNameIndex = getWord16FromCP cp (1 + (cpPos cp)!thisClass) + let className = getUTF8FromCP cp classNameIndex + let access = flagsToAccess accessFlags + let isInterface = (0 /= accessFlags .&. 0x0200) + skip 2 -- super_class + ifCount <- readInt16 -- interfaces_count + skip (2 * ifCount) -- u2 interfaces[interfaces_count] + fieldCount <- readInt16 + fields <- replicateM fieldCount (parseMember cp Field decryptType) + methodCount <- readInt16 + methods <- replicateM methodCount (parseMember cp Method decryptSig) + return (Class (bToString className) access isInterface (fields++methods)) + +parseMember :: ConstantPool -> + (String -> Access -> String -> Member) -> + (B.ByteString -> B.ByteString) -> + Get Member +parseMember cp ctor decryptor = do + accessFlags <- readWord16 + nameIndex <- readWord16 + descrIndex <- readWord16 + attCount <- readInt16 + replicateM attCount $ do + skip 2 + attLen <- readWord32 + skip (fromIntegral attLen) + + return $ ctor (bToString (getUTF8FromCP cp nameIndex)) + (flagsToAccess accessFlags) + (bToString (decryptor (getUTF8FromCP cp descrIndex))) + +-- A strict unboxed list and conversion to an UArray with STUArray's +data List' a = Nil' + | (:!) !a + !(List' a) +infixr 5 :! +toArray' (lo,hi) list = do + arr <- newArray_ (lo,hi) + fill hi list arr + return arr +fill i list arr = fill' i list + where fill' !i (b:!bs') = writeArray arr i b >> fill' (i-1) bs' + fill' !i Nil' = return () + +parseConstantPool :: Word16 -> Get ConstantPool +parseConstantPool n = do + bs <- getRemainingLazyByteString + cpPosList <- parseConstantPool' (n-1) 0 (0 :! Nil') + cpPosArray <- return $ runSTUArray (toArray' (0,n-1) cpPosList) + return (ConstantPool cpPosArray bs) + +parseConstantPool' :: Word16 -> Word16 -> List' Word16 -> Get (List' Word16) +parseConstantPool' 0 pos res = return res +parseConstantPool' n pos res = do + tag <- readByte + let skipRet n = do skip n; return n + delta <- fromIntegral `liftM` case tag of + 1 -> do len <- readInt16 -- CONSTANT_Utf8 + skip len + return (len+2) + 2 -> error "Tag 2 is unused" + 3 -> skipRet 4 -- CONSTANT_Integer + 4 -> skipRet 4 -- CONSTANT_Float + 5 -> skipRet 8 -- CONSTANT_Long (2 slots) + 6 -> skipRet 8 -- CONSTANT_Double (2 slots) + 7 -> skipRet 2 -- CONSTANT_Class + 8 -> skipRet 2 -- CONSTANT_String + 9 -> skipRet 4 -- CONSTANT_Fieldref + 10 -> skipRet 4 -- CONSTANT_Methodref + 11 -> skipRet 4 -- CONSTANT_InterfaceMethodref + 12 -> skipRet 4 -- CONSTANT_NameAndType + _ -> error $ "Unknown tag "++show tag++" at position "++show pos++" in CP" + let n' = if (tag==5 || tag==6) then (n-2) else (n-1) + let p = pos+delta+1 + p `seq` case tag of + 5 -> parseConstantPool' n' p (pos :! (0 :! res)) + 6 -> parseConstantPool' n' p (pos :! (0 :! res)) + _ -> parseConstantPool' n' p (pos :! res) + + +-- Field/method type decryption + +decryptType :: B.ByteString -> B.ByteString +decryptType = onString (fst . decryptType') + +decryptType' :: String -> (String, String) +decryptType' "" = ("","") +decryptType' (a:s) = case a of + 'B' -> ("byte",s) + 'C' -> ("char",s) + 'D' -> ("double",s) + 'F' -> ("float",s) + 'I' -> ("int",s) + 'J' -> ("long",s) + 'S' -> ("short",s) + 'Z' -> ("boolean",s) + 'V' -> ("void",s) + '[' -> let (t,s') = decryptType' s in (t++"[]",s') + 'L' -> go "" s + where go c (';':s) = (reverse c, s) + go c ('/':s) = go ('.':c) s + go c (a:s) = go (a:c) s + go _ _ = error $ "Unrecognized type ending with "++s + _ -> error $ "Unrecognized type: "++s + +decryptSig :: B.ByteString -> B.ByteString +decryptSig = onString decryptSig' + +decryptSig' :: String -> String +decryptSig' s = concat (if null parTypes + then ["()"] + else (intersperse " -> " parTypes)) + ++ " -> " ++ retType + where ('(':params, ')':ret) = break (==')') s + retType = fst (decryptType' ret) + parTypes = go [] params + go ps "" = reverse ps + go ps s = let (p, s') = decryptType' s in go (p:ps) s' + + +flagsToAccess :: Word16 -> Access +flagsToAccess w | 0 /= w.&.0x0001 = Public + | 0 /= w.&.0x0002 = Private + | 0 /= w.&.0x0004 = Protected + | otherwise = Package + + +bToString :: B.ByteString -> String +bToString = map (chr . fromIntegral) . B.unpack + +bFromString :: String -> B.ByteString +bFromString = B.pack . map (fromIntegral . ord) + +onString :: (String -> String) -> (B.ByteString -> B.ByteString) +onString f = bFromString . f . bToString + +data ClassFileSource = ClassFile { path :: FilePath } + | JarFile { path :: FilePath } + | ClassPath { paths :: [ClassFileSource] } + +data Location = InFile FilePath + | InJar { jarPath :: FilePath + , innerPath :: FilePath + } + deriving Show + +parseFileSource :: ClassFileSource -> IO [(Location, Class)] +parseFileSource (ClassFile path) = do + f <- parseClassFile <$> B.readFile path + return [(InFile path, f)] +parseFileSource (JarFile jar) = do + archive <- toArchive <$> B.readFile jar + return [(InJar jar fileName, parseClassFile $ fromEntry entry) + | entry <- zEntries archive, + let fileName = eRelativePath entry, + ".class" `isSuffixOf` fileName] +parseFileSource (ClassPath paths) = concat <$> (sequence $ parseFileSource <$> paths) diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE BangPatterns #-} - module Main (main) where import Codec.Archive.Zip import qualified Data.ByteString.Lazy as B import Control.Monad +import Control.Applicative ((<$>)) import Data.List import Data.Bits import Data.Maybe @@ -20,59 +19,22 @@ import System.Environment import Text.Regex.TDFA - -bToString :: B.ByteString -> String -bToString = map (chr . fromIntegral) . B.unpack - -bFromString :: String -> B.ByteString -bFromString = B.pack . map (fromIntegral . ord) - -onString :: (String -> String) -> (B.ByteString -> B.ByteString) -onString f = bFromString . f . bToString - -data Access = Public | Private | Protected | Package deriving (Eq) - -instance Show Access where - show Public = "public" - show Private = "private" - show Protected = "protected" - show Package = "" - - -data Class = Class { - clsAccess :: Access, - clsMembers :: [Member], - clsName :: B.ByteString, - clsIsInterface :: Bool -} deriving (Show) - -data Member = Method { mAccess :: Access, mName :: B.ByteString, mSig :: B.ByteString } - | Field { mAccess :: Access, mName :: B.ByteString, mSig :: B.ByteString } - deriving (Show) +import JarFind -- Types related to cmdline arguments -data ClassFileSource = ClassFile { path :: FilePath } - | JarFile { path :: FilePath } - | ClassPath { paths :: [ClassFileSource] } - -data Location = InFile FilePath - | InJar { jarPath :: FilePath, innerPath :: FilePath } - deriving (Show) - newtype SearchSource = SearchSource (Class->Bool) data SearchTarget = SearchClass | SearchMember (Member->Bool) -data Args = Args { - dataSource :: [ClassFileSource], - searchSource :: SearchSource, - searchTarget :: SearchTarget -} +data Args = Args { dataSource :: [ClassFileSource] + , searchSource :: SearchSource + , searchTarget :: SearchTarget + } data Result = FoundClass Location Class | FoundMember Location Class Member - deriving (Show) + deriving Show ---------------------------------------------------------------- @@ -80,24 +42,23 @@ ---------------------------------------------------------------- -data PlainArgs = PlainArgs { - typeRegex :: Maybe String, - memberRegex :: Maybe String, - typeAccess :: Maybe String, - memberAccess :: Maybe String, - target :: Maybe String -} +data PlainArgs = PlainArgs { typeRegex :: Maybe String + , memberRegex :: Maybe String + , typeAccess :: Maybe String + , memberAccess :: Maybe String + , target :: Maybe String + } emptyArgs :: PlainArgs emptyArgs = PlainArgs Nothing Nothing Nothing Nothing Nothing -data MemberKind = FieldKind | MethodKind deriving (Eq) +data MemberKind = FieldKind | MethodKind deriving Eq parseArgs :: PlainArgs -> [String] -> Args parseArgs a paths = Args dataSource (SearchSource typeFilter) searchTarget - where searchTarget = case (memberRegex a,memberAccess a,target a) of - (Nothing,Nothing,Nothing) -> SearchClass - _ -> SearchMember memberFilter + where searchTarget = case (memberRegex a, memberAccess a, target a) of + (Nothing, Nothing, Nothing) -> SearchClass + _ -> SearchMember memberFilter searchMembers = isJust (memberRegex a) @@ -114,34 +75,36 @@ Just ('m':_) -> Just MethodKind _ -> Nothing - access a = case a of - Just "public" -> Just Public - Just "private" -> Just Private - Just "protected" -> Just Protected - Just "package" -> Just Package - _ -> Nothing - dataSource = map toDataSource paths toDataSource p | ".jar" `isSuffixOf` p = JarFile p | ".class" `isSuffixOf` p = ClassFile p | ":" `isInfixOf` p = ClassPath . map toDataSource $ (==':') `unjoin` p | otherwise = error $ "Unsupported datasource type: "++p - accessAndRegex acc rx getAcc getName x = (acc `maybeEq` (getAcc x)) - && (nameMatchesRegex x) - where nameMatchesRegex x = case rx of - Nothing -> True - Just rx -> getName x =~ rx +accessAndRegex acc rx getAcc getName x = (acc `maybeEq` (getAcc x)) + && (nameMatchesRegex x) + where nameMatchesRegex x = case rx of + Nothing -> True + Just rx -> getName x =~ rx - maybeEq Nothing _ = True - maybeEq (Just a) b = a==b +maybeEq Nothing _ = True +maybeEq (Just a) b = a == b - unjoin :: (a->Bool) -> [a] -> [[a]] - unjoin p s = go [] [] s - where go res cur [] = reverse (cur:res) - go res cur (x:xs) | p x = go (cur:res) [] xs - | otherwise = go res (x:cur) xs +access a = case a of + Just "public" -> Just Public + Just "private" -> Just Private + Just "protected" -> Just Protected + Just "package" -> Just Package + _ -> Nothing +unjoin :: (a -> Bool) -> [a] -> [[a]] +unjoin p s = go [] [] s + where go res cur [] = reverse (cur:res) + go res cur (x:xs) | p x = go (cur:res) [] xs + | otherwise = go res (x:cur) xs + + + ---------------------------------------------------------------- -- MAIN -- ---------------------------------------------------------------- @@ -172,7 +135,7 @@ run :: Args -> IO () run (Args dataS searchS searchT) = do - classes <- parseDataSource dataS + classes <- parseFileSource (ClassPath dataS) mapM_ (putStrLn . present) . concatMap (search searchS searchT) $ classes -- Results presentation @@ -182,16 +145,16 @@ present (FoundMember loc cls mem) = presentLoc loc ++ ": " ++ presentClass cls ++ ": " ++ show (mAccess mem) ++ " " ++ - bToString (mName mem) ++ " :: " ++ - bToString (mSig mem) + (mName mem) ++ " :: " ++ + (mSig mem) presentLoc :: Location -> String presentLoc (InFile path) = path presentLoc (InJar jp ip) = jp ++ "!" ++ ip presentClass :: Class -> String -presentClass (Class acc _ name False) = show acc ++ " class " ++ bToString name -presentClass (Class acc _ name True) = show acc ++ " interface " ++ bToString name +presentClass (Class name acc False _) = show acc ++ " class " ++ name +presentClass (Class name acc True _) = show acc ++ " interface " ++ name -- Search @@ -201,194 +164,3 @@ search (SearchSource classP) (SearchMember memP) (loc,c) = if (classP c) then [FoundMember loc c mem | mem <- clsMembers c, memP mem] else [] - - --- Getting the actuall classes to search in - -parseDataSource :: [ClassFileSource] -> IO [(Location, Class)] -parseDataSource = fmap (map (second parseClassFile)) . fmap concat . sequence . map files - where second f (a,b) = (a, f b) - -files :: ClassFileSource -> IO [(Location, B.ByteString)] -files (ClassFile path) = do - f <- B.readFile path - return [(InFile path, f)] -files (JarFile jar) = do - archive <- toArchive `liftM` B.readFile jar - return [(InJar jar fileName, fromEntry entry) - | entry <- zEntries archive, - let fileName = eRelativePath entry, - ".class" `isSuffixOf` fileName] -files (ClassPath paths) = fmap concat . sequence . map files $ paths - - ----------------------------------------------------------------- --- CLASS FILE PARSING -- ----------------------------------------------------------------- - --- Constant pool stuff - -data ConstantPool = ConstantPool { - cpPos :: UArray Word16 Word16, - cpData :: B.ByteString -} - -getUTF8FromCP :: ConstantPool -> Word16 -> B.ByteString -getUTF8FromCP cp@(ConstantPool cpPos cpData) i = res - where pos = cpPos!i - begin = fromIntegral $ pos+3 - len = fromIntegral $ getWord16FromCP cp (pos+1) - res = B.take len (B.drop begin cpData) - -getWord16FromCP :: Integral a => ConstantPool -> a -> Word16 -getWord16FromCP (ConstantPool cpPos cpData) iData = - (do skip (fromIntegral iData); readWord16) `runGet` cpData - --- The very class file parser - -readByte :: Get Word8 -readByte = get - -readWord16 :: Get Word16 -readWord16 = get - -readInt16 :: Get Int -readInt16 = fromIntegral `liftM` readWord16 - -readWord32 :: Get Word32 -readWord32 = get - -parseClassFile :: B.ByteString -> Class -parseClassFile = runGet classFileParser - -classFileParser :: Get Class -classFileParser = do - skip (4+2+2) -- magic, minor_version, major_version - cpSize <- readWord16 - cp <- parseConstantPool cpSize - accessFlags <- readWord16 - thisClass <- readWord16 - let classNameIndex = getWord16FromCP cp (1 + (cpPos cp)!thisClass) - let className = getUTF8FromCP cp classNameIndex - let access = flagsToAccess accessFlags - let isInterface = (0 /= accessFlags .&. 0x0200) - skip 2 -- super_class - ifCount <- readInt16 -- interfaces_count - skip (2*ifCount) -- u2 interfaces[interfaces_count] - fieldCount <- readInt16 - fields <- replicateM fieldCount (parseMember cp Field decryptType) - methodCount <- readInt16 - methods <- replicateM methodCount (parseMember cp Method decryptSig) - return (Class access (fields++methods) className isInterface) - -parseMember :: ConstantPool -> - (Access -> B.ByteString -> B.ByteString -> Member) -> - (B.ByteString -> B.ByteString) -> - Get Member -parseMember cp ctor decryptor = do - accessFlags <- readWord16 - nameIndex <- readWord16 - descrIndex <- readWord16 - attCount <- readInt16 - replicateM attCount $ do skip 2; attLen <- readWord32; skip (fromIntegral attLen) - return $ ctor (flagsToAccess accessFlags) - (getUTF8FromCP cp nameIndex) - (decryptor (getUTF8FromCP cp descrIndex)) - --- A strict unboxed list and conversion to an UArray with STUArray's -data List' a = Nil' - | (:!) {-# UNPACK #-} !a - {-# UNPACK #-} !(List' a) -infixr 5 :! -toArray' (lo,hi) list = do - arr <- newArray_ (lo,hi) - fill hi list arr - return arr -fill i list arr = fill' i list - where fill' !i (b:!bs') = writeArray arr i b >> fill' (i-1) bs' - fill' !i Nil' = return () - -parseConstantPool :: Word16 -> Get ConstantPool -parseConstantPool n = do - bs <- getRemainingLazyByteString - cpPosList <- parseConstantPool' (n-1) 0 (0 :! Nil') - cpPosArray <- return $ runSTUArray (toArray' (0,n-1) cpPosList) - return (ConstantPool cpPosArray bs) - - -parseConstantPool' :: Word16 -> Word16 -> List' Word16 -> Get (List' Word16) -parseConstantPool' 0 pos res = return res -parseConstantPool' n pos res = do - tag <- readByte - let skipRet n = do skip n; return n - delta <- fromIntegral `liftM` case tag of - 1 -> do len <- readInt16 -- CONSTANT_Utf8 - skip len - return (len+2) - 2 -> error "Tag 2 is unused" - 3 -> skipRet 4 -- CONSTANT_Integer - 4 -> skipRet 4 -- CONSTANT_Float - 5 -> skipRet 8 -- CONSTANT_Long (2 slots) - 6 -> skipRet 8 -- CONSTANT_Double (2 slots) - 7 -> skipRet 2 -- CONSTANT_Class - 8 -> skipRet 2 -- CONSTANT_String - 9 -> skipRet 4 -- CONSTANT_Fieldref - 10 -> skipRet 4 -- CONSTANT_Methodref - 11 -> skipRet 4 -- CONSTANT_InterfaceMethodref - 12 -> skipRet 4 -- CONSTANT_NameAndType - _ -> error $ "Unknown tag "++show tag++" at position "++show pos++" in CP" - let n' = if (tag==5 || tag==6) then (n-2) else (n-1) - let p = pos+delta+1 - p `seq` case tag of - 5 -> parseConstantPool' n' p (pos :! (0 :! res)) - 6 -> parseConstantPool' n' p (pos :! (0 :! res)) - _ -> parseConstantPool' n' p (pos :! res) - - --- Field/method type decryption - -decryptType :: B.ByteString -> B.ByteString -decryptType = onString (fst . decryptType') - -decryptType' :: String -> (String, String) -decryptType' "" = ("","") -decryptType' (a:s) = case a of - 'B' -> ("byte",s) - 'C' -> ("char",s) - 'D' -> ("double",s) - 'F' -> ("float",s) - 'I' -> ("int",s) - 'J' -> ("long",s) - 'S' -> ("short",s) - 'Z' -> ("boolean",s) - 'V' -> ("void",s) - '[' -> let (t,s') = decryptType' s in (t++"[]",s') - 'L' -> go "" s - where go c (';':s) = (reverse c, s) - go c ('/':s) = go ('.':c) s - go c (a:s) = go (a:c) s - go _ _ = error $ "Unrecognized type ending with "++s - _ -> error $ "Unrecognized type: "++s - -decryptSig :: B.ByteString -> B.ByteString -decryptSig = onString decryptSig' - -decryptSig' :: String -> String -decryptSig' s = concat (if null parTypes - then ["()"] - else (intersperse " -> " parTypes)) - ++ " -> " ++ retType - where ('(':params, ')':ret) = break (==')') s - retType = fst (decryptType' ret) - parTypes = go [] params - go ps "" = reverse ps - go ps s = let (p, s') = decryptType' s in go (p:ps) s' - - -flagsToAccess :: Word16 -> Access -flagsToAccess w | 0 /= w.&.0x0001 = Public - | 0 /= w.&.0x0002 = Private - | 0 /= w.&.0x0004 = Protected - | otherwise = Package - - diff --git a/jarfind.cabal b/jarfind.cabal --- a/jarfind.cabal +++ b/jarfind.cabal @@ -1,5 +1,5 @@ Name: jarfind -Version: 0.1.0.2 +Version: 0.1.0.3 Cabal-version: >= 1.6 Build-type: Simple Synopsis: Tool for searching java classes, members and fields in classfiles and JAR archives @@ -31,4 +31,6 @@ Main-Is: Main.hs Ghc-Options: -O2 Extensions: BangPatterns - +Library + Exposed-modules: JarFind + Build-depends: base >= 3 && < 5, binary, bytestring >= 0.9.0, array, zip-archive >= 0.1.1.2, regex-tdfa