diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index a9121edf4..522b10b06 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -60,7 +60,7 @@ data AllocationCourseForm = AllocationCourseForm , acfMinCapacity :: Int } -courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> Maybe (Entity AllocationCourse) -> CourseForm +courseToForm :: Entity Course -> [Lecturer] -> Map UserEmail (InvitationDBData Lecturer) -> Maybe (Entity AllocationCourse) -> CourseForm courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm { cfCourseId = Just cid , cfName = courseName @@ -83,7 +83,7 @@ courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm , cfRegTo = courseRegisterTo , cfDeRegUntil = courseDeregisterUntil , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] - ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ] + ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- Map.toList lecInvites ] } where cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (Left . E.unValue) @@ -397,7 +397,7 @@ getCourseNewR = do return course template <- case listToMaybe oldCourses of (Just oldTemplate) -> - let newTemplate = courseToForm oldTemplate [] [] Nothing in + let newTemplate = courseToForm oldTemplate mempty mempty Nothing in return $ Just $ newTemplate { cfCourseId = Nothing , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness @@ -429,7 +429,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 $ sourceInvitationsList . entityKey + mbLecInvites <- for mbCourse $ sourceInvitationsF . entityKey mbAllocation <- for mbCourse $ \course -> getBy . UniqueAllocationCourse $ entityKey course return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbAllocation -- IMPORTANT: both GET and POST Handler must use the same template, diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 503e066d4..ac4167be2 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -8,12 +8,13 @@ module Handler.Exam.Form ) where import Import -import Handler.Exam.CorrectorInvite +import Handler.Exam.CorrectorInvite () import Handler.Utils import Handler.Utils.Invitations import Data.Map ((!)) +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto as E @@ -231,7 +232,7 @@ examFormTemplate (Entity eId Exam{..}) = do examParts <- selectList [ ExamPartExam ==. eId ] [] occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] correctors <- selectList [ ExamCorrectorExam ==. eId ] [] - invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId + invitations <- Map.keysSet <$> sourceInvitationsF @ExamCorrector eId examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ @@ -273,7 +274,7 @@ examFormTemplate (Entity eId Exam{..}) = do , epfWeight = examPartWeight } , efCorrectors = Set.unions - [ Set.fromList $ map Left invitations + [ Set.mapMonotonic Left invitations , Set.fromList . map Right $ do Entity _ ExamCorrector{..} <- correctors return examCorrectorUser diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 96f2ec55f..cda01b02a 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -704,7 +704,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 $ \(email, InvDBDataSheetCorrector load state) -> Map.singleton (Left email) (state, load)) (sourceInvitationsList shid) + <*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid) (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads isWrite <- liftHandlerT $ isWriteRequest currentRoute diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 2cba120df..d2d5a6138 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -330,7 +330,7 @@ submissionHelper tid ssh csh shn mcid = do | uid == userID = (Any True , mempty ) | otherwise = (mempty , Set.singleton $ Right userID) - invites <- sourceInvitationsList smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email) + invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email) return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors @@ -440,6 +440,12 @@ submissionHelper tid ssh csh shn mcid = do | isJust msmid -> setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] [] | otherwise -> return Set.empty -- optimization (do not perform selection if submission was freshly created) + -- Since invitations carry no data we only need to consider changes to + -- the set of users/invited emails + -- Otherwise we would have to update old invitations (via + -- `sinkInvitationsF`) because their associated @DBData@ might have + -- changed + forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if -- change is a new user being added to the submission users => send invitation / insert | change `Set.member` subUsers -> case change of @@ -449,11 +455,11 @@ submissionHelper tid ssh csh shn mcid = do return () Right subUid -> do -- user exists and has an id => insert as SubmissionUser and audit - _ <- insert $ SubmissionUser subUid smid + insert_ $ SubmissionUser subUid smid audit $ TransactionSubmissionUserEdit smid subUid -- change is an old user that is not a submission user anymore => delete invitation / delete | otherwise -> case change of - Left subEmail -> runConduit $ yield subEmail .| deleteInvitations @SubmissionUser smid + Left subEmail -> deleteInvitation @SubmissionUser smid subEmail Right subUid -> do deleteWhere [SubmissionUserUser ==. subUid] audit $ TransactionSubmissionUserDelete smid subUid diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 4f3799955..0120e766f 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -413,7 +413,7 @@ postTEditR tid ssh csh tutn = do E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid return $ tutor E.^. TutorUser - tutorInvites <- sourceInvitationsList tutid + tutorInvites <- sourceInvitationsF @Tutor tutid let template = TutorialForm @@ -427,7 +427,7 @@ postTEditR tid ssh csh tutn = do , tfRegisterTo = tutorialRegisterTo , tfDeregisterUntil = tutorialDeregisterUntil , tfTutors = Set.fromList (map Right tutorIds) - <> Set.fromList (map (\(email, InvDBDataTutor) -> Left email) tutorInvites) + <> Set.mapMonotonic Left (Map.keysSet tutorInvites) } return (cid, tutid, template) diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index b9c7d9156..1b4f1e770 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -10,9 +10,9 @@ module Handler.Utils.Invitations , _invitationDBData, _invitationTokenData , InvitationReference(..), invRef , InvitationConfig(..), InvitationTokenConfig(..) - , sourceInvitations, sourceInvitationsList - , deleteInvitations - , sinkInvitations, sinkInvitationsF + , sourceInvitations, sourceInvitationsF + , deleteInvitations, deleteInvitationsF, deleteInvitation + , sinkInvitations, sinkInvitationsF, sinkInvitation , invitationR', InvitationR(..) ) where @@ -68,8 +68,6 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX) _InvitationData = id -- | If `ephemeralInvitation` is not `Nothing` pending invitations are not stored in the database - -- - -- In this case no invitation data can be stored in the database (@InvitationDBData junction ~ ()@) ephemeralInvitation :: Maybe (AnIso' () (InvitationDBData junction)) ephemeralInvitation = Nothing @@ -170,13 +168,11 @@ sinkInvitations :: forall junction. IsInvitableJunction junction => InvitationConfig junction -> Sink (Invitation' junction) (YesodJobDB UniWorX) () --- | Register invitations in the database +-- | Register invitations in the database and send them by email -- -- When an invitation for a certain junction (i.e. an `UserEmail`, `Key --- (InvitationFor junction)`-Pair) already exists it's `InvitationData` is --- updated, instead. --- --- For new junctions an invitation is sent by e-mail. +-- (InvitationFor junction)`-Pair) already exists it is deleted and resent +-- (because the token-data may have changed) sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' where determineExists :: Conduit (Invitation' junction) @@ -242,6 +238,13 @@ sinkInvitationsF :: forall junction mono. -- | Non-conduit version of `sinkInvitations` sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg +sinkInvitation :: forall junction. + IsInvitableJunction junction + => InvitationConfig junction + -> Invitation' junction + -> YesodJobDB UniWorX () +-- | Singular version of `sinkInvitationsF` +sinkInvitation cfg = sinkInvitationsF cfg . Identity sourceInvitations :: forall junction. @@ -255,23 +258,53 @@ sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forK JSON.Success dbData -> return (invitationEmail, 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 +sourceInvitationsF :: forall junction map. + ( IsInvitableJunction junction + , IsMap map + , ContainerKey map ~ UserEmail + , MapValue map ~ InvitationDBData junction + ) + => Key (InvitationFor junction) + -> YesodDB UniWorX map +sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap (uncurry singletonMap) --- | Deletes all invitations for given emails and a given junction. (Type application required) +-- | Deletes all invitations for given emails and a given instance of the +-- non-user side of the junction +-- +-- Requires type application to determine @junction@-type, i.e.: +-- +-- > runConduit $ yield userEmail .| deleteInvitations @SubmissionUser submissionId deleteInvitations :: forall junction m. ( IsInvitableJunction junction , MonadIO m ) => Key (InvitationFor junction) -> Sink UserEmail (ReaderT SqlBackend m) () -deleteInvitations k = do - subEmails <- C.foldMap Set.singleton - lift $ deleteWhere [InvitationEmail <-. Set.toList subEmails, InvitationFor ==. invRef @junction k] +deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k + +deleteInvitationsF :: forall junction m mono. + ( IsInvitableJunction junction + , MonadIO m + , MonoFoldable mono + , Element mono ~ UserEmail + ) + => Key (InvitationFor junction) + -> mono + -> ReaderT SqlBackend m () +-- | Non-conduit version of `deleteInvitations` +deleteInvitationsF invitationFor (otoList -> emailList) + = deleteWhere [InvitationEmail <-. nub emailList, InvitationFor ==. invRef @junction invitationFor] + +deleteInvitation :: forall junction m. + ( IsInvitableJunction junction + , MonadIO m + ) + => Key (InvitationFor junction) + -> UserEmail + -> ReaderT SqlBackend m () +-- | Singular version of `deleteInvitationsF` +deleteInvitation invitationFor = deleteInvitationsF @junction invitationFor . Identity data ButtonInvite = BtnInviteAccept | BtnInviteDecline