diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 +``` diff --git a/libarchive.cabal b/libarchive.cabal --- a/libarchive.cabal +++ b/libarchive.cabal @@ -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 diff --git a/src/Codec/Archive/Unpack.hs b/src/Codec/Archive/Unpack.hs --- a/src/Codec/Archive/Unpack.hs +++ b/src/Codec/Archive/Unpack.hs @@ -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 diff --git a/src/Codec/Archive/Unpack/Lazy.hs b/src/Codec/Archive/Unpack/Lazy.hs --- a/src/Codec/Archive/Unpack/Lazy.hs +++ b/src/Codec/Archive/Unpack/Lazy.hs @@ -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 diff --git a/test/Codec/Archive/Roundtrip.hs b/test/Codec/Archive/Roundtrip.hs --- a/test/Codec/Archive/Roundtrip.hs +++ b/test/Codec/Archive/Roundtrip.hs @@ -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" $ diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 =