fix(submission-users): properly delete old invitations

src/Handler/Submission.hs

@@ -437,7 +437,9 @@ submissionHelper tid ssh csh shn mcid = do
 
           -- Determine old submission users
           subUsersOld <- if
-            | isJust msmid -> setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []
+            | isJust msmid -> Set.union
+                <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] [])
+                <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email))
             | 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

src/Handler/Utils/Invitations.hs

@@ -24,7 +24,8 @@ import Handler.Utils.Tokens
 
 import Text.Hamlet
 
-import Control.Monad.Trans.Reader (mapReaderT)
+import Control.Monad.Trans.Writer (WriterT) 
+import Control.Monad.Trans.Reader (mapReaderT, withReaderT)
 
 import qualified Data.Conduit.List as C
 import qualified Data.List.NonEmpty as NonEmpty
@@ -37,6 +38,8 @@ import qualified Data.Aeson as JSON
 import Data.Proxy (Proxy(..))
 import Data.Typeable
 
+import Database.Persist.Sql (SqlBackendCanWrite, SqlBackendCanRead)
+
 
 class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
       , ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction)
@@ -164,10 +167,13 @@ instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction ju
   parseJSON = $(mkParseJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction)
 
 
-sinkInvitations :: forall junction.
+sinkInvitations :: forall junction m backend.
-                   IsInvitableJunction junction
+                   ( IsInvitableJunction junction
+                   , MonadHandler m, SqlBackendCanWrite backend
+                   , HandlerSite m ~ UniWorX
+                   )
                 => InvitationConfig junction
-                -> Sink (Invitation' junction) (YesodJobDB UniWorX) ()
+                -> Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
 -- | Register invitations in the database and send them by email
 --
 -- When an invitation for a certain junction (i.e. an `UserEmail`, `Key
@@ -176,7 +182,7 @@ sinkInvitations :: forall junction.
 sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
   where
     determineExists :: Conduit (Invitation' junction)
-                               (YesodJobDB UniWorX)
+                               (ReaderT backend (WriterT (Set QueuedJobId) m))
                                (Invitation' junction)
     determineExists
       | is _Just (ephemeralInvitation @junction)
@@ -199,8 +205,8 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
               JSON.Success dbData -> return dbData
               JSON.Error   str    -> fail $ "Could not decode invitationData: " <> str
 
-    sinkInvitations' :: Sink (Invitation' junction) (YesodJobDB UniWorX) ()
+    sinkInvitations' :: Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) ()
-    sinkInvitations' = do
+    sinkInvitations' = transPipe (hoist (hoist liftHandlerT) . withReaderT persistBackend) $ do
       C.mapM_ $ \(jInvitee, fid, dat) -> do
         app <- getYesod
         let mr = renderMessage app $ NonEmpty.toList appLanguages
@@ -227,30 +233,37 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
 
         queueDBJob JobInvitation{..}
 
-sinkInvitationsF :: forall junction mono.
+sinkInvitationsF :: forall junction mono m backend.
                     ( IsInvitableJunction junction
                     , MonoFoldable mono
                     , Element mono ~ Invitation' junction
+                    , MonadHandler m, SqlBackendCanWrite backend
+                    , HandlerSite m ~ UniWorX
                     )
                  => InvitationConfig junction
                  -> mono
-                 -> YesodJobDB UniWorX ()
+                 -> ReaderT backend (WriterT (Set QueuedJobId) m) ()
 -- | Non-conduit version of `sinkInvitations`
 sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg
 
-sinkInvitation :: forall junction.
+sinkInvitation :: forall junction m backend.
-                  IsInvitableJunction junction
+                  ( IsInvitableJunction junction
+                  , MonadHandler m, SqlBackendCanWrite backend
+                  , HandlerSite m ~ UniWorX
+                  )
                => InvitationConfig junction
                -> Invitation' junction
-               -> YesodJobDB UniWorX ()
+               -> ReaderT backend (WriterT (Set QueuedJobId) m) ()
 -- | Singular version of `sinkInvitationsF`
 sinkInvitation cfg = sinkInvitationsF cfg . Identity
 
 
-sourceInvitations :: forall junction.
+sourceInvitations :: forall junction m backend.
-                     IsInvitableJunction junction
+                     ( IsInvitableJunction junction
+                     , MonadResource m, SqlBackendCanRead backend
+                     )
                   => Key (InvitationFor junction)
-                  -> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction)
+                  -> Source (ReaderT backend m) (UserEmail, InvitationDBData junction)
 sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
   where
     decode (Entity _ (Invitation{invitationEmail, invitationData}))
@@ -258,14 +271,15 @@ sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forK
           JSON.Success dbData -> return (invitationEmail, dbData)
           JSON.Error   str    -> fail $ "Could not decode invitationData: " <> str
 
-sourceInvitationsF :: forall junction map.
+sourceInvitationsF :: forall junction map m backend.
                          ( IsInvitableJunction junction
                          , IsMap map
                          , ContainerKey map ~ UserEmail
                          , MapValue map ~ InvitationDBData junction
+                         , MonadResource m, SqlBackendCanRead backend
                          )
                    => Key (InvitationFor junction)
-                   -> YesodDB UniWorX map 
+                   -> ReaderT backend m map 
 sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap (uncurry singletonMap)
 
 
@@ -275,34 +289,34 @@ sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap (
 -- Requires type application to determine @junction@-type, i.e.:
 --
 -- > runConduit $ yield userEmail .| deleteInvitations @SubmissionUser submissionId
-deleteInvitations :: forall junction m.
+deleteInvitations :: forall junction m backend.
                      ( IsInvitableJunction junction
-                     , MonadIO m
+                     , MonadIO m, SqlBackendCanWrite backend
                      )
                   => Key (InvitationFor junction)
-                  -> Sink UserEmail (ReaderT SqlBackend m) ()
+                  -> Sink UserEmail (ReaderT backend m) ()
 deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k
   
-deleteInvitationsF :: forall junction m mono.
+deleteInvitationsF :: forall junction m mono backend.
                       ( IsInvitableJunction junction
-                      , MonadIO m
+                      , MonadIO m, SqlBackendCanWrite backend
                       , MonoFoldable mono
                       , Element mono ~ UserEmail
                       )
                    => Key (InvitationFor junction)
                    -> mono
-                   -> ReaderT SqlBackend m ()
+                   -> ReaderT backend m ()
 -- | Non-conduit version of `deleteInvitations`
 deleteInvitationsF invitationFor (otoList -> emailList)
   = deleteWhere [InvitationEmail <-. nub emailList, InvitationFor ==. invRef @junction invitationFor] 
 
-deleteInvitation :: forall junction m.
+deleteInvitation :: forall junction m backend.
                     ( IsInvitableJunction junction
-                    , MonadIO m
+                    , MonadIO m, SqlBackendCanWrite backend
                     )
                  => Key (InvitationFor junction)
                  -> UserEmail
-                 -> ReaderT SqlBackend m ()
+                 -> ReaderT backend m ()
 -- | Singular version of `deleteInvitationsF`
 deleteInvitation invitationFor = deleteInvitationsF @junction invitationFor . Identity