From 3342daa0e8ddf772d4bd134a34630ab0c1d09c94 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Oct 2018 16:39:45 +0200 Subject: [PATCH] Fix SubmissionRatingDone --- src/Handler/Corrections.hs | 46 +++++++++++++++++++++----------------- src/Model.hs | 2 +- 2 files changed, 26 insertions(+), 22 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 78ad460c8..9814f6d75 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -184,18 +184,23 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_ cell [whamlet|#{review pseudonymText pseudo}|] in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] -colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), a)))) -colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone & cellTooltip MsgRatingPointsDone) $ formCell +colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b)))) +colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell + (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) + (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done)) + +colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b)))) +colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone) $ formCell (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of - NotGraded -> over (_1.mapped) ((_1 .~) . fmap Left) . over _2 fvInput <$> mopt checkBoxField "" (Just . Just $ isJust submissionRatingPoints) - _other -> over (_1.mapped) ((_1 .~) . fmap Right) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints) + NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) + _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints) ) -colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Text)))) +colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text)))) colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) - (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_2 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) + (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment)) type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) @@ -497,11 +502,12 @@ postCorrectionR tid ssh csh shn cid = do [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) pointsForm = case sheetType of - NotGraded -> bool Nothing (Just 0) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) - _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints) + NotGraded -> pure Nothing + _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl") (Just $ submissionRatingPoints) - ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,) - <$> pointsForm + ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) + <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) + <*> pointsForm <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) <* submitButton @@ -512,13 +518,11 @@ postCorrectionR tid ssh csh shn cid = do case corrResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess (ratingPoints, ratingComment) -> do + FormSuccess (rated, ratingPoints, ratingComment) -> do runDBJobs $ do uid <- liftHandlerT requireAuthId now <- liftIO getCurrentTime - let rated = isJust ratingPoints -- <|> void ratingComment -- Comment shouldn't cause rating - Submission{submissionRatingTime} <- getJust sub update sub [ SubmissionRatingBy =. (uid <$ guard rated) @@ -742,12 +746,13 @@ postCorrectionsGradeR = do , colPseudonyms , colSubmissionLink , colRated + , colRatedField , colPointsField , colCommentField ] -- Continue here psValidator = def - & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), Maybe Text))) - unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } -> (bool (Right <$> submissionRatingPoints) (Just . Left $ isJust submissionRatingPoints) $ sheetType == NotGraded, submissionRatingComment) + & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text))) + unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do cID <- encrypt subId @@ -760,15 +765,14 @@ postCorrectionsGradeR = do FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess resMap -> do now <- liftIO getCurrentTime - subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (mPoints, mComment)) -> do - let mPoints' = either (bool Nothing $ return 0) return =<< mPoints - Submission{..} <- get404 subId + subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do + s@Submission{..} <- get404 subId if - | submissionRatingPoints /= mPoints' || submissionRatingComment /= mComment - -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints' + | submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s + -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints , SubmissionRatingComment =. mComment , SubmissionRatingBy =. Just uid - , SubmissionRatingTime =. now <$ (void mPoints' <|> void mComment) + , SubmissionRatingTime =. now <$ guard rated ] | otherwise -> return $ Nothing subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission] diff --git a/src/Model.hs b/src/Model.hs index 70f66d5d9..76a543723 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -51,4 +51,4 @@ data PWEntry = PWEntry $(deriveJSON defaultOptions ''PWEntry) submissionRatingDone :: Submission -> Bool -submissionRatingDone Submission{..} = isJust submissionRatingPoints +submissionRatingDone Submission{..} = isJust submissionRatingTime