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

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
+TableJobCreationInstance: Ersteller
+ActJobDelete: Job entfernen
+TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt

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
+TableJobCreationInstance: Creator
+ActJobDelete: Delete job
+TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted

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
+        dbtColonnade = mconcat
-          [ sortable (Just "job")               (i18nCell MsgTableJob)                  $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent
+          [ 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
+        acts :: Map JobTableAction (AForm Handler JobTableAction)
-        dbtIdent :: Text
+        acts = Map.singleton ActJobDelete $ pure ActJobDelete
-        dbtIdent = "queued-jobs"
+        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

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