diff --git a/config/settings.yml b/config/settings.yml index 89ee33642..d8d6e6534 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -295,3 +295,5 @@ bot-mitigations: volatile-cluster-settings-cache-time: 10 communication-attachments-max-size: 20971520 # 20MiB + +workflow-workflow-archive-after: 5270400 # 61 days diff --git a/messages/uniworx/categories/workflows/de-de-formal.msg b/messages/uniworx/categories/workflows/de-de-formal.msg index 6cd756c84..bb522d69a 100644 --- a/messages/uniworx/categories/workflows/de-de-formal.msg +++ b/messages/uniworx/categories/workflows/de-de-formal.msg @@ -106,6 +106,8 @@ WorkflowWorkflowWorkflowStateHeading: Zustand/Daten WorkflowWorkflowWorkflowPayloadHeading: Aktueller Datensatz WorkflowWorkflowWorkflowStateStateLabel: Aktueller Zustand WorkflowWorkflowWorkflowStateStateHidden: Versteckter Zustand +WorkflowWorkflowWorkflowStateArchivedLabel: Archiviert seit +WorkflowWorkflowWorkflowArchivationInfo: Workflows, welche seit 61 Tagen abgeschlossen sind, werden automatisch archiviert. Aktionen setzen den Archivierungszeitpunkt eines Workflows zurück. WorkflowWorkflowWorkflowHistoryLabelOthers: Aktionen Anderer WorkflowWorkflowWorkflowHistoryLabelOwn: Eigene Aktionen @@ -123,18 +125,18 @@ 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: Laufende Workflows - _{rScope} -WorkflowWorkflowListScopeHeading rScope@RouteWorkflowScope: Laufende Workflows (_{rScope}) -WorkflowWorkflowListInstanceTitle: Laufende Workflows für Instanz -WorkflowWorkflowListInstanceHeading: Laufende Workflows für Instanz -WorkflowWorkflowListNamedInstanceTitle rScope@RouteWorkflowScope wiTitle@Text: Laufende Workflows - _{rScope}, #{wiTitle} -WorkflowWorkflowListNamedInstanceHeading rScope@RouteWorkflowScope wiTitle@Text: Laufende Workflows (_{rScope}, #{wiTitle}) -WorkflowWorkflowListNamedInstanceTitleDisabled rScope@RouteWorkflowScope: Laufende Workflows - _{rScope} -WorkflowWorkflowListNamedInstanceHeadingDisabled rScope@RouteWorkflowScope: Laufende Workflows (_{rScope}) -WorkflowWorkflowListTopTitle: Laufende Workflows -WorkflowWorkflowListTopHeading: Laufende Workflows -AdminWorkflowWorkflowListTitle: Laufende Workflows -AdminWorkflowWorkflowListHeading: Laufende Workflows +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 +AdminWorkflowWorkflowListTitle: Alle Workflows +AdminWorkflowWorkflowListHeading: Alle Workflows WorkflowWorkflowListNumber: Nummer WorkflowWorkflowListScope: Bereich @@ -160,4 +162,4 @@ WorkflowInstanceUpdateUpdatedCategory: Kategorie-Update erfolgreich angewandt WorkflowInstanceUpdateDeletedDescriptionLanguage lang@Lang: Beschreibung/Titel in Sprache „#{lang}“ gelöscht WorkflowInstanceUpdateUpdatedDescriptionLanguage lang@Lang: Beschreibung/Titel-Update für Sprache „#{lang}“ angewandt -WorkflowsDisabled: Workflows sind temporär deaktiviert. \ No newline at end of file +WorkflowsDisabled: Workflows sind zur Zeit deaktiviert. \ No newline at end of file diff --git a/messages/uniworx/categories/workflows/en-eu.msg b/messages/uniworx/categories/workflows/en-eu.msg index 2dcc37915..daaa6cdf7 100644 --- a/messages/uniworx/categories/workflows/en-eu.msg +++ b/messages/uniworx/categories/workflows/en-eu.msg @@ -65,6 +65,8 @@ WorkflowWorkflowWorkflowStateHeading: State/Data WorkflowWorkflowWorkflowPayloadHeading: Current data WorkflowWorkflowWorkflowStateStateLabel: Current state WorkflowWorkflowWorkflowStateStateHidden: Hidden state +WorkflowWorkflowWorkflowStateArchivedLabel: Archived since +WorkflowWorkflowWorkflowArchivationInfo: Workflows that are finalized for 61 days will be automatically moved to the archive. Actions reset the archivation date of a workflow. WorkflowWorkflowWorkflowHistoryLabelOthers: Other users' actions WorkflowWorkflowWorkflowHistoryLabelOwn: Your actions @@ -82,18 +84,18 @@ 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}) -WorkflowWorkflowListNamedInstanceTitleDisabled rScope: Running Workflows - _{rScope} -WorkflowWorkflowListNamedInstanceHeadingDisabled rScope: Running Workflows (_{rScope}) -WorkflowWorkflowListTopTitle: Running workflows -WorkflowWorkflowListTopHeading: Running workflows -AdminWorkflowWorkflowListTitle: Running workflows -AdminWorkflowWorkflowListHeading: Running workflows +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 +AdminWorkflowWorkflowListTitle: All workflows +AdminWorkflowWorkflowListHeading: All workflows WorkflowWorkflowListNumber: Number WorkflowWorkflowListScope: Scope @@ -160,4 +162,4 @@ WorkflowInstanceUpdateUpdatedCategory: Successfully applied updated category WorkflowInstanceUpdateDeletedDescriptionLanguage lang: Successfully deleted description/title for language “#{lang}” WorkflowInstanceUpdateUpdatedDescriptionLanguage lang: Successfully applied updated description/title for language “#{lang}” -WorkflowsDisabled: Workflows are temporarily disabled. +WorkflowsDisabled: Workflows are currently disabled. diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index c79919c59..e038094ad 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -93,11 +93,13 @@ BreadcrumbAdminWorkflowWorkflowNew: Workflow initiieren BreadcrumbWorkflowInstanceEdit win@WorkflowInstanceName !ident-ok: #{win} BreadcrumbWorkflowInstanceDelete: Löschen BreadcrumbWorkflowInstanceWorkflowList: Laufende Workflows +BreadcrumbWorkflowInstanceWorkflowArchive: Archivierte Workflows BreadcrumbWorkflowInstanceInitiate: Workflow starten BreadcrumbWorkflowInstanceList !ident-ok: Workflows BreadcrumbWorkflowInstanceNew: Neuer Workflow BreadcrumbWorkflowInstanceUpdate !ident-ok: Update BreadcrumbWorkflowWorkflowList: Laufende Workflows +BreadcrumbWorkflowWorkflowArchive: Archivierte Workflows BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow !ident-ok: #{toPathPiece workflow} BreadcrumbWorkflowWorkflowFiles: Dateien BreadcrumbWorkflowWorkflowEdit: Editieren @@ -105,6 +107,7 @@ BreadcrumbWorkflowWorkflowDelete: Löschen BreadcrumbGlobalWorkflowInstanceList: Systemweite Workflows BreadcrumbTopWorkflowInstanceList !ident-ok: Workflows BreadcrumbTopWorkflowWorkflowList: Laufende Workflows +BreadcrumbTopWorkflowWorkflowArchive: Archivierte Workflows 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 dfb3eb21a..bff225a9f 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -93,11 +93,13 @@ BreadcrumbAdminWorkflowWorkflowNew: Initiate workflow BreadcrumbWorkflowInstanceEdit win: #{win} BreadcrumbWorkflowInstanceDelete: Delete BreadcrumbWorkflowInstanceWorkflowList: Running workflows +BreadcrumbWorkflowInstanceWorkflowArchive: Archived workflows BreadcrumbWorkflowInstanceInitiate: Start workflow BreadcrumbWorkflowInstanceList: Workflows BreadcrumbWorkflowInstanceNew: New workflow BreadcrumbWorkflowInstanceUpdate !ident-ok: Update BreadcrumbWorkflowWorkflowList: Running workflows +BreadcrumbWorkflowWorkflowArchive: Archived workflows BreadcrumbWorkflowWorkflow workflow: #{toPathPiece workflow} BreadcrumbWorkflowWorkflowFiles: Files BreadcrumbWorkflowWorkflowEdit: Edit @@ -105,6 +107,7 @@ BreadcrumbWorkflowWorkflowDelete: Delete BreadcrumbGlobalWorkflowInstanceList: System-wide workflows BreadcrumbTopWorkflowInstanceList: Workflows BreadcrumbTopWorkflowWorkflowList: Running workflows +BreadcrumbTopWorkflowWorkflowArchive: Archived workflows 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 69bc2b39d..b082c1571 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -127,11 +127,13 @@ MenuWorkflowInstanceWorkflows: Laufende Workflows MenuWorkflowInstanceInitiate: Workflow starten MenuWorkflowInstanceEdit: Bearbeiten MenuWorkflowWorkflowList: Laufende Workflows +MenuWorkflowWorkflowArchive: Archivierte Workflows MenuWorkflowWorkflowEdit: Editieren MenuWorkflowWorkflowDelete: Löschen MenuGlobalWorkflowInstanceList: Systemweite Workflows MenuTopWorkflowInstanceList !ident-ok: Workflows MenuTopWorkflowWorkflowList: Laufende Workflows +MenuTopWorkflowWorkflowArchive: Archivierte Workflows 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 3a4a45a16..00b3ba02c 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -128,11 +128,13 @@ MenuWorkflowInstanceWorkflows: Running workflows MenuWorkflowInstanceInitiate: Start workflow MenuWorkflowInstanceEdit: Edit MenuWorkflowWorkflowList: Running workflows +MenuWorkflowWorkflowArchive: Archived workflows MenuWorkflowWorkflowEdit: Edit MenuWorkflowWorkflowDelete: Delete MenuGlobalWorkflowInstanceList: System-wide workflows MenuTopWorkflowInstanceList: Workflows MenuTopWorkflowWorkflowList: Running workflows +MenuTopWorkflowWorkflowArchive: Archived workflows MenuTopWorkflowWorkflowListHeader: Workflows MenuGlossary: Glossary MenuVersion: Version history diff --git a/models/workflows.model b/models/workflows.model index d20d4e040..7156044fe 100644 --- a/models/workflows.model +++ b/models/workflows.model @@ -50,4 +50,5 @@ WorkflowWorkflow scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId graph SharedWorkflowGraphId state (WorkflowState FileReference SqlBackendKey) -- UserId + archived UTCTime Maybe deriving Generic diff --git a/routes b/routes index f5083251c..313ee42e3 100644 --- a/routes +++ b/routes @@ -76,20 +76,23 @@ /global-workflows/instances GlobalWorkflowInstanceListR GET !free /global-workflows/instances/new GlobalWorkflowInstanceNewR GET POST /global-workflows/instances/#WorkflowInstanceName GlobalWorkflowInstanceR: - /edit GWIEditR GET POST - /delete GWIDeleteR GET POST - /workflows GWIWorkflowsR GET !free - /initiate GWIInitiateR GET POST !workflow - /update GWIUpdateR POST -/global-workflows GlobalWorkflowWorkflowListR GET !free + /edit GWIEditR GET POST + /delete GWIDeleteR GET POST + /workflows GWIWorkflowsR GET !free + /workflows-archive GWIWorkflowsArchiveR GET !free + /initiate GWIInitiateR GET POST !workflow + /update GWIUpdateR POST +/global-workflows GlobalWorkflowWorkflowListR GET !free +/global-workflows-archive GlobalWorkflowWorkflowArchiveR GET !free !/global-workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR: / GWWWorkflowR GET POST !workflow /files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex GWWFilesR GET !workflow /edit GWWEditR GET POST /delete GWWDeleteR GET POST -/workflow-instances TopWorkflowInstanceListR GET !free -/workflows TopWorkflowWorkflowListR GET !free +/workflow-instances TopWorkflowInstanceListR GET !free +/workflows TopWorkflowWorkflowListR GET !free +/workflows-archive TopWorkflowWorkflowArchiveR GET !free /health HealthR GET !free /instance InstanceR GET !free @@ -143,12 +146,14 @@ /workflows/instances SchoolWorkflowInstanceListR GET !free /workflows/instances/new SchoolWorkflowInstanceNewR GET POST /workflows/instances/#WorkflowInstanceName SchoolWorkflowInstanceR: - /edit SWIEditR GET POST - /delete SWIDeleteR GET POST - /workflows SWIWorkflowsR GET !free - /initiate SWIInitiateR GET POST !workflow - /update SWIUpdateR POST - /workflows SchoolWorkflowWorkflowListR GET !free + /edit SWIEditR GET POST + /delete SWIDeleteR GET POST + /workflows SWIWorkflowsR GET !free + /workflows-archive SWIWorkflowsArchiveR GET !free + /initiate SWIInitiateR GET POST !workflow + /update SWIUpdateR POST + /workflows SchoolWorkflowWorkflowListR GET !free + /workflows-archive SchoolWorkflowWorkflowArchiveR GET !free !/workflows/#CryptoFileNameWorkflowWorkflow SchoolWorkflowWorkflowR: / SWWWorkflowR GET POST !workflow /files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex SWWFilesR GET !workflow diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 697960e32..7b5bbb4df 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -118,7 +118,7 @@ breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR -breadcrumb (SchoolR ssh sRoute) = case sRoute of +breadcrumb currentRoute@(SchoolR ssh sRoute) = case sRoute of SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do School{..} <- MaybeT $ get ssh isAdmin <- lift $ hasReadAccessTo SchoolListR @@ -138,6 +138,7 @@ breadcrumb (SchoolR ssh sRoute) = case sRoute of 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 SWIInitiateR -> useRunDB $ do mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if @@ -145,8 +146,17 @@ breadcrumb (SchoolR ssh sRoute) = case sRoute of | 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 SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of - SWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh SchoolWorkflowWorkflowListR + SWWWorkflowR -> do + now <- liftIO getCurrentTime + mWorkflowWorkflow <- useRunDB . runMaybeT $ do + 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 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 @@ -425,6 +435,7 @@ breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of 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 GWIInitiateR -> do mayEdit <- useRunDB . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if @@ -432,14 +443,24 @@ breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of | otherwise -> GlobalWorkflowInstanceListR GWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just $ GlobalWorkflowInstanceR win GWIEditR breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR -breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of - GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowWorkflowListR +breadcrumb GlobalWorkflowWorkflowArchiveR = i18nCrumb MsgBreadcrumbWorkflowWorkflowArchive $ Just GlobalWorkflowInstanceListR +breadcrumb currentRoute@(GlobalWorkflowWorkflowR cID sRoute) = case sRoute of + GWWWorkflowR -> do + now <- liftIO getCurrentTime + mWorkflowWorkflow <- useRunDB . runMaybeT $ do + 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 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 TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing +breadcrumb TopWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowList $ Just TopWorkflowInstanceListR +breadcrumb TopWorkflowWorkflowArchiveR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowArchive $ Just TopWorkflowInstanceListR data NavQuickView @@ -2631,6 +2652,32 @@ 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, WorkflowWorkflowR cID WWWorkflowR) <- route ^? _WorkflowScopeRoute = return [ NavPageActionSecondary { navLink = NavLink @@ -2666,6 +2713,58 @@ 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 _ = return [] submissionList :: ( MonadIO m diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index eac3e22dc..170a156f7 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -42,11 +42,13 @@ getLegalR = -- | Allgemeine Informationen getInfoR :: Handler Html getInfoR = do + AppSettings{..} <- getsYesod appSettings' changelogEntries' <- runDB $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] [] let changelogEntries = Map.fromListWith Set.union [ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem) | Entity _ ChangelogItemFirstSeen{..} <- changelogEntries' ] + changelogItems = $(i18nWidgetFiles "changelog") siteLayoutMsg MsgInfoHeading $ do setTitleI MsgInfoHeading @@ -58,9 +60,6 @@ getInfoR = do gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" $(widgetFile "versionHistory") - where - changelogItems = $(i18nWidgetFiles "changelog") - getGlossaryR :: Handler Html getGlossaryR = diff --git a/src/Handler/Utils/Workflow/CanonicalRoute.hs b/src/Handler/Utils/Workflow/CanonicalRoute.hs index 507da9cee..969d403dd 100644 --- a/src/Handler/Utils/Workflow/CanonicalRoute.hs +++ b/src/Handler/Utils/Workflow/CanonicalRoute.hs @@ -12,11 +12,12 @@ data WorkflowScopeRoute | WorkflowInstanceNewR | WorkflowInstanceR WorkflowInstanceName WorkflowInstanceR | WorkflowWorkflowListR + | WorkflowWorkflowArchiveR | WorkflowWorkflowR CryptoFileNameWorkflowWorkflow WorkflowWorkflowR deriving (Eq, Ord, Read, Show, Generic, Typeable) data WorkflowInstanceR - = WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR | WIUpdateR + = WIEditR | WIDeleteR | WIWorkflowsR | WIWorkflowsArchiveR | WIInitiateR | WIUpdateR deriving (Eq, Ord, Read, Show, Generic, Typeable) data WorkflowWorkflowR @@ -32,12 +33,14 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute WorkflowInstanceListR -> GlobalWorkflowInstanceListR WorkflowInstanceNewR -> GlobalWorkflowInstanceNewR WorkflowInstanceR win subRoute -> GlobalWorkflowInstanceR win $ case subRoute of - WIEditR -> GWIEditR - WIDeleteR -> GWIDeleteR - WIWorkflowsR -> GWIWorkflowsR - WIInitiateR -> GWIInitiateR - WIUpdateR -> GWIUpdateR + WIEditR -> GWIEditR + WIDeleteR -> GWIDeleteR + WIWorkflowsR -> GWIWorkflowsR + WIWorkflowsArchiveR -> GWIWorkflowsArchiveR + WIInitiateR -> GWIInitiateR + WIUpdateR -> GWIUpdateR WorkflowWorkflowListR -> GlobalWorkflowWorkflowListR + WorkflowWorkflowArchiveR -> GlobalWorkflowWorkflowArchiveR WorkflowWorkflowR wwCID subRoute -> GlobalWorkflowWorkflowR wwCID $ case subRoute of WWWorkflowR -> GWWWorkflowR WWFilesR wpl stCID -> GWWFilesR wpl stCID @@ -47,12 +50,14 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute WorkflowInstanceListR -> SchoolWorkflowInstanceListR WorkflowInstanceNewR -> SchoolWorkflowInstanceNewR WorkflowInstanceR win subRoute -> SchoolWorkflowInstanceR win $ case subRoute of - WIEditR -> SWIEditR - WIDeleteR -> SWIDeleteR - WIWorkflowsR -> SWIWorkflowsR - WIInitiateR -> SWIInitiateR - WIUpdateR -> SWIUpdateR + WIEditR -> SWIEditR + WIDeleteR -> SWIDeleteR + WIWorkflowsR -> SWIWorkflowsR + WIWorkflowsArchiveR -> SWIWorkflowsArchiveR + WIInitiateR -> SWIInitiateR + WIUpdateR -> SWIUpdateR WorkflowWorkflowListR -> SchoolWorkflowWorkflowListR + WorkflowWorkflowArchiveR -> SchoolWorkflowWorkflowArchiveR WorkflowWorkflowR wwCID subRoute -> SchoolWorkflowWorkflowR wwCID $ case subRoute of WWWorkflowR -> SWWWorkflowR WWFilesR wpl stCID -> SWWFilesR wpl stCID @@ -63,12 +68,14 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute GlobalWorkflowInstanceListR -> Just ( WSGlobal, WorkflowInstanceListR ) GlobalWorkflowInstanceNewR -> Just ( WSGlobal, WorkflowInstanceNewR ) GlobalWorkflowInstanceR win subRoute -> Just . (WSGlobal, ) . WorkflowInstanceR win $ case subRoute of - GWIEditR -> WIEditR - GWIDeleteR -> WIDeleteR - GWIWorkflowsR -> WIWorkflowsR - GWIInitiateR -> WIInitiateR - GWIUpdateR -> WIUpdateR + GWIEditR -> WIEditR + GWIDeleteR -> WIDeleteR + GWIWorkflowsR -> WIWorkflowsR + GWIWorkflowsArchiveR -> WIWorkflowsArchiveR + GWIInitiateR -> WIInitiateR + GWIUpdateR -> WIUpdateR GlobalWorkflowWorkflowListR -> Just ( WSGlobal, WorkflowWorkflowListR ) + GlobalWorkflowWorkflowArchiveR -> Just ( WSGlobal, WorkflowWorkflowArchiveR ) GlobalWorkflowWorkflowR wwCID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of GWWWorkflowR -> WWWorkflowR GWWFilesR wpl stCID -> WWFilesR wpl stCID @@ -78,12 +85,14 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute 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 - SWIInitiateR -> WIInitiateR - SWIUpdateR -> WIUpdateR + SWIEditR -> WIEditR + SWIDeleteR -> WIDeleteR + SWIWorkflowsR -> WIWorkflowsR + SWIWorkflowsArchiveR -> WIWorkflowsArchiveR + 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 SWWWorkflowR -> WWWorkflowR SWWFilesR wpl stCID -> WWFilesR wpl stCID diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index d0046ae91..f2ba34873 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/src/Handler/Workflow/Instance/Initiate.hs @@ -48,9 +48,10 @@ workflowInstanceInitiateR rScope win = workflowsDisabledWarning MsgWorkflowInsta wwId <- insert WorkflowWorkflow { workflowWorkflowInstance = Just wiId - , workflowWorkflowScope = workflowInstanceScope - , workflowWorkflowGraph = workflowInstanceGraph + , workflowWorkflowScope = workflowInstanceScope + , workflowWorkflowGraph = workflowInstanceGraph , workflowWorkflowState + , workflowWorkflowArchived = Nothing -- FIXME: set to now + 2 months if current state is final state } return . Just $ do diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index a884afb36..9e883e2e2 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 - , getSchoolWorkflowWorkflowListR + ( getGlobalWorkflowWorkflowListR, getGlobalWorkflowWorkflowArchiveR + , getSchoolWorkflowWorkflowListR, getSchoolWorkflowWorkflowArchiveR , workflowWorkflowListR - , getGWIWorkflowsR - , getSWIWorkflowsR + , getGWIWorkflowsR, getGWIWorkflowsArchiveR + , getSWIWorkflowsR, getSWIWorkflowsArchiveR , workflowInstanceWorkflowsR , getAdminWorkflowWorkflowListR - , getTopWorkflowWorkflowListR + , getTopWorkflowWorkflowListR, getTopWorkflowWorkflowArchiveR ) where import Import hiding (Last(..), WriterT) @@ -55,46 +55,66 @@ instance Default WorkflowWorkflowListFilterProj where , wwProjFilterFinal = Nothing } -makeLenses_ ''WorkflowWorkflowListFilterProj +makeLenses_ ''WorkflowWorkflowListFilterProj -getGlobalWorkflowWorkflowListR :: Handler Html -getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal +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) + (workflowWorkflow E.^. WorkflowWorkflowArchived) -getSchoolWorkflowWorkflowListR :: SchoolId -> Handler Html -getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool -workflowWorkflowListR :: RouteWorkflowScope -> Handler Html -workflowWorkflowListR rScope = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) $ do +getGlobalWorkflowWorkflowListR, getGlobalWorkflowWorkflowArchiveR :: Handler Html +getGlobalWorkflowWorkflowListR = workflowWorkflowListR (Just False) WSGlobal +getGlobalWorkflowWorkflowArchiveR = workflowWorkflowListR (Just True ) WSGlobal + +getSchoolWorkflowWorkflowListR, getSchoolWorkflowWorkflowArchiveR :: SchoolId -> Handler Html +getSchoolWorkflowWorkflowListR = workflowWorkflowListR (Just False) . WSSchool +getSchoolWorkflowWorkflowArchiveR = workflowWorkflowListR (Just True ) . WSSchool + +workflowWorkflowListR :: Maybe Bool -- ^ archived/non-archived workflows only? + -> RouteWorkflowScope + -> Handler Html +workflowWorkflowListR mArchived rScope = 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) + return $ + workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope) + E.&&. restrictOnArchived workflowWorkflow now mArchived where columns = def { wwListColumnScope = False } - headings = (MsgWorkflowWorkflowListScopeTitle rScope, MsgWorkflowWorkflowListScopeHeading rScope) + headings = (MsgWorkflowWorkflowListScopeTitle rScope mArchived, MsgWorkflowWorkflowListScopeHeading rScope mArchived) -getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html -getGWIWorkflowsR = workflowInstanceWorkflowsR WSGlobal +getGWIWorkflowsR, getGWIWorkflowsArchiveR :: WorkflowInstanceName -> Handler Html +getGWIWorkflowsR = workflowInstanceWorkflowsR (Just False) WSGlobal +getGWIWorkflowsArchiveR = workflowInstanceWorkflowsR (Just True ) WSGlobal -getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html -getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh +getSWIWorkflowsR, getSWIWorkflowsArchiveR :: SchoolId -> WorkflowInstanceName -> Handler Html +getSWIWorkflowsR = workflowInstanceWorkflowsR (Just False) . WSSchool +getSWIWorkflowsArchiveR = workflowInstanceWorkflowsR (Just True ) . WSSchool -workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html -workflowInstanceWorkflowsR rScope win = workflowsDisabledWarning (MsgWorkflowWorkflowListNamedInstanceTitleDisabled rScope) (MsgWorkflowWorkflowListNamedInstanceHeadingDisabled rScope) $ do +workflowInstanceWorkflowsR :: Maybe Bool -- ^ archived/non-archived workflows only? + -> RouteWorkflowScope + -> WorkflowInstanceName + -> Handler Html +workflowInstanceWorkflowsR mArchived rScope win = workflowsDisabledWarning (MsgWorkflowWorkflowListNamedInstanceTitleDisabled rScope mArchived) (MsgWorkflowWorkflowListNamedInstanceHeadingDisabled rScope mArchived) $ do + now <- liftIO getCurrentTime (scope, desc) <- runDB $ do scope <- maybeT notFound $ fromRouteWorkflowScope rScope wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope desc <- selectWorkflowInstanceDescription wiId return (scope, desc) let headings = case desc of - Nothing -> (MsgWorkflowWorkflowListInstanceTitle, MsgWorkflowWorkflowListInstanceHeading) + Nothing -> (MsgWorkflowWorkflowListInstanceTitle mArchived, MsgWorkflowWorkflowListInstanceHeading mArchived) Just (Entity _ WorkflowInstanceDescription{..}) - -> ( MsgWorkflowWorkflowListNamedInstanceTitle rScope workflowInstanceDescriptionTitle - , MsgWorkflowWorkflowListNamedInstanceHeading rScope workflowInstanceDescriptionTitle + -> ( MsgWorkflowWorkflowListNamedInstanceTitle rScope workflowInstanceDescriptionTitle mArchived + , MsgWorkflowWorkflowListNamedInstanceHeading rScope workflowInstanceDescriptionTitle mArchived ) workflowWorkflowList headings columns . runReader $ do workflowWorkflow <- view queryWorkflowWorkflow @@ -102,6 +122,7 @@ workflowInstanceWorkflowsR rScope win = workflowsDisabledWarning (MsgWorkflowWor 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 where columns = def { wwListColumnInstance = False @@ -110,12 +131,18 @@ workflowInstanceWorkflowsR rScope win = workflowsDisabledWarning (MsgWorkflowWor getAdminWorkflowWorkflowListR :: Handler Html -getAdminWorkflowWorkflowListR = workflowWorkflowList headings def $ const E.true +getAdminWorkflowWorkflowListR = workflowWorkflowList headings def $ const E.true -- archived workflows included where headings = (MsgAdminWorkflowWorkflowListTitle, MsgAdminWorkflowWorkflowListHeading) -getTopWorkflowWorkflowListR :: Handler Html -getTopWorkflowWorkflowListR = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) . workflowWorkflowList headings def . views queryWorkflowWorkflow $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope) - where headings = (MsgWorkflowWorkflowListTopTitle, MsgWorkflowWorkflowListTopHeading) +getTopWorkflowWorkflowListR, getTopWorkflowWorkflowArchiveR :: Handler Html +getTopWorkflowWorkflowListR = topWorkflowWorkflowListR (Just False) +getTopWorkflowWorkflowArchiveR = topWorkflowWorkflowListR (Just True) + +topWorkflowWorkflowListR :: Maybe Bool -> Handler Html +topWorkflowWorkflowListR mArchived = 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) type WorkflowWorkflowTableExpr = E.SqlExpr (Entity WorkflowWorkflow) diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index 441fa1d54..99fe42538 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -52,6 +52,7 @@ data WorkflowHistoryItem = WorkflowHistoryItem data WorkflowCurrentState = WorkflowCurrentState { wcsState :: Maybe (Text, Maybe Icon) + , wcsArchived :: Maybe UTCTime , wcsMessages :: Set Message , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))] } @@ -76,12 +77,13 @@ getSWWFilesR ssh = getWorkflowFilesR $ WSSchool ssh workflowR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html workflowR rScope cID = workflowsDisabledWarning title heading $ do + now <- liftIO getCurrentTime (mEdge, (workflowState, workflowHistory)) <- runDB $ do wwId <- decrypt cID WorkflowWorkflow{..} <- get404 wwId maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope mEdgeForm <- workflowEdgeForm (Right wwId) Nothing - wGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph + wGraph@WorkflowGraph{..} <- getSharedIdWorkflowGraph workflowWorkflowGraph let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) mEdge <- for mEdgeForm $ \edgeForm -> do @@ -94,7 +96,15 @@ workflowR rScope cID = workflowsDisabledWarning title heading $ do wiScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope return (wiScope, Entity wiId wInstance) - update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ] + wwArchived <- lift . maybeT (pure Nothing) $ do + archiveAfter <- MaybeT . getsYesod $ view _appWorkflowWorkflowArchiveAfter + let WorkflowAction{wpTo,wpTime} = last nState + WGN{wgnFinal} <- hoistMaybe $ Map.lookup wpTo wgNodes + return $ const (archiveAfter `addUTCTime` wpTime) <$> wgnFinal + + update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState + , WorkflowWorkflowArchived =. wwArchived + ] return . Just $ do whenIsJust wInstance $ \(wiScope, Entity _ WorkflowInstance{..}) -> do @@ -204,10 +214,11 @@ workflowR rScope cID = workflowsDisabledWarning title heading $ do messageContent <- selectLanguageI18n wnmContent return Message{..} + let wcsArchived = workflowWorkflowArchived + tell ( Just $ Last WorkflowCurrentState{..} , pure WorkflowHistoryItem{..} ) - WorkflowGraph{..} = wGraph wState = review _DBWorkflowState workflowWorkflowState in fmap (over _2 (sortOn (Down . whiTime) . reverse) . view _2) . runConduit $ sourceWorkflowActionInfos wwId wState .| execRWSC () Map.empty (C.mapM_ go) return (mEdge, (workflowState, workflowHistory)) @@ -248,6 +259,7 @@ workflowR rScope cID = workflowsDisabledWarning title heading $ do Nothing -> i18n MsgWorkflowPayloadUserGone Just (Entity _ User{..}) -> nameWidget userDisplayName userSurname WorkflowFieldPayloadW (WFPFile v ) -> absurd v + archivationScheduled archived = $(i18nWidgetFile "workflow-archivation-scheduled") $(widgetFile "workflows/workflow") where (heading, title) = case rScope of diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 78ac1db9e..80e97dd07 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -103,9 +103,7 @@ data ManualMigration | Migration20210208StudyFeaturesRelevanceCachedUUIDs | Migration20210318CrontabSubmissionRatedNotification | Migration20210608SeparateTermActive - -- TODO: migration regarding authorship statements - -- - apply desired non-default modes for IfI - -- - set authorship statement texts for IfI + | Migration20220521WorkflowArchivation deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) @@ -1069,6 +1067,20 @@ customMigrations = mapF $ \case ALTER TABLE "term" DROP COLUMN "active"; |] + Migration20220521WorkflowArchivation -> whenM (and2M (tableExists "workflow_workflow") $ not <$> columnExists "workflow_workflow" "archived") $ do + now <- liftIO getCurrentTime + -- mArchiveAfter <- lift $ view _appWorkflowWorkflowArchiveAfter + let mArchiveAfter = Just (5270400 :: NominalDiffTime) + [executeQQ| ALTER TABLE "workflow_workflow" ADD "archived" timestamp with time zone; |] + let getWorkflows = [queryQQ| SELECT "workflow_workflow"."id", "workflow_workflow"."state"->-1->'time', "workflow_workflow"."state"->-1->'to', "shared_workflow_graph"."graph" FROM "workflow_workflow" INNER JOIN "shared_workflow_graph" ON "workflow_workflow"."graph" = "shared_workflow_graph"."hash"; |] + migrateArchived [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTime), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTo), fromPersistValue -> Right (wGraph :: DBWorkflowGraph) ] = maybeT (return ()) $ do + archiveAfter <- hoistMaybe mArchiveAfter + WGN{wgnFinal} <- hoistMaybe . Map.lookup wpTo $ wgNodes wGraph + let wwArchived = const (max now $ archiveAfter `addUTCTime` wpTime) <$> wgnFinal + lift [executeQQ| UPDATE "workflow_workflow" SET "archived" = #{wwArchived} WHERE "id" = #{wwId}; |] + migrateArchived _ = return () + in runConduit $ getWorkflows .| C.mapM_ migrateArchived + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do diff --git a/src/Settings.hs b/src/Settings.hs index 094386068..1195e1578 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -228,6 +228,8 @@ data AppSettings = AppSettings , appJobMaxFlush :: Maybe Natural , appCommunicationAttachmentsMaxSize :: Maybe Natural + + , appWorkflowWorkflowArchiveAfter :: Maybe NominalDiffTime } deriving Show data JobMode = JobsLocal { jobsAcceptOffload :: Bool } @@ -700,6 +702,8 @@ instance FromJSON AppSettings where appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size" + appWorkflowWorkflowArchiveAfter <- o .:? "workflow-workflow-archive-after" + return AppSettings{..} where isValidARCConf ARCConf{..} = arccMaximumWeight > 0 diff --git a/src/Utils/Workflow.hs b/src/Utils/Workflow.hs index 9fe28aab5..89cc8a21f 100644 --- a/src/Utils/Workflow.hs +++ b/src/Utils/Workflow.hs @@ -200,12 +200,14 @@ getWorkflowWorkflowState' wwId Nothing = withReaderT (projectBackend @SqlBackend , workflowWorkflow E.^. WorkflowWorkflowScope , workflowWorkflow E.^. WorkflowWorkflowGraph , E.veryUnsafeCoerceSqlExprValue $ workflowWorkflow E.^. WorkflowWorkflowState + , workflowWorkflow E.^. WorkflowWorkflowArchived ) let ( E.Value workflowWorkflowInstance , E.Value workflowWorkflowScope , E.Value workflowWorkflowGraph , E.Value (wwState :: PersistValue) -- Don't parse + , E.Value workflowWorkflowArchived ) = res wwState' <- memcachedBy Nothing (WorkflowWorkflowStateParse wwState) . return $ fromPersistValue wwState case wwState' of diff --git a/templates/i18n/changelog/workflows-archivation.de-de-formal.hamlet b/templates/i18n/changelog/workflows-archivation.de-de-formal.hamlet new file mode 100644 index 000000000..c775ce108 --- /dev/null +++ b/templates/i18n/changelog/workflows-archivation.de-de-formal.hamlet @@ -0,0 +1,11 @@ +$newline never + +$maybe archived <- appWorkflowWorkflowArchiveAfter + Workflows werden nun automatisch archiviert, sobald sie # + $if archived /= 0 + seit #{tshow (nominalDiffTimeToSeconds archived / 86400)} Tagen # + abgeschlossen sind. +$nothing + Workflows können nun archiviert werden. +
+Archivierte Workflows werden nicht mehr in der Liste laufender Workflows angezeigt, sondern sind über ein separates Archiv verfügbar. diff --git a/templates/i18n/changelog/workflows-archivation.en-eu.hamlet b/templates/i18n/changelog/workflows-archivation.en-eu.hamlet new file mode 100644 index 000000000..1a1fd4e70 --- /dev/null +++ b/templates/i18n/changelog/workflows-archivation.en-eu.hamlet @@ -0,0 +1,13 @@ +$newline never + +$maybe archived <- appWorkflowWorkflowArchiveAfter + Workflows are now being archived automatically # + $if archived == 0 + immediately # + $else + #{tshow (nominalDiffTimeToSeconds archived / 86400)} days # + after finalization. +$nothing + Workflow may now be archived. +
+Archived workflows are not shown among the list of running workflows, but can instead be accessed via a separate archive list. diff --git a/templates/i18n/workflow-archivation-scheduled/de-de-formal.hamlet b/templates/i18n/workflow-archivation-scheduled/de-de-formal.hamlet new file mode 100644 index 000000000..ff304280d --- /dev/null +++ b/templates/i18n/workflow-archivation-scheduled/de-de-formal.hamlet @@ -0,0 +1,9 @@ +$newline never + +

+ Dieser Workflow wird am ^{formatTimeW SelFormatDateTime archived} archiviert, sofern keine weitere Aktion durchgeführt wird. + +

+ Sobald ein Workflow archiviert ist, wird er nicht mehr in der Liste laufender Workflows angeführt. +
+ Sie können in einem bereits archivierten Workflow auch weiterhin alle Aktionen ausführen, welche Sie in einem laufenden Workflow im gleichen Zustand durchführen könnten. diff --git a/templates/i18n/workflow-archivation-scheduled/en-eu.hamlet b/templates/i18n/workflow-archivation-scheduled/en-eu.hamlet new file mode 100644 index 000000000..022023fe3 --- /dev/null +++ b/templates/i18n/workflow-archivation-scheduled/en-eu.hamlet @@ -0,0 +1,9 @@ +$newline never + +

+ This workflow will be archived on ^{formatTimeW SelFormatDateTime archived} if no further action is performed. + +

+ Once a workflow has been archived, it will not be listed among the list of running workflows anymore. +
+ In an archived workflow, you are still able to perform any action that you could perform in a running workflow in the same current state. diff --git a/templates/workflows/workflow.hamlet b/templates/workflows/workflow.hamlet index aaac0b497..1df3fe1cc 100644 --- a/templates/workflows/workflow.hamlet +++ b/templates/workflows/workflow.hamlet @@ -1,6 +1,10 @@ $newline never $maybe WorkflowCurrentState{..} <- workflowState

+ $maybe archived <- wcsArchived + $if now < archived + ^{notification NotificationBroad =<< messageWidget Warning (archivationScheduled archived)} +

_{MsgWorkflowWorkflowWorkflowStateHeading} @@ -16,6 +20,13 @@ $maybe WorkflowCurrentState{..} <- workflowState $nothing _{MsgWorkflowWorkflowWorkflowStateStateHidden} + $maybe archived <- wcsArchived + $if now >= archived +
+ _{MsgWorkflowWorkflowWorkflowStateArchivedLabel} # + ^{messageTooltip =<< messageI Info MsgWorkflowWorkflowWorkflowArchivationInfo} +
+ ^{formatTimeW SelFormatDateTime archived} $forall msg <- wcsMessages ^{notification NotificationBroad msg}