diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 3aa73ab4f..95d3629f0 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b9186f509..0208a124c 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index abad8669c..5e9991cf1 100644 --- a/src/Handler/Course/Show.hs +++ b/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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 4f28d482d..2b5bdd4c6 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -198,6 +198,7 @@ data FormIdentifier | FIDmaterial | FIDCourseNews | FIDCourseEvent + | FIDCourseFavouriteToggle | FIDsubmission | FIDsettings | FIDcorrectors diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index cf553465f..273c374d5 100644 --- a/src/Utils/Icon.hs +++ b/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"