feat: participants intersection

2020-02-20 15:27:30 +01:00 · 2020-02-20 15:27:30 +01:00 · 697c3e11fc
commit 697c3e11fc
parent 89fdf588b9
10 changed files with 215 additions and 59 deletions
--- a/frontend/src/app.sass
+++ b/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
--- a/messages/uniworx/de-de-formal.msg
+++ b/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
--- a/messages/uniworx/en-eu.msg
+++ b/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
--- a/1
+++ b/1
@ -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
--- a/src/Foundation.hs
+++ b/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 (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants     $ Just ParticipantsListR
+  breadcrumb ParticipantsListR      = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
+  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
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuTermCreate
-      , navRoute       = TermEditR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
+pageActions TermShowR = do
+  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
+  return
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuTermCreate
+        , navRoute       = TermEditR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuParticipantsList
-      , navRoute       = ParticipantsListR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuParticipantsList
+        , navRoute       = ParticipantsListR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = 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
-  [ NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuCourseNew
-      , navRoute       = CourseNewR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
+pageActions CourseListR = do
+  participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
+  return
+    [ NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuCourseNew
+        , navRoute       = CourseNewR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuAllocationList
-      , navRoute       = AllocationListR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuAllocationList
+        , navRoute       = AllocationListR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = False }
+        , navQuick'      = mempty
+        , navForceActive = False
+        }
+      , navChildren = []
      }
-    , navChildren = []
-    }
-  , NavPageActionPrimary
-    { navLink = NavLink
-      { navLabel       = MsgMenuParticipantsList
-      , navRoute       = ParticipantsListR
-      , navAccess'     = return True
-      , navType        = NavTypeLink { navModal = False }
-      , navQuick'      = mempty
-      , navForceActive = False
+    , NavPageActionPrimary
+      { navLink = NavLink
+        { navLabel       = MsgMenuParticipantsList
+        , navRoute       = ParticipantsListR
+        , navAccess'     = return True
+        , navType        = NavTypeLink { navModal = 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 []

--- a/src/Handler/Participants.hs
+++ b/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")
--- a/templates/participants-intersect.hamlet
+++ b/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}
--- a/templates/widgets/massinput/participants-intersect/add.hamlet
+++ b/templates/widgets/massinput/participants-intersect/add.hamlet
@ -0,0 +1,6 @@
+$newline never
+<td colspan=3>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput btn}
--- a/templates/widgets/massinput/participants-intersect/cell.hamlet
+++ b/templates/widgets/massinput/participants-intersect/cell.hamlet
@ -0,0 +1,7 @@
+$newline never
+<td>
+  #{courseTerm}
+<td>
+  #{courseSchool}
+<td>
+  #{courseName}
--- a/templates/widgets/massinput/participants-intersect/layout.hamlet
+++ b/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}