chore: button only redirects to postCFavouriteR

actual swapping should happen there
still need to display the correct button
This commit is contained in:
Wolfgang Witt 2021-04-01 11:42:34 +02:00 committed by Gregor Kleen
parent 6b9c0849e4
commit e23a5a64cc
2 changed files with 22 additions and 31 deletions

View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -Wwarn #-}
module Handler.Course
( module Handler.Course
) where
@ -33,5 +35,12 @@ getCNotesR = postCNotesR
postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|]
postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler ()
postCFavouriteR _ _ _ = error "not implemented"
postCFavouriteR tid ssh csh = do
-- TODO swap FavouriteReason here
-- TODO participants can't remove favourite?
liftIO $ do
putStrLn "\nswapping FavouriteReason"
print (tid, ssh, csh)
-- show course page again
void $ redirect $ CourseR tid ssh csh CShowR
-- TODO Route for Icon to toggle manual Favorite

View File

@ -45,36 +45,18 @@ instance Button UniWorX CourseFavouriteToggleButton where
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)
courseFavouriteToggleForm :: Maybe FavouriteReason -> Form ()
courseFavouriteToggleForm currentReason html
= over _1 (fmap $ const ()) <$> identifyForm FIDCourseFavouriteToggle (buttonForm' [btn]) html
where
btn :: CourseFavouriteToggleButton
btn = case currentReason of
Nothing -> BtnCourseFavouriteToggleOff
(Just FavouriteVisited) -> BtnCourseFavouriteToggleAutomatic
(Just FavouriteParticipant) -> BtnCourseFavouriteToggleAutomatic
(Just FavouriteManual) -> BtnCourseFavouriteToggleManual
(Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic
-- TODO add toggle Manual favorite Icon here
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -310,7 +292,7 @@ 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
favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm $ Just FavouriteVisited
let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) ->
wrapForm favouriteToggleView def
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR