zip 1.1.0 → 1.2.0
raw patch · 7 files changed
+116/−19 lines, 7 filesdep ~basedep ~containersdep ~timenew-component:exe:haskell-zip-app
Dependency ranges changed: base, containers, time
Files
- CHANGELOG.md +5/−0
- Codec/Archive/Zip.hs +17/−4
- Codec/Archive/Zip/Internal.hs +35/−9
- Codec/Archive/Zip/Type.hs +4/−1
- bench-app/Main.hs +19/−0
- tests/Main.hs +17/−1
- zip.cabal +19/−4
CHANGELOG.md view
@@ -1,3 +1,8 @@+## Zip 1.2.0++* Added the `setExternalFileAttrs` function and the `edExternalFileAttrs`+ field in the `EntryDescription` record.+ ## Zip 1.1.0 * Made `saveEntry` and `unpackInto` restore modification time of files.
Codec/Archive/Zip.hs view
@@ -71,6 +71,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Codec.Archive.Zip@@ -121,6 +122,7 @@ , setModTime , addExtraField , deleteExtraField+ , setExternalFileAttrs , forEntries -- ** Operations on archive as a whole , setArchiveComment@@ -147,7 +149,7 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Void-import Data.Word (Word16)+import Data.Word (Word16, Word32) import System.Directory import System.FilePath ((</>)) import System.IO.Error (isDoesNotExistError)@@ -189,7 +191,7 @@ instance MonadBaseControl IO ZipArchive where type StM ZipArchive a = (a, ZipState) liftBaseWith f = ZipArchive . StateT $ \s ->- (\x -> (x, s)) <$> f (flip runStateT s . unZipArchive)+ (, s) <$> f (flip runStateT s . unZipArchive) {-# INLINEABLE liftBaseWith #-} restoreM = ZipArchive . StateT . const . return {-# INLINEABLE restoreM #-}@@ -227,7 +229,7 @@ , zsEntries = M.empty , zsArchive = ArchiveDescription Nothing 0 0 , zsActions = S.empty }- action = unZipArchive (liftM2 const m commit)+ action = unZipArchive (m <* commit) evalStateT action st -- | Work with an existing archive. See 'createArchive' if you want to@@ -267,7 +269,7 @@ , zsEntries = entries , zsArchive = desc , zsActions = S.empty }- action = unZipArchive (liftM2 const m commit)+ action = unZipArchive (m <* commit) liftIO (evalStateT action st) ----------------------------------------------------------------------------@@ -529,6 +531,17 @@ -> EntrySelector -- ^ Name of entry to modify -> ZipArchive () deleteExtraField n s = addPending (I.DeleteExtraField n s)++-- | Set external file attributes.+--+-- @since 1.2.0++setExternalFileAttrs+ :: Word32 -- ^ External file attributes+ -> EntrySelector -- ^ Name of entry to modify+ -> ZipArchive ()+setExternalFileAttrs attrs s =+ addPending (I.SetExternalFileAttributes attrs s) -- | Perform an action on every entry in the archive.
Codec/Archive/Zip/Internal.hs view
@@ -9,7 +9,10 @@ -- -- Low-level, non-public concepts and operations. +{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} module Codec.Archive.Zip.Internal ( PendingAction (..)@@ -95,6 +98,8 @@ -- ^ Set comment for entire archive | DeleteArchiveComment -- ^ Delete comment of entire archive+ | SetExternalFileAttributes Word32 EntrySelector+ -- ^ Set an external file attribute for specified entry -- | Collection of maps describing how to produce entries in resulting -- archive.@@ -113,7 +118,8 @@ , eaDeleteComment :: Map EntrySelector () , eaModTime :: Map EntrySelector UTCTime , eaExtraField :: Map EntrySelector (Map Word16 ByteString)- , eaDeleteField :: Map EntrySelector (Map Word16 ()) }+ , eaDeleteField :: Map EntrySelector (Map Word16 ())+ , eaExtFileAttr :: Map EntrySelector Word32 } -- | Origin of entries that can be streamed into archive. @@ -309,7 +315,7 @@ -> (ProducingActions, EditingActions) -- ^ Optimized data optimize = foldl' f ( ProducingActions M.empty M.empty- , EditingActions M.empty M.empty M.empty M.empty M.empty M.empty )+ , EditingActions M.empty M.empty M.empty M.empty M.empty M.empty M.empty) where f (pa, ea) a = case a of SinkEntry m src s ->@@ -354,6 +360,9 @@ ( pa , ea { eaExtraField = M.alter (er n) s (eaExtraField ea) , eaDeleteField = M.alter (ef n ()) s (eaDeleteField ea) } )+ SetExternalFileAttributes b s ->+ ( pa+ , ea { eaExtFileAttr = M.insert s b (eaExtFileAttr ea) }) _ -> (pa, ea) clearEditingFor s ea = ea { eaCompression = M.delete s (eaCompression ea)@@ -361,7 +370,8 @@ , eaDeleteComment = M.delete s (eaDeleteComment ea) , eaModTime = M.delete s (eaModTime ea) , eaExtraField = M.delete s (eaExtraField ea)- , eaDeleteField = M.delete s (eaDeleteField ea) }+ , eaDeleteField = M.delete s (eaDeleteField ea)+ , eaExtFileAttr = M.delete s (eaExtFileAttr ea) } re o n x = if x == o then n else x ef k v (Just m) = Just (M.insert k v m) ef k v Nothing = Just (M.singleton k v)@@ -412,6 +422,9 @@ modTime = case o of GenericOrigin -> currentTime Borrowed ed -> edModTime ed+ extFileAttr = case o of+ GenericOrigin -> M.findWithDefault 0 s eaExtFileAttr+ Borrowed _ -> M.findWithDefault 0 s eaExtFileAttr oldExtraFields = case o of GenericOrigin -> M.empty Borrowed ed -> edExtraField ed@@ -432,7 +445,8 @@ , edUncompressedSize = 0 -- ↑ , edOffset = fromIntegral offset , edComment = M.lookup s eaEntryComment <|> oldComment- , edExtraField = extraField }+ , edExtraField = extraField+ , edExternalFileAttrs = extFileAttr } B.hPut h (runPut (putHeader LocalHeader s desc0)) DataDescriptor {..} <- C.runConduitRes $ if recompression@@ -571,7 +585,8 @@ fileNameSize <- getWord16le -- file name length extraFieldSize <- getWord16le -- extra field length commentSize <- getWord16le -- file comment size- skip 8 -- disk number start, internal/external file attributes+ skip 4 -- disk number start, internal file attributes+ externalFileAttrs <- getWord32le -- external file attributes offset <- fromIntegral <$> getWord32le -- offset of local header fileName <- decodeText needUnicode <$> getBytes (fromIntegral fileNameSize) -- file name@@ -600,7 +615,8 @@ , edUncompressedSize = z64efUncompressedSize z64ef , edOffset = z64efOffset z64ef , edComment = if commentSize == 0 then Nothing else comment- , edExtraField = extraField }+ , edExtraField = extraField+ , edExternalFileAttrs = externalFileAttrs } in return $ (,desc) <$> (fileName >>= mkEntrySelector . T.unpack) -- | Parse an extra-field.@@ -707,7 +723,7 @@ putWord16le (fromIntegral $ B.length comment) -- file comment length putWord16le 0 -- disk number start putWord16le 0 -- internal file attributes- putWord32le 0 -- external file attributes+ putWord32le edExternalFileAttrs -- external file attributes putWord32le (withSaturation edOffset) -- relative offset of local header putByteString rawName -- file name (variable size) putByteString extraField -- extra field (variable size)@@ -913,6 +929,7 @@ targetEntry (SetModTime _ s) = Just s targetEntry (AddExtraField _ _ s) = Just s targetEntry (DeleteExtraField _ s) = Just s+targetEntry (SetExternalFileAttributes _ s) = Just s targetEntry (SetArchiveComment _) = Nothing targetEntry DeleteArchiveComment = Nothing @@ -1037,9 +1054,18 @@ month = fromIntegral $ shiftR msDosDate 5 .&. 0x0f year = 1980 + fromIntegral (shiftR msDosDate 9) --- | We use the constants of the type 'Natural' instead of literals to--- protect ourselves from overflows on 32 bit systems.+-- We use the constants of the type 'Natural' instead of literals to protect+-- ourselves from overflows on 32 bit systems.+--+-- If we're in development mode, use lower values so the tests get a chance+-- to check all cases (otherwise we would need to generate way too big+-- archives on CI). ffff, ffffffff :: Natural+#ifdef HASKELL_ZIP_DEV_MODE+ffff = 200+ffffffff = 5000+#else ffff = 0xffff ffffffff = 0xffffffff+#endif
Codec/Archive/Zip/Type.hs view
@@ -129,7 +129,7 @@ -- | The exception represents various troubles you can have with -- 'EntrySelector'. -data EntrySelectorException+newtype EntrySelectorException = InvalidEntrySelector FilePath -- ^ 'EntrySelector' cannot be created from this path deriving (Eq, Ord, Typeable)@@ -158,6 +158,9 @@ , edOffset :: Natural -- ^ Absolute offset of local file header , edComment :: Maybe Text -- ^ Entry comment , edExtraField :: Map Word16 ByteString -- ^ All extra fields found+ , edExternalFileAttrs :: Word32 -- ^ External file attributes+ --+ -- @since 1.2.0 } deriving (Eq, Typeable) -- | Supported compression methods.
+ bench-app/Main.hs view
@@ -0,0 +1,19 @@+module Main (main) where++import Codec.Archive.Zip+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.FilePath++main :: IO ()+main = do+ [operation, input, output] <- getArgs+ case operation of+ "compress" -> do+ selector <- mkEntrySelector (takeFileName input)+ createArchive output (loadEntry Deflate selector input)+ "uncompress" ->+ withArchive input (unpackInto output)+ _ -> do+ putStrLn "Unknown command."+ exitFailure
tests/Main.hs view
@@ -67,6 +67,7 @@ describe "entry comment" entryCommentSpec describe "setModTime" setModTimeSpec describe "extra field" extraFieldSpec+ describe "setExternalFileAttrsSpec" setExternalFileAttrsSpec describe "renameEntry" renameEntrySpec describe "deleteEntry" deleteEntrySpec describe "forEntries" forEntriesSpec@@ -124,6 +125,7 @@ content <- arbitrary modTime <- arbitrary comment <- arbitrary+ externalFileAttrs <- arbitrary extraFieldTag <- arbitrary `suchThat` (/= 1) extraFieldContent <- arbitrary `suchThat` ((< 0xffff) . B.length) let action = do@@ -131,6 +133,7 @@ setModTime modTime s setEntryComment comment s addExtraField extraFieldTag extraFieldContent s+ setExternalFileAttrs externalFileAttrs s return $ EM s EntryDescription { edVersionMadeBy = undefined , edVersionNeeded = undefined@@ -141,7 +144,8 @@ , edUncompressedSize = fromIntegral (B.length content) , edOffset = undefined , edComment = Just comment- , edExtraField = M.singleton extraFieldTag extraFieldContent }+ , edExtraField = M.singleton extraFieldTag extraFieldContent+ , edExternalFileAttrs = externalFileAttrs } action data EC = EC (Map EntrySelector EntryDescription) (ZipArchive ()) deriving Show@@ -171,6 +175,7 @@ "\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@@ -528,6 +533,17 @@ commit M.lookup n . edExtraField . (! s) <$> getEntries efield `shouldBe` Nothing++setExternalFileAttrsSpec :: SpecWith FilePath+setExternalFileAttrsSpec =+ context "when an external file attribute is added (after creation)" $+ it "sets a custom external file attribute" $ \path -> property $ \attr s -> do+ attr' <- createArchive path $ do+ addEntry Store "foo" s+ setExternalFileAttrs attr s+ commit+ edExternalFileAttrs . (! s) <$> getEntries+ attr' `shouldBe` attr renameEntrySpec :: SpecWith FilePath renameEntrySpec = do
zip.cabal view
@@ -1,7 +1,7 @@ name: zip-version: 1.1.0+version: 1.2.0 cabal-version: 1.18-tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.2+tested-with: GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 license: BSD3 license-file: LICENSE.md author: Mark Karpov <markkarpov92@gmail.com>@@ -43,8 +43,6 @@ , transformers-base if !impl(ghc >= 8.0) build-depends: semigroups >= 0.16- default-extensions: RecordWildCards- , TupleSections exposed-modules: Codec.Archive.Zip , Codec.Archive.Zip.CP437 other-modules: Codec.Archive.Zip.Internal@@ -55,6 +53,7 @@ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+ cpp-options: -DHASKELL_ZIP_DEV_MODE else ghc-options: -O2 -Wall default-language: Haskell2010@@ -87,3 +86,19 @@ source-repository head type: git location: https://github.com/mrkkrp/zip.git++executable haskell-zip-app+ main-is: Main.hs+ hs-source-dirs: bench-app+ build-depends: base >= 4.7 && < 5.0+ , filepath >= 1.2 && < 1.5+ , zip+ if flag(dev)+ ghc-options: -Wall -Werror -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wnoncanonical-monad-instances+ -Wnoncanonical-monadfail-instances+ else+ ghc-options: -O2 -Wall+ default-language: Haskell2010