[commit: Cabal] master: Added extraction to the simple TAR implementation. (88707c7)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/88707c73870457e9d5e4e9096a782188312db1dc

>---------------------------------------------------------------

commit 88707c73870457e9d5e4e9096a782188312db1dc
Author: bjorn <bjorn at bringert.net>
Date:   Sat Oct 6 15:31:22 2007 +0000

    Added extraction to the simple TAR implementation.

>---------------------------------------------------------------

 .../src/Network/Hackage/CabalInstall/Config.hs     |    8 +-
 .../src/Network/Hackage/CabalInstall/Tar.hs        |   94 ++++++++++++++++++--
 2 files changed, 90 insertions(+), 12 deletions(-)

diff --git a/cabal-install/src/Network/Hackage/CabalInstall/Config.hs b/cabal-install/src/Network/Hackage/CabalInstall/Config.hs
index e9b1c7f..da752e6 100644
--- a/cabal-install/src/Network/Hackage/CabalInstall/Config.hs
+++ b/cabal-install/src/Network/Hackage/CabalInstall/Config.hs
@@ -45,7 +45,7 @@ import Distribution.Verbosity
 import System.FilePath ((</>), takeExtension, (<.>))
 import System.Directory
 
-import Network.Hackage.CabalInstall.Tar (readTarArchive)
+import Network.Hackage.CabalInstall.Tar (readTarArchive, tarFileName)
 import Network.Hackage.CabalInstall.Types (ConfigFlags (..), OutputGen(..), PkgInfo (..), Repo(..))
 
 import Paths_cabal_install (getDataDir)
@@ -118,14 +118,14 @@ readRepoIndex cfg repo =
 
 parseRepoIndex :: Repo -> ByteString -> [PkgInfo]
 parseRepoIndex repo s =
-    do (name, content) <- readTarArchive s
-       if takeExtension name == ".cabal"
+    do (hdr, content) <- readTarArchive s
+       if takeExtension (tarFileName hdr) == ".cabal"
          then case parsePackageDescription (BS.unpack content) of
                     ParseOk _ descr -> return $ PkgInfo { 
                                                          pkgRepo = repo,
                                                          pkgDesc = descr
                                                         }
-                    _               -> error $ "Couldn't read cabal file " ++ show name
+                    _               -> error $ "Couldn't read cabal file " ++ show (tarFileName hdr)
          else fail "Not a .cabal file"
 
 getKnownServers :: ConfigFlags -> IO [Repo]
diff --git a/cabal-install/src/Network/Hackage/CabalInstall/Tar.hs b/cabal-install/src/Network/Hackage/CabalInstall/Tar.hs
index 119d376..3f9a848 100644
--- a/cabal-install/src/Network/Hackage/CabalInstall/Tar.hs
+++ b/cabal-install/src/Network/Hackage/CabalInstall/Tar.hs
@@ -1,42 +1,120 @@
 -- | Simplistic TAR archive reading. Only gets the file names and file contents.
-module Network.Hackage.CabalInstall.Tar (readTarArchive) where
+module Network.Hackage.CabalInstall.Tar (TarHeader(..), TarFileType(..),
+                                         readTarArchive, extractTarArchive) where
 
 import qualified Data.ByteString.Lazy.Char8 as BS
 import Data.ByteString.Lazy.Char8 (ByteString)
+import Data.Bits ((.&.))
 import Data.Char (ord)
 import Data.Int (Int8, Int64)
 import Data.List (unfoldr)
 import Data.Maybe (catMaybes)
 import Numeric (readOct)
-
-
-readTarArchive :: ByteString -> [(FilePath,ByteString)]
+import System.Directory (Permissions(..), setPermissions, createDirectoryIfMissing, copyFile)
+import System.FilePath ((</>), isValid, isAbsolute)
+import System.Posix.Types (FileMode)
+
+data TarHeader = TarHeader {
+                            tarFileName   :: FilePath,
+                            tarFileMode   :: FileMode,
+                            tarFileType   :: TarFileType,
+                            tarLinkTarget :: FilePath
+                           }
+
+data TarFileType = 
+   TarNormalFile
+ | TarHardLink
+ | TarSymbolicLink
+ | TarDirectory
+ | TarOther Char
+  deriving (Eq,Show)
+
+readTarArchive :: ByteString -> [(TarHeader,ByteString)]
 readTarArchive = catMaybes . unfoldr getTarEntry
 
-getTarEntry :: ByteString -> Maybe (Maybe (FilePath,ByteString), ByteString)
+extractTarArchive :: Maybe FilePath -> [(TarHeader,ByteString)] -> IO ()
+extractTarArchive mdir = mapM_ (uncurry (extractEntry mdir))
+
+--
+-- * Extracting
+--
+
+extractEntry :: Maybe FilePath -> TarHeader -> ByteString -> IO ()
+extractEntry mdir hdr cnt
+    = do path <- relativizePath mdir (tarFileName hdr)
+         let setPerms   = setPermissions path (fileModeToPermissions (tarFileMode hdr))
+             copyLinked = relativizePath mdir (tarLinkTarget hdr) >>= copyFile path
+         case tarFileType hdr of
+           TarNormalFile   -> BS.writeFile path cnt >> setPerms
+           TarHardLink     -> copyLinked >> setPerms
+           TarSymbolicLink -> copyLinked
+           TarDirectory    -> createDirectoryIfMissing False path >> setPerms
+           TarOther _      -> return () -- FIXME: warning?
+
+relativizePath :: Monad m => Maybe FilePath -> FilePath -> m FilePath
+relativizePath mdir file
+    | isAbsolute file    = fail $ "Absolute file name in TAR archive: " ++ show file
+    | not (isValid file) = fail $ "Invalid file name in TAR archive: " ++ show file
+    | otherwise          = return $ maybe file (</> file) mdir
+
+fileModeToPermissions :: FileMode -> Permissions
+fileModeToPermissions m = 
+    Permissions {
+                 readable   = m .&. ownerReadMode    /= 0,
+                 writable   = m .&. ownerWriteMode   /= 0,
+                 executable = m .&. ownerExecuteMode /= 0,
+                 searchable = m .&. ownerExecuteMode /= 0
+                }
+
+ownerReadMode    :: FileMode
+ownerReadMode    = 0o000400
+
+ownerWriteMode   :: FileMode
+ownerWriteMode   = 0o000200
+
+ownerExecuteMode :: FileMode
+ownerExecuteMode = 0o000100
+
+--
+-- * Reading
+--
+
+getTarEntry :: ByteString -> Maybe (Maybe (TarHeader,ByteString), ByteString)
 getTarEntry bs | endBlock = Nothing
                | BS.length hdr < 512 = error "Truncated TAR archive."
                | not (checkChkSum hdr chkSum) = error "TAR checksum error."
-               | not normalFile = Just (Nothing, bs''')
-               | otherwise = Just (Just (path, cnt), bs''')
+               | otherwise = Just (Just (info, cnt), bs''')
 
    where (hdr,bs') = BS.splitAt 512 bs
 
          endBlock  = getByte 0 hdr == '\0'
 
          fileSuffix = getString   0 100 hdr
+         mode       = getOct    100   8 hdr
          chkSum     = getOct    148   8 hdr
          typ        = getByte   156     hdr
          size       = getOct    124  12 hdr
+         linkTarget = getString 157 100 hdr
          filePrefix = getString 345 155 hdr
 
-         normalFile = typ == '0' || typ == '\0'
-         path       = filePrefix ++ fileSuffix
-
          padding    = (512 - size) `mod` 512
          (cnt,bs'') = BS.splitAt size bs'
          bs'''      = BS.drop padding bs''
 
+         fileType   = case typ of
+                        '\0'-> TarNormalFile
+                        '0' -> TarNormalFile
+                        '1' -> TarHardLink
+                        '2' -> TarSymbolicLink
+                        '5' -> TarDirectory
+                        c   -> TarOther c
+                        
+         path       = filePrefix ++ fileSuffix
+         info       = TarHeader { tarFileName   = path, 
+                                  tarFileMode   = mode,
+                                  tarFileType   = fileType,
+                                  tarLinkTarget = linkTarget }
+
 checkChkSum :: ByteString -> Int -> Bool
 checkChkSum hdr s = s == chkSum hdr' || s == signedChkSum hdr'
   where