From 97eb18c5aac1e9f15ed7bccf313c11c21940ec0a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 18 May 2019 15:58:29 +0200 Subject: [PATCH] Cleanup file handling * Use serve*File(s)-Utilities wherever possible * Stream Files from database through zip-encoder and to client whenever possible * Get rid of ZIPArchiveName and use Content-Disposition everywhere * Make Content-Disposition able to deal with non-ascii filenames --- routes | 9 ++-- src/Foundation.hs | 8 ++-- src/Handler/Material.hs | 45 ++++++++------------ src/Handler/Sheet.hs | 10 ++--- src/Handler/Submission.hs | 86 ++++++++++++++++----------------------- src/Handler/Utils.hs | 43 ++++++++++++-------- src/Model/Types/Misc.hs | 10 ----- src/Utils.hs | 39 +++++++++++++++++- src/Utils/Sheet.hs | 10 ++--- 9 files changed, 134 insertions(+), 126 deletions(-) diff --git a/routes b/routes index d934bd8f6..40579f9e6 100644 --- a/routes +++ b/routes @@ -105,27 +105,26 @@ !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread - /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector /delete SubDelR GET POST !ownerANDtime /assign SAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDreadANDrated /invite SInviteR GET POST !ownerANDtime + !/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /corrector-invite/ SCorrInviteR GET POST + !/#SheetFileType SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor - !/#{ZIPArchiveName SheetFileType} SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /file MaterialListR GET !course-registered !materials !corrector !tutor /file/new MaterialNewR GET POST /file/#MaterialName MaterialR: /edit MEditR GET POST /delete MDelR GET POST /show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - /load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - /download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - /zip MZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + !/download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor + !/download/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor /tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access! /tuts/new CTutorialNewR GET POST /tuts/#TutorialName TutorialR: diff --git a/src/Foundation.hs b/src/Foundation.hs index 48b5e033e..bf592b1b1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -677,10 +677,10 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SFileR _ _ -> mzero -- Archives of SheetFileType - SZipR (ZIPArchiveName SheetExercise) -> guard $ sheetActiveFrom <= cTime - SZipR (ZIPArchiveName SheetHint ) -> guard $ maybe False (<= cTime) sheetHintFrom - SZipR (ZIPArchiveName SheetSolution) -> guard $ maybe False (<= cTime) sheetSolutionFrom - SZipR _ -> mzero + SZipR SheetExercise -> guard $ sheetActiveFrom <= cTime + SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom + SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom + SZipR _ -> mzero -- Submissions SubmissionNewR -> guard active SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 7ae50af56..119fa5027 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -9,7 +9,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Conduit.List as C -- import qualified Data.CaseInsensitive as CI -import qualified Data.Text.Encoding as Text +-- import qualified Data.Text.Encoding as Text import qualified Database.Esqueleto as E import Database.Esqueleto.Utils.TH @@ -107,15 +107,18 @@ getMaterialListR tid ssh csh = do seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility table <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - let row2material = entityVal . dbrOutput -- no inner join, just Entity Material + let row2material = view $ _dbrOutput . _1 . _entityVal psValidator = def & defaultSorting [SortDescBy "last-edit"] dbTableWidget' psValidator DBTable { dbtIdent = "material-list" :: Text , dbtStyle = def , dbtParams = def , dbtSQLQuery = \material -> do - E.where_ $ material E.^. MaterialCourse E.==. E.val cid - return material + E.where_ $ material E.^. MaterialCourse E.==. E.val cid + let filesNum = E.sub_select . E.from $ \materialFile -> do + E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64)) + return (material, filesNum) , dbtRowKey = (E.^. MaterialId) -- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr , dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->) @@ -127,8 +130,10 @@ getMaterialListR tid ssh csh = do $ liftA2 anchorCell matLink toWgt . materialName . row2material , sortable (toNothingS "description") mempty $ foldMap modalCell . materialDescription . row2material - , sortable (toNothingS "zip-archive") mempty -- TODO: don't show if there are no files! - $ fileCell . filesLink . materialName . row2material + , sortable (toNothingS "zip-archive") mempty + $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if + | fileNum == 0 -> mempty + | otherwise -> fileCell $ filesLink materialName , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material , sortable (Just "last-edit") (i18nCell MsgFileModified) @@ -156,9 +161,9 @@ getMaterialListR tid ssh csh = do getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent -getMFileR tid ssh csh mnm title = serveOneFile fileQuery +getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal where - fileQuery = E.select $ E.from $ + fileQuery = E.selectSource $ E.from $ \(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile) @@ -180,7 +185,7 @@ getMShowR tid ssh csh mnm = do matLink = CourseR tid ssh csh . MaterialR mnm . MFileR zipLink :: Route UniWorX - zipLink = CMaterialR tid ssh csh mnm MZipR + zipLink = CMaterialR tid ssh csh mnm MArchiveR seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility @@ -351,28 +356,12 @@ postMDelR tid ssh csh mnm = do , drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR } --- | Variant of getMArchiveR that always serves a Zip Archive, even for single files. Kept, since we might change this according to UX feedback. -getMZipR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent -getMZipR tid ssh csh mnm = do - let filename = ZIPArchiveName mnm - addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] - respondSourceDB "application/zip" $ do - mid <- lift $ getMaterialKeyBy404 tid ssh csh mnm - -- Entity{entityKey=mid, entityVal=material} <- lift $ fetchMaterial tid ssh csh mnm - let - fileSelect = E.selectSource . E.from $ \(materialFile `E.InnerJoin` file) -> do - E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId - E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid - return file - zipComment = Text.encodeUtf8 $ termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> ":" <> mnm) - fileSelect .| C.map entityVal .| produceZip ZipInfo{..} .| C.map toFlushBuilder - --- | Variant of getMZipR that does not serve single file Zip Archives. Maybe confusing to users. +-- | Serve all material-files getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery where - archivename = termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm) - getMatQuery = E.select . E.from $ + archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip" + getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $ \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c5c7fb45f..88af1d515 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -215,7 +215,7 @@ getSheetListR tid ssh csh = do [ icnCell & addIconFixedWidth | let existingSFTs = hasSFT existFiles , sft <- [minBound..maxBound] - , let link = CSheetR tid ssh csh sheetName $ SZipR $ ZIPArchiveName sft + , let link = CSheetR tid ssh csh sheetName $ SZipR sft , let icn = toWidget $ sheetFile2markup sft , let icnCell = if sft `elem` existingSFTs then linkEmptyCell link icn @@ -455,11 +455,11 @@ postSPseudonymR tid ssh csh shn = do getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent -getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file +getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal -getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> ZIPArchiveName SheetFileType -> Handler TypedContent -getSZipR tid ssh csh shn filename@(ZIPArchiveName sft) - = serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery tid ssh csh shn sft +getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent +getSZipR tid ssh csh shn sft + = serveSomeFiles (unpack (toPathPiece sft) <.> "zip") $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 3e31fb658..f9f04f8cc 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -38,8 +38,6 @@ import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map -- import Data.Bifunctor -import System.FilePath - import Text.Blaze (Markup) import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) @@ -515,8 +513,8 @@ submissionHelper tid ssh csh shn mcid = do defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn - let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected)) - urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal)) + let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected + urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal $(widgetFile "submission") getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html @@ -525,72 +523,60 @@ postSInviteR = invitationR submissionUserInvitationConfig getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent -getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do - submissionID <- submissionMatchesSheet tid ssh csh shn cID +getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do + (submissionID, isRating) <- runDB $ do + submissionID <- submissionMatchesSheet tid ssh csh shn cID - isRating <- (== Just submissionID) <$> isRatingFile path + isRating <- (== Just submissionID) <$> isRatingFile path - when (isUpdate || isRating) $ - guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False + when (isUpdate || isRating) $ + guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False + + return (submissionID, isRating) case isRating of True - | isUpdate -> do + | isUpdate -> runDB $ 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_ (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 results = (.| Conduit.map entityVal) . 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.&&. f E.^. FileTitle E.==. E.val path + 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 - case results of - [] -> notFound - [Entity _ File{ fileContent = Just c, fileTitle }] -> do - whenM downloadFiles $ - addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] - return $ TypedContent (mimeLookup (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." + serveOneFile results -getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent -getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do +getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent +getSubArchiveR tid ssh csh shn cID sfType = do when (sfType == SubmissionCorrected) $ guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False let filename - | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType - | otherwise = ZIPArchiveName $ toPathPiece cID + | SubmissionOriginal <- sfType = toPathPiece cID <> "-" <> toPathPiece sfType + | otherwise = toPathPiece cID - addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] - respondSourceDB "application/zip" $ do - submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID - rating <- lift $ getRating submissionID + source = do + submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID + rating <- lift $ getRating submissionID - let - fileSelect = 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 + case sfType of + SubmissionOriginal -> (.| Conduit.map entityVal) . 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 .| Conduit.map entityVal - fileSource' = do - fileSelect .| Conduit.map entityVal when (sfType == SubmissionCorrected) $ maybe (return ()) (yieldM . ratingFile cID) rating - zipComment = Text.encodeUtf8 $ toPathPiece cID - - fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + serveSomeFiles (unpack filename <.> "zip") source getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubDelR = postSubDelR @@ -612,4 +598,4 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions when (null subs) $ do addMessageI Info MsgNoOpenSubmissions redirect CorrectionsR - submissionMultiArchive $ Set.fromList subs \ No newline at end of file + submissionMultiArchive $ Set.fromList subs diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index a51723840..e1aea383f 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -48,40 +48,47 @@ downloadFiles = do UserDefaultConf{..} <- getsYesod $ view _appUserDefaults return userDefaultDownloadFiles +setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m () +setContentDisposition' mFileName = do + wantsDownload <- downloadFiles + setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName + -- | Simply send a `File`-Value sendThisFile :: File -> Handler TypedContent sendThisFile File{..} | Just fileContent' <- fileContent = do - ifM downloadFiles - (addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]) - (addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|]) + setContentDisposition' . Just $ takeFileName fileTitle return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise = sendResponseStatus noContent204 () -- | Serve a single file, identified through a given DB query -serveOneFile :: DB [Entity File] -> Handler TypedContent -serveOneFile query = do - results <- runDB query +serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent +serveOneFile source = do + results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below case results of - [Entity _fileId file] -> sendThisFile file - [] -> notFound - other -> do + [file] -> sendThisFile file + [] -> notFound + other -> do $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other error "Multiple matching files found." -- | Serve one file directly or a zip-archive of files, identified through a given DB query +-- -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned -serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent -serveSomeFiles archiveName query = do - results <- runDB query +serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent +serveSomeFiles archiveName source = do + results <- runDB . runConduit $ source .| peekN 2 + + $logDebugS "serveSomeFiles" . tshow $ length results + case results of - [] -> notFound - [Entity _fileId file] -> sendThisFile file - moreFiles -> do - addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|] + [] -> notFound + [file] -> sendThisFile file + _moreFiles -> do + setContentDisposition' $ Just archiveName respondSourceDB "application/zip" $ do - let zipComment = T.encodeUtf8 archiveName - yieldMany moreFiles .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + let zipComment = T.encodeUtf8 $ pack archiveName + source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder tidFromText :: Text -> Maybe TermId diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 0affd8b70..aa3811f9d 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -18,13 +18,11 @@ import Data.Universe.Helpers import qualified Data.Text as Text import qualified Data.Text.Lens as Text -import qualified Data.CaseInsensitive as CI import Data.CaseInsensitive.Instances () import Database.Persist.TH hiding (derivePersistFieldJSON) import Model.Types.JSON -import Yesod.Core.Dispatch (PathPiece(..)) import Data.Aeson (Value()) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) @@ -71,14 +69,6 @@ $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " derivePersistField "Theme" -newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj } - deriving (Show, Read, Eq, Ord, Generic, Typeable) - -instance PathPiece obj => PathPiece (ZIPArchiveName obj) where - fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" - toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName - - data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) diff --git a/src/Utils.hs b/src/Utils.hs index a66e0313a..4f9d28a25 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -30,7 +30,7 @@ import Utils.Parameters as Utils import Text.Blaze (Markup, ToMarkup) -import Data.Char (isDigit, isSpace) +import Data.Char (isDigit, isSpace, isAscii) import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) import Numeric (showFFloat) @@ -718,6 +718,16 @@ mconcatForM = flip mconcatMapM findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b) findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero +------------- +-- Conduit -- +------------- + +peekN :: (Integral n, Monad m) => n -> Consumer a m [a] +peekN n = do + peeked <- catMaybes <$> replicateM (fromIntegral n) await + mapM_ leftover peeked + return peeked + ----------------- -- Alternative -- ----------------- @@ -781,6 +791,33 @@ addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload) addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload) replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload) +------------------ +-- HTTP Headers -- +------------------ + +data ContentDisposition = ContentInline | ContentAttachment + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ContentDisposition +instance Finite ContentDisposition +nullaryPathPiece ''ContentDisposition $ camelToPathPiece' 1 + +setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath -> m () +-- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader` +-- +-- Takes care of correct formatting and encoding of non-ascii filenames +setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal + where + headerVal + | Just fName <- mFName + , Text.all isAscii fName + , Text.all (not . flip elem ['"', '\\']) fName + = [st|#{toPathPiece cd}; filename="#{fName}"|] + | Just fName <- mFName + = let encoded = decodeUtf8 . urlEncode True $ encodeUtf8 fName + in [st|#{toPathPiece cd}; filename*=UTF-8''#{encoded}|] + | otherwise + = toPathPiece cd + ------------------ -- Cryptography -- ------------------ diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index d2f0cf11e..0fa7da74f 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -47,8 +47,8 @@ sheetOldUnassigned tid ssh csh = do _ -> error "SQL Query with limit 1 returned more than one result" -- | Return a specfic file from a `Sheet` -sheetFileQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> SqlReadT m [Entity File] -sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $ +sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Source (SqlPersistT m) (Entity File) +sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) @@ -66,8 +66,8 @@ sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $ return file -- | Return all files of a certain `SheetFileType` for a `Sheet` -sheetFilesAllQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> SqlReadT m [Entity File] -sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $ +sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Source (SqlPersistT m) (Entity File) +sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) @@ -89,4 +89,4 @@ hasSheetFileQuery :: Database.Esqueleto.Internal.Language.From query expr backen hasSheetFileQuery sheet sft = E.exists $ E.from $ \sFile -> E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) - E.&&. (sFile E.^. SheetFileType E.==. E.val sft )) \ No newline at end of file + E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))