From b334df49398746e6e9b3e1113382f0a987bf4ae0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 29 Jun 2018 15:41:05 +0200 Subject: [PATCH] Further work on correction tables --- messages/de.msg | 5 + src/Foundation.hs | 6 ++ src/Handler/Corrections.hs | 99 +++++++++++++------ .../submissionsAlreadyAssigned.hamlet | 5 + 4 files changed, 85 insertions(+), 30 deletions(-) create mode 100644 templates/messages/submissionsAlreadyAssigned.hamlet diff --git a/messages/de.msg b/messages/de.msg index d7eb1b787..f22a70d21 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -124,3 +124,8 @@ SelectColumn: Auswahl CorrDownload: Herunterladen CorrSetCorrector: Korrektor zuweisen NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! + +SubmissionsAlreadyAssigned: Folgende Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert: +UpdatedAssignedCorrectors num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt. +NoCorrector: Kein Korrektor +RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt. \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index c4e22c72e..a8230a582 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -629,6 +629,12 @@ pageActions (CourseR tid csh CShowR) = return (sheets,lecturer) or2M (return lecturer) $ anyM sheets sheetRouteAccess } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgaben" + , menuItemIcon = Nothing + , menuItemRoute = CourseR tid csh CourseCorrectionsR + , menuItemAccessCallback' = return True + } , PageActionSecondary $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 5b3537b00..2021c54a6 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1,9 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -48,6 +48,11 @@ import Control.Lens import Web.PathPieces +import Text.Hamlet (ihamletFile) +import Text.Blaze.Html (preEscapedToHtml) + +import Database.Persist.Sql (updateWhereCount) + type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) => @@ -61,24 +66,24 @@ courseIs :: Key Course -> CorrectionsWhere courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid -type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School))) +type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User)) colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) - $ \DBRow{ dbrOutput=(_, _, course) } -> + $ \DBRow{ dbrOutput=(_, _, course, _) } -> -- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(_, _, course) } -> cell $ + $ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $ let tid = E.unValue $ course ^. _3 csh = E.unValue $ course ^. _2 in [whamlet|#{display csh}|] colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) - $ \DBRow{ dbrOutput=(_, sheet, course) } -> cell $ + $ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $ let tid = E.unValue $ course ^. _3 csh = E.unValue $ course ^. _2 shn = sheetName $ entityVal sheet @@ -86,13 +91,13 @@ colSheet = sortable (Just "sheet") (i18nCell MsgSheet) -- textCell $ sheetName $ entityVal sheet colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) -colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) - $ \DBRow{ dbrOutput=(submission, _, _) } -> - textCell $ display $ submissionRatingBy $ entityVal submission +colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case + DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty + DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) - $ \DBRow{ dbrOutput=(submission, sheet, course) } -> cell $ do + $ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do let tid = E.unValue $ course ^. _3 csh = E.unValue $ course ^. _2 shn = sheetName $ entityVal sheet @@ -100,16 +105,14 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) [whamlet|#{display cid}|] colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) -colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _) } -> encrypt subId +colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h ) => _ -> Colonnade h r' (DBCell m x) -> Handler (DBResult m x) makeCorrectionsTable whereClause colChoices = do - let tableData :: E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity Course)) - (E.SqlExpr (Entity Sheet ))) - (E.SqlExpr (Entity Submission)) - -> E.SqlQuery _ - tableData (course `E.InnerJoin` sheet `E.InnerJoin` submission) = do + let tableData :: (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) -> E.SqlQuery _ + tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do + E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ whereClause (course,sheet,submission) @@ -118,15 +121,15 @@ makeCorrectionsTable whereClause colChoices = do , course E.^. CourseTerm , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) ) - return (submission, sheet, crse) + return (submission, sheet, crse, corrector) dbTable def $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colChoices , dbtSorting = [ ( "term" - , SortColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) -> course E.^. CourseTerm + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm ) , ( "course" - , SortColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) -> course E.^. CourseShorthand + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand ) -- TODO ] @@ -152,7 +155,7 @@ instance RenderMessage UniWorX ActionCorrections where renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector data ActionCorrectionsData = CorrDownloadData - | CorrSetCorrectorData UserId + | CorrSetCorrectorData (Maybe UserId) correctionsR :: _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget)) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) actions = do @@ -167,11 +170,31 @@ correctionsR whereClause (formColonnade -> displayColumns) actions = do FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs FormMissing -> return () FormSuccess (CorrDownloadData, subs) -> do - (Set.fromList -> ids) <- forM (Set.toList subs) decrypt + ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\"" sendResponse =<< submissionMultiArchive ids - FormSuccess (CorrSetCorrectorData uid, subs) -> do - addMessage "danger" $ "Setting correctors not implemented yet" -- TODO + FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do + subs <- mapM decrypt $ Set.toList subs' + runDB $ do + alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] + when (not $ null alreadyAssigned) $ do + mr <- (toHtml . ) <$> getMessageRender + alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) + addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) + let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) + when (not $ null unassigned) $ do + num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid] + addMessageI "success" $ MsgUpdatedAssignedCorrectors num + redirect currentRoute + FormSuccess (CorrSetCorrectorData Nothing, subs') -> do + subs <- mapM decrypt $ Set.toList subs' + runDB $ do + num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing + , SubmissionRatingComment =. Nothing + , SubmissionRatingBy =. Nothing + , SubmissionRatingTime =. Nothing + ] + addMessageI "success" $ MsgRemovedCorrections num redirect currentRoute fmap toTypedContent . defaultLayout $ do @@ -186,10 +209,26 @@ downloadAction = ( CorrDownload , return (pure CorrDownloadData, mempty) ) -assignAction :: ActionCorrections' -assignAction = ( CorrSetCorrector - , return (pure undefined, mempty) -- TODO - ) +assignAction :: CourseId -> ActionCorrections' +assignAction cId = ( CorrSetCorrector + , do + correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do + E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + + E.where_ $ course E.^. CourseId E.==. E.val cId + + return user + + mr <- getMessageRender + + correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey + + ($ mempty) . renderAForm FormStandard . wFormToAForm $ do + cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing + fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId + ) getCorrectionsR, postCorrectionsR :: Handler TypedContent getCorrectionsR = postCorrectionsR @@ -211,8 +250,8 @@ postCorrectionsR = do getCourseCorrectionsR, postCourseCorrectionsR :: TermId -> Text -> Handler TypedContent getCourseCorrectionsR = postCourseCorrectionsR postCourseCorrectionsR tid csh = do - cid <- runDB $ getBy404 $ CourseTermShort tid csh - let whereClause = courseIs $ entityKey cid + Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh + let whereClause = courseIs cid colonnade = mconcat [ colSelect , dbRow @@ -222,5 +261,5 @@ postCourseCorrectionsR tid csh = do ] -- Continue here correctionsR whereClause colonnade $ Map.fromList [ downloadAction - , assignAction + , assignAction cid ] diff --git a/templates/messages/submissionsAlreadyAssigned.hamlet b/templates/messages/submissionsAlreadyAssigned.hamlet new file mode 100644 index 000000000..b7af031e8 --- /dev/null +++ b/templates/messages/submissionsAlreadyAssigned.hamlet @@ -0,0 +1,5 @@ +_{MsgSubmissionsAlreadyAssigned} + +