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

perf: try to reduce db conn load of site-layout/nav

Browse Source
This commit is contained in:
Gregor Kleen 2021-03-23 15:18:37 +01:00
parent da724654ed
commit c23222aef6
5 changed files with 240 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
src/Foundation/Navigation.hs
View File

@ -24,7 +24,6 @@ import Foundation.Type
import Foundation.Routes import Foundation.Routes
import Foundation.I18n import Foundation.I18n
import Foundation.Authorization import Foundation.Authorization
import Foundation.DB
import Handler.Utils.Memcached import Handler.Utils.Memcached
import Handler.Utils.ExamOffice.Course import Handler.Utils.ExamOffice.Course
@ -69,9 +68,12 @@ i18nCrumb msg mbR = do
-- Keep in mind that Breadcrumbs are also shown by the 403-Handler, -- Keep in mind that Breadcrumbs are also shown by the 403-Handler,
-- i.e. information might be leaked by not performing permission checks if the -- i.e. information might be leaked by not performing permission checks if the
-- breadcrumb value depends on sensitive content (like an user's name). -- breadcrumb value depends on sensitive content (like an user's name).
breadcrumb :: BearerAuthSite UniWorX breadcrumb :: ( BearerAuthSite UniWorX
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
, MonadHandler m, HandlerSite m ~ UniWorX
)
=> Route UniWorX => Route UniWorX
-> ReaderT SqlReadBackend (HandlerFor UniWorX) Breadcrumb -> m Breadcrumb
breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR
breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing
breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing
@ -81,21 +83,21 @@ breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing
breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing
breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR
breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR
breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do breadcrumb (AdminUserR cID) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do
guardM . lift . hasReadAccessTo $ AdminUserR cID guardM . lift . hasReadAccessTo $ AdminUserR cID
uid <- decrypt cID uid <- decrypt cID
User{..} <- MaybeT $ get uid User{..} <- MaybeT $ get uid
return (userDisplayName, Just UsersR) return (userDisplayName, Just UsersR)
breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
breadcrumb (UserNotificationR cID) = do breadcrumb (UserNotificationR cID) = useRunDB $ do
mayList <- hasReadAccessTo UsersR mayList <- hasReadAccessTo UsersR
if if
| mayList | mayList
-> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID
| otherwise | otherwise
-> i18nCrumb MsgMenuUserNotifications $ Just ProfileR -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR
breadcrumb (UserPasswordR cID) = do breadcrumb (UserPasswordR cID) = useRunDB $ do
mayList <- hasReadAccessTo UsersR mayList <- hasReadAccessTo UsersR
if if
| mayList | mayList
@ -114,7 +116,7 @@ breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
breadcrumb (SchoolR ssh sRoute) = case sRoute of breadcrumb (SchoolR ssh sRoute) = case sRoute of
SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
School{..} <- MaybeT $ get ssh School{..} <- MaybeT $ get ssh
isAdmin <- lift $ hasReadAccessTo SchoolListR isAdmin <- lift $ hasReadAccessTo SchoolListR
return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
@ -123,7 +125,7 @@ breadcrumb (SchoolR ssh sRoute) = case sRoute of
SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR
SchoolWorkflowInstanceR win sRoute' -> case sRoute' of SchoolWorkflowInstanceR win sRoute' -> case sRoute' of
SWIEditR -> do SWIEditR -> do
desc <- runMaybeT $ do desc <- useRunDB . runMaybeT $ do
guardM . lift . hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR guardM . lift . hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR
wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh
MaybeT $ selectWorkflowInstanceDescription wiId MaybeT $ selectWorkflowInstanceDescription wiId
@ -133,7 +135,7 @@ breadcrumb (SchoolR ssh sRoute) = case sRoute of
Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute
SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
SWIInitiateR -> do SWIInitiateR -> useRunDB $ do
mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if
| mayEdit -> SchoolWorkflowInstanceR win SWIEditR | mayEdit -> SchoolWorkflowInstanceR win SWIEditR
@ -178,11 +180,11 @@ breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR
breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR
breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR
breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid
breadcrumb (TermCourseListR tid) = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs breadcrumb (TermCourseListR tid) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs
guardM . lift $ isJust <$> get tid guardM . lift $ isJust <$> get tid
i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR
breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs breadcrumb (TermSchoolCourseListR tid ssh) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs
guardM . lift $ guardM . lift $
(&&) <$> fmap isJust (get ssh) (&&) <$> fmap isJust (get ssh)
<*> fmap isJust (get tid) <*> fmap isJust (get tid)
@ -190,12 +192,12 @@ breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbScho
breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR
breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of
AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do AShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do
mr <- getMessageRender mr <- getMessageRender
Entity _ Allocation{allocationName} <- MaybeT . getBy $ TermSchoolAllocationShort tid ssh ash Entity _ Allocation{allocationName} <- MaybeT . getBy $ TermSchoolAllocationShort tid ssh ash
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR) return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR)
ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR
AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do AApplyR cID -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do
cid <- decrypt cID cid <- decrypt cID
Course{..} <- do Course{..} <- do
aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
@ -214,7 +216,7 @@ breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect $ Ju
breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing
breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR
breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do breadcrumb (CourseR tid ssh csh CShowR) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do
guardM . lift . existsBy $ TermSchoolCourseShort tid ssh csh guardM . lift . existsBy $ TermSchoolCourseShort tid ssh csh
return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR
@ -222,7 +224,7 @@ breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . J
breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR
breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do breadcrumb (CourseR tid ssh csh (CUserR cID)) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
uid <- decrypt cID uid <- decrypt cID
User{userDisplayName} <- MaybeT $ get uid User{userDisplayName} <- MaybeT $ get uid
@ -264,7 +266,7 @@ breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplica
breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR
breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of
CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do CAEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do
guardM . lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR guardM . lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
appId <- decrypt cID appId <- decrypt cID
User{..} <- MaybeT (get appId) >>= MaybeT . get . courseApplicationUser User{..} <- MaybeT (get appId) >>= MaybeT . get . courseApplicationUser
@ -272,7 +274,7 @@ breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute o
CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR
breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of
EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do EShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do
guardM . lift . hasReadAccessTo $ CExamR tid ssh csh examn EShowR guardM . lift . hasReadAccessTo $ CExamR tid ssh csh examn EShowR
return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR
@ -287,7 +289,7 @@ breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of
ECorrectR -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR ECorrectR -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR
breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do TUsersR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
@ -297,7 +299,7 @@ breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR
breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do SShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do
guardM . lift . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR guardM . lift . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR
@ -307,7 +309,7 @@ breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR
SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR
SubmissionR cid sRoute' -> case sRoute' of SubmissionR cid sRoute' -> case sRoute' of
SubShowR -> do SubShowR -> useRunDB $ do
mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
if if
| mayList | mayList
@ -331,7 +333,7 @@ breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR
breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR
breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of
MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do MShowR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do
guardM . lift . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR guardM . lift . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR
@ -351,7 +353,7 @@ breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just Co
breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing
breadcrumb (MessageR _) = do breadcrumb (MessageR _) = do
mayList <- hasReadAccessTo MessageListR mayList <- useRunDB $ hasReadAccessTo MessageListR
if if
| mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR | mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR
| otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR
@ -362,13 +364,13 @@ breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR
breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing
breadcrumb EExamNewR = do breadcrumb EExamNewR = do
isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR isEO <- useRunDB . hasReadAccessTo $ ExamOfficeR EOExamsR
i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if
| isEO -> ExamOfficeR EOExamsR | isEO -> ExamOfficeR EOExamsR
| otherwise -> EExamListR | otherwise -> EExamListR
breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of
EEShowR -> do EEShowR -> do
(isEO, mayShow) <- (,) (isEO, mayShow) <- useRunDB $ (,)
<$> hasReadAccessTo (ExamOfficeR EOExamsR) <$> hasReadAccessTo (ExamOfficeR EOExamsR)
<*> hasReadAccessTo (EExamR tid ssh coursen examn EEShowR) <*> hasReadAccessTo (EExamR tid ssh coursen examn EEShowR)
maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do
@ -401,7 +403,7 @@ breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowIn
breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR
breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
GWIEditR -> do GWIEditR -> do
desc <- runMaybeT $ do desc <- useRunDB . runMaybeT $ do
guardM . lift . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR guardM . lift . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR
wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal
MaybeT $ selectWorkflowInstanceDescription wiId MaybeT $ selectWorkflowInstanceDescription wiId
@ -411,7 +413,7 @@ breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR
GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR
GWIInitiateR -> do GWIInitiateR -> do
mayEdit <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR mayEdit <- useRunDB . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if
| mayEdit -> GlobalWorkflowInstanceR win GWIEditR | mayEdit -> GlobalWorkflowInstanceR win GWIEditR
| otherwise -> GlobalWorkflowInstanceListR | otherwise -> GlobalWorkflowInstanceListR
@ -532,7 +534,7 @@ deriving anyclass instance Hashable (AuthId UniWorX) => Hashable NavigationCache
deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary NavigationCacheKey deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary NavigationCacheKey
navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, WithRunDB SqlReadBackend (HandlerFor UniWorX) m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav
navAccess = execStateT $ do navAccess = execStateT $ do
guardM $ preuse _navLink >>= lift . lift . maybe (return True) navLinkAccess guardM $ preuse _navLink >>= lift . lift . maybe (return True) navLinkAccess
@ -540,24 +542,25 @@ navAccess = execStateT $ do
whenM (hasn't _navLink <$> use id) $ whenM (hasn't _navLink <$> use id) $
guardM $ not . null <$> use _navChildren guardM $ not . null <$> use _navChildren
navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => NavLink -> m Bool navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, WithRunDB SqlReadBackend (HandlerFor UniWorX) m, BearerAuthSite UniWorX) => NavLink -> m Bool
navLinkAccess NavLink{..} = case navAccess' of navLinkAccess NavLink{..} = case navAccess' of
NavAccessHandler naNoDb -> handle shortCircuit $ liftHandler naNoDb `and2M` accessCheck (liftHandler . runDBRead) navType navRoute NavAccessHandler naNoDb -> handle shortCircuit $ liftHandler naNoDb `and2M` accessCheck navType navRoute
NavAccessDB naDb -> handle shortCircuit . liftHandler . runDBRead $ naDb `and2M` accessCheck id navType navRoute NavAccessDB naDb -> handle shortCircuit . useRunDB $ naDb `and2M` accessCheck navType navRoute
NavAccessTrue -> accessCheck (liftHandler . runDBRead) navType navRoute NavAccessTrue -> accessCheck navType navRoute
where where
shortCircuit :: HandlerContents -> m Bool shortCircuit :: HandlerContents -> m Bool
shortCircuit _ = return False shortCircuit _ = return False
accessCheck :: forall route m'. (HasRoute UniWorX route, MonadHandler m', HandlerSite m' ~ UniWorX, MonadThrow m') => (forall a. ReaderT SqlReadBackend Handler a -> m' a) -> NavType -> route -> m' Bool accessCheck :: forall m' route. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadThrow m', WithRunDB SqlReadBackend (HandlerFor UniWorX) m', HasRoute UniWorX route) => NavType -> route -> m' Bool
accessCheck liftDb nt (urlRoute -> route) = do accessCheck nt (urlRoute -> route) = do
authCtx <- getAuthContext authCtx <- getAuthContext
memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheRouteAccess authCtx nt route) . liftDb $ memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheRouteAccess authCtx nt route) . useRunDB $
bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
defaultLinks :: ( MonadHandler m defaultLinks :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
) => m [Nav] ) => m [Nav]
defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
@ -743,7 +746,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
} }
, do , do
authCtx <- getAuthContext authCtx <- getAuthContext
(haveInstances, haveWorkflows) <- memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheHaveTopWorkflowsInstances authCtx) . liftHandler . runDBRead $ (,) (haveInstances, haveWorkflows) <- lift . memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheHaveTopWorkflowsInstances authCtx) . useRunDB $ (,)
<$> haveTopWorkflowInstances <$> haveTopWorkflowInstances
<*> haveTopWorkflowWorkflows <*> haveTopWorkflowWorkflows
@ -903,8 +906,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
pageActions :: ( MonadHandler m pageActions :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadCatch m , MonadCatch m
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
, MonadUnliftIO m , MonadUnliftIO m
) )
=> Route UniWorX -> m [Nav] => Route UniWorX -> m [Nav]
@ -941,7 +944,7 @@ pageActions (CourseR tid ssh csh CShowR) = do
let examListBound :: Num a => a let examListBound :: Num a => a
examListBound = 4 -- guaranteed random; chosen by fair dice roll examListBound = 4 -- guaranteed random; chosen by fair dice roll
examListExams <- liftHandler . runDBRead $ do examListExams <- useRunDB $ do
examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.where_ $ course E.^. CourseTerm E.==. E.val tid
@ -2609,8 +2612,8 @@ submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) .
pageQuickActions :: ( MonadCatch m, MonadUnliftIO m pageQuickActions :: ( MonadCatch m, MonadUnliftIO m
, MonadHandler m , MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
) )
=> NavQuickView -> Route UniWorX -> m [NavLink] => NavQuickView -> Route UniWorX -> m [NavLink]
pageQuickActions qView route = do pageQuickActions qView route = do

192
src/Foundation/SiteLayout.hs
View File

@ -7,14 +7,14 @@ module Foundation.SiteLayout
, getSystemMessageState , getSystemMessageState
) where ) where
import Import.NoFoundation hiding (embedFile) import Import.NoFoundation hiding (embedFile, runDB)
import Foundation.Type import Foundation.Type
import Foundation.Authorization import Foundation.Authorization
import Foundation.Routes import Foundation.Routes
import Foundation.Navigation import Foundation.Navigation
import Foundation.I18n import Foundation.I18n
import Foundation.DB import Foundation.Yesod.Persist
import Utils.SystemMessage import Utils.SystemMessage
import Utils.Form import Utils.Form
@ -54,16 +54,15 @@ data MemcachedLimitKeyFavourites
deriving anyclass (Hashable, Binary) deriving anyclass (Hashable, Binary)
siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
siteLayoutMsg = siteLayout . i18n siteLayoutMsg = siteLayout . i18n
{-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-} {-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-}
siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
siteLayoutMsg' = siteLayoutMsg siteLayoutMsg' = siteLayoutMsg
siteLayout :: ( BearerAuthSite UniWorX siteLayout :: ( BearerAuthSite UniWorX
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) , YesodPersistBackend UniWorX ~ SqlBackend
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
, Button UniWorX ButtonSubmit , Button UniWorX ButtonSubmit
) )
=> WidgetFor UniWorX () -- ^ `pageHeading` => WidgetFor UniWorX () -- ^ `pageHeading`
@ -71,8 +70,7 @@ siteLayout :: ( BearerAuthSite UniWorX
siteLayout = siteLayout' . Just siteLayout = siteLayout' . Just
siteLayout' :: ( BearerAuthSite UniWorX siteLayout' :: ( BearerAuthSite UniWorX
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) , YesodPersistBackend UniWorX ~ SqlBackend
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
, Button UniWorX ButtonSubmit , Button UniWorX ButtonSubmit
) )
=> Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading` => Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading`
@ -96,12 +94,12 @@ siteLayout' overrideHeading widget = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- Lookup Favourites, Breadcrumbs, & Theme if possible -- Lookup Favourites, Breadcrumbs, Headline, & Theme if possible
(favourites', (title, parents), maxFavouriteTerms, currentTheme) <- do (favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme) <- do
muid <- maybeAuthPair muid <- maybeAuthPair
(favCourses, breadcrumbs'') <- runDBRead $ do (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs) <- runDB $ do
favCourses'' <- E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do favCourses'' <- withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
@ -150,7 +148,7 @@ siteLayout' overrideHeading widget = do
, courseVisible , courseVisible
) )
favCourses' <- forM favCourses'' $ \((E.Value cName, E.Value tid, E.Value ssh, E.Value csh), reason, E.Value courseVisible) -> do favCourses' <- withReaderT (projectBackend @SqlReadBackend) . forM favCourses'' $ \((E.Value cName, E.Value tid, E.Value ssh, E.Value csh), reason, E.Value courseVisible) -> do
mayView <- hasReadAccessTo $ CourseR tid ssh csh CShowR mayView <- hasReadAccessTo $ CourseR tid ssh csh CShowR
mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
return ((cName, tid, ssh, csh), reason, courseVisible, mayView, mayEdit) return ((cName, tid, ssh, csh), reason, courseVisible, mayView, mayEdit)
@ -172,12 +170,33 @@ siteLayout' overrideHeading widget = do
hasAccess <- hasReadAccessTo cRoute hasAccess <- hasReadAccessTo cRoute
(title, next) <- breadcrumb cRoute (title, next) <- breadcrumb cRoute
go ((cRoute, title, hasAccess) : crumbs) next go ((cRoute, title, hasAccess) : crumbs) next
in breadcrumbs' mcurrentRoute in withReaderT (projectBackend @SqlReadBackend) $ breadcrumbs' mcurrentRoute
return (favCourses, breadcrumbs'') nav'' <- withReaderT (projectBackend @SqlReadBackend) $ mconcat <$> sequence
[ defaultLinks
, maybe (return []) pageActions mcurrentRoute
]
nav' <- withReaderT (projectBackend @SqlReadBackend) $ catMaybes <$> mapM (runMaybeT . navAccess) nav''
-- contentHeadline :: Maybe (WidgetFor UniWorX ())
contentHeadline <- withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ hoistMaybe overrideHeading <|> (pageHeading =<< hoistMaybe mcurrentRoute)
mmsgs <- if
| isModal -> return mempty
| otherwise -> do
applySystemMessages
authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
forM_ authTagPivots $
\authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
getMessages
return (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs)
return ( favCourses return ( favCourses
, breadcrumbs'' , breadcrumbs''
, nav'
, contentHeadline
, mmsgs
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
, maybe userDefaultTheme userTheme $ view _2 <$> muid , maybe userDefaultTheme userTheme $ view _2 <$> muid
) )
@ -203,7 +222,7 @@ siteLayout' overrideHeading widget = do
appFavouritesQuickActionsTimeout appFavouritesQuickActionsTimeout
cK cK
cK cK
. observeFavouritesQuickActionsDuration $ do . observeFavouritesQuickActionsDuration . runCachedDBRunner $ do
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
items' <- pageQuickActions NavQuickViewFavourite courseRoute items' <- pageQuickActions NavQuickViewFavourite courseRoute
items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n
@ -212,22 +231,8 @@ siteLayout' overrideHeading widget = do
$logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit) return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit)
nav'' <- mconcat <$> sequence
[ defaultLinks
, maybe (return []) pageActions mcurrentRoute
]
nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav''
nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse (toTextUrl <=< navLinkRoute) (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> (toTextUrl <=< navLinkRoute) nc) (n ^. _navChildren) nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse (toTextUrl <=< navLinkRoute) (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> (toTextUrl <=< navLinkRoute) nc) (n ^. _navChildren)
mmsgs <- if
| isModal -> return mempty
| otherwise -> do
applySystemMessages
authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
forM_ authTagPivots $
\authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
getMessages
-- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm
-- let langFormView' = wrapForm langFormView def -- let langFormView' = wrapForm langFormView def
-- { formAction = Just $ SomeRoute LangR -- { formAction = Just $ SomeRoute LangR
@ -364,8 +369,6 @@ siteLayout' overrideHeading widget = do
where isNavFooter = has $ _1 . _NavFooter where isNavFooter = has $ _1 . _NavFooter
alerts :: WidgetFor UniWorX () alerts :: WidgetFor UniWorX ()
alerts = $(widgetFile "widgets/alerts/alerts") alerts = $(widgetFile "widgets/alerts/alerts")
contentHeadline :: Maybe (WidgetFor UniWorX ())
contentHeadline = overrideHeading <|> (pageHeading =<< mcurrentRoute)
breadcrumbsWgt :: WidgetFor UniWorX () breadcrumbsWgt :: WidgetFor UniWorX ()
breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs") breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
pageaction :: WidgetFor UniWorX () pageaction :: WidgetFor UniWorX ()
@ -423,19 +426,25 @@ getSystemMessageState smId = liftHandler $ do
where foldSt (Entity _ SystemMessageHidden{..}) where foldSt (Entity _ SystemMessageHidden{..})
= MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime } = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m () applySystemMessages :: forall m.
applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do ( MonadHandler m, HandlerSite m ~ UniWorX
, YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX
, WithRunDB SqlBackend (HandlerFor UniWorX) m
, MonadCatch m
) => m ()
applySystemMessages = maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
cRoute <- lift getCurrentRoute cRoute <- getCurrentRoute
guard $ cRoute /= Just NewsR guard $ cRoute /= Just NewsR
lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage lift . useRunDB . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
where where
syncSystemMessageHidden :: UserId -> HandlerFor UniWorX () syncSystemMessageHidden :: UserId -> m ()
syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do syncSystemMessageHidden uid = do
smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState) smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: m (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
iforM_ smSt $ \cID UserSystemMessageState{..} -> do iforM_ smSt $ \cID UserSystemMessageState{..} -> useRunDB $ do
smId <- decrypt cID smId <- decrypt cID
whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $ whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
upsert SystemMessageHidden upsert SystemMessageHidden
@ -452,11 +461,11 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
-> fmap MergeHashMap . assertM' (/= mempty) $ -> fmap MergeHashMap . assertM' (/= mempty) $
HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm
applyMessage :: Entity SystemMessage -> ReaderT SqlReadBackend (HandlerFor UniWorX) () applyMessage :: Entity SystemMessage -> ReaderT SqlBackend (HandlerFor UniWorX) ()
applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
guard $ not systemMessageNewsOnly guard $ not systemMessageNewsOnly
cID <- encrypt smId cID <- lift $ encrypt smId
guardM . lift . hasReadAccessTo $ MessageR cID guardM . lift . hasReadAccessTo $ MessageR cID
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -488,103 +497,102 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
-- All handlers whose code is under our control should use -- All handlers whose code is under our control should use
-- `siteLayout` instead; `pageHeading` is only a fallback solution for -- `siteLayout` instead; `pageHeading` is only a fallback solution for
-- e.g. subsites like `AuthR` -- e.g. subsites like `AuthR`
pageHeading :: ( YesodPersist UniWorX pageHeading :: ( YesodPersistBackend UniWorX ~ SqlBackend
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) , WithRunDB SqlReadBackend (HandlerFor UniWorX) m
) => Route UniWorX -> Maybe Widget , MonadHandler m
) => Route UniWorX -> MaybeT m Widget
pageHeading (AuthR _) pageHeading (AuthR _)
= Just $ i18n MsgLoginHeading = return $ i18n MsgLoginHeading
pageHeading NewsR pageHeading NewsR
= Just $ i18n MsgNewsHeading = return $ i18n MsgNewsHeading
pageHeading UsersR pageHeading UsersR
= Just $ i18n MsgUsers = return $ i18n MsgUsers
pageHeading (AdminUserR _) pageHeading (AdminUserR _)
= Just $ i18n MsgAdminUserHeading = return $ i18n MsgAdminUserHeading
pageHeading AdminTestR pageHeading AdminTestR
= Just [whamlet|Internal Code Demonstration Page|] = return [whamlet|Internal Code Demonstration Page|]
pageHeading AdminErrMsgR pageHeading AdminErrMsgR
= Just $ i18n MsgErrMsgHeading = return $ i18n MsgErrMsgHeading
pageHeading InfoR pageHeading InfoR
= Just $ i18n MsgInfoHeading = return $ i18n MsgInfoHeading
pageHeading LegalR pageHeading LegalR
= Just $ i18n MsgLegalHeading = return $ i18n MsgLegalHeading
pageHeading VersionR pageHeading VersionR
= Just $ i18n MsgVersionHeading = return $ i18n MsgVersionHeading
pageHeading HelpR pageHeading HelpR
= Just $ i18n MsgHelpRequest = return $ i18n MsgHelpRequest
pageHeading ProfileR pageHeading ProfileR
= Just $ i18n MsgProfileHeading = return $ i18n MsgProfileHeading
pageHeading ProfileDataR pageHeading ProfileDataR
= Just $ i18n MsgProfileDataHeading = return $ i18n MsgProfileDataHeading
pageHeading TermShowR pageHeading TermShowR
= Just $ i18n MsgTermsHeading = return $ i18n MsgTermsHeading
pageHeading TermCurrentR pageHeading TermCurrentR
= Just $ i18n MsgTermCurrent = return $ i18n MsgTermCurrent
pageHeading TermEditR pageHeading TermEditR
= Just $ i18n MsgTermEditHeading = return $ i18n MsgTermEditHeading
pageHeading (TermEditExistR tid) pageHeading (TermEditExistR tid)
= Just $ i18n $ MsgTermEditTid tid = return $ i18n $ MsgTermEditTid tid
pageHeading (TermCourseListR tid) pageHeading (TermCourseListR tid)
= Just . i18n . MsgTermCourseListHeading $ tid = return . i18n . MsgTermCourseListHeading $ tid
pageHeading (TermSchoolCourseListR tid ssh) pageHeading (TermSchoolCourseListR tid ssh) = do
= Just $ do School{schoolName=school} <- MaybeT . useRunDB $ get ssh
School{schoolName=school} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) $ get404 ssh return . i18n $ MsgTermSchoolCourseListHeading tid school
i18n $ MsgTermSchoolCourseListHeading tid school
pageHeading CourseListR pageHeading CourseListR
= Just $ i18n MsgCourseListTitle = return $ i18n MsgCourseListTitle
pageHeading CourseNewR pageHeading CourseNewR
= Just $ i18n MsgCourseNewHeading = return $ i18n MsgCourseNewHeading
pageHeading (CourseR tid ssh csh CShowR) pageHeading (CourseR tid ssh csh CShowR) = do
= Just $ do Entity _ Course{..} <- MaybeT . useRunDB . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Course{..} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) . getBy404 $ TermSchoolCourseShort tid ssh csh return $ toWidget courseName
toWidget courseName
-- (CourseR tid csh CRegisterR) -- just for POST -- (CourseR tid csh CRegisterR) -- just for POST
pageHeading (CourseR tid ssh csh CEditR) pageHeading (CourseR tid ssh csh CEditR)
= Just $ i18n $ MsgCourseEditHeading tid ssh csh = return $ i18n $ MsgCourseEditHeading tid ssh csh
pageHeading (CourseR tid ssh csh CCorrectionsR) pageHeading (CourseR tid ssh csh CCorrectionsR)
= Just $ i18n $ MsgSubmissionsCourse tid ssh csh = return $ i18n $ MsgSubmissionsCourse tid ssh csh
pageHeading (CourseR tid ssh csh SheetListR) pageHeading (CourseR tid ssh csh SheetListR)
= Just $ i18n $ MsgSheetList tid ssh csh = return $ i18n $ MsgSheetList tid ssh csh
pageHeading (CourseR tid ssh csh SheetNewR) pageHeading (CourseR tid ssh csh SheetNewR)
= Just $ i18n $ MsgSheetNewHeading tid ssh csh = return $ i18n $ MsgSheetNewHeading tid ssh csh
pageHeading (CSheetR tid ssh csh shn SShowR) pageHeading (CSheetR tid ssh csh shn SShowR)
= Just $ i18n $ MsgSheetTitle tid ssh csh shn = return $ i18n $ MsgSheetTitle tid ssh csh shn
-- = Just $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity -- = return $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
pageHeading (CSheetR tid ssh csh shn SEditR) pageHeading (CSheetR tid ssh csh shn SEditR)
= Just $ i18n $ MsgSheetEditHead tid ssh csh shn = return $ i18n $ MsgSheetEditHead tid ssh csh shn
pageHeading (CSheetR tid ssh csh shn SDelR) pageHeading (CSheetR tid ssh csh shn SDelR)
= Just $ i18n $ MsgSheetDelHead tid ssh csh shn = return $ i18n $ MsgSheetDelHead tid ssh csh shn
pageHeading (CSheetR _tid _ssh _csh shn SSubsR) pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
= Just $ i18n $ MsgSubmissionsSheet shn = return $ i18n $ MsgSubmissionsSheet shn
pageHeading (CSheetR tid ssh csh shn SubmissionNewR) pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSheetR tid ssh csh shn SubmissionOwnR) pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn = return $ i18n $ MsgSubmissionEditHead tid ssh csh shn
-- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download -- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
= Just $ i18n $ MsgCorrectionHead tid ssh csh shn cid = return $ i18n $ MsgCorrectionHead tid ssh csh shn cid
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download -- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
pageHeading CorrectionsR pageHeading CorrectionsR
= Just $ i18n MsgCorrectionsTitle = return $ i18n MsgCorrectionsTitle
pageHeading CorrectionsUploadR pageHeading CorrectionsUploadR
= Just $ i18n MsgCorrUpload = return $ i18n MsgCorrUpload
pageHeading CorrectionsCreateR pageHeading CorrectionsCreateR
= Just $ i18n MsgCorrCreate = return $ i18n MsgCorrCreate
pageHeading CorrectionsGradeR pageHeading CorrectionsGradeR
= Just $ i18n MsgCorrGrade = return $ i18n MsgCorrGrade
pageHeading (MessageR _) pageHeading (MessageR _)
= Just $ i18n MsgSystemMessageHeading = return $ i18n MsgSystemMessageHeading
pageHeading MessageListR pageHeading MessageListR
= Just $ i18n MsgSystemMessageListHeading = return $ i18n MsgSystemMessageListHeading
-- TODO: add headings for more single course- and single term-pages -- TODO: add headings for more single course- and single term-pages
pageHeading _ pageHeading _
= Nothing = mzero

3
src/Foundation/Yesod/ErrorHandler.hs
View File

@ -25,8 +25,7 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
, MonadAuth (HandlerFor UniWorX) , MonadAuth (HandlerFor UniWorX)
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, Button UniWorX ButtonSubmit , Button UniWorX ButtonSubmit
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) , YesodPersistBackend UniWorX ~ SqlBackend
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
) )
=> ErrorResponse -> HandlerFor UniWorX TypedContent => ErrorResponse -> HandlerFor UniWorX TypedContent
errorHandler err = do errorHandler err = do

27
src/Foundation/Yesod/Persist.hs
View File

@ -1,6 +1,8 @@
module Foundation.Yesod.Persist module Foundation.Yesod.Persist
( runDB, getDBRunner ( runDB, getDBRunner
, runDB', getDBRunner' , runDB', getDBRunner'
, runCachedDBRunner
, runCachedDBRunner'
, module Foundation.DB , module Foundation.DB
) where ) where
@ -80,3 +82,28 @@ getDBRunner' lbl = do
$logDebugS "YesodPersist" "runDBRunner" $logDebugS "YesodPersist" "runDBRunner"
runDBRunner action' runDBRunner action'
) )
runCachedDBRunner :: ( BackendCompatible backend (YesodPersistBackend UniWorX)
, YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX
, HasCallStack
)
=> CachedDBRunner backend (HandlerFor UniWorX) a
-> HandlerFor UniWorX a
runCachedDBRunner = runCachedDBRunner' callStack
runCachedDBRunner' :: ( BackendCompatible backend (YesodPersistBackend UniWorX)
, YesodPersistBackend UniWorX ~ SqlBackend
, BearerAuthSite UniWorX
)
=> CallStack
-> CachedDBRunner backend (HandlerFor UniWorX) a
-> HandlerFor UniWorX a
runCachedDBRunner' lbl act = do
cleanups <- newTVarIO []
res <- flip runCachedDBRunnerSTM act $ do
(runner, cleanup) <- getDBRunner' lbl
atomically . modifyTVar' cleanups $ (:) cleanup
return $ fromDBRunner runner
mapM_ liftHandler =<< readTVarIO cleanups
return res

72
src/Utils/DB.hs
View File

@ -12,7 +12,7 @@ import Utils
import Control.Lens import Control.Lens
import Control.Lens.Extras (is) import Control.Lens.Extras (is)
import Control.Monad.Catch import Control.Monad.Catch hiding (bracket)
import qualified Utils.Pool as Custom import qualified Utils.Pool as Custom
@ -20,6 +20,11 @@ import Database.Persist.Sql (runSqlConn)
import GHC.Stack (HasCallStack, CallStack, callStack) import GHC.Stack (HasCallStack, CallStack, callStack)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Fail (MonadFail)
import Control.Monad.Trans.Reader (withReaderT)
emptyOrIn :: PersistField typ emptyOrIn :: PersistField typ
=> E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
@ -175,3 +180,68 @@ customRunSqlPool' :: (MonadUnliftIO m, BackendCompatible SqlBackend backend)
-> CallStack -> CallStack
-> m a -> m a
customRunSqlPool' act p label = Custom.withResource' p label $ runSqlConn act customRunSqlPool' act p label = Custom.withResource' p label $ runSqlConn act
class WithRunDB backend m' m | m -> backend m' where
useRunDB :: ReaderT backend m' a -> m a
instance WithRunDB backend m (ReaderT backend m) where
useRunDB = id
data DBRunner' backend m = DBRunner' { runDBRunner' :: forall b. ReaderT backend m b -> m b }
_DBRunner' :: Iso' (DBRunner site) (DBRunner' (YesodPersistBackend site) (HandlerFor site))
_DBRunner' = iso fromDBRunner' toDBRunner
where
fromDBRunner' :: forall site.
DBRunner site
-> DBRunner' (YesodPersistBackend site) (HandlerFor site)
fromDBRunner' DBRunner{..} = DBRunner' runDBRunner
toDBRunner :: forall site.
DBRunner' (YesodPersistBackend site) (HandlerFor site)
-> DBRunner site
toDBRunner DBRunner'{..} = DBRunner runDBRunner'
fromDBRunner :: BackendCompatible backend (YesodPersistBackend site) => DBRunner site -> DBRunner' backend (HandlerFor site)
fromDBRunner DBRunner{..} = DBRunner' (runDBRunner . withReaderT projectBackend)
newtype CachedDBRunner backend m a = CachedDBRunner { runCachedDBRunnerUsing :: m (DBRunner' backend m) -> m a }
deriving (Functor, Applicative, Monad, MonadFix, MonadFail, Contravariant, MonadIO, Alternative, MonadPlus, MonadUnliftIO, MonadResource, MonadLogger, MonadThrow, MonadCatch, MonadMask) via (ReaderT (m (DBRunner' backend m)) m)
instance MonadTrans (CachedDBRunner backend) where
lift act = CachedDBRunner (\_ -> act)
instance MonadHandler m => MonadHandler (CachedDBRunner backend m) where
type HandlerSite (CachedDBRunner backend m) = HandlerSite m
type SubHandlerSite (CachedDBRunner backend m) = SubHandlerSite m
liftHandler = lift . liftHandler
liftSubHandler = lift . liftSubHandler
instance Monad m => WithRunDB backend m (CachedDBRunner backend m) where
useRunDB act = CachedDBRunner (\getRunner -> getRunner >>= \DBRunner'{..} -> runDBRunner' act)
runCachedDBRunnerSTM :: MonadUnliftIO m
=> m (DBRunner' backend m)
-> CachedDBRunner backend m a
-> m a
runCachedDBRunnerSTM doAcquire act = do
doAcquireLock <- newTMVarIO ()
runnerTMVar <- newEmptyTMVarIO
let getRunner = bracket (atomically $ takeTMVar doAcquireLock) (void . atomically . tryPutTMVar doAcquireLock) . const $ do
cachedRunner <- atomically $ tryReadTMVar runnerTMVar
case cachedRunner of
Just cachedRunner' -> return cachedRunner'
Nothing -> do
runner <- doAcquire
void . atomically $ tryPutTMVar runnerTMVar runner
return runner
getRunnerNoLock = do
cachedRunner <- atomically $ tryReadTMVar runnerTMVar
case cachedRunner of
Just cachedRunner' -> return cachedRunner'
Nothing -> getRunner
runCachedDBRunnerUsing act getRunnerNoLock