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

refactor: use the same function to lookup storedFavouriteReason

Browse Source
This commit is contained in:
Wolfgang Witt 2021-04-02 09:10:31 +02:00 committed by Gregor Kleen
parent f0ddd680d1
commit 0605e940c6
2 changed files with 45 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
src/Handler/Course.hs
View File

@ -43,38 +43,7 @@ postCFavouriteR tid ssh csh = do
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
currentReason <- storedFavouriteReason tid ssh csh muid
-- TODO change stored reason in DB
-- TODO participants can't remove favourite (only toggle between automatic/manual)?
pure ()

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

@ -3,6 +3,7 @@
module Handler.Course.Show
( getCShowR
, getCRegisterTemplateR, courseRegisterTemplateSource
, storedFavouriteReason
) where
import Import
@ -58,13 +59,54 @@ courseFavouriteToggleForm currentReason html
(Just FavouriteManual) -> BtnCourseFavouriteToggleManual
(Just FavouriteCurrent) -> BtnCourseFavouriteToggleAutomatic
-- Nothing means blacklist
-- Will never return FavouriteCurrent
storedFavouriteReason :: (MonadIO m) => TermId -> SchoolId -> CourseShorthand -> Maybe (AuthId UniWorX, AuthEntity UniWorX)
-> ReaderT SqlBackend m (Maybe FavouriteReason)
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.&&. 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.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
where
unValueFirst :: [E.Value (Maybe a)] -> Maybe a
unValueFirst = join . fmap E.unValue . listToMaybe
-- TODO add toggle Manual favorite Icon here
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), favouriteReason') <- 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
@ -168,40 +210,7 @@ getCShowR tid ssh csh = do
mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
-- 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
favouriteReason <- lift $ storedFavouriteReason tid ssh csh muid
return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial), favouriteReason)
@ -329,11 +338,6 @@ getCShowR tid ssh csh = do
mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR
mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
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