fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

feat(workflows): implement handlers for listing all workflows

Browse Source
This commit is contained in:
Sarah Vaupel 2022-05-28 00:10:56 +02:00
parent e49223332d
commit 85c24f713a
15 changed files with 190 additions and 230 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
messages/uniworx/categories/workflows/de-de-formal.msg
View File

@ -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}

24
messages/uniworx/categories/workflows/en-eu.msg
View File

@ -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

9
messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg
View File

@ -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

9
messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg
View File

@ -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

6
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -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

6
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -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

15
routes
View File

@ -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

6
src/Foundation/Authorization.hs
View File

@ -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

2
src/Foundation/I18n.hs
View File

@ -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

169
src/Foundation/Navigation.hs
View File

@ -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

45
src/Handler/Utils/Workflow/CanonicalRoute.hs
View File

@ -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

2
src/Handler/Workflow/Instance/Initiate.hs
View File

@ -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 )
]

4
src/Handler/Workflow/Instance/List.hs
View File

@ -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)

83
src/Handler/Workflow/Workflow/List.hs
View File

@ -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

16
src/Model/Types/Workflow.hs
View File

@ -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 -----