Java/JAR/Archive.hs

   1 -- | This module defines functions to read Java JAR files.
   2 module Java.JAR.Archive where
   3
   4 import qualified Codec.Archive.LibZip as Zip
   5 import Data.Binary
   6 import Data.List
   7 import qualified Data.ByteString.Lazy as B
   8 import System.FilePath
   9
  10 import Java.ClassPath.Types
  11 import Java.ClassPath.Common
  12 import JVM.ClassFile
  13 import JVM.Converter
  14
  15 readJAREntry :: (Enum a) => FilePath -> String -> IO (Maybe [a])
  16 readJAREntry jarfile path = do
  17   Zip.catchZipError (Just `fmap` (Zip.withArchive [] jarfile $ Zip.fileContents [] path))
  18                     (\_ -> return Nothing)
  19
  20 -- | Read all entires from JAR file
  21 readAllJAR :: FilePath -> IO [Tree CPEntry]
  22 readAllJAR jarfile = do
  23     files <- Zip.withArchive [] jarfile $ Zip.fileNames []
  24     return $ mapF (NotLoadedJAR jarfile) (buildTree $ filter good files)
  25   where
  26     good file = ".class" `isSuffixOf` file
  27
  28 -- | Read one class from JAR file
  29 readFromJAR :: FilePath -> FilePath -> IO (Class Direct)
  30 readFromJAR jarfile path = do
  31   content <- Zip.withArchive [] jarfile $ Zip.fileContents [] path
  32   let bstr = B.pack content
  33   return $ classFile2Direct (decode bstr)
  34
  35 checkClassTree :: [Tree CPEntry] -> IO [Tree (FilePath, Class Direct)]
  36 checkClassTree forest = mapFMF check forest
  37   where
  38     check _ (NotLoaded path) = do
  39        cls <- parseClassFile path
  40        return (path, cls)
  41     check a (Loaded path cls) = return (a </> path, cls)
  42     check a (NotLoadedJAR jar path) = do
  43        cls <- readFromJAR jar (a </> path)
  44        return (a </> path, cls)
  45     check a (LoadedJAR _ cls) =
  46        return (a </> show (thisClass cls), cls)
  47
  48 zipJAR :: [Tree (FilePath, Class Direct)] -> Zip.Archive ()
  49 zipJAR forest = do
  50     mapFM go forest
  51     return ()
  52   where
  53     go (path, cls) = Zip.addFile path =<< Zip.sourceBuffer (B.unpack $ encodeClass cls)
  54