feat(workflows): proper workflow-workflow-tables
This commit is contained in:
Gregor Kleen
parent
7a7cd4d07c
commit
ac08846c26
@ -720,7 +720,7 @@ section
|
||||
background-color: hsla($hue, 75%, 50%, $opacity) !important
|
||||
|
||||
|
||||
.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text
|
||||
.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text, .cryptoid
|
||||
font-family: var(--font-monospace)
|
||||
|
||||
.shown
|
||||
|
||||
@ -3101,6 +3101,25 @@ GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId@CryptoFileNameWorkflowWor
|
||||
SchoolWorkflowWorkflowWorkflowHeading ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
SchoolWorkflowWorkflowWorkflowTitle ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
|
||||
WorkflowWorkflowListScopeTitle rScope@Text: Laufende Workflows - #{rScope}
|
||||
WorkflowWorkflowListScopeHeading rScope@Text: Laufende Workflows (#{rScope})
|
||||
WorkflowWorkflowListInstanceTitle: Laufende Workflows für Instanz
|
||||
WorkflowWorkflowListInstanceHeading: Laufende Workflows für Instanz
|
||||
WorkflowWorkflowListNamedInstanceTitle rScope@Text wiTitle@Text: Laufende Workflows - #{rScope}, #{wiTitle}
|
||||
WorkflowWorkflowListNamedInstanceHeading rScope@Text wiTitle@Text: Laufende Workflows (#{rScope}, #{wiTitle})
|
||||
WorkflowWorkflowListTopTitle: Laufende Workflows
|
||||
WorkflowWorkflowListTopHeading: Laufende Workflows
|
||||
AdminWorkflowWorkflowListTitle: Laufende Workflows
|
||||
AdminWorkflowWorkflowListHeading: Laufende Workflows
|
||||
|
||||
WorkflowWorkflowListNumber: Nummer
|
||||
WorkflowWorkflowListScope: Bereich
|
||||
WorkflowWorkflowListInstance: Instanz
|
||||
WorkflowWorkflowListCurrentState: Aktueller Zustand
|
||||
WorkflowWorkflowListLastActionTime: Zeitpunkt, letzte Aktion
|
||||
WorkflowWorkflowListLastActionUser: Benutzer, letzte Aktion
|
||||
WorkflowWorkflowListIsFinal: Abgeschlossen?
|
||||
|
||||
FormFieldWorkflowDatasetTip: Mindestens ein gekennzeichnetes Feld pro Datensatz muss ausgefüllt werden
|
||||
|
||||
ChangelogItemFeature: Feature
|
||||
|
||||
@ -3061,6 +3061,25 @@ GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId: Workflow #{toPathPiece w
|
||||
SchoolWorkflowWorkflowWorkflowHeading ssh workflowWorkflowId: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
SchoolWorkflowWorkflowWorkflowTitle ssh workflowWorkflowId: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
|
||||
WorkflowWorkflowListScopeTitle rScope: Running workflows - #{rScope}
|
||||
WorkflowWorkflowListScopeHeading rScope: Running workflows (#{rScope})
|
||||
WorkflowWorkflowListInstanceTitle: Running workflows for an instance
|
||||
WorkflowWorkflowListInstanceHeading: Running workflows for an instance
|
||||
WorkflowWorkflowListNamedInstanceTitle rScope wiTitle: Running workflows - #{rScope}, #{wiTitle}
|
||||
WorkflowWorkflowListNamedInstanceHeading rScope wiTitle: Running workflows (#{rScope}, #{wiTitle})
|
||||
WorkflowWorkflowListTopTitle: Running workflows
|
||||
WorkflowWorkflowListTopHeading: Running workflows
|
||||
AdminWorkflowWorkflowListTitle: Running workflows
|
||||
AdminWorkflowWorkflowListHeading: Running workflows
|
||||
|
||||
WorkflowWorkflowListNumber: Number
|
||||
WorkflowWorkflowListScope: Scope
|
||||
WorkflowWorkflowListInstance: Instance
|
||||
WorkflowWorkflowListCurrentState: Current state
|
||||
WorkflowWorkflowListLastActionTime: Timestamp of last action
|
||||
WorkflowWorkflowListLastActionUser: User for last action
|
||||
WorkflowWorkflowListIsFinal: Finalised?
|
||||
|
||||
FormFieldWorkflowDatasetTip: At least one of the marked fields must be filled
|
||||
WorkflowDefinitionGraph: Specification
|
||||
WorkflowDefinitionKeyDoesNotExist renderedCryptoID: Referenced id does not exist: #{renderedCryptoID}
|
||||
|
||||
@ -111,7 +111,16 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
||||
SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR
|
||||
SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
||||
SchoolWorkflowInstanceR win sRoute' -> case sRoute' of
|
||||
SWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
||||
SWIEditR -> do
|
||||
mayList <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR
|
||||
desc <- runDBRead . runMaybeT $ do
|
||||
guard mayList
|
||||
wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh
|
||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||
let bRoute = SchoolR ssh SchoolWorkflowInstanceListR
|
||||
case desc of
|
||||
Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just bRoute
|
||||
Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute
|
||||
SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
SWIInitiateR -> do
|
||||
@ -379,7 +388,15 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
||||
breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing
|
||||
breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR
|
||||
breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
|
||||
GWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR
|
||||
GWIEditR -> do
|
||||
mayList <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR
|
||||
desc <- runDBRead . runMaybeT $ do
|
||||
guard mayList
|
||||
wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal
|
||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||
case desc of
|
||||
Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR
|
||||
Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just GlobalWorkflowInstanceListR
|
||||
GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR
|
||||
GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR
|
||||
GWIInitiateR -> do
|
||||
|
||||
@ -35,7 +35,7 @@ indicatorCell = writerCell . tell $ Any True
|
||||
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
|
||||
writerCell act = mempty & cellContents %~ (<* act)
|
||||
|
||||
maybeCell :: IsDBTable m a => Maybe a -> (a -> DBCell m a) -> DBCell m a
|
||||
maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
|
||||
maybeCell = flip foldMap
|
||||
|
||||
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
|
||||
@ -265,3 +265,6 @@ occurrencesCell = cell . occurrencesWidget
|
||||
|
||||
roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a
|
||||
roomReferenceCell = cell . roomReferenceWidget
|
||||
|
||||
cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
|
||||
cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece
|
||||
|
||||
@ -77,11 +77,7 @@ getAdminWorkflowInstanceListR = do
|
||||
dbtRowKey = (E.^. WorkflowInstanceId)
|
||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
||||
wi@(Entity wiId _) <- view _1
|
||||
descLangs <- lift . E.select . E.from $ \workflowInstanceDescription -> do
|
||||
E.where_ $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionInstance E.==. E.val wiId
|
||||
return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
|
||||
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
|
||||
desc <- lift . fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
|
||||
desc <- lift $ selectWorkflowInstanceDescription wiId
|
||||
(wi, desc,)
|
||||
<$> view (_2 . _Value)
|
||||
dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Workflow.Workflow.List
|
||||
( getGlobalWorkflowWorkflowListR
|
||||
, getSchoolWorkflowWorkflowListR
|
||||
@ -14,9 +16,18 @@ import Import
|
||||
import Utils.Workflow
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
|
||||
import Handler.Workflow.Workflow.Workflow (WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Utils.Form
|
||||
import Handler.Utils hiding (columns)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
getGlobalWorkflowWorkflowListR :: Handler Html
|
||||
getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
|
||||
@ -27,7 +38,15 @@ getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
|
||||
workflowWorkflowListR :: RouteWorkflowScope -> Handler Html
|
||||
workflowWorkflowListR rScope = do
|
||||
scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
|
||||
workflowWorkflowList $ \workflowWorkflow -> workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
workflowWorkflowList (headings mr) columns . runReader $ do
|
||||
workflowWorkflow <- view queryWorkflowWorkflow
|
||||
return $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
where
|
||||
columns = def
|
||||
{ wwListColumnScope = False
|
||||
}
|
||||
headings mr = (MsgWorkflowWorkflowListScopeTitle $ mr rScope, MsgWorkflowWorkflowListScopeHeading $ mr rScope)
|
||||
|
||||
|
||||
getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
|
||||
@ -38,41 +57,264 @@ getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh
|
||||
|
||||
workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
|
||||
workflowInstanceWorkflowsR rScope win = do
|
||||
scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
|
||||
workflowWorkflowList $ \workflowWorkflow ->
|
||||
E.exists . E.from $ \workflowInstance ->
|
||||
(scope, desc) <- runDB $ do
|
||||
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
|
||||
wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
|
||||
desc <- selectWorkflowInstanceDescription wiId
|
||||
return (scope, desc)
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let headings = case desc of
|
||||
Nothing -> (MsgWorkflowWorkflowListInstanceTitle, MsgWorkflowWorkflowListInstanceHeading)
|
||||
Just (Entity _ WorkflowInstanceDescription{..})
|
||||
-> ( MsgWorkflowWorkflowListNamedInstanceTitle (mr rScope) workflowInstanceDescriptionTitle
|
||||
, MsgWorkflowWorkflowListNamedInstanceHeading (mr rScope) workflowInstanceDescriptionTitle
|
||||
)
|
||||
workflowWorkflowList headings columns . runReader $ do
|
||||
workflowWorkflow <- view queryWorkflowWorkflow
|
||||
return . E.exists . E.from $ \workflowInstance ->
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
|
||||
E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
E.&&. workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
||||
where
|
||||
columns = def
|
||||
{ wwListColumnInstance = False
|
||||
, wwListColumnScope = False
|
||||
}
|
||||
|
||||
|
||||
getAdminWorkflowWorkflowListR :: Handler Html
|
||||
getAdminWorkflowWorkflowListR = workflowWorkflowList $ const E.true
|
||||
getAdminWorkflowWorkflowListR = workflowWorkflowList headings def $ const E.true
|
||||
where headings = (MsgAdminWorkflowWorkflowListTitle, MsgAdminWorkflowWorkflowListHeading)
|
||||
|
||||
getTopWorkflowWorkflowListR :: Handler Html
|
||||
getTopWorkflowWorkflowListR = workflowWorkflowList $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
|
||||
getTopWorkflowWorkflowListR = workflowWorkflowList headings def . views queryWorkflowWorkflow $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
|
||||
where headings = (MsgWorkflowWorkflowListTopTitle, MsgWorkflowWorkflowListTopHeading)
|
||||
|
||||
|
||||
workflowWorkflowList :: (E.SqlExpr (Entity WorkflowWorkflow) -> E.SqlExpr (E.Value Bool))
|
||||
type WorkflowWorkflowTableExpr = E.SqlExpr (Entity WorkflowWorkflow)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity WorkflowInstance))
|
||||
|
||||
queryWorkflowWorkflow :: Getter WorkflowWorkflowTableExpr (E.SqlExpr (Entity WorkflowWorkflow))
|
||||
queryWorkflowWorkflow = to $(E.sqlLOJproj 2 1)
|
||||
|
||||
queryWorkflowInstance :: Getter WorkflowWorkflowTableExpr (E.SqlExpr (Maybe (Entity WorkflowInstance)))
|
||||
queryWorkflowInstance = to $(E.sqlLOJproj 2 2)
|
||||
|
||||
type WorkflowWorkflowData = DBRow
|
||||
( CryptoFileNameWorkflowWorkflow
|
||||
, Maybe RouteWorkflowScope
|
||||
, Entity WorkflowWorkflow
|
||||
, Maybe (Entity WorkflowInstance)
|
||||
, Maybe (Entity WorkflowInstanceDescription)
|
||||
, Maybe WorkflowWorkflowActionData -- ^ Last Action
|
||||
)
|
||||
|
||||
type WorkflowWorkflowActionData = ( Maybe Text
|
||||
, UTCTime
|
||||
, Maybe WorkflowHistoryItemActor
|
||||
, Maybe Icon
|
||||
)
|
||||
|
||||
resultWorkflowWorkflowId :: Lens' WorkflowWorkflowData CryptoFileNameWorkflowWorkflow
|
||||
resultWorkflowWorkflowId = _dbrOutput . _1
|
||||
|
||||
resultRouteScope :: Lens' WorkflowWorkflowData (Maybe RouteWorkflowScope)
|
||||
resultRouteScope = _dbrOutput . _2
|
||||
|
||||
_resultWorkflowWorkflow :: Lens' WorkflowWorkflowData (Entity WorkflowWorkflow)
|
||||
_resultWorkflowWorkflow = _dbrOutput . _3
|
||||
|
||||
resultWorkflowInstance :: Lens' WorkflowWorkflowData (Maybe (Entity WorkflowInstance))
|
||||
resultWorkflowInstance = _dbrOutput . _4
|
||||
|
||||
resultWorkflowInstanceDescription :: Lens' WorkflowWorkflowData (Maybe (Entity WorkflowInstanceDescription))
|
||||
resultWorkflowInstanceDescription = _dbrOutput . _5
|
||||
|
||||
resultWorkflowInstanceTitle :: Getter WorkflowWorkflowData Text
|
||||
resultWorkflowInstanceTitle = to $ \x -> case x ^? resultWorkflowInstanceDescription . _Just . _entityVal . _workflowInstanceDescriptionTitle of
|
||||
Just dTitle -> dTitle
|
||||
Nothing -> x ^. resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName . to CI.original
|
||||
|
||||
resultLastAction :: Lens' WorkflowWorkflowData (Maybe WorkflowWorkflowActionData)
|
||||
resultLastAction = _dbrOutput . _6
|
||||
|
||||
actionTo :: Lens' WorkflowWorkflowActionData (Maybe Text)
|
||||
actionTo = _1
|
||||
|
||||
actionTime :: Lens' WorkflowWorkflowActionData UTCTime
|
||||
actionTime = _2
|
||||
|
||||
actionActor :: Lens' WorkflowWorkflowActionData (Maybe WorkflowHistoryItemActor)
|
||||
actionActor = _3
|
||||
|
||||
actionFinal :: Lens' WorkflowWorkflowActionData (Maybe Icon)
|
||||
actionFinal = _4
|
||||
|
||||
data WorkflowWorkflowListColumns = WWListColumns
|
||||
{ wwListColumnInstance :: Bool
|
||||
, wwListColumnScope :: Bool
|
||||
}
|
||||
|
||||
instance Default WorkflowWorkflowListColumns where
|
||||
def = WWListColumns
|
||||
{ wwListColumnInstance = True
|
||||
, wwListColumnScope = True
|
||||
}
|
||||
|
||||
workflowWorkflowList :: ( RenderMessage UniWorX title, RenderMessage UniWorX heading)
|
||||
=> (title, heading)
|
||||
-> WorkflowWorkflowListColumns
|
||||
-> (WorkflowWorkflowTableExpr -> E.SqlExpr (E.Value Bool))
|
||||
-> Handler Html
|
||||
workflowWorkflowList sqlPred = do -- not implemented; TODO: FIXME
|
||||
wfRoutes <- runDB $ do
|
||||
wfs <- E.select . E.from $ \workflowWorkflow -> do
|
||||
E.where_ $ sqlPred workflowWorkflow
|
||||
return workflowWorkflow
|
||||
flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
cID <- encrypt wfId
|
||||
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
guardM $ hasReadAccessTo route
|
||||
return (cID, route)
|
||||
workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
||||
mAuthId <- maybeAuthId
|
||||
|
||||
workflowTable <- runDB $
|
||||
let
|
||||
workflowWorkflowDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
workflowWorkflow <- view queryWorkflowWorkflow
|
||||
workflowInstance <- view queryWorkflowInstance
|
||||
lift . E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. workflowInstance E.?. WorkflowInstanceId
|
||||
lift <=< asks $ E.where_ . sqlPred
|
||||
return (workflowWorkflow, workflowInstance)
|
||||
dbtRowKey = views queryWorkflowWorkflow (E.^. WorkflowWorkflowId)
|
||||
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
||||
ww@(Entity wwId WorkflowWorkflow{..}) <- view _1
|
||||
mwi <- view _2
|
||||
wiDesc <- lift . runMaybeT $ do
|
||||
Entity wiId _ <- hoistMaybe mwi
|
||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||
cID <- encrypt wwId
|
||||
rScope <- lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
let WorkflowGraph{..} = ww ^. _entityVal . _workflowWorkflowGraph . from _DBWorkflowGraph
|
||||
hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
|
||||
hasWorkflowRole' role = maybeT (return False) $ do
|
||||
rScope' <- hoistMaybe rScope
|
||||
let canonRoute = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
|
||||
lift . $cachedHereBinary (wwId, role) $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
|
||||
|
||||
defaultLayout
|
||||
[whamlet|
|
||||
$newline never
|
||||
<ul>
|
||||
$forall (cID, route) <- wfRoutes
|
||||
<li>
|
||||
<a href=@{route}>
|
||||
#{toPathPiece cID}
|
||||
|]
|
||||
let
|
||||
goAction p w = lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p
|
||||
where
|
||||
go Nothing = return Nothing
|
||||
go (Just (act, newSt)) = maybeT (go $ newSt ^? _nullable . p) $ do
|
||||
guardM . lift . $cachedHereBinary (wwId, wpTo act, wpUser act, Map.keys $ wpPayload act) $ mayViewWorkflowAction mAuthId wwId act
|
||||
Just <$> lift (w act)
|
||||
descAction p = goAction p $ \WorkflowAction{..} ->
|
||||
let actName = runMaybeT $ do
|
||||
WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers
|
||||
guardM . lift $ anyM (otoList wnvViewers) hasWorkflowRole'
|
||||
selectLanguageI18n wnvDisplayLabel
|
||||
actUser = for wpUser $ \wpUser' -> if
|
||||
| is _Just mAuthId
|
||||
, wpUser' == mAuthId -> return WHIASelf
|
||||
| otherwise -> maybeT (return WHIAHidden) $ do
|
||||
viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
|
||||
guardM . lift $ anyM (otoList viewActors) hasWorkflowRole'
|
||||
resUser <- lift $ traverse getEntity wpUser'
|
||||
return $ case resUser of
|
||||
Nothing -> WHIAOther Nothing
|
||||
Just Nothing -> WHIAGone
|
||||
Just (Just uEnt) -> WHIAOther $ Just uEnt
|
||||
where mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes
|
||||
actFinal = do
|
||||
WGN{..} <- Map.lookup wpTo wgNodes
|
||||
wgnFinal
|
||||
in (,,,)
|
||||
<$> actName
|
||||
<*> pure wpTime
|
||||
<*> actUser
|
||||
<*> pure actFinal
|
||||
lastAct <- descAction $ re _nullable . _Snoc . swapped
|
||||
|
||||
return (cID, rScope, ww, mwi, wiDesc, lastAct)
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat -- TODO: columns
|
||||
[ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . toPathPiece
|
||||
, guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x
|
||||
, guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x
|
||||
, sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell
|
||||
, sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell
|
||||
, sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell
|
||||
]
|
||||
where
|
||||
stateCell = \case
|
||||
(Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text)
|
||||
(Just n, Nothing) -> textCell n
|
||||
(Just n, Just fin) -> cell [whamlet|#{icon fin} #{n}|]
|
||||
actorCell = \case
|
||||
Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text)
|
||||
Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text)
|
||||
Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text)
|
||||
Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text)
|
||||
Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text)
|
||||
Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname
|
||||
|
||||
anchorWorkflowWorkflow :: (WorkflowWorkflowData -> Widget) -> _
|
||||
anchorWorkflowWorkflow f = maybeAnchorCellM <$> mkLink <*> f
|
||||
where mkLink = runReaderT $ do
|
||||
cID <- view resultWorkflowWorkflowId
|
||||
rScope <- hoistMaybe =<< view resultRouteScope
|
||||
return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f
|
||||
where mkLink = runReaderT $ do
|
||||
rScope <- hoistMaybe =<< view resultRouteScope
|
||||
return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
|
||||
anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f
|
||||
where mkLink = runReaderT $ do
|
||||
rScope <- hoistMaybe =<< view resultRouteScope
|
||||
win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName)
|
||||
return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap "workflow-workflow" . SortProjected . comparing $ view resultWorkflowWorkflowId
|
||||
, singletonMap "scope" . SortProjected . comparing $ view resultRouteScope
|
||||
, singletonMap "instance" . SortProjected . comparing $ preview resultWorkflowInstanceTitle
|
||||
, singletonMap "current-state" . SortProjected . comparing . preview $ resultLastAction . _Just . actionTo . _Just
|
||||
, singletonMap "last-action-time" . SortProjected . comparing . preview $ resultLastAction . _Just . actionTime
|
||||
, singletonMap "last-action-user" . SortProjected . comparing . preview $ resultLastAction . _Just . actionActor . to (over (mapped . mapped) $ \(Entity _ User{..}) -> (userSurname, userDisplayName))
|
||||
, singletonMap "final" . SortProjected . comparing $ \x -> guardOnM (has (resultLastAction . _Just . actionTo . _Just) x) (x ^? resultLastAction . _Just . actionFinal . _Just)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) ->
|
||||
let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId
|
||||
criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
in any (`isInfixOf` cid) criteria'
|
||||
, singletonMap "may-access" . FilterProjected $ \x (Any b) -> fmap (== b) . maybeT (return False) $ do
|
||||
let cID = x ^. resultWorkflowWorkflowId
|
||||
rScope <- hoistMaybe $ x ^. resultRouteScope
|
||||
lift . lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool
|
||||
, singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) ->
|
||||
let criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
in maybe False (\cSt -> any (`isInfixOf` cSt) criteria') $ x ^? resultLastAction . _Just . actionTo . _Just . to (map CI.mk . unpack)
|
||||
, singletonMap "final" . FilterProjected $ \x (criterion :: Last Bool) -> case getLast criterion of
|
||||
Nothing -> True
|
||||
Just needle -> let val = has (resultLastAction . _Just . actionTo . _Just) x
|
||||
&& has (resultLastAction . _Just . actionFinal . _Just) x
|
||||
in needle == val
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ flip (prismAForm $ singletonFilter "workflow-workflow") $ aopt textField (fslI MsgWorkflowWorkflowListNumber)
|
||||
, flip (prismAForm $ singletonFilter "current-state") $ aopt textField (fslI MsgWorkflowWorkflowListCurrentState)
|
||||
|
||||
, flip (prismAForm (singletonFilter "final" . maybePrism _PathPiece)) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgWorkflowWorkflowListIsFinal)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "workflow-workflows"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
workflowWorkflowDBTableValidator = def
|
||||
& defaultSorting defSort
|
||||
& forceFilter "may-access" (Any True)
|
||||
defSort | wwListColumnInstance = SortAscBy "instance" : defSort'
|
||||
| otherwise = defSort'
|
||||
where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"]
|
||||
in dbTableDB' workflowWorkflowDBTableValidator workflowWorkflowDBTable
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI title
|
||||
|
||||
workflowTable
|
||||
|
||||
@ -2,6 +2,7 @@ module Handler.Workflow.Workflow.Workflow
|
||||
( getGWWWorkflowR, postGWWWorkflowR, getGWWFilesR
|
||||
, getSWWWorkflowR, postSWWWorkflowR, getSWWFilesR
|
||||
, workflowR
|
||||
, WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor
|
||||
) where
|
||||
|
||||
import Import hiding (Last(..), Encoding(None))
|
||||
@ -38,25 +39,26 @@ import Data.Void (absurd)
|
||||
import Data.List (inits)
|
||||
|
||||
|
||||
data WorkflowHistoryItemActor = WHIASelf | WHIAOther (Maybe (Entity User)) | WHIAHidden | WHIAGone
|
||||
deriving (Generic, Typeable)
|
||||
data WorkflowHistoryItemActor' user = WHIASelf | WHIAOther (Maybe user) | WHIAHidden | WHIAGone
|
||||
deriving (Eq, Ord, Functor, Traversable, Foldable, Generic, Typeable)
|
||||
type WorkflowHistoryItemActor = WorkflowHistoryItemActor' (Entity User)
|
||||
|
||||
data WorkflowHistoryItem = WorkflowHistoryItem
|
||||
{ whiUser :: Maybe WorkflowHistoryItemActor
|
||||
, whiTime :: UTCTime
|
||||
, whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
|
||||
, whiFrom :: Maybe (Maybe Text) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
|
||||
, whiFrom :: Maybe (Maybe (Text, Maybe Icon)) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
|
||||
, whiVia :: Maybe Text
|
||||
, whiTo :: Maybe Text
|
||||
, whiTo :: Maybe (Text, Maybe Icon)
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
data WorkflowCurrentState = WorkflowCurrentState
|
||||
{ wcsState :: Maybe Text
|
||||
{ wcsState :: Maybe (Text, Maybe Icon)
|
||||
, wcsMessages :: Set Message
|
||||
, wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
|
||||
}
|
||||
|
||||
makePrisms ''WorkflowHistoryItemActor
|
||||
makePrisms ''WorkflowHistoryItemActor'
|
||||
|
||||
data OneOrMany a = None | One a | Many
|
||||
deriving (Eq, Ord, Read, Show, Functor, Traversable, Foldable, Generic, Typeable)
|
||||
@ -130,9 +132,10 @@ workflowR rScope cID = do
|
||||
|
||||
stCID <- encryptWorkflowStateIndex wwId stIx
|
||||
let nodeView nodeLbl = do
|
||||
WorkflowNodeView{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes >>= wgnViewers
|
||||
WGN{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes
|
||||
WorkflowNodeView{..} <- hoistMaybe wgnViewers
|
||||
guardM $ anyM (otoList wnvViewers) hasWorkflowRole'
|
||||
selectLanguageI18n wnvDisplayLabel
|
||||
(, wgnFinal) <$> selectLanguageI18n wnvDisplayLabel
|
||||
whiTime = wpTime
|
||||
mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes
|
||||
hasWorkflowRole' role = $cachedHereBinary (rScope, wwId, role) . lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
|
||||
@ -241,8 +244,13 @@ workflowR rScope cID = do
|
||||
WSGlobal -> return (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
|
||||
WSSchool ssh -> return (MsgSchoolWorkflowWorkflowWorkflowHeading ssh cID, MsgSchoolWorkflowWorkflowWorkflowTitle ssh cID)
|
||||
_other -> error "not implemented"
|
||||
let headingWgt
|
||||
| Just WorkflowCurrentState{..} <- workflowState
|
||||
, Just (_, Just icn) <- wcsState
|
||||
= [whamlet|_{heading} #{icon icn}|]
|
||||
| otherwise = i18n heading
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
siteLayout headingWgt $ do
|
||||
setTitleI title
|
||||
let mEdgeView = mEdge <&> \((_, edgeView'), edgeEnc) -> wrapForm edgeView' FormSettings
|
||||
{ formMethod = POST
|
||||
|
||||
@ -68,15 +68,12 @@ predNFAesonOptions = defaultOptions
|
||||
}
|
||||
|
||||
|
||||
workflowGraphEdgeAesonOptions, workflowGraphNodeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions, workflowNodeViewAesonOptions, workflowNodeMessageAesonOptions :: Options
|
||||
workflowGraphEdgeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions, workflowNodeViewAesonOptions, workflowNodeMessageAesonOptions :: Options
|
||||
workflowGraphEdgeAesonOptions = defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 3
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
, sumEncoding = TaggedObject "mode" $ error "There should be no field called ‘mode’"
|
||||
}
|
||||
workflowGraphNodeAesonOptions = defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
}
|
||||
workflowActionAesonOptions = defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
}
|
||||
|
||||
@ -77,7 +77,7 @@ newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLab
|
||||
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary)
|
||||
|
||||
data WorkflowGraphNode fileid userid = WGN
|
||||
{ wgnFinal :: Bool
|
||||
{ wgnFinal :: Maybe Icon
|
||||
, wgnViewers :: Maybe (WorkflowNodeView userid)
|
||||
, wgnMessages :: Set (WorkflowNodeMessage userid)
|
||||
, wgnEdges :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid)
|
||||
@ -814,15 +814,34 @@ instance ( FromJSON fileid, FromJSON userid
|
||||
wpfmRange <- o JSON..:? "range"
|
||||
return $ WorkflowPayloadSpec WorkflowPayloadFieldMultiple{..}
|
||||
|
||||
defaultFinalIcon :: Icon
|
||||
defaultFinalIcon = IconOK
|
||||
|
||||
instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphNode fileid userid) where
|
||||
toJSON = genericToJSON workflowGraphNodeAesonOptions
|
||||
toJSON WGN{..} = JSON.object
|
||||
[ ("final" JSON..=) $ case wgnFinal of
|
||||
Nothing -> toJSON False
|
||||
Just icn | icn == defaultFinalIcon -> toJSON True
|
||||
other -> toJSON other
|
||||
, "viewers" JSON..= wgnViewers
|
||||
, "messages" JSON..= wgnMessages
|
||||
, "edges" JSON..= wgnEdges
|
||||
, "payload-view" JSON..= wgnPayloadView
|
||||
]
|
||||
instance ( FromJSON fileid, FromJSON userid
|
||||
, Ord fileid, Ord userid
|
||||
, Typeable fileid, Typeable userid
|
||||
, FromJSON (FileField fileid)
|
||||
, Ord (FileField fileid)
|
||||
) => FromJSON (WorkflowGraphNode fileid userid) where
|
||||
parseJSON = genericParseJSON workflowGraphNodeAesonOptions
|
||||
parseJSON = JSON.withObject "WorkflowGraphNode" $ \o -> do
|
||||
wgnFinal <- o JSON..:? "final"
|
||||
<|> fmap (bool Nothing $ Just defaultFinalIcon) (o JSON..: "final")
|
||||
wgnViewers <- o JSON..:? "viewers"
|
||||
wgnMessages <- o JSON..:? "messages" JSON..!= Set.empty
|
||||
wgnEdges <- o JSON..:? "edges" JSON..!= Map.empty
|
||||
wgnPayloadView <- o JSON..:? "payload-view" JSON..!= Map.empty
|
||||
return WGN{..}
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
|
||||
@ -6,8 +6,10 @@ module Utils.Workflow
|
||||
, _DBWorkflowGraph
|
||||
, DBWorkflowState, IdWorkflowState
|
||||
, _DBWorkflowState
|
||||
, DBWorkflowAction, IdWorkflowAction
|
||||
, decryptWorkflowStateIndex, encryptWorkflowStateIndex
|
||||
, isTopWorkflowScope, isTopWorkflowScopeSql
|
||||
, selectWorkflowInstanceDescription
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
@ -77,6 +79,9 @@ _DBWorkflowState = iso toDB fromDB
|
||||
toDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference UserId) @(WorkflowState FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)
|
||||
fromDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference SqlBackendKey) @(WorkflowState FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey)
|
||||
|
||||
type IdWorkflowAction = WorkflowAction FileReference UserId
|
||||
type DBWorkflowAction = WorkflowAction FileReference SqlBackendKey
|
||||
|
||||
|
||||
data WorkflowStateIndexKeyException
|
||||
= WorkflowStateIndexCryptoIDKeyCouldNotDecodeRandom
|
||||
@ -112,3 +117,16 @@ isTopWorkflowScope = (`elem` [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . c
|
||||
isTopWorkflowScopeSql :: E.SqlExpr (E.Value DBWorkflowScope) -> E.SqlExpr (E.Value Bool)
|
||||
isTopWorkflowScopeSql = (`E.in_` E.valList [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScopeSql
|
||||
where classifyWorkflowScopeSql = (E.->. "tag")
|
||||
|
||||
|
||||
selectWorkflowInstanceDescription :: ( MonadHandler m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> WorkflowInstanceId
|
||||
-> ReaderT backend m (Maybe (Entity WorkflowInstanceDescription))
|
||||
selectWorkflowInstanceDescription wiId = withReaderT (projectBackend @SqlReadBackend) $ do
|
||||
descLangs <- E.select . E.from $ \workflowInstanceDescription -> do
|
||||
E.where_ $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionInstance E.==. E.val wiId
|
||||
return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
|
||||
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
|
||||
fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
|
||||
|
||||
@ -9,8 +9,10 @@ $maybe WorkflowCurrentState{..} <- workflowState
|
||||
<dt .deflist__dt>
|
||||
_{MsgWorkflowWorkflowWorkflowStateStateLabel}
|
||||
<dd .deflist__dd>
|
||||
$maybe stLbl <- wcsState
|
||||
#{stLbl}
|
||||
$maybe (stLbl, stFin) <- wcsState
|
||||
#{stLbl}
|
||||
$maybe icn <- stFin
|
||||
#{icon icn}
|
||||
$nothing
|
||||
<span .workflow-state--state-special>
|
||||
_{MsgWorkflowWorkflowWorkflowStateStateHidden}
|
||||
|
||||
@ -37,16 +37,20 @@ $newline never
|
||||
<dt .deflist__dt>
|
||||
_{MsgWorkflowWorkflowWorkflowHistoryFromLabel}
|
||||
<dd .deflist__dd>
|
||||
$maybe fromLbl <- mFromLbl
|
||||
$maybe (fromLbl, fromFin) <- mFromLbl
|
||||
#{fromLbl}
|
||||
$maybe icn <- fromFin
|
||||
#{icon icn}
|
||||
$nothing
|
||||
<span .workflow-history--item-state-special>
|
||||
_{MsgWorkflowWorkflowWorkflowHistoryStateHidden}
|
||||
<dt .deflist__dt>
|
||||
_{MsgWorkflowWorkflowWorkflowHistoryToLabel}
|
||||
<dd .deflist__dd>
|
||||
$maybe toLbl <- whiTo
|
||||
#{toLbl}
|
||||
$maybe (toLbl, toFin) <- whiTo
|
||||
#{toLbl}
|
||||
$maybe icn <- toFin
|
||||
#{icon icn}
|
||||
$nothing
|
||||
<span .workflow-history--item-state-special>
|
||||
_{MsgWorkflowWorkflowWorkflowHistoryStateHidden}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user