fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Automagic corrections distribution

Browse Source
This commit is contained in:
Gregor Kleen 2018-12-21 14:59:28 +01:00
parent 9895d725ec
commit 3a0b79e137
16 changed files with 158 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
messages/uniworx/de.msg
View File

@ -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}"

1
models/sheets
View File

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

45
src/Handler/Sheet.hs
View File

@ -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
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Nothing
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|]
}
])
return ( (,) <$> autoDistributeRes <*> corrResults
, [ autoDistributeView
, countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Nothing
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<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

2
src/Handler/Utils/Submission.hs
View File

@ -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(..))

1
src/Jobs.hs
View File

@ -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

9
src/Jobs/Crontab.hs
View File

@ -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] []

21
src/Jobs/Handler/DistributeCorrections.hs Normal file
View File

@ -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

52
src/Jobs/Handler/QueueNotification.hs
View File

@ -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
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
return user
determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetSoonInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetInactive{..} = 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
determineNotificationCandidates NotificationCorrectionsAssigned{..} = selectList [UserId ==. nUser] []
determineNotificationCandidates NotificationSubmissionRated{..}
= E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
return user
determineNotificationCandidates NotificationSheetActive{..}
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetSoonInactive{..}
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetInactive{..}
= 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
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

1
src/Jobs/Handler/SendNotification.hs
View File

@ -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 ()

2
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -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

31
src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs Normal file
View File

@ -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))

1
src/Jobs/Queue.hs
View File

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

2
src/Jobs/Types.hs
View File

@ -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

2
src/Model/Types.hs
View File

@ -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

17
templates/mail/correctionsUndistributed.hamlet Normal file
View File

@ -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}

7
test/Database.hs
View File

@ -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