chore(job): add sleep job for testing

also show running job workers

config/test-settings.yml

@@ -14,4 +14,6 @@ log-settings:
   destination:   test.log
 
 auth-dummy-login: true
-server-session-acid-fallback: true
+server-session-acid-fallback: true
+
+job-workers: 20

src/Handler/Admin/Crontab.hs

@@ -17,7 +17,7 @@ import Handler.Utils
 -- import Data.Aeson (fromJSON)
 -- import qualified Data.Aeson as Aeson
 -- import qualified Data.Aeson.Types as Aeson
-import qualified Data.Aeson.Encode.Pretty as Pretty          
+import qualified Data.Aeson.Encode.Pretty as Pretty
 
 -- import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as Text
@@ -37,13 +37,13 @@ import qualified Database.Esqueleto.Utils as E
 
 -- Number of minutes a job must have been locked already to allow forced deletion
 jobDeleteLockMinutes :: Int
-jobDeleteLockMinutes = 3 
+jobDeleteLockMinutes = 3
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1
   } ''CronNextMatch
 
-  
+
 getAdminCrontabR :: Handler TypedContent
 getAdminCrontabR = do
   jState <- getsYesod appJobState
@@ -64,7 +64,7 @@ getAdminCrontabR = do
 
         encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupCrontab) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton AdminCrontabR) Nothing (Just Nothing) Nothing
 
-      
+
       siteLayoutMsg MsgHeadingAdminCrontab $ do
         setTitleI MsgHeadingAdminCrontab
         [whamlet|
@@ -121,7 +121,7 @@ instance Finite JobTableAction
 nullaryPathPiece ''JobTableAction $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''JobTableAction id
 
-newtype JobTableActionData = ActJobDeleteData 
+newtype JobTableActionData = ActJobDeleteData
                             { jobDeleteLocked :: Bool
                             }
   deriving (Eq, Ord, Read, Show, Generic)
@@ -151,7 +151,7 @@ postAdminJobsR = do
           , sortable (Just "lock-instance")     (i18nCell MsgTableJobLockInstance)      $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe (stringCell . show) queuedJobLockInstance
           , sortable (Just "creation-instance") (i18nCell MsgTableJobCreationInstance)  $ \(view $ resultJob . _entityVal -> QueuedJob{..}) ->            stringCell $ show  queuedJobCreationInstance
           ]
-        dbtSorting = Map.fromList 
+        dbtSorting = Map.fromList
           [ ("creation-time"    , SortColumnNullsInv (E.^. QueuedJobCreationTime))
           , ("job"              , SortColumn         (\v -> v E.^. QueuedJobContent E.->>. "job"))
           , ("content"          , SortColumn         (E.^. QueuedJobContent))
@@ -171,8 +171,8 @@ postAdminJobsR = do
         acts :: Map JobTableAction (AForm Handler JobTableActionData)
         acts = Map.singleton ActJobDelete $ ActJobDeleteData
                 <$> areq checkBoxField (fslI $ MsgActJobDeleteForce jobDeleteLockMinutes) Nothing
-        dbtParams = DBParamsForm 
-          { dbParamsFormAdditional = 
+        dbtParams = DBParamsForm
+          { dbParamsFormAdditional =
             renderAForm FormStandard
                $  (, mempty) . First . Just
               <$> multiActionA acts (fslI MsgTableAction) Nothing
@@ -188,14 +188,15 @@ postAdminJobsR = do
         dbtCsvDecode = Nothing
         dbtExtraReps = []
     -- jobsDBTableValidator :: PSValidator (MForm Handler) (FormResult (First JobTableAction, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob))))
-    jobsDBTableValidator = def 
+    jobsDBTableValidator = def
       & defaultSorting [SortDescBy "creation-time"]
-    postprocess :: FormResult (First JobTableActionData, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob))) 
+    postprocess :: FormResult (First JobTableActionData, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob)))
                 -> FormResult (JobTableActionData, Set QueuedJobId)
-    postprocess inp = do 
+    postprocess inp = do
       (First (Just act), jobMap) <- inp
       let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
       return (act, jobSet)
+  void . queueJob' $ JobSleep 42 -- debug add sleep job
   (jobActRes, jobsTable) <- runDB (over _1 postprocess <$> dbTable jobsDBTableValidator jobsDBTable)
 
   formResult jobActRes $ \case
@@ -205,24 +206,33 @@ postAdminJobsR = do
           cutoff = addUTCTime (nominalMinute * fromIntegral (negate jobDeleteLockMinutes)) now
           jobReq    = length jobIds
           lockCriteria
-            | jobDeleteLocked = 
+            | jobDeleteLocked =
                 [ QueuedJobLockTime ==. Nothing ] ||.
                 [ QueuedJobLockTime <=. Just cutoff ]
-            | otherwise = 
+            | otherwise =
                 [ QueuedJobLockTime     ==. Nothing
                 , QueuedJobLockInstance ==. Nothing
                 ]
       rmvd <- runDB $ fromIntegral <$> deleteWhereCount
         ((QueuedJobId <-. Set.toList jobIds) : lockCriteria)
-        
+
       addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq)
       reloadKeepGetParams AdminJobsR
 
+  -- gather some data on job worles
+  (nrWorkers, jobStateVar) <- getsYesod (view _appJobWorkers &&& appJobState)
+  jState <- atomically $ tryReadTMVar jobStateVar
+  let running = Map.size . jobWorkers <$> jState
 
   siteLayoutMsg MsgMenuAdminJobs $ do
     setTitleI MsgMenuAdminJobs
     [whamlet|
-      ^{jobsTable}
+      <section>
+        ^{jobsTable}
+      <section>
+        <ul>
+          <li> #{running} job workers currently running
+          <li> #{nrWorkers} job workers configured to run
     |]
   where
     doEnc :: ToJSON a => a -> _
@@ -232,8 +242,8 @@ postAdminJobsR = do
                                                , Text.splitOn "-" t
                                                )
       }
-  
+
     getJobName :: Value -> Maybe Text
-    getJobName (Object o) 
+    getJobName (Object o)
       | Just (String s) <- HashMap.lookup "job" o = Just s --  (kebabToCamel s)
     getJobName _ = Nothing

src/Jobs/Handler/SendTestEmail.hs

@@ -4,6 +4,7 @@
 
 module Jobs.Handler.SendTestEmail
   ( dispatchJobSendTestEmail
+  , dispatchJobSleep
   ) where
 
 import Import
@@ -14,6 +15,8 @@ import Text.Hamlet
 -- import Handler.Utils.I18n
 -- import Text.Blaze.Internal
 
+import UnliftIO.Concurrent (threadDelay)
+
 dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX
 dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do
   _mailTo .= [Address Nothing jEmail]
@@ -58,6 +61,15 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
   --test <- liftHandler $ withUrlRenderer $(i18nHamletFile "test")
   test :: Html <- liftHandler $ withUrlRenderer $(hamletFile "templates/i18n/test/en-eu.hamlet")
   addHtmlMarkdownAlternatives test
-  -- 
+  --
   --test2 <- liftHandler $(i18nHamletFile "test")
-  --addHtmlMarkdownAlternatives test2
+  --addHtmlMarkdownAlternatives test2
+
+
+dispatchJobSleep :: Int -> JobHandler UniWorX
+dispatchJobSleep sleepTime = JobHandlerAtomic act
+  where
+    act = do
+      $logInfoS "JOBS" [st|Sleep job #{sleepTime}s started.|]
+      threadDelay (sleepTime * 1000000)
+      $logInfoS "JOBS" [st|Sleep job #{sleepTime}s ended.|]

src/Jobs/Types.hs

@@ -141,8 +141,9 @@ data Job
   | JobLmsReports     { jQualification :: QualificationId }
   | JobPrintAck
   | JobPrintAckAgain
-
+  | JobSleep          { jSleep :: Int } -- dummy job that just sleeps to test job system
   deriving (Eq, Ord, Show, Read, Generic)
+
 data Notification
   = NotificationSubmissionRated { nSubmission :: SubmissionId }
   | NotificationSheetActive { nSheet :: SheetId }