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

Cleanup file handling

Browse Source 
* 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
This commit is contained in:
Gregor Kleen 2019-05-18 15:58:29 +02:00
parent e676be8f3f
commit 97eb18c5aa
9 changed files with 134 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
routes
View File

@ -105,27 +105,26 @@
!/subs/own SubmissionOwnR GET !free -- just redirect !/subs/own SubmissionOwnR GET !free -- just redirect
/subs/#CryptoFileNameSubmission SubmissionR: /subs/#CryptoFileNameSubmission SubmissionR:
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
/delete SubDelR GET POST !ownerANDtime /delete SubDelR GET POST !ownerANDtime
/assign SAssignR GET POST !lecturerANDtime /assign SAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated /correction CorrectionR GET POST !corrector !ownerANDreadANDrated
/invite SInviteR GET POST !ownerANDtime /invite SInviteR GET POST !ownerANDtime
!/#SubmissionFileType SubArchiveR GET !owner !corrector
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/correctors SCorrR GET POST /correctors SCorrR GET POST
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
/corrector-invite/ SCorrInviteR GET POST /corrector-invite/ SCorrInviteR GET POST
!/#SheetFileType SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
!/#SheetFileType/*FilePath SFileR 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 MaterialListR GET !course-registered !materials !corrector !tutor
/file/new MaterialNewR GET POST /file/new MaterialNewR GET POST
/file/#MaterialName MaterialR: /file/#MaterialName MaterialR:
/edit MEditR GET POST /edit MEditR GET POST
/delete MDelR GET POST /delete MDelR GET POST
/show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor /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
/download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor !/download/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
/zip MZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
/tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access! /tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access!
/tuts/new CTutorialNewR GET POST /tuts/new CTutorialNewR GET POST
/tuts/#TutorialName TutorialR: /tuts/#TutorialName TutorialR:

8
src/Foundation.hs
View File

@ -677,10 +677,10 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SFileR _ _ -> mzero SFileR _ _ -> mzero
-- Archives of SheetFileType -- Archives of SheetFileType
SZipR (ZIPArchiveName SheetExercise) -> guard $ sheetActiveFrom <= cTime SZipR SheetExercise -> guard $ sheetActiveFrom <= cTime
SZipR (ZIPArchiveName SheetHint ) -> guard $ maybe False (<= cTime) sheetHintFrom SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom
SZipR (ZIPArchiveName SheetSolution) -> guard $ maybe False (<= cTime) sheetSolutionFrom SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom
SZipR _ -> mzero SZipR _ -> mzero
-- Submissions -- Submissions
SubmissionNewR -> guard active SubmissionNewR -> guard active
SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change

45
src/Handler/Material.hs
View File

@ -9,7 +9,7 @@ import qualified Data.Set as Set
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
-- import qualified Data.CaseInsensitive as CI -- 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 qualified Database.Esqueleto as E
import Database.Esqueleto.Utils.TH 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 seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility
table <- runDB $ do table <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh 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"] psValidator = def & defaultSorting [SortDescBy "last-edit"]
dbTableWidget' psValidator DBTable dbTableWidget' psValidator DBTable
{ dbtIdent = "material-list" :: Text { dbtIdent = "material-list" :: Text
, dbtStyle = def , dbtStyle = def
, dbtParams = def , dbtParams = def
, dbtSQLQuery = \material -> do , dbtSQLQuery = \material -> do
E.where_ $ material E.^. MaterialCourse E.==. E.val cid E.where_ $ material E.^. MaterialCourse E.==. E.val cid
return material 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) , dbtRowKey = (E.^. MaterialId)
-- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr -- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
, dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->) , dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
@ -127,8 +130,10 @@ getMaterialListR tid ssh csh = do
$ liftA2 anchorCell matLink toWgt . materialName . row2material $ liftA2 anchorCell matLink toWgt . materialName . row2material
, sortable (toNothingS "description") mempty , sortable (toNothingS "description") mempty
$ foldMap modalCell . materialDescription . row2material $ foldMap modalCell . materialDescription . row2material
, sortable (toNothingS "zip-archive") mempty -- TODO: don't show if there are no files! , sortable (toNothingS "zip-archive") mempty
$ fileCell . filesLink . materialName . row2material $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
| fileNum == 0 -> mempty
| otherwise -> fileCell $ filesLink materialName
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince) , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
, sortable (Just "last-edit") (i18nCell MsgFileModified) , sortable (Just "last-edit") (i18nCell MsgFileModified)
@ -156,9 +161,9 @@ getMaterialListR tid ssh csh = do
getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent 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 where
fileQuery = E.select $ E.from $ fileQuery = E.selectSource $ E.from $
\(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile) 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 matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
zipLink :: Route UniWorX 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 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 , 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. -- | Serve all material-files
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.
getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery
where where
archivename = termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm) archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip"
getMatQuery = E.select . E.from $ getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $
\(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do
E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile
E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial

10
src/Handler/Sheet.hs
View File

@ -215,7 +215,7 @@ getSheetListR tid ssh csh = do
[ icnCell & addIconFixedWidth [ icnCell & addIconFixedWidth
| let existingSFTs = hasSFT existFiles | let existingSFTs = hasSFT existFiles
, sft <- [minBound..maxBound] , 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 icn = toWidget $ sheetFile2markup sft
, let icnCell = if sft `elem` existingSFTs , let icnCell = if sft `elem` existingSFTs
then linkEmptyCell link icn then linkEmptyCell link icn
@ -455,11 +455,11 @@ postSPseudonymR tid ssh csh shn = do
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent 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 :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
getSZipR tid ssh csh shn filename@(ZIPArchiveName sft) getSZipR tid ssh csh shn sft
= serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery 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 getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

86
src/Handler/Submission.hs
View File

@ -38,8 +38,6 @@ import Data.Map (Map, (!), (!?))
import qualified Data.Map as Map import qualified Data.Map as Map
-- import Data.Bifunctor -- import Data.Bifunctor
import System.FilePath
import Text.Blaze (Markup) import Text.Blaze (Markup)
import Data.Aeson hiding (Result(..)) import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet) import Text.Hamlet (ihamlet)
@ -515,8 +513,8 @@ submissionHelper tid ssh csh shn mcid = do
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSubmissionEditHead tid ssh csh shn setTitleI $ MsgSubmissionEditHead tid ssh csh shn
let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected)) let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected
urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal)) urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal
$(widgetFile "submission") $(widgetFile "submission")
getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html 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 :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
submissionID <- submissionMatchesSheet tid ssh csh shn cID (submissionID, isRating) <- runDB $ do
submissionID <- submissionMatchesSheet tid ssh csh shn cID
isRating <- (== Just submissionID) <$> isRatingFile path isRating <- (== Just submissionID) <$> isRatingFile path
when (isUpdate || isRating) $ when (isUpdate || isRating) $
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
return (submissionID, isRating)
case isRating of case isRating of
True True
| isUpdate -> do | isUpdate -> runDB $ do
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
| otherwise -> notFound | otherwise -> notFound
False -> do False -> do
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
E.&&. f E.^. FileTitle E.==. E.val path E.&&. f E.^. FileTitle E.==. E.val path
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
return f return f
case results of serveOneFile results
[] -> 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."
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent
getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do getSubArchiveR tid ssh csh shn cID sfType = do
when (sfType == SubmissionCorrected) $ when (sfType == SubmissionCorrected) $
guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
let filename let filename
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType | SubmissionOriginal <- sfType = toPathPiece cID <> "-" <> toPathPiece sfType
| otherwise = ZIPArchiveName $ toPathPiece cID | otherwise = toPathPiece cID
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] source = do
respondSourceDB "application/zip" $ do submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID rating <- lift $ getRating submissionID
rating <- lift $ getRating submissionID
let case sfType of
fileSelect = case sfType of SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False return f
return f _ -> submissionFileSource submissionID .| Conduit.map entityVal
_ -> submissionFileSource submissionID
fileSource' = do
fileSelect .| Conduit.map entityVal
when (sfType == SubmissionCorrected) $ when (sfType == SubmissionCorrected) $
maybe (return ()) (yieldM . ratingFile cID) rating maybe (return ()) (yieldM . ratingFile cID) rating
zipComment = Text.encodeUtf8 $ toPathPiece cID serveSomeFiles (unpack filename <.> "zip") source
fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubDelR = postSubDelR getSubDelR = postSubDelR
@ -612,4 +598,4 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions
when (null subs) $ do when (null subs) $ do
addMessageI Info MsgNoOpenSubmissions addMessageI Info MsgNoOpenSubmissions
redirect CorrectionsR redirect CorrectionsR
submissionMultiArchive $ Set.fromList subs submissionMultiArchive $ Set.fromList subs

43
src/Handler/Utils.hs
View File

@ -48,40 +48,47 @@ downloadFiles = do
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
return userDefaultDownloadFiles 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 -- | Simply send a `File`-Value
sendThisFile :: File -> Handler TypedContent sendThisFile :: File -> Handler TypedContent
sendThisFile File{..} sendThisFile File{..}
| Just fileContent' <- fileContent = do | Just fileContent' <- fileContent = do
ifM downloadFiles setContentDisposition' . Just $ takeFileName fileTitle
(addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|])
(addHeader "Content-Disposition" [st|inline; filename="#{takeFileName fileTitle}"|])
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise = sendResponseStatus noContent204 () | otherwise = sendResponseStatus noContent204 ()
-- | Serve a single file, identified through a given DB query -- | Serve a single file, identified through a given DB query
serveOneFile :: DB [Entity File] -> Handler TypedContent serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent
serveOneFile query = do serveOneFile source = do
results <- runDB query results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
case results of case results of
[Entity _fileId file] -> sendThisFile file [file] -> sendThisFile file
[] -> notFound [] -> notFound
other -> do other -> do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found." error "Multiple matching files found."
-- | Serve one file directly or a zip-archive of files, identified through a given DB query -- | 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 -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
serveSomeFiles archiveName query = do serveSomeFiles archiveName source = do
results <- runDB query results <- runDB . runConduit $ source .| peekN 2
$logDebugS "serveSomeFiles" . tshow $ length results
case results of case results of
[] -> notFound [] -> notFound
[Entity _fileId file] -> sendThisFile file [file] -> sendThisFile file
moreFiles -> do _moreFiles -> do
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|] setContentDisposition' $ Just archiveName
respondSourceDB "application/zip" $ do respondSourceDB "application/zip" $ do
let zipComment = T.encodeUtf8 archiveName let zipComment = T.encodeUtf8 $ pack archiveName
yieldMany moreFiles .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
tidFromText :: Text -> Maybe TermId tidFromText :: Text -> Maybe TermId

10
src/Model/Types/Misc.hs
View File

@ -18,13 +18,11 @@ import Data.Universe.Helpers
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lens as Text import qualified Data.Text.Lens as Text
import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive.Instances () import Data.CaseInsensitive.Instances ()
import Database.Persist.TH hiding (derivePersistFieldJSON) import Database.Persist.TH hiding (derivePersistFieldJSON)
import Model.Types.JSON import Model.Types.JSON
import Yesod.Core.Dispatch (PathPiece(..))
import Data.Aeson (Value()) import Data.Aeson (Value())
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
@ -71,14 +69,6 @@ $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate "
derivePersistField "Theme" 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 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)

39
src/Utils.hs
View File

@ -30,7 +30,7 @@ import Utils.Parameters as Utils
import Text.Blaze (Markup, ToMarkup) import Text.Blaze (Markup, ToMarkup)
import Data.Char (isDigit, isSpace) import Data.Char (isDigit, isSpace, isAscii)
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
import Numeric (showFFloat) 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 :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero 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 -- -- Alternative --
----------------- -----------------
@ -781,6 +791,33 @@ addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload)
addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload) addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload)
replaceOrAddCustomHeader ident payload = replaceOrAddHeader (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 -- -- Cryptography --
------------------ ------------------

10
src/Utils/Sheet.hs
View File

@ -47,8 +47,8 @@ sheetOldUnassigned tid ssh csh = do
_ -> error "SQL Query with limit 1 returned more than one result" _ -> error "SQL Query with limit 1 returned more than one result"
-- | Return a specfic file from a `Sheet` -- | Return a specfic file from a `Sheet`
sheetFileQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> SqlReadT m [Entity File] sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Source (SqlPersistT m) (Entity File)
sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $ sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) 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 file
-- | Return all files of a certain `SheetFileType` for a `Sheet` -- | Return all files of a certain `SheetFileType` for a `Sheet`
sheetFilesAllQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> SqlReadT m [Entity File] sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Source (SqlPersistT m) (Entity File)
sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $ sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile) 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 = hasSheetFileQuery sheet sft =
E.exists $ E.from $ \sFile -> E.exists $ E.from $ \sFile ->
E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.&&. (sFile E.^. SheetFileType E.==. E.val sft )) E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))