feat: participants intersection

frontend/src/app.sass

@@ -1175,3 +1175,8 @@ a.breadcrumbs__home
   .checkbox
     display: inline-block
     margin-left: 7px
+
+.text--right
+  text-align: right
+.text--center
+  text-align: center

messages/uniworx/de-de-formal.msg

@@ -1210,6 +1210,7 @@ MenuExternalExamEdit: Bearbeiten
 MenuExternalExamNew: Neue externe Prüfung
 MenuExternalExamList: Externe Prüfungen
 MenuParticipantsList: Kursteilnehmerlisten
+MenuParticipantsIntersect: Überschneidung von Kursteilnehmern
 
 BreadcrumbSubmissionFile: Datei
 BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
@@ -2333,4 +2334,7 @@ InfoLecturerCourses: Veranstaltungen
 InfoLecturerExercises: Übungsbetrieb
 InfoLecturerTutorials: Tutorien
 InfoLecturerExams: Prüfungen
-InfoLecturerAllocations: Zentralanmeldungen
+InfoLecturerAllocations: Zentralanmeldungen
+
+ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
+ParticipantsIntersectCourses: Kurse

messages/uniworx/en-eu.msg

@@ -1209,6 +1209,7 @@ MenuExternalExamEdit: Edit
 MenuExternalExamNew: New external exam
 MenuExternalExamList: External exams
 MenuParticipantsList: Lists of course participants
+MenuParticipantsIntersect: Common course participants
 
 BreadcrumbSubmissionFile: File
 BreadcrumbSubmissionUserInvite: Invitation to participate in a submission
@@ -2333,4 +2334,7 @@ InfoLecturerCourses: Courses
 InfoLecturerExercises: Course Exercises
 InfoLecturerTutorials: Tutorials
 InfoLecturerExams: Exams
-InfoLecturerAllocations: Central allocations
+InfoLecturerAllocations: Central allocations
+
+ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen}
+ParticipantsIntersectCourses: Courses

routes

@@ -111,6 +111,7 @@
 
 /participants                   ParticipantsListR GET            !evaluation
 /participants/#TermId/#SchoolId ParticipantsR     GET            !evaluation
+/participants/intersect         ParticipantsIntersectR GET POST  !evaluation
 
 
 -- For Pattern Synonyms see Foundation

src/Foundation.hs

@@ -2028,8 +2028,9 @@ instance YesodBreadcrumbs UniWorX where
       MaybeT $ get cid
     return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR)
 
-  breadcrumb ParticipantsListR   = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
+  breadcrumb ParticipantsListR      = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
-  breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants     $ Just ParticipantsListR
+  breadcrumb (ParticipantsR _ _)    = i18nCrumb MsgBreadcrumbParticipants     $ Just ParticipantsListR
+  breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect  $ Just ParticipantsListR
 
   breadcrumb  CourseListR                 = i18nCrumb MsgMenuCourseList   Nothing
   breadcrumb  CourseNewR                  = i18nCrumb MsgMenuCourseNew  $ Just CourseListR
@@ -2968,30 +2969,32 @@ pageActions ProfileR = return
     , navChildren = []
     }
   ]
-pageActions TermShowR = return
+pageActions TermShowR = do
-  [ NavPageActionPrimary
+  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
-    { navLink = NavLink
+  return
-      { navLabel       = MsgMenuTermCreate
+    [ NavPageActionPrimary
-      , navRoute       = TermEditR
+      { navLink = NavLink
-      , navAccess'     = return True
+        { navLabel       = MsgMenuTermCreate
-      , navType        = NavTypeLink { navModal = False }
+        , navRoute       = TermEditR
-      , navQuick'      = mempty
+        , navAccess'     = return True
-      , navForceActive = False
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
       }
-    , navChildren = []
+    , NavPageActionPrimary
-    }
+      { navLink = NavLink
-  , NavPageActionPrimary
+        { navLabel       = MsgMenuParticipantsList
-    { navLink = NavLink
+        , navRoute       = ParticipantsListR
-      { navLabel       = MsgMenuParticipantsList
+        , navAccess'     = return True
-      , navRoute       = ParticipantsListR
+        , navType        = NavTypeLink { navModal = False }
-      , navAccess'     = return True
+        , navQuick'      = mempty
-      , navType        = NavTypeLink { navModal = False }
+        , navForceActive = False
-      , navQuick'      = mempty
+        }
-      , navForceActive = False
+      , navChildren = participantsSecondary
       }
-    , navChildren = []
+    ]
-    }
-  ]
 pageActions (AllocationR _tid _ssh _ash AShowR) = return
   [ NavPageActionPrimary
     { navLink = NavLink
@@ -3005,41 +3008,43 @@ pageActions (AllocationR _tid _ssh _ash AShowR) = return
     , navChildren = []
     }
   ]  
-pageActions CourseListR = return
+pageActions CourseListR = do
-  [ NavPageActionPrimary
+  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
-    { navLink = NavLink
+  return
-      { navLabel       = MsgMenuCourseNew
+    [ NavPageActionPrimary
-      , navRoute       = CourseNewR
+      { navLink = NavLink
-      , navAccess'     = return True
+        { navLabel       = MsgMenuCourseNew
-      , navType        = NavTypeLink { navModal = False }
+        , navRoute       = CourseNewR
-      , navQuick'      = mempty
+        , navAccess'     = return True
-      , navForceActive = False
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
       }
-    , navChildren = []
+    , NavPageActionPrimary
-    }
+      { navLink = NavLink
-  , NavPageActionPrimary
+        { navLabel       = MsgMenuAllocationList
-    { navLink = NavLink
+        , navRoute       = AllocationListR
-      { navLabel       = MsgMenuAllocationList
+        , navAccess'     = return True
-      , navRoute       = AllocationListR
+        , navType        = NavTypeLink { navModal = False }
-      , navAccess'     = return True
+        , navQuick'      = mempty
-      , navType        = NavTypeLink { navModal = False }
+        , navForceActive = False
-      , navQuick'      = mempty
+        }
-      , navForceActive = False
+      , navChildren = []
       }
-    , navChildren = []
+    , NavPageActionPrimary
-    }
+      { navLink = NavLink
-  , NavPageActionPrimary
+        { navLabel       = MsgMenuParticipantsList
-    { navLink = NavLink
+        , navRoute       = ParticipantsListR
-      { navLabel       = MsgMenuParticipantsList
+        , navAccess'     = return True
-      , navRoute       = ParticipantsListR
+        , navType        = NavTypeLink { navModal = False }
-      , navAccess'     = return True
+        , navQuick'      = mempty
-      , navType        = NavTypeLink { navModal = False }
+        , navForceActive = False
-      , navQuick'      = mempty
+        }
-      , navForceActive = False
+      , navChildren = participantsSecondary
       }
-    , navChildren = []
+    ] 
-    }
-  ] 
 pageActions CourseNewR = return
   [ NavPageActionPrimary
     { navLink = NavLink
@@ -3813,6 +3818,18 @@ pageActions ParticipantsListR = return
         }
       , navChildren = []
       }
+
+  , NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuParticipantsIntersect
+      , navRoute       = ParticipantsIntersectR
+      , navAccess'     = return True
+      , navType        = NavTypeLink { navModal = False}
+      , navQuick'      = navQuick NavQuickViewPageActionSecondary
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
   ]
 pageActions _ = return []
 

src/Handler/Participants.hs

@@ -2,22 +2,27 @@
 module Handler.Participants
   ( getParticipantsListR
   , getParticipantsR
+  , getParticipantsIntersectR, postParticipantsIntersectR
   ) where
 
 import Import
+import Handler.Utils
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
+import qualified Data.Map as Map
 import qualified Data.Set as Set
+import Data.Map ((!), (!?))
 
 import Handler.Utils.Csv
-import Handler.Utils.ContentDisposition
 
 import qualified Data.Csv as Csv
 
 import qualified Data.Conduit.List as C
 
+import qualified Data.List as List
+
 
 data ParticipantEntry = ParticipantEntry
   { peCourse :: CourseName
@@ -77,3 +82,71 @@ getParticipantsR tid ssh = do
       return (course E.^. CourseName, user E.^. UserEmail)
 
     toParticipantEntry (E.Value peCourse, E.Value peEmail) = ParticipantEntry{..}
+
+getParticipantsIntersectR, postParticipantsIntersectR :: Handler Html
+getParticipantsIntersectR = postParticipantsIntersectR
+postParticipantsIntersectR = do
+  let
+    miAdd' nudge btn csrf = do
+      let
+        courseOptions = optionsPersistCryptoId [] [Desc CourseTerm, Asc CourseSchool, Asc CourseName] (\Course{..} -> MsgParticipantsIntersectCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey) . filterCourseOptions
+        filterCourseOptions = fmap mkOptionList . filterCourseOptions' . olOptions
+          where
+            filterCourseOptions' opts = do
+              let termSchools = List.nub [ optionInternalValue ^. _entityVal . $(multifocusL 2) _courseTerm _courseSchool | Option{..} <- opts ]
+              termSchools' <- Set.fromList <$> filterM (\(tid, ssh) -> hasReadAccessTo $ ParticipantsR tid ssh) termSchools
+              return $ opts
+                & filter (\Option{ optionInternalValue = Entity _ Course{..} } -> (courseTerm, courseSchool) `Set.member` termSchools')
+      (courseRes, addView) <- mpopt (selectField courseOptions) (fslI MsgCourse & addName (nudge "course")) Nothing
+      let res = courseRes <&> \newCourse oldCourses -> pure (Set.toList $ Set.singleton newCourse `Set.difference` Set.fromList oldCourses)
+      return (res, $(widgetFile "widgets/massinput/participants-intersect/add"))
+    miCell' cid = do
+      Course{..} <- liftHandler . runDB $ get404 cid
+      $(widgetFile "widgets/massinput/participants-intersect/cell")
+    miButtonAction' _ = Nothing
+    miLayout' :: MassInputLayout ListLength CourseId ()
+    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/participants-intersect/layout")
+    miIdent' :: Text
+    miIdent' = "participants-intersect"
+    fSettings =  fslI MsgParticipantsIntersectCourses
+    fRequired = False
+    mPrev = Nothing
+  ((coursesRes, coursesView), coursesEnc) <- runFormPost . renderAForm FormStandard $ massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
+  let formWidget = wrapForm coursesView def
+        { formAction = Just . SomeRoute $ ParticipantsIntersectR :#: ("table" :: Text)
+        , formEncoding = coursesEnc
+        }
+
+  intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \(Set.fromList -> 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.where_ . E.exists . E.from $ \courseParticipant ->
+        E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
+             E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val uCid
+      return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
+    selfIntersections <- fmap Map.fromList . forM (Set.toList cids) $ \cid -> ((cid, cid), ) <$> count [CourseParticipantCourse ==. cid]
+    let intersections' = Map.union intersections selfIntersections
+    courses <- sortOn (view $ _entityVal . $(multifocusL 3) _courseTerm _courseSchool _courseShorthand) <$> forM (Set.toList cids) getEntity404
+    return (courses, intersections')
+
+  let
+    symmIntersection intersections lCid uCid = fromMaybe 0 $ intersections !? (lCid, uCid) <|> intersections !? (uCid, lCid)
+    intersectionHotness :: _ -> _ -> _ -> Centi
+    intersectionHotness intersections lCid uCid
+      | sumSize == 0 = 0
+      | otherwise    = realToFrac . max 0 . min 1 $ 2 * intersectSize % sumSize
+      where
+        sumSize = intersections ! (lCid, lCid) + intersections ! (uCid, uCid)
+        intersectSize = symmIntersection intersections lCid uCid
+
+    lIxed = zip [0..]
+
+  siteLayoutMsg MsgMenuParticipantsIntersect $ do
+    setTitleI MsgMenuParticipantsIntersect
+    $(widgetFile "participants-intersect")

templates/participants-intersect.hamlet

@@ -0,0 +1,26 @@
+$newline never
+<section>
+  ^{formWidget}
+$maybe (courses, intersections) <- intersectionsRes
+  <section>
+    <div .scrolltable .scrolltable--bordered>
+      <table .table .table--hover .table--condensed>
+        <thead>
+          <tr .table__row--head>
+            <th .table__th>
+            $forall Entity _ Course{courseTerm, courseSchool, courseShorthand} <- courses
+              <th .table__th .text--center>
+                #{courseTerm}-#{courseSchool}-#{courseShorthand}
+        <tbody>
+          $forall (l, Entity lCid Course{courseTerm, courseSchool, courseShorthand}) <- lIxed courses
+            <tr .table__row>
+              <th .table__th .text--right>
+                #{courseTerm}-#{courseSchool}-#{courseShorthand}
+              $forall (u, Entity uCid _) <- lIxed courses
+                $if l > u
+                  <td .table__td>
+                $else
+                  $with n <- symmIntersection intersections lCid uCid
+                    <td .table__td .text--center :uCid == lCid:.table__td--automatic :uCid /= lCid:.heated :uCid /= lCid:style="--hotness: #{toPathPiece (intersectionHotness intersections lCid uCid)}">
+                      $if n /= 0
+                        #{n}

templates/widgets/massinput/participants-intersect/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=3>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput btn}

templates/widgets/massinput/participants-intersect/cell.hamlet

@@ -0,0 +1,7 @@
+$newline never
+<td>
+  #{courseTerm}
+<td>
+  #{courseSchool}
+<td>
+  #{courseName}

templates/widgets/massinput/participants-intersect/layout.hamlet

@@ -0,0 +1,13 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          $maybe delButton <- delButtons !? coord
+            ^{fvInput delButton}
+  $maybe addWdgt <- addWdgts !? (0, 0)
+    <tfoot>
+      <tr .massinput__cell.massinput__cell--add>
+        ^{addWdgt}