From c23222aef65ebab38029c7417cda53274e2df063 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 23 Mar 2021 15:18:37 +0100 Subject: [PATCH] perf: try to reduce db conn load of site-layout/nav --- src/Foundation/Navigation.hs | 79 +++++------ src/Foundation/SiteLayout.hs | 192 ++++++++++++++------------- src/Foundation/Yesod/ErrorHandler.hs | 3 +- src/Foundation/Yesod/Persist.hs | 27 ++++ src/Utils/DB.hs | 72 +++++++++- 5 files changed, 240 insertions(+), 133 deletions(-) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1c0cf98cc..5c2eef1fe 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 95e32abf9..28d4d1342 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -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 diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs index bc7647387..4669a6bac 100644 --- a/src/Foundation/Yesod/ErrorHandler.hs +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -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 diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index e9f2374a2..1ebc60983 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -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 diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index bd8fc160e..05ec0516b 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -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