fix(course): fix #150 course edit for associated qualifications requires school admin or lecturer rights
This commit is contained in:
parent
bc47387c91
commit
5b6e4e60e7
@ -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}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user