Merge branch 'master' into course-visibility

CHANGELOG.md

@@ -2,6 +2,20 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [18.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.4.0...v18.5.0) (2020-08-03)
+
+
+### Bug Fixes
+
+* **jobs:** queue certain jobs at most once ([1be9716](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1be9716))
+
+
+### Features
+
+* admin-crontab-r ([460c133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/460c133))
+
+
+
 ## [18.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.3.0...v18.4.0) (2020-08-02)
 
 

config/settings.yml

@@ -35,7 +35,7 @@ bearer-expiration: 604800
 bearer-encoding: HS256
 maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
 session-files-expire: 3600
-prune-unreferenced-files: 600
+prune-unreferenced-files: 28800
 keep-unreferenced-files: 86400
 health-check-interval:
   matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"

messages/uniworx/de-de-formal.msg

@@ -1350,6 +1350,7 @@ MenuAllocationPriorities: Zentrale Dringlichkeiten
 MenuAllocationCompute: Platzvergabe berechnen
 MenuAllocationAccept: Platzvergabe akzeptieren
 MenuFaq: FAQ
+MenuAdminCrontab: Crontab
 
 BreadcrumbSubmissionFile: Datei
 BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
@@ -1421,6 +1422,7 @@ BreadcrumbAllocationCompute: Platzvergabe berechnen
 BreadcrumbAllocationAccept: Platzvergabe akzeptieren
 BreadcrumbMessageHide: Verstecken
 BreadcrumbFaq: FAQ
+BreadcrumbAdminCrontab: Crontab
 
 ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
 ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
@@ -2677,3 +2679,7 @@ SubmissionDoneByFile: Je nach Bewertungsdatei
 SubmissionDoneAlways: Immer
 CorrUploadSubmissionDoneMode: Bewertung abgeschlossen
 CorrUploadSubmissionDoneModeTip: Sollen hochgeladene Korrekturen als abgeschlossen markiert werden? Bewertungen sind erst für Studierende sichtbar und zählen gegen Examboni, wenn sie abgeschlossen sind.
+
+AdminCrontabNotGenerated: (Noch) keine Crontab generiert
+CronMatchAsap: ASAP
+CronMatchNone: Nie

messages/uniworx/en-eu.msg

@@ -1350,6 +1350,7 @@ MenuAllocationPriorities: Central priorities
 MenuAllocationCompute: Compute allocation
 MenuAllocationAccept: Accept allocation
 MenuFaq: FAQ
+MenuAdminCrontab: Crontab
 
 BreadcrumbSubmissionFile: File
 BreadcrumbSubmissionUserInvite: Invitation to participate in a submission
@@ -1421,6 +1422,7 @@ BreadcrumbAllocationCompute: Compute allocation
 BreadcrumbAllocationAccept: Accept allocation
 BreadcrumbMessageHide: Hide
 BreadcrumbFaq: FAQ
+BreadcrumbAdminCrontab: Crontab
 
 ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn}
 ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn}
@@ -2677,3 +2679,7 @@ SubmissionDoneByFile: According to correction file
 SubmissionDoneAlways: Always
 CorrUploadSubmissionDoneMode: Rating finished
 CorrUploadSubmissionDoneModeTip: Should uploaded corrections be marked as finished? The rating is only visible to the submittors and considered for any exam bonuses if it is finished.
+
+AdminCrontabNotGenerated: Crontab not (yet) generated
+CronMatchAsap: ASAP
+CronMatchNone: Never

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "18.4.0",
+  "version": "18.5.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "18.4.0",
+  "version": "18.5.0",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 18.4.0
+version: 18.5.0
 
 dependencies:
   - base

routes

@@ -56,6 +56,7 @@
 /admin/test                   AdminTestR       GET POST
 /admin/errMsg                 AdminErrMsgR     GET POST
 /admin/tokens                 AdminTokensR     GET POST
+/admin/crontab                AdminCrontabR    GET
 
 /health                       HealthR          GET             !free
 /instance                     InstanceR        GET             !free

src/Cron.hs

@@ -1,6 +1,6 @@
 module Cron
   ( evalCronMatch
-  , CronNextMatch(..)
+  , CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone
   , nextCronMatch
   , module Cron.Types
   ) where
@@ -84,6 +84,8 @@ consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
 data CronNextMatch a = MatchAsap | MatchAt a | MatchNone
   deriving (Eq, Ord, Show, Read, Functor)
 
+makePrisms ''CronNextMatch
+
 instance Applicative CronNextMatch where
   pure = MatchAt
   _ <*> MatchNone = MatchNone

src/Database/Esqueleto/Utils.hs

@@ -298,6 +298,8 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.E
   sqlProject = (E.?.)
   unSqlProject _ _ = Just
 
+infixl 8 ->.
+
 (->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
 (->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t
 

src/Foundation.hs

@@ -2415,6 +2415,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb AdminTestR       = i18nCrumb MsgMenuAdminTest        $ Just AdminR
   breadcrumb AdminErrMsgR     = i18nCrumb MsgMenuAdminErrMsg      $ Just AdminR
   breadcrumb AdminTokensR     = i18nCrumb MsgMenuAdminTokens      $ Just AdminR
+  breadcrumb AdminCrontabR    = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
   
   breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
   breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
@@ -2902,6 +2903,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               , navQuick'      = mempty
               , navForceActive = False
               }
+          , NavLink
+              { navLabel       = MsgMenuAdminCrontab
+              , navRoute       = AdminCrontabR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
           , NavLink
               { navLabel       = MsgMenuAdminTest
               , navRoute       = AdminTestR

src/Handler/Admin.hs

@@ -10,6 +10,7 @@ import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
 import Handler.Admin.StudyFeatures as Handler.Admin
 import Handler.Admin.Tokens as Handler.Admin
+import Handler.Admin.Crontab as Handler.Admin
 
 
 getAdminR :: Handler Html

src/Handler/Admin/Crontab.hs

@@ -0,0 +1,44 @@
+module Handler.Admin.Crontab
+  ( getAdminCrontabR
+  ) where
+
+import Import
+import Jobs
+import Handler.Utils.DateTime
+
+import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
+
+
+getAdminCrontabR :: Handler Html
+getAdminCrontabR = do
+  jState <- getsYesod appJobState
+  mCrontab' <- atomically . runMaybeT $ do
+    JobState{jobCurrentCrontab} <- MaybeT $ tryReadTMVar jState
+    MaybeT $ readTVar jobCurrentCrontab
+
+  let mCrontab = mCrontab' <&> _2 %~ filter (hasn't $ _1 . _MatchNone)
+
+  siteLayoutMsg MsgMenuAdminCrontab $ do
+    setTitleI MsgMenuAdminCrontab
+    [whamlet|
+      $newline never
+      $maybe (genTime, crontab) <- mCrontab
+        <p>
+          ^{formatTimeW SelFormatDateTime genTime}
+        <table .table .table--striped .table--hover>
+          $forall (match, job) <- crontab
+            <tr .table__row>
+              <td .table__td>
+                $case match
+                  $of MatchAsap
+                    _{MsgCronMatchAsap}
+                  $of MatchNone
+                    _{MsgCronMatchNone}
+                  $of MatchAt t
+                    ^{formatTimeW SelFormatDateTime t}
+              <td .table__td>
+                <pre>
+                  #{encodePrettyToTextBuilder job}
+      $nothing
+        _{MsgAdminCrontabNotGenerated}
+    |]

src/Handler/Admin/Test.hs

@@ -86,11 +86,9 @@ postAdminTestR = do
 
   ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
   formResultModal emailResult AdminTestR $ \(email, ls) -> do
-    jId <- mapWriterT runDB $ do
+    mapWriterT runDBJobs $ do
-      jId <- queueJob $ JobSendTestEmail email ls
+      lift . queueDBJob $ JobSendTestEmail email ls
-      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
+      tell . pure $ Message Success [shamlet|Email-test gestartet|] (Just IconEmail)
-      return jId
-    runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
     addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`
 
   let emailWidget' = wrapForm emailWidget def

src/Handler/Utils/Exam.hs

@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
 
 module Handler.Utils.Exam
   ( fetchExamAux
@@ -519,7 +519,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
                    )
     postprocess result = (resultAscList, resultUsers)
       where
-        resultAscList = pad . Map.fromListWith Set.union . accRes (pure <$> Set.lookupMin rangeAlphabet) $ (\r -> traceShow (over (traverse . _2 . traverse . traverse) CI.original r) r) result
+        resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
           where
             accRes _ [] = []
             accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)

src/Jobs.hs

@@ -97,6 +97,7 @@ handleJobs foundation@UniWorX{..}
       jobCrontab <- liftIO $ newTVarIO HashMap.empty
       jobConfirm <- liftIO $ newTVarIO HashMap.empty
       jobShutdown <- liftIO newEmptyTMVarIO
+      jobCurrentCrontab <- liftIO $ newTVarIO Nothing
       atomically $ putTMVar appJobState JobState
         { jobContext = JobContext{..}
         , ..
@@ -109,12 +110,12 @@ manageCrontab :: forall m.
               => UniWorX -> (forall a. m a -> m a) -> m ()
 manageCrontab foundation@UniWorX{..} unmask = do
   ch <- allocateLinkedAsync $ do
-    context <- atomically . fmap jobContext $ readTMVar appJobState
+    jState <- atomically $ readTMVar appJobState
     liftIO . unsafeHandler foundation . void $ do
       atomically . assertM_ (not . Map.null . jobWorkers) $ readTMVar appJobState
       runReaderT ?? foundation $
         writeJobCtlBlock JobCtlDetermineCrontab
-      void $ evalRWST (forever execCrontab) context HashMap.empty
+      void $ evalRWST (forever execCrontab) jState HashMap.empty
 
   let awaitTermination = guardM $
         readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
@@ -252,7 +253,7 @@ stopJobCtl UniWorX{appJobState} = do
       , jobCron jSt'
       ] ++ workers
 
-execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
+execCrontab :: RWST JobState () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
 -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
 --   seen, wait for the time of the next job and fire it
 execCrontab = do
@@ -276,7 +277,7 @@ execCrontab = do
   refT <- liftIO getCurrentTime
   settings <- getsYesod appSettings'
   (currentCrontab, (jobCtl, nextMatch), currentState) <- mapRWST (liftIO . atomically) $ do
-    crontab <- liftBase . readTVar =<< asks jobCrontab
+    crontab <- liftBase . readTVar =<< asks (jobCrontab . jobContext)
 
     State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
     prevExec <- State.get
@@ -288,13 +289,16 @@ execCrontab = do
   do
     lastTimes <- State.get
     now <- liftIO getCurrentTime
-    $logDebugS "Crontab" . intercalate "\n" . map tshow . sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
+    let currentCrontab' = sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
+    crontabTVar <- asks jobCurrentCrontab
+    atomically . writeTVar crontabTVar $ Just (now, currentCrontab')
+    $logDebugS "Crontab" . intercalate "\n" $ "Current crontab:" : map tshow currentCrontab'
 
   let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do
         newCrontab <- lift $ hoist lift determineCrontab'
         when (newCrontab /= currentCrontab) $ 
           mapRWST (liftIO . atomically) $
-            liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
+            liftBase . void . flip swapTVar newCrontab =<< asks (jobCrontab . jobContext)
 
         mergeState
         newState <- State.get
@@ -315,11 +319,11 @@ execCrontab = do
     MatchAsap -> doJob
     MatchNone -> return ()
     MatchAt nextTime -> do
-      JobContext{jobCrontab} <- ask
+      crontab <- asks $ jobCrontab . jobContext
       nextTime' <- applyJitter jobCtl nextTime
       $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
       logFunc <- askLoggerIO
-      whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
+      whenM (liftIO . flip runLoggingT logFunc $ waitUntil crontab currentCrontab nextTime')
         doJob
 
   where

src/Jobs/Queue.hs

@@ -80,22 +80,28 @@ writeJobCtlBlock :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -
 -- | Pass an instruction to the `Job`-Workers and block until it was acted upon
 writeJobCtlBlock = writeJobCtlBlock' writeJobCtl
 
-queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX QueuedJobId
+queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX (Maybe QueuedJobId)
 queueJobUnsafe queuedJobWriteLastExec job = do
   $logInfoS "queueJob" $ tshow job
-  queuedJobCreationTime <- liftIO getCurrentTime
+  
-  queuedJobCreationInstance <- getsYesod appInstanceID
+  doQueue <- fmap not . and2M (return $ jobNoQueueSame job) $ exists [ QueuedJobContent ==. toJSON job ]
-  insert QueuedJob
+  
-    { queuedJobContent = toJSON job
+  if
-    , queuedJobLockInstance = Nothing
+    | doQueue -> Just <$> do
-    , queuedJobLockTime = Nothing
+        queuedJobCreationTime <- liftIO getCurrentTime
-    , ..
+        queuedJobCreationInstance <- getsYesod appInstanceID
-    }
+        insert QueuedJob
-  -- We should not immediately notify a worker; instead wait for the transaction to finish first
+          { queuedJobContent = toJSON job
-  -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
+          , queuedJobLockInstance = Nothing
-  -- return jId
+          , queuedJobLockTime = Nothing
+          , ..
+          }
+        -- We should not immediately notify a worker; instead wait for the transaction to finish first
+        -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
+        -- return jId
+    | otherwise -> return Nothing
 
-queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
+queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m (Maybe QueuedJobId)
 -- ^ Queue a job for later execution
 --
 -- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`)
@@ -105,15 +111,15 @@ queueJob' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m
 -- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
 queueJob' job = do
   app <- getYesod
-  queueJob job >>= flip runReaderT app . writeJobCtl . JobCtlPerform
+  queueJob job >>= maybe (return ()) (flip runReaderT app . writeJobCtl . JobCtlPerform)
 
 -- | Slightly modified Version of `DB` for `runDBJobs`
 type JobDB = YesodJobDB UniWorX
 
 queueDBJob, queueDBJobCron :: Job -> YesodJobDB UniWorX ()
 -- | Queue a job as part of a database transaction and execute it after the transaction succeeds
-queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . Set.singleton
+queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . maybe Set.empty Set.singleton
-queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . Set.singleton
+queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . maybe Set.empty Set.singleton
 
 sinkDBJobs :: ConduitT Job Void (YesodJobDB UniWorX) ()
 -- | Queue many jobs as part of a database transaction and execute them after the transaction passes

src/Jobs/Types.hs

@@ -17,6 +17,8 @@ module Jobs.Types
   , showWorkerId, newWorkerId
   , JobQueue, jqInsert, jqDequeue
   , JobPriority(..), prioritiseJob
+  , jobNoQueueSame
+  , module Cron
   ) where
 
 import Import.NoFoundation hiding (Unique, state)
@@ -37,6 +39,8 @@ import Utils.Metrics (withJobWorkerStateLbls)
 
 import qualified Prometheus (Label4)
 
+import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
+
 
 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
          | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
@@ -232,6 +236,19 @@ prioritiseJob (JobCtlGenerateHealthReport _)  = JobPrioRealtime
 prioritiseJob  JobCtlDetermineCrontab         = JobPrioRealtime
 prioritiseJob  _                              = JobPrioBatch
 
+jobNoQueueSame :: Job -> Bool
+jobNoQueueSame = \case
+  JobSendPasswordReset{}       -> True
+  JobTruncateTransactionLog{}  -> True
+  JobPruneInvitations{}        -> True
+  JobDeleteTransactionLogIPs{} -> True
+  JobSynchroniseLdapUser{}     -> True
+  JobChangeUserDisplayEmail{}  -> True
+  JobPruneSessionFiles{}       -> True
+  JobPruneUnreferencedFiles{}  -> True
+  JobInjectFiles{}             -> True
+  _                            -> False
+
 
 newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue JobPriority JobCtl }
   deriving (Eq, Ord, Read, Show)
@@ -253,6 +270,7 @@ data JobState = JobState
   , jobPoolManager :: Async ()
   , jobCron :: Async ()
   , jobShutdown :: TMVar ()
+  , jobCurrentCrontab :: TVar (Maybe (UTCTime, [(CronNextMatch UTCTime, JobCtl)]))
   }
 
 jobWorkerNames :: JobState -> Set JobWorkerId