Test suite for zip handling

package.yaml

@@ -98,6 +98,8 @@ tests:
     - hspec >=2.0.0
     - QuickCheck
     - yesod-test
+    - conduit-extra
+    - quickcheck-instances
 
 # Define flags used by "yesod devel" to make compilation faster
 flags:

src/Handler/Zip.hs

@@ -7,6 +7,7 @@
 module Handler.Zip
   ( Zip.ZipError(..)
   , Zip.ZipInfo(..)
+  , ZipEntry(..)
   , produceZip
   , consumeZip
   ) where
@@ -38,7 +39,7 @@ data ZipEntry = ZipEntry
   { zipEntryName :: FilePath
   , zipEntryTime :: UTCTime
   , zipEntryContents :: Maybe Lazy.ByteString -- ^ 'Nothing' means this is a directory
-  } deriving (Read, Show, Generic, Typeable)
+  } deriving (Read, Show, Generic, Typeable, Eq, Ord)
 
 
 instance Default Zip.ZipInfo where
@@ -59,15 +60,15 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
       input <- await
       case input of
         Nothing -> return []
-        Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP"
+        Just (Right _) -> consumeZip' -- throw $ userError "Data chunk in unexpected place when parsing ZIP"
         Just (Left e) -> do
-          zipEntryName' <- either throw return . Text.decodeUtf8' $ Zip.zipEntryName e
+          zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ Zip.zipEntryName e
           contentChunks <- accContents
           let
-            zipEntryName = normalise . makeValid $ Text.unpack zipEntryName'
+            zipEntryName = normalise $ dropTrailingPathSeparator zipEntryName'
             zipEntryTime = localTimeToUTC utc $ Zip.zipEntryTime e
             zipEntryContents
-              | hasTrailingPathSeparator zipEntryName = Nothing
+              | hasTrailingPathSeparator zipEntryName' = Nothing
               | otherwise = Just $ Lazy.ByteString.fromChunks contentChunks
           (:) <$> (lift $ handleEntry ZipEntry{..}) <*> consumeZip'
     accContents :: Monad m => Sink (Either a b) m [b]
@@ -100,6 +101,6 @@ produceZip info = Conduit.map toZipData =$= void (Zip.zipStream zipOptions)
     toZipEntry :: Bool -- ^ Is directory?
                -> ZipEntry -> Zip.ZipEntry
     toZipEntry isDir ZipEntry{..} = Zip.ZipEntry
-      { zipEntryName = Text.encodeUtf8 . Text.pack . bool dropTrailingPathSeparator addTrailingPathSeparator isDir . normalise $ makeValid zipEntryName
+      { zipEntryName = Text.encodeUtf8 . Text.pack . bool dropTrailingPathSeparator addTrailingPathSeparator isDir . normalise $ zipEntryName
       , zipEntryTime = utcToLocalTime utc zipEntryTime
       }

test/Handler/ZipSpec.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.ZipSpec where
+
+import TestImport
+
+import Handler.Zip
+
+import System.FilePath
+
+import Data.Conduit
+import qualified Data.Conduit.List as Conduit
+import Data.Conduit.Binary (sourceLbs, sinkLbs)
+
+instance Arbitrary ZipEntry where
+  arbitrary = do
+    zipEntryName <- normalise . dropTrailingPathSeparator . joinPath <$> arbitrary
+    zipEntryTime <- arbitrary
+    zipEntryContents <- arbitrary
+    return ZipEntry{..}
+
+spec :: Spec
+spec = describe "Zip file handling" $ do
+  it "has compatible encoding/decoding to/from zip files" . property $
+    \zipFiles -> do
+      bs <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= sinkLbs
+      (_, zipFiles') <- runConduit $ sourceLbs bs =$= consumeZip return
+      zipFiles' `shouldBe` zipFiles

test/TestImport.hs

@@ -22,6 +22,8 @@ import Yesod.Test            as X
 import Yesod.Core.Unsafe     (fakeHandlerGetLogger)
 import Test.QuickCheck       as X
 import Test.QuickCheck.Gen   as X
+import Data.Default          as X
+import Test.QuickCheck.Instances as X
 
 runDB :: SqlPersistM a -> YesodExample UniWorX a
 runDB query = do