fix(downloads): do download links via redirect
This commit is contained in:
Gregor Kleen
parent
7854222a8d
commit
3ba41d8f24
@ -83,15 +83,6 @@ instance Yesod UniWorX where
|
||||
Nothing -> getApprootText guessApproot app req
|
||||
Just root -> root
|
||||
|
||||
urlParamRenderOverride app route params = do
|
||||
rApproot <- case authoritiveApproot route of
|
||||
ApprootDefault -> mzero
|
||||
rApproot -> return rApproot
|
||||
guard $ views _appRoot ($ ApprootDefault) app /= views _appRoot ($ rApproot) app
|
||||
approotText <- app ^. _appRoot . to ($ rApproot)
|
||||
let (ps, params') = renderRoute route
|
||||
return . joinPath app approotText ps $ params ++ params'
|
||||
|
||||
makeSessionBackend = UniWorX.makeSessionBackend
|
||||
|
||||
maximumContentLength app _ = app ^. _appMaximumContentLength
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -31,7 +31,7 @@ yesodMiddleware :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> HandlerFor UniWorX res -> HandlerFor UniWorX res
|
||||
yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware
|
||||
yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . securityMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware . setActiveAuthTagsMiddleware . normalizeApprootMiddleware
|
||||
where
|
||||
dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
dryRunMiddleware handler = do
|
||||
@ -135,6 +135,30 @@ yesodMiddleware = cacheControlMiddleware . storeBearerMiddleware . csrfMiddlewar
|
||||
handler
|
||||
cacheControlMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
cacheControlMiddleware = (addHeader "Vary" "Accept, Accept-Language" *>)
|
||||
normalizeApprootMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
normalizeApprootMiddleware handler = maybeT handler $ do
|
||||
route <- MaybeT getCurrentRoute
|
||||
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
|
||||
let rApproot = authoritiveApproot route
|
||||
app <- getYesod
|
||||
approotHost <- hoistMaybe $ approotScopeHost rApproot app
|
||||
let doRedirect = do
|
||||
url <- approotRender rApproot route
|
||||
$logErrorS "normalizeApprootMiddleware" url
|
||||
redirect url
|
||||
if | approotHost /= reqHost
|
||||
, rApproot /= ApprootUserGenerated
|
||||
-> doRedirect
|
||||
| approotHost /= reqHost -> do
|
||||
resp <- try $ lift handler
|
||||
$logErrorS "normalizeApprootMiddleware" $ tshow (is _Right resp, preview _Left resp)
|
||||
case resp of
|
||||
Right _ -> doRedirect
|
||||
Left sc | is _HCRedirect sc -> throwM sc
|
||||
Left _ -> doRedirect
|
||||
| otherwise -> lift handler
|
||||
|
||||
|
||||
|
||||
updateFavourites :: forall m backend.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
@ -175,8 +199,7 @@ routeNormalizers :: forall m backend.
|
||||
, BearerAuthSite UniWorX
|
||||
) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
|
||||
routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
|
||||
[ normalizeApproot
|
||||
, normalizeRender
|
||||
[ normalizeRender
|
||||
, ncSchool
|
||||
, ncAllocation
|
||||
, ncCourse
|
||||
@ -195,12 +218,6 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
|
||||
, verifyMaterialVideo
|
||||
]
|
||||
where
|
||||
normalizeApproot route = (route <$) . runMaybeT $ do
|
||||
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
|
||||
approotHost <- MaybeT . getsYesod . approotScopeHost $ authoritiveApproot route
|
||||
when (approotHost /= reqHost) $
|
||||
tell $ Any True
|
||||
|
||||
normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
|
||||
normalizeRender route = route <$ do
|
||||
YesodRequest{..} <- liftHandler getRequest
|
||||
|
||||
@ -13,8 +13,6 @@ import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Handler.Course.Show
|
||||
|
||||
|
||||
data AllocationAddUserForm = AllocationAddUserForm
|
||||
{ aauUser :: UserId
|
||||
@ -121,7 +119,7 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
|
||||
mApplicationTemplate <- runMaybeT $ do
|
||||
guard hasApplicationTemplate
|
||||
let Course{..} = course
|
||||
liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
|
||||
toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
|
||||
over _2 (course, allocCourse, mApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing
|
||||
let appsRes = sequenceA $ view _1 <$> appsRes'
|
||||
appsViews = view _2 <$> appsRes'
|
||||
|
||||
@ -141,7 +141,7 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
|
||||
appFilesInfo <- for mApp $ \(Entity appId _) -> liftHandler . runDB $ do
|
||||
hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
|
||||
appCID <- encrypt appId
|
||||
appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
|
||||
appFilesLink <- toTextUrl $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
|
||||
return (hasFiles, appFilesLink)
|
||||
let hasFiles = maybe False (view _1) appFilesInfo
|
||||
|
||||
|
||||
@ -15,8 +15,6 @@ import Handler.Allocation.Application
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Handler.Course.Show
|
||||
|
||||
|
||||
data NotifyNewCourseButton
|
||||
= BtnNotifyNewCourseForceOn
|
||||
@ -178,7 +176,7 @@ postAShowR tid ssh ash = do
|
||||
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
|
||||
mApplicationTemplate <- runMaybeT $ do
|
||||
guard hasApplicationTemplate
|
||||
liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
|
||||
toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
|
||||
|
||||
let mApplyFormView' = view _1 <$> mApplyFormView
|
||||
overrideVisible = not mayApply && is _Just mApp
|
||||
|
||||
@ -104,7 +104,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
appFilesInfo <- for application $ \(Entity appId _) -> liftHandler . runDB $ do
|
||||
hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
|
||||
appCID <- encrypt appId
|
||||
appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
|
||||
appFilesLink <- toTextUrl $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
|
||||
return (hasFiles, appFilesLink)
|
||||
let hasFiles = maybe False (view _1) appFilesInfo
|
||||
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
||||
|
||||
@ -25,8 +25,6 @@ import qualified Data.Conduit.List as C
|
||||
|
||||
import Handler.Exam.List (mkExamTable)
|
||||
|
||||
import Handler.Course.News.Download
|
||||
|
||||
|
||||
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
@ -80,7 +78,7 @@ getCShowR tid ssh csh = do
|
||||
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
|
||||
mApplicationTemplate <- runMaybeT $ do
|
||||
guard hasApplicationTemplate
|
||||
lift . lift $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource tid ssh csh) $ CourseR tid ssh csh CRegisterTemplateR
|
||||
lift . lift . toTextUrl $ CourseR tid ssh csh CRegisterTemplateR
|
||||
mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
|
||||
news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
@ -98,8 +96,8 @@ getCShowR tid ssh csh = do
|
||||
mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
|
||||
mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
|
||||
|
||||
files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl <=< withFileDownloadToken (cnFileSource nId fPath) . CNewsR tid ssh csh cID $ CNFileR fPath
|
||||
archiveUrl <- lift . lift $ toTextUrl <=< withFileDownloadToken (cnArchiveSource nId) $ CNewsR tid ssh csh cID CNArchiveR
|
||||
files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath
|
||||
archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR
|
||||
|
||||
return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete, archiveUrl)
|
||||
|
||||
|
||||
@ -83,9 +83,8 @@ getMaterialListR tid ssh csh = do
|
||||
let matLink :: MaterialName -> Route UniWorX
|
||||
matLink = CourseR tid ssh csh . flip MaterialR MShowR
|
||||
|
||||
filesLink :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> MaterialName -> m (SomeRoute UniWorX)
|
||||
filesLink mnm = liftHandler . runDB $ withFileDownloadToken (materialArchiveSource tid ssh csh mnm) . CourseR tid ssh csh $ MaterialR mnm MArchiveR
|
||||
filesLink :: MaterialName -> SomeRoute UniWorX
|
||||
filesLink mnm = SomeRoute . CourseR tid ssh csh $ MaterialR mnm MArchiveR
|
||||
|
||||
materialModDateCell :: IsDBTable m a => Material -> DBCell m a
|
||||
materialModDateCell Material{materialVisibleFrom, materialLastEdit}
|
||||
@ -124,7 +123,7 @@ getMaterialListR tid ssh csh = do
|
||||
, sortable (toNothingS "zip-archive") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialFiles))
|
||||
$ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
|
||||
| fileNum == 0 -> mempty
|
||||
| otherwise -> anchorCellM (filesLink materialName) iconFileDownload
|
||||
| otherwise -> anchorCell (filesLink materialName) iconFileDownload
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
|
||||
, sortable (Just "last-edit") (i18nCell MsgFileModified)
|
||||
@ -177,10 +176,10 @@ getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
|
||||
getMVideoR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html
|
||||
getMVideoR tid ssh csh mnm cID = do
|
||||
mfId <- decrypt cID
|
||||
mf@MaterialFile{..} <- runDB $ get404 mfId
|
||||
MaterialFile{..} <- runDB $ get404 mfId
|
||||
let mimeType = mimeLookup $ pack materialFileTitle
|
||||
mfile <- withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
||||
let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, mempty) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params)
|
||||
mfile = CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
||||
let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, toPathPiece True) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params)
|
||||
mfileText <- toTextUrl mfile
|
||||
mfileDownloadText <- toTextUrl mfileDownload
|
||||
unless (mimeType `Set.member` videoTypes) $
|
||||
@ -206,7 +205,7 @@ getMShowR tid ssh csh mnm = do
|
||||
seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
|
||||
|
||||
(Entity _mid material@Material{materialType, materialDescription}, (Any hasFiles,fileTable), zipLink) <- runDB $ do
|
||||
zipLink <- withFileDownloadToken (materialArchiveSource tid ssh csh mnm) $ CMaterialR tid ssh csh mnm MArchiveR
|
||||
let zipLink = CMaterialR tid ssh csh mnm MArchiveR
|
||||
matEnt <- fetchMaterial tid ssh csh mnm
|
||||
let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
|
||||
materialModDateCol = if seeAllModificationTimestamps
|
||||
@ -220,12 +219,12 @@ getMShowR tid ssh csh mnm = do
|
||||
return matFile
|
||||
, dbtRowKey = (E.^. MaterialFileId)
|
||||
, dbtColonnade = widgetColonnade $ mconcat
|
||||
[ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId mf@MaterialFile{..})
|
||||
[ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId MaterialFile{..})
|
||||
-> let matLink
|
||||
| isVideo
|
||||
= SomeRoute . CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId
|
||||
= CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId
|
||||
| otherwise
|
||||
= withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
||||
= pure . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
||||
wgt = [whamlet|
|
||||
$newline never
|
||||
<span .file-path>
|
||||
|
||||
@ -54,10 +54,10 @@ getSheetListR tid ssh csh = do
|
||||
[ icnCell & addIconFixedWidth
|
||||
| let existingSFTs = hasSFT existFiles
|
||||
, sft <- [minBound..maxBound]
|
||||
, let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh sheetName muid sft) . CSheetR tid ssh csh sheetName $ SZipR sft
|
||||
, let link = CSheetR tid ssh csh sheetName $ SZipR sft
|
||||
, let icn = toWgt $ sheetFile2markup sft
|
||||
, let icnCell = if sft `elem` existingSFTs
|
||||
then linkEitherCellM link (icn, [whamlet| |])
|
||||
then linkEitherCell link (icn, [whamlet| |])
|
||||
else spacerCell
|
||||
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
|
||||
@ -50,14 +50,14 @@ getSShowR tid ssh csh shn = do
|
||||
)
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype, _) ->
|
||||
let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh shn muid ftype) . CSheetR tid ssh csh shn $ SZipR ftype
|
||||
let link = CSheetR tid ssh csh shn $ SZipR ftype
|
||||
in tellCell (Any True) $
|
||||
anchorCellM link [whamlet|#{sheetFile2markup ftype} _{ftype}|]
|
||||
anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|]
|
||||
-- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
|
||||
-- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,E.Value fMod,E.Value fType, E.Value fRef) -> anchorCellM
|
||||
(withFileDownloadToken (yield $ FileReference fName fRef fMod) $ CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName, _, E.Value fType, _) -> anchorCell
|
||||
(CSheetR tid ssh csh shn $ SFileR fType fName)
|
||||
(str2widget fName)
|
||||
, sortable (toNothing "visible") (i18nCell MsgVisibleFrom)
|
||||
$ \(_, _ , E.Value ftype, _) -> sftVisible ftype
|
||||
|
||||
@ -17,8 +17,6 @@ import qualified Control.Monad.State.Class as State
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Handler.Submission.Download
|
||||
|
||||
|
||||
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
||||
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
||||
@ -146,7 +144,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
|]
|
||||
siteLayout headingWgt $ do
|
||||
setTitleI heading
|
||||
urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource tid ssh csh shn cid SubmissionCorrected) . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
|
||||
urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
|
||||
let userCorrection = $(widgetFile "correction-user")
|
||||
$(widgetFile "correction")
|
||||
_ -> notFound
|
||||
@ -159,6 +157,6 @@ getCorrectionUserR tid ssh csh shn cid = do
|
||||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] ->
|
||||
let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
|
||||
in defaultLayout $ do
|
||||
urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource courseTerm courseSchool courseShorthand sheetName cid SubmissionCorrected) . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected
|
||||
urlArchive <- toTextUrl . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected
|
||||
$(widgetFile "correction-user")
|
||||
_ -> notFound
|
||||
|
||||
@ -27,8 +27,6 @@ import Text.Blaze (Markup)
|
||||
import qualified Data.Aeson.Types as JSON
|
||||
import Data.Aeson.Lens
|
||||
|
||||
|
||||
import Handler.Submission.Download
|
||||
import Handler.Submission.SubmissionUserInvite
|
||||
|
||||
|
||||
@ -491,12 +489,12 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
|
||||
Just isFile = origIsFile <|> corrIsFile
|
||||
in if
|
||||
| Just True <- origIsFile -> anchorCellM (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
|
||||
| Just True <- origIsFile -> anchorCell (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
|
||||
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
|
||||
, guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of
|
||||
Nothing -> cell mempty
|
||||
Just (Entity _ SubmissionFile{..})
|
||||
| isJust submissionFileContent -> anchorCellM (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
|
||||
| isJust submissionFileContent -> anchorCell (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
|
||||
| otherwise -> i18nCell MsgCorrected
|
||||
, Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let
|
||||
origTime = submissionFileModified . entityVal <$> mOrig
|
||||
@ -504,8 +502,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
|
||||
in dateTimeCell fileTime
|
||||
]
|
||||
subDownloadLink :: _ -> _ -> _ -> WidgetFor UniWorX _
|
||||
subDownloadLink cid sft fileTitle' = liftHandler . runDB . withFileDownloadToken (subDownloadSource tid ssh csh shn cid sft fileTitle') . CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle'
|
||||
subDownloadLink cid sft fileTitle' = CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle'
|
||||
submissionFiles :: _ -> _ -> E.SqlQuery _
|
||||
submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do
|
||||
E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle
|
||||
@ -555,7 +552,7 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSubmissionEditHead tid ssh csh shn
|
||||
(urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID
|
||||
-> let mkUrl sft = toTextUrl <=< withFileDownloadToken' (subArchiveSource tid ssh csh shn cID sft) . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft
|
||||
-> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft
|
||||
in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal
|
||||
let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) ->
|
||||
let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
|
||||
|
||||
@ -18,6 +18,6 @@ downloadFiles = do
|
||||
|
||||
setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Maybe FilePath -> m ()
|
||||
setContentDisposition' mFileName = do
|
||||
wantsDownload <- or2M (hasGlobalGetParam GetDownload) downloadFiles
|
||||
wantsDownload <- maybeT downloadFiles . MaybeT $ lookupGlobalGetParam GetDownload
|
||||
setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
|
||||
|
||||
|
||||
@ -1,6 +1,5 @@
|
||||
module Handler.Utils.Download
|
||||
( withFileDownloadTokenMaybe', withFileDownloadToken, withFileDownloadToken'
|
||||
, sendThisFile
|
||||
( sendThisFile
|
||||
, sendFileReference
|
||||
, serveOneFile
|
||||
, serveSomeFiles
|
||||
@ -22,6 +21,8 @@ import Handler.Utils.Zip
|
||||
import Handler.Utils.ContentDisposition
|
||||
import Handler.Utils.Files
|
||||
|
||||
import qualified Network.Wai as W
|
||||
|
||||
|
||||
data DownloadTokenRestriction
|
||||
= DownloadRestrictSingle { downloadRestrictReference :: FileContentReference }
|
||||
@ -70,55 +71,90 @@ withFileDownloadTokenMaybe' mSource route = maybeT (return $ SomeRoute route) $
|
||||
encodedBearer <- lift $ encodeBearer bearer
|
||||
|
||||
lift . setDownload $ SomeRoute @UniWorX route
|
||||
& over (urlRouteParams $ Proxy @UniWorX) ((toPathPiece GetBearer, toPathPiece encodedBearer) :)
|
||||
& over (urlRouteParams $ Proxy @UniWorX) (((toPathPiece GetBearer, toPathPiece encodedBearer) :) . filter (views _1 (maybe False (/= GetBearer) . fromPathPiece)))
|
||||
|
||||
where
|
||||
setDownload :: SomeRoute UniWorX -> m (SomeRoute UniWorX)
|
||||
setDownload route' = do
|
||||
wantsDownload <- downloadFiles
|
||||
defWantsDownload <- getsYesod $ views _appUserDefaults userDefaultDownloadFiles
|
||||
let
|
||||
addDownload params
|
||||
| anyOf (folded . _1) (== toPathPiece GetDownload) params = params
|
||||
| otherwise = (toPathPiece GetDownload, toPathPiece wantsDownload) : params
|
||||
return $ route'
|
||||
& over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload wantsDownload)
|
||||
where
|
||||
addDownload params | anyOf (folded . _1) (== toPathPiece GetDownload) params = params
|
||||
| otherwise = (toPathPiece GetDownload, mempty) : params
|
||||
& over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload $ wantsDownload /= defWantsDownload)
|
||||
|
||||
withFileDownloadToken' :: forall file url m.
|
||||
( HasFileReference file
|
||||
, HasRoute UniWorX url
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
||||
)
|
||||
=> ConduitT () (Either file DBFile) m ()
|
||||
-> url
|
||||
-> m (SomeRoute UniWorX)
|
||||
withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1))
|
||||
-- withFileDownloadToken' :: forall file url m.
|
||||
-- ( HasFileReference file
|
||||
-- , HasRoute UniWorX url
|
||||
-- , MonadHandler m, HandlerSite m ~ UniWorX
|
||||
-- , MonadCrypto m
|
||||
-- , MonadCryptoKey m ~ CryptoIDKey
|
||||
-- , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
||||
-- )
|
||||
-- => ConduitT () (Either file DBFile) m ()
|
||||
-- -> url
|
||||
-- -> m (SomeRoute UniWorX)
|
||||
-- withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1))
|
||||
|
||||
|
||||
withFileDownloadToken :: forall file url m.
|
||||
( HasFileReference file
|
||||
, HasRoute UniWorX url
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> ConduitT () file m ()
|
||||
-> url
|
||||
-> m (SomeRoute UniWorX)
|
||||
withFileDownloadToken = withFileDownloadToken' . (.| C.map Left)
|
||||
-- withFileDownloadToken :: forall file url m.
|
||||
-- ( HasFileReference file
|
||||
-- , HasRoute UniWorX url
|
||||
-- , MonadHandler m, HandlerSite m ~ UniWorX
|
||||
-- , MonadCrypto m
|
||||
-- , MonadCryptoKey m ~ CryptoIDKey
|
||||
-- , BearerAuthSite UniWorX
|
||||
-- )
|
||||
-- => ConduitT () file m ()
|
||||
-- -> url
|
||||
-- -> m (SomeRoute UniWorX)
|
||||
-- withFileDownloadToken = withFileDownloadToken' . (.| C.map Left)
|
||||
|
||||
ensureApprootUserGeneratedMaybe'
|
||||
:: forall m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
||||
)
|
||||
=> Maybe (ConduitT () (Either FileReference DBFile) m ())
|
||||
-> m ()
|
||||
ensureApprootUserGeneratedMaybe' source = maybeT (return ()) $ do
|
||||
route <- (,) <$> MaybeT getCurrentRoute <*> fmap reqGetParams getRequest
|
||||
$logErrorS "ensureApproot" $ tshow route
|
||||
rApproot <- hoistMaybe <=< lift . runMaybeT $ do
|
||||
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
|
||||
let rApproot = authoritiveApproot $ urlRoute route
|
||||
guard $ rApproot == ApprootUserGenerated
|
||||
approotHost <- MaybeT . getsYesod $ approotScopeHost rApproot
|
||||
guard $ approotHost /= reqHost
|
||||
return rApproot
|
||||
$logErrorS "ensureApproot" $ tshow rApproot
|
||||
route' <- lift $ withFileDownloadTokenMaybe' source route
|
||||
url <- approotRender rApproot route'
|
||||
$logErrorS "ensureApprootUserGenerated" url
|
||||
redirect url
|
||||
|
||||
|
||||
-- | Simply send a `File`-Value
|
||||
sendThisFile :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId, YesodPersistRunner UniWorX) => DBFile -> HandlerFor UniWorX TypedContent
|
||||
sendThisFile File{..}
|
||||
| Just fileContent' <- fileContent = do
|
||||
setCSPSandbox
|
||||
setContentDisposition' . Just $ takeFileName fileTitle
|
||||
let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
|
||||
respondSourceDB cType $
|
||||
fileContent' .| C.map toFlushBuilder
|
||||
| otherwise = sendResponseStatus noContent204 ()
|
||||
sendThisFile :: ( YesodAuthPersist UniWorX
|
||||
, AuthEntity UniWorX ~ User
|
||||
, AuthId UniWorX ~ UserId
|
||||
, YesodPersistRunner UniWorX
|
||||
, MonadCrypto (HandlerFor UniWorX), MonadCryptoKey (HandlerFor UniWorX) ~ CryptoIDKey
|
||||
) => DBFile -> HandlerFor UniWorX TypedContent
|
||||
sendThisFile File{..} = do
|
||||
ensureApprootUserGeneratedMaybe' Nothing
|
||||
if
|
||||
| Just fileContent' <- fileContent -> do
|
||||
setCSPSandbox
|
||||
setContentDisposition' . Just $ takeFileName fileTitle
|
||||
let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
|
||||
respondSourceDB cType $
|
||||
fileContent' .| C.map toFlushBuilder
|
||||
| otherwise -> sendResponseStatus noContent204 ()
|
||||
|
||||
sendFileReference :: forall file a.
|
||||
( HasFileReference file
|
||||
@ -128,6 +164,7 @@ sendFileReference :: forall file a.
|
||||
)
|
||||
=> file -> HandlerFor UniWorX a
|
||||
sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do
|
||||
ensureApprootUserGeneratedMaybe' . Just . yield $ Left fRef
|
||||
whenIsJust fileReferenceContent $ \fRef' -> do
|
||||
dlRestr <- maybeCurrentBearerRestrictions
|
||||
case dlRestr of
|
||||
@ -146,6 +183,7 @@ serveOneFile :: forall file.
|
||||
) => ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
||||
serveOneFile source = do
|
||||
results <- runDB . runConduit $ source .| C.take 2 .| C.foldMap pure -- We don't need more than two files to make a decision below
|
||||
ensureApprootUserGeneratedMaybe' . Just . yieldMany $ map (views (_FileReference . _1) Left) results
|
||||
case results of
|
||||
[file] -> sendFileReference file
|
||||
[] -> notFound
|
||||
@ -172,6 +210,7 @@ serveSomeFiles' :: forall file.
|
||||
) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
||||
serveSomeFiles' archiveName source = do
|
||||
(source', results) <- runDB $ runPeekN 2 source
|
||||
ensureApprootUserGeneratedMaybe' . Just . yieldMany $ over (traverse . _Left) (view $ _FileReference . _1) results
|
||||
|
||||
$logDebugS "serveSomeFiles" . tshow $ length results
|
||||
|
||||
|
||||
@ -25,7 +25,6 @@ import Handler.Utils.Form
|
||||
import Handler.Utils.Widgets
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Handler.Utils.Download
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -376,7 +375,7 @@ colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body
|
||||
| showLink
|
||||
-> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do
|
||||
cID <- encrypt appId
|
||||
liftHandler . runDB . withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR tid ssh csh cID CAFilesR
|
||||
return $ CApplicationR tid ssh csh cID CAFilesR
|
||||
| otherwise
|
||||
-> mempty
|
||||
|
||||
|
||||
@ -60,22 +60,6 @@ data WorkflowCurrentState = WorkflowCurrentState
|
||||
|
||||
makePrisms ''WorkflowHistoryItemActor'
|
||||
|
||||
data OneOrMany a = None | One a | Many
|
||||
deriving (Eq, Ord, Read, Show, Functor, Traversable, Foldable, Generic, Typeable)
|
||||
|
||||
instance Semigroup (OneOrMany a) where
|
||||
None <> x = x
|
||||
x <> None = x
|
||||
_ <> _ = Many
|
||||
instance Monoid (OneOrMany a) where
|
||||
mempty = None
|
||||
|
||||
oneOrMany :: b -> (a -> b) -> b -> OneOrMany a -> b
|
||||
oneOrMany onNone onOne onMany = \case
|
||||
None -> onNone
|
||||
One x -> onOne x
|
||||
Many -> onMany
|
||||
|
||||
|
||||
getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getGWWWorkflowR = postGWWWorkflowR
|
||||
@ -198,13 +182,13 @@ workflowR rScope cID = do
|
||||
<> (compareUnicode `on` userDisplayName) uA uB
|
||||
<> comparing userIdent uA uB
|
||||
(WFPUser{}, _ ) -> GT
|
||||
forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl <=< oneOrMany (return Nothing) (\fRef -> Just <$> withFileDownloadToken (yield fRef) fRoute) (Just <$> withFileDownloadTokenMaybe' Nothing fRoute)) <=< execWriterT @_ @(_, OneOrMany FileReference). forM_ payloads $ \case
|
||||
WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
|
||||
WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
|
||||
WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
|
||||
WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
|
||||
WorkflowFieldPayloadW (WFPFile fRef) -> tell (mempty, One fRef)
|
||||
WorkflowFieldPayloadW (WFPUser uid ) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
|
||||
forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl . bool Nothing (Just fRoute) . getAny) <=< execWriterT @_ @(_, Any). forM_ payloads $ \case
|
||||
WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
|
||||
WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
|
||||
WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
|
||||
WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
|
||||
WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True)
|
||||
WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
|
||||
|
||||
payloadChanges <- State.state $ \oldPayload ->
|
||||
( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload
|
||||
|
||||
@ -1,18 +1,44 @@
|
||||
module Utils.Approot
|
||||
( approotScopeHost
|
||||
( approotScopeHost, approotScopeBaseUrl, approotScopeHost'
|
||||
, approotRender
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import ClassyPrelude.Yesod hiding (Proxy)
|
||||
import Settings
|
||||
|
||||
import Utils.Route
|
||||
|
||||
import Network.URI (URI(URI), URIAuth(URIAuth))
|
||||
import qualified Network.URI as URI
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString
|
||||
approotScopeHost rApproot app = do
|
||||
|
||||
approotScopeHost' :: HasAppSettings site => (URI -> URIAuth -> a) -> ApprootScope -> site -> Maybe a
|
||||
approotScopeHost' f rApproot app = do
|
||||
approotText <- views _appRoot ($ rApproot) app
|
||||
approotURI <- URI.parseURI $ unpack approotText
|
||||
approotAuthority <- URI.uriAuthority approotURI
|
||||
return . encodeUtf8 . pack $ URI.uriRegName approotAuthority <> URI.uriPort approotAuthority
|
||||
return $ f approotURI approotAuthority
|
||||
|
||||
approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString
|
||||
approotScopeHost = approotScopeHost' $ \_ URIAuth{..}
|
||||
-> encodeUtf8 . pack $ uriRegName <> uriPort
|
||||
|
||||
approotScopeBaseUrl :: HasAppSettings site => ApprootScope -> site -> Maybe Text
|
||||
approotScopeBaseUrl = approotScopeHost' $ \URI{..} URIAuth{..}
|
||||
-> pack $ uriScheme <> "//" <> uriRegName <> uriPort
|
||||
|
||||
approotRender :: forall url m.
|
||||
( HasAppSettings (HandlerSite m)
|
||||
, MonadHandler m
|
||||
, Yesod (HandlerSite m)
|
||||
, HasRoute (HandlerSite m) url
|
||||
)
|
||||
=> ApprootScope -> url -> m Text
|
||||
approotRender rApproot route = do
|
||||
app <- getYesod
|
||||
approotHost <- maybe (getApprootText approot app <$> waiRequest) return $ approotScopeBaseUrl rApproot app
|
||||
return . yesodRender app approotHost (urlRoute route) . withLens (urlRouteParams (Proxy @(HandlerSite m))) $ \g _ -> g route
|
||||
|
||||
@ -1,10 +1,13 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Utils.Route where
|
||||
|
||||
import Control.Lens
|
||||
import ClassyPrelude.Yesod -- hiding (foldlM)
|
||||
import ClassyPrelude.Yesod hiding (Proxy)
|
||||
import Data.Kind (Type)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.Proxy
|
||||
|
||||
|
||||
class RedirectUrl site url => HasRoute site url where
|
||||
@ -46,3 +49,5 @@ instance HasRoute site (SomeRoute site) where
|
||||
type RouteWithParams site (SomeRoute site) = SomeRoute site
|
||||
urlRoute (SomeRoute url) = urlRoute url
|
||||
urlRouteParams pSite = lens (\(SomeRoute url) -> withLens (urlRouteParams pSite) $ \g _ -> g url) (\(SomeRoute url) params -> SomeRoute (urlRoute url :: Route site, params))
|
||||
instance Eq (Route site) => Eq (SomeRoute site) where
|
||||
(==) = (==) `on` (\(SomeRoute r) -> withLens (urlRouteParams $ Proxy @site) $ \g _ -> (urlRoute r :: Route site, sort $ g r))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user