Cleanup pseudonym handling

Fixes #247

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
+        WriterT . runDB . mapReaderT runWriterT $ do
-        Sheet{..} <- get404 sid
+          Sheet{..} <- get404 sid
-        (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
+          (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
-        forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
+          forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
-        now <- liftIO getCurrentTime
+          tell . All $ null unknown
-        let
+          now <- liftIO getCurrentTime
-          sps' :: [[SheetPseudonym]]
+          let
-          duplicate :: Set Pseudonym
+            sps' :: [[SheetPseudonym]]
-          ( sps'
+            duplicate :: Set Pseudonym
-            , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
+            ( sps'
-            ) = 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
+              , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
-                  known <- State.gets $ Map.member sheetPseudonymPseudonym
+              ) = 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
-                  State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
+                    known <- State.gets $ Map.member sheetPseudonymPseudonym
-                  return $ bool (p :) id known ps
+                    State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
-          submissionPrototype = Submission
+                    return $ bool (p :) id known ps
-            { submissionSheet = sid
+            submissionPrototype = Submission
-            , submissionRatingPoints = Nothing
+              { submissionSheet = sid
-            , submissionRatingComment = Nothing
+              , submissionRatingPoints = Nothing
-            , submissionRatingBy = Just uid
+              , submissionRatingComment = Nothing
-            , submissionRatingAssigned = Just now
+              , submissionRatingBy = Just uid
-            , submissionRatingTime = Nothing
+              , 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
               }
-            when (genericLength spGroup > maxSize) $
+          unless (null duplicate)
-              addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
+            $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
-          RegisteredGroups -> do
+          existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
-            groups <- E.select . E.from $ \submissionGroup -> do
+            E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
-              E.where_ . E.exists . E.from $ \submissionGroupUser ->
+            E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
-                E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
+                 E.&&. submission E.^. SubmissionSheet E.==. E.val sid
-              return $ submissionGroup E.^. SubmissionGroupId
+            return submissionUser
-            if
+          unless (null existingSubUsers) . mapReaderT lift $ do
-              | length (groups :: [E.Value SubmissionGroupId]) < 2
+            (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
-                -> do
+            $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
-                  subId <- insert submissionPrototype
+          let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
-                  void . insert $ SubmissionEdit uid now subId
+          forM_ sps'' $ \spGroup
-                  insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+            -> let
-                    { submissionUserUser = sheetPseudonymUser
+                 sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
-                    , submissionUserSubmission = subId
+                in case sheetGrouping of
-                    }
+            Arbitrary maxSize -> do
-                  when (null groups) $
+              subId <- insert submissionPrototype
-                    addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
+              void . insert $ SubmissionEdit uid now subId
-              | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
+              insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
-          NoGroups -> do
+                { submissionUserUser = sheetPseudonymUser
-            subId <- insert submissionPrototype
+                , submissionUserSubmission = subId
-            void . insert $ SubmissionEdit uid now subId
+                }
-            insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+              when (genericLength spGroup > maxSize) $
-              { submissionUserUser = sheetPseudonymUser
+                addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
-              , submissionUserSubmission = subId
+            RegisteredGroups -> do
-              }
+              let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
-            when (length spGroup > 1) $
+              groups <- E.select . E.from $ \submissionGroup -> do
-              addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
+                E.where_ . E.exists . E.from $ \submissionGroupUser ->
-      redirect CorrectionsGradeR
+                  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 $

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"