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 (..),
+   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 (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]
+