diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 0b755dad5..b819e5d4a 100644 --- 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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 8bc16a232..de61d9ffd 100644 --- 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 \ No newline at end of file +InfoLecturerAllocations: Zentralanmeldungen + +ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} +ParticipantsIntersectCourses: Kurse \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 0f9f3a61f..19a403532 100644 --- 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 \ No newline at end of file +InfoLecturerAllocations: Central allocations + +ParticipantsIntersectCourseOption tid@TermId ssh@SchoolId coursen@CourseName: #{tid} - #{ssh} - #{coursen} +ParticipantsIntersectCourses: Courses \ No newline at end of file diff --git a/routes b/routes index 753ea445a..c44925aa1 100644 --- a/routes +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 56c0f7328..b76e29fc1 100644 --- 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 [] diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index 65e07da1e..146564ce1 100644 --- 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") diff --git a/templates/participants-intersect.hamlet b/templates/participants-intersect.hamlet new file mode 100644 index 000000000..f5e834c7d --- /dev/null +++ b/templates/participants-intersect.hamlet @@ -0,0 +1,26 @@ +$newline never +
+ ^{formWidget} +$maybe (courses, intersections) <- intersectionsRes +
+
+ + + + + $forall (l, Entity lCid Course{courseTerm, courseSchool, courseShorthand}) <- lIxed courses + +
+ $forall Entity _ Course{courseTerm, courseSchool, courseShorthand} <- courses + + #{courseTerm}-#{courseSchool}-#{courseShorthand} +
+ #{courseTerm}-#{courseSchool}-#{courseShorthand} + $forall (u, Entity uCid _) <- lIxed courses + $if l > u + + $else + $with n <- symmIntersection intersections lCid uCid + + $if n /= 0 + #{n} diff --git a/templates/widgets/massinput/participants-intersect/add.hamlet b/templates/widgets/massinput/participants-intersect/add.hamlet new file mode 100644 index 000000000..da5411bc4 --- /dev/null +++ b/templates/widgets/massinput/participants-intersect/add.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{fvInput addView} + + ^{fvInput btn} diff --git a/templates/widgets/massinput/participants-intersect/cell.hamlet b/templates/widgets/massinput/participants-intersect/cell.hamlet new file mode 100644 index 000000000..5fd8639ae --- /dev/null +++ b/templates/widgets/massinput/participants-intersect/cell.hamlet @@ -0,0 +1,7 @@ +$newline never + + #{courseTerm} + + #{courseSchool} + + #{courseName} diff --git a/templates/widgets/massinput/participants-intersect/layout.hamlet b/templates/widgets/massinput/participants-intersect/layout.hamlet new file mode 100644 index 000000000..f1842a72f --- /dev/null +++ b/templates/widgets/massinput/participants-intersect/layout.hamlet @@ -0,0 +1,13 @@ +$newline never + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgt}
+ $maybe delButton <- delButtons !? coord + ^{fvInput delButton} + $maybe addWdgt <- addWdgts !? (0, 0) +