libarchive 2.1.3.1 → 2.1.3.2
raw patch · 11 files changed
+65/−33 lines, 11 files
Files
- CHANGELOG.md +4/−0
- README.md +1/−1
- libarchive.cabal +1/−1
- src/Codec/Archive/Common.hs +12/−0
- src/Codec/Archive/Monad.hs +10/−0
- src/Codec/Archive/Pack.hs +10/−8
- src/Codec/Archive/Types.hs +2/−2
- src/Codec/Archive/Unpack.hs +12/−7
- src/Codec/Archive/Unpack/Lazy.hs +1/−11
- test/Codec/Archive/Roundtrip.hs +4/−0
- test/Spec.hs +8/−3
CHANGELOG.md view
@@ -1,5 +1,9 @@ # libarchive +## 2.1.3.2++ * Fix segfault in strict function+ ## 2.1.3.0 * `archiveVersionString` &c. are now pure
README.md view
@@ -18,7 +18,7 @@ To run the test suite, first run ```-make -j+make ``` so that you have appropriate test data downloaded.
libarchive.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: libarchive-version: 2.1.3.1+version: 2.1.3.2 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018-2019 Vanessa McHale
src/Codec/Archive/Common.hs view
@@ -1,10 +1,22 @@ module Codec.Archive.Common ( actFree , actFreeCallback+ , hmemcpy ) where import Codec.Archive.Foreign+import Control.Composition ((.**))+import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..))+import Foreign.C.Types (CSize (..)) import Foreign.Ptr++foreign import ccall memcpy :: Ptr a -- ^ Destination+ -> Ptr b -- ^ Source+ -> CSize -- ^ Size+ -> IO (Ptr a) -- ^ Pointer to destination++hmemcpy :: Ptr a -> Ptr b -> CSize -> IO ()+hmemcpy = void .** memcpy -- | Do something with an 'Archive' and then free it actFree :: MonadIO m
src/Codec/Archive/Monad.hs view
@@ -5,10 +5,12 @@ , withCStringArchiveM , useAsCStringLenArchiveM , allocaBytesArchiveM+ , bracketM , ArchiveM ) where import Codec.Archive.Types+import Control.Exception (bracket) import Control.Monad (void) import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.IO.Class@@ -56,3 +58,11 @@ useAsCStringLenArchiveM :: BS.ByteString -> (CStringLen -> ExceptT a IO b) -> ExceptT a IO b useAsCStringLenArchiveM = genBracket useAsCStringLen++bracketM :: IO a -- ^ Allocate/aquire a resource+ -> (a -> IO b) -- ^ Free/release a resource (assumed not to fail)+ -> (a -> ArchiveM c)+ -> ArchiveM c+bracketM get free act =+ flipExceptIO $+ bracket get free (runArchiveM.act)
src/Codec/Archive/Pack.hs view
@@ -129,7 +129,7 @@ bufSize = entriesSz hsEntries' filePacker :: (Traversable t) => (FilePath -> t Entry -> ArchiveM ()) -> FilePath -> t FilePath -> ArchiveM ()-filePacker f tar fps = f tar =<< liftIO (traverse mkEntry fps)+filePacker f tar fps = f tar =<< liftIO (traverse mkEntry fps) -- TODO: undsafeInterleaveIO? lol. -- | @since 2.0.0.0 packToFile :: Traversable t@@ -177,13 +177,15 @@ entriesToFile7Zip = entriesToFileGeneral archiveWriteSetFormat7zip entriesToFileGeneral :: Foldable t => (Ptr Archive -> IO ArchiveResult) -> FilePath -> t Entry -> ArchiveM ()-entriesToFileGeneral modifier fp hsEntries' = do- a <- liftIO archiveWriteNew- ignore $ modifier a- withCStringArchiveM fp $ \fpc ->- handle $ archiveWriteOpenFilename a fpc- packEntries a hsEntries'- ignore $ archiveFree a+entriesToFileGeneral modifier fp hsEntries' =+ bracketM+ archiveWriteNew+ archiveFree+ (\a -> do+ ignore $ modifier a+ withCStringArchiveM fp $ \fpc ->+ handle $ archiveWriteOpenFilename a fpc+ packEntries a hsEntries') withArchiveEntry :: MonadIO m => (Ptr ArchiveEntry -> m a) -> m a withArchiveEntry fact = do
src/Codec/Archive/Types.hs view
@@ -41,7 +41,7 @@ | Directory | Symlink !FilePath | Hardlink !FilePath- deriving (Eq)+ deriving (Show, Eq) data Entry = Entry { filepath :: !FilePath , content :: !EntryContent@@ -49,7 +49,7 @@ , ownership :: !Ownership , time :: !(Maybe ModTime) }- deriving (Eq)+ deriving (Show, Eq) data Ownership = Ownership { userName :: !(Maybe String) , groupName :: !(Maybe String)
src/Codec/Archive/Unpack.hs view
@@ -15,7 +15,7 @@ import Data.Bifunctor (first) import qualified Data.ByteString as BS import Foreign.C.String-import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Marshal.Alloc (allocaBytes, free, mallocBytes) import Foreign.Ptr (Ptr, nullPtr) import System.FilePath ((</>)) import System.IO.Unsafe (unsafeDupablePerformIO)@@ -25,17 +25,20 @@ -- -- @since 1.0.0.0 readArchiveBS :: BS.ByteString -> Either ArchiveResult [Entry]-readArchiveBS = unsafeDupablePerformIO . runArchiveM . (actFree hsEntries <=< bsToArchive)+readArchiveBS = unsafeDupablePerformIO . runArchiveM . (actFreeCallback hsEntries <=< bsToArchive) {-# NOINLINE readArchiveBS #-} -bsToArchive :: BS.ByteString -> ArchiveM (Ptr Archive)+bsToArchive :: BS.ByteString -> ArchiveM (Ptr Archive, IO ()) bsToArchive bs = do a <- liftIO archiveReadNew ignore $ archiveReadSupportFormatAll a- useAsCStringLenArchiveM bs $- \(buf, sz) ->+ bufPtr <- useAsCStringLenArchiveM bs $+ \(buf, sz) -> do+ buf' <- liftIO $ mallocBytes sz+ _ <- liftIO $ hmemcpy buf' buf (fromIntegral sz) handle $ archiveReadOpenMemory a buf (fromIntegral sz)- pure a+ pure buf'+ pure (a, free bufPtr) -- | Read an archive from a file. The format of the archive is automatically -- detected.@@ -60,6 +63,7 @@ -> FilePath -- ^ Dirctory to unpack in -> ArchiveM () unpackArchive tarFp dirFp = do+ -- TODO: bracket here a <- archiveFile tarFp unpackEntriesFp a dirFp ignore $ archiveFree a@@ -171,6 +175,7 @@ -> BS.ByteString -- ^ 'BS.ByteString' containing archive -> ArchiveM () unpackToDir fp bs = do- a <- bsToArchive bs+ (a, act) <- bsToArchive bs unpackEntriesFp a fp+ liftIO act void $ liftIO $ archiveFree a
src/Codec/Archive/Unpack/Lazy.hs view
@@ -7,27 +7,17 @@ import Codec.Archive.Monad import Codec.Archive.Types import Codec.Archive.Unpack-import Control.Composition ((.**))-import Control.Monad (void, (<=<))+import Control.Monad ((<=<)) import Control.Monad.IO.Class import Data.ByteString (useAsCStringLen) import qualified Data.ByteString.Lazy as BSL import Data.Foldable (traverse_) import Data.Functor (($>)) import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)-import Foreign.C.Types import Foreign.Marshal.Alloc (free, mallocBytes, reallocBytes) import Foreign.Ptr import Foreign.Storable (poke) import System.IO.Unsafe (unsafeDupablePerformIO)--foreign import ccall memcpy :: Ptr a -- ^ Destination- -> Ptr b -- ^ Source- -> CSize -- ^ Size- -> IO (Ptr a) -- ^ Pointer to destination--hmemcpy :: Ptr a -> Ptr b -> CSize -> IO ()-hmemcpy = void .** memcpy -- | In general, this will be more efficient than 'unpackToDir' --
test/Codec/Archive/Roundtrip.hs view
@@ -1,6 +1,7 @@ module Codec.Archive.Roundtrip ( itPacksUnpacks , itPacksUnpacksViaFS , roundtrip+ , roundtripStrict , roundtripFreaky ) where @@ -34,6 +35,9 @@ showsContent (Hardlink target) = ("(Hardlink " ++) . shows target . (')':) joinBy :: ShowS -> [ShowS] -> ShowS joinBy sep = thread . intersperse sep++roundtripStrict :: FilePath -> IO (Either ArchiveResult BS.ByteString)+roundtripStrict = fmap (fmap entriesToBS . readArchiveBSL . BSL.fromStrict) . BS.readFile roundtripRead :: (FilePath -> IO BSL.ByteString) -> FilePath -> IO (Either ArchiveResult BSL.ByteString) roundtripRead = (fmap (fmap entriesToBSL . readArchiveBSL) .)
test/Spec.hs view
@@ -2,7 +2,7 @@ module Main ( main ) where import Codec.Archive-import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky)+import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky, roundtripStrict) import Codec.Archive.Test import Data.Either (isRight) import Data.Foldable (traverse_)@@ -10,10 +10,14 @@ import System.FilePath ((</>)) import Test.Hspec -testFp :: HasCallStack => FilePath -> Spec+testFp :: FilePath -> Spec testFp fp = parallel $ it ("sucessfully unpacks/packs (" ++ fp ++ ")") $ roundtrip fp >>= (`shouldSatisfy` isRight) +testFpStrict :: FilePath -> Spec+testFpStrict fp = parallel $ it ("works on strict bytestring (" ++ fp ++ ")") $+ roundtripStrict fp >>= (`shouldSatisfy` isRight)+ testFpFreaky :: FilePath -> Spec testFpFreaky fp = parallel $ it ("works on nonstandard bytestring (" ++ fp ++ ")") $ roundtripFreaky fp >>= (`shouldSatisfy` isRight)@@ -23,13 +27,14 @@ dir <- doesDirectoryExist "test/data" tarballs <- if dir then listDirectory "test/data" else pure []- let tarPaths = (("test/data" </>) <$> tarballs)+ let tarPaths = ("test/data" </>) <$> tarballs hspec $ describe "roundtrip" $ do traverse_ testFp tarPaths traverse_ testFpFreaky tarPaths+ traverse_ testFpStrict tarPaths context "with symlinks" $ do let entries =