Automagic corrections distribution

messages/uniworx/de.msg

@@ -195,6 +195,7 @@ AddCorrector: Zusätzlicher Korrektor
 CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
 SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
+AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen
 Corrector: Korrektor
 Correctors: Korrektoren
 CorState: Status
@@ -389,11 +390,17 @@ MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{co
 MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
 MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
 
+MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden
+MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{tshow n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden.
+
 MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
 MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
 MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfrist für #{sheetName} in #{csh} abgelaufen
 MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
-MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} Abgaben wurden Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
+
+MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt
+MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} #{pluralDE n "Abgabe wurde" "Abgaben wurden"} Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
+
 MailEditNotifications: Benachrichtigungen ein-/ausschalten
 MailSubjectSupport: Supportanfrage
 
@@ -441,6 +448,7 @@ NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
 NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
 NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
 NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
+NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
 
 CorrCreate: Abgaben erstellen
 UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"

models/sheets

@@ -12,6 +12,7 @@ Sheet
     solutionFrom    UTCTime Maybe
     uploadMode      UploadMode
     submissionMode  SheetSubmissionMode default='UserSubmissions'
+    autoDistribute  Bool default=false
     CourseSheet course name
 SheetEdit
     user            UserId

src/Handler/Sheet.hs

@@ -498,6 +498,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               , sheetSolutionFrom = sfSolutionFrom
               , sheetUploadMode   = sfUploadMode
               , sheetSubmissionMode = sfSubmissionMode
+              , sheetAutoDistribute = False
               }
         mbsid <- dbAction newSheet
         case mbsid of
@@ -596,7 +597,7 @@ defaultLoads shid = do
     toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
 
 
-correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
+correctorForm :: SheetId -> MForm Handler (FormResult (Bool {- ^ autoDistribute -} , Set SheetCorrector), [FieldView UniWorX])
 correctorForm shid = do
   cListIdent <- newFormIdent
   let
@@ -609,7 +610,7 @@ correctorForm shid = do
   let
     currentLoads :: DB Loads
     currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
-  (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
+  (autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
   loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
     | Map.null currentLoads'
     , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
@@ -621,6 +622,7 @@ correctorForm shid = do
       didDelete = any (flip Set.member deletions) formCIDs
 
   (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
+  (autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
   let
     tutorField :: Field Handler [UserEmail]
     tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
@@ -714,23 +716,25 @@ correctorForm shid = do
       cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
       toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
 
-  return (corrResults, [ countTutView
+  return ( (,) <$> autoDistributeRes <*> corrResults
-                       , FieldView
+         , [ autoDistributeView
-                           { fvLabel = text $ mr MsgCorrectors
+           , countTutView
-                           , fvTooltip = Nothing
+           , FieldView
-                           , fvId = ""
+             { fvLabel = text $ mr MsgCorrectors
-                           , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
+             , fvTooltip = Nothing
-                           , fvErrors = Nothing
+             , fvId = ""
-                           , fvRequired = True
+             , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
-                           }
+             , fvErrors = Nothing
-                       , addTutView
+             , fvRequired = True
-                           { fvInput = [whamlet|
+             }
-                               <div>
+           , addTutView
-                                 ^{fvInput addTutView}
+             { fvInput = [whamlet|
-                                 <button type=submit formnovalidate data-formnorequired>Hinzufügen
+                           <div>
-                             |]
+                             ^{fvInput addTutView}
-                           }
+                             <button type=submit formnovalidate data-formnorequired>Hinzufügen
-                       ])
+                         |]
+             }
+           ])
 
   -- Eingabebox für Korrektor hinzufügen
   -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
@@ -744,7 +748,8 @@ getSCorrR tid ssh csh shn = do
 
   case res of
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-    FormSuccess res' -> runDB $ do
+    FormSuccess (autoDistribute, res') -> runDB $ do
+      update shid [ SheetAutoDistribute =. autoDistribute ]
       deleteWhere [SheetCorrectorSheet ==. shid]
       insertMany_ $ Set.toList res'
       addMessageI Success MsgCorrectorsUpdated

src/Handler/Utils/Submission.hs

@@ -12,7 +12,7 @@ module Handler.Utils.Submission
   ) where
 
 import Import hiding (joinPath)
-import Jobs
+import Jobs.Queue
 import Prelude (lcm)
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 

src/Jobs.hs

@@ -57,6 +57,7 @@ import Jobs.Handler.SendTestEmail
 import Jobs.Handler.QueueNotification
 import Jobs.Handler.HelpRequest
 import Jobs.Handler.SetLogSettings
+import Jobs.Handler.DistributeCorrections
 
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob

src/Jobs/Crontab.hs

@@ -71,6 +71,15 @@ determineCrontab = execWriterT $ do
           , cronRateLimit = appNotificationRateLimit
           , cronNotAfter  = Left appNotificationExpiration
           }             
+      when sheetAutoDistribute $
+        tell $ HashMap.singleton
+          (JobCtlQueue $ JobDistributeCorrections nSheet)
+          Cron
+            { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
+            , cronRepeat    = CronRepeatNever
+            , cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
+            , cronNotAfter  = Left nominalDay
+            }
       
       sheetSubmissions <- lift $ collateSubmissions <$> 
           selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []      

src/Jobs/Handler/DistributeCorrections.hs

@@ -0,0 +1,21 @@
+module Jobs.Handler.DistributeCorrections
+  ( dispatchJobDistributeCorrections
+  ) where
+
+import Import
+
+import Jobs.Queue
+
+import Control.Monad.Trans.Reader (mapReaderT)
+
+import Handler.Utils.Submission
+
+import qualified Data.Set as Set
+
+
+dispatchJobDistributeCorrections :: SheetId
+                                 -> Handler ()
+dispatchJobDistributeCorrections jSheet = runDBJobs $ do
+  (_, unassigned) <- mapReaderT lift $ assignSubmissions jSheet Nothing
+  unless (Set.null unassigned) $
+    queueDBJob . JobQueueNotification $ NotificationCorrectionsNotDistributed jSheet

src/Jobs/Handler/QueueNotification.hs

@@ -22,26 +22,37 @@ dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
 
   
 determineNotificationCandidates :: Notification -> DB [Entity User]
-determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
+determineNotificationCandidates NotificationSubmissionRated{..}
-  E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
+  = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
-  E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
+      E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
-  return user
+      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
-determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
+      return user
-  E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
+determineNotificationCandidates NotificationSheetActive{..}
-  E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+  = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
-  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+      E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
-  return user
+      E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
-determineNotificationCandidates NotificationSheetSoonInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
-  E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
+      return user
-  E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+determineNotificationCandidates NotificationSheetSoonInactive{..}
-  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+  = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
-  return user
+      E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
-determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do  
+      E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
-  E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse 
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
-  E.on $ lecturer E.^. LecturerUser   E.==. user E.^. UserId
+      return user
-  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+determineNotificationCandidates NotificationSheetInactive{..}
-  return user
+  = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do  
-determineNotificationCandidates NotificationCorrectionsAssigned{..} = selectList [UserId ==. nUser] [] 
+      E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse 
+      E.on $ lecturer E.^. LecturerUser   E.==. user E.^. UserId
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+      return user
+determineNotificationCandidates NotificationCorrectionsAssigned{..}
+  = selectList [UserId ==. nUser] [] 
+determineNotificationCandidates NotificationCorrectionsNotDistributed{nSheet}
+  = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do
+      E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
+      E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
+      E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+      return user
   
 classifyNotification :: Notification -> DB NotificationTrigger
 classifyNotification NotificationSubmissionRated{..} = do
@@ -53,5 +64,6 @@ classifyNotification NotificationSheetActive{} = return NTSheetActive
 classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
 classifyNotification NotificationSheetInactive{} = return NTSheetInactive
 classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
+classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed
 
 

src/Jobs/Handler/SendNotification.hs

@@ -11,6 +11,7 @@ import Jobs.Handler.SendNotification.SubmissionRated
 import Jobs.Handler.SendNotification.SheetActive
 import Jobs.Handler.SendNotification.SheetInactive
 import Jobs.Handler.SendNotification.CorrectionsAssigned
+import Jobs.Handler.SendNotification.CorrectionsNotDistributed
 
 
 dispatchJobSendNotification :: UserId -> Notification -> Handler ()

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -22,7 +22,7 @@ dispatchNotificationCorrectionsAssigned  nUser nSheet jRecipient = do
                      ]
     return (course, sheet, nbrSubs)
   when (nbrSubs > 0) . userMailT jRecipient $ do 
-    setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
+    setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
 
     MsgRenderer mr <- getMailMsgRenderer
     let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm

src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs

@@ -0,0 +1,31 @@
+module Jobs.Handler.SendNotification.CorrectionsNotDistributed
+  ( dispatchNotificationCorrectionsNotDistributed
+  ) where
+
+import Import
+
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler ()
+dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
+  (Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
+    sheet <- getJust nSheet
+    course <- belongsToJust sheetCourse sheet
+    nbrSubs <- count [ SubmissionSheet      ==. nSheet
+                     , SubmissionRatingBy   ==. Nothing
+                     ]
+    return (course, sheet, nbrSubs)
+  when (nbrSubs > 0) . userMailT jRecipient $ do 
+    setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName
+    MsgRenderer mr <- getMailMsgRenderer
+    let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+        tid = courseTerm
+        ssh = courseSchool
+        csh = courseShorthand
+        shn = sheetName
+
+    addAlternatives $
+      providePreferredAlternative ($(ihamletFile "templates/mail/correctionsUndistributed.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Queue.hs

@@ -3,6 +3,7 @@ module Jobs.Queue
   , queueJob, queueJob'
   , YesodJobDB
   , runDBJobs, queueDBJob
+  , module Jobs.Types
   ) where
 
 import Import

src/Jobs/Types.hs

@@ -19,12 +19,14 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                           , jRequestTime :: UTCTime
                           , jHelpRequest :: Text, jReferer :: Maybe Text }
          | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }         
+         | JobDistributeCorrections { jSheet :: SheetId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }
                   | NotificationSheetSoonInactive { nSheet :: SheetId }
                   | NotificationSheetInactive { nSheet :: SheetId }
                   | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
+                  | NotificationCorrectionsNotDistributed { nSheet :: SheetId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 instance Hashable Job

src/Model/Types.hs

@@ -574,6 +574,7 @@ data NotificationTrigger = NTSubmissionRatedGraded
                          | NTSheetSoonInactive
                          | NTSheetInactive
                          | NTCorrectionsAssigned
+                         | NTCorrectionsNotDistributed
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 
 instance Universe NotificationTrigger
@@ -604,6 +605,7 @@ instance Default NotificationSettings where
     NTSheetSoonInactive -> False
     NTSheetInactive -> True
     NTCorrectionsAssigned -> True
+    NTCorrectionsNotDistributed -> True
 
 instance ToJSON NotificationSettings where
   toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF

templates/mail/correctionsUndistributed.hamlet

@@ -0,0 +1,17 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailSubmissionsUnassignedIntro nbrSubs (CI.original courseName) termDesc sheetName}
+    <p>
+      <a href=@{CSheetR tid ssh csh shn SSubsR}>
+        #{sheetName}

test/Database.hs

@@ -237,11 +237,11 @@ fillDb = do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp
   void . insert $ Lecturer gkleen ffp
-  adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
+  adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
   insert_ $ SheetEdit gkleen now adhoc
-  feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
+  feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
   insert_ $ SheetEdit gkleen now feste
-  keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
+  keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
   insert_ $ SheetEdit gkleen now keine
   -- EIP
   eip <- insert' Course
@@ -330,6 +330,7 @@ fillDb = do
     , sheetUploadMode = Upload True
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
+    , sheetAutoDistribute = True
     }
   void . insert $ SheetEdit jost now sh1
   forM_ [fhamann, maxMuster, tinaTester] $ \u -> do