diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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.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 diff --git a/src/Codec/Archive/Pack/Common.hs b/src/Codec/Archive/Pack/Common.hs --- a/src/Codec/Archive/Pack/Common.hs +++ b/src/Codec/Archive/Pack/Common.hs @@ -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 diff --git a/src/Codec/Archive/Types.hs b/src/Codec/Archive/Types.hs --- a/src/Codec/Archive/Types.hs +++ b/src/Codec/Archive/Types.hs @@ -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) 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 @@ -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) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 }