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,12 +670,15 @@ 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
           (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]]
@@ -699,7 +704,7 @@ postCorrectionsCreateR = do
             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
+          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'
@@ -717,22 +722,33 @@ postCorrectionsCreateR = do
               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
-              | length (groups :: [E.Value SubmissionGroupId]) < 2
+                | [_] <- groups
+                , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers
                   -> do
                     subId <- insert submissionPrototype
                     void . insert $ SubmissionEdit uid now subId
-                  insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
-                    { submissionUserUser = sheetPseudonymUser
+                      { submissionUserUser = sheetUser
                       , submissionUserSubmission = subId
                       }
                     when (null groups) $
                       addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
-              | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup 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
@@ -742,6 +758,7 @@ postCorrectionsCreateR = do
                 }
               when (length spGroup > 1) $
                 addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
+      when allDone $
         redirect CorrectionsGradeR
 
 

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"