224 lines
9.2 KiB
Haskell
224 lines
9.2 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Admin.Crontab
|
|
( getAdminCrontabR
|
|
, getAdminJobsR
|
|
, postAdminJobsR
|
|
) where
|
|
|
|
import Import
|
|
import Jobs
|
|
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.CaseInsensitive as CI
|
|
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
|
|
|
|
|
|
deriveJSON defaultOptions
|
|
{ constructorTagModifier = camelToPathPiece' 1
|
|
} ''CronNextMatch
|
|
|
|
|
|
getAdminCrontabR :: Handler TypedContent
|
|
getAdminCrontabR = do
|
|
jState <- getsYesod appJobState
|
|
mCrontab' <- atomically . runMaybeT $ do
|
|
JobState{jobCurrentCrontab} <- MaybeT $ tryReadTMVar jState
|
|
MaybeT $ readTVar jobCurrentCrontab
|
|
|
|
let mCrontab = mCrontab' <&> _2 %~ filter (hasn't $ _3 . _MatchNone)
|
|
|
|
instanceId <- getsYesod appInstanceID
|
|
|
|
selectRep $ do
|
|
provideRep $ do
|
|
crontabBearer <- runMaybeT . hoist runDB $ do
|
|
guardM $ hasGlobalGetParam GetGenerateToken
|
|
uid <- MaybeT maybeAuthId
|
|
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupCrontab uid
|
|
|
|
encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupCrontab) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton AdminCrontabR) Nothing (Just Nothing) Nothing
|
|
|
|
|
|
siteLayoutMsg MsgHeadingAdminCrontab $ do
|
|
setTitleI MsgHeadingAdminCrontab
|
|
[whamlet|
|
|
$newline never
|
|
$maybe t <- crontabBearer
|
|
<section>
|
|
<pre .token>
|
|
#{toPathPiece t}
|
|
<section>
|
|
<dl .deflist>
|
|
<dt .deflist__dt>_{MsgAdminInstanceId}
|
|
<dd .deflist__dd .uuid>#{UUID.toText instanceId}
|
|
<section>
|
|
$maybe (genTime, crontab) <- mCrontab
|
|
<p>
|
|
^{formatTimeW SelFormatDateTime genTime}
|
|
<table .table .table--striped .table--hover>
|
|
$forall (job, lExec, match) <- crontab
|
|
<tr .table__row>
|
|
<td .table__td>
|
|
$case match
|
|
$of MatchAsap
|
|
_{MsgCronMatchAsap}
|
|
$of MatchNone
|
|
_{MsgCronMatchNone}
|
|
$of MatchAt t
|
|
^{formatTimeW SelFormatDateTime t}
|
|
<td .table__td>
|
|
$maybe lT <- lExec
|
|
^{formatTimeW SelFormatDateTime lT}
|
|
<td .table__td .json>
|
|
#{doEnc job}
|
|
$nothing
|
|
<p .explanation>
|
|
_{MsgAdminCrontabNotGenerated}
|
|
|]
|
|
provideJson mCrontab'
|
|
provideRep . return . Text.Builder.toLazyText $ doEnc mCrontab'
|
|
where
|
|
doEnc :: ToJSON a => a -> _
|
|
doEnc = Pretty.encodePrettyToTextBuilder' Pretty.defConfig
|
|
{ Pretty.confIndent = Pretty.Spaces 2
|
|
, Pretty.confCompare = comparing $ \t -> ( t `elem` ["instruction", "job", "notification"]
|
|
, Text.splitOn "-" t
|
|
)
|
|
}
|
|
|
|
|
|
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
|
|
|
|
data JobTableActionData = ActJobDeleteData
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
getAdminJobsR, postAdminJobsR :: Handler Html
|
|
getAdminJobsR = postAdminJobsR
|
|
postAdminJobsR = do
|
|
let
|
|
jobsDBTable = DBTable{..}
|
|
where
|
|
resultJob :: Lens' (DBRow (Entity QueuedJob)) (Entity QueuedJob)
|
|
resultJob = _dbrOutput
|
|
|
|
dbtIdent :: Text
|
|
dbtIdent = "queued-jobs"
|
|
|
|
dbtSQLQuery = return
|
|
dbtRowKey = (E.^. QueuedJobId)
|
|
dbtProj = dbtProjId
|
|
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))
|
|
, ("lock-time" , SortColumnNullsInv (E.^. QueuedJobLockTime))
|
|
, ("lock-instance" , SortColumn (E.^. QueuedJobLockInstance))
|
|
, ("creation-instance", SortColumn (E.^. QueuedJobCreationInstance))
|
|
]
|
|
dbtFilter = Map.fromList
|
|
[
|
|
("job", FilterColumn $ E.mkContainsFilter (\v -> v E.^. QueuedJobContent E.->>. "job"))
|
|
]
|
|
dbtFilterUI = \mPrev -> mconcat
|
|
[
|
|
prismAForm (singletonFilter "job" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableJob)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
acts :: Map JobTableAction (AForm Handler JobTableActionData)
|
|
acts = Map.singleton ActJobDelete $ pure ActJobDeleteData
|
|
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"]
|
|
postprocess :: FormResult (First JobTableActionData, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob)))
|
|
-> FormResult (JobTableActionData, 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
|
|
(ActJobDeleteData, jobIds) -> do
|
|
let jobReq = length jobIds
|
|
rmvd <- runDB $ fromIntegral <$> 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
|
|
[whamlet|
|
|
^{jobsTable}
|
|
|]
|
|
where
|
|
doEnc :: ToJSON a => a -> _
|
|
doEnc = Pretty.encodePrettyToTextBuilder' Pretty.defConfig
|
|
{ Pretty.confIndent = Pretty.Spaces 2
|
|
, Pretty.confCompare = comparing $ \t -> ( t `elem` ["job", "notification"]
|
|
, Text.splitOn "-" t
|
|
)
|
|
}
|
|
|
|
getJobName :: Value -> Maybe Text
|
|
getJobName (Object o)
|
|
| Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s
|
|
getJobName _ = Nothing |