{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Participants
  ( getParticipantsListR
  , getParticipantsR
  ) where

import Import

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import qualified Data.Set as Set

import Handler.Utils.Csv
import Handler.Utils.ContentDisposition

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

    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

      return (course E.^. CourseName, user E.^. UserEmail)

    toParticipantEntry (E.Value peCourse, E.Value peEmail) = ParticipantEntry{..}