summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorvmchale <>2019-12-02 20:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-12-02 20:29:00 (GMT)
commita849a99b52401686c0438288f00efe0324ccfcc2 (patch)
tree767226a18a5f3093707e1ceb99fd66a165092d08
parent3fdc4378a889f62e460e37eba91d22a3b93b4707 (diff)
version 2.1.0.12.1.0.1
-rw-r--r--CHANGELOG.md5
-rw-r--r--libarchive.cabal10
-rw-r--r--src/Codec/Archive/Pack/Common.hs13
-rw-r--r--src/Codec/Archive/Types.hs3
-rw-r--r--src/Codec/Archive/Unpack.hs24
-rw-r--r--test/Spec.hs122
6 files changed, 154 insertions, 23 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 76a4a14..ba7391c 100644
--- 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
index b8c6282..0b00384 100644
--- 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 @@ source-repository head
custom-setup
setup-depends:
base -any,
+ Cabal -any,
chs-cabal -any
flag cross
@@ -82,6 +83,7 @@ test-suite libarchive-test
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 @@ test-suite libarchive-test
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
index fb0ec12..aa36e5c 100644
--- a/src/Codec/Archive/Pack/Common.hs
+++ b/src/Codec/Archive/Pack/Common.hs
@@ -5,17 +5,18 @@ import qualified Data.ByteString as BS
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
index ec0a329..0807ff8 100644
--- a/src/Codec/Archive/Types.hs
+++ b/src/Codec/Archive/Types.hs
@@ -41,6 +41,7 @@ data EntryContent = NormalFile !BS.ByteString
| Directory
| Symlink !FilePath
| Hardlink !FilePath
+ deriving (Eq)
data Entry = Entry { filepath :: !FilePath
, content :: !EntryContent
@@ -48,12 +49,14 @@ data Entry = Entry { filepath :: !FilePath
, 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
index a34772b..6d932fa 100644
--- a/src/Codec/Archive/Unpack.hs
+++ b/src/Codec/Archive/Unpack.hs
@@ -101,8 +101,20 @@ unpackEntriesFp a fp = do
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 @@ readBS a sz =
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
index bc963f0..7f8648d 100644
--- 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 @@ main = do
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 }