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

chore: unify runDB calls

Browse Source
This commit is contained in:
Wolfgang Witt 2021-04-13 13:08:24 +02:00 committed by Gregor Kleen
parent 89e7345b8c
commit d6e39fb07c
1 changed files with 11 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/Foundation/SiteLayout.hs
View File

@ -151,11 +151,11 @@ siteLayout' overrideHeading widget = do
now <- liftIO getCurrentTime
muid <- maybeAuthPair
-- Lookup Favourites, Breadcrumbs, Headline, & Theme if possible
(favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme) <- do
muid <- maybeAuthPair
(favourites', (title, parents), nav', contentHeadline, mmsgs, maxFavouriteTerms, currentTheme, storedReasonAndToggleRoute) <- do
(favCourses, breadcrumbs'', nav', contentHeadline, mmsgs) <- runDB $ do
(favCourses, breadcrumbs'', nav', contentHeadline, mmsgs, storedReasonAndToggleRoute) <- 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)
@ -246,8 +246,12 @@ siteLayout' overrideHeading widget = do
forM_ authTagPivots $
\authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
getMessages
storedReasonAndToggleRoute <- case mcurrentRoute of
(Just (CourseR tid ssh csh _)) -> (, Just . SomeRoute $ CourseR tid ssh csh CFavouriteR) <$> storedFavouriteReason tid ssh csh muid
_otherwise -> pure (Nothing, Nothing)
return (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs)
return (favCourses, breadcrumbs'', nav', contentHeadline, mmsgs, storedReasonAndToggleRoute)
return ( favCourses
, breadcrumbs''
@ -256,13 +260,11 @@ siteLayout' overrideHeading widget = do
, mmsgs
, maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
, maybe userDefaultTheme userTheme $ view _2 <$> muid
, storedReasonAndToggleRoute
)
muid <- maybeAuthPair
(currentReason', maybeRoute) <- case mcurrentRoute of
(Just (CourseR tid ssh csh _)) -> (, Just . SomeRoute $ CourseR tid ssh csh CFavouriteR) <$> runDB (storedFavouriteReason tid ssh csh muid)
_otherwise -> pure (Nothing, Nothing)
let currentReason = case currentReason' of
let (currentReason', maybeRoute) = storedReasonAndToggleRoute
currentReason = case currentReason' of
-- (reason, blacklist)
(Just (_reason, True)) -> Nothing
(Just (Just reason, False)) -> Just reason