diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 27205f38c..a2b36e1b4 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -53,6 +53,11 @@ "type": "npm", "script": "yesod:start", "problemMatcher": [] + }, + { + "type": "npm", + "script": "start", + "problemMatcher": [] } ] } \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8513fc2db..e1cfd10d2 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/routes b/routes index b1a1214bc..31885f668 100644 --- a/routes +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index a4fc86fb5..20d6464aa 100644 --- a/src/Foundation.hs +++ b/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 - 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 } diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index aef00e033..10364c814 100644 --- a/src/Handler/Corrections.hs +++ b/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 - 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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 12c605917..0fe085dc1 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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") diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 7356e17b0..84a747cf5 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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)) diff --git a/src/Utils.hs b/src/Utils.hs index 2080947ec..bd9364299 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2c04192ec..8a8621414 100644 --- a/src/Utils/Form.hs +++ b/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 @@ -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 diff --git a/templates/corrections-assign-result.hamlet b/templates/corrections-assign-result.hamlet new file mode 100644 index 000000000..2312758cf --- /dev/null +++ b/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 +
+ + + +
+ _{MsgSheet} + + _{MsgNrSubmissionsTotal} + + _{MsgNrSubmissionsUnassigned} + + _{MsgNrCorrectors} + + _{MsgNrSubmissionsNewlyAssigned} + + _{MsgNrSubmissionsNotAssigned} + + $forall sid <- sids + $case Map.lookup sid openSubs + $of Nothing + + $of Just SubAssignInfo{saiName, saiSubmissionNr, saiUnassignedNr, saiCorrectorNr} +
+ #{saiName} + + #{show saiSubmissionNr} + + #{show saiUnassignedNr} + + #{show saiCorrectorNr} + $case Map.lookup sid status + $of Nothing + + + + + $of Just (assigned,unassigned) + + #{show (Set.size assigned)} + + #{show (Set.size unassigned)}