CorrectionsGradeR

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!
 

routes

@@ -85,9 +85,10 @@
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
 
-/corrections  CorrectionsR GET POST !corrector !lecturer
+/submissions  CorrectionsR GET POST !corrector !lecturer
-/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
+/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer
-/corrections/create CorrectionsCreateR GET POST !corrector !lecturer
+/submissions/create CorrectionsCreateR GET POST !corrector !lecturer
+/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer
 
 
 /msg/#{CryptoUUIDSystemMessage} MessageR      GET POST        !timeANDisReadANDauthentication

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
 

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)
+                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
-makeCorrectionsTable whereClause colChoices psValidator = do
+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")

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|
+        <div .js-tooltip>
+          <div .tooltip__handle>
+          <div .tooltip__content>_{msg}
+      |]
+
 
 anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
 anchorCell = anchorCellM . return

templates/corrections-grade.hamlet

@@ -0,0 +1,5 @@
+<div .container>
+  <form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
+    ^{table}
+    <button type=submit>
+      _{MsgBtnSubmit}