From 5a372b10d0647f9d572b9a70d7512cf653df97e3 Mon Sep 17 00:00:00 2001 From: "Ilya V. Portnov" Date: Mon, 3 Oct 2011 18:05:22 +0600 Subject: [PATCH] First implementation of CLASSPATH and JAR files reading. --- JAR/Archive.hs | 57 +++++++++++++++++++++++++ JAR/Tree.hs | 3 ++ JVM/ClassFile.hs | 6 +++ Java/ClassPath.hs | 101 ++++++++++++++++++++++++++++++++++++++++++++ Java/META.hs | 11 +++++ Java/META/Parser.hs | 60 ++++++++++++++++++++++++++ Java/META/Spec.hs | 99 +++++++++++++++++++++++++++++++++++++++++++ Java/META/Types.hs | 10 +++++ 8 files changed, 347 insertions(+) create mode 100644 JAR/Archive.hs create mode 100644 JAR/Tree.hs create mode 100644 Java/ClassPath.hs create mode 100644 Java/META.hs create mode 100644 Java/META/Parser.hs create mode 100644 Java/META/Spec.hs create mode 100644 Java/META/Types.hs diff --git a/JAR/Archive.hs b/JAR/Archive.hs new file mode 100644 index 0000000..78902dc --- /dev/null +++ b/JAR/Archive.hs @@ -0,0 +1,57 @@ + +module JAR.Archive where + +import Control.Monad.Trans +import qualified Control.Monad.State as St +import qualified Codec.Archive.LibZip as Zip +import Data.Binary +import Data.String.Utils (split) +import qualified Data.ByteString.Lazy as B + +import Java.ClassPath +import JVM.ClassFile +import JVM.Converter + +readJAR :: FilePath -> IO [Tree CPEntry] +readJAR jarfile = do + files <- Zip.withArchive [] jarfile $ Zip.fileNames [] + return $ mapF (NotLoadedJAR jarfile) (buildTree files) + +readFromJAR :: FilePath -> FilePath -> IO (Class Direct) +readFromJAR jarfile path = do + content <- Zip.withArchive [] jarfile $ Zip.fileContents [] path + let bstr = B.pack content + return $ classFile2Direct (decode bstr) + +addJAR :: FilePath -> ClassPath () +addJAR jarfile = do + classes <- liftIO $ readJAR jarfile + cp <- St.get + let cp' = merge $ cp ++ classes + St.put cp' + +loadClass :: String -> ClassPath () +loadClass path = do + cp <- St.get + cp' <- liftIO $ mapM (load xs) cp + St.put cp' + where + xs = split "/" path + + load :: [String] -> Tree CPEntry -> IO (Tree CPEntry) + load [] t = return t + load (p:ps) t@(Directory dir forest) + | p == dir = Directory dir `fmap` mapM (load ps) forest + | otherwise = return t + load [p] t@(File (NotLoaded f)) + | (p ++ ".class") == f = do + cls <- parseClassFile (path ++ ".class") + return (File $ Loaded path cls) + | otherwise = return t + load [p] t@(File (NotLoadedJAR jarfile f)) + | (p ++ ".class") == f = do + cls <- readFromJAR jarfile (path ++ ".class") + return (File $ LoadedJAR jarfile cls) + | otherwise = return t + load ps (File _) = fail $ "Found file when expecting directory! " ++ show ps + diff --git a/JAR/Tree.hs b/JAR/Tree.hs new file mode 100644 index 0000000..7057aa2 --- /dev/null +++ b/JAR/Tree.hs @@ -0,0 +1,3 @@ + +module JAR.Tree where + diff --git a/JVM/ClassFile.hs b/JVM/ClassFile.hs index 1cf0494..56615c0 100644 --- a/JVM/ClassFile.hs +++ b/JVM/ClassFile.hs @@ -23,6 +23,7 @@ module JVM.ClassFile -- * Misc HasSignature (..), HasAttributes (..), NameType (..), + toString, className, apsize, arsize, arlist ) @@ -218,6 +219,11 @@ data Class stage = Class { classAttributes :: Attributes stage -- ^ Class attributes } +deriving instance Eq (Class File) +deriving instance Eq (Class Direct) +deriving instance Show (Class File) +deriving instance Show (Class Direct) + deriving instance Eq (Constant File) deriving instance Eq (Constant Direct) deriving instance Show (Constant File) diff --git a/Java/ClassPath.hs b/Java/ClassPath.hs new file mode 100644 index 0000000..ecc4ae4 --- /dev/null +++ b/Java/ClassPath.hs @@ -0,0 +1,101 @@ + +module Java.ClassPath where + +import Control.Monad +import Control.Monad.State +import System.Directory +import System.FilePath +import System.FilePath.Glob +import Data.Function (on) +import Data.List +import Data.String.Utils (split) + +import JVM.ClassFile +import JVM.Converter + +data Tree a = + Directory FilePath [Tree a] + | File a + deriving (Eq) + +instance Show a => Show (Tree a) where + show (Directory dir forest) = dir ++ "/{" ++ intercalate ", " (map show forest) ++ "}" + show (File a) = show a + +data CPEntry = + NotLoaded FilePath + | Loaded FilePath (Class Direct) + | NotLoadedJAR FilePath FilePath + | LoadedJAR FilePath (Class Direct) + deriving (Eq) + +instance Show CPEntry where + show (NotLoaded path) = "" + show (Loaded path cls) = "" + show (NotLoadedJAR jar path) = "" + show (LoadedJAR path cls) = "" + +type ClassPath a = StateT [Tree CPEntry] IO a + +-- | For given list of glob masks, return list of matching files +glob :: FilePath -> [FilePath] -> IO [FilePath] +glob dir patterns = do + (matches, _) <- globDir (map compile patterns) dir + return $ concat matches + +mapF :: (t -> a) -> [Tree t] -> [Tree a] +mapF fn forest = map (mapT fn) forest + +mapFM fn forest = mapM (mapTM fn) forest + +mapTM fn (Directory dir forest) = Directory dir `fmap` mapFM fn forest +mapTM fn (File a) = File `fmap` fn a + +mapT :: (t -> a) -> Tree t -> Tree a +mapT fn (Directory dir forest) = Directory dir (mapF fn forest) +mapT fn (File a) = File (fn a) + +buildTree :: [FilePath] -> [Tree FilePath] +buildTree strs = + let build :: [[String]] -> [Tree FilePath] + build [[name]] = [File name] + build ss = map node $ groupBy eq (sort ss) + + node [] = error "Impossible: groupBy give an empty group!" + node ([]:l) = node l + node l | all (null . tail) l = File (head $ head l) + | otherwise = Directory (head $ head l) (build $ map tail l) + + ls = map (split "/") strs + + eq [] [] = True + eq (x:_) (y:_) = x == y + + in build ls + +appendPath :: FilePath -> [Tree CPEntry] -> [Tree CPEntry] +appendPath path forest = merge $ forest ++ (mapF NotLoaded $ buildTree [path]) + +merge :: [Tree CPEntry] -> [Tree CPEntry] +merge [] = [] +merge (t:ts) = foldl merge1 [t] ts + +merge1 :: [Tree CPEntry] -> Tree CPEntry -> [Tree CPEntry] +merge1 [] x = [x] +merge1 (x@(File e): es) y@(File e') | e == e' = x: es + | otherwise = x: merge1 es y +merge1 (d@(Directory _ _):es) f@(File _) = d: merge1 es f +merge1 (x@(Directory dir f):es) y@(Directory dir' f') + | dir == dir' = Directory dir (merge $ f ++ f'): es + | otherwise = x: merge1 es y + +addDirectory :: FilePath -> ClassPath () +addDirectory dir = do + files <- liftIO $ glob dir ["*.class"] + cp <- get + let cp' = foldr appendPath cp files + put cp' + +runClassPath :: ClassPath () -> IO [Tree CPEntry] +runClassPath m = execStateT m [] + diff --git a/Java/META.hs b/Java/META.hs new file mode 100644 index 0000000..3293977 --- /dev/null +++ b/Java/META.hs @@ -0,0 +1,11 @@ + +module Java.META + (module Java.META.Types, + module Java.META.Parser, + module Java.META.Spec) + where + +import Java.META.Types +import Java.META.Parser +import Java.META.Spec + diff --git a/Java/META/Parser.hs b/Java/META/Parser.hs new file mode 100644 index 0000000..b27cecc --- /dev/null +++ b/Java/META/Parser.hs @@ -0,0 +1,60 @@ + +module Java.META.Parser where + +import qualified Data.Map as M +import Text.Parsec +import Text.Parsec.String + +import Java.META.Types + +pNewLine :: Parser () +pNewLine = choice $ map try $ [ + string "\r\n" >> return (), + char '\r' >> return (), + char '\n' >> return () ] + +blankline :: Parser () +blankline = do + pNewLine "first newline in blankline" + return () + +pSection :: Parser Section +pSection = do + list <- many1 pHeader + blankline "blank line" + return $ M.fromList list + +pHeader :: Parser (String, String) +pHeader = do + name <- many1 headerChar "header name" + char ':' + value <- pValue + return (name, value) + where + headerChar = oneOf "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_" + +pValue :: Parser String +pValue = do + list <- manyLines + return (concat list) + +manyLines :: Parser [String] +manyLines = do + char ' ' + many space + s <- many1 (noneOf "\n\r\0") + pNewLine "new line at end of value line" + c <- lookAhead anyChar + if c == ' ' + then do + next <- manyLines + return (s: next) + else return [s] + +pMETA :: Parser META +pMETA = many1 pSection + +parseMetaFile :: FilePath -> IO (Either ParseError META) +parseMetaFile path = do + str <- readFile path + return $ parse pMETA path (str ++ "\n\n") diff --git a/Java/META/Spec.hs b/Java/META/Spec.hs new file mode 100644 index 0000000..82d55c1 --- /dev/null +++ b/Java/META/Spec.hs @@ -0,0 +1,99 @@ +module Java.META.Spec where + +import Control.Monad +import Control.Monad.Error +import qualified Data.Map as M +import Data.Map ((!)) +import Data.Char (toLower) + +import Java.META.Types + +class MetaSpec s where + loadFirstSection :: Section -> s + + loadOtherSection :: s -> Section -> s + loadOtherSection s _ = s + + storeMeta :: s -> META + +loadSpec :: (MetaSpec s) => META -> s +loadSpec [] = error "Cannot load empty metadata" +loadSpec (s:ss) = + let x = loadFirstSection s + in foldl loadOtherSection x ss + +lookupList :: String -> Maybe String -> [(String, String)] +lookupList _ Nothing = [] +lookupList name (Just val) = [(name, val)] + +bool2string :: Bool -> String +bool2string True = "true" +bool2string False = "false" + +string2bool :: String -> Bool +string2bool s + | map toLower s == "true" = True + | otherwise = False + +data Manifest = Manifest { + manifestVersion :: String, + createdBy :: String, + sealed :: Bool, + signatureVersion :: Maybe String, + classPath :: [String], + mainClass :: Maybe String, + manifestEntries :: [ManifestEntry]} + deriving (Eq, Show) + +data ManifestEntry = ManifestEntry { + meName :: String, + meSealed :: Bool, + meContentType :: Maybe String, + meBean :: Bool } + deriving (Eq, Show) + +instance MetaSpec Manifest where + loadFirstSection s = Manifest { + manifestVersion = s ! "Manifest-Version", + createdBy = s ! "Created-By", + sealed = case M.lookup "Sealed" s of + Nothing -> False + Just str -> string2bool str, + signatureVersion = M.lookup "Signature-Version" s, + classPath = case M.lookup "Class-Path" s of + Nothing -> [] + Just str -> words str, + mainClass = M.lookup "Main-Class" s, + manifestEntries = []} + + loadOtherSection m s = m {manifestEntries = manifestEntries m ++ [entry]} + where + entry = ManifestEntry { + meName = s ! "Name", + meSealed = case M.lookup "Sealed" s of + Nothing -> sealed m + Just str -> string2bool str, + meContentType = M.lookup "Content-Type" s, + meBean = case M.lookup "Java-Bean" s of + Nothing -> False + Just str -> string2bool str } + + storeMeta m = first: map store (manifestEntries m) + where + first = M.fromList $ [ + ("Manifest-Version", manifestVersion m), + ("Created-By", createdBy m)] ++ + lookupList "Signature-Version" (signatureVersion m) ++ + lookupList "Main-Class" (mainClass m) ++ + case classPath m of + [] -> [] + list -> [("Class-Path", unwords list)] + + store e = M.fromList $ [ + ("Name", meName e), + ("Sealed", bool2string $ meSealed e)] ++ + lookupList "Content-Type" (meContentType e) ++ + if meBean e + then [("Java-Bean", "true")] + else [] + diff --git a/Java/META/Types.hs b/Java/META/Types.hs new file mode 100644 index 0000000..f058f5a --- /dev/null +++ b/Java/META/Types.hs @@ -0,0 +1,10 @@ + +module Java.META.Types where + +import qualified Data.Map as M +import Text.Parsec +import Text.Parsec.String + +type Section = M.Map String String +type META = [Section] + -- 2.25.1