summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorvmchale <>2020-01-13 21:19:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-01-13 21:19:00 (GMT)
commita01f2a62899a69b2aaead7db074dc1a2354cdeed (patch)
tree84f23833c9f6ac8890962a58aeba4eda2225a57f
parent4b9e283f298d90db5f6e8902c064f17e7e8e860c (diff)
version 2.2.0.12.2.0.1
-rw-r--r--CHANGELOG.md8
-rw-r--r--libarchive.cabal2
-rw-r--r--src/Codec/Archive.hs1
-rw-r--r--src/Codec/Archive/Common.hs10
-rw-r--r--src/Codec/Archive/Pack.hs5
-rw-r--r--src/Codec/Archive/Pack/Common.hs2
-rw-r--r--src/Codec/Archive/Types.hs2
-rw-r--r--src/Codec/Archive/Types/Foreign.chs2
-rw-r--r--src/Codec/Archive/Unpack.hs27
-rw-r--r--test/Codec/Archive/Roundtrip.hs2
-rw-r--r--test/Spec.hs20
11 files changed, 55 insertions, 26 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 1471d01..bf37756 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,13 @@
# libarchive
+## 2.2.0.1
+
+ * Use `bracket` in a few places where it doesn't crash GHC
+
+## 2.2.0.0
+
+ * Haskell `Entry` type now includes `Symlink` field
+
## 2.1.3.2
* Fix segfault in strict function
diff --git a/libarchive.cabal b/libarchive.cabal
index c0ffba0..35ff198 100644
--- a/libarchive.cabal
+++ b/libarchive.cabal
@@ -1,6 +1,6 @@
cabal-version: 1.18
name: libarchive
-version: 2.1.3.2
+version: 2.2.0.1
license: BSD3
license-file: LICENSE
copyright: Copyright: (c) 2018-2019 Vanessa McHale
diff --git a/src/Codec/Archive.hs b/src/Codec/Archive.hs
index ace5895..f983425 100644
--- a/src/Codec/Archive.hs
+++ b/src/Codec/Archive.hs
@@ -27,6 +27,7 @@ module Codec.Archive
-- * Concrete (Haskell) types
, ArchiveResult (..)
, Entry (..)
+ , Symlink (..)
, EntryContent (..)
, Ownership (..)
, Permissions
diff --git a/src/Codec/Archive/Common.hs b/src/Codec/Archive/Common.hs
index a1d1af2..b369e20 100644
--- a/src/Codec/Archive/Common.hs
+++ b/src/Codec/Archive/Common.hs
@@ -4,6 +4,7 @@ module Codec.Archive.Common ( actFree
) where
import Codec.Archive.Foreign
+import Codec.Archive.Monad (ArchiveM, bracketM)
import Control.Composition ((.**))
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (..))
@@ -19,11 +20,10 @@ hmemcpy :: Ptr a -> Ptr b -> CSize -> IO ()
hmemcpy = void .** memcpy
-- | Do something with an 'Archive' and then free it
-actFree :: MonadIO m
- => (Ptr Archive -> m a)
- -> Ptr Archive
- -> m a
-actFree fact a = fact a <* liftIO (archiveFree a)
+actFree :: IO (Ptr Archive)
+ -> (Ptr Archive -> ArchiveM a)
+ -> ArchiveM a
+actFree get = bracketM get archiveFree
actFreeCallback :: MonadIO m
=> (Ptr Archive -> m a)
diff --git a/src/Codec/Archive/Pack.hs b/src/Codec/Archive/Pack.hs
index ef2dc0f..e1525f8 100644
--- a/src/Codec/Archive/Pack.hs
+++ b/src/Codec/Archive/Pack.hs
@@ -40,8 +40,9 @@ contentAdd (NormalFile contents) a entry = do
contentAdd Directory a entry = do
liftIO $ archiveEntrySetFiletype entry (Just FtDirectory)
handle $ archiveWriteHeader a entry
-contentAdd (Symlink fp) a entry = do
+contentAdd (Symlink fp st) a entry = do
liftIO $ archiveEntrySetFiletype entry (Just FtLink)
+ liftIO $ archiveEntrySetSymlinkType entry st
liftIO $ withCString fp $ \fpc ->
archiveEntrySetSymlink entry fpc
handle $ archiveWriteHeader a entry
@@ -78,7 +79,7 @@ entriesSz = getSum . foldMap (Sum . entrySz)
where entrySz e = 512 + 512 * (contentSz (content e) `div` 512 + 1)
contentSz (NormalFile str) = fromIntegral $ BS.length str
contentSz Directory = 0
- contentSz (Symlink fp) = fromIntegral $ length fp
+ contentSz (Symlink fp _) = 1 + fromIntegral (length fp)
contentSz (Hardlink fp) = fromIntegral $ length fp --idk if this is right
-- | Returns a 'BS.ByteString' containing a tar archive with the 'Entry's
diff --git a/src/Codec/Archive/Pack/Common.hs b/src/Codec/Archive/Pack/Common.hs
index 563e880..6b6911c 100644
--- a/src/Codec/Archive/Pack/Common.hs
+++ b/src/Codec/Archive/Pack/Common.hs
@@ -14,7 +14,7 @@ mkContent fp status =
(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
+ (False, False, True, _) -> Symlink <$> readSymbolicLink fp <*> pure SymlinkUndefined
(_, _, _, _) -> error "inconsistent read result"
mkEntry :: FilePath -> IO Entry
diff --git a/src/Codec/Archive/Types.hs b/src/Codec/Archive/Types.hs
index 6113d14..3e9482e 100644
--- a/src/Codec/Archive/Types.hs
+++ b/src/Codec/Archive/Types.hs
@@ -39,7 +39,7 @@ data ArchiveEncryption = HasEncryption
-- TODO: support everything here: http://hackage.haskell.org/package/tar/docs/Codec-Archive-Tar-Entry.html#t:EntryContent
data EntryContent = NormalFile !BS.ByteString
| Directory
- | Symlink !FilePath
+ | Symlink !FilePath !Symlink
| Hardlink !FilePath
deriving (Show, Eq)
diff --git a/src/Codec/Archive/Types/Foreign.chs b/src/Codec/Archive/Types/Foreign.chs
index ca68da1..4c6cee1 100644
--- a/src/Codec/Archive/Types/Foreign.chs
+++ b/src/Codec/Archive/Types/Foreign.chs
@@ -67,7 +67,7 @@ type LaSSize = {# type la_ssize_t #}
{# enum define Symlink { AE_SYMLINK_TYPE_UNDEFINED as SymlinkUndefined
, AE_SYMLINK_TYPE_FILE as SymlinkFile
, AE_SYMLINK_TYPE_DIRECTORY as SymlinkDirectory
- } deriving (Eq)
+ } deriving (Show, Eq)
#}
{# enum define ArchiveFilter { ARCHIVE_FILTER_NONE as ArchiveFilterNone
diff --git a/src/Codec/Archive/Unpack.hs b/src/Codec/Archive/Unpack.hs
index d3f19d0..937b1cc 100644
--- a/src/Codec/Archive/Unpack.hs
+++ b/src/Codec/Archive/Unpack.hs
@@ -45,14 +45,13 @@ bsToArchive bs = do
--
-- @since 1.0.0.0
readArchiveFile :: FilePath -> ArchiveM [Entry]
-readArchiveFile = actFree hsEntries <=< archiveFile
+readArchiveFile fp = actFree archiveReadNew (\a -> archiveFile fp a *> hsEntries a)
+-- actFree hsEntries <=< a dorchiveFile
-archiveFile :: FilePath -> ArchiveM (Ptr Archive)
-archiveFile fp = withCStringArchiveM fp $ \cpath -> do
- a <- liftIO archiveReadNew
- ignore $ archiveReadSupportFormatAll a
- handle $ archiveReadOpenFilename a cpath 10240
- pure a
+archiveFile :: FilePath -> Ptr Archive -> ArchiveM ()
+archiveFile fp a = withCStringArchiveM fp $ \cpath ->
+ ignore (archiveReadSupportFormatAll a) *>
+ handle (archiveReadOpenFilename a cpath 10240)
-- | This is more efficient than
--
@@ -62,11 +61,13 @@ archiveFile fp = withCStringArchiveM fp $ \cpath -> do
unpackArchive :: FilePath -- ^ Filepath pointing to archive
-> FilePath -- ^ Dirctory to unpack in
-> ArchiveM ()
-unpackArchive tarFp dirFp = do
- -- TODO: bracket here
- a <- archiveFile tarFp
- unpackEntriesFp a dirFp
- ignore $ archiveFree a
+unpackArchive tarFp dirFp =
+ bracketM
+ archiveReadNew
+ archiveFree
+ (\a ->
+ archiveFile tarFp a *>
+ unpackEntriesFp a dirFp)
readEntry :: Ptr Archive -> Ptr ArchiveEntry -> IO Entry
readEntry a entry =
@@ -128,7 +129,7 @@ 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)
+ go (Just FtLink) = Symlink <$> (peekCString =<< archiveEntrySymlink entry) <*> archiveEntrySymlinkType entry
go (Just FtDirectory) = pure Directory
go (Just _) = error "Unsupported filetype"
sz = fromIntegral <$> archiveEntrySize entry
diff --git a/test/Codec/Archive/Roundtrip.hs b/test/Codec/Archive/Roundtrip.hs
index 753da09..b3f637d 100644
--- a/test/Codec/Archive/Roundtrip.hs
+++ b/test/Codec/Archive/Roundtrip.hs
@@ -31,7 +31,7 @@ instance Show TestEntries where
("}" ++)
showsContent (NormalFile bytes) = ("(NormalFile $ " ++) . shows (BS.take 10 bytes) . (" <> undefined)" ++)
showsContent Directory = ("Directory" ++)
- showsContent (Symlink target) = ("(Symlink " ++) . shows target . (')':)
+ showsContent (Symlink target _) = ("(Symlink " ++) . shows target . (')':)
showsContent (Hardlink target) = ("(Hardlink " ++) . shows target . (')':)
joinBy :: ShowS -> [ShowS] -> ShowS
joinBy sep = thread . intersperse sep
diff --git a/test/Spec.hs b/test/Spec.hs
index 92e8b7a..c1805d4 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -8,6 +8,7 @@ import Data.Either (isRight)
import Data.Foldable (traverse_)
import System.Directory (doesDirectoryExist, listDirectory)
import System.FilePath ((</>))
+import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec
testFp :: FilePath -> Spec
@@ -22,6 +23,21 @@ testFpFreaky :: FilePath -> Spec
testFpFreaky fp = parallel $ it ("works on nonstandard bytestring (" ++ fp ++ ")") $
roundtripFreaky fp >>= (`shouldSatisfy` isRight)
+unpack :: FilePath -> IO (Either ArchiveResult ())
+unpack fp = withSystemTempDirectory "libarchive" $
+ \tmp -> runArchiveM $ unpackArchive fp tmp
+
+readArchiveFile' :: FilePath -> IO (Either ArchiveResult [Entry])
+readArchiveFile' = runArchiveM . readArchiveFile
+
+testUnpackLibarchive :: FilePath -> Spec
+testUnpackLibarchive fp = parallel $ it ("unpacks " ++ fp) $
+ unpack fp >>= (`shouldSatisfy` isRight)
+
+testReadArchiveFile :: FilePath -> Spec
+testReadArchiveFile fp = parallel $ it ("reads " ++ fp) $
+ readArchiveFile' fp >>= (`shouldSatisfy` isRight)
+
main :: IO ()
main = do
@@ -35,12 +51,14 @@ main = do
traverse_ testFp tarPaths
traverse_ testFpFreaky tarPaths
traverse_ testFpStrict tarPaths
+ traverse_ testUnpackLibarchive tarPaths
+ traverse_ testReadArchiveFile tarPaths
context "with symlinks" $ do
let entries =
[ simpleDir "x/"
, simpleFile "x/a.txt" (NormalFile "referenced")
- , simpleFile "x/b.txt" (Symlink "a.txt")
+ , simpleFile "x/b.txt" (Symlink "a.txt" SymlinkUndefined)
]
itPacksUnpacks entries
itPacksUnpacksViaFS entries