From 19413380753684aa0d378e31f7e489279d0c5b0b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 5 Dec 2018 21:52:37 +0100 Subject: [PATCH] Cleanup pseudonym handling Fixes #247 --- src/Handler/Corrections.hs | 167 ++++++++++++++++++++----------------- test/Database.hs | 10 ++- 2 files changed, 101 insertions(+), 76 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 31465c5f8..803ef4bae 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -14,12 +14,13 @@ import Utils.Lens import Data.Set (Set) import qualified Data.Set as Set -import Data.Map (Map) +import Data.Map (Map, (!)) import qualified Data.Map as Map import qualified Data.Text as Text import Data.Semigroup (Sum(..)) +import Data.Monoid (All(..)) -- import Data.Time -- import qualified Data.Text as T @@ -46,7 +47,8 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) -import Control.Monad.Trans.Writer (WriterT(..), runWriter) +import Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT) +import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Trans.RWS (RWST) @@ -668,81 +670,96 @@ postCorrectionsCreateR = do FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, (pss, invalids)) -> do - forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet") + allDone <- fmap getAll . execWriterT $ do + forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet") + tell . All $ null invalids - runDB $ do - Sheet{..} <- get404 sid - (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) - forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText - now <- liftIO getCurrentTime - let - sps' :: [[SheetPseudonym]] - duplicate :: Set Pseudonym - ( sps' - , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate - ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do - known <- State.gets $ Map.member sheetPseudonymPseudonym - State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) - return $ bool (p :) id known ps - submissionPrototype = Submission - { submissionSheet = sid - , submissionRatingPoints = Nothing - , submissionRatingComment = Nothing - , submissionRatingBy = Just uid - , submissionRatingAssigned = Just now - , submissionRatingTime = Nothing - } - unless (null duplicate) - $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") - existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do - E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') - E.&&. submission E.^. SubmissionSheet E.==. E.val sid - return submissionUser - unless (null existingSubUsers) $ do - (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers - $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet") - let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' - forM_ sps'' $ \spGroup - -> let - sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup - in case sheetGrouping of - Arbitrary maxSize -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId + WriterT . runDB . mapReaderT runWriterT $ do + Sheet{..} <- get404 sid + (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) + forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText + tell . All $ null unknown + now <- liftIO getCurrentTime + let + sps' :: [[SheetPseudonym]] + duplicate :: Set Pseudonym + ( sps' + , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate + ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do + known <- State.gets $ Map.member sheetPseudonymPseudonym + State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) + return $ bool (p :) id known ps + submissionPrototype = Submission + { submissionSheet = sid + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Just uid + , submissionRatingAssigned = Just now + , submissionRatingTime = Nothing } - when (genericLength spGroup > maxSize) $ - addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc - RegisteredGroups -> do - groups <- E.select . E.from $ \submissionGroup -> do - E.where_ . E.exists . E.from $ \submissionGroupUser -> - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) - return $ submissionGroup E.^. SubmissionGroupId - if - | length (groups :: [E.Value SubmissionGroupId]) < 2 - -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId - } - when (null groups) $ - addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc - | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc - NoGroups -> do - subId <- insert submissionPrototype - void . insert $ SubmissionEdit uid now subId - insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser - { submissionUserUser = sheetPseudonymUser - , submissionUserSubmission = subId - } - when (length spGroup > 1) $ - addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc - redirect CorrectionsGradeR + unless (null duplicate) + $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") + existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') + E.&&. submission E.^. SubmissionSheet E.==. E.val sid + return submissionUser + unless (null existingSubUsers) . mapReaderT lift $ do + (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers + $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet") + let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' + forM_ sps'' $ \spGroup + -> let + sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup + in case sheetGrouping of + Arbitrary maxSize -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + when (genericLength spGroup > maxSize) $ + addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc + RegisteredGroups -> do + let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup + groups <- E.select . E.from $ \submissionGroup -> do + E.where_ . E.exists . E.from $ \submissionGroupUser -> + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) + return $ submissionGroup E.^. SubmissionGroupId + groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups) + return $ submissionGroupUser E.^. SubmissionGroupUserUser + if + | [_] <- groups + , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers + -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser + { submissionUserUser = sheetUser + , submissionUserSubmission = subId + } + when (null groups) $ + addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc + | length groups < 2 + -> do + forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do + addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym) + tell $ All False + | otherwise -> + addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc + NoGroups -> do + subId <- insert submissionPrototype + void . insert $ SubmissionEdit uid now subId + insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser + { submissionUserUser = sheetPseudonymUser + , submissionUserSubmission = subId + } + when (length spGroup > 1) $ + addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc + when allDone $ + redirect CorrectionsGradeR defaultLayout $ diff --git a/test/Database.hs b/test/Database.hs index 0308a3dfa..1e42ecaf6 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -24,6 +24,9 @@ import qualified Data.ByteString as BS import Data.Time +import Utils.Lens (review) +import Control.Monad.Random.Class (MonadRandom(..)) + data DBAction = DBClear | DBTruncate @@ -151,7 +154,7 @@ fillDb = do , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } - void . insert $ User + tinaTester <- insert $ User { userIdent = "tester@campus.lmu.de" , userAuthentication = AuthLDAP , userMatrikelnummer = Just "999" @@ -312,6 +315,7 @@ fillDb = do insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo + void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester] sh1 <- insert Sheet { sheetCourse = pmo , sheetName = "Blatt 1" @@ -328,6 +332,10 @@ fillDb = do , sheetSolutionFrom = Nothing } void . insert $ SheetEdit jost now sh1 + forM_ [fhamann, maxMuster, tinaTester] $ \u -> do + p <- liftIO getRandom + $logDebug (review _PseudonymText p) + void . insert $ SheetPseudonym sh1 p u void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal h102 <- insertFile "H10-2.hs"