Merge branch '334-urgent-sheet-corrector-table-heading' into 'master'

Work on "Urgent: Sheet Corrector Table Heading"

See merge request !180

messages/uniworx/de.msg

@@ -13,6 +13,8 @@ BtnCandidatesDeleteAll: Alle Beobachtungen löschen
 BtnResetTokens: Authorisierungs-Tokens invalidieren
 BtnLecInvAccept: Annehmen
 BtnLecInvDecline: Ablehnen
+BtnCorrInvAccept: Annehmen
+BtnCorrInvDecline: Ablehnen
 
 Aborted: Abgebrochen
 Remarks: Hinweise
@@ -253,7 +255,7 @@ NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nic
 TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
 
 AddCorrector: Zusätzlicher Korrektor
-CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
+CorrectorExists: Nutzer ist bereits als Korrektor eingetragen
 SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
 AutoAssignCorrs: Korrekturen nach Ablauf des Abgabezeitraums automatisch zuteilen
@@ -533,7 +535,9 @@ MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
 
 CommCourseSubject: Kursmitteilung
 MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
-CourseLecturerInvitationAcceptDecline: Einladung annehmen/ablehnen
+InvitationAcceptDecline: Einladung annehmen/ablehnen
+
+MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn}
 
 SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
@@ -753,7 +757,7 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "
 DeleteConfirmation: Bestätigung
 DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
 
-DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
+DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
 
 MassInputAddDimension: Hinzufügen
 MassInputDeleteCell: Entfernen
@@ -763,7 +767,7 @@ NavigationFavourites: Favoriten
 CommSubject: Betreff
 CommBody: Nachricht
 CommRecipients: Empfänger
-CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht.
+CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
 CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
 CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt
 
@@ -776,10 +780,15 @@ RGCourseLecturers: Kursverwalter
 RGCourseCorrectors: Korrektoren
 
 MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg)
-MultiEmailFieldTip: Je nach Browser sind mehrere komma-separierte E-Mail-Addressen möglich
+MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich
 EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
 
 LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen
 LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt
 CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
 CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.
+
+CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen
+CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt
+SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
+SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein.

models/sheets

@@ -36,6 +36,13 @@ SheetCorrector                -- grant corrector role to user for a sheet
     state           CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness)
     UniqueSheetCorrector user sheet
     deriving Show Eq Ord
+SheetCorrectorInvitation json
+    email           UserEmail
+    sheet           SheetId
+    load            Load
+    state           CorrectorState
+    UniqueSheetCorrectorInvitation email sheet
+    deriving Show Read Eq Ord Generic Typeable
 SheetFile                     -- a file that is part of an exercise sheet
     sheet           SheetId
     file            FileId

routes

@@ -104,6 +104,7 @@
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner !corrector
     /correctors                 SCorrR        GET POST
     /pseudonym                  SPseudonymR   GET POST        !registeredANDcorrector-submissions
+    /corrector-invite/#UserEmail SCorrInviteR     GET POST
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
 

src/Handler/Course.hs

@@ -545,6 +545,7 @@ courseEditHandler miButtonAction mbCourseForm = do
                   (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
                     deleteWhere [LecturerCourse ==. cid]
+                    deleteWhere [LecturerInvitationCourse ==. cid, LecturerInvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
                     forM_ (cfLecturers res) $ \case
                       Right (lid, lty) -> insert_  $ Lecturer lid cid lty
                       Left (lEmail, mLTy) -> do

src/Handler/Sheet.hs

@@ -1,6 +1,9 @@
 module Handler.Sheet where
 
 import Import
+
+import Jobs.Queue
+  
 import System.FilePath (takeFileName)
 
 import Utils.Sheet
@@ -9,20 +12,19 @@ import Handler.Utils
 import Handler.Utils.Table.Cells
 import Handler.Utils.SheetType
 import Handler.Utils.Delete
+import Handler.Utils.Form.MassInput
 
 -- import Data.Time
 -- import qualified Data.Text as T
 -- import Data.Function ((&))
 --
 -- import Colonnade hiding (fromMaybe, singleton, bool)
-import qualified Yesod.Colonnade as Yesod
-import Text.Blaze (text)
 --
 -- import qualified Data.UUID.Cryptographic as UUID
 import qualified Data.Conduit.List as C
 
 -- import Data.CaseInsensitive (CI)
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
 
 import qualified Database.Esqueleto as E
 -- import qualified Database.Esqueleto.Internal.Sql as E
@@ -42,7 +44,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-import Data.Map (Map, (!?))
+import Data.Map (Map, (!))
 
 import Data.Monoid (Any(..))
 
@@ -614,7 +616,7 @@ data CorrectorForm = CorrectorForm
   , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
   }
 
-type Loads = Map UserId (CorrectorState, Load)
+type Loads = Map (Either UserEmail UserId) (CorrectorState, Load)
 
 defaultLoads :: SheetId -> DB Loads
 -- ^ Generate `Loads` in such a way that minimal editing is required
@@ -637,164 +639,152 @@ defaultLoads shid = do
     return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
   where
     toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
-    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
+    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
 
 
-correctorForm :: SheetId -> MForm Handler (FormResult (Bool, Set SheetCorrector), [FieldView UniWorX])
+correctorForm :: SheetId -> AForm Handler (Set (Either SheetCorrectorInvitation SheetCorrector))
-correctorForm shid = do
+correctorForm shid = wFormToAForm $ do
-  cListIdent <- newFormIdent
+  Just currentRoute <- liftHandlerT getCurrentRoute
-  let
+  userId <- liftHandlerT requireAuthId
-    guardNonDeleted :: UserId -> Handler (Maybe UserId)
+  MsgRenderer mr <- getMsgRenderer
-    guardNonDeleted uid = do
+  
-      CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser
-      deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
-      return $ bool Just (const Nothing) (isJust deleted) uid
-  formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
   let
     currentLoads :: DB Loads
-    currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
+    currentLoads = Map.union
-  (autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
+      <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
-  loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
+      <*> fmap (foldMap $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. shid ] [])
-    | Map.null currentLoads'
+  (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads
-    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
-    | otherwise              -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'
 
-  deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
+  isWrite <- liftHandlerT $ isWriteRequest currentRoute
-
-  let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
-      didDelete = any (flip Set.member deletions) formCIDs
-
-  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
-  (autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
-  let
-    tutorField :: Field Handler [UserEmail]
-    tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
-      { fieldView = \theId name attrs _val isReq -> asWidgetT $ do
-          listIdent <- newIdent
-          userId <- handlerToWidget requireAuthId
-          previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
-            E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
-            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
-            E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
-            E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
-            return $ user E.^. UserEmail
-          [whamlet|
-            $newline never
-            <input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
-            <datalist id=#{listIdent}>
-              $forall E.Value prev <- previousCorrectors
-                <option value=#{prev}>
-          |]
-      }
-  (addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
-
-  loads <- case addTutRes of
-    FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
-      mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
-      case mUid of
-        Nothing  -> loads'' <$ addMessageI Error (MsgEMailUnknown email)
-        Just uid
-          | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
-          | otherwise                   -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
-    FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
-    _ -> return loads''
-
-  let deletions' = deletions `Set.difference` Map.keysSet loads
-
-  names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
-    E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys  loads)
-    return $ (user E.^. UserId, user E.^. UserDisplayName)
 
   let
-    constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
+    applyDefaultLoads = Map.null currentLoads' && not isWrite
-    constructFields (uid, uname, (state, Load{..})) = do
+    loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
-      CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
+    loads
-      let
+      | applyDefaultLoads = defaultLoads'
-        fs name = ""
+      | otherwise         = currentLoads'
-          { fsName = Just $ tshow ciphertext <> "-" <> name
-          }
-        rationalField = convertField toRational fromRational doubleField
 
-      (stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
+  when (not (Map.null loads) && applyDefaultLoads) $
-      (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
+    addMessageI Warning MsgCorrectorsDefaulted
-      (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
+  
-      (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
+  countTutRes <- wreq checkBoxField (fsm MsgCountTutProp) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
+
+  let
+    previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
+    previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
+      E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+      E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+      E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+      E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+      E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
+      return user
+    
+    miAdd :: ListPosition
+          -> Natural
+          -> (Text -> Text)
+          -> FieldView UniWorX
+          -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+    miAdd _ _ nudge submitView = Just $ \csrf -> do
+      (addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
+      let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
+            | existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
+            , not $ null existing
+              -> FormFailure [mr MsgCorrectorExists]
+            | otherwise
+              -> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
+      return (addRes', $(widgetFile "sheetCorrectors/add"))
+
+    miCell :: ListPosition
+           -> Either UserEmail UserId
+           -> Maybe (CorrectorState, Load)
+           -> (Text -> Text)
+           -> Form (CorrectorState, Load)
+    miCell _ userIdent initRes nudge csrf = do
+      (stateRes, stateView) <- mreq (selectField optionsFinite) ("" & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
+      (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
+      (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) ("" & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
       let
-        cfResult :: FormResult (CorrectorState, Load)
+        res :: FormResult (CorrectorState, Load)
-        cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
+        res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
         tutRes'
           | FormSuccess True <- byTutRes  = Just <$> countTutRes
           | otherwise                     = Nothing <$ byTutRes
-        cfUserId = uid
+      identWidget <- case userIdent of
-        cfUserName = uname
+        Left email -> return . toWidget $ mailtoHtml email
-      return CorrectorForm{..}
+        Right uid -> do
+          User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
+          return $ nameEmailWidget userEmail userDisplayName userSurname
+      return (res, $(widgetFile "sheetCorrectors/cell"))
       
-  corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
 
-  mr <- getMessageRender
+    miDelete :: ListLength
+             -> ListPosition
+             -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
+    miDelete = miDeleteList
 
-  $logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
+    miAllowAdd :: ListPosition
+               -> Natural
+               -> ListLength
+               -> Bool
+    miAllowAdd _ _ _ = True
 
-  let
+    miAddEmpty :: ListPosition
-    corrColonnade = mconcat
+               -> Natural
-      [ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
+               -> ListLength
-      , headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
+               -> Set ListPosition
-      , headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
+    miAddEmpty _ _ _ = Set.empty
-      , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
-      , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
-      ]
-    corrResults
-      | FormSuccess (Just es) <- addTutRes
-      , not $ null es = FormMissing
-      | didDelete = FormMissing
-      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
-                                                  | CorrectorForm{..} <- corrData
-                                                  ]
-    idField CorrectorForm{..} = do
-      cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
-      toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
 
-    delField uid = do
+    miButtonAction :: forall p.
-      cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
+                      PathPiece p
-      toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
+                   => p
+                   -> Maybe (SomeRoute UniWorX)
+    miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
 
-  return ( (,) <$> autoDistributeRes <*> corrResults
+    miLayout :: ListLength
-         , [ autoDistributeView
+             -> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
-           , countTutView
+             -> Map ListPosition Widget
-           , FieldView
+             -> Map ListPosition (FieldView UniWorX)
-             { fvLabel = text $ mr MsgCorrectors
+             -> Map (Natural, ListPosition) Widget
-             , fvTooltip = Just $ toHtml $ mr MsgCorrectorStateTip
+             -> Widget
-             , fvId = ""
+    miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
-             , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
-             , fvErrors = Nothing
-             , fvRequired = True
-             }
-           , addTutView
-             { fvInput = [whamlet|
-                           <div>
-                             ^{fvInput addTutView}
-                             <button type=submit formnovalidate data-formnorequired>Hinzufügen
-                         |]
-             }
-           ])
 
-  -- Eingabebox für Korrektor hinzufügen
+    postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector)
-  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
+    postProcess = Set.fromList . map postProcess' . Map.elems
+      where
+        sheetCorrectorSheet = shid
+        sheetCorrectorInvitationSheet = shid
+        
+        postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector
+        postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
+        postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..}
+
+  fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) True (Just . Map.fromList . zip [0..] $ Map.toList loads)
 
 getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 postSCorrR = getSCorrR
 getSCorrR tid ssh csh shn = do
+  uid <- requireAuthId
   Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
 
-  ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid)
+  ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
+    (,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute)
+        <*> correctorForm shid
 
   case res of
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
-    FormSuccess (autoDistribute, res') -> runDB $ do
+    FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
       update shid [ SheetAutoDistribute =. autoDistribute ]
-      deleteWhere [SheetCorrectorSheet ==. shid]
+      deleteWhere [ SheetCorrectorSheet ==. shid ]
-      insertMany_ $ Set.toList res'
+      deleteWhere [ SheetCorrectorInvitationSheet ==. shid, SheetCorrectorInvitationEmail /<-. toListOf (folded . _Left . _sheetCorrectorInvitationEmail) sheetCorrectors ]
+      forM_ sheetCorrectors $ \case
+        Right shCor -> insert_ shCor
+        Left shCorInv -> do
+          insertRes <- insertBy shCorInv
+          case insertRes of
+            Right _ ->
+              void . queueDBJob $ JobCorrectorInvitation uid shCorInv
+            Left (Entity old _) ->
+               replace old shCorInv
       addMessageI Success MsgCorrectorsUpdated
     FormMissing -> return ()
 
@@ -804,3 +794,50 @@ getSCorrR tid ssh csh shn = do
       { formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SCorrR
       , formEncoding = formEnctype
       }
+
+
+data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe ButtonCorrInvite
+instance Finite ButtonCorrInvite
+
+nullaryPathPiece ''ButtonCorrInvite $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''ButtonCorrInvite id
+
+instance Button UniWorX ButtonCorrInvite where
+  btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary]
+  btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger]
+
+getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> UserEmail -> Handler Html
+getSCorrInviteR = postSCorrInviteR
+postSCorrInviteR tid ssh csh shn email = do
+  uid <- requireAuthId
+  (Entity _ Course{..}, Entity shid Sheet{..}, Entity ciId SheetCorrectorInvitation{..}) <- runDB $ do
+    (sRes@(Entity shid _), cRes) <- fetchSheetCourse tid ssh csh shn
+    iRes <- getBy404 $ UniqueSheetCorrectorInvitation email shid
+    return (cRes, sRes, iRes)
+
+  ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ formEmbedJwtPost buttonForm
+
+  let btnWidget = wrapForm btnInnerWidget def
+        { formEncoding = btnEncoding
+        , formAction = Just . SomeRoute . CSheetR tid ssh csh shn $ SCorrInviteR email
+        , formSubmit = FormNoSubmit
+        }
+
+  formResult btnResult $ \case
+    BtnCorrInvAccept -> do
+      runDB $ do
+        delete ciId
+        insert_ $ SheetCorrector uid shid sheetCorrectorInvitationLoad sheetCorrectorInvitationState
+      addMessageI Success $ MsgCorrectorInvitationAccepted shn
+      redirect $ CSheetR tid ssh csh shn SShowR
+    BtnCorrInvDecline -> do
+      runDB $
+        delete ciId
+      addMessageI Info $ MsgCorrectorInvitationDeclined shn
+      redirect HomeR
+
+  siteLayoutMsg (MsgSheetCorrInviteHeading shn) $ do
+    setTitleI $ MsgSheetCorrInviteHeading shn
+    $(widgetFile "sheetCorrInvite")

src/Handler/Utils.hs

@@ -101,7 +101,7 @@ wrapMailto (original -> email) linkText
 
 -- | Just show an email address in a standard way, for convenience inside hamlet files.
 mailtoHtml :: UserEmail -> Html
-mailtoHtml email = wrapMailto email $ toHtml email
+mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")
 
 -- | Generic i18n text for "edited at sometime by someone"
 editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget

src/Handler/Utils/Communication.hs

@@ -24,8 +24,6 @@ import qualified Data.Set as Set
 import Data.Aeson.TH
 import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
 
-import Data.List (nub)
-
 
 data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
@@ -133,9 +131,9 @@ commR CommunicationRoute{..} =  do
       recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
         where
           miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
-            (addRes, addView) <- mpreq multiEmailField (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
+            (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
             let
-              addRes' = addRes <&> \(nub . map CI.mk -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) (map Left nEmails)
+              addRes' = addRes <&> \(Set.toList -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) nEmails
             return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
           miAdd _ _ _ _ = Nothing
           miCell _ (Left (CI.original -> email)) initRes nudge csrf = do

src/Handler/Utils/Form.hs

@@ -33,12 +33,13 @@ import Data.Map (Map, (!))
 import qualified Data.Map as Map
 
 import Control.Monad.Trans.Writer (execWriterT, WriterT)
-import Control.Monad.Except (runExceptT)
+import Control.Monad.Trans.Except (throwE, runExceptT)
 import Control.Monad.Writer.Class
 
 import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)
+import Data.Either (partitionEithers)
 
 import Utils.Lens
 
@@ -47,6 +48,8 @@ import Data.Aeson.Text (encodeToLazyText)
 
 import Data.Proxy
 
+import qualified Text.Email.Validate as Email
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -651,3 +654,67 @@ formResultModal res finalDest handler = maybeT_ $ do
     | otherwise -> do
         forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
         redirect finalDest
+
+multiUserField :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  )
+               => Bool -- ^ Only resolve suggested users?
+               -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
+               -> Field m (Set (Either UserEmail UserId))
+multiUserField onlySuggested suggestions = Field{..}
+  where
+    lookupExpr
+      | onlySuggested = suggestions
+      | otherwise     = Just $ E.from return
+    
+    fieldEnctype = UrlEncoded
+    fieldView theId name attrs val isReq = do
+      val' <- case val of
+        Left t -> return t
+        Right vs -> Text.intercalate ", " . map CI.original <$> do
+          let (emails, uids) = partitionEithers $ Set.toList vs
+          rEmails <- case lookupExpr of
+            Nothing -> return []
+            Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
+              dbRes <- liftHandlerT . runDB . E.select $ do
+                user <- lookupExpr'
+                E.where_ $ user E.^. UserId E.==. E.val uid
+                return $ user E.^. UserEmail
+              case dbRes of
+                [E.Value email] -> return [email]
+                _other -> return []
+          return $ emails ++ rEmails
+
+      datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
+      
+      [whamlet|
+        $newline never
+        <input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
+      |]
+
+      whenIsJust suggestions $ \suggestions' -> do
+        suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do
+          user <- suggestions'
+          return $ user E.^. UserEmail
+        [whamlet|
+          $newline never
+          <datalist id=#{datalistId}>
+            $forall email <- suggestedEmails
+              <option value=#{email}>
+        |]
+    fieldParse (all Text.null -> True) _ = return $ Right Nothing 
+    fieldParse ts _ = runExceptT . fmap Just $ do
+      let ts' = concatMap (Text.splitOn ",") ts
+      emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
+      fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
+        Nothing -> return $ Left email
+        Just lookupExpr' -> do
+            dbRes <- liftHandlerT . runDB . E.select $ do
+              user <- lookupExpr'
+              E.where_ $ user E.^. UserEmail E.==. E.val email
+              return $ user E.^. UserId
+            case dbRes of
+              [] -> return $ Left email
+              [E.Value uid] -> return $ Right uid
+              _other -> fail "Ambiguous e-mail addr"

src/Handler/Utils/Form/MassInput.hs

@@ -6,7 +6,7 @@ module Handler.Utils.Form.MassInput
   , defaultMiLayout
   , massInput
   , module Handler.Utils.Form.MassInput.Liveliness
-  , massInputA
+  , massInputA, massInputW
   , massInputList
   , ListLength(..), ListPosition(..), miDeleteList
   , EnumLiveliness(..), EnumPosition(..)
@@ -484,3 +484,17 @@ massInputA :: forall handler cellData cellResult liveliness.
           -> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
 massInputA  mi fs fvRequired initialResult = formToAForm $
   over _2 pure <$> massInput mi fs fvRequired initialResult mempty
+
+massInputW :: forall handler cellData cellResult liveliness.
+           ( MonadHandler handler, HandlerSite handler ~ UniWorX
+           , ToJSON cellData, FromJSON cellData
+           , Liveliness liveliness
+           , MonadLogger handler
+           )
+          => MassInput handler liveliness cellData cellResult
+          -> FieldSettings UniWorX
+          -> Bool -- ^ Required?
+          -> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
+          -> WForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)))
+massInputW mi fs fvRequired initialResult = mFormToWForm $
+  massInput mi fs fvRequired initialResult mempty

src/Handler/Utils/Sheet.hs

@@ -12,7 +12,7 @@ fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
                   , Typeable a, MonadHandler m, IsPersistBackend backend
                   , PersistQueryRead backend, PersistUniqueRead backend
                   )
-  =>  (E.SqlExpr (Entity Sheet) -> b)
+  =>  (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
       -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
 fetchSheetAux prj tid ssh csh shn =
     let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
@@ -27,19 +27,22 @@ fetchSheetAux prj tid ssh csh shn =
                 E.&&.  course E.^. CourseSchool    E.==. E.val ssh
                 E.&&.  course E.^. CourseShorthand E.==. E.val csh
                 E.&&.  sheet  E.^. SheetName       E.==. E.val shn
-            return $ prj sheet
+            return $ prj sheet course
         case sheetList of
           [sheet] -> return sheet
           _other  -> notFound
 
 fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
-fetchSheet = fetchSheetAux id
+fetchSheet = fetchSheetAux const
+
+fetchSheetCourse :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet, Entity Course)
+fetchSheetCourse = fetchSheetAux (,)
 
 fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
-fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn
+fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (\sheet _ -> sheet E.^. SheetId) tid ssh cid shn
 
 fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
-fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
+fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn
 
 
 sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet

src/Jobs.hs

@@ -61,6 +61,7 @@ import Jobs.Handler.SetLogSettings
 import Jobs.Handler.DistributeCorrections
 import Jobs.Handler.SendCourseCommunication
 import Jobs.Handler.LecturerInvitation
+import Jobs.Handler.CorrectorInvitation
 
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob

src/Jobs/Handler/CorrectorInvitation.hs

@@ -0,0 +1,42 @@
+module Jobs.Handler.CorrectorInvitation
+  ( dispatchJobCorrectorInvitation
+  ) where
+
+import Import
+
+import Text.Hamlet
+
+import qualified Data.HashSet as HashSet
+
+import qualified Data.CaseInsensitive as CI
+
+import Utils.Lens
+
+
+dispatchJobCorrectorInvitation :: UserId -> SheetCorrectorInvitation -> Handler ()
+dispatchJobCorrectorInvitation jInviter jCorrectorInvitation@SheetCorrectorInvitation{..} = do
+  ctx <- runDB . runMaybeT $ do
+    sheet <- MaybeT $ get sheetCorrectorInvitationSheet
+    course <- MaybeT . get $ sheetCourse sheet
+    void . MaybeT $ getByValue jCorrectorInvitation
+    user <- MaybeT $ get jInviter
+    return (sheet, course, user)
+
+  case ctx of
+    Just (Sheet{..}, Course{..}, User{..}) -> do
+      let baseRoute = CSheetR courseTerm courseSchool courseShorthand sheetName $ SCorrInviteR sheetCorrectorInvitationEmail
+      jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
+      let
+        invitationUrl :: SomeRoute UniWorX
+        invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
+      invitationUrl' <- toTextUrl invitationUrl
+
+      mailT def $ do
+        _mailTo .= [Address Nothing (CI.original $ sheetCorrectorInvitationEmail)]
+        replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
+        replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+        setSubjectI $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
+      
+        addPart ($(ihamletFile "templates/mail/correctorInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+    Nothing -> runDB .
+      deleteBy $ UniqueSheetCorrectorInvitation sheetCorrectorInvitationEmail sheetCorrectorInvitationSheet

src/Jobs/Types.hs

@@ -34,6 +34,9 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
          | JobLecturerInvitation { jInviter :: UserId
                                  , jLecturerInvitation :: LecturerInvitation
                                  }
+         | JobCorrectorInvitation { jInviter :: UserId
+                                  , jCorrectorInvitation :: SheetCorrectorInvitation
+                                  }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }

src/Model.hs

@@ -41,6 +41,7 @@ deriving instance Eq (Unique Sheet)
 deriving instance Binary (Key Term)
 
 instance Hashable LecturerInvitation
+instance Hashable SheetCorrectorInvitation
 
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Types.hs

@@ -332,6 +332,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
 deriveJSON defaultOptions ''Load
 derivePersistFieldJSON ''Load
 
+instance Hashable Load
 
 instance Semigroup Load where
   (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
@@ -529,9 +530,11 @@ deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Corrector"
   } ''CorrectorState
 
-instance Universe CorrectorState where universe = universeDef
+instance Universe CorrectorState
 instance Finite CorrectorState
 
+instance Hashable CorrectorState
+
 nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
 
 derivePersistField "CorrectorState"

src/Utils/Form.hs

@@ -441,6 +441,9 @@ optionsFinite = do
       }
   return . mkOptionList $ mkOption <$> universeF
 
+rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
+rationalField = convertField toRational fromRational doubleField
+
 
 -----------
 -- Forms --

src/Utils/Lens.hs

@@ -100,6 +100,8 @@ makePrisms ''HandlerContents
 
 makePrisms ''ErrorResponse
 
+makeLenses_ ''SheetCorrectorInvitation
+
 
 -- makeClassy_ ''Load
 

static/js/utils/checkAll.js

@@ -91,12 +91,10 @@
       checkboxColumn = columns[checkboxColumnId];
       var firstRow = element.querySelector('tr');
       var th = Array.from(firstRow.querySelectorAll('th, td'))[checkboxColumnId];
-      th.innerHTML = 'test';
       checkAllCheckbox = document.createElement('input');
       checkAllCheckbox.setAttribute('type', 'checkbox');
       checkAllCheckbox.setAttribute('id', getCheckboxId());
-      th.innerHTML = '';
+      th.insertBefore(checkAllCheckbox, th.firstChild);
-      th.insertBefore(checkAllCheckbox, null);
 
       // manually set up newly created checkbox
       if (UtilRegistry) {

static/js/utils/inputs.js

@@ -161,7 +161,7 @@
         return false;
       }
 
-      var siblingEl = element.nextElementSibling;
+      var siblingEl = element.nextSibling;
       var parentEl = element.parentElement;
 
       var wrapperEl = document.createElement('div');

templates/mail/correctorInvitation.hamlet

@@ -0,0 +1,11 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+  <body>
+    <p>
+      _{MsgSheetCorrInviteExplanation}
+    <p>
+      <a href=#{invitationUrl'}>
+        _{MsgInvitationAcceptDecline}

templates/mail/lecturerInvitation.hamlet

@@ -8,4 +8,4 @@ $newline never
       _{MsgCourseLecInviteExplanation}
     <p>
       <a href=#{invitationUrl'}>
-        _{MsgCourseLecturerInvitationAcceptDecline}
+        _{MsgInvitationAcceptDecline}

templates/sheetCorrInvite.hamlet

@@ -0,0 +1,3 @@
+<p>
+  _{MsgSheetCorrInviteExplanation}
+^{btnWidget}

templates/sheetCorrectors/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=5>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput submitView}

templates/sheetCorrectors/cell.hamlet

@@ -0,0 +1,20 @@
+$newline never
+$case userIdent
+  $of Left _
+    <td>
+      ^{identWidget}
+    <td>
+      <div .tooltip>
+        <div .tooltip__handle>
+        <div .tooltip__content>
+          _{MsgEmailInvitationWarning}
+  $of Right _
+    <td colspan=2>
+      ^{identWidget}
+<td>
+  #{csrf}
+  ^{fvInput stateView}
+<td>
+  ^{fvInput byTutView}
+<td>
+  ^{fvInput propView}

templates/sheetCorrectors/layout.hamlet

@@ -0,0 +1,18 @@
+$newline never
+<table .table .table--striped .table--hover>
+  <thead>
+    <tr .table__row .table__row--head>
+      <th .table__th colspan="2">_{MsgCorrector}
+      <th .table__th>_{MsgCorState}
+      <th .table__th>_{MsgCorByTut}
+      <th .table__th>_{MsgCorProportion}
+      <td>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput--cell .table__row>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvInput (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/email.hamlet

@@ -0,0 +1,2 @@
+<span style="font-family: monospace">
+  ^{toHtml email}