chore: show some Icon calling postCFavouriteR

src/Foundation/Yesod/Middleware.hs

@@ -184,6 +184,9 @@ updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do
   mcid  <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId)
   User{userMaxFavourites} <- MaybeT $ get uid
 
+  -- TODO optimize for `userMaxFavourites == 0`
+  -- no need to store (upsert?) them, since they will be removed in the pruning step anyway!
+
   -- update Favourites
   for_ mcid $ \cid ->
     void . lift $ upsertBy

src/Handler/Course.hs

@@ -34,3 +34,4 @@ postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this cou
 
 postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler ()
 postCFavouriteR _ _ _ = error "not implemented"
+-- TODO Route for Icon to toggle manual Favorite

src/Handler/Course/Show.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
 module Handler.Course.Show
   ( getCShowR
   , getCRegisterTemplateR, courseRegisterTemplateSource
@@ -26,6 +28,55 @@ import qualified Data.Conduit.List as C
 import Handler.Exam.List (mkExamTable)
 
 
+data CourseFavouriteToggleButton
+  = BtnCourseFavouriteToggleManual
+  | BtnCourseFavouriteToggleAutomatic
+  | BtnCourseFavouriteToggleOff
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe CourseFavouriteToggleButton
+instance Finite CourseFavouriteToggleButton
+
+nullaryPathPiece ''CourseFavouriteToggleButton $ camelToPathPiece' 4
+
+instance Button UniWorX CourseFavouriteToggleButton where
+  btnLabel BtnCourseFavouriteToggleManual = toWidget iconCourseFavouriteManual
+  btnLabel BtnCourseFavouriteToggleAutomatic = toWidget iconCourseFavouriteAutomatic
+  btnLabel BtnCourseFavouriteToggleOff = toWidget iconCourseFavouriteOff
+
+  btnClasses _ = [BCIsButton]
+
+newtype CourseFavouriteToggleForm = CourseFavouriteToggleForm
+  { cftfFavouriteReason :: Maybe FavouriteReason
+  } deriving stock   (Eq, Ord, Read, Show, Generic, Typeable)
+    deriving newtype (Default, FromJSON, ToJSON)
+
+makeLenses_ ''CourseFavouriteToggleForm
+
+-- inspired by examAutoOccurrenceIgnoreRoomsForm
+courseFavouriteToggleForm :: TermId -> SchoolId -> CourseShorthand -> CourseFavouriteToggleForm -> Form CourseFavouriteToggleForm
+courseFavouriteToggleForm tid ssh csh protoForm html = do
+  -- create all buttons
+  (btnResManual, wgtManual) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleManual]) html
+  (btnResAutomatic, wgtAutomatic) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleAutomatic]) html
+  (btnResOff, wgtOff) <- identifyForm FIDCourseFavouriteToggle (buttonForm' [BtnCourseFavouriteToggleOff]) html
+
+  -- choose the relevant button to display
+  let btnRes = btnResManual <|> btnResAutomatic <|> btnResOff
+      (wgt, res) = case btnRes of
+        (FormSuccess BtnCourseFavouriteToggleManual) -> (wgtAutomatic, FormSuccess $ CourseFavouriteToggleForm $ Just FavouriteCurrent)
+          -- TODO participants can't remove favourite?
+        (FormSuccess BtnCourseFavouriteToggleAutomatic) -> (wgtOff, FormSuccess $ CourseFavouriteToggleForm Nothing)
+        (FormSuccess BtnCourseFavouriteToggleOff) -> (wgtAutomatic, FormSuccess $ CourseFavouriteToggleForm $ Just FavouriteCurrent)
+        _otherwise -> (,FormMissing) $ case cftfFavouriteReason protoForm of
+          Nothing -> wgtOff
+          (Just FavouriteVisited) -> wgtAutomatic
+          -- TODO participants can't remove favourite?
+          (Just FavouriteParticipant) -> wgtAutomatic
+          (Just FavouriteManual) -> wgtManual
+          (Just FavouriteCurrent) -> wgtAutomatic
+  return (res, wgt)
+
+-- TODO add toggle Manual favorite Icon here
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
@@ -259,11 +310,22 @@ getCShowR tid ssh csh = do
   mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR
   mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
 
+  favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm tid ssh csh $ CourseFavouriteToggleForm $ Just FavouriteVisited
+  let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) ->
+        wrapForm favouriteToggleView def
+          { formAction   = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR
+          , formEncoding = favouriteToggleEncoding
+          , formSubmit   = FormNoSubmit
+          , formAttrs = [("class", "buttongroup")]
+          }
+
+
   let heading = [whamlet|
           $newline never
           ^{courseName course}
           $if not courseVisible && mayEdit
             \ #{iconInvisible}
+          ^{favouriteToggleWgt}
         |]
 
   siteLayout heading $ do

src/Utils/Form.hs

@@ -198,6 +198,7 @@ data FormIdentifier
   | FIDmaterial
   | FIDCourseNews
   | FIDCourseEvent
+  | FIDCourseFavouriteToggle
   | FIDsubmission
   | FIDsettings
   | FIDcorrectors

src/Utils/Icon.hs

@@ -37,6 +37,7 @@ data Icon
   | IconVisible
   | IconInvisible
   | IconCourse
+  | IconCourseFavouriteManual | IconCourseFavouriteAutomatic | IconCourseFavouriteOff
   | IconEnrolTrue
   | IconEnrolFalse
   | IconPlanned
@@ -110,6 +111,10 @@ iconText = \case
     IconVisible                 -> "eye"
     IconInvisible               -> "eye-slash"
     IconCourse                  -> "graduation-cap"
+    -- TODO find better Icons: https://fontawesome.com/icons?d=gallery&p=2&s=solid
+    IconCourseFavouriteManual   -> "battery-full"
+    IconCourseFavouriteAutomatic -> "battery-half"
+    IconCourseFavouriteOff      -> "battery-slash"
     IconEnrolTrue               -> "user-plus"
     IconEnrolFalse              -> "user-slash"
     IconPlanned                 -> "cog"