diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 0dca25d69..8e1e0cff0 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 6dd1468a0..57ce64ece 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 494dc2230..871f64a2b 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -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} diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index feb11b3df..43bc50e86 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e23b65a19..55cdd8060 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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 diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index 462db8547..4db2397c5 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -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 _ diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 1354ee1bc..ce6662f60 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -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 -