tar-bytestring 0.6.2.0 → 0.6.3.0

raw patch · 6 files changed

+117/−41 lines, 6 filesdep +thesePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: these

API changes (from Hackage documentation)

Files

• Codec/Archive/Tar/Index.hs +3/−2
• Codec/Archive/Tar/Pack.hs +32/−12
• Codec/Archive/Tar/Types.hs +37/−11
• Codec/Archive/Tar/Unpack.hs +37/−15
• changelog.md +4/−0
• tar-bytestring.cabal +4/−1

@@ -124,6 +124,7 @@ #endif  #ifdef TESTS+import Data.These import qualified Prelude import Test.QuickCheck import Test.QuickCheck.Property (ioProperty)@@ -710,7 +711,7 @@ testEntry :: RawFilePath -> Int64 -> Entry testEntry name size = simpleEntry path (NormalFile mempty size)   where-    Right path = toTarPath False name+    That path = toTarPath False name  -- | Simple tar archive containing regular files only data SimpleTarArchive = SimpleTarArchive {@@ -775,7 +776,7 @@       mkList []            = []       mkList ((fp, bs):es) = entry : mkList es         where-          Right path = toTarPath False fp+          That path = toTarPath False fp           entry   = simpleEntry path content           content = NormalFile bs (LBS.length bs) 

@@ -21,8 +21,10 @@  import Codec.Archive.Tar.Types import Control.Applicative+import Control.Monad (join) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L+import Data.These import qualified System.Posix.IO.ByteString as SPI import System.Posix.FD import System.Posix.ByteString.FilePath (RawFilePath)@@ -73,8 +75,8 @@  packPaths :: RawFilePath -> [RawFilePath] -> IO [Entry] packPaths baseDir paths =-  interleave-    [ do tarpath <- either fail return (toTarPath isDir relpath)+  join <$> interleave+    [ do let tarpath = toTarPath isDir relpath          if isDir then packDirectoryEntry filepath tarpath                   else packFileEntry      filepath tarpath     | relpath <- paths@@ -99,33 +101,51 @@ -- * The file contents is read lazily. -- packFileEntry :: RawFilePath -- ^ Full path to find the file on the local disk-              -> TarPath  -- ^ Path to use for the tar Entry in the archive-              -> IO Entry+              -> These SplitError TarPath  -- ^ Path to use for the tar Entry in the archive+              -> IO [Entry] packFileEntry filepath tarpath = do   mtime   <- getModTime filepath   executable   <- isExecutable filepath   file    <- openFd filepath SPI.ReadOnly [] Nothing >>= SPI.fdToHandle   size    <- hFileSize file   content <- L.hGetContents file-  return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {-    entryPermissions = if executable then executableFilePermissions-                                     else ordinaryFilePermissions,-    entryTime = mtime-  } +  let entry tp = (simpleEntry tp (NormalFile content (fromIntegral size))) {+         entryPermissions = if executable then executableFilePermissions+                                          else ordinaryFilePermissions,+         entryTime = mtime+         }++  case tarpath of+       This e     -> fail $ show e+       That tp    -> return [entry tp]+       These _ tp -> do+         let lEntry = longLinkEntry filepath+         return [lEntry, entry tp]++ -- | Construct a tar 'Entry' based on a local directory (but not its contents). -- -- The only attribute of the directory that is used is its modification time. -- Directory ownership and detailed permissions are not preserved. -- packDirectoryEntry :: RawFilePath -- ^ Full path to find the file on the local disk-                   -> TarPath  -- ^ Path to use for the tar Entry in the archive-                   -> IO Entry+                   -> These SplitError TarPath  -- ^ Path to use for the tar Entry in the archive+                   -> IO [Entry] packDirectoryEntry filepath tarpath = do   mtime   <- getModTime filepath-  return (directoryEntry tarpath) {++  let dEntry tp = (directoryEntry tp) {     entryTime = mtime   }++  case tarpath of+       This e     -> fail $ show e+       That tp    -> return [dEntry tp]+       These _ tp -> do+         let lEntry = longLinkEntry filepath+         return [lEntry, dEntry tp]+  -- | This is a utility function, much like 'getDirectoryContents'. The -- difference is that it includes the contents of subdirectories.

@@ -29,6 +29,7 @@   RawFilePath,    simpleEntry,+  longLinkEntry,   fileEntry,   directoryEntry, @@ -37,6 +38,7 @@   directoryPermissions,    TarPath(..),+  SplitError(..),   toTarPath,   fromTarPath,   fromTarPathToPosixPath,@@ -64,6 +66,7 @@ import Data.Int      (Int64) import Data.Monoid   (Monoid(..)) import Data.Semigroup as Sem+import Data.These import qualified Data.ByteString       as BS import qualified Data.ByteString.Char8 as BS.Char8 import qualified Data.ByteString.Lazy  as LBS@@ -246,6 +249,22 @@     entryFormat      = UstarFormat   } ++-- | Gnu entry for when a filepath is too long to be in entryTarPath.+-- Gnu tar uses OtherEntryType 'L' then as the first Entry and puts path+-- in the entryContent. The Next entry will then be the "original"+-- entry with the entryTarPath truncated.+longLinkEntry :: RawFilePath -> Entry+longLinkEntry tarpath = Entry {+    entryTarPath     = TarPath (BS.Char8.pack "././@LongLink") BS.empty,+    entryContent     = OtherEntryType 'L' (LBS.fromStrict tarpath) (fromIntegral $ BS.length tarpath),+    entryPermissions = ordinaryFilePermissions,+    entryOwnership   = Ownership "" "" 0 0,+    entryTime        = 0,+    entryFormat      = GnuFormat+  }++ -- | A tar 'Entry' for a file. -- -- Entry  fields such as file permissions and ownership have default values.@@ -349,7 +368,7 @@ -- toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for                   -- directories a 'TarPath' must always use a trailing @\/@.-          -> RawFilePath -> Either String TarPath+          -> RawFilePath -> These SplitError TarPath toTarPath isDir = splitLongPath                 . addTrailingSep                 . FilePath.Posix.joinPath@@ -358,6 +377,11 @@     addTrailingSep | isDir     = FilePath.Posix.addTrailingPathSeparator                    | otherwise = id ++data SplitError = FileNameEmpty+                | FileNameTooLong+                deriving Show+ -- | Take a sanitised path, split on directory separators and try to pack it -- into the 155 + 100 tar file name format. --@@ -365,15 +389,17 @@ -- and try to fit as many components into the 100 long name area as possible. -- If all the remaining components fit in the 155 name area then we win. ---splitLongPath :: RawFilePath -> Either String TarPath+splitLongPath :: RawFilePath -> These SplitError TarPath splitLongPath path =   case packName nameMax (reverse (FilePath.Posix.splitPath path)) of-    Left err                 -> Left err-    Right (name, [])         -> Right $! TarPath name BS.empty+    Left FileNameTooLong     -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty+    Left e                   -> This e+    Right (name, [])         -> That $! TarPath name BS.empty     Right (name, first:rest) -> case packName prefixMax remainder of-      Left err               -> Left err-      Right (_     , (_:_))  -> Left "File name too long (cannot split)"-      Right (prefix, [])     -> Right $! TarPath name prefix+      Left FileNameTooLong   -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty+      Left e                 -> This e+      Right (_     , (_:_))  -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty+      Right (prefix, [])     -> That $! TarPath name prefix       where         -- drop the '/' between the name and prefix:         remainder = BS.init first : rest@@ -383,9 +409,9 @@     nameMax   = 100     prefixMax = 155 -    packName _      []     = Left "File name empty"+    packName _      []     = Left FileNameEmpty     packName maxLen (c:cs)-      | n > maxLen         = Left "File name too long"+      | n > maxLen         = Left FileNameTooLong       | otherwise          = Right (packName' maxLen n [c] cs)       where n = BS.length c @@ -558,14 +584,14 @@       | perms' <- shrinkIntegral perms ]  instance Arbitrary TarPath where-  arbitrary = either error id+  arbitrary = these (error . show) id (flip const)             . toTarPath False             . FilePath.Posix.joinPath             . fmap BS.Char8.pack           <$> listOf1ToN (255 `div` 5)                          (elements (map (replicate 4) "abcd")) -  shrink = map (either error id . toTarPath False)+  shrink = map (these (error . show) id (flip const) . toTarPath False)          . map FilePath.Posix.joinPath          . filter (not . null)          . shrinkList shrinkNothing

@@ -18,6 +18,7 @@ import Codec.Archive.Tar.Types import Codec.Archive.Tar.Check +import Data.List (partition) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import System.Posix.FilePath@@ -65,8 +66,12 @@ -- use 'checkSecurity' before 'checkTarbomb' or other checks. -- unpack :: Exception e => RawFilePath -> Entries e -> IO ()-unpack baseDir entries = unpackEntries [] (checkSecurity entries)-                     >>= emulateLinks+unpack baseDir entries = do+  uEntries <- unpackEntries [] (checkSecurity entries)+  let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries+  -- emulate hardlinks first, in case a symlink points to it+  emulateLinks hardlinks+  emulateLinks symlinks    where     -- We're relying here on 'checkSecurity' to make sure we're not scribbling@@ -75,23 +80,37 @@     unpackEntries _     (Fail err)      = either throwIO throwIO err     unpackEntries links Done            = return links     unpackEntries links (Next entry es) = case entryContent entry of-      NormalFile file _ -> extractFile entry path file mtime+      NormalFile file _ -> extractFile fPerms path file mtime                         >> unpackEntries links es       Directory         -> extractDir path mtime                         >> unpackEntries links es-      HardLink     link -> (unpackEntries $! saveLink path link links) es-      SymbolicLink link -> (unpackEntries $! saveLink path link links) es-      _                 -> unpackEntries links es --ignore other file types+      HardLink     link -> (unpackEntries $! saveLink True path link links) es+      SymbolicLink link -> (unpackEntries $! saveLink False path link links) es+      OtherEntryType 'L' fn _ ->+        case es of+             (Next entry' es') -> case entryContent entry' of+               NormalFile file _ -> extractFile fPerms (L.toStrict fn) file mtime+                                 >> unpackEntries links es'+               Directory         -> extractDir (L.toStrict fn) mtime+                                 >> unpackEntries links es'+               HardLink     link -> (unpackEntries $! saveLink True path link links) es'+               SymbolicLink link -> (unpackEntries $! saveLink False path link links) es'+               OtherEntryType 'L' _ _ -> throwIO $ userError "Two subsequent OtherEntryType 'L'"+               _ -> unpackEntries links es'+             (Fail err)      -> either throwIO throwIO err+             Done            -> throwIO $ userError "././@LongLink without a subsequent entry"+      _ -> unpackEntries links es --ignore other file types       where         path  = entryPath entry         mtime = entryTime entry+        fPerms = entryPermissions entry -    extractFile entry path content mtime = do+    extractFile fPerms path content mtime = do       -- 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.       createDirRecursive dirPerms (normalise absDir)-      writeFileL absPath (Just $ entryPermissions entry) content+      writeFileL absPath (Just fPerms) content       setModTime absPath mtime       where         absDir  = baseDir </> FilePath.Native.takeDirectory path@@ -103,15 +122,18 @@       where         absPath = baseDir </> path -    saveLink path link links = seq (BS.length path)-                             $ seq (BS.length link')-                             $ (path, link'):links+    saveLink isHardLink path link links = seq (BS.length path)+                                        $ seq (BS.length link')+                                        $ (path, link', isHardLink):links       where link' = fromLinkTarget link -    emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> do-      let absPath = baseDir </> relPath-          absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget-      copyFile absTarget absPath Overwrite+    emulateLinks = mapM_ $ \(relPath, relLinkTarget, isHardLink) ->+      let absPath   = baseDir </> relPath+          -- hard links link targets are always "absolute" paths in+          -- the context of the tar root+          absTarget = if isHardLink then baseDir </> relLinkTarget else FilePath.Native.takeDirectory absPath </> relLinkTarget+      in copyFile absTarget absPath Overwrite+  setModTime :: RawFilePath -> EpochTime -> IO () setModTime p t = setModificationTime p (fromIntegral t)

@@ -1,5 +1,9 @@ See also http://pvp.haskell.org/faq +0.6.3.0++  * Fix unpacking of hard links+ 0.6.2.0    * fix executable bit: https://github.com/haskell/tar/issues/25

@@ -1,5 +1,5 @@ name:            tar-bytestring-version:         0.6.2.0+version:         0.6.3.0 license:         BSD3 license-file:    LICENSE author:          Duncan Coutts <duncan@community.haskell.org>@@ -48,6 +48,7 @@                  hpath-filepath   >= 0.10.4 && < 0.11,                  hpath-posix      >= 0.13.1 && < 0.14,                  safe-exceptions  >= 0.1,+                 these            >= 1.0.1,                  unix,                  word8 @@ -98,6 +99,7 @@                  hpath-filepath   >= 0.10.4 && < 0.11,                  hpath-posix      >= 0.13.1 && < 0.14,                  safe-exceptions  >= 0.1,+                 these            >= 1.0.1,                  unix,                  word8 @@ -151,6 +153,7 @@                  hpath-filepath   >= 0.10.4 && < 0.11,                  hpath-posix      >= 0.13.1 && < 0.14,                  safe-exceptions  >= 0.1,+                 these            >= 1.0.1,                  unix,                  word8