diff --git a/CHANGELOG.md b/CHANGELOG.md index 4d8551769..d1129dc3f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,20 +2,21 @@ 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. -## [27.4.18](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.17...t27.4.18) (2023-07-16) +## [27.4.18](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.18) (2023-07-17) -## [27.4.17](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.16...t27.4.17) (2023-07-16) +## [27.4.17](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.17) (2023-07-17) -## [27.4.16](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.15...t27.4.16) (2023-07-16) +## [27.4.16](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.16) (2023-07-17) -## [27.4.15](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t0.4.0...t27.4.15) (2023-07-16) +## [27.4.15](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.14...v27.4.15) (2023-07-17) -## [27.4.14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.13...v27.4.14) (2023-07-15) +## [27.4.14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.13...v27.4.14) (2023-07-14) ### Bug Fixes * **avs:** eliminate call to undefined in Esqueleto.Internals ([240c6f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/240c6f81f81d1872317da01411fa67ec97e3b16d)) +* **job:** fix [#95](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/95) by implementing queued job deletion for admins ([5b9a554](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b9a5545457dbe506d20f7362fb6e0d6bae4f7f4)) ## [27.4.13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.12...v27.4.13) (2023-07-12) diff --git a/messages/uniworx/categories/health/de-de-formal.msg b/messages/uniworx/categories/health/de-de-formal.msg index 75aa473dd..2c8355493 100644 --- a/messages/uniworx/categories/health/de-de-formal.msg +++ b/messages/uniworx/categories/health/de-de-formal.msg @@ -9,7 +9,7 @@ HealthCheckLDAPAdmins: Anteil der Administrator:innen mit LDAP Authentifizierung HealthCheckSMTPConnect: SMTP-Server kann erreicht werden HealthCheckWidgetMemcached: Memcached-Server liefert Widgets korrekt aus HealthCheckActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen -HealthCheckDoesFlush: Zustandsprüfung läuft durch +HealthCheckDoesFlush: Abgearbeitete Jobs werden aufgeräumt InstanceIdentification: Instanz-Identifikation InstanceId: Instanz-Nummer ClusterId: Cluster-Nummer \ No newline at end of file diff --git a/messages/uniworx/categories/health/en-eu.msg b/messages/uniworx/categories/health/en-eu.msg index 948a7c4cc..4e24bd8bb 100644 --- a/messages/uniworx/categories/health/en-eu.msg +++ b/messages/uniworx/categories/health/en-eu.msg @@ -9,7 +9,7 @@ HealthCheckLDAPAdmins: Proportion of administrators with LDAP authentication tha HealthCheckSMTPConnect: SMTP server is reachable HealthCheckWidgetMemcached: Memcached server is serving widgets correctly HealthCheckActiveJobExecutors: Proportion of job workers accepting new jobs -HealthCheckDoesFlush: Health reports flushes +HealthCheckDoesFlush: Executed jobs are removed InstanceIdentification: Instance identification InstanceId: Instance id ClusterId: Cluster id diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index e95b4757e..16d43de61 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -81,3 +81,8 @@ TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job TableJobContent !ident-ok: Parameter +TableJobLockTime: Bearbeitung seit +TableJobLockInstance: Bearbeiter +TableJobCreationInstance: Ersteller +ActJobDelete: Job entfernen +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 682c66966..17fbfe79a 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -80,4 +80,9 @@ TableCompanyNos: Company numbers TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job -TableJobContent !ident-ok: Parameters \ No newline at end of file +TableJobContent !ident-ok: Parameters +TableJobLockTime: Lock time +TableJobLockInstance: Worker +TableJobCreationInstance: Creator +ActJobDelete: Delete job +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted \ No newline at end of file diff --git a/nix/docker/test-version.json b/nix/docker/test-version.json index 6a3252ea8..3a246763d 100644 --- a/nix/docker/test-version.json +++ b/nix/docker/test-version.json @@ -1,3 +1,3 @@ { - "version": "0.1.0" + "version": "27.4.18" } diff --git a/src/Application.hs b/src/Application.hs index 6592a8342..90d344bfd 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -550,8 +550,8 @@ warpSettings foundation = defaultSettings & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval)) atomically $ do results <- readTVar $ foundation ^. _appHealthReport - guard $ activeChecks == Set.map (classifyHealthReport . snd) results - guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results + guard $ activeChecks `Set.isSubsetOf` Set.map (classifyHealthReport . snd) results + guard . (/= Min HealthFailure) $ foldMap (Min . healthReportStatus . snd) results notifyReady | otherwise -> notifyReady @@ -679,7 +679,7 @@ appMain = runResourceT $ do interval <- mInterval let lastSuccess = maybeMonoid mResults & Set.filter (\(_, rep) -> classifyHealthReport rep == hc) - & Set.filter (\(_, rep) -> healthReportStatus rep >= HealthSuccess) + & Set.filter (\(_, rep) -> healthReportStatus rep > HealthFailure) & Set.mapMonotonic (view _1) & Set.lookupMax diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index 18b14fbe6..5cb000074 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -23,12 +23,14 @@ import qualified Data.Aeson.Encode.Pretty as Pretty import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.UUID as UUID +import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto.Utils.TH @@ -108,6 +110,19 @@ getAdminCrontabR = do } +data JobTableAction = ActJobDelete + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe JobTableAction +instance Finite JobTableAction +nullaryPathPiece ''JobTableAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''JobTableAction id + +-- Not yet needed, since there is no additional data for now (also, postprocess did not type somehow) +-- data JobTableActionData = ActJobDeleteData +-- deriving (Eq, Ord, Read, Show, Generic) + + getAdminJobsR, postAdminJobsR :: Handler Html getAdminJobsR = postAdminJobsR postAdminJobsR = do @@ -117,18 +132,28 @@ postAdminJobsR = do resultJob :: Lens' (DBRow (Entity QueuedJob)) (Entity QueuedJob) resultJob = _dbrOutput + dbtIdent :: Text + dbtIdent = "queued-jobs" + dbtSQLQuery = return dbtRowKey = (E.^. QueuedJobId) dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat -- remove call to dbColonnade if table actions are added - [ sortable (Just "job") (i18nCell MsgTableJob) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent - , sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime - , sortable (Just "content") (i18nCell MsgTableJobContent) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cell [whamlet|#{doEnc queuedJobContent}|] & addCellClass ("json"::Text) + dbtColonnade = mconcat + [ dbSelect (applying _2) id (return . view (resultJob . _entityKey)) + , sortable (Just "job") (i18nCell MsgTableJob) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent + , sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime + , sortable (Just "content") (i18nCell MsgTableJobContent) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cell [whamlet|#{doEnc queuedJobContent}|] & addCellClass ("json"::Text) + , sortable (Just "lock-time") (i18nCell MsgTableJobLockTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe dateTimeCell queuedJobLockTime + , 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 - [ ("creation-time", SortColumnNullsInv (E.^. QueuedJobCreationTime)) - , ("job" , SortColumn (\v -> v E.^. QueuedJobContent E.->>. "job")) - , ("content" , SortColumn (E.^. QueuedJobContent)) + [ ("creation-time" , SortColumnNullsInv (E.^. QueuedJobCreationTime)) + , ("job" , SortColumn (\v -> v E.^. QueuedJobContent E.->>. "job")) + , ("content" , SortColumn (E.^. QueuedJobContent)) + , ("lock-time" , SortColumnNullsInv (E.^. QueuedJobLockTime)) + , ("lock-instance" , SortColumn (E.^. QueuedJobLockInstance)) + , ("creation-instance", SortColumn (E.^. QueuedJobCreationInstance)) ] dbtFilter = Map.fromList [ @@ -139,15 +164,46 @@ postAdminJobsR = do prismAForm (singletonFilter "job" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableJob) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "queued-jobs" + acts :: Map JobTableAction (AForm Handler JobTableAction) + acts = Map.singleton ActJobDelete $ pure ActJobDelete + dbtParams = DBParamsForm + { dbParamsFormAdditional = + renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormMethod = POST + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] + -- jobsDBTableValidator :: PSValidator (MForm Handler) (FormResult (First JobTableAction, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob)))) jobsDBTableValidator = def & defaultSorting [SortDescBy "creation-time"] - ((), jobsTable) <- runDB $ dbTable jobsDBTableValidator jobsDBTable + -- postprocess :: FormResult (First JobTableAction, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob))) + -- -> FormResult (JobTableAction, Set QueuedJobId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + (jobActRes, jobsTable) <- runDB (over _1 postprocess <$> dbTable jobsDBTableValidator jobsDBTable) + + formResult jobActRes $ \case + (ActJobDelete, jobIds) -> do + let jobReq = length jobIds + rmvd <- fromIntegral <$> runDB (deleteWhereCount + [ QueuedJobLockTime ==. Nothing + , QueuedJobLockInstance ==. Nothing + , QueuedJobId <-. Set.toList jobIds + ]) + addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq) + reloadKeepGetParams AdminJobsR + siteLayoutMsg MsgMenuAdminJobs $ do setTitleI MsgMenuAdminJobs diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 34d20300e..2c886be11 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -326,7 +326,6 @@ instance Finite LmsTableAction nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id --- Not yet needed, since there is no additional data for now: data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData | LmsActRenewPinData -- no longer used diff --git a/src/Jobs.hs b/src/Jobs.hs index c658668dc..0d5993ce7 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -593,7 +593,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind $logInfoS logIdent [st|#{tshow kind}: #{toPathPiece newStatus}|] - unless (newStatus == HealthSuccess) $ do + unless (newStatus > HealthFailure) $ do $logErrorS logIdent [st|#{tshow kind}: #{tshow newReport}|] liftIO $ do diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs index 36f4be750..64ad49b3a 100644 --- a/src/Model/Types/Health.hs +++ b/src/Model/Types/Health.hs @@ -67,10 +67,10 @@ classifyHealthReport :: HealthReport -> HealthCheck classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig classifyHealthReport HealthLDAPAdmins{} = HealthCheckLDAPAdmins classifyHealthReport HealthHTTPReachable{} = HealthCheckHTTPReachable -classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect -classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached -classifyHealthReport HealthActiveJobExecutors{} = HealthCheckActiveJobExecutors -classifyHealthReport HealthDoesFlush{} = HealthCheckDoesFlush +classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect +classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached -- kein Neustart notwendig +classifyHealthReport HealthActiveJobExecutors{} = HealthCheckActiveJobExecutors +classifyHealthReport HealthDoesFlush{} = HealthCheckDoesFlush -- evtl. kein Neustart notwendig -- | `HealthReport` classified (`classifyHealthReport`) by badness -- @@ -111,7 +111,8 @@ healthReportStatus = \case HealthActiveJobExecutors Nothing -> HealthInactive HealthActiveJobExecutors (Just prop ) | prop > 0 -> HealthSuccess - HealthDoesFlush mProp - | maybe True (>= 2) mProp -> HealthFailure -- Looks buggy to me? + HealthDoesFlush Nothing -> HealthInactive + HealthDoesFlush (Just prop ) + | prop >= 2 -> HealthFailure | otherwise -> HealthSuccess _other -> HealthFailure