139 lines
5.9 KiB
Haskell
139 lines
5.9 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-incomplete-uni-patterns #-}
|
|
module Handler.Participants
|
|
( getParticipantsListR
|
|
, getParticipantsR
|
|
, getParticipantsIntersectR, postParticipantsIntersectR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Data.Ratio ((%))
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Data.Map ((!), (!?))
|
|
|
|
import Handler.Utils.Csv
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
|
|
data ParticipantEntry = ParticipantEntry
|
|
{ peCourse :: CourseName
|
|
, peEmail :: UserEmail
|
|
} deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
instance ToNamedRecord ParticipantEntry where
|
|
toNamedRecord ParticipantEntry{..} = Csv.namedRecord
|
|
[ "course" Csv..= peCourse
|
|
, "email" Csv..= peEmail
|
|
]
|
|
|
|
instance DefaultOrdered ParticipantEntry where
|
|
headerOrder _ = Csv.header ["course", "email"]
|
|
|
|
|
|
getParticipantsListR :: Handler Html
|
|
getParticipantsListR = do
|
|
schoolTerms'' <- runDB . E.select . E.from $ \(school `E.InnerJoin` term) -> do
|
|
E.on E.true
|
|
|
|
E.where_ . E.exists . E.from $ \(course `E.InnerJoin` participant) -> do
|
|
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
|
|
E.&&. course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
|
|
return (school E.^. SchoolId, term E.^. TermId)
|
|
|
|
schoolTerms' <- flip filterM schoolTerms'' $ \(E.Value ssh, E.Value tid) ->
|
|
hasReadAccessTo $ ParticipantsR tid ssh
|
|
|
|
let schoolTerms :: Set (SchoolId, TermId)
|
|
schoolTerms = setOf (folded . $(multifocusG 2) (_1 . _Value) (_2 . _Value)) schoolTerms'
|
|
|
|
siteLayoutMsg MsgParticipantsList $ do
|
|
setTitleI MsgParticipantsList
|
|
|
|
let schools :: Set SchoolId
|
|
schools = Set.map (view _1) schoolTerms
|
|
terms :: Set TermId
|
|
terms = Set.map (view _2) schoolTerms
|
|
$(widgetFile "participants-list")
|
|
|
|
getParticipantsR :: TermId -> SchoolId -> Handler TypedContent
|
|
getParticipantsR tid ssh = do
|
|
setContentDispositionCsv $ MsgParticipantsCsvName tid ssh
|
|
respondDefaultOrderedCsvDB (MsgParticipantsCsvSheetName tid ssh) $ E.selectSource partQuery .| C.map toParticipantEntry
|
|
where
|
|
partQuery = E.from $ \(course `E.InnerJoin` participant `E.InnerJoin` user) -> do
|
|
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
|
|
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
|
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
|
|
return (course E.^. CourseName, user E.^. UserEmail)
|
|
|
|
toParticipantEntry (E.Value peCourse, E.Value peEmail) = ParticipantEntry{..}
|
|
|
|
getParticipantsIntersectR, postParticipantsIntersectR :: Handler Html
|
|
getParticipantsIntersectR = postParticipantsIntersectR
|
|
postParticipantsIntersectR = do
|
|
let
|
|
courseQuery = E.from return
|
|
termSchoolAccess (Entity _ Course{..}) =
|
|
hasReadAccessTo $ ParticipantsR courseTerm courseSchool
|
|
((coursesRes, coursesView), coursesEnc) <- runFormPost . renderAForm FormStandard $ courseSelectForm courseQuery termSchoolAccess (const Nothing) ("participants-intersect" :: Text) (fslI MsgParticipantsIntersectCourses) False Nothing
|
|
let formWidget = wrapForm coursesView def
|
|
{ formAction = Just . SomeRoute $ ParticipantsIntersectR :#: ("table" :: Text)
|
|
, formEncoding = coursesEnc
|
|
}
|
|
|
|
intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \cids -> runDB $ do
|
|
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
|
|
let allUsersUnion = Set.size . Set.unions $ Map.elems courseUsers
|
|
let mapIntersect = mapIntersectNotOne courseUsers
|
|
let allUsersIntersection = Set.size . setIntersections $ Map.elems courseUsers
|
|
return (courses, intersections', mapIntersect, allUsersUnion, allUsersIntersection)
|
|
|
|
let
|
|
symmIntersection intersections lCid uCid = fromMaybe 0 $ intersections !? (lCid, uCid) <|> intersections !? (uCid, lCid)
|
|
intersectionHotness :: _ -> _ -> _ -> Centi
|
|
intersectionHotness intersections lCid uCid
|
|
| sumSize > 0 && intersectSize > 0 = realToFrac . (0.5 +) . (0.5 *) . max 0 . min 1 $ 2 * intersectSize % sumSize
|
|
| otherwise = 0
|
|
where
|
|
sumSize = (min `on` (intersections !)) (lCid, lCid) (uCid, uCid)
|
|
intersectSize = symmIntersection intersections lCid uCid
|
|
showNumber n lCid uCid = n /= 0 || lCid == uCid
|
|
|
|
lIxed = zip [0..]
|
|
|
|
siteLayoutMsg MsgParticipantsIntersect $ do
|
|
setTitleI MsgParticipantsIntersect
|
|
$(widgetFile "participants-intersect")
|