feat(exams): improve handling of exam results everywhere
BREAKING CHANGE: ExamResult now contains ExamResultPassedGrade
This commit is contained in:
Gregor Kleen
parent
408c15df6f
commit
0e49bc14e5
@ -29,9 +29,9 @@ export class InteractiveFieldset {
|
||||
return false;
|
||||
}
|
||||
|
||||
if (this._element.querySelector('[uw-interactive-fieldset]')) {
|
||||
return false;
|
||||
}
|
||||
// if (this._element.querySelector('[uw-interactive-fieldset]')) {
|
||||
// return false;
|
||||
// }
|
||||
|
||||
// param conditionalInput
|
||||
if (!this._element.dataset.conditionalInput) {
|
||||
|
||||
@ -1640,6 +1640,7 @@ ExamCorrectors: Korrektoren
|
||||
ExamCorrectorsTip: Hier eingetragene Korrektoren können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer im System hinterlegen.
|
||||
ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen
|
||||
|
||||
ExamPart: Teilprüfung/Aufgabe
|
||||
ExamParts: Teilprüfungen/Aufgaben
|
||||
ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein
|
||||
ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits
|
||||
@ -1703,10 +1704,16 @@ ExamUserAssignOccurrence: Termin/Raum zuweisen
|
||||
ExamUserAcceptComputedResult: Berechnetes Prüfungsergebnis übernehmen
|
||||
ExamUserResetToComputedResult: Prüfungsergebnis zurücksetzen
|
||||
ExamUserResetBonus: Auch Bonuspunkte zurücksetzen
|
||||
ExamUserSetPartResult: Teilergebnis setzen
|
||||
ExamUserSetBonus: Bonuspunkte setzen
|
||||
ExamUserSetResult: Prüfungsergebnis setzen
|
||||
ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet
|
||||
ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt
|
||||
ExamUsersResultsAccepted count@Int64: Prüfungsergebnis für #{show count} Teilnehmer übernommen
|
||||
ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehmer zurückgesetzt
|
||||
ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst
|
||||
ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst
|
||||
ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst
|
||||
|
||||
ExamUserSynchronised: Synchronisiert
|
||||
ExamUserSyncOfficeName: Name
|
||||
@ -2314,3 +2321,5 @@ BtnExamAutoOccurrenceNudgeDown: -
|
||||
ExamRoomMappingSurname: Nachnamen beginnend mit
|
||||
ExamRoomMappingMatriculation: Matrikelnummern endend in
|
||||
ExamRoomLoad: Auslastung
|
||||
|
||||
NoFilter: Keine Einschränkung
|
||||
@ -56,7 +56,7 @@ ExamBonus
|
||||
ExamResult
|
||||
exam ExamId
|
||||
user UserId
|
||||
result ExamResultGrade
|
||||
result ExamResultPassedGrade
|
||||
lastChanged UTCTime default=now()
|
||||
UniqueExamResult exam user
|
||||
ExamCorrector
|
||||
|
||||
@ -9,7 +9,7 @@ ExternalExam
|
||||
ExternalExamResult
|
||||
user UserId
|
||||
exam ExternalExamId
|
||||
result ExamResultGrade
|
||||
result ExamResultPassedGrade
|
||||
time UTCTime
|
||||
lastChanged UTCTime
|
||||
UniqueExternalExamResult exam user
|
||||
|
||||
@ -2255,7 +2255,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
|
||||
let navChildren = flip map (toList appLanguages) $ \lang -> NavLink
|
||||
{ navLabel = MsgLanguage lang
|
||||
, navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | let Just currentRoute = mCurrentRoute ])
|
||||
, navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeButton
|
||||
{ navMethod = POST
|
||||
@ -2281,7 +2281,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
, navIcon = IconMenuHelp
|
||||
, navLink = NavLink
|
||||
{ navLabel = MsgMenuHelp
|
||||
, navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | let Just currentRoute = mCurrentRoute ])
|
||||
, navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ])
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = True }
|
||||
, navQuick' = mempty
|
||||
|
||||
@ -213,11 +213,8 @@ postECorrectR tid ssh csh examn = do
|
||||
delete oldId
|
||||
audit $ TransactionExamResultDeleted eId uid
|
||||
return Nothing
|
||||
| Just result <- ciqGrade' -> let
|
||||
mOld = view passedGrade . examResultResult . entityVal <$> mOldResult
|
||||
resultGrade = review passedGrade result
|
||||
passedGrade :: Iso' ExamResultGrade ExamResultPassedGrade
|
||||
passedGrade = iso (fmap $ bool (Left . view passingGrade) Right examShowGrades) (fmap $ either (review passingGrade) id)
|
||||
| Just resultGrade <- ciqGrade' -> let
|
||||
mOld = examResultResult . entityVal <$> mOldResult
|
||||
in if
|
||||
| ciqGrade' /= mOld -> do
|
||||
newResult <- upsert ExamResult
|
||||
@ -230,8 +227,8 @@ postECorrectR tid ssh csh examn = do
|
||||
, ExamResultLastChanged =. now
|
||||
]
|
||||
audit $ TransactionExamResultEdit eId uid
|
||||
return $ newResult ^? _entityVal . _examResultResult . passedGrade
|
||||
| otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult . passedGrade
|
||||
return $ newResult ^? _entityVal . _examResultResult
|
||||
| otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult
|
||||
| otherwise -> return Nothing
|
||||
|
||||
user <- userToResponse match
|
||||
|
||||
@ -88,7 +88,7 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
noBonus = fromMaybe False $ do
|
||||
guardM $ bonusOnlyPassed <$> examBonusRule
|
||||
return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not
|
||||
return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
|
||||
|
||||
sumPoints = fmap getSum . mconcat $ catMaybes
|
||||
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
|
||||
|
||||
@ -167,11 +167,12 @@ resultCourseNote = _dbrOutput . _10 . _Just
|
||||
resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
|
||||
resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
|
||||
|
||||
resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade
|
||||
resultAutomaticExamResult exam examBonus' = folding . runReader $ do
|
||||
resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultPassedGrade
|
||||
resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do
|
||||
parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
|
||||
bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
|
||||
return $ examGrade exam bonus =<< parts'
|
||||
let gradeRes = examGrade exam bonus =<< parts'
|
||||
return $ fmap (bool (Left . view passingGrade) Right examShowGrades) <$> gradeRes
|
||||
|
||||
|
||||
csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
|
||||
@ -301,6 +302,9 @@ examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
|
||||
|
||||
data ExamUserAction = ExamUserDeregister
|
||||
| ExamUserAssignOccurrence
|
||||
| ExamUserSetPartResult
|
||||
| ExamUserSetBonus
|
||||
| ExamUserSetResult
|
||||
| ExamUserAcceptComputedResult
|
||||
| ExamUserResetToComputedResult
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
@ -312,11 +316,15 @@ embedRenderMessage ''UniWorX ''ExamUserAction id
|
||||
|
||||
data ExamUserActionData = ExamUserDeregisterData
|
||||
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
|
||||
| ExamUserSetPartResultData ExamPartNumber (Maybe ExamResultPoints)
|
||||
| ExamUserSetBonusData (Maybe Points)
|
||||
| ExamUserSetResultData (Maybe ExamResultPassedGrade)
|
||||
| ExamUserAcceptComputedResultData
|
||||
| ExamUserResetToComputedResultData
|
||||
{ examUserResetBonus :: Bool
|
||||
}
|
||||
|
||||
|
||||
data ExamUserCsvActionClass
|
||||
= ExamUserCsvCourseRegister
|
||||
| ExamUserCsvRegister
|
||||
@ -394,6 +402,7 @@ getEUsersR = postEUsersR
|
||||
postEUsersR tid ssh csh examn = do
|
||||
(((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do
|
||||
exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
|
||||
occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName]
|
||||
examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
|
||||
bonus <- examBonus exam
|
||||
|
||||
@ -405,14 +414,11 @@ postEUsersR tid ssh csh examn = do
|
||||
showPasses = doBonus && numSheetsPasses allBoni /= 0
|
||||
showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0
|
||||
|
||||
resultView :: ExamResultGrade -> ExamResultPassedGrade
|
||||
resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
|
||||
|
||||
examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
|
||||
|
||||
resultAutomaticExamBonus' :: Fold ExamUserTableData Points
|
||||
resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus
|
||||
resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade
|
||||
resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultPassedGrade
|
||||
resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus
|
||||
|
||||
automaticCell :: forall msg m a b r.
|
||||
@ -512,7 +518,7 @@ postEUsersR tid ssh csh examn = do
|
||||
[ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
|
||||
| Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
|
||||
]
|
||||
, pure $ sortable (Just $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView)
|
||||
, pure $ sortable (Just "exam-result") (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left)
|
||||
, pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
|
||||
-> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
|
||||
]
|
||||
@ -528,34 +534,20 @@ postEUsersR tid ssh csh examn = do
|
||||
]
|
||||
, singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)
|
||||
, singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus)
|
||||
, singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
|
||||
, singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
|
||||
, sortExamResult (to $ queryExamResult >>> (E.?. ExamResultResult))
|
||||
, singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
|
||||
E.subSelectMaybe . E.from $ \edit -> do
|
||||
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
||||
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
||||
]
|
||||
dbtFilter = Map.fromList
|
||||
[ fltrUserNameEmail queryUser
|
||||
, fltrUserMatriclenr queryUser
|
||||
, fltrField queryStudyField
|
||||
, 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'')
|
||||
)
|
||||
dbtFilter = mconcat
|
||||
[ uncurry singletonMap $ fltrUserNameEmail queryUser
|
||||
, uncurry singletonMap $ fltrUserMatriclenr queryUser
|
||||
, uncurry singletonMap $ fltrField queryStudyField
|
||||
, uncurry singletonMap $ fltrDegree queryStudyDegree
|
||||
, uncurry singletonMap $ fltrFeaturesSemester queryStudyFeatures
|
||||
, uncurry singletonMap ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
|
||||
, fltrExamResultPoints (to $ queryExamResult >>> (E.?. ExamResultResult))
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat $ catMaybes
|
||||
[ Just $ fltrUserNameEmailUI mPrev
|
||||
@ -563,9 +555,8 @@ postEUsersR tid ssh csh examn = do
|
||||
, 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)
|
||||
, Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ optionsF [CI.original examOccurrenceName | Entity _ ExamOccurrence{..} <- occurrences]) (fslI MsgExamOccurrence)
|
||||
, Just $ fltrExamResultPointsUI mPrev
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = DBParamsForm
|
||||
@ -581,17 +572,36 @@ postEUsersR tid ssh csh examn = do
|
||||
pure ExamUserDeregisterData
|
||||
, singletonMap ExamUserAssignOccurrence $
|
||||
ExamUserAssignOccurrenceData
|
||||
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
|
||||
, bool mempty computeActionMap $ is _Just examGradingRule
|
||||
]
|
||||
computeActionMap = mconcat
|
||||
[ singletonMap ExamUserAcceptComputedResult $
|
||||
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
|
||||
, singletonMap ExamUserAcceptComputedResult $
|
||||
pure ExamUserAcceptComputedResultData
|
||||
, singletonMap ExamUserResetToComputedResult $
|
||||
ExamUserResetToComputedResultData
|
||||
<$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
|
||||
<$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
|
||||
, singletonMap ExamUserSetPartResult $
|
||||
ExamUserSetPartResultData
|
||||
<$> areq (selectField $ optionsPairs (map ((MsgExamPartNumbered &&& id) . examPartNumber . entityVal) examParts)) (fslI MsgExamPart) Nothing
|
||||
<*> (fmap ExamAttended <$> aopt pointsField (fslI MsgPoints) Nothing)
|
||||
, singletonMap ExamUserSetBonus $
|
||||
ExamUserSetBonusData
|
||||
<$> aopt pointsField (fslI MsgPoints) Nothing
|
||||
, singletonMap ExamUserSetResult $
|
||||
ExamUserSetResultData
|
||||
<$> aopt (examResultField (Just $ SomeMessage MsgExamResultNone) examPassedGradeField) (fslI MsgExamResult) Nothing
|
||||
]
|
||||
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
|
||||
|
||||
actionOpts :: Handler (OptionList ExamUserAction)
|
||||
actionOpts = execWriterT $ do
|
||||
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
|
||||
when (is _Just examGradingRule) $
|
||||
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
|
||||
when (not $ null examParts) $
|
||||
tell =<< optionsF [ ExamUserSetPartResult ]
|
||||
when doBonus $
|
||||
tell =<< optionsF [ ExamUserSetBonus ]
|
||||
tell =<< optionsF [ ExamUserSetResult ]
|
||||
|
||||
(res, formWgt) <- multiActionMOpts actionMap actionOpts (fslI MsgAction) Nothing csrf
|
||||
let formRes = (, mempty) . First . Just <$> res
|
||||
return (formRes, formWgt)
|
||||
, dbParamsFormEvaluate = liftHandler . runFormPost
|
||||
@ -623,7 +633,7 @@ postEUsersR tid ssh csh examn = do
|
||||
<*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
|
||||
<*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus)
|
||||
<*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
|
||||
<*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView
|
||||
<*> preview (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
|
||||
<*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
|
||||
dbtCsvDecode = Just DBTCsvDecode
|
||||
{ dbtCsvRowKey = \csv -> do
|
||||
@ -686,8 +696,8 @@ postEUsersR tid ssh csh examn = do
|
||||
oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
|
||||
|
||||
newResult, oldResult :: Maybe ExamResultPassedGrade
|
||||
newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults
|
||||
oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView
|
||||
newResult = fmap (fmap $ bool (Left . view passingGrade) Right examShowGrades) . examGrade examVal (newBonus <|> oldBonus) =<< newResults
|
||||
oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
|
||||
|
||||
when doBonus $
|
||||
case newBonus of
|
||||
@ -806,12 +816,11 @@ postEUsersR tid ssh csh examn = do
|
||||
deleteBy $ UniqueExamResult eid examUserCsvActUser
|
||||
audit $ TransactionExamResultDeleted eid examUserCsvActUser
|
||||
Just res -> do
|
||||
let res' = either (review passingGrade) id <$> res
|
||||
now <- liftIO getCurrentTime
|
||||
void $ upsertBy
|
||||
(UniqueExamResult eid examUserCsvActUser)
|
||||
(ExamResult eid examUserCsvActUser res' now)
|
||||
[ ExamResultResult =. res'
|
||||
(ExamResult eid examUserCsvActUser res now)
|
||||
[ ExamResultResult =. res
|
||||
, ExamResultLastChanged =. now
|
||||
]
|
||||
audit $ TransactionExamResultEdit eid examUserCsvActUser
|
||||
@ -1084,6 +1093,88 @@ postEUsersR tid ssh csh examn = do
|
||||
Nothing -> return mempty
|
||||
addMessageI Success $ MsgExamUsersResultsReset nrReset
|
||||
redirect $ CExamR tid ssh csh examn EUsersR
|
||||
(ExamUserSetPartResultData part mPts, Map.elems -> rows) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
updated <- fmap getSum . runDB $ do
|
||||
partId <- getKeyBy $ UniqueExamPartNumber eId part
|
||||
flip foldMapM partId $ \epId -> flip foldMapM rows $ \row -> do
|
||||
let uid = row ^. resultUser . _entityKey
|
||||
oldPartResult <- getBy $ UniqueExamPartResult epId uid
|
||||
case mPts of
|
||||
Just pts
|
||||
| maybe True ((/= pts) . examPartResultResult . entityVal) oldPartResult -> do
|
||||
void $ upsert
|
||||
ExamPartResult
|
||||
{ examPartResultExamPart = epId
|
||||
, examPartResultUser = row ^. resultUser . _entityKey
|
||||
, examPartResultResult = pts
|
||||
, examPartResultLastChanged = now
|
||||
}
|
||||
[ ExamPartResultResult =. pts, ExamPartResultLastChanged =. now ]
|
||||
audit $ TransactionExamPartResultEdit epId uid
|
||||
return $ Sum 1
|
||||
Nothing
|
||||
| is _Just oldPartResult -> do
|
||||
deleteBy $ UniqueExamPartResult epId uid
|
||||
audit $ TransactionExamPartResultDeleted epId uid
|
||||
return $ Sum 1
|
||||
_other -> return mempty
|
||||
addMessageI Success $ MsgExamUsersPartResultsSet updated
|
||||
redirect $ CExamR tid ssh csh examn EUsersR
|
||||
(ExamUserSetBonusData mPts, Map.elems -> rows) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
updated <- fmap getSum . runDB $ do
|
||||
flip foldMapM rows $ \row -> do
|
||||
let uid = row ^. resultUser . _entityKey
|
||||
oldBonus <- getBy $ UniqueExamBonus eId uid
|
||||
case mPts of
|
||||
Just pts
|
||||
| maybe True ((/= pts) . examBonusBonus . entityVal) oldBonus -> do
|
||||
void $ upsert
|
||||
ExamBonus
|
||||
{ examBonusExam = eId
|
||||
, examBonusUser = row ^. resultUser . _entityKey
|
||||
, examBonusBonus = pts
|
||||
, examBonusLastChanged = now
|
||||
}
|
||||
[ ExamBonusBonus =. pts, ExamBonusLastChanged =. now ]
|
||||
audit $ TransactionExamBonusEdit eId uid
|
||||
return $ Sum 1
|
||||
Nothing
|
||||
| is _Just oldBonus -> do
|
||||
deleteBy $ UniqueExamBonus eId uid
|
||||
audit $ TransactionExamBonusDeleted eId uid
|
||||
return $ Sum 1
|
||||
_other -> return mempty
|
||||
addMessageI Success $ MsgExamUsersBonusSet updated
|
||||
redirect $ CExamR tid ssh csh examn EUsersR
|
||||
(ExamUserSetResultData mRes, Map.elems -> rows) -> do
|
||||
now <- liftIO getCurrentTime
|
||||
updated <- fmap getSum . runDB $ do
|
||||
flip foldMapM rows $ \row -> do
|
||||
let uid = row ^. resultUser . _entityKey
|
||||
oldResult <- getBy $ UniqueExamResult eId uid
|
||||
case mRes of
|
||||
Just res
|
||||
| maybe True ((/= res) . examResultResult . entityVal) oldResult -> do
|
||||
void $ upsert
|
||||
ExamResult
|
||||
{ examResultExam = eId
|
||||
, examResultUser = row ^. resultUser . _entityKey
|
||||
, examResultResult = res
|
||||
, examResultLastChanged = now
|
||||
}
|
||||
[ ExamResultResult =. res, ExamResultLastChanged =. now ]
|
||||
audit $ TransactionExamResultEdit eId uid
|
||||
return $ Sum 1
|
||||
Nothing
|
||||
| is _Just oldResult -> do
|
||||
deleteBy $ UniqueExamResult eId uid
|
||||
audit $ TransactionExamResultDeleted eId uid
|
||||
return $ Sum 1
|
||||
_other -> return mempty
|
||||
addMessageI Success $ MsgExamUsersResultSet updated
|
||||
redirect $ CExamR tid ssh csh examn EUsersR
|
||||
|
||||
closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId
|
||||
|
||||
|
||||
@ -341,7 +341,7 @@ postEGradesR tid ssh csh examn = do
|
||||
start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just
|
||||
end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just
|
||||
lift $ maybe mempty (flip (formatTimeRangeW SelFormatDateTime) end) start
|
||||
, colExamResult examShowGrades (resultExamResult . _entityVal . _examResultResult)
|
||||
, colExamResult (resultExamResult . _entityVal . _examResultResult)
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
|
||||
@ -350,7 +350,7 @@ postEGradesR tid ssh csh examn = do
|
||||
, sortStudyDegree queryStudyDegree
|
||||
, sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
|
||||
, sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
|
||||
, maybeOpticSortColumn (sortExamResult examShowGrades) (queryExamResult . to (E.^. ExamResultResult))
|
||||
, maybeOpticSortColumn sortExamResult (queryExamResult . to (E.^. ExamResultResult))
|
||||
, singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
@ -359,7 +359,7 @@ postEGradesR tid ssh csh examn = do
|
||||
, fltrStudyTerms queryStudyField
|
||||
, fltrStudyDegree queryStudyDegree
|
||||
, fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
|
||||
, fltrExamResultPoints examShowGrades (queryExamResult . to (E.^. ExamResultResult))
|
||||
, fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just)
|
||||
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
@ -368,7 +368,7 @@ postEGradesR tid ssh csh examn = do
|
||||
, fltrStudyTermsUI
|
||||
, fltrStudyDegreeUI
|
||||
, fltrStudyFeaturesSemesterUI
|
||||
, fltrExamResultPointsUI examShowGrades
|
||||
, fltrExamResultPointsUI
|
||||
, \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
@ -408,7 +408,7 @@ postEGradesR tid ssh csh examn = do
|
||||
(row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand))
|
||||
(row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester)
|
||||
(row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
|
||||
(row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades))
|
||||
(row ^. resultExamResult . _entityVal . _examResultResult)
|
||||
, dbtCsvName = unpack csvName
|
||||
, dbtCsvNoExportData = Nothing
|
||||
, dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
|
||||
|
||||
@ -178,9 +178,6 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
||||
currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute
|
||||
|
||||
let
|
||||
resultView :: ExamResultGrade -> ExamResultPassedGrade
|
||||
resultView = fmap $ bool (Left . view passingGrade) Right externalExamShowGrades
|
||||
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
result <- view queryResult
|
||||
user <- view queryUser
|
||||
@ -262,25 +259,25 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
||||
, Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
|
||||
t <- view $ resultResult . _entityVal . _externalExamResultTime
|
||||
lift $ formatTimeW SelFormatDateTime t
|
||||
, colExamResult externalExamShowGrades (resultResult . _entityVal . _externalExamResultResult)
|
||||
, colExamResult (resultResult . _entityVal . _externalExamResultResult)
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
|
||||
, sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
||||
, sortOccurrenceStart (queryResult . to (E.^. ExternalExamResultTime))
|
||||
, maybeOpticSortColumn (sortExamResult externalExamShowGrades) (queryResult . to (E.^. ExternalExamResultResult))
|
||||
, maybeOpticSortColumn sortExamResult (queryResult . to (E.^. ExternalExamResultResult))
|
||||
, singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ fltrUserName' (queryUser . to (E.^. UserDisplayName))
|
||||
, fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
|
||||
, fltrExamResultPoints externalExamShowGrades (queryResult . to (E.^. ExternalExamResultResult))
|
||||
, fltrExamResultPoints (queryResult . to (E.^. ExternalExamResultResult) . to E.just)
|
||||
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrUserNameUI'
|
||||
, fltrUserMatriculationUI
|
||||
, fltrExamResultPointsUI externalExamShowGrades
|
||||
, fltrExamResultPointsUI
|
||||
, case mode of
|
||||
EEUMGrades ->
|
||||
\mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
|
||||
@ -332,7 +329,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
||||
, csvEUserName = row ^? resultUser . _entityVal . _userDisplayName
|
||||
, csvEUserMatriculation = row ^? resultUser . _entityVal . _userMatrikelnummer . _Just
|
||||
, csvEUserOccurrenceStart = row ^. resultResult . _entityVal . _externalExamResultTime . to utcToZonedTime
|
||||
, csvEUserExamResult = row ^. resultResult . _entityVal . _externalExamResultResult . to (fmap $ bool (Left . view passingGrade) Right externalExamShowGrades)
|
||||
, csvEUserExamResult = row ^. resultResult . _entityVal . _externalExamResultResult
|
||||
}
|
||||
dbtCsvDecode
|
||||
| mode == EEUMUsers = Just DBTCsvDecode
|
||||
@ -353,7 +350,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
||||
when (zonedTimeToUTC csvEUserOccurrenceStart /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultTime) $
|
||||
yield $ ExternalExamUserCsvSetTimeData (E.unValue dbCsvOldKey) (zonedTimeToUTC csvEUserOccurrenceStart)
|
||||
|
||||
when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult . to resultView) $
|
||||
when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult) $
|
||||
yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult
|
||||
, dbtCsvClassifyAction = \case
|
||||
ExternalExamUserCsvRegisterData{} -> ExternalExamUserCsvRegister
|
||||
@ -368,12 +365,11 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
||||
C.mapM_ $ \case
|
||||
ExternalExamUserCsvRegisterData{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let res' = either (review passingGrade) id <$> externalExamUserCsvActResult
|
||||
insert_ ExternalExamResult
|
||||
{ externalExamResultExam = eeId
|
||||
, externalExamResultUser = externalExamUserCsvActUser
|
||||
, externalExamResultTime = externalExamUserCsvActTime
|
||||
, externalExamResultResult = res'
|
||||
, externalExamResultResult = externalExamUserCsvActResult
|
||||
, externalExamResultLastChanged = now
|
||||
}
|
||||
audit $ TransactionExternalExamResultEdit eeId externalExamUserCsvActUser
|
||||
@ -386,9 +382,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
|
||||
audit $ TransactionExternalExamResultEdit eeId externalExamResultUser
|
||||
ExternalExamUserCsvSetResultData{..} -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let res' = either (review passingGrade) id <$> externalExamUserCsvActResult
|
||||
ExternalExamResult{..} <- updateGet externalExamUserCsvActRegistration
|
||||
[ ExternalExamResultResult =. res'
|
||||
[ ExternalExamResultResult =. externalExamUserCsvActResult
|
||||
, ExternalExamResultLastChanged =. now
|
||||
]
|
||||
audit $ TransactionExternalExamResultEdit eeId externalExamResultUser
|
||||
|
||||
@ -221,6 +221,15 @@ multiAction :: forall action a.
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
multiAction = multiAction' mpopt
|
||||
|
||||
multiActionOpts :: forall action a.
|
||||
Ord action
|
||||
=> Map action (AForm Handler a)
|
||||
-> Handler (OptionList action)
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
multiActionOpts = multiActionOpts' mpopt
|
||||
|
||||
multiAction' :: forall action a.
|
||||
( RenderMessage UniWorX action, PathPiece action, Ord action )
|
||||
@ -229,15 +238,37 @@ multiAction' :: forall action a.
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
multiAction' minp acts fs@FieldSettings{..} defAction csrf = do
|
||||
(actionRes, actionView) <- minp (selectField . optionsF $ Map.keysSet acts) fs defAction
|
||||
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
|
||||
multiAction' minp acts = multiActionOpts' minp acts (optionsF $ Map.keysSet acts)
|
||||
|
||||
multiActionOpts' :: forall action a.
|
||||
Ord action
|
||||
=> (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
|
||||
-> Map action (AForm Handler a)
|
||||
-> Handler (OptionList action)
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
||||
multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
|
||||
actsOpts <- liftHandler mActsOpts
|
||||
let actsOpts' = OptionList
|
||||
{ olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts
|
||||
, olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts
|
||||
}
|
||||
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
|
||||
|
||||
(actionRes, actionView) <- minp (selectField $ return actsOpts') fs defAction
|
||||
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts'
|
||||
|
||||
let actionResults = view _1 <$> results
|
||||
|
||||
actionViews = Map.foldrWithKey accViews [] results
|
||||
|
||||
accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
|
||||
accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
|
||||
accViews act
|
||||
| Option{..} : _ <- filter ((== act) . optionInternalValue) $ olOptions actsOpts'
|
||||
= flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
|
||||
| otherwise
|
||||
= flip const
|
||||
|
||||
return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
|
||||
|
||||
@ -247,6 +278,14 @@ multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action)
|
||||
-> Maybe action
|
||||
-> AForm Handler a
|
||||
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
|
||||
|
||||
multiActionAOpts :: Ord action
|
||||
=> Map action (AForm Handler a)
|
||||
-> Handler (OptionList action)
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> AForm Handler a
|
||||
multiActionAOpts acts opts fSettings defAction = formToAForm $ multiActionOpts acts opts fSettings defAction mempty
|
||||
|
||||
multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action)
|
||||
=> Map action (AForm Handler a)
|
||||
@ -254,6 +293,14 @@ multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action)
|
||||
-> Maybe action
|
||||
-> WForm Handler (FormResult a)
|
||||
multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction
|
||||
|
||||
multiActionWOpts :: Ord action
|
||||
=> Map action (AForm Handler a)
|
||||
-> Handler (OptionList action)
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> WForm Handler (FormResult a)
|
||||
multiActionWOpts acts opts fSettings defAction = aFormToWForm $ multiActionAOpts acts opts fSettings defAction
|
||||
|
||||
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action)
|
||||
=> Map action (AForm Handler a)
|
||||
@ -261,6 +308,14 @@ multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action)
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, Widget))
|
||||
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
|
||||
|
||||
multiActionMOpts :: Ord action
|
||||
=> Map action (AForm Handler a)
|
||||
-> Handler (OptionList action)
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> (Html -> MForm Handler (FormResult a, Widget))
|
||||
multiActionMOpts acts opts fSettings defAction = renderAForm FormStandard $ multiActionAOpts acts opts fSettings defAction
|
||||
|
||||
|
||||
------------
|
||||
@ -1175,32 +1230,33 @@ examResultField :: forall m res.
|
||||
, HandlerSite m ~ UniWorX
|
||||
, PathPiece res
|
||||
)
|
||||
=> Field m res -> Field m (ExamResult' res)
|
||||
examResultField innerField = Field
|
||||
=> Maybe (SomeMessage UniWorX) -> Field m res -> Field m (ExamResult' res)
|
||||
examResultField optMsg innerField = Field
|
||||
{ fieldEnctype = UrlEncoded <> fieldEnctype innerField
|
||||
, fieldParse = \ts fs -> if
|
||||
| [t] <- ts
|
||||
, Just res <- fromPathPiece t
|
||||
, is _ExamNoShow res || is _ExamVoided res
|
||||
| res : _ <- mapMaybe (assertM ((||) <$> is _ExamNoShow <*> is _ExamVoided) . fromPathPiece) ts
|
||||
-> return . Right $ Just res
|
||||
| null ts || any null ts
|
||||
-> return $ Right Nothing
|
||||
| otherwise
|
||||
-> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) 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
|
||||
val' :: ExamResult' (Either Text res)
|
||||
val' = either (ExamAttended . Left) (fmap Right) val
|
||||
innerVal :: Either Text res
|
||||
innerVal = val >>= maybe (Left "") return . preview _ExamAttended
|
||||
[whamlet|
|
||||
$newline never
|
||||
<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}
|
||||
$maybe optMsg' <- guardOnM (not isReq) optMsg
|
||||
<option value="" :is _Left val:selected>
|
||||
_{optMsg'}
|
||||
<option value="attended" :is (_Right . _ExamAttended) val:selected>_{MsgExamResultAttended}
|
||||
<option value="no-show" :is (_Right . _ExamNoShow) val:selected>_{MsgExamResultNoShow}
|
||||
<option value="voided" :is (_Right . _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}
|
||||
^{fieldView innerField innerId name attrs innerVal True}
|
||||
|]
|
||||
}
|
||||
|
||||
@ -1218,6 +1274,13 @@ examPassedField :: forall m.
|
||||
=> Field m ExamPassed
|
||||
examPassedField = hoistField liftHandler $ selectField optionsFinite
|
||||
|
||||
examPassedGradeField :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Field m (Either ExamPassed ExamGrade)
|
||||
examPassedGradeField = hoistField liftHandler . selectField $ (<>) <$> (fmap Left <$> optionsFinite) <*> (fmap Right <$> optionsFinite)
|
||||
|
||||
|
||||
data CsvFormatOptions' = CsvFormatOptionsPreset' CsvPreset
|
||||
| CsvFormatOptionsCustom'
|
||||
|
||||
@ -270,39 +270,23 @@ sortOccurrenceStart queryStart = singletonMap "occurrence-start" . SortColumn $
|
||||
-- Exam results --
|
||||
------------------
|
||||
|
||||
colExamResult :: Bool -- ^ Show grades?
|
||||
-> OpticColonnade ExamResultGrade
|
||||
colExamResult showGrades resultResult = Colonnade.singleton (fromSortable header) body
|
||||
colExamResult :: OpticColonnade ExamResultPassedGrade
|
||||
colExamResult resultResult = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "exam-result") (i18nCell MsgExamResult)
|
||||
body = views resultResult $ bool (i18nCell . fmap (view passingGrade)) i18nCell showGrades
|
||||
body = views resultResult i18nCell
|
||||
|
||||
sortExamResult :: Bool -- ^ Show grades?
|
||||
-> OpticSortColumn (Maybe ExamResultGrade)
|
||||
sortExamResult showGrades queryResult = singletonMap "exam-result" $ if
|
||||
| showGrades -> SortColumn $ view queryResult
|
||||
| otherwise -> SortColumn . views queryResult $ E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
|
||||
sortExamResult :: OpticSortColumn (Maybe ExamResultPassedGrade)
|
||||
sortExamResult queryResult = singletonMap "exam-result" $ SortColumn $ view queryResult
|
||||
|
||||
fltrExamResultPoints :: Bool -- ^ Show grades?
|
||||
-> OpticFilterColumn t ExamResultGrade
|
||||
fltrExamResultPoints showGrades queryExamResult = singletonMap "exam-result" . FilterColumn $ \row criteria -> if
|
||||
fltrExamResultPoints :: OpticFilterColumn' t (Set ExamResultPassedGrade) (E.SqlExpr (E.Value (Maybe ExamResultPassedGrade)))
|
||||
fltrExamResultPoints queryExamResult = singletonMap "exam-result" . FilterColumn $ \row criteria -> if
|
||||
| Set.null criteria -> E.true
|
||||
| otherwise -> let matches :: [ExamResultGrade]
|
||||
matches = filter (\res -> oany (((==) `on` viewResult) res) criteria) universeF
|
||||
|
||||
viewResult
|
||||
| showGrades = id
|
||||
| otherwise = fmap (view $ passingGrade . from passingGrade)
|
||||
in view queryExamResult row `E.in_` E.valList matches
|
||||
| otherwise -> view queryExamResult row `E.in_` E.valList (Just <$> Set.toList criteria)
|
||||
|
||||
|
||||
fltrExamResultPointsUI :: Bool -- ^ Show grades?
|
||||
-> DBFilterUI
|
||||
fltrExamResultPointsUI showGrades mPrev = prismAForm (singletonFilter "exam-result" . maybePrism _PathPiece) mPrev $ aopt field (fslI MsgExamResult)
|
||||
where
|
||||
field
|
||||
| showGrades = examResultField examGradeField
|
||||
| otherwise = convertField (over _examResult $ review passingGrade) (over _examResult $ view passingGrade) $ examResultField examPassedField
|
||||
fltrExamResultPointsUI :: DBFilterUI
|
||||
fltrExamResultPointsUI mPrev = prismAForm (singletonFilter "exam-result" . maybePrism _PathPiece) mPrev $ aopt (examResultField (Just $ SomeMessage MsgNoFilter) examPassedGradeField) (fslI MsgExamResult)
|
||||
|
||||
-------------
|
||||
-- Courses --
|
||||
|
||||
@ -154,6 +154,7 @@ import Colonnade.Instances as Import ()
|
||||
import Data.Bool.Instances as Import ()
|
||||
import Data.Encoding.Instances as Import ()
|
||||
import Prometheus.Instances as Import ()
|
||||
import Yesod.Form.Fields.Instances as Import ()
|
||||
|
||||
import Crypto.Hash as Import (Digest, SHA3_256)
|
||||
|
||||
|
||||
@ -606,6 +606,14 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|30.0.0|] [version|31.0.0|]
|
||||
, whenM ((&&) <$> tableExists "exam" <*> tableExists "exam_result") $ do
|
||||
queryRes <- [sqlQQ|SELECT exam_result.id, exam_result.result FROM exam_result INNER JOIN exam ON exam_result.exam = exam.id WHERE NOT exam.show_grades;|]
|
||||
forM_ queryRes $ \(resId :: ExamResultId, Single (res :: ExamResultGrade)) ->
|
||||
let res' :: ExamResultPassedGrade
|
||||
res' = Left . view passingGrade <$> res
|
||||
in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -333,6 +333,17 @@ instance Csv.ToField (Either ExamPassed ExamGrade) where
|
||||
instance Csv.FromField (Either ExamPassed ExamGrade) where
|
||||
parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint
|
||||
|
||||
instance PathPiece (Either ExamPassed ExamGrade) where
|
||||
toPathPiece = either toPathPiece toPathPiece
|
||||
fromPathPiece x = (Left <$> fromPathPiece x) <|> (Right <$> fromPathPiece x)
|
||||
|
||||
instance {-# OVERLAPPING #-} ToJSON (Either ExamPassed ExamGrade) where
|
||||
toJSON = either toJSON toJSON
|
||||
toEncoding = either toEncoding toEncoding
|
||||
|
||||
instance {-# OVERLAPPING #-} FromJSON (Either ExamPassed ExamGrade) where
|
||||
parseJSON x = (Left <$> parseJSON x) <|> (Right <$> parseJSON x)
|
||||
|
||||
|
||||
newtype ExamPartNumber = ExamPartNumber { examPartNumberFragments :: [Either (CI Text) Natural] }
|
||||
deriving (Eq, Ord, Generic, Typeable)
|
||||
|
||||
29
src/Yesod/Form/Fields/Instances.hs
Normal file
29
src/Yesod/Form/Fields/Instances.hs
Normal file
@ -0,0 +1,29 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Yesod.Form.Fields.Instances
|
||||
() where
|
||||
|
||||
import ClassyPrelude hiding (foldMap)
|
||||
import Yesod.Form.Fields
|
||||
|
||||
import Data.Foldable (Foldable(..))
|
||||
|
||||
|
||||
deriving instance Foldable Option
|
||||
deriving instance Traversable Option
|
||||
|
||||
instance Foldable OptionList where
|
||||
foldMap f OptionList{..} = foldMap (foldMap f) olOptions
|
||||
|
||||
|
||||
instance Semigroup (OptionList a) where
|
||||
a <> b = OptionList
|
||||
{ olOptions = olOptions a <> olOptions b
|
||||
, olReadExternal = \inp -> olReadExternal a inp <|> olReadExternal b inp
|
||||
}
|
||||
|
||||
instance Monoid (OptionList a) where
|
||||
mempty = OptionList
|
||||
{ olOptions = mempty
|
||||
, olReadExternal = const Nothing
|
||||
}
|
||||
@ -9,13 +9,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result
|
||||
<p .result>
|
||||
$case examResultResult
|
||||
$of ExamAttended grade
|
||||
$if examShowGrades
|
||||
_{grade}
|
||||
$else
|
||||
$if view (passingGrade . _Wrapped) grade
|
||||
_{MsgExamPassed}
|
||||
$else
|
||||
_{MsgExamNotPassed}
|
||||
_{grade}
|
||||
$of ExamNoShow
|
||||
_{MsgExamNoShow}
|
||||
$of ExamVoided
|
||||
|
||||
@ -7,13 +7,7 @@ $maybe ExternalExamResult{externalExamResultResult} <- mResult
|
||||
<p .result>
|
||||
$case externalExamResultResult
|
||||
$of ExamAttended grade
|
||||
$if externalExamShowGrades
|
||||
_{grade}
|
||||
$else
|
||||
$if view (passingGrade . _Wrapped) grade
|
||||
_{MsgExamPassed}
|
||||
$else
|
||||
_{MsgExamNotPassed}
|
||||
_{grade}
|
||||
$of ExamNoShow
|
||||
_{MsgExamNoShow}
|
||||
$of ExamVoided
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
<fieldset uw-interactive-fieldset data-conditional-input=#{fvId actionView} data-conditional-value=#{toPathPiece act}>
|
||||
$newline never
|
||||
<fieldset uw-interactive-fieldset data-conditional-input=#{fvId actionView} data-conditional-value=#{optionExternalValue}>
|
||||
<legend>
|
||||
_{act}
|
||||
#{optionDisplay}
|
||||
^{w}
|
||||
|
||||
Reference in New Issue
Block a user