86 lines
4.5 KiB
Haskell
86 lines
4.5 KiB
Haskell
module Handler.Utils.Exam
|
|
( fetchExamAux
|
|
, fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
|
|
, examBonus, examBonusPossible, examBonusAchieved
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Internal.Sql as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import Utils.Lens
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
fetchExamAux :: ( SqlBackendCanRead backend
|
|
, E.SqlSelect b a
|
|
, MonadHandler m
|
|
, Typeable a
|
|
)
|
|
=> (E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity Course) -> b)
|
|
-> TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT backend m a
|
|
fetchExamAux prj tid ssh csh examn =
|
|
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, examn)
|
|
in cachedBy cachId $ do
|
|
tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
|
|
E.on $ course E.^. CourseId E.==. tut E.^. ExamCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. tut E.^. ExamName E.==. E.val examn
|
|
return $ prj tut course
|
|
case tutList of
|
|
[tut] -> return tut
|
|
_other -> notFound
|
|
|
|
fetchExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Entity Exam)
|
|
fetchExam = fetchExamAux const
|
|
|
|
fetchExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Exam)
|
|
fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn
|
|
|
|
fetchCourseIdExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Key Exam)
|
|
fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn
|
|
|
|
fetchCourseIdExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam)
|
|
fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn
|
|
|
|
|
|
examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary)
|
|
examBonus (Entity eId Exam{..}) = runConduit $
|
|
let
|
|
rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do
|
|
E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
|
|
E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser
|
|
E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
|
|
)
|
|
E.on E.true
|
|
E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse
|
|
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId
|
|
E.where_ $ E.case_
|
|
[ E.when_
|
|
( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
|
|
E.then_
|
|
( E.just (sheet E.^. SheetActiveTo) E.<=. examOccurrence E.?. ExamOccurrenceStart
|
|
E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
|
|
)
|
|
]
|
|
( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
|
|
)
|
|
return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission)
|
|
accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) ->
|
|
Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub
|
|
in rawData .| accum
|
|
|
|
examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary
|
|
examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap
|
|
examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap
|