Merge branch 'zip-stream'

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
+    title           FilePath
-    content         ByteString
+    content         ByteString Maybe -- Nothing iff this is a directory
-    created         UTCTime
+    modified        UTCTime
-    changed         UTCTime
+    deriving Show Eq Ord
-    createdBy       UserId
-    changedBy       UserId    
 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

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:

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

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)

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

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

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