Switch Zip to work on 'File's

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

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

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)

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