Use our native Haskell tar implementation to extract code from tarballs. We...

Use our native Haskell tar implementation to extract code from tarballs. We now don't use an external tar program for anything.

cabal-install/cabal-install.cabal

@@ -36,7 +36,6 @@ Other-Modules:
     Network.Hackage.CabalInstall.Main
     Network.Hackage.CabalInstall.Setup
     Network.Hackage.CabalInstall.Tar
-    Network.Hackage.CabalInstall.TarUtils
     Network.Hackage.CabalInstall.Types
     Network.Hackage.CabalInstall.Update
     Network.Hackage.CabalInstall.Utils

cabal-install/src/Network/Hackage/CabalInstall/Install.hs

@@ -23,13 +23,14 @@ import Control.Exception (bracket_)
 import Network.Hackage.CabalInstall.Dependency (getPackages, resolveDependencies
                                                , listInstalledPackages)
 import Network.Hackage.CabalInstall.Fetch (isFetched, packageFile, fetchPackage)
+import Network.Hackage.CabalInstall.Tar (extractTarGzFile)
 import Network.Hackage.CabalInstall.Types (ConfigFlags(..), UnresolvedDependency(..)
                                       ,OutputGen(..), Repo(..))
-import Network.Hackage.CabalInstall.TarUtils
 
 import Distribution.Simple.SetupWrapper (setupWrapper)
 import Distribution.Package (showPackageId, PackageIdentifier)
 import Distribution.Verbosity
+
 import System.FilePath ((</>), splitFileName)
 
 import Data.Maybe (fromMaybe, maybeToList)
@@ -99,7 +100,6 @@ installPkg cfg globalArgs (pkg,ops,repo)
     = do pkgPath <- downloadPkg cfg pkg repo
          tmp <- getTemporaryDirectory
          let tmpDirPath = tmp </> printf "TMP%sTMP" (showPackageId pkg)
-             tmpPkgPath = tmpDirPath </> printf "TAR%s.tgz" (showPackageId pkg)
              setup cmd
                  = let cmdOps = mkPkgOps cfg cmd (globalArgs++ops)
                        path = tmpDirPath </> showPackageId pkg
@@ -108,30 +108,23 @@ installPkg cfg globalArgs (pkg,ops,repo)
                          setupWrapper (cmd:cmdOps) (Just path)
          bracket_ (createDirectoryIfMissing True tmpDirPath)
                   (removeDirectoryRecursive tmpDirPath)
-                  (do copyFile pkgPath tmpPkgPath
-                      message output deafening (printf "Extracting %s..." tmpPkgPath)
-                      extractTarFile tarProg tmpPkgPath
-                      installUnpackedPkg cfg pkg tmpPkgPath setup
+                  (do message output deafening (printf "Extracting %s..." pkgPath)
+                      extractTarGzFile (Just tmpDirPath) pkgPath
+                      installUnpackedPkg cfg pkg setup
                       return ())
     where tarProg = configTarPath cfg
           output = configOutputGen cfg
 
-installUnpackedPkg :: ConfigFlags -> PackageIdentifier -> FilePath
+installUnpackedPkg :: ConfigFlags -> PackageIdentifier
                    -> (String -> IO ()) -> IO ()
-installUnpackedPkg cfg pkgId tarFile setup
-    = do tarFiles <- tarballGetFiles tarProg tarFile
-         let cabalFile = locateFileExt tarFiles "cabal"
-         case cabalFile of
-           Just f -> let (path,_) = splitFileName f
-                     in do buildingPkg output pkgId
-                           stepConfigPkg output pkgId
-                           setup "configure"
-                           stepBuildPkg output pkgId
-                           setup "build"
-                           stepInstallPkg output pkgId
-                           setup "install"
-                           stepFinishedPkg output pkgId
-                           return ()
-           Nothing -> noCabalFile output pkgId
+installUnpackedPkg cfg pkgId setup
+    = do buildingPkg output pkgId
+         stepConfigPkg output pkgId
+         setup "configure"
+         stepBuildPkg output pkgId
+         setup "build"
+         stepInstallPkg output pkgId
+         setup "install"
+         stepFinishedPkg output pkgId
+         return ()
     where output = configOutputGen cfg
-          tarProg = configTarPath cfg

cabal-install/src/Network/Hackage/CabalInstall/Tar.hs

 -- | Simplistic TAR archive reading. Only gets the file names and file contents.
 module Network.Hackage.CabalInstall.Tar (TarHeader(..), TarFileType(..),
-                                         readTarArchive, extractTarArchive) where
+                                         readTarArchive, extractTarArchive, 
+                                         extractTarGzFile) where
 
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.ByteString.Lazy.Char8 (ByteString)
@@ -14,12 +15,15 @@ import System.Directory (Permissions(..), setPermissions, createDirectoryIfMissi
 import System.FilePath ((</>), isValid, isAbsolute)
 import System.Posix.Types (FileMode)
 
+import Codec.Compression.GZip (decompress)
+
 data TarHeader = TarHeader {
                             tarFileName   :: FilePath,
                             tarFileMode   :: FileMode,
                             tarFileType   :: TarFileType,
                             tarLinkTarget :: FilePath
                            }
+               deriving (Show)
 
 data TarFileType = 
    TarNormalFile
@@ -35,6 +39,12 @@ readTarArchive = catMaybes . unfoldr getTarEntry
 extractTarArchive :: Maybe FilePath -> [(TarHeader,ByteString)] -> IO ()
 extractTarArchive mdir = mapM_ (uncurry (extractEntry mdir))
 
+extractTarGzFile :: Maybe FilePath -- ^ Destination directory
+               -> FilePath -- ^ Tarball
+               -> IO ()
+extractTarGzFile mdir file = 
+    BS.readFile file >>= extractTarArchive mdir . readTarArchive . decompress
+
 --
 -- * Extracting
 --

cabal-install/src/Network/Hackage/CabalInstall/TarUtils.hs

------------------------------------------------------------------------------
--- |
--- Module      :  Network.Hackage.CabalInstall.TarUtils
--- Copyright   :  (c) David Himmelstrup 2005
--- License     :  BSD-like
---
--- Maintainer  :  lemmih@gmail.com
--- Stability   :  provisional
--- Portability :  portable
---
--- Utility functions for manipulating tar archives.
------------------------------------------------------------------------------
-module Network.Hackage.CabalInstall.TarUtils
-    ( tarballGetFiles
-    , locateFile
-    , locateFileExt
-    , extractTarFile
-    ) where
-
-import Data.Char (isSpace)
-import System.FilePath
-import System.IO (hClose, hGetContents)
-import System.Process (runInteractiveProcess, runProcess, waitForProcess)
-import System.Exit (ExitCode(..))
-import Text.Printf (printf)
-import Data.List (find, sortBy)
-import Data.Maybe (listToMaybe)
-
--- |List the files in a gzipped tar archive. Throwing an exception on failure.
-tarballGetFiles :: FilePath -- ^Path to the 'tar' binary.
-                -> FilePath -- ^Path to the .tgz archive.
-                -> IO [FilePath]
-tarballGetFiles tarProg tarFile
-    = do (inch,out,_,handle) <- runInteractiveProcess tarProg args Nothing Nothing
-         hClose inch
-         files <- hGetContents out
-         length files `seq` hClose out
-         eCode <- waitForProcess handle
-         case eCode of
-           ExitFailure err -> error $ printf "Failed to get filelist from '%s': %s." tarFile (show err)
-           _ -> return (map trim $ lines files)
-    where args = ["--list"
-                 ,"--gunzip"
-                 ,"--file"
-                 ,tarFile]
-          trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace  --slow'y
-{-|
-Find a file in a given directory.
-
-@
- locateFile [\"somedir\/jalla.txt\"] \"somedir\" [\"jalla.txt\"]
-     => Just \"somedir\/jalla.txt\"
- locateFile [\"somepkg\/pkg.cabal\", \"somepkg\/Setup.hs\"] \"somepkg\" [\"Setup.lhs\", \"Setup.hs\"]
-     => Just \"somedir\/Setup.hs\"
-@
--}
-locateFile :: [FilePath] -- ^File list.
-           -> FilePath   -- ^Base directory.
-           -> [FilePath] -- ^List of filenames to locate.
-           -> Maybe FilePath
-locateFile files dir names
-    = find findFile files
-    where findFile file
-              = let (root,name) = splitFileName file
-                in root == dir && name `elem` names
-
-{-|
-Locate all files with a given extension and return the shortest result.
-
-@
-  locateFileExt [\"somedir\/test.cabal\"] \"cabal\"
-     => Just \"somedir\/test.cabal\"
-@
--}
-locateFileExt :: [FilePath] -> String -> Maybe FilePath
-locateFileExt files fileExt
-    = let okExts = filter ((== fileExt) . tailNotNull . takeExtension) files
-      in (listToMaybe (sortBy sortFn okExts))
-    where comparing f a b = f a `compare` f b
-          sortFn = comparing (length.splitPath)
-          tailNotNull [] = []
-          tailNotNull x  = tail x
-
--- |Extract a given archive in the directory where it's placed.
-extractTarFile :: FilePath -- ^Path to the 'tar' binary.
-               -> FilePath -- ^Path to the .tgz archive.
-               -> IO ()
-extractTarFile tarProg tarFile
-    = do tarHandle <- runProcess tarProg args (Just dir) Nothing Nothing Nothing Nothing
-         eCode  <- waitForProcess tarHandle
-         case eCode of
-           ExitFailure err -> error $ printf "Failed to extract tar file '%s': %s with command '%s' in directory '%s'" tarFile (show err) (tarProg ++ " " ++ (show args)) dir
-           _ -> return ()
-    where args = ["-xzf",fileName]
-          (dir,fileName) = splitFileName tarFile