fix(course): fix #150 no longer allow duplicated associated qualifications and orders due to editing existing

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}

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}

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
+              let addRes = formRes <&> \newDat@(newQid,oldOrd) (unzip -> (oldQids,oldOrds)) ->
-                    | newDat `Set.member` oldDat -> FormFailure [mr MsgCourseEditQualificationFailExists]
+                    let qidBad = guardMonoid (newQid `elem` oldQids) [mr MsgCourseEditQualificationFailExists]
-                    | otherwise -> FormSuccess $ pure newDat
+                        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

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 --
 ------------