From bd98f11ad5b7c238882284e32919a19174a0dfd4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 20 Apr 2019 21:21:20 +0200 Subject: [PATCH 1/2] Overhaul corrector interface --- messages/uniworx/de.msg | 19 +- models/sheets | 7 + routes | 1 + src/Handler/Course.hs | 1 + src/Handler/Sheet.hs | 305 ++++++++++++---------- src/Handler/Utils.hs | 2 +- src/Handler/Utils/Communication.hs | 6 +- src/Handler/Utils/Form.hs | 69 ++++- src/Handler/Utils/Form/MassInput.hs | 16 +- src/Handler/Utils/Sheet.hs | 13 +- src/Jobs.hs | 1 + src/Jobs/Handler/CorrectorInvitation.hs | 42 +++ src/Jobs/Types.hs | 3 + src/Model.hs | 1 + src/Model/Types.hs | 5 +- src/Utils/Form.hs | 3 + src/Utils/Lens.hs | 2 + static/js/utils/checkAll.js | 4 +- static/js/utils/inputs.js | 2 +- templates/mail/correctorInvitation.hamlet | 11 + templates/mail/lecturerInvitation.hamlet | 2 +- templates/sheetCorrInvite.hamlet | 3 + templates/sheetCorrectors/add.hamlet | 6 + templates/sheetCorrectors/cell.hamlet | 20 ++ templates/sheetCorrectors/layout.hamlet | 18 ++ templates/widgets/email.hamlet | 2 + 26 files changed, 407 insertions(+), 157 deletions(-) create mode 100644 src/Jobs/Handler/CorrectorInvitation.hs create mode 100644 templates/mail/correctorInvitation.hamlet create mode 100644 templates/sheetCorrInvite.hamlet create mode 100644 templates/sheetCorrectors/add.hamlet create mode 100644 templates/sheetCorrectors/cell.hamlet create mode 100644 templates/sheetCorrectors/layout.hamlet create mode 100644 templates/widgets/email.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 49184101c..0c3465350 100644 --- a/messages/uniworx/de.msg +++ b/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. \ No newline at end of file diff --git a/models/sheets b/models/sheets index e13fc2d47..8f6d623db 100644 --- a/models/sheets +++ b/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 diff --git a/routes b/routes index 161383a7e..0e801e22b 100644 --- a/routes +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 593b08f7d..5697b7bd4 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index cc5bc7718..cf3f36b09 100644 --- a/src/Handler/Sheet.hs +++ b/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 shid = do - cListIdent <- newFormIdent - let - guardNonDeleted :: UserId -> Handler (Maybe UserId) - 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]) +correctorForm :: SheetId -> AForm Handler (Set (Either SheetCorrectorInvitation SheetCorrector)) +correctorForm shid = wFormToAForm $ do + Just currentRoute <- liftHandlerT getCurrentRoute + userId <- liftHandlerT requireAuthId + MsgRenderer mr <- getMsgRenderer + let currentLoads :: DB Loads - currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] - (autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads - loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if - | Map.null currentLoads' - , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted) - | otherwise -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads' + currentLoads = Map.union + <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] []) + <*> fmap (foldMap $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. shid ] []) + (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads - deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads') - - 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 - - - $forall E.Value prev <- previousCorrectors -