First implementation of CLASSPATH and JAR files reading.

diff --git a/JAR/Archive.hs b/JAR/Archive.hs
new file mode 100644 (file)
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 (file)
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 1cf0494be69b935f657d372f8850d722692a5a5a..56615c0181b03cba7d505281f1713c95dc639055 100644 (file)
--- a/JVM/ClassFile.hs
+++ b/JVM/ClassFile.hs
@@ -23,6 +23,7 @@ module JVM.ClassFile
    -- * Misc
    HasSignature (..), HasAttributes (..),
    NameType (..),
    -- * Misc
    HasSignature (..), HasAttributes (..),
    NameType (..),

+   toString,

    className,
    apsize, arsize, arlist
   )
    className,
    apsize, arsize, arlist
   )


@@ -218,6 +219,11 @@ data Class stage = Class {
   classAttributes :: Attributes stage -- ^ Class attributes
   }
 
   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)
 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 (file)
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) = "<Not loaded file: " ++ path ++ ">"
+  show (Loaded path cls) = "<Loaded from " ++ path ++ ": " ++ toString (thisClass cls) ++ ">"
+  show (NotLoadedJAR jar path) = "<Not loaded JAR: " ++ jar ++ ": " ++ path ++ ">"
+  show (LoadedJAR path cls) = "<Read JAR: " ++ path ++ ": " ++ toString (thisClass 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 (file)
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 (file)
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 (file)
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 (file)
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]
+