363 lines
18 KiB
Haskell
363 lines
18 KiB
Haskell
{-# OPTIONS_GHC -O0 -fasm #-}
|
|
|
|
module Foundation.Yesod.Middleware
|
|
( yesodMiddleware
|
|
, updateFavourites
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (yesodMiddleware)
|
|
|
|
import Foundation.Type
|
|
import Foundation.Routes
|
|
import Foundation.Authorization
|
|
import Foundation.I18n
|
|
|
|
import Utils.Metrics
|
|
import Utils.Workflow
|
|
|
|
import Handler.Utils.Workflow.CanonicalRoute
|
|
|
|
import qualified Network.Wai as W
|
|
import qualified Data.Aeson as JSON
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
yesodMiddleware :: ( BearerAuthSite UniWorX
|
|
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
|
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
|
)
|
|
=> HandlerFor UniWorX res -> HandlerFor UniWorX res
|
|
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
|
|
dryRun <- isDryRun
|
|
if | dryRun -> do
|
|
hData <- ask
|
|
prevState <- readIORef (handlerState hData)
|
|
let
|
|
restoreSession =
|
|
modifyIORef (handlerState hData) $
|
|
\hst -> hst { ghsSession = ghsSession prevState
|
|
, ghsCache = ghsCache prevState
|
|
, ghsCacheBy = ghsCacheBy prevState
|
|
}
|
|
site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing }
|
|
handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler
|
|
|
|
addCustomHeader HeaderDryRun $ toPathPiece True
|
|
|
|
handler' `finally` restoreSession
|
|
| otherwise -> handler
|
|
updateFavouritesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
|
updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
|
|
route <- MaybeT getCurrentRoute
|
|
case route of -- update Course Favourites here
|
|
CourseR tid ssh csh _ -> do
|
|
void . lift . runDB . runMaybeT $ do
|
|
guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
|
|
lift . updateFavourites $ Just (tid, ssh, csh)
|
|
_other -> return ()
|
|
normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
|
normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
|
|
route <- MaybeT getCurrentRoute
|
|
(route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers
|
|
when changed $ do
|
|
$logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
|
|
redirectWith movedPermanently301 route'
|
|
headerMessagesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
|
headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
|
|
massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
|
|
$logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
|
|
guard $ or
|
|
[ isModal
|
|
, dbTableShortcircuit
|
|
, massInputShortcircuit
|
|
]
|
|
|
|
lift . bracketOnError getMessages (mapM_ addMessage') $
|
|
addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
|
|
observeYesodCacheSizeMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
|
observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
|
|
csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
|
csrfMiddleware handler = do
|
|
hasBearer <- is _Just <$> lookupBearerAuth
|
|
reqHost <- W.requestHeaderHost <$> waiRequest
|
|
userGeneratedHost <- getsYesod $ \app ->
|
|
guardOnM (views _appRoot ($ ApprootDefault) app /= views _appRoot ($ ApprootUserGenerated) app) $ approotScopeHost ApprootUserGenerated app
|
|
mCurrentRoute <- getCurrentRoute
|
|
let isError = case mCurrentRoute of
|
|
Just ErrorR -> True
|
|
_other -> False
|
|
|
|
if | hasBearer
|
|
-> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
|
|
| fromMaybe False ((==) <$> reqHost <*> userGeneratedHost) || isError -> do
|
|
whenIsJust mCurrentRoute $ \currentRoute -> do
|
|
isWrite <- isWriteRequest currentRoute
|
|
when isWrite $
|
|
permissionDeniedI MsgUnauthorizedCsrfDisabled
|
|
handler
|
|
| otherwise
|
|
-> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
|
|
where
|
|
csrfSetCookieMiddleware' handler' = do
|
|
mcsrf <- reqToken <$> getRequest
|
|
whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
|
|
handler'
|
|
storeBearerMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
|
storeBearerMiddleware handler = do
|
|
askBearer >>= \case
|
|
Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
|
|
Nothing -> return ()
|
|
|
|
handler
|
|
setActiveAuthTagsMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
|
setActiveAuthTagsMiddleware handler = do
|
|
mtagActive <- lookupSessionJson SessionActiveAuthTags :: HandlerFor UniWorX (Maybe AuthTagActive)
|
|
when (is _Nothing mtagActive) $ do
|
|
mAuthTagActive <- lookupRegisteredCookieJson CookieActiveAuthTags
|
|
for_ mAuthTagActive $ setSessionJson SessionActiveAuthTags . review _ReducedActiveAuthTags
|
|
|
|
handler
|
|
securityMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
|
securityMiddleware handler = do
|
|
addHeader "X-XSS-Protection" "1; mode=block"
|
|
addHeader "X-Frame-Options" "sameorigin"
|
|
addHeader "X-Content-Type-Options" "nosniff"
|
|
authorizationCheck
|
|
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
|
|
|
|
case route of
|
|
MetricsR -> mzero
|
|
HealthR -> mzero
|
|
InstanceR -> mzero
|
|
_other -> return ()
|
|
|
|
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
|
|
let rApproot = authoritiveApproot route
|
|
app <- getYesod
|
|
approotHost <- hoistMaybe $ approotScopeHost rApproot app
|
|
let doRedirect = do
|
|
url <- approotRender rApproot route
|
|
$logDebugS "normalizeApprootMiddleware" url
|
|
redirect url
|
|
if | approotHost /= reqHost
|
|
, rApproot /= ApprootUserGenerated
|
|
-> doRedirect
|
|
| approotHost /= reqHost -> do
|
|
resp <- try $ lift handler
|
|
$logDebugS "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
|
|
, BackendCompatible SqlBackend backend
|
|
, YesodAuth UniWorX
|
|
, UserId ~ AuthId UniWorX
|
|
)
|
|
=> Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
|
|
-> ReaderT backend m ()
|
|
updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do
|
|
$logDebugS "updateFavourites" "Updating favourites"
|
|
|
|
now <- liftIO getCurrentTime
|
|
uid <- MaybeT $ liftHandler maybeAuthId
|
|
mcid <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId)
|
|
User{userMaxFavourites} <- MaybeT $ get uid
|
|
|
|
-- update Favourites
|
|
for_ mcid $ \cid ->
|
|
void . lift $ upsertBy
|
|
(UniqueCourseFavourite uid cid)
|
|
(CourseFavourite uid cid FavouriteVisited now)
|
|
[CourseFavouriteLastVisit =. now]
|
|
-- prune Favourites to user-defined size
|
|
oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
|
|
let deleteFavs = oldFavs
|
|
& sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
|
|
& drop userMaxFavourites
|
|
& filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
|
|
& map entityKey
|
|
unless (null deleteFavs) $
|
|
lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
|
|
|
|
|
|
routeNormalizers :: forall m backend.
|
|
( BackendCompatible SqlReadBackend backend
|
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BearerAuthSite UniWorX
|
|
) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
|
|
routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
|
|
[ normalizeRender
|
|
, ncSchool
|
|
, ncAllocation
|
|
, ncCourse
|
|
, ncSheet
|
|
, ncMaterial
|
|
, ncTutorial
|
|
, ncExam
|
|
, ncExternalExam
|
|
, ncAdminWorkflowDefinition
|
|
, ncWorkflowInstance
|
|
, ncWorkflowPayloadLabel
|
|
, verifySubmission
|
|
, verifyCourseApplication
|
|
, verifyCourseNews
|
|
, verifyWorkflowWorkflow
|
|
, verifyMaterialVideo
|
|
]
|
|
where
|
|
normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
|
|
normalizeRender route = route <$ do
|
|
YesodRequest{..} <- liftHandler getRequest
|
|
let original = (W.pathInfo reqWaiRequest, reqGetParams)
|
|
rendered = renderRoute route
|
|
if
|
|
| (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
|
|
$logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
|
|
| otherwise -> do
|
|
$logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
|
|
tell $ Any True
|
|
|
|
maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) (Route UniWorX))
|
|
-> Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
|
|
maybeOrig f route = maybeT (return route) $ f route
|
|
|
|
caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) ()
|
|
caseChanged a b
|
|
| ((/=) `on` CI.original) a b = do
|
|
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
|
|
tell $ Any True
|
|
| otherwise = return ()
|
|
|
|
ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
|
|
let schoolShort :: SchoolShorthand
|
|
schoolShort = unSchoolKey ssh
|
|
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
|
|
(caseChanged `on` unSchoolKey) ssh ssh'
|
|
return ssh'
|
|
ncAllocation = maybeOrig $ \route -> do
|
|
AllocationR tid ssh ash _ <- return route
|
|
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
|
|
caseChanged ash allocationShorthand
|
|
return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
|
|
ncCourse = maybeOrig $ \route -> do
|
|
CourseR tid ssh csh _ <- return route
|
|
Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
|
caseChanged csh courseShorthand
|
|
return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
|
|
ncSheet = maybeOrig $ \route -> do
|
|
CSheetR tid ssh csh shn _ <- return route
|
|
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
|
|
caseChanged shn sheetName
|
|
return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
|
|
ncMaterial = maybeOrig $ \route -> do
|
|
CMaterialR tid ssh csh mnm _ <- return route
|
|
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
|
|
caseChanged mnm materialName
|
|
return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
|
|
ncTutorial = maybeOrig $ \route -> do
|
|
CTutorialR tid ssh csh tutn _ <- return route
|
|
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
|
|
caseChanged tutn tutorialName
|
|
return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
|
|
ncExam = maybeOrig $ \route -> do
|
|
CExamR tid ssh csh examn _ <- return route
|
|
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
|
|
caseChanged examn examName
|
|
return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
|
|
ncExternalExam = maybeOrig $ \route -> do
|
|
EExamR tid ssh coursen examn _ <- return route
|
|
Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
|
|
caseChanged coursen externalExamCourseName
|
|
caseChanged examn externalExamExamName
|
|
return $ route
|
|
& typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
|
|
& typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
|
|
ncAdminWorkflowDefinition = maybeOrig $ \route -> do
|
|
AdminWorkflowDefinitionR wds wdn _ <- return route
|
|
Entity _ WorkflowDefinition{..} <- MaybeT . $cachedHereBinary (wds, wdn) . lift . getBy $ UniqueWorkflowDefinition wdn wds
|
|
caseChanged wdn workflowDefinitionName
|
|
return $ route
|
|
& typesUsing @RouteChildren @WorkflowDefinitionName . filtered (== wdn) .~ workflowDefinitionName
|
|
ncWorkflowInstance = maybeOrig $ \route -> do
|
|
(rScope, WorkflowInstanceR win _) <- hoistMaybe $ route ^? _WorkflowScopeRoute
|
|
dbScope <- fmap (view _DBWorkflowScope) . hoist lift $ fromRouteWorkflowScope rScope
|
|
Entity _ WorkflowInstance{..} <- lift . lift . getBy404 $ UniqueWorkflowInstance win dbScope
|
|
caseChanged win workflowInstanceName
|
|
return $ route
|
|
& typesUsing @RouteChildren @WorkflowInstanceName . filtered (== win) .~ workflowInstanceName
|
|
ncWorkflowPayloadLabel = maybeOrig $ \route -> do
|
|
(_, WorkflowWorkflowR cID (WWFilesR wpl _)) <- hoistMaybe $ route ^? _WorkflowScopeRoute
|
|
wwId <- decrypt cID
|
|
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId . lift $ get wwId
|
|
wwGraph <- lift . lift $ getSharedDBWorkflowGraph workflowWorkflowGraph
|
|
[wpl'] <- return . filter (== wpl) . sortOn (CI.original . unWorkflowPayloadLabel) . foldMap Map.keys $ wgnPayloadView <$> wgNodes wwGraph
|
|
(caseChanged `on` unWorkflowPayloadLabel) wpl wpl'
|
|
return $ route
|
|
& typesUsing @RouteChildren @WorkflowPayloadLabel . filtered (== wpl) .~ wpl'
|
|
verifySubmission = maybeOrig $ \route -> do
|
|
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
|
|
sId <- $cachedHereBinary cID $ decrypt cID
|
|
Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
|
|
Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
|
|
Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
|
|
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
|
|
tell . Any $ route /= newRoute
|
|
return newRoute
|
|
verifyCourseApplication = maybeOrig $ \route -> do
|
|
CApplicationR _tid _ssh _csh cID sr <- return route
|
|
aId <- decrypt cID
|
|
CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
|
|
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
|
|
let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
|
|
tell . Any $ route /= newRoute
|
|
return newRoute
|
|
verifyCourseNews = maybeOrig $ \route -> do
|
|
CNewsR _tid _ssh _csh cID sr <- return route
|
|
aId <- decrypt cID
|
|
CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
|
|
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
|
|
let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
|
|
tell . Any $ route /= newRoute
|
|
return newRoute
|
|
verifyWorkflowWorkflow = maybeOrig $ \route -> do
|
|
(_, WorkflowWorkflowR cID wwR) <- hoistMaybe $ route ^? _WorkflowScopeRoute
|
|
wwId <- decrypt cID
|
|
WorkflowWorkflow{..} <- lift . lift $ get404 wwId
|
|
rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
|
let newRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID wwR)
|
|
tell . Any $ route /= newRoute
|
|
return newRoute
|
|
verifyMaterialVideo = maybeOrig $ \route -> do
|
|
CMaterialR _tid _ssh _csh _mnm (MVideoR cID) <- return route
|
|
mfId <- decrypt cID
|
|
MaterialFile{materialFileMaterial} <- lift . lift $ get404 mfId
|
|
Material{materialName, materialCourse} <- lift . lift $ get404 materialFileMaterial
|
|
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 materialCourse
|
|
let newRoute = CMaterialR courseTerm courseSchool courseShorthand materialName (MVideoR cID)
|
|
tell . Any $ route /= newRoute
|
|
return newRoute
|