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

chore: lookup current favourite reason in DB

Browse Source
This commit is contained in:
Wolfgang Witt 2021-04-01 14:29:55 +02:00 committed by Gregor Kleen
parent e23a5a64cc
commit f0ddd680d1
2 changed files with 87 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
src/Handler/Course.hs
View File

@ -6,6 +6,8 @@ module Handler.Course
import Import 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.Communication as Handler.Course
import Handler.Course.Delete 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 :: TermId -> SchoolId -> CourseShorthand -> Handler ()
postCFavouriteR tid ssh csh = do postCFavouriteR tid ssh csh = do
muid <- maybeAuthPair
-- TODO swap FavouriteReason here -- 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? -- TODO participants can't remove favourite?
liftIO $ do liftIO $ do
putStrLn "\nswapping FavouriteReason" putStrLn "\nswapping FavouriteReason"

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

@ -62,8 +62,9 @@ courseFavouriteToggleForm currentReason html
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
muid <- maybeAuthPair
now <- liftIO getCurrentTime 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)] [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
<- lift . E.select . E.from $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -166,7 +167,43 @@ getCShowR tid ssh csh = do
return $ material E.^. MaterialName return $ material E.^. MaterialName
mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR 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 let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
mDereg <- traverse (formatTime SelFormatDateTime) mDereg' mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
@ -292,7 +329,12 @@ getCShowR tid ssh csh = do
mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR
mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR 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) -> let favouriteToggleWgt = favouriteToggleRes & \((_, favouriteToggleView), favouriteToggleEncoding) ->
wrapForm favouriteToggleView def wrapForm favouriteToggleView def
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR { formAction = Just . SomeRoute $ CourseR tid ssh csh CFavouriteR