From a3465240731423e3ea5d7f85f8f8c73935166b76 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 22 Aug 2019 10:29:49 +0200 Subject: [PATCH] fix(csv exam import): ignore unchanged noshow and voided noshow and voided are now independent of whether the exam is graded or pass and fail only --- src/Foundation.hs | 11 ++++++++--- src/Handler/Exam/Users.hs | 18 ++++++------------ src/Model/Types/Exam.hs | 10 ++++++---- 3 files changed, 20 insertions(+), 19 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index a80f277d6..3ccd28aae 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -369,6 +369,11 @@ instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where + renderMessage foundation ls = either mr mr + where + mr :: RenderMessage UniWorX msg => msg -> Text + mr = renderMessage foundation ls -- ToMessage instances for converting raw numbers to Text (no internationalization) @@ -759,7 +764,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo return Authorized - + CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn @@ -872,7 +877,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do -- Checks `registerFrom` and `registerTo`, override as further routes become available now <- liftIO getCurrentTime - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash guard $ NTop allocationRegisterFrom <= NTop (Just now) guard $ NTop (Just now) <= NTop allocationRegisterTo return Authorized @@ -890,7 +895,7 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do -- Checks `registerFrom` and `registerTo`, override as further routes become available now <- liftIO getCurrentTime - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash guard $ NTop allocationStaffAllocationFrom <= NTop (Just now) guard $ NTop (Just now) <= NTop allocationStaffAllocationTo return Authorized diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 19168a7eb..2a5f9fbe9 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -109,7 +109,7 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserExerciseNumPasses :: Maybe Int , csvEUserExercisePointsMax :: Maybe Points , csvEUserExerciseNumPassesMax :: Maybe Int - , csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) + , csvEUserExamResult :: Maybe ExamResultPassedGrade , csvEUserCourseNote :: Maybe Html } deriving (Generic) @@ -209,7 +209,7 @@ data ExamUserCsvAction } | ExamUserCsvSetResultData { examUserCsvActUser :: UserId - , examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade) + , examUserCsvActExamResult :: Maybe ExamResultPassedGrade } | ExamUserCsvSetCourseNoteData { examUserCsvActUser :: UserId @@ -244,8 +244,8 @@ postEUsersR tid ssh csh examn = do showPasses = numSheetsPasses allBoni /= 0 showPoints = getSum (numSheetsPoints allBoni) /= 0 - resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade - resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades + resultView :: ExamResultGrade -> ExamResultPassedGrade + resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades let examUsersDBTable = DBTable{..} @@ -471,7 +471,7 @@ postEUsersR tid ssh csh examn = do deleteBy $ UniqueExamResult eid examUserCsvActUser audit $ TransactionExamResultDeleted eid examUserCsvActUser Just res -> do - let res' = either (over _examResult $ review passingGrade) id res + let res' = either (review passingGrade) id <$> res now <- liftIO getCurrentTime void $ upsertBy (UniqueExamResult eid examUserCsvActUser) @@ -550,11 +550,7 @@ postEUsersR tid ssh csh examn = do $newline never ^{nameWidget userDisplayName userSurname} $maybe newResult <- examUserCsvActExamResult - $case newResult - $of Left pResult - , _{pResult} - $of Right gResult - , _{gResult} + , _{newResult} $nothing , _{MsgExamResultNone} |] @@ -643,8 +639,6 @@ postEUsersR tid ssh csh examn = do ] E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid let isActive = studyFeatures E.^. StudyFeaturesValid E.==. E.val True - -- isActiveOrPrevious = maybe isActive (\Entity sfid _ -> isActive E.||. (studyFeatures E.^. StudyFeaturesId E.==. E.val sfid)) oldFeatures -- one line, but obfuscates the `or else` structure - -- isActiveOrPrevious = isActive E.||. $ maybe (E.val False) (\Entity sfid _ -> (studyFeatures E.^. StudyFeaturesId E.==. E.val sfid)) oldFeatures -- meh isActiveOrPrevious = case oldFeatures of Just (Entity _ CourseParticipant{courseParticipantField = Just sfid}) -> isActive E.||. (E.val sfid E.==. studyFeatures E.^. StudyFeaturesId) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index ef5a8f1f9..8dcf8f844 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -20,7 +20,7 @@ import Utils.Lens.TH import qualified Data.Csv as Csv import Database.Persist.Sql - + data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow @@ -211,14 +211,16 @@ pathPieceJSONKey ''ExamPassed passingGrade :: Iso' ExamGrade ExamPassed -- ^ Improper isomorphism; maps @ExamPassed True@ to `Grade10` passingGrade = iso (ExamPassed . (>= Grade40)) (bool Grade50 Grade10 . examPassed) - + type ExamResultPoints = ExamResult' Points type ExamResultGrade = ExamResult' ExamGrade type ExamResultPassed = ExamResult' ExamPassed -instance Csv.ToField (Either ExamResultPassed ExamResultGrade) where +type ExamResultPassedGrade = ExamResult' (Either ExamPassed ExamGrade) + +instance Csv.ToField (Either ExamPassed ExamGrade) where toField = either Csv.toField Csv.toField -instance Csv.FromField (Either ExamResultPassed ExamResultGrade) where +instance Csv.FromField (Either ExamPassed ExamGrade) where parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint