diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/Codec/Archive/Zip.hs b/Codec/Archive/Zip.hs --- a/Codec/Archive/Zip.hs +++ b/Codec/Archive/Zip.hs @@ -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. 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 @@ -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 diff --git a/Codec/Archive/Zip/Type.hs b/Codec/Archive/Zip/Type.hs --- a/Codec/Archive/Zip/Type.hs +++ b/Codec/Archive/Zip/Type.hs @@ -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. diff --git a/bench-app/Main.hs b/bench-app/Main.hs new file mode 100644 --- /dev/null +++ b/bench-app/Main.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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 diff --git a/zip.cabal b/zip.cabal --- a/zip.cabal +++ b/zip.cabal @@ -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 @@ -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