80 lines
2.7 KiB
Haskell
80 lines
2.7 KiB
Haskell
{-# 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{..}
|