Merge branch '423-uneingeloste-einladungen-garbage-collecten' into 'master'

Resolve "Uneingelöste Einladungen garbage-collecten"

Closes #423

See merge request !264

models/invitations

@@ -2,4 +2,5 @@ Invitation
   email     UserEmail
   for       Value
   data      Value
+  expiresAt UTCTime Maybe
   UniqueInvitation email for

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,13 @@ 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
+                                                                       { invitationEmail = jInvitee
+                                                                       , invitationFor = invRef @junction fid
+                                                                       , invitationData = toJSON $ dat ^. _invitationDBData
+                                                                       , invitationExpiresAt = tokenExpiresAt token
+                                                                       }
+
         queueDBJob JobInvitation{..}
 
 sinkInvitationsF :: forall junction mono.
@@ -245,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.

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
 

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

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

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 }

src/Utils/Lens.hs

@@ -149,6 +149,8 @@ makeLenses_ ''Occurrences
 
 makeLenses_ ''PredDNF
 
+makeLenses_ ''Invitation
+
 makeLenses_ ''ExamBonusRule
 makeLenses_ ''ExamGradingRule
 makeLenses_ ''ExamResult