From 85c24f713a974bcb932513da162d5224c2d76fa3 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Sat, 28 May 2022 00:10:56 +0200 Subject: [PATCH] feat(workflows): implement handlers for listing all workflows --- .../categories/workflows/de-de-formal.msg | 24 +-- .../uniworx/categories/workflows/en-eu.msg | 24 +-- .../navigation/breadcrumbs/de-de-formal.msg | 9 +- .../utils/navigation/breadcrumbs/en-eu.msg | 9 +- .../utils/navigation/menu/de-de-formal.msg | 6 +- .../uniworx/utils/navigation/menu/en-eu.msg | 6 +- routes | 15 +- src/Foundation/Authorization.hs | 6 +- src/Foundation/I18n.hs | 2 + src/Foundation/Navigation.hs | 169 +++++++----------- src/Handler/Utils/Workflow/CanonicalRoute.hs | 45 ++--- src/Handler/Workflow/Instance/Initiate.hs | 2 +- src/Handler/Workflow/Instance/List.hs | 4 +- src/Handler/Workflow/Workflow/List.hs | 83 ++++----- src/Model/Types/Workflow.hs | 16 +- 15 files changed, 190 insertions(+), 230 deletions(-) diff --git a/messages/uniworx/categories/workflows/de-de-formal.msg b/messages/uniworx/categories/workflows/de-de-formal.msg index bb522d69a..ef966e272 100644 --- a/messages/uniworx/categories/workflows/de-de-formal.msg +++ b/messages/uniworx/categories/workflows/de-de-formal.msg @@ -125,16 +125,16 @@ GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId@CryptoFileNameWorkflowWor SchoolWorkflowWorkflowWorkflowHeading ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow !ident-ok: Workflow #{ssh}, #{toPathPiece workflowWorkflowId} SchoolWorkflowWorkflowWorkflowTitle ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow !ident-ok: Workflow #{ssh}, #{toPathPiece workflowWorkflowId} -WorkflowWorkflowListScopeTitle rScope@RouteWorkflowScope mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows - _{rScope} -WorkflowWorkflowListScopeHeading rScope@RouteWorkflowScope mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows (_{rScope}) -WorkflowWorkflowListInstanceTitle mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows für Instanz -WorkflowWorkflowListInstanceHeading mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows für Instanz -WorkflowWorkflowListNamedInstanceTitle rScope@RouteWorkflowScope wiTitle@Text mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows - _{rScope}, #{wiTitle} -WorkflowWorkflowListNamedInstanceHeading rScope@RouteWorkflowScope wiTitle@Text mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows (_{rScope}, #{wiTitle}) -WorkflowWorkflowListNamedInstanceTitleDisabled rScope@RouteWorkflowScope mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows - _{rScope} -WorkflowWorkflowListNamedInstanceHeadingDisabled rScope@RouteWorkflowScope mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows (_{rScope}) -WorkflowWorkflowListTopTitle mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows -WorkflowWorkflowListTopHeading mArchived@(Maybe Bool): #{maybe (Text.pack "Alle") (bool "Laufende" "Archivierte") mArchived} Workflows +WorkflowWorkflowListScopeTitle rScope@RouteWorkflowScope listType@WorkflowWorkflowListType !ident-ok: _{listType} - _{rScope} +WorkflowWorkflowListScopeHeading rScope@RouteWorkflowScope listType@WorkflowWorkflowListType !ident-ok: _{listType} (_{rScope}) +WorkflowWorkflowListInstanceTitle listType@WorkflowWorkflowListType: _{listType} für Instanz +WorkflowWorkflowListInstanceHeading listType@WorkflowWorkflowListType: _{listType} für Instanz +WorkflowWorkflowListNamedInstanceTitle rScope@RouteWorkflowScope wiTitle@Text listType@WorkflowWorkflowListType !ident-ok: _{listType} - _{rScope}, #{wiTitle} +WorkflowWorkflowListNamedInstanceHeading rScope@RouteWorkflowScope wiTitle@Text listType@WorkflowWorkflowListType !ident-ok: _{listType} (_{rScope}, #{wiTitle}) +WorkflowWorkflowListNamedInstanceTitleDisabled rScope@RouteWorkflowScope listType@WorkflowWorkflowListType !ident-ok: _{listType} - _{rScope} +WorkflowWorkflowListNamedInstanceHeadingDisabled rScope@RouteWorkflowScope listType@WorkflowWorkflowListType !ident-ok: _{listType} _{rScope}) +WorkflowWorkflowListTopTitle listType@WorkflowWorkflowListType !ident-ok: _{listType} +WorkflowWorkflowListTopHeading listType@WorkflowWorkflowListType !ident-ok: _{listType} AdminWorkflowWorkflowListTitle: Alle Workflows AdminWorkflowWorkflowListHeading: Alle Workflows @@ -146,6 +146,10 @@ WorkflowWorkflowListLastActionTime: Zeitpunkt, letzte Aktion WorkflowWorkflowListLastActionUser: Benutzer:in, letzte Aktion WorkflowWorkflowListIsFinal: Abgeschlossen? +WorkflowWorkflowListActive: Laufende Workflows +WorkflowWorkflowListArchive: Archivierte Workflows +WorkflowWorkflowListAll: Alle Workflows + WorkflowGraphFormUploadIsDirectory: Upload ist Verzeichnis WorkflowGraphFormInvalidNumberOfFiles: Es muss genau eine Datei hochgeladen werden WorkflowCourseOption tid@TermId ssh@SchoolId coursen@CourseName !ident-ok: #{tid} - #{ssh} - #{coursen} diff --git a/messages/uniworx/categories/workflows/en-eu.msg b/messages/uniworx/categories/workflows/en-eu.msg index daaa6cdf7..ed3a5bdb8 100644 --- a/messages/uniworx/categories/workflows/en-eu.msg +++ b/messages/uniworx/categories/workflows/en-eu.msg @@ -84,16 +84,16 @@ GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId: Workflow #{toPathPiece w SchoolWorkflowWorkflowWorkflowHeading ssh workflowWorkflowId: Workflow #{ssh}, #{toPathPiece workflowWorkflowId} SchoolWorkflowWorkflowWorkflowTitle ssh workflowWorkflowId: Workflow #{ssh}, #{toPathPiece workflowWorkflowId} -WorkflowWorkflowListScopeTitle rScope mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows - _{rScope} -WorkflowWorkflowListScopeHeading rScope mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows (_{rScope}) -WorkflowWorkflowListInstanceTitle mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows for an instance -WorkflowWorkflowListInstanceHeading mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows for an instance -WorkflowWorkflowListNamedInstanceTitle rScope wiTitle mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows - _{rScope}, #{wiTitle} -WorkflowWorkflowListNamedInstanceHeading rScope wiTitle mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows (_{rScope}, #{wiTitle}) -WorkflowWorkflowListNamedInstanceTitleDisabled rScope mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows - _{rScope} -WorkflowWorkflowListNamedInstanceHeadingDisabled rScope mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows (_{rScope}) -WorkflowWorkflowListTopTitle mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows -WorkflowWorkflowListTopHeading mArchived: #{maybe (Text.pack "All") (bool "Running" "Archived") mArchived} workflows +WorkflowWorkflowListScopeTitle rScope listType: _{listType} - _{rScope} +WorkflowWorkflowListScopeHeading rScope listType: _{listType} (_{rScope}) +WorkflowWorkflowListInstanceTitle listType: _{listType} for an instance +WorkflowWorkflowListInstanceHeading listType: _{listType} for an instance +WorkflowWorkflowListNamedInstanceTitle rScope wiTitle listType: _{listType} - _{rScope}, #{wiTitle} +WorkflowWorkflowListNamedInstanceHeading rScope wiTitle listType: _{listType} (_{rScope}, #{wiTitle}) +WorkflowWorkflowListNamedInstanceTitleDisabled rScope listType: _{listType} - _{rScope} +WorkflowWorkflowListNamedInstanceHeadingDisabled rScope listType: _{listType} (_{rScope}) +WorkflowWorkflowListTopTitle listType: _{listType} +WorkflowWorkflowListTopHeading listType: _{listType} AdminWorkflowWorkflowListTitle: All workflows AdminWorkflowWorkflowListHeading: All workflows @@ -105,6 +105,10 @@ WorkflowWorkflowListLastActionTime: Timestamp of last action WorkflowWorkflowListLastActionUser: User for last action WorkflowWorkflowListIsFinal: Finalised? +WorkflowWorkflowListActive: Running workflows +WorkflowWorkflowListArchive: Archived workflows +WorkflowWorkflowListAll: All workflows + WorkflowDefinitionGraph: Specification WorkflowDefinitionKeyDoesNotExist renderedCryptoID: Referenced id does not exist: #{renderedCryptoID} WorkflowDefinitionFiles: Files diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index e038094ad..363119fa1 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -92,22 +92,19 @@ BreadcrumbAdminWorkflowWorkflowList: Initiierte Workflows BreadcrumbAdminWorkflowWorkflowNew: Workflow initiieren BreadcrumbWorkflowInstanceEdit win@WorkflowInstanceName !ident-ok: #{win} BreadcrumbWorkflowInstanceDelete: Löschen -BreadcrumbWorkflowInstanceWorkflowList: Laufende Workflows -BreadcrumbWorkflowInstanceWorkflowArchive: Archivierte Workflows +BreadcrumbWorkflowInstanceWorkflowList listType@WorkflowWorkflowListType !ident-ok: _{listType} BreadcrumbWorkflowInstanceInitiate: Workflow starten BreadcrumbWorkflowInstanceList !ident-ok: Workflows BreadcrumbWorkflowInstanceNew: Neuer Workflow BreadcrumbWorkflowInstanceUpdate !ident-ok: Update -BreadcrumbWorkflowWorkflowList: Laufende Workflows -BreadcrumbWorkflowWorkflowArchive: Archivierte Workflows +BreadcrumbWorkflowWorkflowList listType@WorkflowWorkflowListType !ident-ok: _{listType} BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow !ident-ok: #{toPathPiece workflow} BreadcrumbWorkflowWorkflowFiles: Dateien BreadcrumbWorkflowWorkflowEdit: Editieren BreadcrumbWorkflowWorkflowDelete: Löschen BreadcrumbGlobalWorkflowInstanceList: Systemweite Workflows BreadcrumbTopWorkflowInstanceList !ident-ok: Workflows -BreadcrumbTopWorkflowWorkflowList: Laufende Workflows -BreadcrumbTopWorkflowWorkflowArchive: Archivierte Workflows +BreadcrumbTopWorkflowWorkflowList listType@WorkflowWorkflowListType !ident-ok: _{listType} BreadcrumbError: Fehler BreadcrumbUpload !ident-ok: Upload BreadcrumbUserAdd: Benutzer:in anlegen diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index bff225a9f..1b2194e4e 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -92,22 +92,19 @@ BreadcrumbAdminWorkflowWorkflowList: Initiated workflows BreadcrumbAdminWorkflowWorkflowNew: Initiate workflow BreadcrumbWorkflowInstanceEdit win: #{win} BreadcrumbWorkflowInstanceDelete: Delete -BreadcrumbWorkflowInstanceWorkflowList: Running workflows -BreadcrumbWorkflowInstanceWorkflowArchive: Archived workflows +BreadcrumbWorkflowInstanceWorkflowList listType: _{listType} BreadcrumbWorkflowInstanceInitiate: Start workflow BreadcrumbWorkflowInstanceList: Workflows BreadcrumbWorkflowInstanceNew: New workflow BreadcrumbWorkflowInstanceUpdate !ident-ok: Update -BreadcrumbWorkflowWorkflowList: Running workflows -BreadcrumbWorkflowWorkflowArchive: Archived workflows +BreadcrumbWorkflowWorkflowList listType: _{listType} BreadcrumbWorkflowWorkflow workflow: #{toPathPiece workflow} BreadcrumbWorkflowWorkflowFiles: Files BreadcrumbWorkflowWorkflowEdit: Edit BreadcrumbWorkflowWorkflowDelete: Delete BreadcrumbGlobalWorkflowInstanceList: System-wide workflows BreadcrumbTopWorkflowInstanceList: Workflows -BreadcrumbTopWorkflowWorkflowList: Running workflows -BreadcrumbTopWorkflowWorkflowArchive: Archived workflows +BreadcrumbTopWorkflowWorkflowList listType: _{listType} BreadcrumbError: Error BreadcrumbUpload: Upload BreadcrumbUserAdd: Add user diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index b082c1571..359e7df30 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -126,14 +126,12 @@ MenuWorkflowInstanceDelete: Löschen MenuWorkflowInstanceWorkflows: Laufende Workflows MenuWorkflowInstanceInitiate: Workflow starten MenuWorkflowInstanceEdit: Bearbeiten -MenuWorkflowWorkflowList: Laufende Workflows -MenuWorkflowWorkflowArchive: Archivierte Workflows +MenuWorkflowWorkflowList listType@WorkflowWorkflowListType !ident-ok: _{listType} MenuWorkflowWorkflowEdit: Editieren MenuWorkflowWorkflowDelete: Löschen MenuGlobalWorkflowInstanceList: Systemweite Workflows MenuTopWorkflowInstanceList !ident-ok: Workflows -MenuTopWorkflowWorkflowList: Laufende Workflows -MenuTopWorkflowWorkflowArchive: Archivierte Workflows +MenuTopWorkflowWorkflowList listType@WorkflowWorkflowListType !ident-ok: _{listType} MenuTopWorkflowWorkflowListHeader !ident-ok: Workflows MenuGlossary: Begriffsverzeichnis MenuVersion: Versionsgeschichte diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 00b3ba02c..8fc36a55f 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -127,14 +127,12 @@ MenuWorkflowInstanceDelete: Delete MenuWorkflowInstanceWorkflows: Running workflows MenuWorkflowInstanceInitiate: Start workflow MenuWorkflowInstanceEdit: Edit -MenuWorkflowWorkflowList: Running workflows -MenuWorkflowWorkflowArchive: Archived workflows +MenuWorkflowWorkflowList listType: _{listType} MenuWorkflowWorkflowEdit: Edit MenuWorkflowWorkflowDelete: Delete MenuGlobalWorkflowInstanceList: System-wide workflows MenuTopWorkflowInstanceList: Workflows -MenuTopWorkflowWorkflowList: Running workflows -MenuTopWorkflowWorkflowArchive: Archived workflows +MenuTopWorkflowWorkflowList listType: _{listType} MenuTopWorkflowWorkflowListHeader: Workflows MenuGlossary: Glossary MenuVersion: Version history diff --git a/routes b/routes index 313ee42e3..6eecd8873 100644 --- a/routes +++ b/routes @@ -78,12 +78,10 @@ /global-workflows/instances/#WorkflowInstanceName GlobalWorkflowInstanceR: /edit GWIEditR GET POST /delete GWIDeleteR GET POST - /workflows GWIWorkflowsR GET !free - /workflows-archive GWIWorkflowsArchiveR GET !free + /workflows/#WorkflowWorkflowListType GWIWorkflowsR GET !free /initiate GWIInitiateR GET POST !workflow /update GWIUpdateR POST -/global-workflows GlobalWorkflowWorkflowListR GET !free -/global-workflows-archive GlobalWorkflowWorkflowArchiveR GET !free +!/global-workflows/#WorkflowWorkflowListType GlobalWorkflowWorkflowListR GET !free !/global-workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR: / GWWWorkflowR GET POST !workflow /files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex GWWFilesR GET !workflow @@ -91,8 +89,7 @@ /delete GWWDeleteR GET POST /workflow-instances TopWorkflowInstanceListR GET !free -/workflows TopWorkflowWorkflowListR GET !free -/workflows-archive TopWorkflowWorkflowArchiveR GET !free +/workflows/#WorkflowWorkflowListType TopWorkflowWorkflowListR GET !free /health HealthR GET !free /instance InstanceR GET !free @@ -148,12 +145,10 @@ /workflows/instances/#WorkflowInstanceName SchoolWorkflowInstanceR: /edit SWIEditR GET POST /delete SWIDeleteR GET POST - /workflows SWIWorkflowsR GET !free - /workflows-archive SWIWorkflowsArchiveR GET !free + /workflows/#WorkflowWorkflowListType SWIWorkflowsR GET !free /initiate SWIInitiateR GET POST !workflow /update SWIUpdateR POST - /workflows SchoolWorkflowWorkflowListR GET !free - /workflows-archive SchoolWorkflowWorkflowArchiveR GET !free + !/workflows/#WorkflowWorkflowListType SchoolWorkflowWorkflowListR GET !free !/workflows/#CryptoFileNameWorkflowWorkflow SchoolWorkflowWorkflowR: / SWWWorkflowR GET POST !workflow /files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex SWWFilesR GET !workflow diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 042dcc374..f18a2fb94 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1569,7 +1569,7 @@ tagAccessPredicate AuthEmpty = APDB $ \evalCtx eval' mAuthId route _ -> do orAR' = shortCircuitM (is _Authorized) (orAR mr) _andAR' = shortCircuitM (is _Unauthorized) (andAR mr) - workflowInstanceWorkflowsEmpty rScope win = workflowsEnabledAuth $ selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do + workflowInstanceWorkflowsEmpty rScope win _lState = workflowsEnabledAuth $ selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ do scope <- fromRouteWorkflowScope rScope let dbScope = scope ^. _DBWorkflowScope @@ -1604,8 +1604,8 @@ tagAccessPredicate AuthEmpty = APDB $ \evalCtx eval' mAuthId route _ -> do guardM . fmap (isn't _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles) return AuthorizedI18n in case route of - r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute - -> workflowInstanceWorkflowsEmpty rScope win + r | Just (rScope, WorkflowInstanceR win (WIWorkflowsR lState)) <- r ^? _WorkflowScopeRoute + -> workflowInstanceWorkflowsEmpty rScope win lState EExamListR -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index dada7b2d5..467d56ca0 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -514,6 +514,8 @@ instance RenderMessage UniWorX RouteWorkflowScope where mr :: forall msg. RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +embedRenderMessage ''UniWorX ''WorkflowWorkflowListType id + instance RenderMessage UniWorX VolatileClusterSettingsKey where renderMessage foundation ls = \case ClusterVolatileWorkflowsEnabled -> mr MsgClusterVolatileWorkflowsEnabled diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 7b5bbb4df..d52d9f2c9 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -129,7 +129,7 @@ breadcrumb currentRoute@(SchoolR ssh sRoute) = case sRoute of SchoolWorkflowInstanceR win sRoute' -> case sRoute' of SWIEditR -> do desc <- useRunDB . runMaybeT $ do - guardM . lift . hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR + guardM . lift . hasReadAccessTo . SchoolR ssh . SchoolWorkflowInstanceR win $ SWIWorkflowsR WorkflowWorkflowListActive wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh MaybeT $ selectWorkflowInstanceDescription wiId let bRoute = SchoolR ssh SchoolWorkflowInstanceListR @@ -137,16 +137,14 @@ breadcrumb currentRoute@(SchoolR ssh sRoute) = case sRoute 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 - SWIWorkflowsArchiveR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowArchive . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR + SWIWorkflowsR lState -> i18nCrumb (MsgBreadcrumbWorkflowInstanceWorkflowList lState) . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR SWIInitiateR -> useRunDB $ do mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if | mayEdit -> SchoolWorkflowInstanceR win SWIEditR | otherwise -> SchoolWorkflowInstanceListR SWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR - SchoolWorkflowWorkflowListR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowList . Just $ SchoolR ssh SchoolWorkflowInstanceListR - SchoolWorkflowWorkflowArchiveR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowArchive . Just $ SchoolR ssh SchoolWorkflowInstanceListR + SchoolWorkflowWorkflowListR lState -> i18nCrumb (MsgBreadcrumbWorkflowWorkflowList lState) . Just $ SchoolR ssh SchoolWorkflowInstanceListR SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of SWWWorkflowR -> do now <- liftIO getCurrentTime @@ -154,9 +152,9 @@ breadcrumb currentRoute@(SchoolR ssh sRoute) = case sRoute of guardM . lift $ hasReadAccessTo currentRoute wwId <- lift $ decrypt cID MaybeT $ get wwId - let workflowList | Just WorkflowWorkflow{workflowWorkflowArchived=Just archived} <- mWorkflowWorkflow, archived <= now = SchoolWorkflowWorkflowArchiveR - | otherwise = SchoolWorkflowWorkflowListR - i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh workflowList + let listType | Just WorkflowWorkflow{workflowWorkflowArchived=Just archived} <- mWorkflowWorkflow, archived <= now = WorkflowWorkflowListArchive + | otherwise = WorkflowWorkflowListActive + i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just . SchoolR ssh $ SchoolWorkflowWorkflowListR listType SWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR SWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR SWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR @@ -427,23 +425,21 @@ breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceN breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of GWIEditR -> do desc <- useRunDB . runMaybeT $ do - guardM . lift . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR + guardM . lift . hasReadAccessTo . GlobalWorkflowInstanceR win $ GWIWorkflowsR WorkflowWorkflowListActive 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 - GWIWorkflowsArchiveR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowArchive . Just $ GlobalWorkflowInstanceR win GWIEditR + GWIWorkflowsR lState -> i18nCrumb (MsgBreadcrumbWorkflowInstanceWorkflowList lState) . Just $ GlobalWorkflowInstanceR win GWIEditR GWIInitiateR -> do mayEdit <- useRunDB . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if | mayEdit -> GlobalWorkflowInstanceR win GWIEditR | otherwise -> GlobalWorkflowInstanceListR GWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just $ GlobalWorkflowInstanceR win GWIEditR -breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR -breadcrumb GlobalWorkflowWorkflowArchiveR = i18nCrumb MsgBreadcrumbWorkflowWorkflowArchive $ Just GlobalWorkflowInstanceListR +breadcrumb (GlobalWorkflowWorkflowListR lState) = i18nCrumb (MsgBreadcrumbWorkflowWorkflowList lState) $ Just GlobalWorkflowInstanceListR breadcrumb currentRoute@(GlobalWorkflowWorkflowR cID sRoute) = case sRoute of GWWWorkflowR -> do now <- liftIO getCurrentTime @@ -451,16 +447,15 @@ breadcrumb currentRoute@(GlobalWorkflowWorkflowR cID sRoute) = case sRoute of guardM . lift $ hasReadAccessTo currentRoute wwId <- lift $ decrypt cID MaybeT $ get wwId - let workflowList | Just WorkflowWorkflow{workflowWorkflowArchived=Just archived} <- mWorkflowWorkflow, archived <= now = GlobalWorkflowWorkflowArchiveR - | otherwise = GlobalWorkflowWorkflowListR - i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just workflowList + let listType | Just WorkflowWorkflow{workflowWorkflowArchived=Just archived} <- mWorkflowWorkflow, archived <= now = WorkflowWorkflowListArchive + | otherwise = WorkflowWorkflowListActive + i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ GlobalWorkflowWorkflowListR listType GWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR -breadcrumb TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing -breadcrumb TopWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowList $ Just TopWorkflowInstanceListR -breadcrumb TopWorkflowWorkflowArchiveR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowArchive $ Just TopWorkflowInstanceListR +breadcrumb TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing +breadcrumb (TopWorkflowWorkflowListR lType) = i18nCrumb (MsgBreadcrumbTopWorkflowWorkflowList lType) $ Just TopWorkflowInstanceListR data NavQuickView @@ -2608,8 +2603,8 @@ pageActions AdminWorkflowInstanceListR = return pageActions route | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowScopeRoute = return [ NavPageActionPrimary { navLink = NavLink - { navLabel = MsgMenuWorkflowWorkflowList - , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) + { navLabel = MsgMenuWorkflowWorkflowList WorkflowWorkflowListActive + , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR WorkflowWorkflowListActive) , navAccess' = NavAccessDB $ haveWorkflowWorkflows rScope , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2632,7 +2627,7 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo , NavPageActionPrimary { navLink = NavLink { navLabel = MsgMenuWorkflowInstanceWorkflows - , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) + , navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win $ WIWorkflowsR WorkflowWorkflowListActive) , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2652,32 +2647,22 @@ pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _Wo , navChildren = [] } ] -pageActions route | Just (rScope, WorkflowWorkflowListR) <- route ^? _WorkflowScopeRoute = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuWorkflowWorkflowArchive - , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowArchiveR) - , navAccess' = NavAccessTrue - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions route | Just (rScope, WorkflowWorkflowArchiveR) <- route ^? _WorkflowScopeRoute = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuWorkflowWorkflowList - , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) - , navAccess' = NavAccessTrue - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] +pageActions route | Just (rScope, WorkflowWorkflowListR lState) <- route ^? _WorkflowScopeRoute = + let lState' | lState == WorkflowWorkflowListActive = WorkflowWorkflowListArchive + | otherwise = WorkflowWorkflowListActive + in return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuWorkflowWorkflowList lState' + , navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR lState') + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? _WorkflowScopeRoute = return [ NavPageActionSecondary { navLink = NavLink @@ -2703,8 +2688,8 @@ pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? pageActions TopWorkflowInstanceListR = return [ NavPageActionPrimary { navLink = NavLink - { navLabel = MsgMenuTopWorkflowWorkflowList - , navRoute = TopWorkflowWorkflowListR + { navLabel = MsgMenuTopWorkflowWorkflowList WorkflowWorkflowListActive + , navRoute = TopWorkflowWorkflowListR WorkflowWorkflowListActive , navAccess' = NavAccessDB haveTopWorkflowWorkflows , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -2713,58 +2698,38 @@ pageActions TopWorkflowInstanceListR = return , navChildren = [] } ] -pageActions TopWorkflowWorkflowListR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuTopWorkflowWorkflowArchive - , navRoute = TopWorkflowWorkflowArchiveR - , navAccess' = NavAccessTrue - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions TopWorkflowWorkflowArchiveR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuTopWorkflowWorkflowList - , navRoute = TopWorkflowWorkflowListR - , navAccess' = NavAccessTrue - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (SchoolR ssh (SchoolWorkflowInstanceR swiName SWIWorkflowsR)) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuWorkflowWorkflowArchive - , navRoute = SchoolR ssh $ SchoolWorkflowInstanceR swiName SWIWorkflowsArchiveR - , navAccess' = NavAccessTrue - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (SchoolR ssh (SchoolWorkflowInstanceR swiName SWIWorkflowsArchiveR)) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuWorkflowWorkflowList - , navRoute = SchoolR ssh $ SchoolWorkflowInstanceR swiName SWIWorkflowsR - , navAccess' = NavAccessTrue - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] +pageActions (TopWorkflowWorkflowListR lState) = + let lState' | lState == WorkflowWorkflowListActive = WorkflowWorkflowListArchive + | otherwise = WorkflowWorkflowListActive + in return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuTopWorkflowWorkflowList lState' + , navRoute = TopWorkflowWorkflowListR lState' + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (SchoolR ssh (SchoolWorkflowInstanceR swiName (SWIWorkflowsR lState))) = + let lState' | lState == WorkflowWorkflowListActive = WorkflowWorkflowListArchive + | otherwise = WorkflowWorkflowListActive + in return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuWorkflowWorkflowList lState' + , navRoute = SchoolR ssh . SchoolWorkflowInstanceR swiName $ SWIWorkflowsR lState' + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] pageActions _ = return [] submissionList :: ( MonadIO m diff --git a/src/Handler/Utils/Workflow/CanonicalRoute.hs b/src/Handler/Utils/Workflow/CanonicalRoute.hs index 969d403dd..7a3dcaaf6 100644 --- a/src/Handler/Utils/Workflow/CanonicalRoute.hs +++ b/src/Handler/Utils/Workflow/CanonicalRoute.hs @@ -11,13 +11,12 @@ data WorkflowScopeRoute = WorkflowInstanceListR | WorkflowInstanceNewR | WorkflowInstanceR WorkflowInstanceName WorkflowInstanceR - | WorkflowWorkflowListR - | WorkflowWorkflowArchiveR + | WorkflowWorkflowListR WorkflowWorkflowListType | WorkflowWorkflowR CryptoFileNameWorkflowWorkflow WorkflowWorkflowR deriving (Eq, Ord, Read, Show, Generic, Typeable) data WorkflowInstanceR - = WIEditR | WIDeleteR | WIWorkflowsR | WIWorkflowsArchiveR | WIInitiateR | WIUpdateR + = WIEditR | WIDeleteR | WIWorkflowsR WorkflowWorkflowListType | WIInitiateR | WIUpdateR deriving (Eq, Ord, Read, Show, Generic, Typeable) data WorkflowWorkflowR @@ -35,12 +34,10 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute WorkflowInstanceR win subRoute -> GlobalWorkflowInstanceR win $ case subRoute of WIEditR -> GWIEditR WIDeleteR -> GWIDeleteR - WIWorkflowsR -> GWIWorkflowsR - WIWorkflowsArchiveR -> GWIWorkflowsArchiveR + WIWorkflowsR lState -> GWIWorkflowsR lState WIInitiateR -> GWIInitiateR WIUpdateR -> GWIUpdateR - WorkflowWorkflowListR -> GlobalWorkflowWorkflowListR - WorkflowWorkflowArchiveR -> GlobalWorkflowWorkflowArchiveR + WorkflowWorkflowListR lState -> GlobalWorkflowWorkflowListR lState WorkflowWorkflowR wwCID subRoute -> GlobalWorkflowWorkflowR wwCID $ case subRoute of WWWorkflowR -> GWWWorkflowR WWFilesR wpl stCID -> GWWFilesR wpl stCID @@ -52,12 +49,10 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute WorkflowInstanceR win subRoute -> SchoolWorkflowInstanceR win $ case subRoute of WIEditR -> SWIEditR WIDeleteR -> SWIDeleteR - WIWorkflowsR -> SWIWorkflowsR - WIWorkflowsArchiveR -> SWIWorkflowsArchiveR + WIWorkflowsR lState -> SWIWorkflowsR lState WIInitiateR -> SWIInitiateR WIUpdateR -> SWIUpdateR - WorkflowWorkflowListR -> SchoolWorkflowWorkflowListR - WorkflowWorkflowArchiveR -> SchoolWorkflowWorkflowArchiveR + WorkflowWorkflowListR lState -> SchoolWorkflowWorkflowListR lState WorkflowWorkflowR wwCID subRoute -> SchoolWorkflowWorkflowR wwCID $ case subRoute of WWWorkflowR -> SWWWorkflowR WWFilesR wpl stCID -> SWWFilesR wpl stCID @@ -65,35 +60,31 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute WWDeleteR -> SWWDeleteR other -> error $ "not implemented _WorkflowScopeRoute for: " <> show other toWorkflowScopeRoute = \case - GlobalWorkflowInstanceListR -> Just ( WSGlobal, WorkflowInstanceListR ) - GlobalWorkflowInstanceNewR -> Just ( WSGlobal, WorkflowInstanceNewR ) - GlobalWorkflowInstanceR win subRoute -> Just . (WSGlobal, ) . WorkflowInstanceR win $ case subRoute of + GlobalWorkflowInstanceListR -> Just ( WSGlobal, WorkflowInstanceListR ) + GlobalWorkflowInstanceNewR -> Just ( WSGlobal, WorkflowInstanceNewR ) + GlobalWorkflowInstanceR win subRoute -> Just . ( WSGlobal, ) . WorkflowInstanceR win $ case subRoute of GWIEditR -> WIEditR GWIDeleteR -> WIDeleteR - GWIWorkflowsR -> WIWorkflowsR - GWIWorkflowsArchiveR -> WIWorkflowsArchiveR + GWIWorkflowsR lState -> WIWorkflowsR lState GWIInitiateR -> WIInitiateR GWIUpdateR -> WIUpdateR - GlobalWorkflowWorkflowListR -> Just ( WSGlobal, WorkflowWorkflowListR ) - GlobalWorkflowWorkflowArchiveR -> Just ( WSGlobal, WorkflowWorkflowArchiveR ) - GlobalWorkflowWorkflowR wwCID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of + GlobalWorkflowWorkflowListR lState -> Just ( WSGlobal, WorkflowWorkflowListR lState ) + GlobalWorkflowWorkflowR wwCID subRoute -> Just . ( WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of GWWWorkflowR -> WWWorkflowR GWWFilesR wpl stCID -> WWFilesR wpl stCID GWWEditR -> WWEditR GWWDeleteR -> WWDeleteR SchoolR ssh sRoute -> case sRoute of - SchoolWorkflowInstanceListR -> Just ( WSSchool ssh, WorkflowInstanceListR ) - SchoolWorkflowInstanceNewR -> Just ( WSSchool ssh, WorkflowInstanceNewR ) - SchoolWorkflowInstanceR win subRoute -> Just . (WSSchool ssh, ) . WorkflowInstanceR win $ case subRoute of + SchoolWorkflowInstanceListR -> Just ( WSSchool ssh, WorkflowInstanceListR ) + SchoolWorkflowInstanceNewR -> Just ( WSSchool ssh, WorkflowInstanceNewR ) + SchoolWorkflowInstanceR win subRoute -> Just . ( WSSchool ssh, ) . WorkflowInstanceR win $ case subRoute of SWIEditR -> WIEditR SWIDeleteR -> WIDeleteR - SWIWorkflowsR -> WIWorkflowsR - SWIWorkflowsArchiveR -> WIWorkflowsArchiveR + SWIWorkflowsR lState -> WIWorkflowsR lState SWIInitiateR -> WIInitiateR SWIUpdateR -> WIUpdateR - SchoolWorkflowWorkflowListR -> Just ( WSSchool ssh, WorkflowWorkflowListR ) - SchoolWorkflowWorkflowArchiveR -> Just ( WSSchool ssh, WorkflowWorkflowArchiveR ) - SchoolWorkflowWorkflowR wwCID subRoute -> Just . (WSSchool ssh, ) . WorkflowWorkflowR wwCID $ case subRoute of + SchoolWorkflowWorkflowListR lState -> Just ( WSSchool ssh, WorkflowWorkflowListR lState ) + SchoolWorkflowWorkflowR wwCID subRoute -> Just . ( WSSchool ssh, ) . WorkflowWorkflowR wwCID $ case subRoute of SWWWorkflowR -> WWWorkflowR SWWFilesR wpl stCID -> WWFilesR wpl stCID SWWEditR -> WWEditR diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index f2ba34873..e508a855c 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/src/Handler/Workflow/Instance/Initiate.hs @@ -66,7 +66,7 @@ workflowInstanceInitiateR rScope win = workflowsDisabledWarning MsgWorkflowInsta cID <- encrypt wwId redirectAlternatives $ NonEmpty.fromList [ _WorkflowScopeRoute # ( rScope, WorkflowWorkflowR cID WWWorkflowR ) - , _WorkflowScopeRoute # ( rScope, WorkflowInstanceR workflowInstanceName WIWorkflowsR ) + , _WorkflowScopeRoute # ( rScope, WorkflowInstanceR workflowInstanceName $ WIWorkflowsR WorkflowWorkflowListActive ) , _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR ) ] diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index e2515faf5..2f6ef4f4a 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -177,7 +177,7 @@ workflowInstanceListR rScope = workflowsDisabledWarning title heading $ do where toInitiateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) toEditRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR) - toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) + toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win $ WIWorkflowsR WorkflowWorkflowListActive) toUpdateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR) (heading, title) = case rScope of @@ -241,7 +241,7 @@ getTopWorkflowInstanceListR = workflowsDisabledWarning title heading $ do where toInitiateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) toEditRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR) - toListRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) + toListRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win $ WIWorkflowsR WorkflowWorkflowListActive) toUpdateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR) (title, heading) = (MsgTopWorkflowInstancesTitle, MsgTopWorkflowInstancesHeading) diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 9e883e2e2..f0c123c1c 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -1,14 +1,14 @@ {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Workflow.Workflow.List - ( getGlobalWorkflowWorkflowListR, getGlobalWorkflowWorkflowArchiveR - , getSchoolWorkflowWorkflowListR, getSchoolWorkflowWorkflowArchiveR + ( getGlobalWorkflowWorkflowListR + , getSchoolWorkflowWorkflowListR , workflowWorkflowListR - , getGWIWorkflowsR, getGWIWorkflowsArchiveR - , getSWIWorkflowsR, getSWIWorkflowsArchiveR + , getGWIWorkflowsR + , getSWIWorkflowsR , workflowInstanceWorkflowsR , getAdminWorkflowWorkflowListR - , getTopWorkflowWorkflowListR, getTopWorkflowWorkflowArchiveR + , getTopWorkflowWorkflowListR ) where import Import hiding (Last(..), WriterT) @@ -58,52 +58,49 @@ instance Default WorkflowWorkflowListFilterProj where makeLenses_ ''WorkflowWorkflowListFilterProj -restrictOnArchived :: E.SqlExpr (Entity WorkflowWorkflow) -> UTCTime -> Maybe Bool -> E.SqlExpr (E.Value Bool) -restrictOnArchived workflowWorkflow now = maybe E.true $ \archived -> E.maybe - (E.val $ not archived) - (\archivedOn -> if archived then archivedOn E.<=. E.val now else E.val now E.<. archivedOn) +restrictOnArchived :: E.SqlExpr (Entity WorkflowWorkflow) -> UTCTime -> WorkflowWorkflowListType -> E.SqlExpr (E.Value Bool) +restrictOnArchived _ _ WorkflowWorkflowListAll = E.true +restrictOnArchived workflowWorkflow now wwListType = E.maybe + (E.val $ wwListType /= WorkflowWorkflowListArchive) + (\archivedOn -> if wwListType == WorkflowWorkflowListArchive then archivedOn E.<=. E.val now else E.val now E.<. archivedOn) (workflowWorkflow E.^. WorkflowWorkflowArchived) -getGlobalWorkflowWorkflowListR, getGlobalWorkflowWorkflowArchiveR :: Handler Html -getGlobalWorkflowWorkflowListR = workflowWorkflowListR (Just False) WSGlobal -getGlobalWorkflowWorkflowArchiveR = workflowWorkflowListR (Just True ) WSGlobal +getGlobalWorkflowWorkflowListR :: WorkflowWorkflowListType -> Handler Html +getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal -getSchoolWorkflowWorkflowListR, getSchoolWorkflowWorkflowArchiveR :: SchoolId -> Handler Html -getSchoolWorkflowWorkflowListR = workflowWorkflowListR (Just False) . WSSchool -getSchoolWorkflowWorkflowArchiveR = workflowWorkflowListR (Just True ) . WSSchool +getSchoolWorkflowWorkflowListR :: SchoolId -> WorkflowWorkflowListType -> Handler Html +getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool -workflowWorkflowListR :: Maybe Bool -- ^ archived/non-archived workflows only? - -> RouteWorkflowScope +workflowWorkflowListR :: RouteWorkflowScope + -> WorkflowWorkflowListType -> Handler Html -workflowWorkflowListR mArchived rScope = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) $ do +workflowWorkflowListR rScope wwListType = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) $ do now <- liftIO getCurrentTime scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope workflowWorkflowList headings columns . runReader $ do workflowWorkflow <- view queryWorkflowWorkflow return $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope) - E.&&. restrictOnArchived workflowWorkflow now mArchived + E.&&. restrictOnArchived workflowWorkflow now wwListType where columns = def { wwListColumnScope = False } - headings = (MsgWorkflowWorkflowListScopeTitle rScope mArchived, MsgWorkflowWorkflowListScopeHeading rScope mArchived) + headings = (MsgWorkflowWorkflowListScopeTitle rScope wwListType, MsgWorkflowWorkflowListScopeHeading rScope wwListType) -getGWIWorkflowsR, getGWIWorkflowsArchiveR :: WorkflowInstanceName -> Handler Html -getGWIWorkflowsR = workflowInstanceWorkflowsR (Just False) WSGlobal -getGWIWorkflowsArchiveR = workflowInstanceWorkflowsR (Just True ) WSGlobal +getGWIWorkflowsR :: WorkflowInstanceName -> WorkflowWorkflowListType -> Handler Html +getGWIWorkflowsR = workflowInstanceWorkflowsR WSGlobal -getSWIWorkflowsR, getSWIWorkflowsArchiveR :: SchoolId -> WorkflowInstanceName -> Handler Html -getSWIWorkflowsR = workflowInstanceWorkflowsR (Just False) . WSSchool -getSWIWorkflowsArchiveR = workflowInstanceWorkflowsR (Just True ) . WSSchool +getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> WorkflowWorkflowListType -> Handler Html +getSWIWorkflowsR = workflowInstanceWorkflowsR . WSSchool -workflowInstanceWorkflowsR :: Maybe Bool -- ^ archived/non-archived workflows only? - -> RouteWorkflowScope +workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName + -> WorkflowWorkflowListType -> Handler Html -workflowInstanceWorkflowsR mArchived rScope win = workflowsDisabledWarning (MsgWorkflowWorkflowListNamedInstanceTitleDisabled rScope mArchived) (MsgWorkflowWorkflowListNamedInstanceHeadingDisabled rScope mArchived) $ do +workflowInstanceWorkflowsR rScope win wwListType = workflowsDisabledWarning (MsgWorkflowWorkflowListNamedInstanceTitleDisabled rScope wwListType) (MsgWorkflowWorkflowListNamedInstanceHeadingDisabled rScope wwListType) $ do now <- liftIO getCurrentTime (scope, desc) <- runDB $ do scope <- maybeT notFound $ fromRouteWorkflowScope rScope @@ -111,10 +108,10 @@ workflowInstanceWorkflowsR mArchived rScope win = workflowsDisabledWarning (MsgW desc <- selectWorkflowInstanceDescription wiId return (scope, desc) let headings = case desc of - Nothing -> (MsgWorkflowWorkflowListInstanceTitle mArchived, MsgWorkflowWorkflowListInstanceHeading mArchived) + Nothing -> (MsgWorkflowWorkflowListInstanceTitle wwListType, MsgWorkflowWorkflowListInstanceHeading wwListType) Just (Entity _ WorkflowInstanceDescription{..}) - -> ( MsgWorkflowWorkflowListNamedInstanceTitle rScope workflowInstanceDescriptionTitle mArchived - , MsgWorkflowWorkflowListNamedInstanceHeading rScope workflowInstanceDescriptionTitle mArchived + -> ( MsgWorkflowWorkflowListNamedInstanceTitle rScope workflowInstanceDescriptionTitle wwListType + , MsgWorkflowWorkflowListNamedInstanceHeading rScope workflowInstanceDescriptionTitle wwListType ) workflowWorkflowList headings columns . runReader $ do workflowWorkflow <- view queryWorkflowWorkflow @@ -122,7 +119,7 @@ workflowInstanceWorkflowsR mArchived rScope win = workflowsDisabledWarning (MsgW 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) - E.&&. restrictOnArchived workflowWorkflow now mArchived + E.&&. restrictOnArchived workflowWorkflow now wwListType where columns = def { wwListColumnInstance = False @@ -131,19 +128,17 @@ workflowInstanceWorkflowsR mArchived rScope win = workflowsDisabledWarning (MsgW getAdminWorkflowWorkflowListR :: Handler Html -getAdminWorkflowWorkflowListR = workflowWorkflowList headings def $ const E.true -- archived workflows included +getAdminWorkflowWorkflowListR = workflowWorkflowList headings def $ const E.true where headings = (MsgAdminWorkflowWorkflowListTitle, MsgAdminWorkflowWorkflowListHeading) -getTopWorkflowWorkflowListR, getTopWorkflowWorkflowArchiveR :: Handler Html -getTopWorkflowWorkflowListR = topWorkflowWorkflowListR (Just False) -getTopWorkflowWorkflowArchiveR = topWorkflowWorkflowListR (Just True) +getTopWorkflowWorkflowListR :: WorkflowWorkflowListType -> Handler Html +getTopWorkflowWorkflowListR = topWorkflowWorkflowListR -topWorkflowWorkflowListR :: Maybe Bool -> Handler Html -topWorkflowWorkflowListR mArchived = do +topWorkflowWorkflowListR :: WorkflowWorkflowListType -> Handler Html +topWorkflowWorkflowListR wwListType = do now <- liftIO getCurrentTime - workflowsDisabledWarning (headings ^. _1) (headings ^. _2) . workflowWorkflowList headings def . views queryWorkflowWorkflow $ \workflowWorkflow -> isTopWorkflowScopeSql (workflowWorkflow E.^. WorkflowWorkflowScope) E.&&. restrictOnArchived workflowWorkflow now mArchived - where headings = (MsgWorkflowWorkflowListTopTitle mArchived, MsgWorkflowWorkflowListTopHeading mArchived) - + workflowsDisabledWarning (headings ^. _1) (headings ^. _2) . workflowWorkflowList headings def . views queryWorkflowWorkflow $ \workflowWorkflow -> isTopWorkflowScopeSql (workflowWorkflow E.^. WorkflowWorkflowScope) E.&&. restrictOnArchived workflowWorkflow now wwListType + where headings = (MsgWorkflowWorkflowListTopTitle wwListType, MsgWorkflowWorkflowListTopHeading wwListType) type WorkflowWorkflowTableExpr = E.SqlExpr (Entity WorkflowWorkflow) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity WorkflowInstance)) @@ -388,12 +383,12 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f where mkLink = runReaderT $ do rScope <- hoistMaybe =<< view resultRouteScope - return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) + return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR WorkflowWorkflowListActive) 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) + return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win $ WIWorkflowsR WorkflowWorkflowListActive) dbtSorting = mconcat [ singletonMap "workflow-workflow" . SortProjected . comparing $ view resultWorkflowWorkflowId , singletonMap "scope" . SortProjected . comparing $ view resultRouteScope diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 0eb666e38..34c5fca60 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -32,6 +32,7 @@ module Model.Types.Workflow , WorkflowFieldPayload(..), _WorkflowFieldPayload , workflowStatePayload, workflowStateCurrentPayloads , WorkflowChildren + , WorkflowWorkflowListType(..) ) where import Import.NoModel @@ -438,7 +439,8 @@ classifyWorkflowScope = \case WSTermSchool{} -> WSTermSchool' WSCourse{} -> WSCourse' ------ WORKFLOW: PAYLOAD ----- + +----- WORKFLOW PAYLOAD ----- newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel :: CI Text } deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) @@ -675,10 +677,19 @@ workflowStateCurrentPayloads :: forall fileid userid mono. -> Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW fileid userid)) workflowStateCurrentPayloads = Map.unionsWith (\_ v -> v) . map wpPayload . otoList + +----- Workflow routing types ----- + +data WorkflowWorkflowListType = WorkflowWorkflowListActive | WorkflowWorkflowListArchive | WorkflowWorkflowListAll + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) + + ----- Lenses needed here ----- makeLenses_ ''WorkflowAction + ----- Generic traversal ----- type family Concat as bs where @@ -824,6 +835,8 @@ derivePathPiece ''WorkflowScope (camelToPathPiece' 1) "--" nullaryPathPiece ''WorkflowPayloadTimeCapturePrecision $ camelToPathPiece' 2 +nullaryPathPiece ''WorkflowWorkflowListType $ camelToPathPiece' 3 + ----- ToJSON / FromJSON instances ----- omitNothing :: [JSON.Pair] -> [JSON.Pair] @@ -1229,6 +1242,7 @@ instance (Ord fileid, FromJSON fileid, FromJSON userid, Typeable fileid, Typeabl uid <- o JSON..: toPathPiece WFPUser' return $ WorkflowFieldPayloadW $ WFPUser uid +pathPieceJSON ''WorkflowWorkflowListType ----- PersistField / PersistFieldSql instances -----