diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8ffd3ec53..9079b16da 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -552,6 +552,8 @@ InvitationAcceptDecline: Einladung annehmen/ablehnen MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn} +MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn} + SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten @@ -817,6 +819,11 @@ CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor f SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn} SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein. +TutorInvitationAccepted tutn@TutorialName: Sie wurden als Tutor für #{tutn} eingetragen +TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für #{tutn} zu werden, abgelehnt +TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn} +TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein. + InvitationAction: Aktion InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten diff --git a/models/courses b/models/courses index 45166d7d5..4fcf67d65 100644 --- a/models/courses +++ b/models/courses @@ -35,12 +35,6 @@ Lecturer -- course ownership course CourseId type LecturerType default='"lecturer"' UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table -LecturerInvitation json -- preliminary course ownership for when a token to become `Lecturer` is sent to an email - email (CI Text) - course CourseId - type LecturerType Maybe - UniqueLecturerInvitation email course - deriving Eq Ord Read Show Generic Typeable CourseParticipant -- course enrolement course CourseId user UserId diff --git a/models/sheets b/models/sheets index 293d75b2f..f8d21a6c2 100644 --- a/models/sheets +++ b/models/sheets @@ -35,13 +35,6 @@ 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 0c6712fff..5ab08b660 100644 --- a/routes +++ b/routes @@ -108,7 +108,7 @@ !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions - /corrector-invite/#UserEmail SCorrInviteR GET POST + /corrector-invite SCorrInviteR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector /tuts CTutorialListR GET !tutor /tuts/new CTutorialNewR GET POST @@ -118,6 +118,7 @@ /participants TUsersR GET POST !tutor /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /communication TCommR GET POST !tutor + /tutor-invite TInviteR GET POST /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 40e49c343..e05481c8a 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -535,7 +535,7 @@ pgCEditR tid ssh csh = do courseData <- runDB $ do mbCourse <- getBy (TermSchoolCourseShort tid ssh csh) mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] - mbLecInvites <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerInvitationCourse ==. entityKey course] [Asc LecturerInvitationType] + mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites -- IMPORTANT: both GET and POST Handler must use the same template, -- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons. @@ -684,8 +684,8 @@ lecturerInvitationConfig = InvitationConfig{..} invitationResolveFor = do Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute getKeyBy404 $ TermSchoolCourseShort tid csh ssh - invitationSubject Course{..} _ = SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand - invitationHeading Course{..} _ = SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName + invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand + invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId @@ -720,7 +720,7 @@ data CourseForm = CourseForm , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] } -courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm +courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm { cfCourseId = Just cid , cfName = courseName @@ -736,7 +736,7 @@ courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm , cfRegTo = courseRegisterTo , cfDeRegUntil = courseDeregisterUntil , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] - ++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ] + ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ] } makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 8448a5203..478f00a91 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Handler.Sheet where import Import @@ -13,6 +15,7 @@ import Handler.Utils.Table.Cells import Handler.Utils.SheetType import Handler.Utils.Delete import Handler.Utils.Form.MassInput +import Handler.Utils.Invitations -- import Data.Time -- import qualified Data.Text as T @@ -56,6 +59,9 @@ import Utils.Lens import Control.Monad.Random.Class (MonadRandom(..)) import Utils.Sql +import Data.Aeson hiding (Result(..)) +import Text.Hamlet (ihamlet) + {- * Implement Handlers @@ -637,7 +643,7 @@ defaultLoads shid = do toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load) -correctorForm :: SheetId -> AForm Handler (Set (Either SheetCorrectorInvitation SheetCorrector)) +correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector)) correctorForm shid = wFormToAForm $ do Just currentRoute <- liftHandlerT getCurrentRoute userId <- liftHandlerT requireAuthId @@ -647,7 +653,7 @@ correctorForm shid = wFormToAForm $ do currentLoads :: DB Loads 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 ] []) + <*> fmap (foldMap $ \(email, InvDBDataSheetCorrector load state) -> Map.singleton (Left email) (state, load)) (sourceInvitationsList shid) (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads isWrite <- liftHandlerT $ isWriteRequest currentRoute @@ -743,22 +749,20 @@ correctorForm shid = wFormToAForm $ do -> Widget miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout") - postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector) + postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector) postProcess = Set.fromList . map postProcess' . Map.elems where sheetCorrectorSheet = shid - sheetCorrectorInvitationSheet = shid - postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector + postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..} - postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..} + postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector)) fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) 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 $ @@ -769,17 +773,15 @@ getSCorrR tid ssh csh shn = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do update shid [ SheetAutoDistribute =. autoDistribute ] + + let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors + deleteWhere [ SheetCorrectorSheet ==. shid ] - 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 + insertMany_ adds + + deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites] + sinkInvitationsF correctorInvitationConfig invites + addMessageI Success MsgCorrectorsUpdated FormMissing -> return () @@ -791,48 +793,65 @@ getSCorrR tid ssh csh shn = do } -data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe ButtonCorrInvite -instance Finite ButtonCorrInvite +instance IsInvitableJunction SheetCorrector where + type InvitationFor SheetCorrector = Sheet + data InvitableJunction SheetCorrector = JunctionSheetCorrector + { jSheetCorrectorLoad :: Load + , jSheetCorrectorState :: CorrectorState + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData SheetCorrector = InvDBDataSheetCorrector + { invDBSheetCorrectorLoad :: Load + , invDBSheetCorrectorState :: CorrectorState + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) -nullaryPathPiece ''ButtonCorrInvite $ camelToPathPiece' 3 -embedRenderMessage ''UniWorX ''ButtonCorrInvite id + _InvitableJunction = iso + (\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState)) + (\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..}) -instance Button UniWorX ButtonCorrInvite where - btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary] - btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger] +instance ToJSON (InvitableJunction SheetCorrector) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction SheetCorrector) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } -getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> UserEmail -> Handler Html +instance ToJSON (InvitationDBData SheetCorrector) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationDBData SheetCorrector) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + +instance ToJSON (InvitationTokenData SheetCorrector) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationTokenData SheetCorrector) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + +correctorInvitationConfig :: InvitationConfig SheetCorrector +correctorInvitationConfig = InvitationConfig{..} + where + invitationRoute Sheet{..} _ = do + Course{..} <- get404 sheetCourse + return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR + invitationResolveFor = do + Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute + fetchSheetId tid csh ssh shn + invitationSubject Sheet{..} _ = do + Course{..} <- get404 sheetCourse + return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName + invitationHeading Sheet{..} _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] + invitationTokenConfig _ _ = do + itAuthority <- liftHandlerT requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm _ (InvDBDataSheetCorrector load state, _) = pure $ JunctionSheetCorrector load state + invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName + invitationUltDest Sheet{..} _ = do + Course{..} <- get404 sheetCourse + return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR + +getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> 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") +postSCorrInviteR = invitationR correctorInvitationConfig diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 93b09166c..c32de13bb 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Handler.Tutorial where import Import @@ -8,6 +10,8 @@ import Handler.Utils.Delete import Handler.Utils.Communication import Handler.Utils.Form.MassInput import Handler.Utils.Form.Occurences +import Handler.Utils.Invitations +import Jobs.Queue import qualified Database.Esqueleto as E import Database.Esqueleto.Utils.TH @@ -22,6 +26,9 @@ import qualified Data.Text as Text import Utils.Lens +import Data.Aeson hiding (Result(..)) +import Text.Hamlet (ihamlet) + {-# ANN module ("Hlint: ignore Redundant void" :: String) #-} @@ -193,6 +200,66 @@ postTCommR tid ssh csh tutn = do } +instance IsInvitableJunction Tutor where + type InvitationFor Tutor = Tutorial + data InvitableJunction Tutor = JunctionTutor + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData Tutor = InvDBDataTutor + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData Tutor = InvTokenDataTutor + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\Tutor{..} -> (tutorUser, tutorTutorial, JunctionTutor)) + (\(tutorUser, tutorTutorial, JunctionTutor) -> Tutor{..}) + +instance ToJSON (InvitableJunction Tutor) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction Tutor) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData Tutor) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationDBData Tutor) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + +instance ToJSON (InvitationTokenData Tutor) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationTokenData Tutor) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + +tutorInvitationConfig :: InvitationConfig Tutor +tutorInvitationConfig = InvitationConfig{..} + where + invitationRoute Tutorial{..} _ = do + Course{..} <- get404 tutorialCourse + return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR + invitationResolveFor = do + Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute + fetchTutorialId tid csh ssh tutn + invitationSubject Tutorial{..} _ = do + Course{..} <- get404 tutorialCourse + return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName + invitationHeading Tutorial{..} _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] + invitationTokenConfig _ _ = do + itAuthority <- liftHandlerT requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm _ _ = pure JunctionTutor + invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName + invitationUltDest Tutorial{..} _ = do + Course{..} <- get404 tutorialCourse + return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR + +getTInviteR, postTInviteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTInviteR = postTInviteR +postTInviteR = invitationR tutorInvitationConfig + + data TutorialForm = TutorialForm { tfName :: TutorialName , tfType :: CI Text @@ -203,7 +270,7 @@ data TutorialForm = TutorialForm , tfRegisterFrom :: Maybe UTCTime , tfRegisterTo :: Maybe UTCTime , tfDeregisterUntil :: Maybe UTCTime - , tfTutors :: Set UserId -- awaiting feat/generic-invitations + , tfTutors :: Set (Either UserEmail UserId) } tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm @@ -215,29 +282,29 @@ tutorialForm cid template html = do let tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([UserId] -> FormResult [UserId]) + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) miAdd' nudge submitView csrf = do (addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing let addRes' - | unresolved <- toListOf (_FormSuccess . folded . _Left) addRes - , (fUnresolved : _) <- unresolved - = FormFailure [mr $ MsgEMailUnknown fUnresolved] | otherwise = addRes <&> \newDat oldDat -> if - | (_ : _) <- Set.toList $ setOf (folded . _Right) newDat `Set.intersection` Set.fromList oldDat + | existing <- newDat `Set.intersection` Set.fromList oldDat + , not $ Set.null existing -> FormFailure [mr MsgTutorialTutorAlreadyAdded] | otherwise - -> FormSuccess $ toListOf (folded . _Right) newDat + -> FormSuccess $ Set.toList newDat return (addRes', $(widgetFile "tutorial/tutorMassInput/add")) - miCell' :: UserId -> Widget - miCell' userId = do + miCell' :: Either UserEmail UserId -> Widget + miCell' (Left email) = + $(widgetFile "tutorial/tutorMassInput/cellInvitation") + miCell' (Right userId) = do User{..} <- liftHandlerT . runDB $ get404 userId $(widgetFile "tutorial/tutorMassInput/cellKnown") - miLayout' :: MassInputLayout ListLength UserId () + miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout") flip (renderAForm FormStandard) html $ TutorialForm @@ -282,7 +349,7 @@ postCTutorialNewR tid ssh csh = do ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do - insertRes <- runDB $ do + insertRes <- runDBJobs $ do now <- liftIO getCurrentTime insertRes <- insertUnique Tutorial { tutorialName = tfName @@ -297,9 +364,10 @@ postCTutorialNewR tid ssh csh = do , tutorialDeregisterUntil = tfDeregisterUntil , tutorialLastChanged = now } - forM_ tfTutors $ \tutor -> case insertRes of - Just tutid -> void . insert $ Tutor tutid tutor - _other -> return () + whenIsJust insertRes $ \tutid -> do + let (invites, adds) = partitionEithers $ Set.toList tfTutors + insertMany_ $ map (Tutor tutid) adds + sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites return insertRes case insertRes of Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName @@ -329,6 +397,8 @@ postTEditR tid ssh csh tutn = do E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid return $ tutor E.^. TutorUser + tutorInvites <- sourceInvitationsList tutid + let template = TutorialForm { tfName = tutorialName @@ -340,7 +410,8 @@ postTEditR tid ssh csh tutn = do , tfRegisterFrom = tutorialRegisterFrom , tfRegisterTo = tutorialRegisterTo , tfDeregisterUntil = tutorialDeregisterUntil - , tfTutors = Set.fromList tutorIds + , tfTutors = Set.fromList (map Right tutorIds) + <> Set.fromList (map (\(email, InvDBDataTutor) -> Left email) tutorInvites) } return (cid, tutid, template) @@ -348,7 +419,7 @@ postTEditR tid ssh csh tutn = do ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template formResult newTutResult $ \TutorialForm{..} -> do - insertRes <- runDB $ do + insertRes <- runDBJobs $ do now <- liftIO getCurrentTime insertRes <- myReplaceUnique tutid Tutorial { tutorialName = tfName @@ -363,8 +434,14 @@ postTEditR tid ssh csh tutn = do , tutorialDeregisterUntil = tfDeregisterUntil , tutorialLastChanged = now } - deleteWhere [ TutorTutorial ==. tutid ] - forM_ tfTutors $ void . insert . Tutor tutid + when (is _Nothing insertRes) $ do + let (invites, adds) = partitionEithers $ Set.toList tfTutors + + deleteWhere [ TutorTutorial ==. tutid ] + insertMany_ $ map (Tutor tutid) adds + + deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ] + sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites return insertRes case insertRes of Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 0061b730a..a256a7a99 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -6,9 +6,11 @@ module Handler.Utils.Invitations -- -- $procedure IsInvitableJunction(..) + , Invitation' , _invitationDBData, _invitationTokenData , InvitationReference(..), invRef , InvitationConfig(..), InvitationTokenConfig(..) + , sourceInvitations, sourceInvitationsList , sinkInvitations, sinkInvitationsF , invitationR', InvitationR(..) ) where @@ -78,6 +80,9 @@ _invitationTokenData :: IsInvitableJunction junction => Lens' (InvitationData ju _invitationTokenData = _InvitationData . _2 +type Invitation' junction = (UserEmail, Key (InvitationFor junction), InvitationData junction) + + data InvitationReference junction = IsInvitableJunction junction => InvRef (Key (InvitationFor junction)) deriving instance Eq (InvitationReference junction) @@ -114,9 +119,9 @@ data InvitationConfig junction = InvitationConfig -- ^ Monadically resolve `InvitationFor` during `inviteR` -- -- Usually from `requireBearerToken` or `getCurrentRoute` - , invitationSubject :: InvitationFor junction -> InvitationData junction -> SomeMessage UniWorX + , invitationSubject :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX) -- ^ Subject of the e-mail which sends the token to the user - , invitationHeading :: InvitationFor junction -> InvitationData junction -> SomeMessage UniWorX + , invitationHeading :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX) -- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR` , invitationExplanation :: InvitationFor junction -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) -- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`) @@ -161,7 +166,7 @@ instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction ju sinkInvitations :: forall junction. IsInvitableJunction junction => InvitationConfig junction - -> Sink (UserEmail, Key (InvitationFor junction), InvitationData junction) (YesodJobDB UniWorX) () + -> Sink (Invitation' junction) (YesodJobDB UniWorX) () -- | Register invitations in the database -- -- When an invitation for a certain junction (i.e. an `UserEmail`, `Key @@ -171,9 +176,9 @@ sinkInvitations :: forall junction. -- For new junctions an invitation is sent by e-mail. sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations' where - determineExists :: Conduit (UserEmail, Key (InvitationFor junction), InvitationData junction) + determineExists :: Conduit (Invitation' junction) (YesodJobDB UniWorX) - (Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction)) + (Either (InvitationId, InvitationData junction) (Invitation' junction)) determineExists | is _Just (ephemeralInvitation @junction) = C.map Right @@ -181,7 +186,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif = C.mapM $ \inp@(email, fid, dat) -> maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid)) - sinkInvitations' :: [Either (InvitationId, InvitationData junction) (UserEmail, Key (InvitationFor junction), InvitationData junction)] + sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)] -> YesodJobDB UniWorX () sinkInvitations' (partitionEithers -> (existing, new)) = do when (is _Nothing (ephemeralInvitation @junction)) $ do @@ -201,15 +206,15 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) jwt <- encodeToken token jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) - let jInvitationSubject = mr $ invitationSubject fRec dat - jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur + jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fRec dat + let jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur queueDBJob JobInvitation{..} sinkInvitationsF :: forall junction mono. ( IsInvitableJunction junction , MonoFoldable mono - , Element mono ~ (UserEmail, Key (InvitationFor junction), InvitationData junction) + , Element mono ~ Invitation' junction ) => InvitationConfig junction -> mono @@ -218,6 +223,25 @@ sinkInvitationsF :: forall junction mono. sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg + +sourceInvitations :: forall junction. + IsInvitableJunction junction + => Key (InvitationFor junction) + -> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction) +sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode + where + decode (Entity _ (Invitation email _ invitationData)) + = case fromJSON invitationData of + JSON.Success dbData -> return (email, dbData) + JSON.Error str -> fail $ "Could not decode invitationData: " <> str + +sourceInvitationsList :: forall junction. + IsInvitableJunction junction + => Key (InvitationFor junction) + -> YesodDB UniWorX [(UserEmail, InvitationDBData junction)] +sourceInvitationsList forKey = runConduit $ sourceInvitations forKey .| C.foldMap pure + + data ButtonInvite = BtnInviteAccept | BtnInviteDecline deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ButtonInvite @@ -268,9 +292,8 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do MsgRenderer mr <- getMsgRenderer ur <- getUrlRenderParams - let - heading = invitationHeading fRec iData - explanation = invitationExplanation fRec iData (toHtml . mr) ur + heading <- invitationHeading fRec iData + let explanation = invitationExplanation fRec iData (toHtml . mr) ur fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case Nothing -> do @@ -282,6 +305,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do case mResult of Nothing -> invalidArgsI [MsgInvitationCollision] Just res -> do + deleteBy . UniqueInvitation itEmail $ invRef @junction fid addMessageI Success =<< invitationSuccessMsg fRec res Just <$> invitationUltDest fRec res diff --git a/src/Jobs.hs b/src/Jobs.hs index 799c1689c..fd0b08c60 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -59,7 +59,6 @@ import Jobs.Handler.HelpRequest import Jobs.Handler.SetLogSettings import Jobs.Handler.DistributeCorrections import Jobs.Handler.SendCourseCommunication -import Jobs.Handler.CorrectorInvitation import Jobs.Handler.Invitation diff --git a/src/Jobs/Handler/CorrectorInvitation.hs b/src/Jobs/Handler/CorrectorInvitation.hs deleted file mode 100644 index 76e0d26c2..000000000 --- a/src/Jobs/Handler/CorrectorInvitation.hs +++ /dev/null @@ -1,42 +0,0 @@ -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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index c5a0aa763..01800048e 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -31,9 +31,6 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica , jSubject :: Maybe Text , jMailContent :: Html } - | JobCorrectorInvitation { jInviter :: UserId - , jCorrectorInvitation :: SheetCorrectorInvitation - } | JobInvitation { jInviter :: UserId , jInvitee :: UserEmail , jInvitationUrl :: Text diff --git a/src/Model.hs b/src/Model.hs index 6ae0a2f0c..703b78d71 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -41,8 +41,5 @@ deriving instance Eq (Unique Tutorial) -- Automatically generated (i.e. numeric) ids are already taken care of deriving instance Binary (Key Term) -instance Hashable LecturerInvitation -instance Hashable SheetCorrectorInvitation - submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 52780e335..7a7c6a4db 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -98,8 +98,6 @@ makePrisms ''HandlerContents makePrisms ''ErrorResponse -makeLenses_ ''SheetCorrectorInvitation - makeLenses_ ''SubmissionMode makePrisms ''E.Value diff --git a/templates/sheetCorrInvite.hamlet b/templates/sheetCorrInvite.hamlet deleted file mode 100644 index 8e51c7358..000000000 --- a/templates/sheetCorrInvite.hamlet +++ /dev/null @@ -1,3 +0,0 @@ -

- _{MsgSheetCorrInviteExplanation} -^{btnWidget} diff --git a/templates/tutorial/tutorMassInput/add.hamlet b/templates/tutorial/tutorMassInput/add.hamlet index cf4cc6e72..bdf6da247 100644 --- a/templates/tutorial/tutorMassInput/add.hamlet +++ b/templates/tutorial/tutorMassInput/add.hamlet @@ -1,5 +1,5 @@ $newline never - + #{csrf} ^{fvInput addView} diff --git a/templates/tutorial/tutorMassInput/cellInvitation.hamlet b/templates/tutorial/tutorMassInput/cellInvitation.hamlet new file mode 100644 index 000000000..27c423ad1 --- /dev/null +++ b/templates/tutorial/tutorMassInput/cellInvitation.hamlet @@ -0,0 +1,9 @@ +$newline never + + + #{email} + +

+
+
+ _{MsgEmailInvitationWarning} diff --git a/templates/tutorial/tutorMassInput/cellKnown.hamlet b/templates/tutorial/tutorMassInput/cellKnown.hamlet index c6c6cc2ad..5ea4cca6f 100644 --- a/templates/tutorial/tutorMassInput/cellKnown.hamlet +++ b/templates/tutorial/tutorMassInput/cellKnown.hamlet @@ -1,3 +1,3 @@ $newline never - + ^{nameEmailWidget userEmail userDisplayName userSurname}