From dc4f37c921d9c1fcbee8af2e300a37aed57f0652 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 13 Nov 2018 15:36:59 +0100 Subject: [PATCH] Subtask for #233. Rights checked for Corrector assignment --- messages/uniworx/de.msg | 1 + routes | 4 +- src/Handler/Corrections.hs | 44 ++++++++++++++----- src/Utils.hs | 20 ++++++++- .../submissionsAssignUnauthorized.hamlet | 5 +++ 5 files changed, 58 insertions(+), 16 deletions(-) create mode 100644 templates/messages/submissionsAssignUnauthorized.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 14fff01cf..f28a96c9c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -231,6 +231,7 @@ CorrAutoSetCorrector: Korrekturen verteilen NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert: +SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist): UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt. NoCorrector: Kein Korrektor RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt. diff --git a/routes b/routes index b4c90b0cd..406500f4d 100644 --- a/routes +++ b/routes @@ -77,10 +77,10 @@ /subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions /subs/own SubmissionOwnR GET !free -- just redirect /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead: - / SubShowR GET POST !ownerANDtime !ownerANDisRead + / SubShowR GET POST !ownerANDtime !ownerANDisRead /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner /assign SAssignR GET POST !lecturerANDtime - /correction CorrectionR GET POST !corrector !ownerANDisReadANDrated + /correction CorrectionR GET POST !corrector !ownerANDisReadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner /correctors SCorrR GET POST /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index a64605446..06cc76545 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -302,9 +302,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) - - unless (null unassigned) $ do - num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] + (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned + unless (null unassignedUnauth) $ do + let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission + unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth + $(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet") + unless (null unassignedAuth) $ do + num <- updateWhereCount [SubmissionId <-. Set.toList unassignedAuth] [ SubmissionRatingBy =. Just uid , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned ] @@ -316,15 +320,15 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = return (E.countRows :: E.SqlExpr (E.Value Int64)) when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors redirect currentRoute - FormSuccess (CorrSetCorrectorData Nothing, subs') -> do + FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections subs <- mapM decrypt $ Set.toList subs' runDB $ do num <- updateWhereCount [SubmissionId <-. subs] - [ SubmissionRatingPoints =. Nothing - , SubmissionRatingComment =. Nothing - , SubmissionRatingBy =. Nothing + [ SubmissionRatingBy =. Nothing , SubmissionRatingAssigned =. Nothing , SubmissionRatingTime =. Nothing + -- , SubmissionRatingPoints =. Nothing -- Kept for easy reassignment by 2nd corrector + -- , SubmissionRatingComment =. Nothing -- Kept for easy reassignment by 2nd corrector ] addMessageI Success $ MsgRemovedCorrections num redirect currentRoute @@ -337,8 +341,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) - unless (null unassigned) $ do - (assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned) + (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned + unless (null unassignedUnauth) $ do + let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission + unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth + $(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet") + unless (null unassignedAuth) $ do + (assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth) unless (null assigned) $ addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) unless (null stillUnassigned) $ do @@ -350,7 +359,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") - + where + authorizedToAssign :: SubmissionId -> DB Bool + authorizedToAssign sId = do + [(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <- + E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + 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 + (== Authorized) <$> evalAccessDB route True type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) @@ -768,12 +788,12 @@ postSAssignR tid ssh csh shn cID = do sId <- decrypt cID (currentCorrector, sheetCorrectors) <- runDB $ do Submission{submissionRatingBy, submissionSheet} <- get404 sId - -- Beginn Verify that CryptoId matches ordinary prameters + -- Beginn Verify that CryptoId matches ordinary prameters, see #233 -- Necessarry, since authorisation checks those parameters only, but can be changed by user! Sheet{sheetCourse, sheetName} <- get404 submissionSheet Course{courseTerm, courseSchool, courseShorthand} <- get404 sheetCourse let cidMatches = and [tid==courseTerm, ssh==courseSchool, csh==courseShorthand, shn==sheetName] - unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] + unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] -- maybe remove message if refactored -- End Verification sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] [] userCorrector <- traverse getJustEntity submissionRatingBy diff --git a/src/Utils.hs b/src/Utils.hs index 23dc860ff..c035e8d93 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -306,9 +306,9 @@ ifMaybeM (Just x) _ act = act x maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if maybePositive a | a > 0 = Just a - | otherwise = Nothing + | otherwise = Nothing -positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive +positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive positiveSum (Sum x) = maybePositive x maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b @@ -443,6 +443,22 @@ orM = Fold.foldr or2M (return False) anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool anyM xs f = orM $ fmap f xs +partitionM :: forall mono m . + ( MonoFoldable mono + , Monoid mono + , MonoPointed mono + , Monad m) + => (Element mono -> m Bool) -> mono -> m (mono, mono) +partitionM crit = ofoldlM dist mempty + where + dist :: (mono,mono) -> Element mono -> m (mono,mono) + dist acc x = do + okay <- crit x + return $ if + | okay -> acc `mappend` (opoint x, mempty) + | otherwise -> acc `mappend` (mempty, opoint x) + + -------------- -- Sessions -- -------------- diff --git a/templates/messages/submissionsAssignUnauthorized.hamlet b/templates/messages/submissionsAssignUnauthorized.hamlet new file mode 100644 index 000000000..f0002faed --- /dev/null +++ b/templates/messages/submissionsAssignUnauthorized.hamlet @@ -0,0 +1,5 @@ +_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))} + +