libarchive 2.1.0.0 → 2.1.0.1
raw patch · 6 files changed
+154/−23 lines, 6 filesdep +dir-traversedep ~mtl
Dependencies added: dir-traverse
Dependency ranges changed: mtl
Files
- CHANGELOG.md +5/−0
- libarchive.cabal +8/−2
- src/Codec/Archive/Pack/Common.hs +7/−6
- src/Codec/Archive/Types.hs +3/−0
- src/Codec/Archive/Unpack.hs +18/−6
- test/Spec.hs +113/−9
CHANGELOG.md view
@@ -1,5 +1,10 @@ # libarchive +## 2.1.0.1++ * `packEntries` and friends now detect hardlinks+ * Add `Cabal` to `custom-setup` depends to ensure builds work with stack+ ## 2.1.0.0 * Remove `archiveEntryAclNext` since it doesn't exist in the static linked
libarchive.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: libarchive-version: 2.1.0.0+version: 2.1.0.1 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018-2019 Vanessa McHale@@ -25,6 +25,7 @@ custom-setup setup-depends: base -any,+ Cabal -any, chs-cabal -any flag cross@@ -82,6 +83,7 @@ main-is: Spec.hs hs-source-dirs: test default-language: Haskell2010+ other-extensions: OverloadedStrings ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints@@ -92,7 +94,11 @@ hspec -any, bytestring -any, directory >=1.2.5.0,- filepath -any+ filepath -any,+ temporary -any,+ mtl >=2.2.2,+ dir-traverse,+ composition-prelude >=2.0.5.0 if impl(ghc >=8.4) ghc-options: -Wmissing-export-lists
src/Codec/Archive/Pack/Common.hs view
@@ -5,17 +5,18 @@ import System.PosixCompat.Files (fileGroup, fileMode, fileOwner, getFileStatus, isDirectory, isRegularFile, isSymbolicLink,- readSymbolicLink)+ linkCount, readSymbolicLink) mkContent :: FilePath -> IO EntryContent mkContent fp = do status <- getFileStatus fp- let res = (isRegularFile status, isDirectory status, isSymbolicLink status)+ let res = (isRegularFile status, isDirectory status, isSymbolicLink status, linkCount status) case res of- (True, False, False) -> NormalFile <$> BS.readFile fp- (False, True, False) -> pure Directory- (False, False, True) -> Symlink <$> readSymbolicLink fp- (_, _, _) -> error "inconsistent read result"+ (True, False, False, 1) -> NormalFile <$> BS.readFile fp+ (True, False, False, _) -> pure $ Hardlink fp+ (False, True, False, _) -> pure Directory+ (False, False, True, _) -> Symlink <$> readSymbolicLink fp+ (_, _, _, _) -> error "inconsistent read result" mkEntry :: FilePath -> IO Entry mkEntry fp = do
src/Codec/Archive/Types.hs view
@@ -41,6 +41,7 @@ | Directory | Symlink !FilePath | Hardlink !FilePath+ deriving (Eq) data Entry = Entry { filepath :: !FilePath , content :: !EntryContent@@ -48,12 +49,14 @@ , ownership :: !Ownership , time :: !(Maybe ModTime) }+ deriving (Eq) data Ownership = Ownership { userName :: !(Maybe String) , groupName :: !(Maybe String) , ownerId :: !Id , groupId :: !Id }+ deriving (Eq, Show) type Permissions = CMode type ModTime = (CTime, CLong)
src/Codec/Archive/Unpack.hs view
@@ -101,8 +101,20 @@ let file' = fp </> file liftIO $ withCString file' $ \fileC -> archiveEntrySetPathname x fileC- ignore $ archiveReadExtract a x archiveExtractTime- liftIO $ archiveEntrySetPathname x preFile+ ft <- liftIO $ archiveEntryFiletype x+ case ft of+ Just{} -> do+ ignore $ archiveReadExtract a x archiveExtractTime+ liftIO $ archiveEntrySetPathname x preFile+ Nothing -> do+ preHardlink <- liftIO $ archiveEntryHardlink x+ hardlink <- liftIO $ peekCString preHardlink+ 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 @@ -114,11 +126,11 @@ readContents :: Ptr Archive -> Ptr ArchiveEntry -> IO EntryContent readContents a entry = go =<< archiveEntryFiletype entry- where go Nothing = Hardlink <$> (peekCString =<< archiveEntryHardlink entry)- go (Just FtRegular) = NormalFile <$> (readBS a =<< sz)- go (Just FtLink) = Symlink <$> (peekCString =<< archiveEntrySymlink entry)+ where go Nothing = Hardlink <$> (peekCString =<< archiveEntryHardlink entry)+ go (Just FtRegular) = NormalFile <$> (readBS a =<< sz)+ go (Just FtLink) = Symlink <$> (peekCString =<< archiveEntrySymlink entry) go (Just FtDirectory) = pure Directory- go (Just _) = error "Unsupported filetype"+ go (Just _) = error "Unsupported filetype" sz = fromIntegral <$> archiveEntrySize entry archiveGetterHelper :: (Ptr ArchiveEntry -> IO a) -> (Ptr ArchiveEntry -> IO Bool) -> Ptr ArchiveEntry -> IO (Maybe a)
test/Spec.hs view
@@ -1,18 +1,73 @@+{-# LANGUAGE OverloadedStrings #-} module Main ( main ) where import Codec.Archive-import qualified Data.ByteString.Lazy as BSL-import Data.Either (isRight)-import Data.Foldable (traverse_)-import System.Directory (doesDirectoryExist, listDirectory)-import System.FilePath ((</>))+import Control.Composition (thread, (.@))+import Control.Monad.Except+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Either (isRight)+import Data.Foldable (traverse_)+import Data.List (intersperse, sort)+import System.Directory (doesDirectoryExist, listDirectory, withCurrentDirectory)+import System.Directory.Recursive (getDirRecursive)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory) import Test.Hspec ++newtype TestEntries = TestEntries [Entry]+ deriving (Eq)++instance Show TestEntries where+ showsPrec _ (TestEntries entries) = ("(TestEntries [" ++) . joinBy (", "++) (map showsEntry entries) . ("])" ++) where+ showsEntry entry = ("Entry " ++) .+ ("{filepath=" ++) . shows (filepath entry) .+ (", content=" ++) . showsContent (content entry) .+ (", permissions=" ++) . shows (permissions entry) .+ (", ownership=" ++) . shows (ownership entry) .+ (", time=" ++) . shows (time entry) .+ ("}" ++)+ showsContent (NormalFile bytes) = ("(NormalFile $ " ++) . shows (BS.take 10 bytes) . (" <> undefined)" ++)+ showsContent Directory = ("Directory" ++)+ showsContent (Symlink target) = ("(Symlink " ++) . shows target . (')':)+ showsContent (Hardlink target) = ("(Hardlink " ++) . shows target . (')':)+ joinBy :: ShowS -> [ShowS] -> ShowS+ joinBy sep = thread . intersperse sep+ roundtrip :: FilePath -> IO (Either ArchiveResult BSL.ByteString) roundtrip = fmap (fmap entriesToBSL . readArchiveBSL) . BSL.readFile -testFp :: FilePath -> Spec-testFp fp = parallel $ it ("sucessfully packs/unpacks itself (" ++ fp ++ ")") $+itPacksUnpacks :: HasCallStack => [Entry] -> Spec+itPacksUnpacks entries = parallel $ it "packs/unpacks successfully without loss" $+ (TestEntries <$> unpacked) `shouldBe` Right (TestEntries entries)+ where+ packed = entriesToBSL entries+ unpacked = readArchiveBSL packed++itPacksUnpacksViaFS :: HasCallStack => [Entry] -> Spec+itPacksUnpacksViaFS entries = parallel $ unpackedFromFS $ it "packs/unpacks on filesystem successfully without loss" $ \unpacked ->+ fmap (fmap stripDotSlash . testEntries) unpacked `shouldBe` Right (testEntries entries)+ where+ -- Use this to test content as well+ -- testEntries = TestEntries . sortOn filepath . map (stripOwnership . stripPermissions)+ testEntries = sort . map filepath+ unpackedFromFS = around $ \action ->+ withSystemTempDirectory "spec-" $ \tmpdir -> do+ unpacked <- {- withCurrentDirectory tmpdir . -} runArchiveM $ do+ entriesToDir tmpdir entries+ packed <- liftIO . withCurrentDirectory tmpdir $ do+ files <- getDirRecursive "."+ packFiles files+ liftEither $ readArchiveBSL packed++ action unpacked+ stripDotSlash :: FilePath -> FilePath+ stripDotSlash ('.':'/':fp) = fp+ stripDotSlash fp = fp++testFp :: HasCallStack => FilePath -> Spec+testFp fp = parallel $ it ("sucessfully unpacks/packs (" ++ fp ++ ")") $ roundtrip fp >>= (`shouldSatisfy` isRight) main :: IO ()@@ -20,5 +75,54 @@ dir <- doesDirectoryExist "test/data" tarballs <- if dir then listDirectory "test/data" else pure [] hspec $- describe "roundtrip" $ traverse_ testFp- (("test/data" </>) <$> tarballs)+ describe "roundtrip" $ do+ traverse_ testFp (("test/data" </>) <$> tarballs)+ context "with symlinks" $ do+ let entries =+ [ simpleDir "x/"+ , simpleFile "x/a.txt" (NormalFile "referenced")+ , simpleFile "x/b.txt" (Symlink "a.txt")+ ]+ itPacksUnpacks entries+ itPacksUnpacksViaFS entries++ context "with hardlinks" $ do+ let entries =+ [ simpleDir "x/"+ , simpleFile "x/a.txt" (NormalFile "shared")+ , simpleFile "x/b.txt" (Hardlink "x/a.txt")+ ]+ itPacksUnpacks entries+ context "issue#4" $ itPacksUnpacksViaFS entries++ context "with forward referenced hardlinks" $ do+ let entries =+ [ simpleDir "x/"+ , simpleFile "x/b.txt" (Hardlink "x/a.txt")+ , simpleFile "x/a.txt" (NormalFile "shared")+ ]+ itPacksUnpacks entries+ xcontext "re-ordering on unpack" $ itPacksUnpacksViaFS entries++ xcontext "having entry without ownership" . itPacksUnpacks $+ [ stripOwnership (simpleFile "a.txt" (NormalFile "text")) ]+ xcontext "having entry without timestamp" . itPacksUnpacks $+ [ stripTime (simpleFile "a.txt" (NormalFile "text")) ]++simpleFile :: FilePath -> EntryContent -> Entry+simpleFile name what = Entry name what standardPermissions (Ownership (Just "root") (Just "root") 0 0) (Just (0,0))++simpleDir :: FilePath -> Entry+simpleDir name = Entry name Directory dirPermissions (Ownership (Just "root") (Just "root") 0 0) (Just (0,0))++dirPermissions :: Permissions+dirPermissions = executablePermissions++-- TODO: expose something like this via archive_write_disk+-- entriesToDir :: Foldable t => FilePath -> t Entry -> ArchiveM ()+entriesToDir :: FilePath -> [Entry] -> ArchiveM ()+entriesToDir = entriesToBSL .@ unpackToDirLazy++stripOwnership, stripTime :: Entry -> Entry+stripOwnership entry = entry { ownership = Ownership Nothing Nothing 0 0 }+stripTime entry = entry { time = Nothing }