diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 3c7c20024..db8da1dda 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -207,7 +207,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = FormMissing -> return () FormSuccess (CorrDownloadData, subs) -> do ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable - addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\"" + addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|] sendResponse =<< submissionMultiArchive ids FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do subs <- mapM decrypt $ Set.toList subs' diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 539ba05eb..1fa719f2a 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -274,7 +274,7 @@ getSShowR tid csh shn = do getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent getSFileR tid csh shn typ title = do - content <- runDB $ E.select $ E.from $ + results <- runDB $ E.select $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) @@ -288,15 +288,18 @@ getSFileR tid csh shn typ title = do E.&&. (course E.^. CourseTerm E.==. E.val tid ) ) -- return desired columns - return $ file E.^. FileContent + return $ (file E.^. FileTitle, file E.^. FileContent) let mimeType = defaultMimeLookup $ pack title - case content of - [E.Value (Just nochmalContent)] -> do - addHeader "Content-Disposition" "attachment" - respond mimeType nochmalContent - [] -> notFound - _other -> error "Multiple matching files found." - + case results of + [(E.Value fileTitle, E.Value fileContent)] + | Just fileContent' <- fileContent -> do + addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] + return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') + | otherwise -> sendResponseStatus noContent204 () + [] -> notFound + other -> do + $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other + error "Multiple matching files found." getSheetNewR :: TermId -> Text -> Handler Html getSheetNewR tid csh = do diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 8b71cbefb..f85c0f0fd 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} @@ -56,8 +56,6 @@ import Colonnade hiding (bool, fromMaybe) import qualified Yesod.Colonnade as Yesod import qualified Text.Blaze.Html5.Attributes as HA -import Text.Shakespeare.Text (st) - numberOfSubmissionEditDates :: Int64 numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. @@ -143,7 +141,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do addMessageI "info" $ MsgSubmissionAlreadyExists redirect $ CSubmissionR tid csh shn cID SubShowR (Just smid) -> do - submissionMatchesSheet tid csh shn (fromJust mcid) + void $ submissionMatchesSheet tid csh shn (fromJust mcid) shid' <- submissionSheet <$> get404 smid -- fetch buddies from current submission @@ -311,40 +309,52 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do getSubDownloadR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do - submissionID <- decrypt cID - runDB $ do - submissionMatchesSheet tid csh shn cID + submissionID <- submissionMatchesSheet tid csh shn cID isRating <- maybe False (== submissionID) <$> isRatingFile path + + when (isUpdate || isRating) $ + guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False + case isRating of - True -> do - file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) - maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file + True + | isUpdate -> do + file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) + maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file + | otherwise -> notFound False -> do results <- E.select . 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.&&. f E.^. FileTitle E.==. E.val path - E.&&. E.not_ (E.isNothing $ f E.^. FileContent) E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate + -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 return f let fileName = Text.pack $ takeFileName path case results of - [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c) - _ -> notFound + [Entity _ File{ fileContent = Just c, fileTitle }] -> do + addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] + return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) + [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () + other -> do + $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other + error "Multiple matching files found." 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}-#{toPathPiece sfType}.zip"|] + when (sfType == SubmissionCorrected) $ + guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False + let filename + | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType + | otherwise = ZIPArchiveName $ toPathPiece cID + + addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] respondSourceDB "application/zip" $ do - lift $ submissionMatchesSheet tid csh shn cID - + submissionID <- lift $ submissionMatchesSheet tid csh shn cID rating <- lift $ getRating submissionID let @@ -361,6 +371,6 @@ getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do when (sfType == SubmissionCorrected) $ maybe (return ()) (yieldM . ratingFile cID) rating - zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext + zipComment = Text.encodeUtf8 $ toPathPiece cID fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 00ca2f06b..2fbfb5532 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -462,11 +462,7 @@ sinkMultiSubmission userId isUpdate = do Submission{..} <- get404 sId Sheet{..} <- get404 submissionSheet Course{..} <- get404 sheetCourse - authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True - case authRes of - AuthenticationRequired -> notAuthenticated - Unauthorized t -> permissionDenied t - Authorized -> return () + guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate sink' <- lift $ yield val ++$$ sink case sink' of @@ -512,9 +508,10 @@ sinkMultiSubmission userId isUpdate = do handleCryptoID _ = return Nothing -submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB () +submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB SubmissionId submissionMatchesSheet tid csh shn cid = do sid <- decrypt cid shid <- fetchSheetId tid csh shn Submission{..} <- get404 sid when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] + return sid diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 2e586ba56..665c509b5 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -19,3 +19,5 @@ import CryptoID as Import import Data.UUID as Import (UUID) import Text.Lucius as Import + +import Text.Shakespeare.Text as Import hiding (text, stext) diff --git a/src/Utils.hs b/src/Utils.hs index 1ec44e5ba..10559c802 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -51,6 +51,11 @@ instance Monad FormResult where (FormFailure errs) >>= _ = FormFailure errs (FormSuccess a) >>= f = f a +guardAuthResult :: MonadHandler m => AuthResult -> m () +guardAuthResult AuthenticationRequired = notAuthenticated +guardAuthResult (Unauthorized t) = permissionDenied t +guardAuthResult Authorized = return () + ---------------------