perf: try to reduce db conn load of site-layout/nav
This commit is contained in:
Gregor Kleen
parent
da724654ed
commit
c23222aef6
@ -24,7 +24,6 @@ import Foundation.Type
|
||||
import Foundation.Routes
|
||||
import Foundation.I18n
|
||||
import Foundation.Authorization
|
||||
import Foundation.DB
|
||||
|
||||
import Handler.Utils.Memcached
|
||||
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,
|
||||
-- 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 :: BearerAuthSite UniWorX
|
||||
breadcrumb :: ( BearerAuthSite UniWorX
|
||||
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Route UniWorX
|
||||
-> ReaderT SqlReadBackend (HandlerFor UniWorX) Breadcrumb
|
||||
-> m Breadcrumb
|
||||
breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR
|
||||
breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing
|
||||
breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing
|
||||
@ -81,21 +83,21 @@ breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing
|
||||
breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing
|
||||
breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR
|
||||
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
|
||||
uid <- decrypt cID
|
||||
User{..} <- MaybeT $ get uid
|
||||
return (userDisplayName, Just UsersR)
|
||||
breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID
|
||||
breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID
|
||||
breadcrumb (UserNotificationR cID) = do
|
||||
breadcrumb (UserNotificationR cID) = useRunDB $ do
|
||||
mayList <- hasReadAccessTo UsersR
|
||||
if
|
||||
| mayList
|
||||
-> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID
|
||||
| otherwise
|
||||
-> i18nCrumb MsgMenuUserNotifications $ Just ProfileR
|
||||
breadcrumb (UserPasswordR cID) = do
|
||||
breadcrumb (UserPasswordR cID) = useRunDB $ do
|
||||
mayList <- hasReadAccessTo UsersR
|
||||
if
|
||||
| mayList
|
||||
@ -114,7 +116,7 @@ breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
|
||||
|
||||
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
||||
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
|
||||
isAdmin <- lift $ hasReadAccessTo SchoolListR
|
||||
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
|
||||
SchoolWorkflowInstanceR win sRoute' -> case sRoute' of
|
||||
SWIEditR -> do
|
||||
desc <- runMaybeT $ do
|
||||
desc <- useRunDB . runMaybeT $ do
|
||||
guardM . lift . hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR
|
||||
wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh
|
||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||
@ -133,7 +135,7 @@ breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
||||
Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute
|
||||
SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . 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
|
||||
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if
|
||||
| mayEdit -> SchoolWorkflowInstanceR win SWIEditR
|
||||
@ -178,11 +180,11 @@ breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR
|
||||
breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR
|
||||
breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR
|
||||
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
|
||||
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 $
|
||||
(&&) <$> fmap isJust (get ssh)
|
||||
<*> fmap isJust (get tid)
|
||||
@ -190,12 +192,12 @@ breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbScho
|
||||
|
||||
breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR
|
||||
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
|
||||
Entity _ Allocation{allocationName} <- MaybeT . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR)
|
||||
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
|
||||
Course{..} <- do
|
||||
aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash
|
||||
@ -214,7 +216,7 @@ breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect $ Ju
|
||||
|
||||
breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing
|
||||
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
|
||||
return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
|
||||
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 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 (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
|
||||
uid <- decrypt cID
|
||||
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 (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
|
||||
appId <- decrypt cID
|
||||
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
|
||||
|
||||
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
|
||||
return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
|
||||
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
|
||||
|
||||
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
|
||||
return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
||||
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
|
||||
|
||||
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
|
||||
return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
|
||||
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
|
||||
SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR
|
||||
SubmissionR cid sRoute' -> case sRoute' of
|
||||
SubShowR -> do
|
||||
SubShowR -> useRunDB $ do
|
||||
mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
|
||||
if
|
||||
| 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 MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR
|
||||
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
|
||||
return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
|
||||
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 (MessageR _) = do
|
||||
mayList <- hasReadAccessTo MessageListR
|
||||
mayList <- useRunDB $ hasReadAccessTo MessageListR
|
||||
if
|
||||
| mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR
|
||||
| otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR
|
||||
@ -362,13 +364,13 @@ breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR
|
||||
|
||||
breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing
|
||||
breadcrumb EExamNewR = do
|
||||
isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
|
||||
isEO <- useRunDB . hasReadAccessTo $ ExamOfficeR EOExamsR
|
||||
i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if
|
||||
| isEO -> ExamOfficeR EOExamsR
|
||||
| otherwise -> EExamListR
|
||||
breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of
|
||||
EEShowR -> do
|
||||
(isEO, mayShow) <- (,)
|
||||
(isEO, mayShow) <- useRunDB $ (,)
|
||||
<$> hasReadAccessTo (ExamOfficeR EOExamsR)
|
||||
<*> hasReadAccessTo (EExamR tid ssh coursen examn EEShowR)
|
||||
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 (GlobalWorkflowInstanceR win sRoute) = case sRoute of
|
||||
GWIEditR -> do
|
||||
desc <- runMaybeT $ do
|
||||
desc <- useRunDB . runMaybeT $ do
|
||||
guardM . lift . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR
|
||||
wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal
|
||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||
@ -411,7 +413,7 @@ breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
|
||||
GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR
|
||||
GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR
|
||||
GWIInitiateR -> do
|
||||
mayEdit <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR
|
||||
mayEdit <- useRunDB . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR
|
||||
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if
|
||||
| mayEdit -> GlobalWorkflowInstanceR win GWIEditR
|
||||
| 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
|
||||
|
||||
|
||||
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
|
||||
guardM $ preuse _navLink >>= lift . lift . maybe (return True) navLinkAccess
|
||||
|
||||
@ -540,24 +542,25 @@ navAccess = execStateT $ do
|
||||
whenM (hasn't _navLink <$> use id) $
|
||||
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
|
||||
NavAccessHandler naNoDb -> handle shortCircuit $ liftHandler naNoDb `and2M` accessCheck (liftHandler . runDBRead) navType navRoute
|
||||
NavAccessDB naDb -> handle shortCircuit . liftHandler . runDBRead $ naDb `and2M` accessCheck id navType navRoute
|
||||
NavAccessTrue -> accessCheck (liftHandler . runDBRead) navType navRoute
|
||||
NavAccessHandler naNoDb -> handle shortCircuit $ liftHandler naNoDb `and2M` accessCheck navType navRoute
|
||||
NavAccessDB naDb -> handle shortCircuit . useRunDB $ naDb `and2M` accessCheck navType navRoute
|
||||
NavAccessTrue -> accessCheck navType navRoute
|
||||
where
|
||||
shortCircuit :: HandlerContents -> m Bool
|
||||
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 liftDb nt (urlRoute -> route) = do
|
||||
accessCheck :: forall m' route. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadThrow m', WithRunDB SqlReadBackend (HandlerFor UniWorX) m', HasRoute UniWorX route) => NavType -> route -> m' Bool
|
||||
accessCheck nt (urlRoute -> route) = do
|
||||
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
|
||||
|
||||
defaultLinks :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
|
||||
, BearerAuthSite UniWorX
|
||||
) => m [Nav]
|
||||
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
|
||||
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
|
||||
<*> haveTopWorkflowWorkflows
|
||||
|
||||
@ -903,8 +906,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
pageActions :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
|
||||
, BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Route UniWorX -> m [Nav]
|
||||
@ -941,7 +944,7 @@ pageActions (CourseR tid ssh csh CShowR) = do
|
||||
|
||||
let examListBound :: Num a => a
|
||||
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
|
||||
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
|
||||
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
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
|
||||
, BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
)
|
||||
=> NavQuickView -> Route UniWorX -> m [NavLink]
|
||||
pageQuickActions qView route = do
|
||||
|
||||
@ -7,14 +7,14 @@ module Foundation.SiteLayout
|
||||
, getSystemMessageState
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (embedFile)
|
||||
import Import.NoFoundation hiding (embedFile, runDB)
|
||||
|
||||
import Foundation.Type
|
||||
import Foundation.Authorization
|
||||
import Foundation.Routes
|
||||
import Foundation.Navigation
|
||||
import Foundation.I18n
|
||||
import Foundation.DB
|
||||
import Foundation.Yesod.Persist
|
||||
|
||||
import Utils.SystemMessage
|
||||
import Utils.Form
|
||||
@ -54,16 +54,15 @@ data MemcachedLimitKeyFavourites
|
||||
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
|
||||
|
||||
{-# 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
|
||||
|
||||
siteLayout :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, Button UniWorX ButtonSubmit
|
||||
)
|
||||
=> WidgetFor UniWorX () -- ^ `pageHeading`
|
||||
@ -71,8 +70,7 @@ siteLayout :: ( BearerAuthSite UniWorX
|
||||
siteLayout = siteLayout' . Just
|
||||
|
||||
siteLayout' :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, Button UniWorX ButtonSubmit
|
||||
)
|
||||
=> Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading`
|
||||
@ -96,12 +94,12 @@ siteLayout' overrideHeading widget = do
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
|
||||
-- Lookup Favourites, Breadcrumbs, & Theme if possible
|
||||
(favourites', (title, parents), maxFavouriteTerms, currentTheme) <- do
|
||||
-- Lookup Favourites, Breadcrumbs, Headline, & Theme if possible
|
||||
(favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme) <- do
|
||||
muid <- maybeAuthPair
|
||||
|
||||
(favCourses, breadcrumbs'') <- runDBRead $ do
|
||||
favCourses'' <- E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
|
||||
(favCourses, breadcrumbs'', nav', contentHeadline, mmsgs) <- runDB $ 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.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
|
||||
|
||||
@ -150,7 +148,7 @@ siteLayout' overrideHeading widget = do
|
||||
, 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
|
||||
mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
|
||||
return ((cName, tid, ssh, csh), reason, courseVisible, mayView, mayEdit)
|
||||
@ -172,12 +170,33 @@ siteLayout' overrideHeading widget = do
|
||||
hasAccess <- hasReadAccessTo cRoute
|
||||
(title, next) <- breadcrumb cRoute
|
||||
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
|
||||
, breadcrumbs''
|
||||
, nav'
|
||||
, contentHeadline
|
||||
, mmsgs
|
||||
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
|
||||
, maybe userDefaultTheme userTheme $ view _2 <$> muid
|
||||
)
|
||||
@ -203,7 +222,7 @@ siteLayout' overrideHeading widget = do
|
||||
appFavouritesQuickActionsTimeout
|
||||
cK
|
||||
cK
|
||||
. observeFavouritesQuickActionsDuration $ do
|
||||
. observeFavouritesQuickActionsDuration . runCachedDBRunner $ do
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
|
||||
items' <- pageQuickActions NavQuickViewFavourite courseRoute
|
||||
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)
|
||||
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)
|
||||
|
||||
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
|
||||
-- let langFormView' = wrapForm langFormView def
|
||||
-- { formAction = Just $ SomeRoute LangR
|
||||
@ -364,8 +369,6 @@ siteLayout' overrideHeading widget = do
|
||||
where isNavFooter = has $ _1 . _NavFooter
|
||||
alerts :: WidgetFor UniWorX ()
|
||||
alerts = $(widgetFile "widgets/alerts/alerts")
|
||||
contentHeadline :: Maybe (WidgetFor UniWorX ())
|
||||
contentHeadline = overrideHeading <|> (pageHeading =<< mcurrentRoute)
|
||||
breadcrumbsWgt :: WidgetFor UniWorX ()
|
||||
breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
|
||||
pageaction :: WidgetFor UniWorX ()
|
||||
@ -423,19 +426,25 @@ getSystemMessageState smId = liftHandler $ do
|
||||
where foldSt (Entity _ SystemMessageHidden{..})
|
||||
= MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }
|
||||
|
||||
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m ()
|
||||
applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
|
||||
applySystemMessages :: forall m.
|
||||
( 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
|
||||
|
||||
cRoute <- lift getCurrentRoute
|
||||
cRoute <- getCurrentRoute
|
||||
guard $ cRoute /= Just NewsR
|
||||
|
||||
lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
|
||||
lift . useRunDB . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
|
||||
where
|
||||
syncSystemMessageHidden :: UserId -> HandlerFor UniWorX ()
|
||||
syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do
|
||||
smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
|
||||
iforM_ smSt $ \cID UserSystemMessageState{..} -> do
|
||||
syncSystemMessageHidden :: UserId -> m ()
|
||||
syncSystemMessageHidden uid = do
|
||||
smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: m (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
|
||||
iforM_ smSt $ \cID UserSystemMessageState{..} -> useRunDB $ do
|
||||
smId <- decrypt cID
|
||||
whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
|
||||
upsert SystemMessageHidden
|
||||
@ -452,11 +461,11 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
|
||||
-> fmap MergeHashMap . assertM' (/= mempty) $
|
||||
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
|
||||
guard $ not systemMessageNewsOnly
|
||||
|
||||
cID <- encrypt smId
|
||||
cID <- lift $ encrypt smId
|
||||
guardM . lift . hasReadAccessTo $ MessageR cID
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
@ -488,103 +497,102 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
|
||||
-- All handlers whose code is under our control should use
|
||||
-- `siteLayout` instead; `pageHeading` is only a fallback solution for
|
||||
-- e.g. subsites like `AuthR`
|
||||
pageHeading :: ( YesodPersist UniWorX
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
) => Route UniWorX -> Maybe Widget
|
||||
pageHeading :: ( YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
|
||||
, MonadHandler m
|
||||
) => Route UniWorX -> MaybeT m Widget
|
||||
pageHeading (AuthR _)
|
||||
= Just $ i18n MsgLoginHeading
|
||||
= return $ i18n MsgLoginHeading
|
||||
pageHeading NewsR
|
||||
= Just $ i18n MsgNewsHeading
|
||||
= return $ i18n MsgNewsHeading
|
||||
pageHeading UsersR
|
||||
= Just $ i18n MsgUsers
|
||||
= return $ i18n MsgUsers
|
||||
pageHeading (AdminUserR _)
|
||||
= Just $ i18n MsgAdminUserHeading
|
||||
= return $ i18n MsgAdminUserHeading
|
||||
pageHeading AdminTestR
|
||||
= Just [whamlet|Internal Code Demonstration Page|]
|
||||
= return [whamlet|Internal Code Demonstration Page|]
|
||||
pageHeading AdminErrMsgR
|
||||
= Just $ i18n MsgErrMsgHeading
|
||||
= return $ i18n MsgErrMsgHeading
|
||||
|
||||
pageHeading InfoR
|
||||
= Just $ i18n MsgInfoHeading
|
||||
= return $ i18n MsgInfoHeading
|
||||
pageHeading LegalR
|
||||
= Just $ i18n MsgLegalHeading
|
||||
= return $ i18n MsgLegalHeading
|
||||
pageHeading VersionR
|
||||
= Just $ i18n MsgVersionHeading
|
||||
= return $ i18n MsgVersionHeading
|
||||
|
||||
pageHeading HelpR
|
||||
= Just $ i18n MsgHelpRequest
|
||||
= return $ i18n MsgHelpRequest
|
||||
|
||||
pageHeading ProfileR
|
||||
= Just $ i18n MsgProfileHeading
|
||||
= return $ i18n MsgProfileHeading
|
||||
pageHeading ProfileDataR
|
||||
= Just $ i18n MsgProfileDataHeading
|
||||
= return $ i18n MsgProfileDataHeading
|
||||
|
||||
pageHeading TermShowR
|
||||
= Just $ i18n MsgTermsHeading
|
||||
= return $ i18n MsgTermsHeading
|
||||
pageHeading TermCurrentR
|
||||
= Just $ i18n MsgTermCurrent
|
||||
= return $ i18n MsgTermCurrent
|
||||
pageHeading TermEditR
|
||||
= Just $ i18n MsgTermEditHeading
|
||||
= return $ i18n MsgTermEditHeading
|
||||
pageHeading (TermEditExistR tid)
|
||||
= Just $ i18n $ MsgTermEditTid tid
|
||||
= return $ i18n $ MsgTermEditTid tid
|
||||
pageHeading (TermCourseListR tid)
|
||||
= Just . i18n . MsgTermCourseListHeading $ tid
|
||||
pageHeading (TermSchoolCourseListR tid ssh)
|
||||
= Just $ do
|
||||
School{schoolName=school} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) $ get404 ssh
|
||||
i18n $ MsgTermSchoolCourseListHeading tid school
|
||||
= return . i18n . MsgTermCourseListHeading $ tid
|
||||
pageHeading (TermSchoolCourseListR tid ssh) = do
|
||||
School{schoolName=school} <- MaybeT . useRunDB $ get ssh
|
||||
return . i18n $ MsgTermSchoolCourseListHeading tid school
|
||||
|
||||
pageHeading CourseListR
|
||||
= Just $ i18n MsgCourseListTitle
|
||||
= return $ i18n MsgCourseListTitle
|
||||
pageHeading CourseNewR
|
||||
= Just $ i18n MsgCourseNewHeading
|
||||
pageHeading (CourseR tid ssh csh CShowR)
|
||||
= Just $ do
|
||||
Entity _ Course{..} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
toWidget courseName
|
||||
= return $ i18n MsgCourseNewHeading
|
||||
pageHeading (CourseR tid ssh csh CShowR) = do
|
||||
Entity _ Course{..} <- MaybeT . useRunDB . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
return $ toWidget courseName
|
||||
-- (CourseR tid csh CRegisterR) -- just for POST
|
||||
pageHeading (CourseR tid ssh csh CEditR)
|
||||
= Just $ i18n $ MsgCourseEditHeading tid ssh csh
|
||||
= return $ i18n $ MsgCourseEditHeading tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh CCorrectionsR)
|
||||
= Just $ i18n $ MsgSubmissionsCourse tid ssh csh
|
||||
= return $ i18n $ MsgSubmissionsCourse tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh SheetListR)
|
||||
= Just $ i18n $ MsgSheetList tid ssh csh
|
||||
= return $ i18n $ MsgSheetList tid ssh csh
|
||||
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)
|
||||
= Just $ i18n $ MsgSheetTitle tid ssh csh shn
|
||||
-- = Just $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
|
||||
= return $ i18n $ MsgSheetTitle tid ssh csh shn
|
||||
-- = return $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
|
||||
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)
|
||||
= Just $ i18n $ MsgSheetDelHead tid ssh csh shn
|
||||
= return $ i18n $ MsgSheetDelHead tid ssh csh shn
|
||||
pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
|
||||
= Just $ i18n $ MsgSubmissionsSheet shn
|
||||
= return $ i18n $ MsgSubmissionsSheet shn
|
||||
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)
|
||||
= 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!
|
||||
= Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
|
||||
= return $ i18n $ MsgSubmissionEditHead tid ssh csh shn
|
||||
-- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
|
||||
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
|
||||
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
|
||||
|
||||
pageHeading CorrectionsR
|
||||
= Just $ i18n MsgCorrectionsTitle
|
||||
= return $ i18n MsgCorrectionsTitle
|
||||
pageHeading CorrectionsUploadR
|
||||
= Just $ i18n MsgCorrUpload
|
||||
= return $ i18n MsgCorrUpload
|
||||
pageHeading CorrectionsCreateR
|
||||
= Just $ i18n MsgCorrCreate
|
||||
= return $ i18n MsgCorrCreate
|
||||
pageHeading CorrectionsGradeR
|
||||
= Just $ i18n MsgCorrGrade
|
||||
= return $ i18n MsgCorrGrade
|
||||
pageHeading (MessageR _)
|
||||
= Just $ i18n MsgSystemMessageHeading
|
||||
= return $ i18n MsgSystemMessageHeading
|
||||
pageHeading MessageListR
|
||||
= Just $ i18n MsgSystemMessageListHeading
|
||||
= return $ i18n MsgSystemMessageListHeading
|
||||
|
||||
-- TODO: add headings for more single course- and single term-pages
|
||||
pageHeading _
|
||||
= Nothing
|
||||
= mzero
|
||||
|
||||
@ -25,8 +25,7 @@ errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
|
||||
, MonadAuth (HandlerFor UniWorX)
|
||||
, BearerAuthSite UniWorX
|
||||
, Button UniWorX ButtonSubmit
|
||||
, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
)
|
||||
=> ErrorResponse -> HandlerFor UniWorX TypedContent
|
||||
errorHandler err = do
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
module Foundation.Yesod.Persist
|
||||
( runDB, getDBRunner
|
||||
, runDB', getDBRunner'
|
||||
, runCachedDBRunner
|
||||
, runCachedDBRunner'
|
||||
, module Foundation.DB
|
||||
) where
|
||||
|
||||
@ -80,3 +82,28 @@ getDBRunner' lbl = do
|
||||
$logDebugS "YesodPersist" "runDBRunner"
|
||||
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
|
||||
|
||||
@ -12,7 +12,7 @@ import Utils
|
||||
import Control.Lens
|
||||
import Control.Lens.Extras (is)
|
||||
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Catch hiding (bracket)
|
||||
|
||||
import qualified Utils.Pool as Custom
|
||||
|
||||
@ -20,6 +20,11 @@ import Database.Persist.Sql (runSqlConn)
|
||||
|
||||
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
|
||||
=> E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
|
||||
@ -175,3 +180,68 @@ customRunSqlPool' :: (MonadUnliftIO m, BackendCompatible SqlBackend backend)
|
||||
-> CallStack
|
||||
-> m a
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user