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

automatic corrector assignment

Browse Source
This commit is contained in:
Steffen Jost 2019-06-04 08:14:13 +02:00
parent 745feeac83
commit d34998ac04
10 changed files with 227 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.vscode/tasks.json vendored
View File

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

10
messages/uniworx/de.msg
View File

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

4
routes
View File

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

55
src/Foundation.hs
View File

@ -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
SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
SubmissionR _ _ -> guard active
_ -> return ()
SubmissionNewR -> guard active
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 _ SubAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
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
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, 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
}

105
src/Handler/Corrections.hs
View File

@ -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
let actionUrl = CSubmissionR tid ssh csh shn cID SAssignR
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 "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")
postSAssignR tid ssh csh shn = do
shid <- runDB $ fetchSheetId tid ssh csh shn
assignHandler tid ssh csh [shid]
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

35
src/Handler/Submission.hs
View File

@ -364,7 +364,7 @@ submissionHelper tid ssh csh shn mcid = do
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
-- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
-- Therefore we do not restrict upload behaviour in any way in that case
((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
let formWidget = wrapForm' BtnHandIn formWidget' def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype
@ -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")

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

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

7
src/Utils.hs
View File

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

7
src/Utils/Form.hs
View File

@ -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
@ -661,7 +666,7 @@ aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
writer ((a, ints, enctype), vs)
infixl 4 `fmapAForm`
fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints

46
templates/corrections-assign-result.hamlet Normal file
View File

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