chore: lookup current favourite reason in DB
This commit is contained in:
Wolfgang Witt
Gregor Kleen
parent
e23a5a64cc
commit
f0ddd680d1
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user