Subtask for #233. Rights checked for Corrector assignment

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.

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

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)
-
+        (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
-        unless (null unassigned) $ do
+        unless (null unassignedUnauth) $ do
-          num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
+          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
+                  [ SubmissionRatingBy       =. Nothing
-                  , SubmissionRatingComment  =. 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
+        (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
-          (assigned, stillUnassigned) <- assignSubmissions shid (Just 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

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

templates/messages/submissionsAssignUnauthorized.hamlet

@@ -0,0 +1,5 @@
+_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
+
+<ul>
+  $forall cID <- unassignedUnauth'
+    <li><pre>#{toPathPiece cID}