diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index fe52740d4..7f732e74a 100644 --- a/src/Handler/Submission.hs +++ b/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 diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 1b4f1e770..b1618fc99 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/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. - IsInvitableJunction junction +sinkInvitations :: forall junction m backend. + ( 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' = do + sinkInvitations' :: Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) () + 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. - IsInvitableJunction junction +sinkInvitation :: forall junction m backend. + ( 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. - IsInvitableJunction junction +sourceInvitations :: forall junction m backend. + ( 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