From ec027675525b30198378745ed281f60a42471807 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 2 Aug 2024 15:40:25 +0200 Subject: [PATCH] fix(course): fix #150 no longer allow duplicated associated qualifications and orders due to editing existing --- .../courses/courses/de-de-formal.msg | 1 + .../categories/courses/courses/en-eu.msg | 1 + src/Handler/Course/Edit.hs | 20 +++++++++++++------ src/Utils.hs | 20 +++++++++++++++++++ 4 files changed, 36 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index 53cc9d2d9..e0c589aba 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -73,6 +73,7 @@ CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kursart #{tid}-# 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. CourseEditQualificationFailExists: Diese Qualifikation ist bereits assoziert +CourseEditQualificationFailOrder: Diese Sortierpriorität existiert bereits 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 ed44433f7..9f7835095 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -73,6 +73,7 @@ CourseEditDupShort tid ssh csh: Could not edit course type #{tid}-#{ssh}-#{csh}. 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}. CourseEditQualificationFailExists: This qualification is already associated +CourseEditQualificationFailOrder: This sort order priority is used already CourseLecturer: Course administrator MailSubjectParticipantInvitation tid ssh csh: [#{tid}-#{ssh}-#{csh}] Invitaion to join the course CourseParticipantInviteHeading courseName: Invitation to enrol for #{courseName} diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 007276923..6c0c7e851 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -177,12 +177,16 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([(QualificationId,Int)] -> FormResult [(QualificationId,Int)]) miAdd nudge submitView csrf = do (formRes, formView) <- aCourseQualiForm nudge Nothing csrf - let addRes = formRes <&> \newDat (Set.fromList -> oldDat) -> if - | newDat `Set.member` oldDat -> FormFailure [mr MsgCourseEditQualificationFailExists] - | otherwise -> FormSuccess $ pure newDat + let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) -> + let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists] + ordBad = guardMonoid (oldOrd `elem` oldOrds) [mr MsgCourseEditQualificationFailOrder ] + problems = qidBad ++ ordBad + in if null problems + then FormSuccess $ pure newDat + else FormFailure problems return (addRes, $(widgetFile "widgets/massinput/courseQualifications/add")) - miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId,Int) + miEdit :: (Text -> Text) -> (QualificationId, Int) -> Form (QualificationId, Int) miEdit nudge = aCourseQualiForm nudge . Just miLayout :: MassInputLayout ListLength (QualificationId,Int) (QualificationId, Int) @@ -259,6 +263,10 @@ validateCourse = do unless userAdmin $ do guardValidation MsgCourseUserMustBeLecturer $ anyOf (traverse . _Right . _1) (== uid) cfLecturers + guardValidation MsgCourseEditQualificationFailExists + $ not $ hasDuplicates $ fst <$> cfQualis + guardValidation MsgCourseEditQualificationFailOrder + $ not $ hasDuplicates $ snd <$> cfQualis warnValidation MsgCourseShorthandTooLong $ length (CI.original cfShort) <= 10 @@ -460,10 +468,10 @@ courseEditHandler miButtonAction mbCourseForm = do 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))) + oldQualis <- Map.fromList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder))) <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification] -- 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) + okSchools <- Set.fromList . fmap (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool] {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition: $logErrorS "CourseQuali" $ "OLD Course Qualifications:" <> tshow oldQualis diff --git a/src/Utils.hs b/src/Utils.hs index f16b0aa14..ac3027992 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1447,6 +1447,26 @@ anyone :: (Foldable t, Alternative f) => t a -> f a anyone = Fold.foldr ((<|>).pure) empty + +-- returns true, if the foldable contains an element twice +hasDuplicates :: (Foldable t, Ord a) => t a -> Bool +hasDuplicates = fst . Fold.foldl' aux (False, mempty) + where + aux r@(True , _) _ = r + aux (False, xs) x + | x `Set.member` xs = (True , xs) + | otherwise = (False, Set.insert x xs) + +{- +-- | like `hasDuplicates` but terminates on infinte lists that contain duplicates +hasDuplicates' :: Ord a => [a] -> Bool +hasDuplicates' = aux mempty + where + aux _ [] = False + aux seen (x:xs) = Set.member x seen || aux (Set.insert x seen) xs +-} + + ------------ -- Writer -- ------------