From f0ddd680d169b3252eccd48be12c51ab997ef244 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Thu, 1 Apr 2021 14:29:55 +0200 Subject: [PATCH] chore: lookup current favourite reason in DB --- src/Handler/Course.hs | 42 +++++++++++++++++++++++++++++++++ src/Handler/Course/Show.hs | 48 +++++++++++++++++++++++++++++++++++--- 2 files changed, 87 insertions(+), 3 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 051875618..c6655dc36 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -6,6 +6,8 @@ module Handler.Course import Import +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Handler.Course.Communication as Handler.Course import Handler.Course.Delete as Handler.Course @@ -36,7 +38,47 @@ postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this cou postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () postCFavouriteR tid ssh csh = do + muid <- maybeAuthPair -- TODO swap FavouriteReason here + runDB $ do + -- Nothing means blacklist + -- should never return FavouriteCurrent + currentReason <- withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse + E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.limit 1 -- we know that there is at most one match, but we tell the DB this info too + let isBlacklist = E.exists . E.from $ \courseNoFavourite -> + E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) + E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId + isParticipant = E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + 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.case_ + [ E.when_ isBlacklist E.then_ E.nothing, + E.when_ isAssociated E.then_ . E.just . E.val $ Just FavouriteParticipant + ] (E.else_ . E.just $ courseFavourite E.?. CourseFavouriteReason) + pure reason + -- TODO change stored reason in DB + -- TODO participants can't remove favourite (only toggle between automatic/manual)? + pure () + -- TODO participants can't remove favourite? liftIO $ do putStrLn "\nswapping FavouriteReason" diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 6d25eed48..74feea6a3 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -62,8 +62,9 @@ courseFavouriteToggleForm currentReason html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId + muid <- maybeAuthPair now <- liftIO getCurrentTime - (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do + (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason') <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -166,7 +167,43 @@ getCShowR tid ssh csh = do return $ material E.^. MaterialName mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR - return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) + + -- Nothing means blacklist + -- inner maybe is reason stored in database + favouriteReason <- lift . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse + E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.limit 1 -- we know that there is at most one match, but we tell the DB this info too + let isBlacklist = E.exists . E.from $ \courseNoFavourite -> + E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) + E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId + isParticipant = E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + 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.case_ + [ E.when_ isBlacklist E.then_ E.nothing, + E.when_ isAssociated E.then_ . E.just . E.val $ Just FavouriteParticipant + ] (E.else_ . E.just $ courseFavourite E.?. CourseFavouriteReason) + pure reason + + return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason) let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) mDereg' @@ -292,7 +329,12 @@ getCShowR tid ssh csh = do mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR - favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm $ Just FavouriteVisited + let favouriteReason = case favouriteReason' of + [E.Value Nothing] -> Nothing + [E.Value (Just (Just reason))] -> Just reason + -- should only be [E.Value (Just Nothing)] + _otherwise -> Just FavouriteVisited + favouriteToggleRes <- runFormPost $ courseFavouriteToggleForm favouriteReason let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) -> wrapForm favouriteToggleView def { formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR