diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 71ab9a2b1..3c4ef4358 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -258,6 +258,7 @@ RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist +ColumnRatingPointsDone: Punktzahl/Abgeschlossen Pseudonyms: Pseudonyme FileTitle: Dateiname @@ -386,6 +387,7 @@ SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert: SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben: +CorrGrade: Korrekturen eintragen UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! diff --git a/routes b/routes index dbe76f4d9..e2572e8ba 100644 --- a/routes +++ b/routes @@ -85,9 +85,10 @@ !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector -/corrections CorrectionsR GET POST !corrector !lecturer -/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer -/corrections/create CorrectionsCreateR GET POST !corrector !lecturer +/submissions CorrectionsR GET POST !corrector !lecturer +/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer +/submissions/create CorrectionsCreateR GET POST !corrector !lecturer +/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer /msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication diff --git a/src/Foundation.hs b/src/Foundation.hs index 1cdf8cfb2..95459077c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1122,6 +1122,35 @@ pageActions (CSheetR tid ssh csh shn SCorrR) = } ] pageActions (CorrectionsR) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Korrekturen hochladen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsUploadR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgaben erstellen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsCreateR + , menuItemModal = True + , menuItemAccessCallback' = runDB $ do + uid <- liftHandlerT requireAuthId + [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions + return E.countRows + return $ (count :: Int) /= 0 + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Korrekturen eintragen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsGradeR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CorrectionsGradeR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrekturen hochladen" , menuItemIcon = Nothing @@ -1237,6 +1266,8 @@ pageHeading CorrectionsUploadR = Just $ i18nHeading MsgCorrUpload pageHeading CorrectionsCreateR = Just $ i18nHeading MsgCorrCreate +pageHeading CorrectionsGradeR + = Just $ i18nHeading MsgCorrGrade pageHeading (MessageR _) = Just $ i18nHeading MsgSystemMessageHeading diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 904a283d7..78ad460c8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -69,6 +69,8 @@ import qualified Data.CaseInsensitive as CI import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Trans.RWS (RWST) + import Control.Monad.Trans.State (State, StateT(..), runState) import qualified Control.Monad.State.Class as State @@ -90,6 +92,9 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid sheetIs :: Key Sheet -> CorrectionsWhere sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid +submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere +submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode + type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym)) @@ -179,13 +184,25 @@ 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 + (\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) + ) + +colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, 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)) 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)) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) - => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) -makeCorrectionsTable whereClause colChoices psValidator = do + => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x) +makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy @@ -209,10 +226,10 @@ makeCorrectionsTable whereClause colChoices psValidator = do return (user, pseudonym E.?. SheetPseudonymPseudonym) let submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors - return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) + dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap) dbTable psValidator $ DBTable { dbtSQLQuery - , dbtColonnade = colChoices + , dbtColonnade , dbtProj , dbtSorting = Map.fromList [ ( "term" @@ -230,6 +247,9 @@ makeCorrectionsTable whereClause colChoices psValidator = do , ( "rating" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints ) + , ( "ratingtime" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime + ) ] , dbtFilter = Map.fromList [ ( "term" @@ -277,7 +297,7 @@ data ActionCorrectionsData = CorrDownloadData correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do - tableForm <- makeCorrectionsTable whereClause displayColumns psValidator + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf (actionRes, action) <- multiAction actions Nothing @@ -602,6 +622,7 @@ postCorrectionsCreateR = do FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, pss) -> do + now <- liftIO getCurrentTime runDB $ do Sheet{..} <- get404 sid (sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) @@ -643,6 +664,7 @@ postCorrectionsCreateR = do | otherwise -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId @@ -655,12 +677,14 @@ postCorrectionsCreateR = do case (groups :: [E.Value SubmissionGroupId]) of [x] -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } [] -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId @@ -671,17 +695,20 @@ postCorrectionsCreateR = do | [SheetPseudonym{sheetPseudonymUser}] <- spGroup -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insert_ SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } | otherwise -> do subId <- insert submission + void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc + redirect CorrectionsGradeR defaultLayout $ do @@ -701,3 +728,51 @@ postCorrectionsCreateR = do [] -> return $ Right valid textFromList :: [[Pseudonym]] -> Textarea textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText)) + +getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html +getCorrectionsGradeR = postCorrectionsGradeR +postCorrectionsGradeR = do + uid <- requireAuthId + let whereClause = ratedBy uid + displayColumns = mconcat -- should match getSSubsR for consistent UX + [ dbRow + , colTerm + , colCourse + , colSheet + , colPseudonyms + , colSubmissionLink + , colRated + , 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) + + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do + cID <- encrypt subId + void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True + return i + (((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm + + case tableRes of + FormMissing -> return () + 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 + if + | submissionRatingPoints /= mPoints' || submissionRatingComment /= mComment + -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints' + , SubmissionRatingComment =. mComment + , SubmissionRatingBy =. Just uid + , SubmissionRatingTime =. now <$ (void mPoints' <|> void mComment) + ] + | otherwise -> return $ Nothing + subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission] + unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet") + + defaultLayout $ do + $(widgetFile "corrections-grade") diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 3e017472c..d4fe59a22 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -35,7 +35,7 @@ module Handler.Utils.Table.Pagination , widgetColonnade, formColonnade, dbColonnade , cell, textCell, stringCell, i18nCell , anchorCell, anchorCell', anchorCellM, anchorCellM' - , tickmarkCell + , tickmarkCell, cellTooltip , listCell , formCell, DBFormResult, getDBFormResult , dbRow, dbSelect @@ -499,6 +499,15 @@ tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a tickmarkCell True = textCell (tickmark :: Text) tickmarkCell False = mempty +cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a +cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt) + where + tipWdgt = [whamlet| +
+
+
_{msg} + |] + anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a anchorCell = anchorCellM . return diff --git a/templates/corrections-grade.hamlet b/templates/corrections-grade.hamlet new file mode 100644 index 000000000..f68d51e69 --- /dev/null +++ b/templates/corrections-grade.hamlet @@ -0,0 +1,5 @@ +
+
+ ^{table} +