automatic corrector assignment

.vscode/tasks.json

@@ -53,6 +53,11 @@
       "type": "npm",
       "script": "yesod:start",
       "problemMatcher": []
+    },
+    {
+      "type": "npm",
+      "script": "start",
+      "problemMatcher": []
     }
   ]
 }

messages/uniworx/de.msg

@@ -17,7 +17,7 @@ BtnLecInvAccept: Annehmen
 BtnLecInvDecline: Ablehnen
 BtnCorrInvAccept: Annehmen
 BtnCorrInvDecline: Ablehnen
-
+BtnSubmissionsAssign: Abgaben zuteilen
 
 
 Aborted: Abgebrochen
@@ -33,6 +33,7 @@ GenericKey: Schlüssel
 GenericShort: Kürzel
 GenericIsNew: Neu
 GenericHasConflict: Konflikt
+GenericBack: Zurück
 
 SummerTerm year@Integer: Sommersemester #{display year}
 WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
@@ -396,7 +397,11 @@ SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem K
 AssignSubmissionExceptionNoCorrectors: Es sind keine Korrektoren eingestellt
 AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit Anteil ungleich Null eingestellt
 AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden
-
+NrSubmissionsTotal: Abgaben
+NrSubmissionsUnassigned: Ohne Korrektor
+NrCorrectors: Korrektoren
+NrSubmissionsNewlyAssigned: Neu zugeteilt
+NrSubmissionsNotAssigned: Nicht zugeteilt
 
 CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
 NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
@@ -822,6 +827,7 @@ MenuCorrectionsUpload: Korrekturen hochladen
 MenuCorrectionsDownload: Offene Abgaben herunterladen
 MenuCorrectionsCreate: Abgaben registrieren
 MenuCorrectionsGrade: Abgaben online korrigieren
+MenuCorrectionsAssign: Abgaben an Korrektoren zuteilen
 MenuAuthPreds: Authorisierungseinstellungen
 MenuTutorialDelete: Tutorium löschen
 MenuTutorialEdit: Tutorium editieren

routes

@@ -92,6 +92,7 @@
   /communication              CCommR           GET POST
   /notes                      CNotesR          GET POST        !corrector -- THIS route is used to check for overall course corrector access!
   /subs                       CCorrectionsR    GET POST
+  /subs/assigned              CAssignR         GET POST
   /ex                         SheetListR       GET             !course-registered !materials !corrector
   /ex/new                     SheetNewR        GET POST
   /ex/current                 SheetCurrentR    GET             !course-registered !materials !corrector
@@ -103,10 +104,11 @@
     /subs                       SSubsR         GET POST        -- for lecturer only
     !/subs/new                  SubmissionNewR GET POST        !timeANDcourse-registeredANDuser-submissions
     !/subs/own                  SubmissionOwnR GET             !free -- just redirect
+    !/subs/assign               SAssignR       GET POST        !lecturerANDtime
     /subs/#CryptoFileNameSubmission SubmissionR:
       /                         SubShowR       GET POST        !ownerANDtimeANDuser-submissions !ownerANDread !correctorANDread
       /delete                   SubDelR        GET POST        !ownerANDtimeANDuser-submissions
-      /assign                   SAssignR       GET POST        !lecturerANDtime
+      /assign                   SubAssignR     GET POST        !lecturerANDtime
       /correction               CorrectionR    GET POST        !corrector !ownerANDreadANDrated
       /invite                   SInviteR       GET POST        !ownerANDtimeANDuser-submissions
       !/#SubmissionFileType     SubArchiveR    GET             !owner !corrector

src/Foundation.hs

@@ -676,10 +676,11 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
       SZipR                 SheetSolution   -> guard $ maybe False (<= cTime) sheetSolutionFrom
       SZipR                 _               -> mzero
       -- Submissions
-      SubmissionNewR         -> guard   active
+      SubmissionNewR           -> guard   active
-      SubmissionR _ SAssignR -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
+      SAssignR                 -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler
-      SubmissionR _ _        -> guard   active
+      SubmissionR _ SubAssignR -> guard   marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
-      _                      -> return ()
+      SubmissionR _ _          -> guard   active
+      _                        -> return ()
 
     return Authorized
 
@@ -1589,7 +1590,7 @@ pageActions :: Route UniWorX -> [MenuItem]
 pageActions (HomeR) =
   [
     MenuItem
-      { menuItemType = PageActionPrime
+      { menuItemType  = PageActionPrime
       , menuItemLabel = MsgInfoLecturerTitle
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute InfoLecturerR
@@ -1896,6 +1897,16 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (CourseR tid ssh csh CCorrectionsR) =
+  [ MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgMenuCorrectionsAssign
+      , menuItemIcon = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (CourseR tid ssh csh SheetListR) =
   [ MenuItem
       { menuItemType = PageActionPrime
@@ -1925,6 +1936,14 @@ pageActions (CourseR tid ssh csh SheetListR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgMenuCorrectionsAssign
+      , menuItemIcon = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
   , MenuItem
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgMenuCorrectionsOwn
@@ -2094,6 +2113,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+   , MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgMenuCorrectionsAssign
+      , menuItemIcon = Nothing
+      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
   , MenuItem
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgMenuSheetEdit
@@ -2121,6 +2148,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
   ]
 pageActions (CSheetR tid ssh csh shn SSubsR) =
   [ MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgMenuSubmissionNew
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgMenuCorrectors
       , menuItemIcon = Nothing
@@ -2128,11 +2163,11 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
-  , MenuItem
+ , MenuItem
       { menuItemType = PageActionPrime
-      , menuItemLabel = MsgMenuSubmissionNew
+      , menuItemLabel = MsgMenuCorrectionsAssign
-      , menuItemIcon  = Nothing
+      , menuItemIcon = Nothing
-      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
+      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
       , menuItemModal = True
       , menuItemAccessCallback' = return True
       }
@@ -2150,7 +2185,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgCorrectorAssignTitle
       , menuItemIcon  = Nothing
-      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SAssignR
+      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR
       , menuItemModal = True
       , menuItemAccessCallback' = return True
       }

src/Handler/Corrections.hs

@@ -528,7 +528,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
           E.where_ $ submission E.^. SubmissionId E.==. E.val sId
           return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName)
       cID <- encrypt sId
-      let route  = CSubmissionR tid ssh csh shn cID SAssignR
+      let route  = CSubmissionR tid ssh csh shn cID SubAssignR
       (== Authorized) <$> evalAccessDB route True
 
 type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
@@ -1015,38 +1015,79 @@ postCorrectionsGradeR = do
     $(widgetFile "corrections-grade")
 
 
-getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+data ButtonSubmissionsAssign = BtnSubmissionsAssign
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonSubmissionsAssign
+instance Finite   ButtonSubmissionsAssign
+nullaryPathPiece ''ButtonSubmissionsAssign camelToPathPiece
+embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
+instance Button UniWorX ButtonSubmissionsAssign where
+  btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
+
+-- | Gather info about corrector assignment per sheet
+data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int }
+
+getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCAssignR = postCAssignR
+postCAssignR tid ssh csh = do
+  shids <- runDB $ do
+    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+    selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
+  assignHandler tid ssh csh shids
+
+getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSAssignR = postSAssignR
-postSAssignR tid ssh csh shn cID = do
+postSAssignR tid ssh csh shn = do
-  let actionUrl = CSubmissionR tid ssh csh shn cID SAssignR
+  shid <- runDB $ fetchSheetId tid ssh csh shn
-  sId <- decrypt cID
+  assignHandler tid ssh csh [shid]
-  (currentCorrector, sheetCorrectors) <- runDB $ do
-    Submission{submissionRatingBy, submissionSheet} <- get404 sId
-    sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
-    userCorrector <- traverse getJustEntity submissionRatingBy
-    return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)
-
-  $logDebugS "SAssignR" $ tshow currentCorrector
-  let correctorField  = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
-  ((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $
-        aopt correctorField (fslI MsgCorrector) (Just currentCorrector)
-  formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
-    when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
-      now <- liftIO getCurrentTime
-      update sId  [ SubmissionRatingBy =. mbUserId
-                  , SubmissionRatingAssigned =. (now <$ mbUserId)
-                  ]
-      addMessageI Success MsgCorrectorUpdated
-    redirect actionUrl
-  let corrForm = wrapForm' BtnSave corrForm' def
-        { formAction = Just $ SomeRoute actionUrl
-        , formEncoding = corrEncoding
-        , formSubmit = FormDualSubmit
-        }
-  defaultLayout $ do
-      setTitleI MsgCorrectorAssignTitle
-      $(widgetFile "submission-assign")
-
 
+assignHandler :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html
+assignHandler tid ssh csh rawSids = do
+  -- gather data
+  openSubs <- runDB $ (\f -> foldM f Map.empty rawSids) $
+      \acc sid -> maybeT (return acc) $ do
+        Just Sheet{sheetName=saiName} <- lift $ get sid
+        guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh saiName SAssignR  -- we must check, whether the submission is already closed and thus assignable
+        saiUnassignedNr <- lift $ count [SubmissionSheet ==. sid, SubmissionRatingBy ==. Nothing]
+        guard $ 0 < saiUnassignedNr -- only consider sheets with unassigned submissions
+        saiSubmissionNr <- lift $ count [SubmissionSheet ==. sid]
+        saiCorrectorNr  <- lift $ count [SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal]
+        -- guard $ saiCorrectorNr > 0 -- COMMENTED OUT BECAUSE we should show sheets without possible correctors to inform the user about these problematic sheets
+        return $ Map.insert sid SubAssignInfo{..} acc
+  let sids = Map.keys openSubs
+  -- process form
+  currentRoute <- getCurrentRoute
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm FIDAssignSubmissions buttonForm
+  let headingShort = MsgMenuCorrectionsAssign
+      headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
+  case btnResult of
+    FormSuccess BtnSubmissionsAssign -> do -- Button was pressed, assign and report
+        -- Assign submissions
+        status <- runDB $ (\f -> foldM f Map.empty sids) $
+          \acc sid -> flip (Map.insert sid) acc <$> assignSubmissions sid Nothing
+        -- Too much important information for an alert. Display proper info page instead
+        -- TODO: following convenience links available via breadcrumbs already? Or as PrimaryActions?
+        link <- case sids of
+          [sid] -> do Sheet{sheetName} <- runDB $ getJust sid
+                      return $ CSheetR tid ssh csh sheetName SSubsR
+          _     ->    return $ CourseR tid ssh csh CCorrectionsR
+        siteLayoutMsg headingShort $ do
+          setTitleI headingLong
+          $(widgetFile "corrections-assign-result")
+          simpleLinkI (SomeMessage MsgGenericBack) link
+
+    other -> do -- all other cases, show what can be done
+        formFailure2Alerts other
+        -- show info about assignments
+        let btnForm = wrapForm btnWdgt def
+              { formAction = SomeRoute <$> currentRoute
+              , formEncoding = btnEnctype
+              , formSubmit = FormNoSubmit
+              }
+            status = Map.empty -- allows reuse of widget
+        siteLayoutMsg headingShort $ do
+          setTitleI headingLong
+          $(widgetFile "corrections-assign-result")
+          btnForm
 
 

src/Handler/Submission.hs

@@ -611,3 +611,36 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions
     addMessageI Info MsgNoOpenSubmissions
     redirect CorrectionsR
   submissionMultiArchive $ Set.fromList subs
+
+
+getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+getSubAssignR = postSubAssignR
+postSubAssignR tid ssh csh shn cID = do
+  let actionUrl = CSubmissionR tid ssh csh shn cID SubAssignR
+  sId <- decrypt cID
+  (currentCorrector, sheetCorrectors) <- runDB $ do
+    Submission{submissionRatingBy, submissionSheet} <- get404 sId
+    sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
+    userCorrector <- traverse getJustEntity submissionRatingBy
+    return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)
+
+  $logDebugS "SubAssignR" $ tshow currentCorrector
+  let correctorField  = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
+  ((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $
+        aopt correctorField (fslI MsgCorrector) (Just currentCorrector)
+  formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
+    when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
+      now <- liftIO getCurrentTime
+      update sId  [ SubmissionRatingBy =. mbUserId
+                  , SubmissionRatingAssigned =. (now <$ mbUserId)
+                  ]
+      addMessageI Success MsgCorrectorUpdated
+    redirect actionUrl
+  let corrForm = wrapForm' BtnSave corrForm' def
+        { formAction = Just $ SomeRoute actionUrl
+        , formEncoding = corrEncoding
+        , formSubmit = FormSubmit
+        }
+  defaultLayout $ do
+      setTitleI MsgCorrectorAssignTitle
+      $(widgetFile "submission-assign")

src/Handler/Utils/Submission.hs

@@ -53,7 +53,6 @@ import Text.Hamlet (ihamletFile)
 
 import qualified Control.Monad.Catch as E (Handler(..))
 
-
 data AssignSubmissionException = NoCorrectors
                                | NoCorrectorsByProportion
                                | SubmissionsNotFound (NonNull (Set SubmissionId))

src/Utils.hs

@@ -354,7 +354,14 @@ floorToDigits :: (RealFrac a, Integral b) => b -> a -> a
 floorToDigits d x = fromInteger (floor $ x * prec) / prec
   where prec = 10^d
 
+-- | Integral division, but rounded upwards.
+ceilingDiv :: Integral a => a -> a -> a
+ceilingDiv d n = (d+n-1) `div` n
 
+-- | Integral division, rounded to custom digit; convenience function for hamlets
+roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c
+roundDiv digits numerator denominator
+  = roundToDigits digits $ fromIntegral numerator / fromIntegral denominator
 
 ------------
 -- Monoid --

src/Utils/Form.hs

@@ -189,6 +189,7 @@ data FormIdentifier
   | FIDAdminDemo
   | FIDUserDelete
   | FIDCommunication
+  | FIDAssignSubmissions
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -606,6 +607,10 @@ formFailure errs' = do
   mr <- getMessageRender
   return . FormFailure $ map mr errs'
 
+-- | Turn form errors into alerts, but otherwise do nothing at all
+formFailure2Alerts :: MonadHandler m => FormResult a -> m ()
+formFailure2Alerts = flip formResult $ const $ return ()
+
 -- | Turns errors into alerts, ignores missing forms and applies processing function
 formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
 formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x

templates/corrections-assign-result.hamlet

@@ -0,0 +1,46 @@
+$# Display a table showing the result of the corrector assignment for possibly several sheets
+$# Expected variables"
+$#  sids     :: list of SheetId
+$#  openSubs :: Map from SheetId to SubAssignInfo, a datatype collecting info about open submissions
+$#  status   :: Map from SheetId to (Set SubmissionId, Set SubmisionId), i.e. assigned submissions and unassigned submissions for that sheet
+<div .scrolltable>
+  <table .table .table--striped>
+    <tr .table__row .table__row--head>
+      <th .table__th>
+        _{MsgSheet}
+      <th .table__th>
+        _{MsgNrSubmissionsTotal}
+      <th .table__th>
+        _{MsgNrSubmissionsUnassigned}
+      <th .table__th>
+        _{MsgNrCorrectors}
+      <th .table__th>
+        _{MsgNrSubmissionsNewlyAssigned}
+      <th .table__th>
+        _{MsgNrSubmissionsNotAssigned}
+
+    $forall sid <- sids
+      $case Map.lookup sid openSubs
+        $of Nothing
+          <!-- Empty table row; should not occur. -->
+        $of Just SubAssignInfo{saiName, saiSubmissionNr, saiUnassignedNr, saiCorrectorNr}
+          <tr .table__row>
+            <td .table__td>
+              #{saiName}
+            <td .table__td>
+              #{show saiSubmissionNr}
+            <td .table__td>
+              #{show saiUnassignedNr}
+            <td .table__td>
+              #{show saiCorrectorNr}
+            $case Map.lookup sid status
+              $of Nothing
+                <td .table__td>
+                  <!-- no newly assigned submission for this sheet -->
+                <td .table__td>
+                  <!-- no newly unassigned submission for this sheet -->
+              $of Just (assigned,unassigned)
+                <td .table__td>
+                  #{show (Set.size assigned)}
+                <td .table__td>
+                  #{show (Set.size unassigned)}