144 lines
9.0 KiB
Haskell
144 lines
9.0 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Workflow.Definition.List
|
|
( getAdminWorkflowDefinitionListR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Yaml as Yaml
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
type WorkflowDefinitionTableExpr = E.SqlExpr (Entity WorkflowDefinition)
|
|
|
|
queryWorkflowDefinition :: Iso' WorkflowDefinitionTableExpr (E.SqlExpr (Entity WorkflowDefinition))
|
|
queryWorkflowDefinition = id
|
|
|
|
queryWorkflowInstanceCount, queryWorkflowCount :: Getter WorkflowDefinitionTableExpr (E.SqlExpr (E.Value Int64))
|
|
queryWorkflowInstanceCount = to $ \(view queryWorkflowDefinition -> workflowDefinition) ->
|
|
E.subSelectCount . E.from $ \workflowInstance ->
|
|
E.where_ $ workflowInstance E.^. WorkflowInstanceDefinition E.==. E.just (workflowDefinition E.^. WorkflowDefinitionId)
|
|
queryWorkflowCount = to $ \(view queryWorkflowDefinition -> workflowDefinition) ->
|
|
E.subSelectCount . E.from $ \(workflowInstance `E.InnerJoin` workflow) -> do
|
|
E.on $ workflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
|
E.where_ $ workflowInstance E.^. WorkflowInstanceDefinition E.==. E.just (workflowDefinition E.^. WorkflowDefinitionId)
|
|
|
|
|
|
|
|
type WorkflowDefinitionData = DBRow
|
|
( Entity WorkflowDefinition
|
|
, Maybe (Entity WorkflowDefinitionDescription)
|
|
, Maybe (Entity WorkflowDefinitionInstanceDescription)
|
|
, Int64, Int64
|
|
)
|
|
|
|
resultDefinition :: Lens' WorkflowDefinitionData (Entity WorkflowDefinition)
|
|
resultDefinition = _dbrOutput . _1
|
|
|
|
resultDescription :: Traversal' WorkflowDefinitionData (Entity WorkflowDefinitionDescription)
|
|
resultDescription = _dbrOutput . _2 . _Just
|
|
|
|
resultInstanceDescription :: Traversal' WorkflowDefinitionData (Entity WorkflowDefinitionInstanceDescription)
|
|
resultInstanceDescription = _dbrOutput . _3 . _Just
|
|
|
|
resultWorkflowInstanceCount, resultWorkflowCount :: Lens' WorkflowDefinitionData Int64
|
|
resultWorkflowInstanceCount = _dbrOutput . _4
|
|
resultWorkflowCount = _dbrOutput . _5
|
|
|
|
|
|
getAdminWorkflowDefinitionListR :: Handler Html
|
|
getAdminWorkflowDefinitionListR = do
|
|
definitionsTable <- runDB $
|
|
let
|
|
workflowDefinitionsDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery = runReaderT $ do
|
|
workflowDefinition <- view queryWorkflowDefinition
|
|
workflowInstanceCount <- view queryWorkflowInstanceCount
|
|
workflowCount <- view queryWorkflowCount
|
|
|
|
return (workflowDefinition, workflowInstanceCount, workflowCount)
|
|
dbtRowKey = (E.^. WorkflowDefinitionId)
|
|
dbtProj = dbtProjFilteredPostSimple . runReaderT $ do
|
|
wd@(Entity wdId _) <- view _1
|
|
descLangs <- lift . E.select . E.from $ \workflowDefinitionDescription -> do
|
|
E.where_ $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionDefinition E.==. E.val wdId
|
|
return $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionLanguage
|
|
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
|
|
desc <- lift . fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowDefinitionDescription wdId descLang'
|
|
idescLangs <- lift . E.select . E.from $ \workflowDefinitionInstanceDescription -> do
|
|
E.where_ $ workflowDefinitionInstanceDescription E.^. WorkflowDefinitionInstanceDescriptionDefinition E.==. E.val wdId
|
|
return $ workflowDefinitionInstanceDescription E.^. WorkflowDefinitionInstanceDescriptionLanguage
|
|
idescLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> idescLangs
|
|
idesc <- lift . fmap join . for idescLang $ \idescLang' -> getBy $ UniqueWorkflowDefinitionInstanceDescription wdId idescLang'
|
|
(wd, desc, idesc,,)
|
|
<$> view (_2 . _Value)
|
|
<*> view (_3 . _Value)
|
|
dbtColonnade :: Colonnade Sortable WorkflowDefinitionData _
|
|
dbtColonnade = mconcat
|
|
[ sortable (Just "name") (i18nCell MsgWorkflowDefinitionName) . anchorEdit $ views (resultDefinition . _entityVal . _workflowDefinitionName) i18n
|
|
, sortable (Just "scope") (i18nCell MsgWorkflowDefinitionScope) $ views (resultDefinition . _entityVal . _workflowDefinitionScope) i18nCell
|
|
, sortable (Just "title") (i18nCell MsgWorkflowDescriptionTitle) $ maybe mempty (anchorEdit . const . i18n) =<< preview (resultDescription . _entityVal . _workflowDefinitionDescriptionTitle)
|
|
, sortable (Just "instances") (i18nCell MsgWorkflowDefinitionInstanceCount) $ maybe mempty i18nCell . views resultWorkflowInstanceCount (assertM' (> 0))
|
|
, sortable (Just "workflows") (i18nCell MsgWorkflowDefinitionWorkflowCount) $ maybe mempty i18nCell . views resultWorkflowCount (assertM' (> 0))
|
|
, sortable (Just "description") (i18nCell MsgWorkflowDescription) $ maybe mempty modalCell . preview (resultDescription . _entityVal . _workflowDefinitionDescriptionDescription . _Just)
|
|
, sortable (Just "instance-title") (i18nCell MsgWorkflowInstanceDescriptionTitle) $ maybe mempty (anchorEdit . const . i18n) =<< preview (resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle)
|
|
, sortable (Just "instance-description") (i18nCell MsgWorkflowInstanceDescription) $ maybe mempty modalCell . preview (resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionDescription . _Just)
|
|
, sortable Nothing (i18nCell MsgWorkflowDefinitionGraph) $ views (resultDefinition . _entityVal . _workflowDefinitionGraph) (modalCell . displayGraph)
|
|
]
|
|
where
|
|
anchorEdit :: (WorkflowDefinitionData -> Widget) -> _
|
|
anchorEdit = anchorCell' $ \(view $ resultDefinition . _entityVal -> WorkflowDefinition{..}) -> AdminWorkflowDefinitionR workflowDefinitionScope workflowDefinitionName AWDEditR
|
|
displayGraph graph
|
|
= [shamlet|
|
|
$newline never
|
|
<code .json>
|
|
#{graph'}
|
|
|]
|
|
where graph' = decodeUtf8 $ Yaml.encode graph
|
|
dbtSorting = mconcat
|
|
[ singletonMap "name" . SortColumn $ views queryWorkflowDefinition (E.^. WorkflowDefinitionName)
|
|
, singletonMap "scope" . SortColumn . views queryWorkflowDefinition $ E.orderByEnum . (E.^. WorkflowDefinitionScope)
|
|
, singletonMap "title" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle
|
|
, singletonMap "description" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowDefinitionDescriptionDescription
|
|
, singletonMap "instance-title" . SortProjected . comparing . view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle
|
|
, singletonMap "instance-description" . SortProjected . comparing . view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionDescription
|
|
, singletonMap "instances" . SortColumn $ view queryWorkflowInstanceCount
|
|
, singletonMap "workflows" . SortColumn $ view queryWorkflowCount
|
|
]
|
|
dbtFilter = mconcat
|
|
[ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowDefinitionName)
|
|
, singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowDefinitionScope)
|
|
, singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
|
, singletonMap "instance-title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowDefinitionName)
|
|
, prismAForm (singletonFilter "scope" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ WorkflowScope') (fslI MsgWorkflowDefinitionScope)
|
|
, prismAForm (singletonFilter "title") mPrev $ aopt textField (fslI MsgWorkflowDescriptionTitle)
|
|
, prismAForm (singletonFilter "instance-title") mPrev $ aopt textField (fslI MsgWorkflowInstanceDescriptionTitle)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "workflow-definitions"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
workflowDefinitionsDBTableValidator = def
|
|
& defaultPagesize PagesizeAll
|
|
& defaultSorting [SortAscBy "scope", SortAscBy "name"]
|
|
in dbTableWidget' workflowDefinitionsDBTableValidator workflowDefinitionsDBTable
|
|
|
|
siteLayoutMsg MsgWorkflowDefinitionListTitle $ do
|
|
setTitleI MsgWorkflowDefinitionListTitle
|
|
|
|
definitionsTable
|