fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(invitations): cleanup

Browse Source
This commit is contained in:
Gregor Kleen 2019-09-06 09:30:14 +02:00
parent baa7a52cdb
commit 5fb6910a58
6 changed files with 72 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/Handler/Course/Edit.hs
View File

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

7
src/Handler/Exam/Form.hs
View File

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

2
src/Handler/Sheet.hs
View File

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

12
src/Handler/Submission.hs
View File

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

4
src/Handler/Tutorial.hs
View File

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

71
src/Handler/Utils/Invitations.hs
View File

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