libarchive 2.1.2.0 → 2.1.2.1
raw patch · 7 files changed
+50/−17 lines, 7 files
Files
- CHANGELOG.md +4/−0
- README.md +9/−0
- libarchive.cabal +1/−1
- src/Codec/Archive/Unpack.hs +2/−6
- src/Codec/Archive/Unpack/Lazy.hs +12/−7
- test/Codec/Archive/Roundtrip.hs +14/−1
- test/Spec.hs +8/−2
CHANGELOG.md view
@@ -1,5 +1,9 @@ # libarchive +## 2.1.2.1++ * Fixed bug that would cause segfaults on lazy bytestrings with large chunks+ ## 2.1.2.0 * More complete API
README.md view
@@ -22,3 +22,12 @@ ``` so that you have appropriate test data downloaded.++### CI++To edit the CI script, edit `github-action.dhall` and regenerate+`.github/workflows/haskell.yml` with++```+make ci+```
libarchive.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: libarchive-version: 2.1.2.0+version: 2.1.2.1 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018-2019 Vanessa McHale
src/Codec/Archive/Unpack.hs view
@@ -103,18 +103,14 @@ archiveEntrySetPathname x fileC ft <- liftIO $ archiveEntryFiletype x case ft of- Just{} -> do+ Just{} -> ignore $ archiveReadExtract a x archiveExtractTime- liftIO $ archiveEntrySetPathname x preFile Nothing -> do- preHardlink <- liftIO $ archiveEntryHardlink x- hardlink <- liftIO $ peekCString preHardlink+ hardlink <- liftIO $ peekCString =<< archiveEntryHardlink x let hardlink' = fp </> hardlink liftIO $ withCString hardlink' $ \hl -> archiveEntrySetHardlink x hl ignore $ archiveReadExtract a x archiveExtractTime- liftIO $ archiveEntrySetPathname x preFile- liftIO $ archiveEntrySetHardlink x preHardlink ignore $ archiveReadDataSkip a unpackEntriesFp a fp
src/Codec/Archive/Unpack/Lazy.hs view
@@ -14,8 +14,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Foldable (traverse_) import Data.Functor (($>))-import Data.IORef (modifyIORef, newIORef, readIORef,- writeIORef)+import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) import Foreign.C.Types import Foreign.Marshal.Alloc (free, mallocBytes, reallocBytes) import Foreign.Ptr@@ -59,9 +58,10 @@ a <- liftIO archiveReadNew ignore $ archiveReadSupportFormatAll a bufPtr <- liftIO $ mallocBytes (32 * 1024) -- default to 32k byte chunks+ bufPtrRef <- liftIO $ newIORef bufPtr bsChunksRef <- liftIO $ newIORef bsChunks bufSzRef <- liftIO $ newIORef (32 * 1024)- rc <- liftIO $ mkReadCallback (readBSL bsChunksRef bufSzRef bufPtr)+ rc <- liftIO $ mkReadCallback (readBSL bsChunksRef bufSzRef bufPtrRef) cc <- liftIO $ mkCloseCallback (\_ ptr -> freeHaskellFunPtr rc *> free ptr $> ArchiveOk) nothingPtr <- liftIO $ mallocBytes 0 let seqErr = traverse_ handle@@ -70,9 +70,9 @@ , archiveReadSetCallbackData a nothingPtr , archiveReadOpen1 a ]- pure (a, freeHaskellFunPtr cc *> free bufPtr)+ pure (a, freeHaskellFunPtr cc *> (free =<< readIORef bufPtrRef)) - where readBSL bsRef bufSzRef bufPtr _ _ dataPtr = do+ where readBSL bsRef bufSzRef bufPtrRef _ _ dataPtr = do bs' <- readIORef bsRef case bs' of [] -> pure 0@@ -80,9 +80,14 @@ modifyIORef bsRef tail useAsCStringLen x $ \(charPtr, sz) -> do bufSz <- readIORef bufSzRef+ bufPtr <- readIORef bufPtrRef bufPtr' <- if sz > bufSz- then writeIORef bufSzRef sz *> reallocBytes bufPtr sz- else pure bufPtr+ then do+ writeIORef bufSzRef sz+ newBufPtr <- reallocBytes bufPtr sz+ writeIORef bufPtrRef newBufPtr+ pure newBufPtr+ else readIORef bufPtrRef hmemcpy bufPtr' charPtr (fromIntegral sz) poke dataPtr bufPtr' $> fromIntegral sz bsChunks = BSL.toChunks bs
test/Codec/Archive/Roundtrip.hs view
@@ -1,6 +1,7 @@ module Codec.Archive.Roundtrip ( itPacksUnpacks , itPacksUnpacksViaFS , roundtrip+ , roundtripFreaky ) where import Codec.Archive@@ -34,8 +35,20 @@ joinBy :: ShowS -> [ShowS] -> ShowS joinBy sep = thread . intersperse sep +roundtripRead :: (FilePath -> IO BSL.ByteString) -> FilePath -> IO (Either ArchiveResult BSL.ByteString)+roundtripRead = (fmap (fmap entriesToBSL . readArchiveBSL) .)+ roundtrip :: FilePath -> IO (Either ArchiveResult BSL.ByteString)-roundtrip = fmap (fmap entriesToBSL . readArchiveBSL) . BSL.readFile+roundtrip = roundtripRead BSL.readFile++roundtripFreaky :: FilePath -> IO (Either ArchiveResult BSL.ByteString)+roundtripFreaky = roundtripRead nonstandardRead++nonstandardRead :: FilePath -> IO BSL.ByteString+nonstandardRead fp = do+ bStrict <- BS.readFile fp+ let (h, t) = BS.splitAt (64 * 1024) bStrict+ pure $ BSL.fromChunks [h, t] itPacksUnpacks :: [Entry] -> Spec itPacksUnpacks entries = parallel $ it "packs/unpacks successfully without loss" $
test/Spec.hs view
@@ -2,7 +2,7 @@ module Main ( main ) where import Codec.Archive-import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip)+import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky) import Codec.Archive.Test import Data.Either (isRight) import Data.Foldable (traverse_)@@ -14,16 +14,22 @@ testFp fp = parallel $ it ("sucessfully unpacks/packs (" ++ fp ++ ")") $ roundtrip fp >>= (`shouldSatisfy` isRight) +testFpFreaky :: FilePath -> Spec+testFpFreaky fp = parallel $ it ("works on nonstandard bytestring (" ++ fp ++ ")") $+ roundtripFreaky fp >>= (`shouldSatisfy` isRight)+ main :: IO () main = do dir <- doesDirectoryExist "test/data" tarballs <- if dir then listDirectory "test/data" else pure []+ let tarPaths = (("test/data" </>) <$> tarballs) hspec $ describe "roundtrip" $ do - traverse_ testFp (("test/data" </>) <$> tarballs)+ traverse_ testFp tarPaths+ traverse_ testFpFreaky tarPaths context "with symlinks" $ do let entries =