From 5b6e4e60e7d2957fbce93ee2e2d6d3464b4e3db7 Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 1 Aug 2024 11:41:27 +0200 Subject: [PATCH] fix(course): fix #150 course edit for associated qualifications requires school admin or lecturer rights --- .../courses/courses/de-de-formal.msg | 2 + .../categories/courses/courses/en-eu.msg | 4 +- src/Handler/Course/Edit.hs | 122 +++++++++++------- src/Utils.hs | 8 +- 4 files changed, 86 insertions(+), 50 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index d8faf2d87..e1e39aa94 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -70,6 +70,8 @@ CourseInvalidInput: Eingaben bitte korrigieren. CourseEditTitle: Kursart editieren/anlegen CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} wurde erfolgreich geändert. CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-#{ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen andere Kursart mit dem selben Kürzel oder Titel in diesem Jahr und Bereich. +CourseEditQualificationFail: Eine Qualifikation konnte uas unbekanntem Grund nicht mit diesem Kurs assoziert werden. +CourseEditQualificationFailRights qsh@QualificationShorthand ssh@SchoolId: Qualifikation #{qsh} konnte nicht mit diesem Kurs assoziert werden, da Ihre Berechtigungen für Bereich #{ssh} dazu nicht ausreichen. CourseLecturer: Kursverwalter:in MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Einladung zur Kursartteilnahme CourseParticipantInviteHeading courseName@Text: Einladung zum Kursartteilnahmer für #{courseName} diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index 9f14a46a7..43ea7c45e 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -70,8 +70,10 @@ CourseInvalidInput: Invalid input CourseEditTitle: Edit/Create course CourseEditOk tid ssh csh: Successfully edited course type #{tid}-#{ssh}-#{csh} CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. Another course type with the same shorthand or title already exists for the given year and school. +CourseEditQualificationFail: A qualifikation could not be associated with this course for unknown reasons. +CourseEditQualificationFailRights qsh ssh: Qualification #{qsh} could not be associated with this course, due to your insufficient rights for department #{ssh}. CourseLecturer: Course administrator -MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course +MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName} CourseParticipantInviteExplanation: You were invited to be a participant of a course. CourseParticipantInviteField: Email addresses to invite diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 509a8d261..bfec8a864 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -106,51 +106,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB -> return (termsSetField [cfTerm cform], [cfTerm cform]) _allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms - let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) - miAdd _ _ _ nudge btn = Just $ \csrf -> do - (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing - let addRes'' = addRes <&> \newDat oldDat -> if - | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat) - , not $ Set.null existing - -> FormFailure [mr MsgCourseLecturerAlreadyAdded] - | otherwise - -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat - addView' = $(widgetFile "course/lecturerMassInput/add") - return (addRes'', addView') - - miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) - miCell _ (Right lid) defType nudge = \csrf -> do - (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType) - usr <- liftHandler . runDB $ get404 lid - let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") - return (Just <$> lrwRes,lrwView') - miCell _ (Left lEmail) defType nudge = \csrf -> do - (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType - invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning - let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") - return (lrwRes,lrwView') - - miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape - -> ListPosition -- ^ Coordinate to delete - -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) - miDelete = miDeleteList - - miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition - miAddEmpty _ _ _ = Set.empty - - miLayout :: ListLength - -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state - -> Map ListPosition Widget -- ^ Cell widgets - -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons - -> Map (Natural, ListPosition) Widget -- ^ Addition widgets - -> Widget - miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout") - - miIdent :: Text - miIdent = "lecturers" - - - lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] + let lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput MassInput{..} (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical) @@ -167,6 +123,50 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB unliftEither (Right (lid , lType )) = (Right lid , Just lType) unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType ) + miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) + miAdd _ _ _ nudge btn = Just $ \csrf -> do + (addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing + let addRes'' = addRes <&> \newDat oldDat -> if + | existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat) + , not $ Set.null existing + -> FormFailure [mr MsgCourseLecturerAlreadyAdded] + | otherwise + -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat + addView' = $(widgetFile "course/lecturerMassInput/add") + return (addRes'', addView') + + miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) + miCell _ (Right lid) defType nudge = \csrf -> do + (lrwRes,lrwView) <- mreq (selectField optionsFinite) (fslI MsgCourseLecturerType & addName (nudge "lecturer-type")) (join defType) + usr <- liftHandler . runDB $ get404 lid + let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") + return (Just <$> lrwRes,lrwView') + miCell _ (Left lEmail) defType nudge = \csrf -> do + (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType + invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning + let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") + return (lrwRes,lrwView') + + miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape + -> ListPosition -- ^ Coordinate to delete + -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) + miDelete = miDeleteList + + miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition + miAddEmpty _ _ _ = Set.empty + + miLayout :: ListLength + -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state + -> Map ListPosition Widget -- ^ Cell widgets + -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons + -> Map (Natural, ListPosition) Widget -- ^ Addition widgets + -> Widget + miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout") + + miIdent :: Text + miIdent = "lecturers" + + (newVisFrom,newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing) _allIOtherCases -> do @@ -366,6 +366,7 @@ courseEditHandler miButtonAction mbCourseForm = do let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites + void $ upsertCourseQualifications aid cid $ cfQualis res insert_ $ CourseEdit aid now cid memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) return insertOkay @@ -414,11 +415,9 @@ courseEditHandler miButtonAction mbCourseForm = do let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites - + void $ upsertCourseQualifications aid cid $ cfQualis res insert_ $ CourseEdit aid now cid - memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId) - addMessageI Success $ MsgCourseEditOk tid ssh csh return True when success $ redirect $ CourseR tid ssh csh CShowR @@ -429,3 +428,30 @@ courseEditHandler miButtonAction mbCourseForm = do { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } + +-- upsertCourseQualifications :: forall m backend . (MonadIO m, PersistStoreWrite backend, PersistQueryRead backend) => UserId -> CourseId -> [(QualificationId, Int)] -> ReaderT backend m Bool +upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] -> YesodJobDB UniWorX Bool -- could be generalized +upsertCourseQualifications uid cid qualis = do + let newQualis = Map.fromList qualis + oldQualis <- Map.fromDistinctAscList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) + <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationSortOrder] + -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150 + okSchools <- Set.fromDistinctAscList . fmap (userFunctionSchool . entityVal) + <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool] + foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of + Just so_new | so_new /= so_old + -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association + Nothing -> delete k -- existing CourseQualifications may be removed, regardless of school association + _ -> return () + res <- foldWithKeyMapM (newQualis Map.\\ oldQualis) $ \qu so -> get qu >>= \case + Just Qualification{qualificationSchool=ssh, qualificationShorthand=qsh} + | Set.member ssh okSchools -> + insert_ CourseQualification{courseQualificationQualification = qu, courseQualificationCourse = cid, courseQualificationSortOrder = so} + $> All True + | otherwise -> do + addMessageI Warning $ MsgCourseEditQualificationFailRights qsh ssh + pure $ All False + _ -> do + addMessageI Warning MsgCourseEditQualificationFail + pure $ All False + pure $ getAll res diff --git a/src/Utils.hs b/src/Utils.hs index 4d6113ba0..f16b0aa14 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -879,6 +879,12 @@ mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . _MapUnit :: Iso' (Map k ()) (Set k) _MapUnit = iso Map.keysSet $ Map.fromSet (const ()) +foldMapWithKeyM :: (Monad m, Monoid o) => (k -> a -> m o) -> Map k a -> m o +foldMapWithKeyM act = foldMapM (uncurry act) . Map.toAscList + +foldWithKeyMapM :: (Monad m, Monoid o) => Map k a -> (k -> a -> m o) -> m o +foldWithKeyMapM = flip foldMapWithKeyM + --------------- -- Functions -- --------------- @@ -1305,7 +1311,7 @@ ofoldl1M _ _ = error "otoList of NonNull is empty" foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b foldMapM f = foldrM (\x xs -> (<> xs) <$> f x) mempty -{- left as a remineder: if you need these, use MaybeT instead! +{- left as a reminder: if you need these below, rather use MaybeT instead! -- convenient synonym for `flip foldMapM` continueJust :: (Applicative m, Monoid b) => Maybe a -> (a -> m b) -> m b continueJust (Just x) f = f x