fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(job): fix #95 by implementing queued job deletion for admins

Browse Source
This commit is contained in:
Steffen Jost 2023-07-14 15:48:18 +00:00
parent 2fc7ac610b
commit 5b9a554545
4 changed files with 61 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -83,4 +83,6 @@ TableJob !ident-ok: Job
TableJobContent !ident-ok: Parameter
TableJobLockTime: Bearbeitung seit
TableJobLockInstance: Bearbeiter
TableJobCreationInstance: Ersteller
TableJobCreationInstance: Ersteller
ActJobDelete: Job entfernen
TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt

4
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -83,4 +83,6 @@ TableJob !ident-ok: Job
TableJobContent !ident-ok: Parameters
TableJobLockTime: Lock time
TableJobLockInstance: Worker
TableJobCreationInstance: Creator
TableJobCreationInstance: Creator
ActJobDelete: Delete job
TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted

61
src/Handler/Admin/Crontab.hs
View File

@ -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,11 +132,15 @@ 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
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
@ -145,15 +164,45 @@ 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

1
src/Handler/LMS.hs
View File

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