diff --git a/src/Foundation.hs b/src/Foundation.hs index 4567440f8..7ce7a5eed 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1744,7 +1744,7 @@ pageActions InstanceR = [ ] pageActions (HelpR) = [ -- MenuItem - -- { menuItemType = PageActionPrime + -- { menuItemType = PageActionPrime -- , menuItemLabel = MsgInfoLecturerTitle -- , menuItemIcon = Nothing -- , menuItemRoute = SomeRoute InfoLecturerR @@ -1754,7 +1754,7 @@ pageActions (HelpR) = [ ] pageActions (ProfileR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuProfileData , menuItemIcon = Just "book" , menuItemRoute = SomeRoute ProfileDataR @@ -1762,7 +1762,7 @@ pageActions (ProfileR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuAuthPreds , menuItemIcon = Nothing , menuItemRoute = SomeRoute AuthPredsR @@ -1772,7 +1772,7 @@ pageActions (ProfileR) = ] pageActions TermShowR = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuTermCreate , menuItemIcon = Nothing , menuItemRoute = SomeRoute TermEditR @@ -1782,7 +1782,7 @@ pageActions TermShowR = ] pageActions (TermCourseListR tid) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCourseNew , menuItemIcon = Just "book" , menuItemRoute = SomeRoute CourseNewR @@ -1790,7 +1790,7 @@ pageActions (TermCourseListR tid) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuTermEdit , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ TermEditExistR tid @@ -1810,7 +1810,7 @@ pageActions (TermSchoolCourseListR _tid _ssh) = ] pageActions (CourseListR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCourseNew , menuItemIcon = Just "book" , menuItemRoute = SomeRoute CourseNewR @@ -1820,7 +1820,7 @@ pageActions (CourseListR) = ] pageActions (CourseNewR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgInfoLecturerTitle , menuItemIcon = Nothing , menuItemRoute = SomeRoute InfoLecturerR @@ -1849,7 +1849,7 @@ pageActions (CourseR tid ssh csh CShowR) = in runDB $ lecturerAccess `or2M` existsVisible } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetList , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR @@ -1877,7 +1877,7 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseMembers , menuItemIcon = Just "user-graduate" , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR @@ -1885,7 +1885,7 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseCommunication , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR @@ -1893,7 +1893,7 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseEdit , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR @@ -1901,7 +1901,7 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseClone , menuItemIcon = Just "copy" , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) @@ -1909,9 +1909,9 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseDelete - , menuItemIcon = Just "trash" + , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR , menuItemModal = False , menuItemAccessCallback' = return True @@ -1919,17 +1919,17 @@ pageActions (CourseR tid ssh csh CShowR) = ] pageActions (CourseR tid ssh csh CCorrectionsR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CourseR tid ssh csh SheetListR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetCurrent , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR @@ -1939,7 +1939,7 @@ pageActions (CourseR tid ssh csh SheetListR) = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetOldUnassigned , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR @@ -1949,25 +1949,25 @@ pageActions (CourseR tid ssh csh SheetListR) = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsOwn - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) , ("corrections-school", CI.original $ unSchoolKey ssh) , ("corrections-course", CI.original csh) @@ -1988,7 +1988,7 @@ pageActions (CourseR tid ssh csh SheetListR) = return ok } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetNew , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR @@ -2082,7 +2082,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissionNew , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR @@ -2094,7 +2094,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissionOwn , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR @@ -2118,49 +2118,49 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectors - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetEdit - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSheetClone - , menuItemIcon = Just "copy" + , menuItemIcon = Just "copy" , menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSheetDelete - , menuItemIcon = Just "trash" + , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR , menuItemModal = False , menuItemAccessCallback' = return True @@ -2168,7 +2168,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = ] pageActions (CSheetR tid ssh csh shn SSubsR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissionNew , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR @@ -2176,25 +2176,25 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectors - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrection , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR @@ -2202,7 +2202,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgCorrectorAssignTitle , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR @@ -2210,7 +2210,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSubmissionDelete , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR @@ -2220,7 +2220,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = ] pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = [ MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSubmissionDelete , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR @@ -2230,17 +2230,17 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = ] pageActions (CSheetR tid ssh csh shn SCorrR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSheetEdit - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR , menuItemModal = False , menuItemAccessCallback' = return True diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 9bb44bf00..dc55df410 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -67,6 +67,24 @@ assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors , Set SubmissionId ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load assignSubmissions sid restriction = do + newSubmissionData <- planSubmissions sid restriction + now <- liftIO getCurrentTime + execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, mCorrector) -> case mCorrector of + Just corrector -> do + lift $ update subId [ SubmissionRatingBy =. Just corrector + , SubmissionRatingAssigned =. Just now + ] + tell (Set.singleton subId, mempty) + Nothing -> + tell (mempty, Set.singleton subId) + + +-- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet! +planSubmissions :: SheetId -- ^ Sheet to distribute to correctors + -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider + -> YesodDB UniWorX (Map SubmissionId (Maybe UserId)) + -- ^ Return map that assigns submissions to Corrector +planSubmissions sid restriction = do Sheet{..} <- getJust sid correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet @@ -210,15 +228,7 @@ assignSubmissions sid restriction = do ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) - now <- liftIO getCurrentTime - execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, (mCorrector, _, _)) -> case mCorrector of - Just corrector -> do - lift $ update subId [ SubmissionRatingBy =. Just corrector - , SubmissionRatingAssigned =. Just now - ] - tell (Set.singleton subId, mempty) - Nothing -> - tell (mempty, Set.singleton subId) + return $ fmap (view _1) newSubmissionData where maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs