feat: admin-crontab-r

messages/uniworx/de-de-formal.msg

@@ -1340,6 +1340,7 @@ MenuAllocationPriorities: Zentrale Dringlichkeiten
 MenuAllocationCompute: Platzvergabe berechnen
 MenuAllocationAccept: Platzvergabe akzeptieren
 MenuFaq: FAQ
+MenuAdminCrontab: Crontab
 
 BreadcrumbSubmissionFile: Datei
 BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
@@ -1411,6 +1412,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}
@@ -2664,4 +2666,8 @@ SubmissionDoneNever: Nie
 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.
+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

@@ -1340,6 +1340,7 @@ MenuAllocationPriorities: Central priorities
 MenuAllocationCompute: Compute allocation
 MenuAllocationAccept: Accept allocation
 MenuFaq: FAQ
+MenuAdminCrontab: Crontab
 
 BreadcrumbSubmissionFile: File
 BreadcrumbSubmissionUserInvite: Invitation to participate in a submission
@@ -1411,6 +1412,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}
@@ -2665,3 +2667,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

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/Foundation.hs

@@ -2362,6 +2362,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
@@ -2849,6 +2850,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' & mapped . _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/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/Types.hs

@@ -17,6 +17,7 @@ module Jobs.Types
   , showWorkerId, newWorkerId
   , JobQueue, jqInsert, jqDequeue
   , JobPriority(..), prioritiseJob
+  , module Cron
   ) where
 
 import Import.NoFoundation hiding (Unique, state)
@@ -37,6 +38,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 }
@@ -253,6 +256,7 @@ data JobState = JobState
   , jobPoolManager :: Async ()
   , jobCron :: Async ()
   , jobShutdown :: TMVar ()
+  , jobCurrentCrontab :: TVar (Maybe (UTCTime, [(CronNextMatch UTCTime, JobCtl)]))
   }
 
 jobWorkerNames :: JobState -> Set JobWorkerId