fradrive/src/Handler/Participants.hs

{-# 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 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 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, Typeable)

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 MsgMenuParticipantsList $ do
    setTitleI MsgMenuParticipantsList

    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
  csvName <- timestampCsv <*> fmap ((flip addExtension `on` unpack) extensionCsv) (getMessageRender <*> pure (MsgParticipantsCsvName tid ssh))
  setContentDisposition' $ Just csvName
  respondDefaultOrderedCsvDB $ 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
    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
    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
      | intersectSize == 0 = 0
      | otherwise    = realToFrac . (0.5 +) . (0.5 *) . max 0 . min 1 $ 2 * intersectSize % sumSize
      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 MsgMenuParticipantsIntersect $ do
    setTitleI MsgMenuParticipantsIntersect
    $(widgetFile "participants-intersect")