mirror of
https://github.com/simplex-chat/zip.git
synced 2026-06-03 09:17:33 +00:00
mrkkrp
5f7af58011
Now that the situation is clear, I think it's pretty safe to remove this additional run of the test suite. It's unlikely that we will run into new Zip64-related issues.
739 lines
26 KiB
Haskell
739 lines
26 KiB
Haskell
--
|
||
-- Tests for the ‘zip’ package.
|
||
--
|
||
-- Copyright © 2016–2017 Mark Karpov <markkarpov@openmailbox.org>
|
||
--
|
||
-- Redistribution and use in source and binary forms, with or without
|
||
-- modification, are permitted provided that the following conditions are
|
||
-- met:
|
||
--
|
||
-- * Redistributions of source code must retain the above copyright notice,
|
||
-- this list of conditions and the following disclaimer.
|
||
--
|
||
-- * Redistributions in binary form must reproduce the above copyright
|
||
-- notice, this list of conditions and the following disclaimer in the
|
||
-- documentation and/or other materials provided with the distribution.
|
||
--
|
||
-- * Neither the name Mark Karpov nor the names of contributors may be used
|
||
-- to endorse or promote products derived from this software without
|
||
-- specific prior written permission.
|
||
--
|
||
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY
|
||
-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
||
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
||
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
|
||
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
|
||
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
|
||
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||
-- POSSIBILITY OF SUCH DAMAGE.
|
||
|
||
{-# LANGUAGE FlexibleInstances #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE TemplateHaskell #-}
|
||
{-# OPTIONS -fno-warn-orphans #-}
|
||
|
||
module Main (main) where
|
||
|
||
import Codec.Archive.Zip
|
||
import Codec.Archive.Zip.CP437
|
||
import Control.Monad
|
||
import Control.Monad.Catch (catchIOError)
|
||
import Control.Monad.IO.Class
|
||
import Data.Bits (complement)
|
||
import Data.ByteString (ByteString)
|
||
import Data.Conduit (yield)
|
||
import Data.Foldable (foldl')
|
||
import Data.List (intercalate)
|
||
import Data.Map (Map, (!))
|
||
import Data.Maybe (fromJust)
|
||
import Data.Monoid
|
||
import Data.Text (Text)
|
||
import Data.Time
|
||
import Data.Version
|
||
import Path
|
||
import Path.IO
|
||
import System.IO
|
||
import System.IO.Error (isDoesNotExistError)
|
||
import Test.Hspec
|
||
import Test.QuickCheck
|
||
import qualified Data.ByteString as B
|
||
import qualified Data.ByteString.Builder as LB
|
||
import qualified Data.ByteString.Lazy as LB
|
||
import qualified Data.Conduit.List as CL
|
||
import qualified Data.Map as M
|
||
import qualified Data.Set as E
|
||
import qualified Data.Text as T
|
||
import qualified Data.Text.Encoding as T
|
||
import qualified System.FilePath.Windows as Windows
|
||
|
||
-- | Zip tests. Please note that Zip64 feature is not currently tested
|
||
-- automatically because for it to expose itself we need > 4GB of
|
||
-- data. Handling such quantities of data locally is problematic and even
|
||
-- more problematic in the context of CI server.
|
||
|
||
main :: IO ()
|
||
main = hspec $ do
|
||
describe "mkEntrySelector" mkEntrySelectorSpec
|
||
describe "unEntrySelector" unEntrySelectorSpec
|
||
describe "getEntryName" getEntryNameSpec
|
||
describe "decodeCP437" decodeCP437Spec
|
||
around withSandbox $ do
|
||
describe "createArchive" createArchiveSpec
|
||
describe "withArchive" withArchiveSpec
|
||
describe "archive comment" archiveCommentSpec
|
||
describe "getEntryDesc" getEntryDescSpec
|
||
describe "version needed" versionNeededSpec
|
||
describe "addEntry" addEntrySpec
|
||
describe "sinkEntry" sinkEntrySpec
|
||
describe "loadEntry" loadEntrySpec
|
||
describe "copyEntry" copyEntrySpec
|
||
describe "checkEntry" checkEntrySpec
|
||
describe "recompress" recompressSpec
|
||
describe "entry comment" entryCommentSpec
|
||
describe "setModTime" setModTimeSpec
|
||
describe "extra field" extraFieldSpec
|
||
describe "renameEntry" renameEntrySpec
|
||
describe "deleteEntry" deleteEntrySpec
|
||
describe "forEntries" forEntriesSpec
|
||
describe "undoEntryChanges" undoEntryChangesSpec
|
||
describe "undoArchiveChanges" undoArchiveChangesSpec
|
||
describe "undoAll" undoAllSpec
|
||
describe "consistency" consistencySpec
|
||
describe "packDirRecur" packDirRecurSpec
|
||
describe "unpackInto" unpackIntoSpec
|
||
|
||
----------------------------------------------------------------------------
|
||
-- Arbitrary instances and generators
|
||
|
||
instance Arbitrary Text where
|
||
arbitrary = T.pack <$> listOf1 arbitrary
|
||
|
||
instance Arbitrary ByteString where
|
||
arbitrary = B.pack <$> listOf arbitrary
|
||
|
||
instance Arbitrary CompressionMethod where
|
||
arbitrary = elements [Store, Deflate, BZip2]
|
||
|
||
instance Arbitrary UTCTime where
|
||
arbitrary = UTCTime
|
||
<$> (ModifiedJulianDay <$> choose (44239, 90989))
|
||
<*> (secondsToDiffTime <$> choose (0, 86399))
|
||
|
||
instance Arbitrary (Path Rel File) where
|
||
arbitrary = do
|
||
x <- intercalate "/" <$> listOf1 (listOf1 charGen)
|
||
case parseRelFile x of
|
||
Nothing -> arbitrary
|
||
Just path -> return path
|
||
|
||
instance Arbitrary EntrySelector where
|
||
arbitrary = do
|
||
x <- arbitrary
|
||
case mkEntrySelector x of
|
||
Nothing -> arbitrary
|
||
Just s -> return s
|
||
|
||
data EM = EM EntrySelector EntryDescription (ZipArchive ()) deriving Show
|
||
|
||
instance Arbitrary EM where
|
||
arbitrary = do
|
||
s <- arbitrary
|
||
method <- arbitrary
|
||
content <- arbitrary
|
||
modTime <- arbitrary
|
||
comment <- arbitrary
|
||
extraFieldTag <- arbitrary `suchThat` (/= 1)
|
||
extraFieldContent <- arbitrary `suchThat` ((< 0xffff) . B.length)
|
||
let action = do
|
||
addEntry method content s
|
||
setModTime modTime s
|
||
setEntryComment comment s
|
||
addExtraField extraFieldTag extraFieldContent s
|
||
return $ EM s EntryDescription
|
||
{ edVersionMadeBy = undefined
|
||
, edVersionNeeded = undefined
|
||
, edCompression = method
|
||
, edModTime = modTime
|
||
, edCRC32 = undefined
|
||
, edCompressedSize = undefined
|
||
, edUncompressedSize = fromIntegral (B.length content)
|
||
, edOffset = undefined
|
||
, edComment = Just comment
|
||
, edExtraField = M.singleton extraFieldTag extraFieldContent }
|
||
action
|
||
|
||
data EC = EC (Map EntrySelector EntryDescription) (ZipArchive ()) deriving Show
|
||
|
||
instance Arbitrary EC where
|
||
arbitrary = foldl' f (EC M.empty (return ())) <$> listOf1 arbitrary
|
||
where f (EC m z') (EM s desc z) = EC (M.insert s desc m) (z' >> z)
|
||
|
||
charGen :: Gen Char
|
||
charGen = frequency
|
||
[ (3, choose ('a', 'z'))
|
||
, (3, choose ('A', 'Z'))
|
||
, (3, choose ('0', '9'))
|
||
, (1, arbitrary `suchThat` (>= ' ')) ]
|
||
|
||
binASCII :: Gen ByteString
|
||
binASCII = LB.toStrict . LB.toLazyByteString <$> go
|
||
where go = frequency
|
||
[ (10, (<>) <$> (LB.word8 <$> choose (0, 127)) <*> go)
|
||
, (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) ++
|
||
" }"
|
||
|
||
instance Show (ZipArchive a) where
|
||
show = const "<zip archive>"
|
||
|
||
----------------------------------------------------------------------------
|
||
-- Pure operations and periphery
|
||
|
||
mkEntrySelectorSpec :: Spec
|
||
mkEntrySelectorSpec = do
|
||
context "when incorrect Windows paths are passed" $
|
||
it "rejects them" . property $ \path ->
|
||
(not . Windows.isValid . toFilePath $ path)
|
||
==> mkEntrySelector path === Nothing
|
||
context "when too long paths are passed" $
|
||
it "rejects them" $ do
|
||
path <- parseRelFile (replicate 0x10000 'a')
|
||
mkEntrySelector path `shouldThrow` isEntrySelectorException path
|
||
context "when correct paths are passed" $
|
||
it "adequately represents them" $ do
|
||
let c str = do
|
||
s <- parseRelFile str >>= mkEntrySelector
|
||
getEntryName s `shouldBe` T.pack str
|
||
c "one/two/three"
|
||
c "something.txt"
|
||
|
||
unEntrySelectorSpec :: Spec
|
||
unEntrySelectorSpec =
|
||
context "when entry selector exists" $
|
||
it "has corresponding path" . property $ \s ->
|
||
not . null . toFilePath . unEntrySelector $ s
|
||
|
||
getEntryNameSpec :: Spec
|
||
getEntryNameSpec =
|
||
context "when entry selector exists" $
|
||
it "has corresponding representation" . property $ \s ->
|
||
not . T.null . getEntryName $ s
|
||
|
||
decodeCP437Spec :: Spec
|
||
decodeCP437Spec = do
|
||
context "when ASCII-compatible subset is used" $
|
||
it "has the same result as decoding UTF-8" . property $
|
||
forAll binASCII $ \bin ->
|
||
decodeCP437 bin `shouldBe` T.decodeUtf8 bin
|
||
context "when non-ASCII subset is used" $
|
||
it "is decoded correctly" $ do
|
||
let c b t = decodeCP437 (B.pack b ) `shouldBe` t
|
||
c [0x80..0x9f] "ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜ¢£¥₧ƒ"
|
||
c [0xa0..0xbf] "áíóúñѪº¿⌐¬½¼¡«»░▒▓│┤╡╢╖╕╣║╗╝╜╛┐"
|
||
c [0xc0..0xdf] "└┴┬├─┼╞╟╚╔╩╦╠═╬╧╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀"
|
||
c [0xe0..0xff] "αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■ "
|
||
|
||
----------------------------------------------------------------------------
|
||
-- Primitive editing/querying actions
|
||
|
||
createArchiveSpec :: SpecWith (Path Abs File)
|
||
createArchiveSpec = do
|
||
context "when called with non-existent path and empty recipe" $
|
||
it "creates correct representation of empty archive" $ \path -> do
|
||
createArchive path (return ())
|
||
B.readFile (toFilePath path) `shouldReturn` emptyArchive
|
||
context "when called with occupied path" $
|
||
it "overwrites it" $ \path -> do
|
||
B.writeFile (toFilePath path) B.empty
|
||
createArchive path (return ())
|
||
B.readFile (toFilePath path) `shouldNotReturn` B.empty
|
||
|
||
withArchiveSpec :: SpecWith (Path Abs File)
|
||
withArchiveSpec = do
|
||
context "when called with non-existent path" $
|
||
it "throws 'isDoesNotExistError' exception" $ \path ->
|
||
withArchive path (return ()) `shouldThrow` isDoesNotExistError
|
||
context "when called with occupied path (empty file)" $
|
||
it "throws 'ParsingFailed' exception" $ \path -> do
|
||
B.writeFile (toFilePath path) B.empty
|
||
withArchive path (return ()) `shouldThrow`
|
||
isParsingFailed path "Cannot locate end of central directory"
|
||
context "when called with occupied path (empty archive)" $
|
||
it "does not overwrite the file unnecessarily" $ \path -> do
|
||
let fp = toFilePath path
|
||
B.writeFile fp emptyArchive
|
||
withArchive path . liftIO $ B.writeFile fp B.empty
|
||
B.readFile fp `shouldNotReturn` emptyArchive
|
||
|
||
archiveCommentSpec :: SpecWith (Path Abs File)
|
||
archiveCommentSpec = do
|
||
context "when new archive is created" $
|
||
it "returns no archive comment" $ \path ->
|
||
createArchive path getArchiveComment `shouldReturn` Nothing
|
||
context "when comment contains end of central directory signature" $
|
||
it "reads it without problems" $ \path -> do
|
||
entries <- createArchive path $ do
|
||
setArchiveComment "I saw you want to have PK\ENQ\ACK here."
|
||
commit
|
||
getEntries
|
||
entries `shouldBe` M.empty
|
||
context "when comment is committed (delete/set)" $
|
||
it "reads it and updates" $ \path -> property $ \txt -> do
|
||
comment <- createArchive path $ do
|
||
deleteArchiveComment
|
||
setArchiveComment txt
|
||
commit
|
||
getArchiveComment
|
||
comment `shouldBe` Just txt
|
||
context "when comment is committed (set/delete)" $
|
||
it "reads it and updates" $ \path -> property $ \txt -> do
|
||
comment <- createArchive path $ do
|
||
setArchiveComment txt
|
||
deleteArchiveComment
|
||
commit
|
||
getArchiveComment
|
||
comment `shouldBe` Nothing
|
||
context "when pre-existing comment is overwritten" $
|
||
it "returns the new comment" $ \path -> property $ \txt txt' -> do
|
||
comment <- createArchive path $ do
|
||
setArchiveComment txt
|
||
commit
|
||
setArchiveComment txt'
|
||
commit
|
||
getArchiveComment
|
||
comment `shouldBe` Just txt'
|
||
context "when pre-existing comment is deleted" $
|
||
it "actually deletes it" $ \path -> property $ \txt -> do
|
||
comment <- createArchive path $ do
|
||
setArchiveComment txt
|
||
commit
|
||
deleteArchiveComment
|
||
commit
|
||
getArchiveComment
|
||
comment `shouldBe` Nothing
|
||
|
||
getEntryDescSpec :: SpecWith (Path Abs File)
|
||
getEntryDescSpec =
|
||
it "always returns correct description" $
|
||
\path -> property $ \(EM s desc z) -> do
|
||
desc' <- fromJust <$> createArchive path (z >> commit >> getEntryDesc s)
|
||
desc' `shouldSatisfy` softEq desc
|
||
|
||
versionNeededSpec :: SpecWith (Path Abs File)
|
||
versionNeededSpec =
|
||
it "writes correct version that is needed to extract archive" $
|
||
-- NOTE for now we check only how version depends on compression method,
|
||
-- it should be mentioned that the version also depends on Zip64 feature
|
||
\path -> 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])
|
||
|
||
addEntrySpec :: SpecWith (Path Abs File)
|
||
addEntrySpec =
|
||
context "when an entry is added" $
|
||
it "is there" $ \path -> property $ \m b s -> do
|
||
info <- createArchive path $ do
|
||
addEntry m b s
|
||
commit
|
||
(,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)
|
||
info `shouldBe` (b, m)
|
||
|
||
sinkEntrySpec :: SpecWith (Path Abs File)
|
||
sinkEntrySpec =
|
||
context "when an entry is sunk" $
|
||
it "is there" $ \path -> property $ \m b s -> do
|
||
info <- createArchive path $ do
|
||
sinkEntry m (yield b) s
|
||
commit
|
||
(,) <$> sourceEntry s (CL.foldMap id)
|
||
<*> (edCompression . (! s) <$> getEntries)
|
||
info `shouldBe` (b, m)
|
||
|
||
loadEntrySpec :: SpecWith (Path Abs File)
|
||
loadEntrySpec =
|
||
context "when an entry is loaded" $
|
||
it "is there" $ \path -> property $ \m b s -> do
|
||
let vpath = deriveVacant path
|
||
B.writeFile (toFilePath vpath) b
|
||
createArchive path $ do
|
||
loadEntry m (const $ return s) vpath
|
||
commit
|
||
liftIO (removeFile vpath)
|
||
saveEntry s vpath
|
||
B.readFile (toFilePath vpath) `shouldReturn` b
|
||
|
||
copyEntrySpec :: SpecWith (Path Abs File)
|
||
copyEntrySpec =
|
||
context "when entry is copied form another archive" $
|
||
it "is there" $ \path -> property $ \m b s -> do
|
||
let vpath = deriveVacant path
|
||
createArchive vpath (addEntry m b s)
|
||
info <- createArchive path $ do
|
||
copyEntry vpath s s
|
||
commit
|
||
(,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)
|
||
info `shouldBe` (b, m)
|
||
|
||
checkEntrySpec :: SpecWith (Path Abs File)
|
||
checkEntrySpec = do
|
||
context "when entry is intact" $
|
||
it "passes the check" $ \path -> property $ \m b s -> do
|
||
check <- createArchive path $ do
|
||
addEntry m b s
|
||
commit
|
||
checkEntry s
|
||
check `shouldBe` True
|
||
context "when entry is corrupted" $
|
||
it "does not pass the check" $ \path -> property $ \b s ->
|
||
not (B.null b) ==> do
|
||
let r = 50 + (B.length . T.encodeUtf8 . getEntryName $ s)
|
||
offset <- createArchive path $ do
|
||
addEntry Store b s
|
||
commit
|
||
fromIntegral . edOffset . (! s) <$> getEntries
|
||
withFile (toFilePath path) ReadWriteMode $ \h -> do
|
||
hSeek h AbsoluteSeek (offset + fromIntegral r)
|
||
byte <- B.map complement <$> B.hGet h 1
|
||
hSeek h RelativeSeek (-1)
|
||
B.hPut h byte
|
||
withArchive path (checkEntry s) `shouldReturn` False
|
||
|
||
recompressSpec :: SpecWith (Path Abs File)
|
||
recompressSpec =
|
||
context "when recompression is used" $
|
||
it "gets recompressed" $ \path -> property $ \m m' b s -> do
|
||
info <- createArchive path $ do
|
||
addEntry m b s
|
||
commit
|
||
recompress m' s
|
||
commit
|
||
(,) <$> getEntry s <*> (edCompression . (! s) <$> getEntries)
|
||
info `shouldBe` (b, m')
|
||
|
||
entryCommentSpec :: SpecWith (Path Abs File)
|
||
entryCommentSpec = do
|
||
context "when comment is committed (delete/set)" $
|
||
it "reads it and updates" $ \path -> property $ \txt s -> do
|
||
comment <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
deleteEntryComment s
|
||
setEntryComment txt s
|
||
commit
|
||
edComment . (! s) <$> getEntries
|
||
comment `shouldBe` Just txt
|
||
context "when comment is committed (set/delete)" $
|
||
it "reads it and updates" $ \path -> property $ \txt s -> do
|
||
comment <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
setEntryComment txt s
|
||
deleteEntryComment s
|
||
commit
|
||
edComment . (! s) <$> getEntries
|
||
comment `shouldBe` Nothing
|
||
context "when pre-existing comment is overwritten" $
|
||
it "returns the new comment" $ \path -> property $ \txt txt' s -> do
|
||
comment <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
setEntryComment txt s
|
||
commit
|
||
setEntryComment txt' s
|
||
commit
|
||
edComment . (! s) <$> getEntries
|
||
comment `shouldBe` Just txt'
|
||
context "when pre-existing comment is deleted" $
|
||
it "actually deletes it" $ \path -> property $ \txt s -> do
|
||
comment <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
setEntryComment txt s
|
||
commit
|
||
deleteEntryComment s
|
||
commit
|
||
edComment . (! s) <$> getEntries
|
||
comment `shouldBe` Nothing
|
||
|
||
setModTimeSpec :: SpecWith (Path Abs File)
|
||
setModTimeSpec = do
|
||
context "when mod time is set (after creation)" $
|
||
it "reads it and updates" $ \path -> property $ \time s -> do
|
||
modTime <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
setModTime time s
|
||
commit
|
||
edModTime . (! s) <$> getEntries
|
||
modTime `shouldSatisfy` isCloseTo time
|
||
context "when mod time is set (before creation)" $
|
||
it "has no effect" $ \path -> property $ \time time' s ->
|
||
not (isCloseTo time time') ==> do
|
||
modTime <- createArchive path $ do
|
||
setModTime time s
|
||
addEntry Store "foo" s
|
||
commit
|
||
edModTime . (! s) <$> getEntries
|
||
modTime `shouldNotSatisfy` isCloseTo time
|
||
|
||
extraFieldSpec :: SpecWith (Path Abs File)
|
||
extraFieldSpec = do
|
||
context "when extra field is committed (delete/set)" $
|
||
it "reads it and updates" $ \path -> property $ \n b s ->
|
||
n /= 1 ==> do
|
||
efield <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
deleteExtraField n s
|
||
addExtraField n b s
|
||
commit
|
||
M.lookup n . edExtraField . (! s) <$> getEntries
|
||
efield `shouldBe` Just b
|
||
context "when extra field is committed (set/delete)" $
|
||
it "reads it and updates" $ \path -> property $ \n b s ->
|
||
n /= 1 ==> do
|
||
efield <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
addExtraField n b s
|
||
deleteExtraField n s
|
||
commit
|
||
M.lookup n . edExtraField . (! s) <$> getEntries
|
||
efield `shouldBe` Nothing
|
||
context "when pre-existing extra field is overwritten" $
|
||
it "reads it and updates" $ \path -> property $ \n b b' s ->
|
||
n /= 1 ==> do
|
||
efield <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
addExtraField n b s
|
||
commit
|
||
addExtraField n b' s
|
||
commit
|
||
M.lookup n . edExtraField . (! s) <$> getEntries
|
||
efield `shouldBe` Just b'
|
||
context "when pre-existing extra field is deleted" $
|
||
it "actually deletes it" $ \path -> property $ \n b s ->
|
||
n /= 1 ==> do
|
||
efield <- createArchive path $ do
|
||
addEntry Store "foo" s
|
||
addExtraField n b s
|
||
commit
|
||
deleteExtraField n s
|
||
commit
|
||
M.lookup n . edExtraField . (! s) <$> getEntries
|
||
efield `shouldBe` Nothing
|
||
|
||
renameEntrySpec :: SpecWith (Path Abs File)
|
||
renameEntrySpec = do
|
||
context "when renaming after editing of new entry" $
|
||
it "produces correct result" $ \path -> property $ \(EM s desc z) s' -> do
|
||
desc' <- createArchive path $ do
|
||
z
|
||
renameEntry s s'
|
||
commit
|
||
(! s') <$> getEntries
|
||
desc' `shouldSatisfy` softEq desc
|
||
context "when renaming existing entry" $
|
||
it "gets renamed" $ \path -> property $ \(EM s desc z) s' -> do
|
||
desc' <- createArchive path $ do
|
||
z
|
||
commit
|
||
renameEntry s s'
|
||
commit
|
||
(! s') <$> getEntries
|
||
desc' `shouldSatisfy` softEq desc
|
||
|
||
deleteEntrySpec :: SpecWith (Path Abs File)
|
||
deleteEntrySpec = do
|
||
context "when deleting after editing of new entry" $
|
||
it "produces correct result" $ \path -> property $ \(EM s _ z) -> do
|
||
member <- createArchive path $ do
|
||
z
|
||
deleteEntry s
|
||
commit
|
||
doesEntryExist s
|
||
member `shouldBe` False
|
||
context "when deleting existing entry" $
|
||
it "gets deleted" $ \path -> property $ \(EM s _ z) -> do
|
||
member <- createArchive path $ do
|
||
z
|
||
commit
|
||
deleteEntry s
|
||
commit
|
||
doesEntryExist s
|
||
member `shouldBe` False
|
||
|
||
forEntriesSpec :: SpecWith (Path Abs File)
|
||
forEntriesSpec =
|
||
it "affects all existing entries" $ \path -> property $ \(EC m z) txt -> do
|
||
m' <- createArchive path $ do
|
||
z
|
||
commit
|
||
forEntries (setEntryComment txt)
|
||
commit
|
||
getEntries
|
||
let f ed = ed { edComment = Just txt }
|
||
m' `shouldSatisfy` softEqMap (M.map f m)
|
||
|
||
undoEntryChangesSpec :: SpecWith (Path Abs File)
|
||
undoEntryChangesSpec =
|
||
it "cancels all actions for specified entry" $
|
||
\path -> property $ \(EM s _ z) -> do
|
||
member <- createArchive path $ do
|
||
z
|
||
undoEntryChanges s
|
||
commit
|
||
doesEntryExist s
|
||
member `shouldBe` False
|
||
|
||
undoArchiveChangesSpec :: SpecWith (Path Abs File)
|
||
undoArchiveChangesSpec = do
|
||
it "cancels archive comment editing" $ \path -> property $ \txt -> do
|
||
comment <- createArchive path $ do
|
||
setArchiveComment txt
|
||
undoArchiveChanges
|
||
commit
|
||
getArchiveComment
|
||
comment `shouldBe` Nothing
|
||
it "cancels archive comment deletion" $ \path -> property $ \txt -> do
|
||
comment <- createArchive path $ do
|
||
setArchiveComment txt
|
||
commit
|
||
deleteArchiveComment
|
||
undoArchiveChanges
|
||
commit
|
||
getArchiveComment
|
||
comment `shouldBe` Just txt
|
||
|
||
undoAllSpec :: SpecWith (Path Abs File)
|
||
undoAllSpec =
|
||
it "cancels all editing at once" $ \path -> property $ \(EC _ z) txt -> do
|
||
let fp = toFilePath path
|
||
createArchive path (return ())
|
||
withArchive path $ do
|
||
z
|
||
setArchiveComment txt
|
||
undoAll
|
||
liftIO (B.writeFile fp B.empty)
|
||
B.readFile fp `shouldReturn` B.empty
|
||
|
||
----------------------------------------------------------------------------
|
||
-- Complex construction/restoration
|
||
|
||
consistencySpec :: SpecWith (Path Abs File)
|
||
consistencySpec =
|
||
it "can save and restore arbitrary archive" $
|
||
\path -> property $ \(EC m z) txt -> do
|
||
(txt', m') <- createArchive path $ do
|
||
z
|
||
setArchiveComment txt
|
||
commit
|
||
(,) <$> getArchiveComment <*> getEntries
|
||
txt' `shouldBe` Just txt
|
||
m' `shouldSatisfy` softEqMap m
|
||
|
||
packDirRecurSpec :: SpecWith (Path Abs File)
|
||
packDirRecurSpec =
|
||
it "packs arbitrary directory recursively" $
|
||
\path -> property $ \contents -> do
|
||
let dir = parent path
|
||
f = stripDir dir >=> mkEntrySelector
|
||
blew <- catchIOError (do
|
||
forM_ contents $ \s -> do
|
||
let item = dir </> unEntrySelector s
|
||
ensureDir (parent item)
|
||
B.writeFile (toFilePath item) "foo"
|
||
return False)
|
||
(const $ return True)
|
||
when blew discard -- TODO
|
||
selectors <- M.keysSet <$>
|
||
createArchive path (packDirRecur Store f dir >> commit >> getEntries)
|
||
selectors `shouldBe` E.fromList contents
|
||
|
||
unpackIntoSpec :: SpecWith (Path Abs File)
|
||
unpackIntoSpec =
|
||
it "unpacks archive contents into directory" $
|
||
\path -> property $ \(EC m z) -> do
|
||
let dir = parent path
|
||
blew <- createArchive path $ do
|
||
z
|
||
commit
|
||
catchIOError
|
||
(unpackInto dir >> return False)
|
||
(const $ return True)
|
||
when blew discard -- TODO
|
||
removeFile path
|
||
selectors <- listDirRecur dir >>=
|
||
mapM (stripDir dir >=> mkEntrySelector) . snd
|
||
E.fromList selectors `shouldBe` M.keysSet m
|
||
|
||
----------------------------------------------------------------------------
|
||
-- Helpers
|
||
|
||
-- | Check whether given exception is 'EntrySelectorException' with specific
|
||
-- path inside.
|
||
|
||
isEntrySelectorException :: Path Rel File -> EntrySelectorException -> Bool
|
||
isEntrySelectorException path (InvalidEntrySelector p) = p == path
|
||
|
||
-- | Check whether given exception is 'ParsingFailed' exception with
|
||
-- specific path and error message inside.
|
||
|
||
isParsingFailed :: Path Abs File -> String -> ZipException -> Bool
|
||
isParsingFailed path msg (ParsingFailed path' msg') =
|
||
path == path' && msg == msg'
|
||
isParsingFailed _ _ _ = False
|
||
|
||
-- | Create sandbox directory to model some situation in it and run some
|
||
-- tests. Note that we're using new unique sandbox directory for each test
|
||
-- case to avoid contamination and it's unconditionally deleted after test
|
||
-- case finishes. The function returns vacant file path in that directory.
|
||
|
||
withSandbox :: ActionWith (Path Abs File) -> IO ()
|
||
withSandbox action = withSystemTempDir "zip-sandbox" $ \dir ->
|
||
action (dir </> $(mkRelFile "foo.zip"))
|
||
|
||
-- | Given primary name (name of archive), generate a name that does not
|
||
-- collide with it.
|
||
|
||
deriveVacant :: Path Abs File -> Path Abs File
|
||
deriveVacant = (</> $(mkRelFile "bar")) . parent
|
||
|
||
-- | Compare times forgiving minor difference.
|
||
|
||
isCloseTo :: UTCTime -> UTCTime -> Bool
|
||
isCloseTo a b = abs (diffUTCTime a b) < 2
|
||
|
||
-- | Compare only some fields of 'EntryDescription' record.
|
||
|
||
softEq :: EntryDescription -> EntryDescription -> Bool
|
||
softEq a b =
|
||
edCompression a == edCompression b &&
|
||
isCloseTo (edModTime a) (edModTime b) &&
|
||
edUncompressedSize a == edUncompressedSize b &&
|
||
edComment a == edComment b &&
|
||
M.delete 1 (edExtraField a) == M.delete 1 (edExtraField b)
|
||
|
||
-- | Compare two maps describing archive entries in such a way that only
|
||
-- some fields in 'EntryDescription' record are tested.
|
||
|
||
softEqMap
|
||
:: Map EntrySelector EntryDescription
|
||
-> Map EntrySelector EntryDescription
|
||
-> Bool
|
||
softEqMap n m = M.null (M.differenceWith f n m)
|
||
where f a b = if softEq a b then Nothing else Just a
|
||
|
||
-- | Canonical representation of empty Zip archive.
|
||
|
||
emptyArchive :: ByteString
|
||
emptyArchive = B.pack
|
||
[ 0x50, 0x4b, 0x05, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
|
||
, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ]
|