Profile
Pastes: 73879
Members: 1427

Paste

Plain view | Edit code: here. | Add this to your website. | Report abuse.

Short URL: N/A

Pasted as Haskell by jkff on Friday, December 26th, 2008 8:32pm ( 6 years ago )

  1. module Main where
  2.  
  3. import Debug.Trace
  4. import Codec.Archive.Zip
  5. import qualified Data.ByteString.Lazy as B
  6. import Control.Monad
  7. import Data.List
  8. import Data.Word
  9. import Data.Bits
  10. import Data.Array.Unboxed
  11. import System.Console.GetOpt
  12. import System.Environment
  13. import Data.Maybe
  14. import Text.Regex.PCRE
  15. import Data.Time.Clock.POSIX
  16.  
  17. import Data.Binary
  18. import Data.Binary.Get
  19. import Data.Char
  20.  
  21. bToString   = map (chr . fromIntegral) . B.unpack
  22. bFromString = B.pack   . map (fromIntegral . ord)
  23. onString f  = bFromString . f . bToString
  24.  
  25. data Access = Public | Private | Protected | Package deriving (Eq)
  26.  
  27. instance Show Access where
  28.     show Public = "public"
  29.     show Private = "private"
  30.     show Protected = "protected"
  31.     show Package = ""
  32.  
  33.  
  34. data Class = Class {
  35.     clsAccess :: Access,
  36.     clsMembers :: [Member],
  37.     clsName :: B.ByteString,
  38.     clsIsInterface :: Bool
  39. } deriving (Show)
  40.  
  41. data Member = Method { mAccess :: Access, mName :: B.ByteString, mSig :: B.ByteString }
  42.             | Field  { mAccess :: Access, mName :: B.ByteString, mSig :: B.ByteString }
  43.             deriving (Show)
  44.  
  45. -- Types related to cmdline arguments
  46.  
  47. data ClassFileSource = ClassFile { path :: FilePath    }
  48.                      | JarFile   { path :: FilePath    }
  49.                      | ClassPath { paths :: [ClassFileSource] }
  50.  
  51. data Location = InFile FilePath
  52.               | InJar  { jarPath :: FilePath, innerPath :: FilePath }
  53.               deriving (Show)
  54.  
  55. newtype SearchSource = SearchSource (Class->Bool)
  56. data SearchTarget = SearchClass
  57.                   | SearchMember (Member->Bool)
  58.  
  59. data Args = Args {
  60.     dataSource   :: [ClassFileSource],
  61.     searchSource :: SearchSource,
  62.     searchTarget :: SearchTarget
  63. }
  64.  
  65. data Result = FoundClass Location Class
  66.             | FoundMember Location Class Member
  67.             deriving (Show)
  68.  
  69.  
  70. ----------------------------------------------------------------
  71. --                    ARGUMENTS PARSING                       --
  72. ----------------------------------------------------------------
  73.  
  74.  
  75. data PlainArgs = PlainArgs {
  76.     typeRegex :: Maybe String,
  77.     memberRegex :: Maybe String,
  78.     typeAccess :: Maybe String,
  79.     memberAccess :: Maybe String,
  80.     target :: Maybe String
  81. }
  82. emptyArgs = PlainArgs Nothing Nothing Nothing Nothing Nothing
  83.  
  84. data MemberKind = FieldKind | MethodKind deriving (Eq)
  85.  
  86. parseArgs :: PlainArgs -> [String] -> Args
  87. parseArgs a paths = Args dataSource (SearchSource typeFilter) searchTarget
  88.     where searchTarget = case (memberRegex a,memberAccess a,target a) of
  89.                             (Nothing,Nothing,Nothing) -> SearchClass
  90.                             _                         -> SearchMember memberFilter
  91.  
  92.           searchMembers = isJust (memberRegex a)
  93.  
  94.           typeFilter = accessAndRegex (access (typeAccess a)) (typeRegex a) clsAccess clsName
  95.          
  96.           memberFilter mem = (memKind `maybeEq` kind mem)
  97.                            && accessAndRegex (access (memberAccess a)) (memberRegex a)
  98.                                              mAccess mName mem
  99.               where kind (Field  _ _ _) = FieldKind
  100.                     kind (Method _ _ _) = MethodKind
  101.  
  102.           memKind = case (target a) of
  103.                         Just ('f':_) -> Just FieldKind
  104.                         Just ('m':_) -> Just MethodKind
  105.                         _            -> Nothing
  106.  
  107.           access a = case a of
  108.                         Just "public"    -> Just Public
  109.                         Just "private"   -> Just Private
  110.                         Just "protected" -> Just Protected
  111.                         Just "package"   -> Just Package
  112.                         _                -> Nothing
  113.  
  114.           dataSource = map toDataSource paths
  115.           toDataSource p | ".jar"   `isSuffixOf` p = JarFile p
  116.                          | ".class" `isSuffixOf` p = ClassFile p
  117.                          | ":"      `isInfixOf`  p = ClassPath . map toDataSource $ (==':') `unjoin` p
  118.  
  119.           accessAndRegex acc rx getAcc getName x =  (acc `maybeEq` (getAcc x))
  120.                                                  && (nameMatchesRegex x)
  121.               where nameMatchesRegex x = case rx of
  122.                                             Nothing -> True
  123.                                             Just rx -> getName x =~ rx
  124.          
  125.           maybeEq Nothing  _ = True
  126.           maybeEq (Just a) b = a==b
  127.          
  128.           unjoin :: (a->Bool) -> [a] -> [[a]]
  129.           unjoin p s = go [] [] s
  130.               where go res cur []     = reverse (cur:res)
  131.                     go res cur (x:xs) | p x       = go (cur:res) [] xs
  132.                                       | otherwise = go res (x:cur) xs
  133.  
  134. ----------------------------------------------------------------
  135. --                            MAIN                            --
  136. ----------------------------------------------------------------
  137.  
  138. main :: IO ()
  139. main = timed $ do
  140.     (opts, paths, errs) <- getOpt Permute options `liftM` getArgs
  141.     let compose = foldr (.) id
  142.     case errs of
  143.         [] -> go (parseArgs (compose opts emptyArgs) paths)
  144.         _  -> mapM_ putStrLn errs >> showHelp
  145.  
  146. timed :: IO a -> IO a
  147. timed a = do
  148.     t1 <- getPOSIXTime
  149.     ra <- a
  150.     t2 <- getPOSIXTime
  151.     putStrLn . show $ diffTimes t1 t2
  152.     return ra
  153.  
  154. diffTimes ta tb  =  i tb - i ta
  155. i x = realToFrac x
  156.  
  157.    
  158.  
  159. options :: [OptDescr (PlainArgs -> PlainArgs)]
  160. options = [ Option ['c'] []         (OptArg (s a -> a { typeRegex    = s }) "RX")  
  161.                 "Search for/in types whose name (with package) contains a match of this regex",
  162.             Option ['m'] []         (OptArg (s a -> a { memberRegex  = s }) "RX")  
  163.                 "Search for members whose name contains a match of this regex",
  164.             Option []    ["ca"]     (OptArg (s a -> a { typeAccess   = s })"ACCESS")  
  165.                 "Search for/in types having the specified access (public/private/protected/package)",
  166.             Option []    ["ma"]     (OptArg (s a -> a { memberAccess = s }) "ACCESS")
  167.                 "Search for members having the specified access (public/private/protected/package)",
  168.             Option ['t'] ["target"] (OptArg (s a -> a { target       = s }) "TYPE")  
  169.                 "Search for members of the given type (field=f/method=m)"]
  170.  
  171. showHelp = putStrLn $ usageInfo usage options
  172.     where usage="jarf [OPTION]... FILE... - Search for classes/methods/interfaces in JAR file(s)"
  173.  
  174. go :: Args -> IO ()
  175. go (Args dataS searchS searchT) = do
  176.     classes <- parseDataSource dataS
  177.     mapM_ (putStrLn . present) . concatMap (search searchS searchT) $ classes
  178.  
  179. -- Results presentation
  180.  
  181. present :: Result -> String
  182. present (FoundClass loc cls) = presentLoc loc ++ ": " ++ presentClass cls
  183. present (FoundMember loc cls mem) = presentLoc loc ++ ": " ++
  184.                                     presentClass cls ++ ": " ++
  185.                                     show (mAccess mem) ++ " " ++
  186.                                     bToString (mName mem) ++ " :: " ++
  187.                                     bToString (mSig mem)
  188.  
  189. presentLoc (InFile path) = path
  190. presentLoc (InJar jp ip) = jp ++ "!" ++ ip
  191.  
  192. presentClass (Class acc _ name False) = show acc ++ " class "     ++ bToString name
  193. presentClass (Class acc _ name True)  = show acc ++ " interface " ++ bToString name
  194.  
  195. -- Search
  196.  
  197. search :: SearchSource -> SearchTarget -> (Location,Class) -> [Result]
  198. search (SearchSource classP) SearchClass (loc,c) =
  199.     if (classP c) then [FoundClass loc c] else []
  200. search (SearchSource classP) (SearchMember memP) (loc,c) =
  201.     if (classP c) then [FoundMember loc c mem | mem <- clsMembers c, memP mem]
  202.                   else []
  203.  
  204.  
  205. -- Getting the actuall classes to search in
  206.  
  207. parseDataSource :: [ClassFileSource] -> IO [(Location, Class)]
  208. parseDataSource = fmap concat . sequence . map parseDataSource'
  209. parseDataSource' :: ClassFileSource -> IO [(Location,Class)]
  210. parseDataSource' (ClassFile path) = do
  211.    f <- parseClassFile `liftM` B.readFile path
  212.    return [(InFile path, f)]
  213. parseDataSource' (JarFile jar)    = do
  214.     archive <- toArchive `liftM` B.readFile jar
  215.     return [(InJar jar fileName, parseClassFile $ fromEntry entry)
  216.             | entry <- zEntries archive,
  217.               let fileName = eRelativePath entry,
  218.               ".class" `isSuffixOf` fileName]
  219.  
  220.  
  221. ----------------------------------------------------------------
  222. --                      CLASS FILE PARSING                    --
  223. ----------------------------------------------------------------
  224.  
  225. -- Constant pool stuff
  226.  
  227. data ConstantPool = ConstantPool {
  228.     cpPos    :: Array Word16 Word16,
  229.     cpData   :: B.ByteString
  230. }
  231.  
  232. getUTF8FromCP :: ConstantPool -> Word16 -> B.ByteString
  233. getUTF8FromCP cp@(ConstantPool cpPos cpData) i = res
  234.     where pos = cpPos!i
  235.           begin = fromIntegral $ pos+3
  236.           len   = fromIntegral $ getWord16FromCP cp (pos+1)
  237.           res = B.take len (B.drop begin cpData)
  238.  
  239. getWord16FromCP (ConstantPool cpPos cpData) iData =
  240.     (do skip (fromIntegral iData); readWord16) `runGet` cpData
  241.  
  242. -- The very class file parser
  243.  
  244. readByte = get :: Get Word8
  245. readWord16 = get :: Get Word16
  246. readInt16 = fromIntegral `liftM` readWord16
  247. readWord32 = get :: Get Word32
  248.  
  249. parseClassFile = runGet classFileParser
  250.  
  251. classFileParser = do
  252.     skip (4+2+2) -- magic, minor_version, major_version
  253.     cpSize      <- readWord16
  254.     cp          <- parseConstantPool cpSize
  255.     accessFlags <- readWord16
  256.     thisClass   <- readWord16
  257.     let classNameIndex = getWord16FromCP cp (1 + (cpPos cp)!thisClass)
  258.     let className      = getUTF8FromCP   cp classNameIndex
  259.     let access         = flagsToAccess accessFlags
  260.     let isInterface    = (0 /= accessFlags .&. 0x0200)
  261.     skip 2                    -- super_class
  262.     ifCount     <- readInt16  -- interfaces_count
  263.     skip (2*ifCount)          -- u2 interfaces[interfaces_count]
  264.     fieldCount  <- readInt16
  265.     fields      <- replicateM fieldCount (parseMember cp Field decryptType)
  266.     methodCount <- readInt16
  267.     methods     <- replicateM methodCount (parseMember cp Method decryptSig)
  268.     return (Class access (fields++methods) className isInterface)
  269.  
  270. parseMember cp ctor decryptor = do
  271.     accessFlags <- readWord16
  272.     nameIndex   <- readWord16
  273.     descrIndex  <- readWord16
  274.     attCount    <- readInt16
  275.     replicateM attCount $ do readWord16; readWord32 >>= (skip.fromIntegral)
  276.     return $ ctor (flagsToAccess accessFlags)
  277.                   (getUTF8FromCP cp nameIndex)
  278.                   (decryptor (getUTF8FromCP cp descrIndex))
  279.  
  280. parseConstantPool :: Word16 -> Get ConstantPool    
  281. parseConstantPool n = do
  282.     bs         <- getRemainingLazyByteString
  283.     cpPosList  <- parseConstantPool' (n-1) 0 []
  284.    cpPosArray <- return $ array (1, genericLength cpPosList) $ zip [1..] cpPosList
  285.    return (ConstantPool cpPosArray bs)
  286.  
  287.  
  288. parseConstantPool' :: Word16 -> Word16 -> [Word16] -> Get [Word16]
  289. parseConstantPool' 0 pos res = return $ reverse (0:res)
  290. parseConstantPool' n pos res = do
  291.   tag <- readByte
  292.   let skipRet n = do skip n; return n
  293.   delta <- fromIntegral `liftM` case tag of
  294.     -- Yes, tag 2 is unused.
  295.     1  -> do len <- readInt16  -- CONSTANT_Utf8
  296.              skip len
  297.              return (len+2)  
  298.     3  -> skipRet 4            -- CONSTANT_Integer
  299.     4  -> skipRet 4            -- CONSTANT_Float
  300.     5  -> skipRet 8            -- CONSTANT_Long (2 slots)
  301.     6  -> skipRet 8            -- CONSTANT_Double (2 slots)
  302.     7  -> skipRet 2            -- CONSTANT_Class
  303.     8  -> skipRet 2            -- CONSTANT_String
  304.     9  -> skipRet 4            -- CONSTANT_Fieldref
  305.     10 -> skipRet 4            -- CONSTANT_Methodref
  306.     11 -> skipRet 4            -- CONSTANT_InterfaceMethodref
  307.     12 -> skipRet 4            -- CONSTANT_NameAndType
  308.   let n' = if (tag==5 || tag==6) then (n-2) else (n-1)
  309.  case tag of
  310.    5 -> parseConstantPool' n' (pos+delta+1) (pos:0:res)
  311.    6 -> parseConstantPool' n' (pos+delta+1) (pos:0:res)
  312.    _ -> parseConstantPool' n' (pos+delta+1) (pos:res)
  313.  
  314.  
  315. -- Field/method type decryption
  316.  
  317. decryptType = onString (fst . decryptType')
  318. decryptType' ""      = ("","")
  319. decryptType' (a:s) = case a of
  320.     'B' -> ("byte",s)
  321.     'C' -> ("char",s)
  322.     'D' -> ("double",s)
  323.     'F' -> ("float",s)
  324.     'I' -> ("int",s)
  325.     'J' -> ("long",s)
  326.     'S' -> ("short",s)
  327.     'Z' -> ("boolean",s)
  328.     'V' -> ("void",s)
  329.     '[' -> let (t,s') = decryptType' s in (t++"[]",s')
  330.    'L' -> go "" s
  331.        where go c (';':s) = (reverse c, s)
  332.              go c ('/':s) = go ('.':c) s
  333.              go c (a:s)   = go (a:c)   s
  334.  
  335. decryptSig = onString decryptSig'
  336. decryptSig' s = concat (if null parTypes
  337.                        then ["()"]
  338.                        else (intersperse " -> " parTypes))
  339.                ++ " -> " ++ retType
  340.    where ('(':params, ')':ret) = break (==')') s
  341.          retType = fst (decryptType' ret)
  342.           parTypes = go [] params
  343.           go ps "" = reverse ps
  344.           go ps s  = let (p, s') = decryptType' s in go (p:ps) s'
  345.  
  346.  
  347. flagsToAccess :: Word16 -> Access
  348. flagsToAccess w | 0 /= w.&.0x0001 = Public
  349.                | 0 /= w.&.0x0002 = Private
  350.                | 0 /= w.&.0x0004 = Protected
  351.                | otherwise       = Package
  352.  
  353.  
  354.  

Revise this Paste
Your Name:
Code Language:
 
Security Image:
Text seen in Image:
Comments

Nothing has been added as yet. Post a comment.