From 9d2995b6a537f73376326ceb43ec9f1edfbd4574 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 2 Oct 2019 18:54:48 +0200 Subject: [PATCH] refactor(favourites): introduce FavouriteReason --- models/courses.model | 6 ------ models/courses/favourite.model | 10 ++++++++++ routes | 1 + src/Foundation.hs | 24 +++++++++++------------- src/Handler/Course.hs | 3 +++ src/Handler/Profile.hs | 7 ------- src/Model/Migration.hs | 7 +++++++ src/Model/Types/Misc.hs | 14 ++++++++++++++ 8 files changed, 46 insertions(+), 26 deletions(-) create mode 100644 models/courses/favourite.model diff --git a/models/courses.model b/models/courses.model index 5cdecddd6..09fa149cd 100644 --- a/models/courses.model +++ b/models/courses.model @@ -35,12 +35,6 @@ CourseEdit -- who edited when a row in table "Course", kept indef user UserId time UTCTime course CourseId -CourseFavourite -- which user accessed which course when, only displayed to user for convenience; - user UserId -- max number of rows kept per user is user-defined by column 'maxFavourites' in table "User" - time UTCTime -- oldest is removed first - course CourseId - UniqueCourseFavourite user course - deriving Show Lecturer -- course ownership user UserId course CourseId diff --git a/models/courses/favourite.model b/models/courses/favourite.model new file mode 100644 index 000000000..1c5077b77 --- /dev/null +++ b/models/courses/favourite.model @@ -0,0 +1,10 @@ +CourseFavourite -- which user accessed which course when, only displayed to user for convenience; + user UserId + course CourseId + reason FavouriteReason + lastVisit UTCTime + UniqueCourseFavourite user course +CourseNoFavourite + user UserId + course CourseId + UniqueCourseNoFavourite user course \ No newline at end of file diff --git a/routes b/routes index d74bb5568..b5deeeb5a 100644 --- a/routes +++ b/routes @@ -104,6 +104,7 @@ !/course/new CourseNewR GET POST !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free + /favourite CFavouriteR POST /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬exam-result !lecturerANDallocation-time /register-template CRegisterTemplateR GET !free /edit CEditR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index d0420eae5..ed240a2fe 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1522,24 +1522,22 @@ instance Yesod UniWorX where now <- liftIO $ getCurrentTime uid <- MaybeT $ liftHandler maybeAuthId cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - user <- MaybeT $ get uid - let courseFavourite = CourseFavourite uid now cid + User{userMaxFavourites} <- MaybeT $ get uid - $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|] -- update Favourites void . lift $ upsertBy (UniqueCourseFavourite uid cid) - courseFavourite - [CourseFavouriteTime =. now] + (CourseFavourite uid cid FavouriteVisited now) + [CourseFavouriteLastVisit =. now] -- prune Favourites to user-defined size - oldFavs <- lift $ selectKeysList - [ CourseFavouriteUser ==. uid] - [ Desc CourseFavouriteTime - , OffsetBy $ userMaxFavourites user - ] - lift . forM_ oldFavs $ \fav -> do - $logDebugS "updateFavourites" "Deleting old favourite." - delete fav + 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] _other -> return () normalizeRouteMiddleware :: Handler a -> Handler a normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 6aefcff7b..454e11c85 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -29,3 +29,6 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- If they are shared, adjust MsgCourseUserNoteTooltip getCNotesR = postCNotesR postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|] + +postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () +postCFavouriteR _ _ _ = error "not implemented" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 57a49c428..6eec1dc0a 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -262,13 +262,6 @@ postProfileR = do when (stgDisplayEmail /= userDisplayEmail) $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail - when (stgMaxFavourties < userMaxFavourites) $ do - -- prune Favourites to user-defined size - oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] - [ Desc CourseFavouriteTime - , OffsetBy stgMaxFavourties - ] - mapM_ delete oldFavs let symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools) forM_ symDiff $ \ssh -> if diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 2c033b534..a5053960c 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -550,6 +550,13 @@ customMigrations = Map.fromListWith (>>) UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; |] ) + , ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|] + , whenM (tableExists "course_favourite") $ + [executeQQ| + ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit"; + ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb; + |] + ) ] diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 3444afb07..9a11e1379 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -131,3 +131,17 @@ instance YesodMail site => ToMailPart site (CsvRendered, CsvOptions) where _partContent .= Csv.encodeByNameWith (encOpts ^. _CsvEncodeOptions) csvRenderedHeader csvRenderedData instance YesodMail site => ToMailPart site CsvRendered where toMailPart = toMailPart . (, def :: CsvOptions) + + +data FavouriteReason + = FavouriteVisited + | FavouriteParticipant + | FavouriteManual + | FavouriteCurrent + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe FavouriteReason +instance Finite FavouriteReason +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''FavouriteReason +derivePersistFieldJSON ''FavouriteReason