refactor(participants-intersect): do intersect in haskell not sql

messages/uniworx/misc/de-de-formal.msg

@@ -2849,7 +2849,7 @@ InfoLecturerTutorials: Tutorien
 InfoLecturerExams: Prüfungen
 InfoLecturerAllocations: Zentralanmeldungen
 
-ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
+ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId csh@CourseShorthand coursen@CourseName: #{tid} - #{ssh} - #{csh}: #{coursen}
 ParticipantsIntersectCourses: Kurse
 
 AllocationUsersTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Bewerber
@@ -2941,7 +2941,7 @@ AllocationUsersCount: Teilnehmer
 AllocationCoursesCount: Kurse
 AllocationCourseEligible: Berücksichtigt
 
-CourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
+CourseOption tid@TermId ssh@SchoolId csh@CourseShorthand coursen@CourseName: #{tid} - #{ssh} - #{csh}: #{coursen}
 
 BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
 BearerTokenAuthorityGroups: Token-Authorität (Gruppen)

messages/uniworx/misc/en-eu.msg

@@ -2849,7 +2849,7 @@ InfoLecturerTutorials: Tutorials
 InfoLecturerExams: Exams
 InfoLecturerAllocations: Central allocations
 
-ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
+ParticipantsIntersectCourseOption tid ssh csh coursen: #{tid} - #{ssh} - #{csh}: #{coursen}
 ParticipantsIntersectCourses: Courses
 
 AllocationUsersTitle tid ssh ash: #{tid}-#{ssh}-#{ash}: Applicants
@@ -2941,7 +2941,7 @@ AllocationUsersCount: Participants
 AllocationCoursesCount: Courses
 AllocationCourseEligible: Considered
 
-CourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen}
+CourseOption tid ssh csh coursen: #{tid} - #{ssh} - #{csh}: #{coursen}
 
 BearerTokenUsageWarning: Using this interface you are able to encode essentially arbitrary permissions inte bearer tokens. This allows you to freely hand permissions off arbitrarily and without relevant restrictions. Only use this interface if you have discussed the consequences of the specific token, that you want to issue, with an experienced developer!
 BearerTokenAuthorityGroups: Authority (groups)

src/Handler/Participants.hs

@@ -96,23 +96,21 @@ postParticipantsIntersectR = do
         }
 
   intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \cids -> runDB $ do
-    let coursePairs = do
-          cid <- Set.toList cids
-          other <- Set.toList . snd $ Set.split cid cids
-          return (cid, other)
-    intersections <- fmap Map.fromList . forM coursePairs $ \cidPair@(lCid, uCid) -> fmap (\[E.Value n] -> (cidPair, n)) . E.select . E.from $ \user -> do
-      E.where_ . E.exists . E.from $ \courseParticipant ->
-        E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
-             E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val lCid
-             E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
-      E.where_ . E.exists . E.from $ \courseParticipant ->
-        E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
-             E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val uCid
-             E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
-      return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
-    selfIntersections <- fmap Map.fromList . forM (Set.toList cids) $ \cid -> ((cid, cid), ) <$> count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
-    let intersections' = Map.union intersections selfIntersections
+    courseUsers <- flip mapFromSetM cids $ \cid -> fmap (Set.fromList . map E.unValue) . E.select . E.from $ \participant -> do
+      E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
+           E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+      return $ participant E.^. CourseParticipantUser
     courses <- sortOn (view $ _entityVal . $(multifocusL 3) _courseTerm _courseSchool _courseShorthand) <$> forM (Set.toList cids) getEntity404
+
+    let coursePairs = Set.fromAscList $ do
+          cid <- Set.toAscList cids
+          other <- Set.toAscList . snd $ Set.split cid cids
+          return (cid, other)
+        intersections = flip Map.fromSet coursePairs $ \(lCid, uCid)
+          -> Set.size $ Map.findWithDefault Set.empty lCid courseUsers `Set.intersection` Map.findWithDefault Set.empty uCid courseUsers
+        selfIntersections = Map.mapKeysMonotonic (\cid -> (cid, cid)) $ Set.size <$> courseUsers
+        intersections' = Map.union intersections selfIntersections
+
     return (courses, intersections')
 
   let

src/Handler/Utils/Form.hs

@@ -2098,12 +2098,13 @@ courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired m
       course <- query
       E.orderBy [ E.desc $ course E.^. CourseTerm
                 , E.asc $ course E.^. CourseSchool
+                , E.asc $ course E.^. CourseShorthand
                 , E.asc $ course E.^. CourseName
                 ]
       return course
 
     miAdd' nudge btn csrf = do
-      let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions
+      let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseShorthand courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions
 
       (courseRes, addView) <- mpopt (hoistField liftHandler $ selectField courseOptions) (fslI MsgCourse & addName (nudge "course")) Nothing
       let res = courseRes <&> \newCourse oldCourses -> pure (Set.toList $ Set.singleton newCourse `Set.difference` Set.fromList oldCourses)

src/Handler/Workflow/Instance/Form.hs

@@ -39,7 +39,7 @@ workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $
         , WSCourse <$> apopt (selectField' Nothing courseOptions) (fslI MsgCourse) (mPrev ^? _Just . _wisCourse)
         )
       ]
-      where courseOptions = fmap (fmap entityKey) . optionsPersistCryptoId [] [ Desc CourseTerm, Asc CourseSchool, Asc CourseName ] $ \Course{..} -> MsgCourseOption courseTerm courseSchool courseName
+      where courseOptions = fmap (fmap entityKey) . optionsPersistCryptoId [] [ Desc CourseTerm, Asc CourseSchool, Asc CourseName ] $ \Course{..} -> MsgCourseOption courseTerm courseSchool courseShorthand courseName
 
 
 data WorkflowInstanceForm = WorkflowInstanceForm

templates/widgets/massinput/courses/add.hamlet

@@ -1,5 +1,5 @@
 $newline never
-<td colspan=3>
+<td colspan=4>
   #{csrf}
   ^{fvWidget addView}
 <td>

templates/widgets/massinput/courses/cell.hamlet

@@ -3,5 +3,7 @@ $newline never
   #{courseTerm}
 <td>
   #{courseSchool}
+<td>
+  #{courseShorthand}
 <td>
   #{courseName}