diff --git a/models b/models index d08da58a6..c0f97f8dc 100644 --- a/models +++ b/models @@ -33,7 +33,7 @@ Course description Html Maybe linkexternal Text Maybe schoolId SchoolId - termId TermId -- TermId ist jetzt Text als Typ + termId TermId -- @data TermId = TermId TermIdentifier@ stored as text capacity Int Maybe created UTCTime changed UTCTime @@ -55,10 +55,6 @@ Sheet sheetType SheetType maxPoints Double Maybe requiredPoints Double Maybe - exerciseId FileId Maybe - hintId FileId Maybe - solutionId FileId Maybe - markingId FileId Maybe markingText Text Maybe activeFrom UTCTime activeTo UTCTime @@ -68,16 +64,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 @@ -89,7 +87,8 @@ Submission SubmissionFile submissionId SubmissionId fileId FileId - UniqueSubmissionFile fileId submissionId + isUpdate Bool + UniqueSubmissionFile fileId submissionId isUpdate SubmissionUser userId UserId submissionId SubmissionId diff --git a/package.yaml b/package.yaml index 190bfb3d7..3ad63a9f2 100644 --- a/package.yaml +++ b/package.yaml @@ -54,6 +54,8 @@ dependencies: - colonnade >=1.1.1 - yesod-colonnade >=1.1.0 - blaze-markup +- zip-stream +- filepath # The library contains all of our application code. The executable # defined below is just a thin wrapper. @@ -100,6 +102,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/Utils/Zip.hs b/src/Handler/Utils/Zip.hs new file mode 100644 index 000000000..4afcb8386 --- /dev/null +++ b/src/Handler/Utils/Zip.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Utils.Zip + ( ZipError(..) + , ZipInfo(..) + , produceZip + , consumeZip + ) where + +import Import + +import qualified Data.Conduit.List as Conduit (map) + +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 Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import System.FilePath +import Data.Time + +import Data.List (dropWhileEnd) + + +instance Default ZipInfo where + def = ZipInfo + { zipComment = mempty + } + + +consumeZip :: ( MonadBase b m + , PrimMonad b + , MonadThrow m + ) => ConduitM ByteString File m ZipInfo +consumeZip = unZipStream `fuseUpstream` consumeZip' + where + consumeZip' :: ( MonadThrow m + ) => Conduit (Either ZipEntry ByteString) m File + consumeZip' = do + input <- await + case input of + 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' $ zipEntryName e + contentChunks <- toConsumer accContents + let + fileTitle = normalise $ makeValid zipEntryName' + fileModified = localTimeToUTC utc $ zipEntryTime e + fileContent + | hasTrailingPathSeparator zipEntryName' = Nothing + | otherwise = Just $ mconcat contentChunks + yield $ File{..} + consumeZip' + accContents :: Monad m => Sink (Either a b) m [b] + accContents = do + input <- await + case input of + Just (Right x) -> (x :) <$> accContents + Just (Left x) -> [] <$ leftover (Left x) + _ -> return [] + +produceZip :: ( MonadBase b m + , PrimMonad b + , MonadThrow m + ) => ZipInfo + -> Conduit File m ByteString +produceZip info = Conduit.map toZipData =$= void (zipStream zipOptions) + where + 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 => File -> (ZipEntry, ZipData m) + toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent) + + 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 e887a515e..6f82c640a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -39,6 +39,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/stack.yaml b/stack.yaml index 1e1790f3f..ab4813dbb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,4 +9,5 @@ packages: extra-deps: - colonnade-1.1.1 - yesod-colonnade-1.1.0 +- zip-stream-0.1.0.1 resolver: lts-9.3 diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs new file mode 100644 index 000000000..b384143fd --- /dev/null +++ b/test/Handler/Utils/ZipSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Utils.ZipSpec where + +import TestImport + +import Handler.Utils.Zip + +import System.FilePath + +import Data.Conduit +import qualified Data.Conduit.List as Conduit + +import Data.List (dropWhileEnd) +import Data.Time + +instance Arbitrary File where + arbitrary = do + fileTitle <- joinPath <$> arbitrary + date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2) + fileModified <- addUTCTime <$> arbitrary <*> pure (UTCTime date 0) + 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 =$= void consumeZip =$= Conduit.consume + forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do + let acceptableFilenameChanges + = makeValid . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid + acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2 + (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 + | time > UTCTime (fromGregorian 1980 1 1) 0 + , time < UTCTime (fromGregorian 2107 1 1) 0 + = True + | otherwise + = False 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