diff --git a/package.yaml b/package.yaml index 46ec0daa1..f7f17cd5c 100644 --- a/package.yaml +++ b/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: diff --git a/src/Handler/Zip.hs b/src/Handler/Zip.hs index a75c84c9b..67a8f62b3 100644 --- a/src/Handler/Zip.hs +++ b/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 } diff --git a/test/Handler/ZipSpec.hs b/test/Handler/ZipSpec.hs new file mode 100644 index 000000000..681041b3a --- /dev/null +++ b/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 diff --git a/test/TestImport.hs b/test/TestImport.hs index 031453f19..768cafad7 100644 --- a/test/TestImport.hs +++ b/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