Pseudonym submission creation

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:

routes

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

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

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 _

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

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{..}

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
 

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 :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
-addDatalist field mValues = field
+addDatalist mValues field = field
   { fieldView = \fId fName fAttrs fRes fReq -> do
       listId <- newIdent
       values <- map toPathPiece . otoList <$> mValues

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

templates/corrections-create.hamlet

@@ -0,0 +1,2 @@
+<form method=post action=@{CorrectionsCreateR} enctype=#{pseudonymEncoding}>
+  ^{pseudonymWidget}

templates/default-layout.lucius

@@ -524,3 +524,6 @@ section:last-of-type {
     border-bottom: none;
 }
 
+.pseudonym {
+    font-family: monospace;
+}

templates/messages/submissionCreateDuplicates.hamlet

@@ -0,0 +1,6 @@
+_{MsgSheetDuplicatePseudonym}
+
+<ul>
+  $forall p <- duplicate
+    <li .pseudonym>
+      #{review pseudonymText p}

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}

templates/sheetShow.cassius

@@ -1,2 +0,0 @@
-.pseudonym
-  font-family: monospace

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

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 _

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}
+              $if isModal
-          $of PageActionSecondary (MenuItem label _mIcon route _callback)
+                <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 _