diff --git a/src/Foundation.hs b/src/Foundation.hs index d9f75af5a..4b54a9fd1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1510,6 +1510,35 @@ evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False +updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) + => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate + -> ReaderT SqlBackend m () +updateFavourites cData = void . runMaybeT $ do + $logDebugS "updateFavourites" "Updating favourites" + + now <- liftIO $ getCurrentTime + uid <- MaybeT $ liftHandler maybeAuthId + mcid <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + User{userMaxFavourites} <- MaybeT $ get uid + + -- update Favourites + for_ mcid $ \cid -> + void . lift $ upsertBy + (UniqueCourseFavourite uid cid) + (CourseFavourite uid cid FavouriteVisited now) + [CourseFavouriteLastVisit =. now] + -- prune Favourites to user-defined size + oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] [] + let deleteFavs = oldFavs + & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal) + & drop userMaxFavourites + & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal) + & map entityKey + unless (null deleteFavs) $ + lift $ deleteWhere [CourseFavouriteId <-. deleteFavs] + + + -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod UniWorX where @@ -1544,27 +1573,7 @@ instance Yesod UniWorX where CourseR tid ssh csh _ -> do void . lift . runDB . runMaybeT $ do guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False - $logDebugS "updateFavourites" "Updating favourites" - - now <- liftIO $ getCurrentTime - uid <- MaybeT $ liftHandler maybeAuthId - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - User{userMaxFavourites} <- MaybeT $ get uid - - -- update Favourites - void . lift $ upsertBy - (UniqueCourseFavourite uid cid) - (CourseFavourite uid cid FavouriteVisited now) - [CourseFavouriteLastVisit =. now] - -- prune Favourites to user-defined size - oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] [] - let deleteFavs = oldFavs - & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal) - & drop userMaxFavourites - & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal) - & map entityKey - unless (null deleteFavs) $ - lift $ deleteWhere [CourseFavouriteId <-. deleteFavs] + lift . updateFavourites $ Just (tid, ssh, csh) _other -> return () normalizeRouteMiddleware :: Handler a -> Handler a normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 839f4ee1e..fbb3093cf 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -278,6 +278,7 @@ postProfileR = do , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] + updateFavourites Nothing when (stgDisplayEmail /= userDisplayEmail) $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail