[commit: Cabal] : Create all parent directories of extraced files (2fbd5fc)

[Ian Lynagh]

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/2fbd5fc799e630c2cf061af248b192a5f7d1d5d0

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

commit 2fbd5fc799e630c2cf061af248b192a5f7d1d5d0
Author: Duncan Coutts <duncan at haskell.org>
Date:   Sun Nov 22 08:04:46 2009 +0000

    Create all parent directories of extraced files
    Previously only created the immediate parent directory.
    No rely more heavily on the file security check to make
    sure we are not writing files outside of the target area.

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

 cabal-install/Distribution/Client/Tar.hs |   12 +++++++++---
 1 files changed, 9 insertions(+), 3 deletions(-)

diff --git a/cabal-install/Distribution/Client/Tar.hs b/cabal-install/Distribution/Client/Tar.hs
index fd9150a..361582e 100644
--- a/cabal-install/Distribution/Client/Tar.hs
+++ b/cabal-install/Distribution/Client/Tar.hs
@@ -434,7 +434,7 @@ checkEntrySecurity entry = case entryContent entry of
 
   where
     check name
-      | FilePath.Native.isAbsolute name
+      | not (FilePath.Native.isRelative name)
       = Just $ "Absolute file name in tar archive: " ++ show name
 
       | not (FilePath.Native.isValid name)
@@ -720,6 +720,9 @@ unpack baseDir entries = unpackEntries [] (checkSecurity entries)
                      >>= emulateLinks
 
   where
+    -- We're relying here on 'checkSecurity' to make sure we're not scribbling
+    -- files all over the place.
+
     unpackEntries _     (Fail err)      = fail err
     unpackEntries links Done            = return links
     unpackEntries links (Next entry es) = case entryContent entry of
@@ -734,13 +737,16 @@ unpack baseDir entries = unpackEntries [] (checkSecurity entries)
         path = entryPath entry
 
     extractFile path content = do
-      createDirectoryIfMissing False absDir
+      -- Note that tar archives do not make sure each directory is created
+      -- before files they contain, indeed we may have to create several
+      -- levels of directory.
+      createDirectoryIfMissing True absDir
       BS.writeFile absPath content
       where
         absDir  = baseDir </> FilePath.Native.takeDirectory path
         absPath = baseDir </> path
 
-    extractDir path = createDirectoryIfMissing False (baseDir </> path)
+    extractDir path = createDirectoryIfMissing True (baseDir </> path)
 
     saveLink path link links = seq (length path)
                              $ seq (length link')