From b8b308d608a6acb9e70a143157437038de1f92ac Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Jul 2019 14:45:45 +0200 Subject: [PATCH] feat(exams): show exam results --- src/Database/Esqueleto/Utils.hs | 11 ++++-- src/Foundation.hs | 17 +++++++++ src/Handler/Exam/Users.hs | 62 ++++++++++++++++++++++++--------- src/Handler/Utils/Form.hs | 29 +++++++++++---- src/Model/Types/Exam.hs | 12 ++++++- src/Utils/Lens.hs | 1 + 6 files changed, 104 insertions(+), 28 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a3bf2192a..7ade5bac9 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -11,6 +11,7 @@ module Database.Esqueleto.Utils , mkContainsFilter, mkContainsFilterWith , mkExistsFilter , anyFilter, allFilter + , orderByList , orderByOrd, orderByEnum , lower, ciEq ) where @@ -167,12 +168,16 @@ allFilter fltrs needle criterias = F.foldr aux true fltrs aux fltr acc = fltr needle criterias E.&&. acc +orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) +orderByList vals + = let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism + in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals) + orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) -orderByOrd = let sortUni = zip [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism - \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1)) +orderByOrd = orderByList $ List.sort universeF orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) -orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1)) +orderByEnum = orderByList $ List.sortOn fromEnum universeF lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) diff --git a/src/Foundation.hs b/src/Foundation.hs index c534d6baf..da54306d1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -334,6 +334,23 @@ instance RenderMessage UniWorX StudyDegreeTerm where instance RenderMessage UniWorX ExamGrade where renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade +instance RenderMessage UniWorX ExamPassed where + renderMessage foundation ls = \case + ExamPassed True -> mr MsgExamPassed + ExamPassed False -> mr MsgExamNotPassed + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls + +instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where + renderMessage foundation ls = \case + ExamAttended{..} -> mr examResult + ExamNoShow -> mr MsgExamResultNoShow + ExamVoided -> mr MsgExamResultVoided + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls + -- ToMessage instances for converting raw numbers to Text (no internationalization) diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 65d7413d1..0d2604336 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -36,8 +36,8 @@ import Control.Arrow (Kleisli(..)) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) -type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms)) +type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) +type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult)) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 @@ -49,22 +49,25 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1) queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) -queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) +queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) -queryExamOccurrence = $(sqlLOJproj 3 2) +queryExamOccurrence = $(sqlLOJproj 4 2) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) -queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) +queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) -queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) +queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3) + +queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) +queryExamResult = $(sqlLOJproj 4 4) resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) resultExamRegistration = _dbrOutput . _1 @@ -84,6 +87,9 @@ resultStudyField = _dbrOutput . _6 . _Just resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence = _dbrOutput . _3 . _Just +resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) +resultExamResult = _dbrOutput . _7 . _Just + data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Maybe Text , csvEUserName :: Maybe Text @@ -200,7 +206,9 @@ postEUsersR tid ssh csh examn = do let examUsersDBTable = DBTable{..} where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult) = do + E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) + E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) @@ -210,7 +218,7 @@ postEUsersR tid ssh csh examn = do E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = return dbtColonnade = mconcat $ catMaybes @@ -229,6 +237,8 @@ postEUsersR tid ssh csh examn = do SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) + , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult) + , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade)) ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -239,6 +249,8 @@ postEUsersR tid ssh csh examn = do , sortDegreeShort queryStudyDegree , sortFeaturesSemester queryStudyFeatures , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult)) + , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser @@ -247,14 +259,30 @@ postEUsersR tid ssh csh examn = do , fltrDegree queryStudyDegree , fltrFeaturesSemester queryStudyFeatures , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + , ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult)) + , ( "result-bool" + , FilterColumn $ \row criteria -> if + | Set.null criteria -> E.true + | otherwise -> let passed :: [ExamResultGrade] + passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF + criteria' = Set.map (fmap $ review passingGrade) criteria + criteria'' + | ExamAttended (ExamPassed True) `Set.member` criteria + = criteria' `Set.union` Set.fromList passed + | otherwise + = criteria' + in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'') + ) ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - , fltrFieldUI mPrev - , fltrDegreeUI mPrev - , fltrFeaturesSemesterUI mPrev - , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence) + dbtFilterUI mPrev = mconcat $ catMaybes + [ Just $ fltrUserNameEmailUI mPrev + , Just $ fltrUserMatriclenrUI mPrev + , Just $ fltrFieldUI mPrev + , Just $ fltrDegreeUI mPrev + , Just $ fltrFeaturesSemesterUI mPrev + , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence) + , guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult) + , guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = DBParamsForm diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 3f01c2eb3..e7c9895ec 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1015,7 +1015,7 @@ examResultField innerField = Field , is _ExamNoShow res || is _ExamVoided res -> return . Right $ Just res | otherwise - -> fmap (fmap ExamAttended) <$> fieldParse innerField ts fs + -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) ts) fs , fieldView = \theId name attrs val isReq -> do innerId <- newIdent let @@ -1025,11 +1025,26 @@ examResultField innerField = Field innerVal = val >>= maybe (Left "") return . preview _ExamAttended [whamlet| $newline never - +