From 0044cea857cd2807589732ed1c959eeefe057bc0 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 28 Aug 2019 13:25:13 +0200 Subject: [PATCH 1/3] refactor(invitations): insert invitations one at a time --- src/Handler/Utils/Invitations.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 94740d96c..22b846c66 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -175,7 +175,7 @@ sinkInvitations :: forall junction. -- updated, instead. -- -- For new junctions an invitation is sent by e-mail. -sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations' +sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' where determineExists :: Conduit (Invitation' junction) (YesodJobDB UniWorX) @@ -201,13 +201,9 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif JSON.Success dbData -> return dbData JSON.Error str -> fail $ "Could not decode invitationData: " <> str - sinkInvitations' :: [Invitation' junction] - -> YesodJobDB UniWorX () - sinkInvitations' new = do - when (is _Nothing (ephemeralInvitation @junction)) $ do - insertMany_ $ map (\(email, fid, dat) -> Invitation email (invRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new - -- forM_ existing $ \(iid, oldDat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ] - forM_ new $ \(jInvitee, fid, dat) -> do + sinkInvitations' :: Sink (Invitation' junction) (YesodJobDB UniWorX) () + sinkInvitations' = do + C.mapM_ $ \(jInvitee, fid, dat) -> do app <- getYesod let mr = renderMessage app $ NonEmpty.toList appLanguages ur <- getUrlRenderParams @@ -224,6 +220,8 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur + when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation jInvitee (invRef @junction fid) (toJSON $ dat ^. _invitationDBData) + queueDBJob JobInvitation{..} sinkInvitationsF :: forall junction mono. From 1c2f2b7221d2bb237f3f1da61ca1cd9cde791506 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 28 Aug 2019 14:18:36 +0200 Subject: [PATCH 2/3] feat(invitations): save expiresAt to DB --- models/invitations | 1 + src/Handler/Utils/Invitations.hs | 11 ++++++++--- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/models/invitations b/models/invitations index c1d15148c..c915d08e4 100644 --- a/models/invitations +++ b/models/invitations @@ -2,4 +2,5 @@ Invitation email UserEmail for Value data Value + expiresAt UTCTime Maybe UniqueInvitation email for \ No newline at end of file diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 22b846c66..00b266b0f 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -220,7 +220,12 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur - when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation jInvitee (invRef @junction fid) (toJSON $ dat ^. _invitationDBData) + when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation + { invitationEmail = jInvitee + , invitationFor = invRef @junction fid + , invitationData = toJSON $ dat ^. _invitationDBData + , invitationExpiresAt = tokenExpiresAt token + } queueDBJob JobInvitation{..} @@ -243,9 +248,9 @@ sourceInvitations :: forall junction. -> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction) sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode where - decode (Entity _ (Invitation email _ invitationData)) + decode (Entity _ (Invitation{invitationEmail, invitationData})) = case fromJSON invitationData of - JSON.Success dbData -> return (email, dbData) + JSON.Success dbData -> return (invitationEmail, dbData) JSON.Error str -> fail $ "Could not decode invitationData: " <> str sourceInvitationsList :: forall junction. From a9c527621ec17287b119617573e22ca918d20d9d Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 28 Aug 2019 16:03:08 +0200 Subject: [PATCH 3/3] feat(crontab): cronjob for pruning expired invitations --- src/Jobs.hs | 1 + src/Jobs/Crontab.hs | 12 ++++++++++++ src/Jobs/Handler/PruneInvitations.hs | 13 +++++++++++++ src/Jobs/Types.hs | 1 + src/Utils/Lens.hs | 2 ++ 5 files changed, 29 insertions(+) create mode 100644 src/Jobs/Handler/PruneInvitations.hs diff --git a/src/Jobs.hs b/src/Jobs.hs index ba9296216..56a65ae22 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -66,6 +66,7 @@ import Jobs.Handler.SendCourseCommunication import Jobs.Handler.Invitation import Jobs.Handler.SendPasswordReset import Jobs.Handler.TransactionLog +import Jobs.Handler.PruneInvitations import Jobs.HealthReport diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 8d07f908e..121e11360 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -12,6 +12,8 @@ import Data.Semigroup (Max(..)) import Data.Time.Zones +import Handler.Utils.DateTime + import Control.Monad.Trans.Writer (WriterT, execWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -44,6 +46,16 @@ determineCrontab = execWriterT $ do , cronRateLimit = appJobCronInterval , cronNotAfter = Right CronNotScheduled } + + oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1] + whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton + (JobCtlQueue JobPruneInvitations) + Cron + { cronInitial = CronTimestamp $ utcToLocalTime oldestInvUTC + , cronRepeat = CronRepeatOnChange + , cronRateLimit = nominalDay + , cronNotAfter = Right CronNotScheduled + } tell . flip foldMap universeF $ \kind -> case appHealthCheckInterval kind of diff --git a/src/Jobs/Handler/PruneInvitations.hs b/src/Jobs/Handler/PruneInvitations.hs new file mode 100644 index 000000000..c9456454c --- /dev/null +++ b/src/Jobs/Handler/PruneInvitations.hs @@ -0,0 +1,13 @@ +module Jobs.Handler.PruneInvitations + ( dispatchJobPruneInvitations + ) where + +import Import + +import Database.Persist.Sql (deleteWhereCount) + +dispatchJobPruneInvitations :: Handler () +dispatchJobPruneInvitations = do + now <- liftIO getCurrentTime + n <- runDB $ deleteWhereCount [ InvitationExpiresAt <. Just now ] + $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|] \ No newline at end of file diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index ad667cd75..040a1b2f1 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -49,6 +49,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobSendPasswordReset { jRecipient :: UserId } | JobTruncateTransactionLog + | JobPruneInvitations | JobDeleteTransactionLogIPs deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index d72fdac3e..83bff05d0 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -149,6 +149,8 @@ makeLenses_ ''Occurrences makeLenses_ ''PredDNF +makeLenses_ ''Invitation + makeLenses_ ''ExamBonusRule makeLenses_ ''ExamGradingRule makeLenses_ ''ExamResult