fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore: remove special case for participants

Browse Source
This commit is contained in:
Wolfgang Witt 2021-04-06 15:13:07 +02:00 committed by Gregor Kleen
parent 664c915065
commit 7896c0bb16
2 changed files with 24 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
src/Handler/Course.hs
View File

@ -48,32 +48,26 @@ postCFavouriteR tid ssh csh = void $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- Nothing means blacklist -- Nothing means blacklist
-- should never return FavouriteCurrent -- should never return FavouriteCurrent
(maybeReason, blacklist) <- storedFavouriteReason tid ssh csh muid >>= pure . \case newReason <- storedFavouriteReason tid ssh csh muid >>= pure . \case
-- Maybe (Maybe reason, blacklist, associated) -- Maybe (Maybe reason, blacklist)
Nothing -> (Just FavouriteManual, False) Nothing -> Just FavouriteManual
-- participants can't remove favourite (only toggle between automatic/manual) Just (_reason, True) -> Just FavouriteVisited
Just (Just FavouriteManual, _blacklist, True) -> (Just FavouriteVisited, False) Just (Just FavouriteManual, False) -> Nothing
Just (_reason, _blacklist, True) -> (Just FavouriteManual, False) Just (_reason, False) -> Just FavouriteManual
Just (_reason, True, False) -> (Just FavouriteVisited, False)
Just (Just FavouriteManual, False, False) -> (Nothing, True)
Just (_reason, False, False) -> (Just FavouriteManual, False)
-- change stored reason in DB -- change stored reason in DB
if blacklist case newReason of
then do (Just reason) -> do
void $ E.upsertBy
(UniqueCourseFavourite uid cid)
(CourseFavourite uid cid reason now)
[P.Update CourseFavouriteReason reason P.Assign]
E.deleteBy $ UniqueCourseNoFavourite uid cid
Nothing -> do
E.deleteBy $ UniqueCourseFavourite uid cid E.deleteBy $ UniqueCourseFavourite uid cid
void $ E.upsertBy void $ E.upsertBy
(UniqueCourseNoFavourite uid cid) (UniqueCourseNoFavourite uid cid)
(CourseNoFavourite uid cid) (CourseNoFavourite uid cid)
[] -- entry shouldn't exists, but keep it unchanged anyway [] -- entry shouldn't exists, but keep it unchanged anyway
else do
case maybeReason of
(Just reason) -> void $ E.upsertBy
(UniqueCourseFavourite uid cid)
(CourseFavourite uid cid reason now)
[P.Update CourseFavouriteReason reason P.Assign]
-- [CourseFavouriteReason E.=. E.val reason]
Nothing -> E.deleteBy $ UniqueCourseFavourite uid cid
E.deleteBy $ UniqueCourseNoFavourite uid cid
| otherwise -> pure () | otherwise -> pure ()
-- show course page again -- show course page again
redirect $ CourseR tid ssh csh CShowR redirect $ CourseR tid ssh csh CShowR

44
src/Handler/Course/Show.hs
View File

@ -61,7 +61,7 @@ courseFavouriteToggleForm currentReason html
-- Will never return FavouriteCurrent -- Will never return FavouriteCurrent
-- Nothing if no entry for current user (e.g. not logged in) -- Nothing if no entry for current user (e.g. not logged in)
storedFavouriteReason :: (MonadIO m) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX) storedFavouriteReason :: (MonadIO m) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX)
-> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool, Bool)) -> ReaderT SqlBackend m (Maybe (Maybe FavouriteReason, Bool))
storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
@ -72,36 +72,13 @@ storedFavouriteReason tid ssh csh muid = fmap unValueFirst . E.select . E.from $
let isBlacklist = E.exists . E.from $ \courseNoFavourite -> let isBlacklist = E.exists . E.from $ \courseNoFavourite ->
E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
isParticipant = E.exists . E.from $ \participant -> reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool))
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist)
E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid)
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
isLecturer = E.exists . E.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid)
isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do
E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid)
isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
reason :: (E.SqlExpr (E.Value (Maybe FavouriteReason)), E.SqlExpr (E.Value Bool), E.SqlExpr (E.Value Bool))
reason = (courseFavourite E.?. CourseFavouriteReason, isBlacklist, isAssociated)
{-
reason :: E.SqlExpr (E.Value (Maybe FavouriteReason))
reason = E.case_
[ E.when_ isBlacklist E.then_ E.nothing,
E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
] (E.else_ . E.just $ E.coalesceDefault [courseFavourite E.?. CourseFavouriteReason] (E.val FavouriteVisited))
-}
pure reason pure reason
where where
unValueFirst :: [(E.Value (Maybe a), E.Value Bool, E.Value Bool)] -> Maybe (Maybe a, Bool, Bool) unValueFirst :: [(E.Value (Maybe a), E.Value Bool)] -> Maybe (Maybe a, Bool)
-- `over each E.unValue` doesn't work here, since E.unValue is monomorphised -- `over each E.unValue` doesn't work here, since E.unValue is monomorphised
unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue . over _3 E.unValue) . listToMaybe unValueFirst = fmap (over _1 E.unValue . over _2 E.unValue) . listToMaybe
-- TODO add toggle Manual favorite Icon here -- TODO add toggle Manual favorite Icon here
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -342,12 +319,11 @@ getCShowR tid ssh csh = do
mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
let favouriteReason = case favouriteReason' of let favouriteReason = case favouriteReason' of
-- (reason, blacklist, associated) -- (reason, blacklist)
(Just (_reason, _blacklist, True)) -> Just FavouriteParticipant (Just (_reason, True)) -> Nothing
(Just (_reason, True, False)) -> Nothing (Just (Just reason, False)) -> Just reason
(Just (Just reason, False, False)) -> Just reason (Just (Nothing, False)) -> Just FavouriteCurrent
(Just (Nothing, False, False)) -> Just FavouriteCurrent Nothing -> Just FavouriteCurrent
Nothing -> Just FavouriteCurrent
favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason
let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) ->
wrapForm favouriteToggleView def wrapForm favouriteToggleView def