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
This commit is contained in:
Gregor Kleen
parent
e676be8f3f
commit
97eb18c5aa
9
routes
9
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:
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
submissionMultiArchive $ Set.fromList subs
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
39
src/Utils.hs
39
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 --
|
||||
------------------
|
||||
|
||||
@ -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 ))
|
||||
E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user