fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(exams): show exam results

Browse Source
This commit is contained in:
Gregor Kleen 2019-07-25 14:45:45 +02:00
parent d5be5d61ee
commit b8b308d608
6 changed files with 104 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/Database/Esqueleto/Utils.hs
View File

@ -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)

17
src/Foundation.hs
View File

@ -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)

62
src/Handler/Exam/Users.hs
View File

@ -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

29
src/Handler/Utils/Form.hs
View File

@ -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
<select id=#{theId} name=#{name} *{attrs} :isReq:required>
<option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
<option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
<option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
<fieldset uw-interactive-fieldset data-conditional-input=#{theId} data-conditional-value="attended">
^{fieldView innerField innerId name attrs innerVal False}
<div>
<select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
<option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
<option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
<option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
<fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value="attended" style="display: inline-block">
^{fieldView innerField innerId name attrs innerVal False}
|]
}
examGradeField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Field m ExamGrade
examGradeField = hoistField liftHandlerT $ selectField optionsFinite
examPassedField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Field m ExamPassed
examPassedField = hoistField liftHandlerT $ selectField optionsFinite

12
src/Model/Types/Exam.hs
View File

@ -12,7 +12,8 @@ module Model.Types.Exam
import Import.NoModel
import Model.Types.Common
import Control.Lens
import Control.Lens hiding (universe)
import Utils.Lens.TH
import qualified Data.Csv as Csv
@ -28,6 +29,7 @@ deriveJSON defaultOptions
} ''ExamResult'
derivePersistFieldJSON ''ExamResult'
makeLenses_ ''ExamResult'
makePrisms ''ExamResult'
instance PathPiece res => PathPiece (ExamResult' res) where
@ -73,6 +75,14 @@ instance Csv.FromField res => Csv.FromField (ExamResult' res) where
parseField "no-show" = pure ExamNoShow
parseField x = ExamAttended <$> Csv.parseField x
instance Universe res => Universe (ExamResult' res) where
universe = concat
[ pure ExamVoided
, pure ExamNoShow
, ExamAttended <$> universe
]
instance Finite res => Finite (ExamResult' res)
data ExamBonusRule = ExamNoBonus
| ExamBonusPoints

1
src/Utils/Lens.hs
View File

@ -140,6 +140,7 @@ makeLenses_ ''PredDNF
makeLenses_ ''ExamBonusRule
makeLenses_ ''ExamGradingRule
makeLenses_ ''ExamResult
makeLenses_ ''UTCTime