fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Switch Zip to work on 'File's

Browse Source
This commit is contained in:
Gregor Kleen 2017-10-09 16:08:02 +02:00
parent 5742d21406
commit 332be4d9ce
4 changed files with 61 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
models
View File

@ -51,10 +51,6 @@ Sheet
sheetType SheetType sheetType SheetType
maxPoints Double Maybe maxPoints Double Maybe
requiredPoints Double Maybe requiredPoints Double Maybe
exerciseId FileId Maybe
hintId FileId Maybe
solutionId FileId Maybe
markingId FileId Maybe
markingText Text markingText Text
activeFrom UTCTime activeFrom UTCTime
activeTo UTCTime activeTo UTCTime
@ -64,16 +60,18 @@ Sheet
changed UTCTime changed UTCTime
createdBy UserId createdBy UserId
changedBy UserId changedBy UserId
SheetFile
sheetId SheetId
fileId FileId
type SheetFileType
UniqueSheetFile fileId sheetId type
File 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 Submission
sheetId SheetId sheetId SheetId
updateId FileId Maybe
ratingBy UserId Maybe ratingBy UserId Maybe
ratingPoints Double Maybe ratingPoints Double Maybe
ratingComment Text Maybe ratingComment Text Maybe
@ -85,7 +83,8 @@ Submission
SubmissionFile SubmissionFile
submissionId SubmissionId submissionId SubmissionId
fileId FileId fileId FileId
UniqueSubmissionFile fileId submissionId isUpdate Bool
UniqueSubmissionFile fileId submissionId isUpdate
SubmissionUser SubmissionUser
userId UserId userId UserId
submissionId SubmissionId submissionId SubmissionId

81
src/Handler/Zip.hs
View File

@ -1,13 +1,12 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} {-# 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 #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Zip module Handler.Zip
( Zip.ZipError(..) ( ZipError(..)
, Zip.ZipInfo(..) , ZipInfo(..)
, ZipEntry(..)
, produceZip , produceZip
, consumeZip , consumeZip
) where ) where
@ -16,14 +15,15 @@ import Import
import qualified Data.Conduit.List as Conduit (map) import qualified Data.Conduit.List as Conduit (map)
import qualified Codec.Archive.Zip.Conduit.Types as Zip import Codec.Archive.Zip.Conduit.Types
import qualified Codec.Archive.Zip.Conduit.UnZip as Zip import Codec.Archive.Zip.Conduit.UnZip
import qualified Codec.Archive.Zip.Conduit.Zip as Zip 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 qualified Data.ByteString.Lazy as Lazy.ByteString
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
@ -31,21 +31,11 @@ import qualified Data.Text.Encoding as Text
import System.FilePath import System.FilePath
import Data.Time import Data.Time
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import Data.List (dropWhileEnd) import Data.List (dropWhileEnd)
data ZipEntry = ZipEntry instance Default ZipInfo where
{ zipEntryName :: FilePath def = ZipInfo
, 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
{ zipComment = mempty { zipComment = mempty
} }
@ -53,26 +43,27 @@ instance Default Zip.ZipInfo where
consumeZip :: ( MonadBase b m consumeZip :: ( MonadBase b m
, PrimMonad b , PrimMonad b
, MonadThrow m , MonadThrow m
) => (ZipEntry -> m a) -- ^ Handle entries (insert into database) ) => ConduitM ByteString File m ZipInfo
-> Sink ByteString m (Zip.ZipInfo, [a]) consumeZip = unZipStream `fuseUpstream` consumeZip'
consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
where where
-- consumeZip' :: Sink (Either Zip.ZipEntry ByteString) m [a] consumeZip' :: ( MonadThrow m
) => Conduit (Either ZipEntry ByteString) m File
consumeZip' = do consumeZip' = do
input <- await input <- await
case input of case input of
Nothing -> return [] Nothing -> return ()
Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP" Just (Right _) -> throw $ userError "Data chunk in unexpected place when parsing ZIP"
Just (Left e) -> do Just (Left e) -> do
zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ Zip.zipEntryName e zipEntryName' <- fmap Text.unpack . either throw return . Text.decodeUtf8' $ zipEntryName e
contentChunks <- accContents contentChunks <- toConsumer accContents
let let
zipEntryName = normalise $ makeValid zipEntryName' fileTitle = normalise $ makeValid zipEntryName'
zipEntryTime = localTimeToUTC utc $ Zip.zipEntryTime e fileModified = localTimeToUTC utc $ zipEntryTime e
zipEntryContents fileContent
| hasTrailingPathSeparator zipEntryName' = Nothing | hasTrailingPathSeparator zipEntryName' = Nothing
| otherwise = Just $ Lazy.ByteString.fromChunks contentChunks | otherwise = Just $ mconcat contentChunks
(:) <$> (lift $ handleEntry ZipEntry{..}) <*> consumeZip' yield $ File{..}
consumeZip'
accContents :: Monad m => Sink (Either a b) m [b] accContents :: Monad m => Sink (Either a b) m [b]
accContents = do accContents = do
input <- await input <- await
@ -84,25 +75,23 @@ consumeZip handleEntry = Zip.unZipStream `fuseBoth` consumeZip'
produceZip :: ( MonadBase b m produceZip :: ( MonadBase b m
, PrimMonad b , PrimMonad b
, MonadThrow m , MonadThrow m
) => Zip.ZipInfo ) => ZipInfo
-> Conduit ZipEntry m ByteString -> Conduit File m ByteString
produceZip info = Conduit.map toZipData =$= void (Zip.zipStream zipOptions) produceZip info = Conduit.map toZipData =$= void (zipStream zipOptions)
where where
zipOptions = Zip.ZipOptions zipOptions = ZipOptions
{ zipOpt64 = True { zipOpt64 = True
, zipOptCompressLevel = -1 -- This is passed through all the way to the C zlib, where it means "default level" , zipOptCompressLevel = -1 -- This is passed through all the way to the C zlib, where it means "default level"
, zipOptInfo = info , zipOptInfo = info
} }
toZipData :: Monad m => ZipEntry -> (Zip.ZipEntry, Zip.ZipData m) toZipData :: Monad m => File -> (ZipEntry, ZipData m)
toZipData (e@ZipEntry{ zipEntryContents = Nothing }) toZipData f@(File{..}) = ((toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }, maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent)
= ((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)
toZipEntry :: Bool -- ^ Is directory? toZipEntry :: File -> ZipEntry
-> ZipEntry -> Zip.ZipEntry toZipEntry File{..} = ZipEntry
toZipEntry isDir ZipEntry{..} = Zip.ZipEntry { zipEntryName = Text.encodeUtf8 . Text.pack . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ fileTitle
{ zipEntryName = Text.encodeUtf8 . Text.pack . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise . makeValid $ zipEntryName , zipEntryTime = utcToLocalTime utc fileModified
, zipEntryTime = utcToLocalTime utc zipEntryTime
} }
where
isDir = isNothing fileContent

4
src/Model/Types.hs
View File

@ -37,6 +37,10 @@ data ExamStatus = Attended | NoShow | Voided
deriving (Show, Read, Eq, Ord, Enum, Bounded) deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "ExamStatus" derivePersistField "ExamStatus"
data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "SheetFileType"
data Season = Summer | Winter data Season = Summer | Winter
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)

22
test/Handler/ZipSpec.hs
View File

@ -16,27 +16,27 @@ import qualified Data.Conduit.List as Conduit
import Data.List (dropWhileEnd) import Data.List (dropWhileEnd)
import Data.Time import Data.Time
instance Arbitrary ZipEntry where instance Arbitrary File where
arbitrary = do arbitrary = do
zipEntryName <- joinPath <$> arbitrary fileTitle <- joinPath <$> arbitrary
let date = addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2) let date = addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
zipEntryTime <- UTCTime <$> date <*> arbitrary fileModified <- UTCTime <$> date <*> arbitrary
zipEntryContents <- arbitrary fileContent <- arbitrary
return ZipEntry{..} return File{..}
spec :: Spec spec :: Spec
spec = describe "Zip file handling" $ do spec = describe "Zip file handling" $ do
it "has compatible encoding/decoding to/from zip files" . property $ it "has compatible encoding/decoding to/from zip files" . property $
\zipFiles -> do \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 forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do
let acceptableFilenameChanges 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 acceptableTimeDifference t1 t2 = abs (diffUTCTime t1 t2) <= 2
(shouldBe `on` acceptableFilenameChanges) (zipEntryName file') (zipEntryName file) (shouldBe `on` acceptableFilenameChanges) (fileTitle file') (fileTitle file)
when (inZipRange $ zipEntryTime file) $ when (inZipRange $ fileModified file) $
(zipEntryTime file', zipEntryTime file) `shouldSatisfy` uncurry acceptableTimeDifference (fileModified file', fileModified file) `shouldSatisfy` uncurry acceptableTimeDifference
(zipEntryContents file') `shouldBe` (zipEntryContents file) (fileContent file') `shouldBe` (fileContent file)
inZipRange :: UTCTime -> Bool inZipRange :: UTCTime -> Bool
inZipRange time inZipRange time