diff --git a/routes b/routes index 68b7879f1..0e06aa6ea 100644 --- a/routes +++ b/routes @@ -64,7 +64,7 @@ /subs/own SubmissionOwnR GET !free -- just redirect /sub/#CryptoFileNameSubmission SubmissionR !corrector: / SubShowR GET POST !ownerANDtime !ownerANDisRead - /archive SubArchiveR GET !owner + /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner /correction CorrectionR GET POST !ownerANDisRead !/#SubmissionFileType/*FilePath SubDownloadR GET !owner /correctors SCorrR GET POST diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 28fb616d1..b8b4b2eed 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -75,12 +75,3 @@ instance PathPiece SubmissionMode where toPathPiece (SubmissionMode (Just x)) = toPathPiece x -newtype ZIPArchiveName objID = ZIPArchiveName (CryptoID (CI FilePath) objID) - deriving (Show, Read, Eq) - -instance PathPiece (ZIPArchiveName objID) where - fromPathPiece (map CI.mk . unpack -> s) - | Just s' <- stripSuffix (map CI.mk ".zip") s = Just . ZIPArchiveName . CryptoID . CI.mk $ map CI.original s' - | otherwise = Nothing - - toPathPiece (ZIPArchiveName CryptoID{..}) = pack (CI.foldedCase ciphertext) <> ".zip" diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index adb967196..714f5b617 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -252,8 +252,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of Nothing -> cell mempty - Just (Entity _ SubmissionFile{..}, Entity _ File{..}) - | submissionFileIsDeletion -> textCell MsgFileCorrectedDeleted + Just (_, Entity _ File{..}) | isJust fileContent -> anchorCell (\() -> CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) (\() -> [whamlet|_{MsgFileCorrected}|]) () @@ -327,20 +326,30 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c) _ -> notFound -getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler TypedContent -getSubArchiveR tid csh shn cID@CryptoID{..} = do +getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent +getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do submissionID <- decrypt cID - addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}.zip"|] + addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}-#{toPathPiece sfType}.zip"|] respondSourceDB "application/zip" $ do lift $ submissionMatchesSheet tid csh shn cID rating <- lift $ getRating submissionID - case rating of - Nothing -> lift notFound - Just rating' -> do - let fileEntitySource' :: Source (YesodDB UniWorX) File - fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') - info = ZipInfo { zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext } - fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder + + let + fileSource = case sfType of + SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do + E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID + E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False + return f + _ -> submissionFileSource submissionID + + fileSource' = do + fileSource .| Conduit.map entityVal + maybe (return ()) (yieldM . ratingFile cID) rating + + zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext + + fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b19a851f1..f202f6eb9 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} {-- # LANGUAGE ExistentialQuantification #-} -- for DA type module Model.Types where @@ -106,7 +107,7 @@ isUpdateSubmissionFileType False = SubmissionOriginal isUpdateSubmissionFileType True = SubmissionCorrected instance PathPiece SubmissionFileType where - toPathPiece SubmissionOriginal = "file" + toPathPiece SubmissionOriginal = "original" toPathPiece SubmissionCorrected = "corrected" fromPathPiece = enumFromPathPiece @@ -281,3 +282,14 @@ instance Default Theme where -} derivePersistField "Theme" + + +newtype ZIPArchiveName obj = ZIPArchiveName obj + deriving (Show, Read, Eq) + +instance PathPiece obj => PathPiece (ZIPArchiveName obj) where + fromPathPiece (map CI.mk . unpack -> s) + | Just s' <- stripSuffix (map CI.mk ".zip") s = fromPathPiece . pack $ map CI.original s' + | otherwise = Nothing + + toPathPiece (ZIPArchiveName obj) = toPathPiece obj <> ".zip" diff --git a/templates/submission.hamlet b/templates/submission.hamlet index 78f449800..476ee179a 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -1,7 +1,7 @@ $maybe cID <- mcid

- Archiv + Archiv $forall (name,time) <- lastEdits
last edited by #{name} at #{formatTimeGerDTlong time} $maybe fileTable <- mFileTable