diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## Zip 2.1.0 + +* Exposed `Codec.Archive.Zip.Internal` and `Codec.Archive.Zip.Internal.Type` + modules. [PR 115](https://github.com/mrkkrp/zip/pull/115). + +* Derived `Show` for `EntryDescription`. [PR + 115](https://github.com/mrkkrp/zip/pull/115). + ## Zip 2.0.1 * Fixed corruption of large entries when zip64 is used. [Issue diff --git a/Codec/Archive/Zip.hs b/Codec/Archive/Zip.hs --- a/Codec/Archive/Zip.hs +++ b/Codec/Archive/Zip.hs @@ -147,7 +147,7 @@ where import Codec.Archive.Zip.Internal qualified as I -import Codec.Archive.Zip.Type +import Codec.Archive.Zip.Internal.Type import Conduit (PrimMonad) import Control.Monad import Control.Monad.Base (MonadBase (..)) diff --git a/Codec/Archive/Zip/Internal.hs b/Codec/Archive/Zip/Internal.hs --- a/Codec/Archive/Zip/Internal.hs +++ b/Codec/Archive/Zip/Internal.hs @@ -13,18 +13,10 @@ -- Portability : portable -- -- Low-level, non-public types and operations. -module Codec.Archive.Zip.Internal - ( PendingAction (..), - targetEntry, - scanArchive, - sourceEntry, - crc32Sink, - commit, - ) -where +module Codec.Archive.Zip.Internal where import Codec.Archive.Zip.CP437 (decodeCP437) -import Codec.Archive.Zip.Type +import Codec.Archive.Zip.Internal.Type import Conduit (PrimMonad) import Control.Applicative (many, (<|>)) import Control.Exception (bracketOnError, catchJust) @@ -1210,8 +1202,8 @@ ffff, ffffffff :: Natural #ifdef HASKELL_ZIP_DEV_MODE -ffff = 200 -ffffffff = 5000 +ffff = 25 +ffffffff = 250 #else ffff = 0xffff ffffffff = 0xffffffff diff --git a/Codec/Archive/Zip/Internal/Type.hs b/Codec/Archive/Zip/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/Codec/Archive/Zip/Internal/Type.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | +-- Module : Codec.Archive.Zip.Internal.Type +-- Copyright : © 2016–present Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Types used by the package. +module Codec.Archive.Zip.Internal.Type + ( -- * Entry selector + EntrySelector, + mkEntrySelector, + unEntrySelector, + getEntryName, + EntrySelectorException (..), + + -- * Entry description + EntryDescription (..), + CompressionMethod (..), + + -- * Archive description + ArchiveDescription (..), + + -- * Exceptions + ZipException (..), + ) +where + +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow (..)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.CaseInsensitive (CI) +import Data.CaseInsensitive qualified as CI +import Data.Data (Data) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Time.Clock (UTCTime) +import Data.Typeable (Typeable) +import Data.Version (Version) +import Data.Word (Word16, Word32) +import Numeric.Natural +import System.FilePath qualified as FP +import System.FilePath.Posix qualified as Posix +import System.FilePath.Windows qualified as Windows + +---------------------------------------------------------------------------- +-- Entry selector + +-- | This data type serves for naming and selection of archive entries. It +-- can be created only with the help of the smart constructor +-- 'mkEntrySelector', and it's the only “key” that can be used to refer to +-- files in the archive or to name new archive entries. +-- +-- The abstraction is crucial for ensuring that created archives are +-- portable across operating systems, file systems, and platforms. Since on +-- some operating systems, file paths are case-insensitive, this selector is +-- also case-insensitive. It makes sure that only relative paths are used to +-- name files inside archive, as it's recommended in the specification. It +-- also guarantees that forward slashes are used when the path is stored +-- inside the archive for compatibility with Unix-like operating systems (as +-- recommended in the specification). On the other hand, in can be rendered +-- as an ordinary relative file path in OS-specific format when needed. +newtype EntrySelector = EntrySelector + { -- | Path pieces of relative path inside archive + unES :: NonEmpty (CI String) + } + deriving (Eq, Ord, Typeable) + +instance Show EntrySelector where + show = show . unEntrySelector + +-- | Create an 'EntrySelector' from a 'FilePath'. To avoid problems with +-- distribution of the archive, characters that some operating systems do +-- not expect in paths are not allowed. +-- +-- Argument to 'mkEntrySelector' should pass these checks: +-- +-- * 'System.FilePath.Posix.isValid' +-- * 'System.FilePath.Windows.isValid' +-- * it is a relative path without slash at the end +-- * binary representations of normalized path should be not longer than +-- 65535 bytes +-- +-- This function can throw an 'EntrySelectorException'. +mkEntrySelector :: (MonadThrow m) => FilePath -> m EntrySelector +mkEntrySelector path = + let f x = + case filter (not . FP.isPathSeparator) x of + [] -> Nothing + xs -> Just (CI.mk xs) + giveup = throwM (InvalidEntrySelector path) + in case NE.nonEmpty (mapMaybe f (FP.splitPath path)) of + Nothing -> giveup + Just pieces -> + let selector = EntrySelector pieces + binLength = B.length . T.encodeUtf8 . getEntryName + in if Posix.isValid path + && Windows.isValid path + && not (FP.isAbsolute path || FP.hasTrailingPathSeparator path) + && (CI.mk "." `notElem` pieces) + && (CI.mk ".." `notElem` pieces) + && binLength selector <= 0xffff + then return selector + else giveup + +-- | Restore a relative path from 'EntrySelector'. Every 'EntrySelector' +-- corresponds to a 'FilePath'. +unEntrySelector :: EntrySelector -> FilePath +unEntrySelector = + FP.joinPath . fmap CI.original . NE.toList . unES + +-- | Get an entry name in the from that is suitable for writing to file +-- header, given an 'EntrySelector'. +getEntryName :: EntrySelector -> Text +getEntryName = + T.pack . concat . NE.toList . NE.intersperse "/" . fmap CI.original . unES + +-- | The problems you can have with an 'EntrySelector'. +newtype EntrySelectorException + = -- | 'EntrySelector' cannot be created from this path + InvalidEntrySelector FilePath + deriving (Eq, Ord, Typeable) + +instance Show EntrySelectorException where + show (InvalidEntrySelector path) = "Cannot build selector from " ++ show path + +instance Exception EntrySelectorException + +---------------------------------------------------------------------------- +-- Entry description + +-- | The information about archive entry that can be stored in a zip +-- archive. It does not mirror local file header or central directory file +-- header, but their binary representations can be built given this data +-- structure and the archive contents. +data EntryDescription = EntryDescription + { -- | Version made by + edVersionMadeBy :: Version, + -- | Version needed to extract + edVersionNeeded :: Version, + -- | Compression method + edCompression :: CompressionMethod, + -- | Last modification date and time + edModTime :: UTCTime, + -- | CRC32 check sum + edCRC32 :: Word32, + -- | Size of compressed entry + edCompressedSize :: Natural, + -- | Size of uncompressed entry + edUncompressedSize :: Natural, + -- | Absolute offset of local file header + edOffset :: Natural, + -- | Entry comment + edComment :: Maybe Text, + -- | All extra fields found + edExtraField :: Map Word16 ByteString, + -- | External file attributes + -- + -- @since 1.2.0 + edExternalFileAttrs :: Word32 + } + deriving (Eq, Typeable, Show) + +-- | The supported compression methods. +data CompressionMethod + = -- | Store file uncompressed + Store + | -- | Deflate + Deflate + | -- | Compressed using BZip2 algorithm + BZip2 + | -- | Compressed using Zstandard algorithm + -- + -- @since 1.6.0 + Zstd + deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable) + +---------------------------------------------------------------------------- +-- Archive description + +-- | The information about the archive as a whole. +data ArchiveDescription = ArchiveDescription + { -- | The comment of the entire archive + adComment :: Maybe Text, + -- | Absolute offset of the start of central directory + adCDOffset :: Natural, + -- | The size of central directory record + adCDSize :: Natural + } + deriving (Show, Read, Eq, Ord, Typeable, Data) + +---------------------------------------------------------------------------- +-- Exceptions + +-- | The bad things that can happen when you use the library. +data ZipException + = -- | Thrown when you try to get contents of non-existing entry + EntryDoesNotExist FilePath EntrySelector + | -- | Thrown when attempting to decompress an entry compressed with an + -- unsupported compression method or the library is compiled without + -- support for it. + -- + -- @since 2.0.0 + UnsupportedCompressionMethod CompressionMethod + | -- | Thrown when archive structure cannot be parsed. + ParsingFailed FilePath String + deriving (Eq, Ord, Typeable) + +instance Show ZipException where + show (EntryDoesNotExist file s) = + "No such entry found: " ++ show s ++ " in " ++ show file + show (ParsingFailed file msg) = + "Parsing of archive structure failed: \n" ++ msg ++ "\nin " ++ show file + show (UnsupportedCompressionMethod method) = + "Encountered a zipfile entry with " + ++ show method + ++ " compression, but " + ++ "zip library does not support it or has been built without support for it." + +instance Exception ZipException diff --git a/Codec/Archive/Zip/Type.hs b/Codec/Archive/Zip/Type.hs deleted file mode 100644 --- a/Codec/Archive/Zip/Type.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | --- Module : Codec.Archive.Zip.Type --- Copyright : © 2016–present Mark Karpov --- License : BSD 3 clause --- --- Maintainer : Mark Karpov --- Stability : experimental --- Portability : portable --- --- Types used by the package. -module Codec.Archive.Zip.Type - ( -- * Entry selector - EntrySelector, - mkEntrySelector, - unEntrySelector, - getEntryName, - EntrySelectorException (..), - - -- * Entry description - EntryDescription (..), - CompressionMethod (..), - - -- * Archive description - ArchiveDescription (..), - - -- * Exceptions - ZipException (..), - ) -where - -import Control.Exception (Exception) -import Control.Monad.Catch (MonadThrow (..)) -import Data.ByteString (ByteString) -import Data.ByteString qualified as B -import Data.CaseInsensitive (CI) -import Data.CaseInsensitive qualified as CI -import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as T -import Data.Time.Clock (UTCTime) -import Data.Typeable (Typeable) -import Data.Version (Version) -import Data.Word (Word16, Word32) -import Numeric.Natural -import System.FilePath qualified as FP -import System.FilePath.Posix qualified as Posix -import System.FilePath.Windows qualified as Windows - ----------------------------------------------------------------------------- --- Entry selector - --- | This data type serves for naming and selection of archive entries. It --- can be created only with the help of the smart constructor --- 'mkEntrySelector', and it's the only “key” that can be used to refer to --- files in the archive or to name new archive entries. --- --- The abstraction is crucial for ensuring that created archives are --- portable across operating systems, file systems, and platforms. Since on --- some operating systems, file paths are case-insensitive, this selector is --- also case-insensitive. It makes sure that only relative paths are used to --- name files inside archive, as it's recommended in the specification. It --- also guarantees that forward slashes are used when the path is stored --- inside the archive for compatibility with Unix-like operating systems (as --- recommended in the specification). On the other hand, in can be rendered --- as an ordinary relative file path in OS-specific format when needed. -newtype EntrySelector = EntrySelector - { -- | Path pieces of relative path inside archive - unES :: NonEmpty (CI String) - } - deriving (Eq, Ord, Typeable) - -instance Show EntrySelector where - show = show . unEntrySelector - --- | Create an 'EntrySelector' from a 'FilePath'. To avoid problems with --- distribution of the archive, characters that some operating systems do --- not expect in paths are not allowed. --- --- Argument to 'mkEntrySelector' should pass these checks: --- --- * 'System.FilePath.Posix.isValid' --- * 'System.FilePath.Windows.isValid' --- * it is a relative path without slash at the end --- * binary representations of normalized path should be not longer than --- 65535 bytes --- --- This function can throw an 'EntrySelectorException'. -mkEntrySelector :: (MonadThrow m) => FilePath -> m EntrySelector -mkEntrySelector path = - let f x = - case filter (not . FP.isPathSeparator) x of - [] -> Nothing - xs -> Just (CI.mk xs) - giveup = throwM (InvalidEntrySelector path) - in case NE.nonEmpty (mapMaybe f (FP.splitPath path)) of - Nothing -> giveup - Just pieces -> - let selector = EntrySelector pieces - binLength = B.length . T.encodeUtf8 . getEntryName - in if Posix.isValid path - && Windows.isValid path - && not (FP.isAbsolute path || FP.hasTrailingPathSeparator path) - && (CI.mk "." `notElem` pieces) - && (CI.mk ".." `notElem` pieces) - && binLength selector <= 0xffff - then return selector - else giveup - --- | Restore a relative path from 'EntrySelector'. Every 'EntrySelector' --- corresponds to a 'FilePath'. -unEntrySelector :: EntrySelector -> FilePath -unEntrySelector = - FP.joinPath . fmap CI.original . NE.toList . unES - --- | Get an entry name in the from that is suitable for writing to file --- header, given an 'EntrySelector'. -getEntryName :: EntrySelector -> Text -getEntryName = - T.pack . concat . NE.toList . NE.intersperse "/" . fmap CI.original . unES - --- | The problems you can have with an 'EntrySelector'. -newtype EntrySelectorException - = -- | 'EntrySelector' cannot be created from this path - InvalidEntrySelector FilePath - deriving (Eq, Ord, Typeable) - -instance Show EntrySelectorException where - show (InvalidEntrySelector path) = "Cannot build selector from " ++ show path - -instance Exception EntrySelectorException - ----------------------------------------------------------------------------- --- Entry description - --- | The information about archive entry that can be stored in a zip --- archive. It does not mirror local file header or central directory file --- header, but their binary representations can be built given this data --- structure and the archive contents. -data EntryDescription = EntryDescription - { -- | Version made by - edVersionMadeBy :: Version, - -- | Version needed to extract - edVersionNeeded :: Version, - -- | Compression method - edCompression :: CompressionMethod, - -- | Last modification date and time - edModTime :: UTCTime, - -- | CRC32 check sum - edCRC32 :: Word32, - -- | Size of compressed entry - edCompressedSize :: Natural, - -- | Size of uncompressed entry - edUncompressedSize :: Natural, - -- | Absolute offset of local file header - edOffset :: Natural, - -- | Entry comment - edComment :: Maybe Text, - -- | All extra fields found - edExtraField :: Map Word16 ByteString, - -- | External file attributes - -- - -- @since 1.2.0 - edExternalFileAttrs :: Word32 - } - deriving (Eq, Typeable) - --- | The supported compression methods. -data CompressionMethod - = -- | Store file uncompressed - Store - | -- | Deflate - Deflate - | -- | Compressed using BZip2 algorithm - BZip2 - | -- | Compressed using Zstandard algorithm - -- - -- @since 1.6.0 - Zstd - deriving (Show, Read, Eq, Ord, Enum, Bounded, Data, Typeable) - ----------------------------------------------------------------------------- --- Archive description - --- | The information about the archive as a whole. -data ArchiveDescription = ArchiveDescription - { -- | The comment of the entire archive - adComment :: Maybe Text, - -- | Absolute offset of the start of central directory - adCDOffset :: Natural, - -- | The size of central directory record - adCDSize :: Natural - } - deriving (Show, Read, Eq, Ord, Typeable, Data) - ----------------------------------------------------------------------------- --- Exceptions - --- | The bad things that can happen when you use the library. -data ZipException - = -- | Thrown when you try to get contents of non-existing entry - EntryDoesNotExist FilePath EntrySelector - | -- | Thrown when attempting to decompress an entry compressed with an - -- unsupported compression method or the library is compiled without - -- support for it. - -- - -- @since 2.0.0 - UnsupportedCompressionMethod CompressionMethod - | -- | Thrown when archive structure cannot be parsed. - ParsingFailed FilePath String - deriving (Eq, Ord, Typeable) - -instance Show ZipException where - show (EntryDoesNotExist file s) = - "No such entry found: " ++ show s ++ " in " ++ show file - show (ParsingFailed file msg) = - "Parsing of archive structure failed: \n" ++ msg ++ "\nin " ++ show file - show (UnsupportedCompressionMethod method) = - "Encountered a zipfile entry with " - ++ show method - ++ " compression, but " - ++ "zip library does not support it or has been built without support for it." - -instance Exception ZipException diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -30,6 +30,7 @@ import Data.Time import Data.Version import Data.Word +import Numeric.Natural import System.Directory import System.FilePath (()) import System.FilePath qualified as FP @@ -39,6 +40,14 @@ import Test.Hspec import Test.QuickCheck hiding ((.&.)) +ffffffff :: Natural + +#ifdef HASKELL_ZIP_DEV_MODE +ffffffff = 250 +#else +ffffffff = 0xffffffff +#endif + -- | Zip tests. Please note that the Zip64 feature is not currently tested -- automatically because we'd need > 4GB of data. Handling such quantities -- of data locally is problematic and even more problematic on CI. @@ -82,7 +91,7 @@ arbitrary = T.pack <$> listOf1 arbitrary instance Arbitrary ByteString where - arbitrary = B.pack <$> listOf arbitrary + arbitrary = B.pack <$> scale (* 10) (listOf arbitrary) {- ORMOLU_DISABLE -} @@ -195,22 +204,6 @@ (1, return mempty) ] -instance Show EntryDescription where - show ed = - "{ edCompression = " - ++ show (edCompression ed) - ++ "\n, edModTime = " - ++ show (edModTime ed) - ++ "\n, edUncompressedSize = " - ++ show (edUncompressedSize ed) - ++ "\n, edComment = " - ++ show (edComment ed) - ++ "\n, edExtraField = " - ++ show (edExtraField ed) - ++ "\n, edExtFileAttr = " - ++ show (edExternalFileAttrs ed) - ++ " }" - instance Show (ZipArchive a) where show = const "" @@ -385,14 +378,19 @@ -- it should be mentioned that the version also depends on Zip64 feature property $ \(EM s desc z) -> do desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s) - edVersionNeeded desc' - `shouldBe` makeVersion - ( case edCompression desc of - Store -> [2, 0] - Deflate -> [2, 0] - BZip2 -> [4, 6] - Zstd -> [6, 3] - ) + let minVersionZip64 = + makeVersion $ + if edUncompressedSize desc' >= ffffffff + || edCompressedSize desc' >= ffffffff + then [4, 5] + else [2, 0] + minVersionCompression = makeVersion $ case edCompression desc of + Store -> [2, 0] + Deflate -> [2, 0] + BZip2 -> [4, 6] + Zstd -> [6, 3] + versionNeeded = max minVersionZip64 minVersionCompression + edVersionNeeded desc' `shouldBe` versionNeeded addEntrySpec :: SpecWith FilePath addEntrySpec = @@ -402,6 +400,7 @@ info <- createArchive path $ do addEntry m b s commit + checkEntry' s (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries) info `shouldBe` (b, m) @@ -413,6 +412,7 @@ info <- createArchive path $ do sinkEntry m (C.yield b) s commit + checkEntry' s (,) <$> sourceEntry s (CL.foldMap id) <*> (edCompression . (! s) <$> getEntries) @@ -429,6 +429,7 @@ createArchive path $ do loadEntry m s vpath commit + checkEntry' s liftIO (removeFile vpath) saveEntry s vpath B.readFile vpath `shouldReturn` b @@ -445,6 +446,7 @@ info <- createArchive path $ do copyEntry vpath s s commit + checkEntry' s (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries) info `shouldBe` (b, m) @@ -452,12 +454,11 @@ checkEntrySpec = do context "when entry is intact" $ it "passes the check" $ \path -> - property $ \m b s -> do - check <- createArchive path $ do + property $ \m b s -> + asIO . createArchive path $ do addEntry m b s commit - checkEntry s - check `shouldBe` True + checkEntry' s context "when entry is corrupted" $ it "does not pass the check" $ \path -> property $ \b s -> @@ -485,8 +486,10 @@ info <- createArchive path $ do addEntry m b s commit + checkEntry' s recompress m' s commit + checkEntry' s (,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries) info `shouldBe` (b, m') @@ -796,6 +799,12 @@ withSandbox action = withSystemTempDirectory "zip-sandbox" $ \dir -> action (dir "foo.zip") +-- | Like 'checkEntry' but automatically aborts the test if the check fails. +checkEntry' :: EntrySelector -> ZipArchive () +checkEntry' s = do + r <- checkEntry s + liftIO (if r then return () else fail "Entry integrity check failed!") + -- | Given a primary name (name of archive), generate a name that does not -- collide with it. deriveVacant :: FilePath -> FilePath @@ -875,3 +884,7 @@ if isDir then go adir' else return mempty + +-- | Constrain the type of the argument monad to 'IO'. +asIO :: IO a -> IO a +asIO = id diff --git a/zip.cabal b/zip.cabal --- a/zip.cabal +++ b/zip.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: zip -version: 2.0.1 +version: 2.1.0 license: BSD-3-Clause license-file: LICENSE.md maintainer: Mark Karpov @@ -44,10 +44,8 @@ Codec.Archive.Zip Codec.Archive.Zip.CP437 Codec.Archive.Zip.Unix - - other-modules: Codec.Archive.Zip.Internal - Codec.Archive.Zip.Type + Codec.Archive.Zip.Internal.Type default-language: GHC2021 build-depends: @@ -137,6 +135,7 @@ zip if flag(dev) + cpp-options: -DHASKELL_ZIP_DEV_MODE ghc-options: -Wall -Werror -Wredundant-constraints -Wpartial-fields -Wunused-packages