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

fix(submission-users): properly delete old invitations

Browse Source
This commit is contained in:
Gregor Kleen 2019-09-11 17:06:12 +02:00
parent 33338cdfe9
commit 91c926b1c5
2 changed files with 43 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Handler/Submission.hs
View File

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

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

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