From 332be4d9ceee6436745c3e0e98ccee6cfeab2888 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 9 Oct 2017 16:08:02 +0200 Subject: [PATCH] Switch Zip to work on 'File's --- models | 23 ++++++------ src/Handler/Zip.hs | 81 ++++++++++++++++++----------------------- src/Model/Types.hs | 4 ++ test/Handler/ZipSpec.hs | 22 +++++------ 4 files changed, 61 insertions(+), 69 deletions(-) diff --git a/models b/models index e115ddd5e..45a202e9b 100644 --- a/models +++ b/models @@ -51,10 +51,6 @@ Sheet sheetType SheetType maxPoints Double Maybe requiredPoints Double Maybe - exerciseId FileId Maybe - hintId FileId Maybe - solutionId FileId Maybe - markingId FileId Maybe markingText Text activeFrom UTCTime activeTo UTCTime @@ -64,16 +60,18 @@ Sheet changed UTCTime createdBy UserId changedBy UserId +SheetFile + sheetId SheetId + fileId FileId + type SheetFileType + UniqueSheetFile fileId sheetId type File - title Text - content ByteString - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId + title FilePath + content ByteString Maybe -- Nothing iff this is a directory + modified UTCTime + deriving Show Eq Ord Submission sheetId SheetId - updateId FileId Maybe ratingBy UserId Maybe ratingPoints Double Maybe ratingComment Text Maybe @@ -85,7 +83,8 @@ Submission SubmissionFile submissionId SubmissionId fileId FileId - UniqueSubmissionFile fileId submissionId + isUpdate Bool + UniqueSubmissionFile fileId submissionId isUpdate SubmissionUser userId UserId submissionId SubmissionId diff --git a/src/Handler/Zip.hs b/src/Handler/Zip.hs index fab24fc85..7d589e87b 100644 --- a/src/Handler/Zip.hs +++ b/src/Handler/Zip.hs @@ -1,13 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns Zip.zipEntrySize in produceZip +{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Zip - ( Zip.ZipError(..) - , Zip.ZipInfo(..) - , ZipEntry(..) + ( ZipError(..) + , ZipInfo(..) , produceZip , consumeZip ) where @@ -16,14 +15,15 @@ import Import import qualified Data.Conduit.List as Conduit (map) -import qualified Codec.Archive.Zip.Conduit.Types as Zip -import qualified Codec.Archive.Zip.Conduit.UnZip as Zip -import qualified Codec.Archive.Zip.Conduit.Zip as Zip +import Codec.Archive.Zip.Conduit.Types +import Codec.Archive.Zip.Conduit.UnZip +import Codec.Archive.Zip.Conduit.Zip -import qualified Data.ByteString.Lazy as Lazy (ByteString) +-- import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy as Lazy.ByteString import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -31,21 +31,11 @@ import qualified Data.Text.Encoding as Text import System.FilePath import Data.Time -import GHC.Generics (Generic) -import Data.Typeable (Typeable) - import Data.List (dropWhileEnd) -data ZipEntry = ZipEntry - { zipEntryName :: FilePath - , zipEntryTime :: UTCTime - , zipEntryContents :: Maybe Lazy.ByteString -- ^ 'Nothing' means this is a directory - } deriving (Read, Show, Generic, Typeable, Eq, Ord) - - -instance Default Zip.ZipInfo where - def = Zip.ZipInfo +instance Default ZipInfo where + def = ZipInfo { zipComment = mempty } @@ -53,26 +43,27 @@ instance Default Zip.ZipInfo where consumeZip :: ( MonadBase b m , PrimMonad b , MonadThrow m - ) => (ZipEntry -> m a) -- ^ Handle entries (insert into database) - -> Sink ByteString m (Zip.ZipInfo, [a]) -consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip' + ) => ConduitM ByteString File m ZipInfo +consumeZip = unZipStream `fuseUpstream` consumeZip' where - -- consumeZip' :: Sink (Either Zip.ZipEntry ByteString) m [a] + consumeZip' :: ( MonadThrow m + ) => Conduit (Either ZipEntry ByteString) m File consumeZip' = do input <- await case input of - Nothing -> return [] + Nothing -> return () Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP" Just (Left e) -> do - zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ Zip.zipEntryName e - contentChunks <- accContents + zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ zipEntryName e + contentChunks <- toConsumer accContents let - zipEntryName = normalise $ makeValid zipEntryName' - zipEntryTime = localTimeToUTC utc $ Zip.zipEntryTime e - zipEntryContents + fileTitle = normalise $ makeValid zipEntryName' + fileModified = localTimeToUTC utc $ zipEntryTime e + fileContent | hasTrailingPathSeparator zipEntryName' = Nothing - | otherwise = Just $ Lazy.ByteString.fromChunks contentChunks - (:) <$> (lift $ handleEntry ZipEntry{..}) <*> consumeZip' + | otherwise = Just $ mconcat contentChunks + yield $ File{..} + consumeZip' accContents :: Monad m => Sink (Either a b) m [b] accContents = do input <- await @@ -84,25 +75,23 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip' produceZip :: ( MonadBase b m , PrimMonad b , MonadThrow m - ) => Zip.ZipInfo - -> Conduit ZipEntry m ByteString -produceZip info = Conduit.map toZipData =$= void (Zip.zipStream zipOptions) + ) => ZipInfo + -> Conduit File m ByteString +produceZip info = Conduit.map toZipData =$= void (zipStream zipOptions) where - zipOptions = Zip.ZipOptions + zipOptions = ZipOptions { zipOpt64 = True , zipOptCompressLevel = -1 -- This is passed through all the way to the C zlib, where it means "default level" , zipOptInfo = info } - toZipData :: Monad m => ZipEntry -> (Zip.ZipEntry, Zip.ZipData m) - toZipData (e@ZipEntry{ zipEntryContents = Nothing }) - = ((toZipEntry True e){ Zip.zipEntrySize = Nothing }, mempty) - toZipData (e@ZipEntry{ zipEntryContents = Just b}) - = ((toZipEntry False e){ Zip.zipEntrySize = Just . fromIntegral $ Lazy.ByteString.length b }, Zip.ZipDataByteString b) + toZipData :: Monad m => File -> (ZipEntry, ZipData m) + toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent) - toZipEntry :: Bool -- ^ Is directory? - -> ZipEntry -> Zip.ZipEntry - toZipEntry isDir ZipEntry{..} = Zip.ZipEntry - { zipEntryName = Text.encodeUtf8 . Text.pack . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ zipEntryName - , zipEntryTime = utcToLocalTime utc zipEntryTime + toZipEntry :: File -> ZipEntry + toZipEntry File{..} = ZipEntry + { zipEntryName = Text.encodeUtf8 . Text.pack . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle + , zipEntryTime = utcToLocalTime utc fileModified } + where + isDir = isNothing fileContent diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 5d7f3c3d7..e6966a773 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -37,6 +37,10 @@ data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "ExamStatus" +data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking + deriving (Show, Read, Eq, Ord, Enum, Bounded) +derivePersistField "SheetFileType" + data Season = Summer | Winter deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) diff --git a/test/Handler/ZipSpec.hs b/test/Handler/ZipSpec.hs index eebcb72d3..10a5ac901 100644 --- a/test/Handler/ZipSpec.hs +++ b/test/Handler/ZipSpec.hs @@ -16,27 +16,27 @@ import qualified Data.Conduit.List as Conduit import Data.List (dropWhileEnd) import Data.Time -instance Arbitrary ZipEntry where +instance Arbitrary File where arbitrary = do - zipEntryName <- joinPath <$> arbitrary + fileTitle <- joinPath <$> arbitrary let date = addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2) - zipEntryTime <- UTCTime <$> date <*> arbitrary - zipEntryContents <- arbitrary - return ZipEntry{..} + fileModified <- UTCTime <$> date <*> arbitrary + fileContent <- arbitrary + return File{..} spec :: Spec spec = describe "Zip file handling" $ do it "has compatible encoding/decoding to/from zip files" . property $ \zipFiles -> do - (_, zipFiles') <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= consumeZip return + (_, zipFiles') <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= consumeZip `fuseBoth` Conduit.consume forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do let acceptableFilenameChanges - = makeValid . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ zipEntryContents file) . normalise . makeValid + = makeValid . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2 - (shouldBe `on` acceptableFilenameChanges) (zipEntryName file') (zipEntryName file) - when (inZipRange $ zipEntryTime file) $ - (zipEntryTime file', zipEntryTime file) `shouldSatisfy` uncurry acceptableTimeDifference - (zipEntryContents file') `shouldBe` (zipEntryContents file) + (shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file) + when (inZipRange $ fileModified file) $ + (fileModified file', fileModified file) `shouldSatisfy` uncurry acceptableTimeDifference + (fileContent file') `shouldBe` (fileContent file) inZipRange :: UTCTime -> Bool inZipRange time