refactor(favourites): introduce FavouriteReason

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

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

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

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

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"

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

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;
+      |]
+    )
   ]
 
 

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