refactor(invitations): cleanup

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,

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

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

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

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)

src/Handler/Utils/Invitations.hs

@@ -10,9 +10,9 @@ module Handler.Utils.Invitations
   , _invitationDBData, _invitationTokenData
   , InvitationReference(..), invRef
   , InvitationConfig(..), InvitationTokenConfig(..)
-  , sourceInvitations, sourceInvitationsList
+  , sourceInvitations, sourceInvitationsF
-  , deleteInvitations
+  , deleteInvitations, deleteInvitationsF, deleteInvitation
-  , sinkInvitations, sinkInvitationsF
+  , 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
+-- (InvitationFor junction)`-Pair) already exists it is deleted and resent
--- updated, instead.
+-- (because the token-data may have changed)
---
--- For new junctions an invitation is sent by e-mail.
 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.
+sourceInvitationsF :: forall junction map.
-                         IsInvitableJunction junction
+                         ( IsInvitableJunction junction
-                      => Key (InvitationFor junction)
+                         , IsMap map
-                      -> YesodDB UniWorX [(UserEmail, InvitationDBData junction)]
+                         , ContainerKey map ~ UserEmail
-sourceInvitationsList forKey = runConduit $ sourceInvitations forKey .| C.foldMap pure
+                         , 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
+deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k
-  subEmails <- C.foldMap Set.singleton
+  
-  lift $ deleteWhere [InvitationEmail <-. Set.toList subEmails, InvitationFor ==. invRef @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