libarchive 2.1.0.1 → 2.1.1.0

raw patch · 13 files changed

+139/−105 lines, 13 files

Files

• CHANGELOG.md +4/−0
• README.md +1/−1
• libarchive.cabal +6/−2
• src/Codec/Archive/Foreign/Archive.chs +2/−0
• src/Codec/Archive/Foreign/Archive/Macros.chs +2/−2
• src/Codec/Archive/Foreign/ArchiveEntry.chs +4/−0
• src/Codec/Archive/Foreign/ArchiveEntry/Macros.chs +4/−4
• src/Codec/Archive/Monad.hs +0/−4
• src/Codec/Archive/Pack/Common.hs +7/−8
• src/Codec/Archive/Unpack.hs +4/−4
• test/Codec/Archive/Roundtrip.hs +75/−0
• test/Codec/Archive/Test.hs +20/−0
• test/Spec.hs +10/−80

@@ -1,5 +1,9 @@ # libarchive +## 2.1.1.0++  * Remove weeds, export things that were missing from past releases+ ## 2.1.0.1    * `packEntries` and friends now detect hardlinks

@@ -18,7 +18,7 @@ To run the test suite, first run  ```-./bash/setup+make -j ```  so that you have appropriate test data downloaded.

@@ -1,6 +1,6 @@ cabal-version:   1.18 name:            libarchive-version:         2.1.0.1+version:         2.1.1.0 license:         BSD3 license-file:    LICENSE copyright:       Copyright: (c) 2018-2019 Vanessa McHale@@ -82,6 +82,10 @@     type:             exitcode-stdio-1.0     main-is:          Spec.hs     hs-source-dirs:   test+    other-modules:+        Codec.Archive.Roundtrip+        Codec.Archive.Test+     default-language: Haskell2010     other-extensions: OverloadedStrings     ghc-options:@@ -97,7 +101,7 @@         filepath -any,         temporary -any,         mtl >=2.2.2,-        dir-traverse,+        dir-traverse -any,         composition-prelude >=2.0.5.0      if impl(ghc >=8.4)

@@ -203,6 +203,8 @@                                      , archiveReadDiskSetBehavior                                      , archiveReadDiskSetMatching                                      , archiveReadDiskSetMetadataFilterCallback+                                     , archiveReadDiskNoAcl+                                     , archiveReadDiskNoFFlags                                      -- * Version macros                                      , archiveVersionNumberMacro                                      , archiveVersionOnlyString

@@ -142,11 +142,11 @@ archiveReadDiskNoXattr :: ReadDiskFlags archiveReadDiskNoXattr = ReadDiskFlags {# const ARCHIVE_READDISK_NO_XATTR #} --- | @since 2.0.0.0+-- | @since 2.1.1.0 archiveReadDiskNoAcl :: ReadDiskFlags archiveReadDiskNoAcl = ReadDiskFlags {# const ARCHIVE_READDISK_NO_ACL #} --- | @since 2.0.0.0+-- | @since 2.1.1.0 archiveReadDiskNoFFlags :: ReadDiskFlags archiveReadDiskNoFFlags = ReadDiskFlags {# const ARCHIVE_READDISK_NO_FFLAGS #} 

@@ -196,6 +196,10 @@                                           , archiveEntryACLEveryone                                           , archiveEntryACLStyleExtraID                                           , archiveEntryACLStyleMarkDefault+                                          , archiveEntryACLEntryInherited+                                          , archiveEntryACLStyleCompact+                                          , archiveEntryACLStyleSeparatorComma+                                          , archiveEntryACLStyleSolaris                                           -- * Abstract types                                           , ArchiveEntry                                           , Stat

@@ -105,7 +105,7 @@ archiveEntryACLSynchronize :: EntryACL archiveEntryACLSynchronize = EntryACL {# const ARCHIVE_ENTRY_ACL_SYNCHRONIZE #} --- | @since 2.0.0.0+-- | @since 2.1.1.0 archiveEntryACLEntryInherited :: EntryACL archiveEntryACLEntryInherited = EntryACL {# const ARCHIVE_ENTRY_ACL_ENTRY_INHERITED #} @@ -172,14 +172,14 @@ archiveEntryACLStyleMarkDefault :: EntryACL archiveEntryACLStyleMarkDefault = EntryACL {# const ARCHIVE_ENTRY_ACL_STYLE_MARK_DEFAULT #} --- | @since 2.0.0.0+-- | @since 2.1.1.0 archiveEntryACLStyleSolaris :: EntryACL archiveEntryACLStyleSolaris = EntryACL {# const ARCHIVE_ENTRY_ACL_STYLE_SOLARIS #} --- | @since 2.0.0.0+-- | @since 2.1.1.0 archiveEntryACLStyleSeparatorComma :: EntryACL archiveEntryACLStyleSeparatorComma = EntryACL {# const ARCHIVE_ENTRY_ACL_STYLE_SEPARATOR_COMMA #} --- | @since 2.0.0.0+-- | @since 2.1.1.0 archiveEntryACLStyleCompact :: EntryACL archiveEntryACLStyleCompact = EntryACL {# const ARCHIVE_ENTRY_ACL_STYLE_COMPACT #}

@@ -4,7 +4,6 @@                            -- * Bracketed resources within 'ArchiveM'                            , withCStringArchiveM                            , useAsCStringLenArchiveM-                           , allocaArchiveM                            , allocaBytesArchiveM                            , ArchiveM                            ) where@@ -49,9 +48,6 @@            -> (b -> ExceptT c IO d) -- ^ The action            -> ExceptT c IO d genBracket f x = flipExceptIO . f x . (runExceptT .)--allocaArchiveM :: Storable a => (Ptr a -> ExceptT b IO c) -> ExceptT b IO c-allocaArchiveM = genBracket (pure alloca) ()  allocaBytesArchiveM :: Int -> (Ptr a -> ExceptT b IO c) -> ExceptT b IO c allocaBytesArchiveM = genBracket allocaBytes

@@ -2,15 +2,14 @@  import           Codec.Archive.Types import qualified Data.ByteString          as BS-import           System.PosixCompat.Files (fileGroup, fileMode, fileOwner,-                                           getFileStatus, isDirectory,-                                           isRegularFile, isSymbolicLink,-                                           linkCount, readSymbolicLink)+import           System.PosixCompat.Files (FileStatus, fileGroup, fileMode, fileOwner, getFileStatus, isDirectory, isRegularFile, isSymbolicLink, linkCount,+                                           readSymbolicLink) -mkContent :: FilePath -> IO EntryContent-mkContent fp = do-    status <- getFileStatus fp+mkContent :: FilePath -> FileStatus -> IO EntryContent+mkContent fp status =     let res = (isRegularFile status, isDirectory status, isSymbolicLink status, linkCount status)+    in+     case res of         (True, False, False, 1) -> NormalFile <$> BS.readFile fp         (True, False, False, _) -> pure $ Hardlink fp@@ -21,6 +20,6 @@ mkEntry :: FilePath -> IO Entry mkEntry fp = do     status <- getFileStatus fp-    content' <- mkContent fp+    content' <- mkContent fp status     pure $ Entry fp content' (fileMode status) (Ownership Nothing Nothing (fromIntegral $ fileOwner status) (fromIntegral $ fileGroup status)) Nothing 

@@ -74,17 +74,17 @@         <*> readTimes entry  -- | Yield the next entry in an archive-getHsEntry :: MonadIO m => Ptr Archive -> m (Maybe Entry)+getHsEntry :: Ptr Archive -> IO (Maybe Entry) getHsEntry a = do-    entry <- liftIO $ getEntry a+    entry <- getEntry a     case entry of         Nothing -> pure Nothing-        Just x  -> Just <$> liftIO (readEntry a x)+        Just x  -> Just <$> readEntry a x  -- | Return a list of 'Entry's. hsEntries :: MonadIO m => Ptr Archive -> m [Entry] hsEntries a = do-    next <- getHsEntry a+    next <- liftIO $ getHsEntry a     case next of         Nothing -> pure []         Just x  -> (x:) <$> hsEntries a

@@ -0,0 +1,75 @@+module Codec.Archive.Roundtrip ( itPacksUnpacks+                               , itPacksUnpacksViaFS+                               , roundtrip+                               ) where++import           Codec.Archive+import           Control.Composition        (thread, (.@))+import           Control.Monad.Except       (liftEither)+import           Control.Monad.IO.Class     (liftIO)+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Lazy       as BSL+import           Data.List                  (intersperse, sort)+import           System.Directory           (withCurrentDirectory)+import           System.Directory.Recursive (getDirRecursive)+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++itPacksUnpacks :: [Entry] -> Spec+itPacksUnpacks entries = parallel $ it "packs/unpacks successfully without loss" $+    let+        packed = entriesToBSL entries+        unpacked = readArchiveBSL packed+    in+        (TestEntries <$> unpacked) `shouldBe` Right (TestEntries entries)++itPacksUnpacksViaFS :: [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++-- TODO: expose something like this via archive_write_disk+-- entriesToDir :: Foldable t => FilePath -> t Entry -> ArchiveM ()+entriesToDir :: FilePath -> [Entry] -> ArchiveM ()+entriesToDir = entriesToBSL .@ unpackToDirLazy

@@ -0,0 +1,20 @@+module Codec.Archive.Test ( simpleFile+                          , simpleDir+                          , stripOwnership+                          , stripTime+                          ) where++import           Codec.Archive++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++stripOwnership, stripTime :: Entry -> Entry+stripOwnership entry = entry { ownership = Ownership Nothing Nothing 0 0 }+stripTime entry = entry { time = Nothing }

@@ -2,81 +2,29 @@ module Main ( main ) where  import           Codec.Archive-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           Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip)+import           Codec.Archive.Test+import           Data.Either             (isRight)+import           Data.Foldable           (traverse_)+import           System.Directory        (doesDirectoryExist, listDirectory)+import           System.FilePath         ((</>)) 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--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 () main = do+     dir <- doesDirectoryExist "test/data"     tarballs <- if dir then listDirectory "test/data" else pure []+     hspec $         describe "roundtrip" $ do+             traverse_ testFp (("test/data" </>) <$> tarballs)+             context "with symlinks" $ do                 let entries =                         [ simpleDir "x/"@@ -108,21 +56,3 @@                 [ 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 }