Pseudonym submission creation

2018-10-15 15:02:44 +02:00 · 2018-10-15 15:02:44 +02:00 · f07ad82c1d
commit f07ad82c1d
parent 2d90eef867
17 changed files with 300 additions and 24 deletions
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@ -363,4 +363,19 @@ SheetFiles: Übungsblatt-Dateien
 NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
 NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
 NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
-NotificationTriggerSheetInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
+NotificationTriggerSheetInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
+
+CorrCreate: Abgaben erstellen
+UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
+InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"
+UnknownPseudonym pseudonym@Text: Unbekanntes Pseudonym "#{pseudonym}"
+CorrectionPseudonyms: Abgaben-Pseudonyme
+CorrectionPseudonymsTip: Eine Abgabe pro Zeile, bei Gruppenabgaben mehrere Pseudonyme (komma-separiert) innerhalb einer Zeile
+PseudonymSheet: Übungsblatt
+CorrectionPseudonymSheet termDesc@Text csh@CourseShorthand shn@SheetName: #{termDesc} > #{csh} > #{shn}
+SheetGroupTooLarge sheetGroupDesc@Text: Abgabegruppe zu groß: #{sheetGroupDesc}
+SheetNoRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" sind nicht als Gruppe registriert
+SheetAmbiguousRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" enthält Mitglieder aus verschiedenen registrierten Gruppen
+SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt nicht vorgesehen (#{sheetGroupDesc})
+SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert:
+SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben:
--- a/1
+++ b/1
@ -86,6 +86,7 @@

 /corrections  CorrectionsR GET POST !corrector !lecturer
 /corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
+/corrections/create CorrectionsCreateR GET POST !corrector !lecturer


 !/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
--- a/src/CryptoID.hs
+++ b/src/CryptoID.hs
@ -38,6 +38,7 @@ import qualified Data.CaseInsensitive as CI
 decCryptoIDs [ ''SubmissionId
             , ''FileId
             , ''UserId
+             , ''SheetId
             ]

 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@ -159,6 +159,7 @@ data MenuItem = MenuItem
    , menuItemIcon  :: Maybe Text
    , menuItemRoute :: Route UniWorX
    , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked)
+    , menuItemModal :: Bool
    }

 menuItemAccessCallback :: MenuItem -> Handler Bool
@ -610,7 +611,7 @@ instance Yesod UniWorX where

        let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute

-        menuTypes <- filterM (menuItemAccessCallback . menuItem) menu
+        menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu

        isAuth <- isJust <$> maybeAuthId

@ -633,7 +634,7 @@ instance Yesod UniWorX where

        let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
            highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
-                            navItems = map snd3 favourites ++ map (menuItemRoute . menuItem) menuTypes
+                            navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes
                            highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
                        in \r -> Just r == highR
            favouriteTerms :: [TermIdentifier]
@ -665,7 +666,7 @@ instance Yesod UniWorX where
            isPageActionPrime (PageActionSecondary _) = True
            isPageActionPrime _ = False
            hasPageActions :: Bool
-            hasPageActions = any isPageActionPrime menuTypes
+            hasPageActions = any (isPageActionPrime . fst) menuTypes

        pc <- widgetToPageContent $ do
            addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600"
@ -798,54 +799,63 @@ defaultLinks = -- Define the menu items of the header.
      { menuItemLabel = "Home"
      , menuItemIcon = Just "home"
      , menuItemRoute = HomeR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , NavbarRight $ MenuItem
      { menuItemLabel = "Impressum"
      , menuItemIcon  = Just "book"
      , menuItemRoute = VersionR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , NavbarRight $ MenuItem
      { menuItemLabel = "Profil"
      , menuItemIcon = Just "cogs"
      , menuItemRoute = ProfileR
+      , menuItemModal = False
      , menuItemAccessCallback' = isJust <$> maybeAuthPair
      }
  , NavbarSecondary $ MenuItem
      { menuItemLabel = "Login"
      , menuItemIcon = Just "sign-in-alt"
      , menuItemRoute = AuthR LoginR
+      , menuItemModal = True
      , menuItemAccessCallback' = isNothing <$> maybeAuthPair
      }
  , NavbarSecondary $ MenuItem
      { menuItemLabel = "Logout"
      , menuItemIcon = Just "sign-out-alt"
      , menuItemRoute = AuthR LogoutR
+      , menuItemModal = False
      , menuItemAccessCallback' = isJust <$> maybeAuthPair
      }
  , NavbarAside $ MenuItem
      { menuItemLabel = "Kurse"
      , menuItemIcon = Just "calendar-alt"
      , menuItemRoute = CourseListR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , NavbarAside $ MenuItem
      { menuItemLabel = "Semester"
      , menuItemIcon = Just "graduation-cap"
      , menuItemRoute = TermShowR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , NavbarAside $ MenuItem
      { menuItemLabel = "Korrekturen"
      , menuItemIcon = Just "check"
      , menuItemRoute = CorrectionsR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , NavbarAside $ MenuItem
      { menuItemLabel = "Benutzer"
      , menuItemIcon = Just "users"
      , menuItemRoute = UsersR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
      }
  ]
@ -871,6 +881,7 @@ pageActions (HomeR) =
      { menuItemLabel = "AdminDemo"
      , menuItemIcon  = Just "screwdriver"
      , menuItemRoute = AdminTestR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -879,6 +890,7 @@ pageActions (ProfileR) =
      { menuItemLabel = "Gespeicherte Daten anzeigen"
      , menuItemIcon  = Just "book"
      , menuItemRoute = ProfileDataR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -887,6 +899,7 @@ pageActions TermShowR =
      { menuItemLabel = "Neues Semester anlegen"
      , menuItemIcon  = Nothing
      , menuItemRoute = TermEditR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -895,12 +908,14 @@ pageActions (TermCourseListR tid) =
      { menuItemLabel = "Neuen Kurs anlegen"
      , menuItemIcon  = Just "book"
      , menuItemRoute = CourseNewR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , PageActionPrime $ MenuItem
      { menuItemLabel = "Semster editieren"
      , menuItemIcon  = Nothing
      , menuItemRoute = TermEditExistR tid
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -909,6 +924,7 @@ pageActions (CourseListR) =
      { menuItemLabel = "Neuen Kurs anlegen"
      , menuItemIcon  = Just "book"
      , menuItemRoute = CourseNewR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -917,6 +933,7 @@ pageActions (CourseR tid ssh csh CShowR) =
      { menuItemLabel = "Übungsblätter"
      , menuItemIcon  = Nothing
      , menuItemRoute = CourseR tid ssh csh SheetListR
+      , menuItemModal = False
      , menuItemAccessCallback' = do --TODO always show for lecturer
          let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
          muid <- maybeAuthId
@ -933,24 +950,28 @@ pageActions (CourseR tid ssh csh CShowR) =
      { menuItemLabel = "Abgaben"
      , menuItemIcon = Nothing
      , menuItemRoute = CourseR tid ssh csh CCorrectionsR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , PageActionPrime $ MenuItem
      { menuItemLabel = "Neues Übungsblatt anlegen"
      , menuItemIcon  = Nothing
      , menuItemRoute = CourseR tid ssh csh SheetNewR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , PageActionSecondary $ MenuItem
      { menuItemLabel = "Kurs editieren"
      , menuItemIcon  = Nothing
      , menuItemRoute = CourseR tid ssh csh CEditR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , PageActionSecondary $ MenuItem
      { menuItemLabel = "Neuen Kurs klonen"
      , menuItemIcon  = Nothing
      , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -959,6 +980,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
      { menuItemLabel = "Neues Übungsblatt anlegen"
      , menuItemIcon  = Nothing
      , menuItemRoute = CourseR tid ssh csh SheetNewR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -967,6 +989,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
      { menuItemLabel = "Abgabe anlegen"
      , menuItemIcon  = Nothing
      , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR
+      , menuItemModal = True
      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
          uid <- MaybeT $ liftHandlerT maybeAuthId
          submissions <- lift $ submissionList tid csh shn uid
@ -977,6 +1000,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
      { menuItemLabel = "Abgabe ansehen"
      , menuItemIcon  = Nothing
      , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR
+      , menuItemModal = False
      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
          uid <- MaybeT $ liftHandlerT maybeAuthId
          submissions <- lift $ submissionList tid csh shn uid
@ -987,18 +1011,21 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
      { menuItemLabel = "Korrektoren"
      , menuItemIcon = Nothing
      , menuItemRoute = CSheetR tid ssh csh shn SCorrR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , PageActionPrime $ MenuItem
      { menuItemLabel = "Abgaben"
      , menuItemIcon = Nothing
      , menuItemRoute = CSheetR tid ssh csh shn SSubsR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , PageActionPrime $ MenuItem
      { menuItemLabel = "Blatt Editieren"
      , menuItemIcon = Nothing
      , menuItemRoute = CSheetR tid ssh csh shn SEditR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -1007,6 +1034,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
      { menuItemLabel = "Korrektoren"
      , menuItemIcon = Nothing
      , menuItemRoute = CSheetR tid ssh csh shn SCorrR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -1015,6 +1043,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
      { menuItemLabel = "Korrektur"
      , menuItemIcon  = Nothing
      , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -1023,12 +1052,14 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
      { menuItemLabel = "Abgaben"
      , menuItemIcon = Nothing
      , menuItemRoute = CSheetR tid ssh csh shn SSubsR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  , PageActionSecondary $ MenuItem
      { menuItemLabel = "Edit " <> (CI.original shn)
      , menuItemIcon = Nothing
      , menuItemRoute = CSheetR tid ssh csh shn SEditR
+      , menuItemModal = False
      , menuItemAccessCallback' = return True
      }
  ]
@ -1037,8 +1068,22 @@ pageActions (CorrectionsR) =
      { menuItemLabel = "Korrekturen hochladen"
      , menuItemIcon = Nothing
      , menuItemRoute = CorrectionsUploadR
+      , menuItemModal = True
      , menuItemAccessCallback' = return True
      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Abgaben erstellen"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CorrectionsCreateR
+      , menuItemModal = True
+      , menuItemAccessCallback' = runDB $ do
+          uid <- liftHandlerT requireAuthId
+          [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
+            E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+            return E.countRows
+          return $ (count :: Int) /= 0
+      }
  ]
 pageActions _ = []

@ -1130,6 +1175,8 @@ pageHeading CorrectionsR
  = Just $ i18nHeading MsgCorrectionsTitle
 pageHeading CorrectionsUploadR
  = Just $ i18nHeading MsgCorrUpload
+pageHeading CorrectionsCreateR
+  = Just $ i18nHeading MsgCorrCreate

 -- TODO: add headings for more single course- and single term-pages
 pageHeading _
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@ -26,6 +26,8 @@ import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
 -- import Handler.Utils.Zip

+import Utils.Lens
+
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map)
@ -33,6 +35,8 @@ import qualified Data.Map as Map

 import qualified Data.Text as Text

+import Data.Semigroup (Sum(..))
+
 -- import Data.Time
 -- import qualified Data.Text as T
 -- import Data.Function ((&))
@ -46,7 +50,6 @@ import Colonnade hiding (fromMaybe, singleton, bool)
 import qualified Database.Esqueleto as E
 -- import qualified Database.Esqueleto.Internal.Sql as E

-import Control.Lens
 -- import Control.Monad.Writer (MonadWriter(..), execWriterT)

 -- import Network.Mime
@ -60,6 +63,18 @@ import Database.Persist.Sql (updateWhereCount)

 import Data.List (genericLength)

+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+import Control.Monad.Trans.State (State, StateT(..), runState)
+import qualified Control.Monad.State.Class as State
+
+import Data.Foldable (foldrM)
+import Data.Traversable (for)
+


 type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
@ -543,3 +558,135 @@ postCorrectionsUploadR = do

  defaultLayout $ do
    $(widgetFile "corrections-upload")
+
+getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
+getCorrectionsCreateR = postCorrectionsCreateR
+postCorrectionsCreateR = do
+  uid <- requireAuthId
+  let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
+        E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+        E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
+             E.&&. sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+        E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
+        return $ (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
+      mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
+      mkOptList opts = do
+        opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts
+        MsgRenderer mr <- getMsgRenderer
+        return . mkOptionList $ do
+          (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts'
+          let tid' = mr $ ShortTermIdentifier (unTermKey tid)
+          return Option
+            { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn
+            , optionInternalValue = sid
+            , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet)
+            }
+  ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,)
+    <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing
+    <*> areq (checkMMap textToList textFromList textareaField) (fslpI MsgCorrectionPseudonyms "Pseudonyme" & setTooltip MsgCorrectionPseudonymsTip) Nothing
+    <* submitButton
+
+  case pseudonymRes of
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    FormSuccess (sid, pss) -> do
+      runDB $ do
+        Sheet{..} <- get404 sid
+        (sps, unknown) <- fmap partition . 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
+          submission = Submission
+            { submissionSheet = sid
+            , submissionRatingPoints = Nothing
+            , submissionRatingComment = Nothing
+            , submissionRatingBy = Just uid
+            , submissionRatingAssigned = Just now
+            , submissionRatingTime = Nothing
+            }
+        when (not $ null duplicate)
+          $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
+        existingSubUsers <- E.select . E.from $ \submissionUser -> do
+          E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
+          return submissionUser
+        when (not $ 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
+            | genericLength sps > maxSize
+              -> addMessageI Error $ MsgSheetGroupTooLarge sheetGroupDesc
+            | otherwise
+              -> do
+                subId <- insert submission
+                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    { submissionUserUser = sheetPseudonymUser
+                    , submissionUserSubmission = subId
+                    }
+          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
+            case (groups :: [E.Value SubmissionGroupId]) of
+              [x] -> do
+                subId <- insert submission
+                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    { submissionUserUser = sheetPseudonymUser
+                    , submissionUserSubmission = subId
+                    }
+              [] -> do
+                subId <- insert submission
+                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    { submissionUserUser = sheetPseudonymUser
+                    , submissionUserSubmission = subId
+                    }               
+                addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
+              _ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
+          NoGroups
+            | [SheetPseudonym{sheetPseudonymUser}] <- spGroup
+              -> do
+                subId <- insert submission
+                insert_ SubmissionUser
+                  { submissionUserUser = sheetPseudonymUser
+                  , submissionUserSubmission = subId
+                  }
+            | otherwise -> do
+                subId <- insert submission
+                insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                    { submissionUserUser = sheetPseudonymUser
+                    , submissionUserSubmission = subId
+                    }               
+                addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
+                
+  
+  defaultLayout $ do
+    $(widgetFile "corrections-create")
+  where
+    partition :: [[Either a b]] -> ([[b]], [a])
+    partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers) 
+    
+    textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
+    textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws)
+      = let
+          invalid :: [Text]
+          valid :: [[Pseudonym]]
+          (valid, invalid) = partition $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws
+        in case invalid of
+             (i:_) -> return . Left $ MsgInvalidPseudonym i
+             []    -> return $ Right valid
+    textFromList :: [[Pseudonym]] -> Textarea
+    textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText))
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -235,6 +235,15 @@ submissionModeField = selectFieldList
  , (MsgSheetUserSubmissions, UserSubmissions)
  ]

+pseudonymWordField :: Field Handler PseudonymWord
+pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
+  where
+    doCheck (CI.mk -> w)
+      | Just w' <- find (== w) pseudonymWordlist
+      = return $ Right w'
+      | otherwise
+      = return . Left $ MsgUnknownPseudonymWord (CI.original w)
+
 zipFileField :: Bool -- ^ Unpack zips?
             -> Field Handler (Source Handler File)
 zipFileField doUnpack = Field{..}
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@ -604,6 +604,15 @@ pseudonymWords = prism' pToWords pFromWords
    maxWord :: Num a => a
    maxWord = 0b111111111111

+pseudonymText :: Prism' Text Pseudonym
+pseudonymText = iso tFromWords tToWords . pseudonymWords
+  where
+    tFromWords :: Text -> [PseudonymWord]
+    tFromWords = map CI.mk . Text.words
+
+    tToWords :: [PseudonymWord] -> Text
+    tToWords = Text.unwords . map CI.original
+

 -- Type synonyms

--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@ -129,8 +129,8 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass)
 setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
 setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }

-addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a
-addDatalist field mValues = field
+addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
+addDatalist mValues field = field
  { fieldView = \fId fName fAttrs fRes fReq -> do
      listId <- newIdent
      values <- map toPathPiece . otoList <$> mValues
--- a/src/Utils/Message.hs
+++ b/src/Utils/Message.hs
@ -1,11 +1,13 @@
 {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveLift #-}


 module Utils.Message
  ( MessageClass(..)
-  , addMessage, addMessageI
+  , addMessage, addMessageI, addMessageIHamlet, addMessageFile
  ) where


@ -16,9 +18,14 @@ import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
 import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
 import ClassyPrelude.Yesod hiding (addMessage, addMessageI)

+import Text.Hamlet
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift)
+

 data MessageClass = Error | Warning | Info | Success
-  deriving (Eq,Ord,Enum,Bounded,Show,Read)
+  deriving (Eq,Ord,Enum,Bounded,Show,Read,Lift)

 instance Universe MessageClass
 instance Finite   MessageClass
@ -34,3 +41,14 @@ addMessage mc  = ClassyPrelude.Yesod.addMessage  (toPathPiece mc)

 addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
 addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
+
+addMessageIHamlet :: ( MonadHandler m
+                     , RenderMessage (HandlerSite m) msg
+                     , HandlerSite m ~ site
+                     ) => MessageClass -> HtmlUrlI18n msg (Route site) -> m ()
+addMessageIHamlet mc iHamlet = do
+  mr <- getMessageRender
+  ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
+
+addMessageFile :: MessageClass -> FilePath -> ExpQ
+addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
--- a/templates/corrections-create.hamlet
+++ b/templates/corrections-create.hamlet
@ -0,0 +1,2 @@
+<form method=post action=@{CorrectionsCreateR} enctype=#{pseudonymEncoding}>
+  ^{pseudonymWidget}
--- a/templates/default-layout.lucius
+++ b/templates/default-layout.lucius
@ -524,3 +524,6 @@ section:last-of-type {
    border-bottom: none;
 }

+.pseudonym {
+    font-family: monospace;
+}
--- a/templates/messages/submissionCreateDuplicates.hamlet
+++ b/templates/messages/submissionCreateDuplicates.hamlet
@ -0,0 +1,6 @@
+_{MsgSheetDuplicatePseudonym}
+
+<ul>
+  $forall p <- duplicate
+    <li .pseudonym>
+      #{review pseudonymText p}
--- a/templates/messages/submissionCreateExisting.hamlet
+++ b/templates/messages/submissionCreateExisting.hamlet
@ -0,0 +1,9 @@
+_{MsgSheetCreateExisting}
+
+<dl>
+  $forall (subId, pseudos) <- subs
+    <dt>#{toPathPiece subId}
+    <dd>
+      <ul>
+        $forall p <- pseudos
+          <li .pseudonym>#{review pseudonymText p}
--- a/templates/sheetShow.cassius
+++ b/templates/sheetShow.cassius
@ -1,2 +0,0 @@
-.pseudonym
-  font-family: monospace
--- a/templates/standalone/modal.julius
+++ b/templates/standalone/modal.julius
@ -56,6 +56,7 @@

      if (modal.dataset.dynamic === 'True') {
        var dynamicContentURL = trigger.getAttribute('href');
+        console.log(dynamicContentURL);
        if (dynamicContentURL.length > 0) {
          fetch(dynamicContentURL, {
            credentials: 'same-origin',
--- a/templates/widgets/navbar.hamlet
+++ b/templates/widgets/navbar.hamlet
@ -12,26 +12,32 @@ $newline never
          <i .fas.fa-star>
          <div .navbar__link-label> Favorites

-      $forall menuType <- menuTypes
+      $forall (menuType, menuIdent) <- menuTypes
        $case menuType
-          $of NavbarAside (MenuItem label mIcon route _)
+          $of NavbarAside (MenuItem label mIcon route _ isModal)
            <li .navbar__list-item :highlight route:.navbar__list-item--active>
-              <a .navbar__link-wrapper href=@{route}>
+              $if isModal
+                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
+              <a .navbar__link-wrapper href=@{route} ##{menuIdent}>
                <i .fas.fa-#{fromMaybe "none" mIcon}>
                <div .navbar__link-label>#{label}
          $of _

    <ul .navbar__list.list--inline>
-      $forall menuType <- menuTypes
+      $forall (menuType, menuIdent) <- menuTypes
        $case menuType
-          $of NavbarRight (MenuItem label mIcon route _)
+          $of NavbarRight (MenuItem label mIcon route _ isModal)
            <li .navbar__list-item :Just route == mcurrentRoute:.navbar__list-item--active>
-              <a .navbar__link-wrapper href=@{route}>
+              $if isModal
+                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
+              <a .navbar__link-wrapper href=@{route} ##{menuIdent}>
                <i .fas.fa-#{fromMaybe "none" mIcon}>
                <div .navbar__link-label>#{label}
-          $of NavbarSecondary (MenuItem label mIcon route _)
+          $of NavbarSecondary (MenuItem label mIcon route _ isModal)
            <li .navbar__list-item.navbar__list-item--secondary :Just route == mcurrentRoute:.navbar__list-item--active>
-              <a .navbar__link-wrapper href=@{route}>
+              $if isModal
+                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
+              <a .navbar__link-wrapper href=@{route} ##{menuIdent}>
                <i .fas.fa-#{fromMaybe "none" mIcon}>
                <div .navbar__link-label>#{label}
          $of _
--- a/templates/widgets/pageactionprime.hamlet
+++ b/templates/widgets/pageactionprime.hamlet
@ -2,12 +2,16 @@ $newline never
 $if hasPageActions
  <div .page-nav-prime>
    <ul .pagenav__list>
-      $forall menuType <- menuTypes
+      $forall (menuType, menuIdent) <- menuTypes
        $case menuType
-          $of PageActionPrime (MenuItem label _mIcon route _callback)
+          $of PageActionPrime (MenuItem label _mIcon route _callback isModal)
            <li .pagenav__list-item>
-              <a .pagenav__link-wrapper href=@{route}>#{label}
-          $of PageActionSecondary (MenuItem label _mIcon route _callback)
+              $if isModal
+                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
+              <a .pagenav__link-wrapper href=@{route} ##{menuIdent}>#{label}
+          $of PageActionSecondary (MenuItem label _mIcon route _callback isModal)
            <li .pagenav__list-item>
-              <a .pagenav__link-wrapper href=@{route}>#{label}
+              $if isModal
+                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
+              <a .pagenav__link-wrapper href=@{route} ##{menuIdent}>#{label}
          $of _