diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 5b03468c8..16d43de61 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -83,4 +83,6 @@ TableJob !ident-ok: Job TableJobContent !ident-ok: Parameter TableJobLockTime: Bearbeitung seit TableJobLockInstance: Bearbeiter -TableJobCreationInstance: Ersteller \ No newline at end of file +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 e27dfebdf..17fbfe79a 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -83,4 +83,6 @@ TableJob !ident-ok: Job TableJobContent !ident-ok: Parameters TableJobLockTime: Lock time TableJobLockInstance: Worker -TableJobCreationInstance: Creator \ No newline at end of file +TableJobCreationInstance: Creator +ActJobDelete: Delete job +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted \ No newline at end of file diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index f309ab73f..42844d91d 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,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 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