diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg
index 5ac37eca2..373acdc1a 100644
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@@ -1383,6 +1383,16 @@ MenuAdminCrontab: Crontab
MenuAdminWorkflowDefinitionList: Workflows
MenuAdminWorkflowDefinitionNew: Neue Workflow-Definition
MenuAdminWorkflowDefinitionDelete: Löschen
+MenuAdminWorkflowInstanceList: Workflow-Instanzen
+MenuAdminWorkflowInstanceNew: Neue Workflow-Instanz
+MenuAdminWorkflowDefinitionInstantiate: Instanziieren
+MenuWorkflowInstanceDelete: Löschen
+MenuWorkflowInstanceWorkflows: Laufende Workflows
+MenuWorkflowInstanceInitiate: Workflow starten
+MenuWorkflowWorkflowEdit: Editieren
+MenuWorkflowWorkflowDelete: Löschen
+MenuGlobalWorkflowInstanceList: Workflows
+MenuGlobalWorkflowWorkflowList: Laufende Workflows
BreadcrumbSubmissionFile: Datei
BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
@@ -1462,6 +1472,22 @@ BreadcrumbAdminWorkflowDefinitionList: Workflow-Definitionen
BreadcrumbAdminWorkflowDefinitionNew: Neue Workflow-Definition
BreadcrumbAdminWorkflowDefinitionEdit renderedWorkflowScope'@Text wfdn@WorkflowDefinitionName: #{wfdn} (#{renderedWorkflowScope'})
BreadcrumbAdminWorkflowDefinitionDelete: Löschen
+BreadcrumbAdminWorkflowDefinitionInstantiate: Instanziieren
+BreadcrumbAdminWorkflowInstanceList: Workflow-Instanzen
+BreadcrumbAdminWorkflowInstanceNew: Neue Workflow-Instanz
+BreadcrumbAdminWorkflowWorkflowList: Initiierte Workflows
+BreadcrumbAdminWorkflowWorkflowNew: Workflow initiieren
+BreadcrumbWorkflowInstanceEdit win@WorkflowInstanceName: #{win}
+BreadcrumbWorkflowInstanceDelete: Löschen
+BreadcrumbWorkflowInstanceWorkflowList: Laufende Workflows
+BreadcrumbWorkflowInstanceInitiate: Workflow starten
+BreadcrumbWorkflowInstanceList: Workflows
+BreadcrumbWorkflowInstanceNew: Neuer Workflow
+BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow: #{toPathPiece workflow}
+BreadcrumbWorkflowWorkflowEdit: Editieren
+BreadcrumbWorkflowWorkflowDelete: Löschen
+BreadcrumbGlobalWorkflowInstanceList: Workflows
+BreadcrumbGlobalWorkflowWorkflowList: Laufende Workflows
ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
@@ -1517,6 +1543,7 @@ AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
AuthTagRead: Zugriff ist nur lesend
AuthTagWrite: Zugriff ist i.A. schreibend
AuthTagSubmissionGroup: Nutzer ist Mitglied in registrierter Abgabegruppe
+AuthTagWorkflow: Nutzer hat passende Workflow-Rolle
DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
DeletePressButtonIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, bestätigen Sie dies bitte durch Drücken des untigen Knopfes.
@@ -2842,30 +2869,32 @@ CronMatchNone: Nie
SystemExamOffice: Prüfungsverwaltung
SystemFaculty: Fakultätsmitglied
-WorkflowInstanceScopeKindGlobal: Systemweit
-WorkflowInstanceScopeKindTerm: Pro Semester
-WorkflowInstanceScopeKindSchool: Pro Institut
-WorkflowInstanceScopeKindTermSchool: Pro Institut & Semester
-WorkflowInstanceScopeKindCourse: Pro Veranstaltung
+WorkflowScopeKindGlobal: Systemweit
+WorkflowScopeKindTerm: Pro Semester
+WorkflowScopeKindSchool: Pro Institut
+WorkflowScopeKindTermSchool: Pro Institut & Semester
+WorkflowScopeKindCourse: Pro Veranstaltung
+WorkflowScopeGlobal: Systemweit
+WorkflowScopeTermSchool tid@TermId ssh@SchoolId: #{tid} #{ssh}
+WorkflowScopeCourse tid@TermId ssh@SchoolId csh@CourseShorthand: #{tid} #{ssh} #{csh}
WorkflowDefinitionScope: Bereich
WorkflowDefinitionName: Name
WorkflowDefinitionDescriptions: Beschreibung
WorkflowDefinitionDescriptionsLanguageExists: Eine Beschreibung in dieser Sprache existiert bereits
-WorkflowDefinitionDescriptionLanguage: Sprach-Code (RFC1766)
-WorkflowDefinitionDescriptionTitle: Titel
-WorkflowDefinitionDescription: Beschreibung
WorkflowDefinitionGraph: Spezifikation
WorkflowDefinitionKeyDoesNotExist renderedCryptoID@Text: Referenziert ID existiert nicht: #{renderedCryptoID}
WorkflowDefinitionFiles: Dateien
-WorkflowDefinitionFileIdentDoesNotExist fileIdent@Text: Referenzierte Datei existiert nicht: #{fileIdent}
+WorkflowFileIdentDoesNotExist fileIdent@Text: Referenzierte Datei existiert nicht: #{fileIdent}
+WorkflowUserDoesNotExist userIdent@Text: Referenzierter Benutzer existiert nicht: #{userIdent}
WorkflowDefinitionFileIdentExists: Eine Datei mit dieser ID existiert bereits
WorkflowDefinitionFileIdent: Dateireferenz
WorkflowDefinitionFile: Datei
WorkflowDefinitionCreated: Workflow-Definition angelegt
WorkflowDefinitionEdited: Workflow-Definition ersetzt
-WorkflowDefinitionCollision: Es existiert bereits eine Workflow-Definition mit diesem Namen
+WorkflowDefinitionCollision: Es existiert bereits eine Workflow-Definition mit diesem Namen und Bereich
WorkflowDefinitionNewTitle: Workflow-Definition anlegen
WorkflowDefinitionEditTitle: Workflow-Definition Bearbeiten
+WorkflowDefinitionInstanceCategory: Kategorie
WorkflowDefinitionListTitle: Workflow-Definitionen
WorkflowDefinitionInstanceCount: Instanzen
@@ -2874,6 +2903,24 @@ WorkflowDefinitionConcreteInstanceCount num@Int64: #{num} Instanzen
WorkflowDefinitionConcreteWorkflowCount num@Int64: #{num} Workflows
WorkflowDefinitionDeleteQuestion: Wollen Sie die unten aufgeführte Workflow-Definition wirklich löschen?
WorkflowDefinitionDeleted: Workflow-Definition gelöscht
+WorkflowDefinitionInstantiateTitle: Workflow-Definition instanziieren
+WorkflowDefinitionInstantiated: Instanz angelegt
+
+WorkflowScope: Bereich
+WorkflowInstanceName: Name
+WorkflowInstanceCategory: Kategorie
+WorkflowInstanceCollision: Es existiert bereits eine Workflow-Instanz mit diesem Namen und Bereich
+WorkflowInstanceListTitle: Workflow-Instanzen
+WorkflowInstanceDescription: Instanz-Beschreibung
+WorkflowInstanceDescriptions: Instanz-Beschreibung
+WorkflowInstanceDescriptionsLanguageExists: Eine Instanz-Beschreibung in dieser Sprache existiert bereits
+WorkflowInstanceCreated: Instanz angelegt
+WorkflowInstanceDescriptionTitle: Instanz-Titel
+WorkflowInstanceWorkflowCount: Workflows
+
+WorkflowDescriptionLanguage: Sprach-Code (RFC1766)
+WorkflowDescriptionTitle: Titel
+WorkflowDescription: Beschreibung
ChangelogItemFeature: Feature
ChangelogItemBugfix: Bugfix
\ No newline at end of file
diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg
index b5c058163..485dab0f3 100644
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@@ -2843,22 +2843,20 @@ CronMatchNone: Never
SystemExamOffice: Exam office
SystemFaculty: Faculty member
-WorkflowInstanceScopeKindGlobal: Global
-WorkflowInstanceScopeKindTerm: Per term
-WorkflowInstanceScopeKindSchool: Per school
-WorkflowInstanceScopeKindTermSchool: Per school & term
-WorkflowInstanceScopeKindCourse: Per course
+WorkflowScopeKindGlobal: Global
+WorkflowScopeKindTerm: Per term
+WorkflowScopeKindSchool: Per school
+WorkflowScopeKindTermSchool: Per school & term
+WorkflowScopeKindCourse: Per course
WorkflowDefinitionScope: Scope
WorkflowDefinitionName: Name
-WorkflowDefinitionDescriptions: Description
-WorkflowDefinitionDescriptionsLanguageExists: A description in this language already exists
-WorkflowDefinitionDescriptionLanguage: Language code (RFC1766)
-WorkflowDefinitionDescriptionTitle: Title
-WorkflowDefinitionDescription: Description
+WorkflowDescriptionLanguage: Language code (RFC1766)
+WorkflowDescriptionTitle: Title
+WorkflowDescription: Description
WorkflowDefinitionGraph: Specification
WorkflowDefinitionKeyDoesNotExist renderedCryptoID: Referenced id does not exist: #{renderedCryptoID}
WorkflowDefinitionFiles: Files
-WorkflowDefinitionFileIdentDoesNotExist fileIdent: Referenced file does not exist: #{fileIdent}
+WorkflowFileIdentDoesNotExist fileIdent: Referenced file does not exist: #{fileIdent}
WorkflowDefinitionFileIdentExists: A file with the given reference id already exists
WorkflowDefinitionFileIdent: File reference id
WorkflowDefinitionFile: File
diff --git a/models/workflows.model b/models/workflows.model
index 201bfa72c..0fb55b58c 100644
--- a/models/workflows.model
+++ b/models/workflows.model
@@ -1,7 +1,8 @@
WorkflowDefinition
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
- scope WorkflowInstanceScope'
+ scope WorkflowScope'
name WorkflowDefinitionName
+ instanceCategory WorkflowInstanceCategory Maybe
UniqueWorkflowDefinition name scope
WorkflowDefinitionDescription
@@ -11,16 +12,31 @@ WorkflowDefinitionDescription
description Html Maybe
UniqueWorkflowDefinitionDescription definition language
+WorkflowDefinitionInstanceDescription
+ definition WorkflowDefinitionId
+ language Lang
+ title Text
+ description Html Maybe
+ UniqueWorkflowDefinitionInstanceDescription definition language
+
WorkflowInstance
definition WorkflowDefinitionId Maybe
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
- scope (WorkflowInstanceScope SqlBackendKey SqlBackendKey SqlBackendKey) -- TermId, SchoolId, CourseId
+ scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId
name WorkflowInstanceName
category WorkflowInstanceCategory Maybe
UniqueWorkflowInstance name scope
+
+WorkflowInstanceDescription
+ instance WorkflowInstanceId
+ language Lang
+ title Text
+ description Html Maybe
+ UniqueWorkflowInstanceDescription instance language
WorkflowWorkflow
instance WorkflowInstanceId Maybe
+ scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
initUser UserId Maybe
initTime UTCTime
diff --git a/routes b/routes
index 45bf455fb..be4b692d8 100644
--- a/routes
+++ b/routes
@@ -57,11 +57,30 @@
/admin/errMsg AdminErrMsgR GET POST
/admin/tokens AdminTokensR GET POST
/admin/crontab AdminCrontabR GET
-/admin/workflow-definitions AdminWorkflowDefinitionListR GET
-/admin/workflow-definitions/new AdminWorkflowDefinitionNewR GET POST
-/admin/workflow-definitions/#WorkflowInstanceScope'/#WorkflowDefinitionName AdminWorkflowDefinitionR:
- /edit AWDEditR GET POST
- /delete AWDDeleteR GET POST
+
+/admin/workflows/definitions AdminWorkflowDefinitionListR GET
+/admin/workflows/definitions/new AdminWorkflowDefinitionNewR GET POST
+/admin/workflows/definitions/#WorkflowScope'/#WorkflowDefinitionName AdminWorkflowDefinitionR:
+ /edit AWDEditR GET POST
+ /delete AWDDeleteR GET POST
+ /instantiate AWDInstantiateR GET POST
+/admin/workflows/instances AdminWorkflowInstanceListR GET
+/admin/workflows/instances/new AdminWorkflowInstanceNewR GET POST
+/admin/workflows/workflows AdminWorkflowWorkflowListR GET
+/admin/workflows/workflows/new AdminWorkflowWorkflowNewR GET POST
+
+/workflow-instances GlobalWorkflowInstanceListR GET !¬empty
+/workflow-instances/new GlobalWorkflowInstanceNewR GET POST
+/workflow-instances/#WorkflowInstanceName GlobalWorkflowInstanceR:
+ /edit GWIEditR GET POST
+ /delete GWIDeleteR GET POST
+ /workflows GWIWorkflowsR GET
+ /initiate GWIInitiateR GET POST !workflow
+/workflows GlobalWorkflowWorkflowListR GET !¬empty
+/workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR:
+ / GWWWorkflowR GET POST !workflow
+ /edit GWWEditR GET POST
+ /delete GWWDeleteR GET POST
/health HealthR GET !free
/instance InstanceR GET !free
diff --git a/src/CryptoID.hs b/src/CryptoID.hs
index b311d2aaa..f6b080d25 100644
--- a/src/CryptoID.hs
+++ b/src/CryptoID.hs
@@ -73,6 +73,7 @@ decCryptoIDs [ ''SubmissionId
, ''CourseEventId
, ''TutorialId
, ''ExternalExamId
+ , ''WorkflowInstanceId
, ''WorkflowWorkflowId
]
@@ -113,3 +114,22 @@ instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "User" (CI FilePath)) where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameUser") return . fromPathPiece
instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "User" (CI FilePath)) where
toMarkup = toMarkup . toPathPiece
+
+
+-- CryptoIDNamespace (CI FilePath) WorkflowWorkflowId ~ "WorkflowWorkflow"
+instance {-# OVERLAPS #-} PathPiece (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
+ fromPathPiece (Text.unpack -> piece) = do
+ piece' <- (stripPrefix `on` map CI.mk) "uww" piece
+ return . CryptoID . CI.mk $ map CI.original piece'
+ toPathPiece = Text.pack . ("uww" <>) . CI.foldedCase . ciphertext
+
+instance {-# OVERLAPS #-} ToJSON (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
+ toJSON = String . toPathPiece
+instance {-# OVERLAPS #-} ToJSONKey (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
+ toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
+instance {-# OVERLAPS #-} FromJSON (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
+ parseJSON = withText "CryptoFileNameWorkflowWorkflow" $ maybe (fail "Could not parse CryptoFileNameWorkflowWorkflow") return . fromPathPiece
+instance {-# OVERLAPS #-} FromJSONKey (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
+ fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameWorkflowWorkflow") return . fromPathPiece
+instance {-# OVERLAPS #-} ToMarkup (E.CryptoID "WorkflowWorkflow" (CI FilePath)) where
+ toMarkup = toMarkup . toPathPiece
diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs
index 9b7b211bd..11a683a80 100644
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@@ -1323,6 +1323,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate AuthAuthentication r
+tagAccessPredicate AuthWorkflow = APHandler $ \_ route _ -> $unsupportedAuthPredicate AuthWorkflow route
tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do
MsgRenderer mr <- ask
return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite
diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs
index 1cfe8c49e..c70fe827f 100644
--- a/src/Foundation/I18n.hs
+++ b/src/Foundation/I18n.hs
@@ -226,7 +226,7 @@ embedRenderMessage ''UniWorX ''ExamOnlinePreset id
embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id
embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
embedRenderMessage ''UniWorX ''ChangelogItemKind id
-embedRenderMessage ''UniWorX ''WorkflowInstanceScope' $ ("WorkflowInstanceScopeKind" <>) . concat . drop 1 . splitCamel . fromMaybe (error "Expected WorkflowInstanceScope' to have '") . stripSuffix "'"
+embedRenderMessage ''UniWorX ''WorkflowScope' $ ("WorkflowScopeKind" <>) . concat . drop 1 . splitCamel . fromMaybe (error "Expected WorkflowScope' to have '") . stripSuffix "'"
embedRenderMessage ''UniWorX ''AuthenticationMode id
@@ -400,6 +400,17 @@ instance RenderMessage UniWorX ShortWeekDay where
embedRenderMessage ''UniWorX ''ButtonSubmit id
+instance RenderMessage UniWorX (WorkflowScope TermIdentifier SchoolShorthand (TermId, SchoolId, CourseShorthand)) where
+ renderMessage foundation ls = \case
+ WSGlobal -> mr MsgWorkflowScopeGlobal
+ WSTerm{..} -> mr $ ShortTermIdentifier wisTerm
+ WSSchool{..} -> mr wisSchool
+ WSTermSchool{..} -> mr $ MsgWorkflowScopeTermSchool (TermKey wisTerm) (SchoolKey wisSchool)
+ WSCourse{ wisCourse = (tid, ssh, csh) } -> mr $ MsgWorkflowScopeCourse tid ssh csh
+ where
+ mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
+ mr = renderMessage foundation ls
+
unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
unRenderMessage' cmp foundation inp = nub $ do
diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs
index 7b89706b9..01ea9a541 100644
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@@ -338,6 +338,28 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
MsgRenderer mr <- getMsgRenderer
i18nCrumb (MsgBreadcrumbAdminWorkflowDefinitionEdit (mr wfdScope) wfdName) $ Just AdminWorkflowDefinitionListR
AWDDeleteR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionDelete . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR
+ AWDInstantiateR -> i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionInstantiate . Just $ AdminWorkflowDefinitionR wfdScope wfdName AWDEditR
+ breadcrumb AdminWorkflowInstanceListR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceList $ Just AdminWorkflowDefinitionListR
+ breadcrumb AdminWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbAdminWorkflowInstanceNew $ Just AdminWorkflowInstanceListR
+ breadcrumb AdminWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowList $ Just AdminWorkflowInstanceListR
+ breadcrumb AdminWorkflowWorkflowNewR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowNew $ Just AdminWorkflowWorkflowListR
+
+ breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbWorkflowInstanceList Nothing
+ breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR
+ breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
+ GWIEditR -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR
+ GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR
+ GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR
+ GWIInitiateR -> do
+ mayEdit <- hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR
+ i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if
+ | mayEdit -> GlobalWorkflowInstanceR win GWIEditR
+ | otherwise -> GlobalWorkflowInstanceListR
+ breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbGlobalWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR
+ breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of
+ GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowInstanceListR
+ GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
+ GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
data NavQuickView
@@ -748,6 +770,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
}
]
}
+ , return NavHeader
+ { navHeaderRole = NavHeaderPrimary
+ , navIcon = IconMenuWorkflows
+ , navLink = NavLink
+ { navLabel = MsgMenuGlobalWorkflowInstanceList
+ , navRoute = GlobalWorkflowInstanceListR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ }
]
pageActions :: ( MonadHandler m
@@ -2299,6 +2333,17 @@ pageActions AdminWorkflowDefinitionListR = return
}
, navChildren = []
}
+ , NavPageActionPrimary
+ { navLink = NavLink
+ { navLabel = MsgMenuAdminWorkflowInstanceList
+ , navRoute = AdminWorkflowInstanceListR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ , navChildren = []
+ }
]
pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return
[ NavPageActionSecondary
@@ -2311,6 +2356,99 @@ pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return
, navForceActive = False
}
}
+ , NavPageActionPrimary
+ { navLink = NavLink
+ { navLabel = MsgMenuAdminWorkflowDefinitionInstantiate
+ , navRoute = AdminWorkflowDefinitionR wds wdn AWDInstantiateR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = True }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ , navChildren = []
+ }
+ ]
+pageActions AdminWorkflowInstanceListR = return
+ [ NavPageActionPrimary
+ { navLink = NavLink
+ { navLabel = MsgMenuAdminWorkflowInstanceNew
+ , navRoute = AdminWorkflowInstanceNewR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ , navChildren = []
+ }
+ ]
+pageActions GlobalWorkflowInstanceListR = return
+ [ NavPageActionPrimary
+ { navLink = NavLink
+ { navLabel = MsgMenuGlobalWorkflowWorkflowList
+ , navRoute = GlobalWorkflowWorkflowListR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ , navChildren = []
+ }
+ ]
+pageActions (GlobalWorkflowInstanceR win GWIEditR) = return
+ [ NavPageActionSecondary
+ { navLink = NavLink
+ { navLabel = MsgMenuWorkflowInstanceDelete
+ , navRoute = GlobalWorkflowInstanceR win GWIDeleteR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ }
+ , NavPageActionPrimary
+ { navLink = NavLink
+ { navLabel = MsgMenuWorkflowInstanceWorkflows
+ , navRoute = GlobalWorkflowInstanceR win GWIWorkflowsR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ , navChildren = []
+ }
+ , NavPageActionPrimary
+ { navLink = NavLink
+ { navLabel = MsgMenuWorkflowInstanceInitiate
+ , navRoute = GlobalWorkflowInstanceR win GWIInitiateR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ , navChildren = []
+ }
+ ]
+pageActions (GlobalWorkflowWorkflowR cID GWWWorkflowR) = return
+ [ NavPageActionSecondary
+ { navLink = NavLink
+ { navLabel = MsgMenuWorkflowWorkflowEdit
+ , navRoute = GlobalWorkflowWorkflowR cID GWWEditR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ }
+ , NavPageActionSecondary
+ { navLink = NavLink
+ { navLabel = MsgMenuWorkflowWorkflowDelete
+ , navRoute = GlobalWorkflowWorkflowR cID GWWDeleteR
+ , navAccess' = return True
+ , navType = NavTypeLink { navModal = False }
+ , navQuick' = mempty
+ , navForceActive = False
+ }
+ }
]
pageActions _ = return []
diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs
index 081569d77..096f909c9 100644
--- a/src/Foundation/Routes.hs
+++ b/src/Foundation/Routes.hs
@@ -39,6 +39,8 @@ deriving instance Generic ExamOfficeR
deriving instance Generic CourseNewsR
deriving instance Generic CourseEventR
deriving instance Generic AdminWorkflowDefinitionR
+deriving instance Generic GlobalWorkflowInstanceR
+deriving instance Generic GlobalWorkflowWorkflowR
deriving instance Generic (Route UniWorX)
data RouteChildren
diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs
index 1a7183602..6f9b679c7 100644
--- a/src/Foundation/Yesod/Middleware.hs
+++ b/src/Foundation/Yesod/Middleware.hs
@@ -147,6 +147,8 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
, ncTutorial
, ncExam
, ncExternalExam
+ , ncAdminWorkflowDefinition
+ , ncGlobalWorkflowInstance
, verifySubmission
, verifyCourseApplication
, verifyCourseNews
@@ -223,6 +225,18 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
return $ route
& typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
& typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
+ ncAdminWorkflowDefinition = maybeOrig $ \route -> do
+ AdminWorkflowDefinitionR wds wdn _ <- return route
+ Entity _ WorkflowDefinition{..} <- MaybeT . $cachedHereBinary (wds, wdn) . lift . getBy $ UniqueWorkflowDefinition wdn wds
+ caseChanged wdn workflowDefinitionName
+ return $ route
+ & typesUsing @RouteChildren @WorkflowDefinitionName . filtered (== wdn) .~ workflowDefinitionName
+ ncGlobalWorkflowInstance = maybeOrig $ \route -> do
+ GlobalWorkflowInstanceR wdn _ <- return route
+ Entity _ WorkflowInstance{..} <- MaybeT . $cachedHereBinary wdn . lift . getBy $ UniqueWorkflowInstance wdn WSGlobal
+ caseChanged wdn workflowInstanceName
+ return $ route
+ & typesUsing @RouteChildren @WorkflowInstanceName . filtered (== wdn) .~ workflowInstanceName
verifySubmission = maybeOrig $ \route -> do
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
sId <- $cachedHereBinary cID $ decrypt cID
@@ -248,3 +262,5 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
tell . Any $ route /= newRoute
return newRoute
+
+ -- TODO: verify*WorkflowWorkflow
diff --git a/src/Handler/Utils/Workflow/Form.hs b/src/Handler/Utils/Workflow/Form.hs
new file mode 100644
index 000000000..637b5a865
--- /dev/null
+++ b/src/Handler/Utils/Workflow/Form.hs
@@ -0,0 +1,143 @@
+module Handler.Utils.Workflow.Form
+ ( FileIdent
+ , WorkflowGraphForm(..)
+ , workflowGraphForm
+ , toWorkflowGraphForm, fromWorkflowGraphForm
+ , WorkflowDescriptionsFormScope(..)
+ , workflowDescriptionsForm
+ ) where
+
+import Import
+import Utils.Form
+
+import Handler.Utils.Form
+
+import qualified Data.Conduit.Combinators as C
+
+import qualified Data.Map as Map
+import Data.Map ((!))
+import qualified Data.Set as Set
+import qualified Data.CaseInsensitive as CI
+
+import Data.Bimap (Bimap)
+import qualified Data.Bimap as Bimap
+
+import qualified Control.Monad.State.Class as State
+
+import qualified Data.List.NonEmpty as NonEmpty
+
+
+newtype FileIdent = FileIdent (CI Text)
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving newtype (ToMessage, ToJSON, FromJSON)
+
+makeWrapped ''FileIdent
+
+data WorkflowGraphForm = WorkflowGraphForm
+ { wgfGraph :: WorkflowGraph FileIdent CryptoUUIDUser
+ , wgfFiles :: Map FileIdent FileReference
+ } deriving (Generic, Typeable)
+
+makeLenses_ ''WorkflowGraphForm
+
+
+workflowGraphForm :: Maybe WorkflowGraphForm -> AForm DB WorkflowGraphForm
+workflowGraphForm template = validateAForm validateWorkflowGraphForm . hoistAForm lift $ WorkflowGraphForm
+ <$> areq yamlField (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
+ <*> filesForm
+ where
+ filesForm = Map.fromList <$> massInputAccumEditA fileAdd fileEdit (const Nothing) fileLayout ("workflow-definition-files" :: Text) (fslI MsgWorkflowDefinitionFiles) False (Map.toList . wgfFiles <$> template)
+ where fileAdd nudge submitView csrf = do
+ (formRes, formView) <- fileForm nudge Nothing csrf
+ MsgRenderer mr <- getMsgRenderer
+ let res' = formRes <&> \newFile@(newFileIdent, _) oldFiles -> if
+ | any (\(oldFileIdent, _) -> newFileIdent == oldFileIdent) oldFiles
+ -> FormFailure [mr MsgWorkflowDefinitionFileIdentExists]
+ | otherwise
+ -> FormSuccess $ pure newFile
+ return (res', $(widgetFile "widgets/massinput/workflowDefinitionFiles/add"))
+ fileEdit nudge = fileForm nudge . Just
+ fileForm :: (Text -> Text) -> Maybe (FileIdent, FileReference) -> Form (FileIdent, FileReference)
+ fileForm nudge fileTemplate csrf = do
+ (fileIdentRes, fileIdentView) <- mpreq (isoField _Unwrapped ciField) (fslI MsgWorkflowDefinitionFileIdent & addName (nudge "ident")) (view _1 <$> fileTemplate)
+ (fileRes, fileView) <- mpreq (singleFileField . fromMaybe (return ()) $ views _2 yield <$> fileTemplate) (fslI MsgWorkflowDefinitionFile & addName (nudge "file")) (views _2 yield <$> fileTemplate)
+ fileRes' <- liftHandler . runDB $ case fileRes of
+ FormSuccess uploads -> maybe FormMissing FormSuccess <$> runConduit (transPipe liftHandler uploads .| C.head)
+ FormFailure errs -> return $ FormFailure errs
+ FormMissing -> return FormMissing
+ return ((,) <$> fileIdentRes <*> fileRes', $(widgetFile "widgets/massinput/workflowDefinitionFiles/form"))
+ fileLayout :: MassInputLayout ListLength (FileIdent, FileReference) (FileIdent, FileReference)
+ fileLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDefinitionFiles/layout")
+
+validateWorkflowGraphForm :: FormValidator WorkflowGraphForm DB ()
+validateWorkflowGraphForm = do
+ fIdentsReferenced <- uses _wgfGraph . setOf $ typesCustom @WorkflowChildren
+ fIdentsAvailable <- uses _wgfFiles Map.keysSet
+ forM_ (fIdentsReferenced `Set.difference` fIdentsAvailable) $ tellValidationError . MsgWorkflowFileIdentDoesNotExist . views _Wrapped CI.original
+
+toWorkflowGraphForm :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ )
+ => WorkflowGraph FileReference SqlBackendKey
+ -> m WorkflowGraphForm
+toWorkflowGraphForm g = liftHandler . fmap (uncurry WorkflowGraphForm . over _2 Bimap.toMap) . (runStateT ?? Bimap.empty) . ($ g)
+ $ traverseOf (typesCustom @WorkflowChildren) recordFile
+ >=> traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileIdent SqlBackendKey) @_ @_ @CryptoUUIDUser) (encrypt . review (_SqlKey @User))
+ where
+ recordFile :: forall m. Monad m => FileReference -> StateT (Bimap FileIdent FileReference) m FileIdent
+ recordFile fRef@FileReference{..} = do
+ prev <- State.gets $ Bimap.lookupR fRef
+ case prev of
+ Just fIdent -> return fIdent
+ Nothing -> do
+ cMap <- State.get
+ let candidateIdents = map (review _Wrapped . CI.mk) $
+ map pack $ fileReferenceTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fileReferenceTitle ]
+ fIdent = case filter (`Bimap.notMember` cMap) candidateIdents of
+ fIdent' : _ -> fIdent'
+ [] -> error "candidateIdents should be infinite; cMap should be finite"
+ State.modify $ Bimap.insert fIdent fRef
+ return fIdent
+
+fromWorkflowGraphForm :: (MonadHandler m, HandlerSite m ~ UniWorX)
+ => WorkflowGraphForm
+ -> m (WorkflowGraph FileReference SqlBackendKey)
+fromWorkflowGraphForm WorkflowGraphForm{..}
+ = liftHandler $ wgfGraph
+ & over (typesCustom @WorkflowChildren) (wgfFiles !)
+ & traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
+
+
+data WorkflowDescriptionsFormScope
+ = WorkflowDescriptionsFormDefinition
+ | WorkflowDescriptionsFormInstance
+ deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
+ deriving (Universe, Finite)
+
+workflowDescriptionsForm :: WorkflowDescriptionsFormScope -> Maybe (Map Lang (Text, Maybe Html)) -> AForm Handler (Map Lang (Text, Maybe Html))
+workflowDescriptionsForm scope template = Map.fromList <$> massInputAccumEditA descrAdd descrEdit (const Nothing) descrLayout ("workflow-descriptions" :: Text) (fslI msgWorkflowDescriptions) False (Map.toList <$> template)
+ where
+ descrAdd nudge submitView csrf = do
+ (formRes, formView) <- descrForm nudge Nothing csrf
+ MsgRenderer mr <- getMsgRenderer
+ let res' = formRes <&> \newDescr@(newLang, _) oldDescrs -> if
+ | any (\(oldLang, _) -> newLang == oldLang) oldDescrs
+ -> FormFailure [mr msgWorkflowDescriptionsLanguageExists]
+ | otherwise
+ -> FormSuccess $ pure newDescr
+ return (res', $(widgetFile "widgets/massinput/workflowDescriptions/add"))
+ descrEdit nudge = descrForm nudge . Just
+ descrForm :: (Text -> Text) -> Maybe (Lang, (Text, Maybe Html)) -> Form (Lang, (Text, Maybe Html))
+ descrForm nudge descrTemplate csrf = do
+ (langRes, langView) <- mpreq (langField False) (fslI MsgWorkflowDescriptionLanguage & addName (nudge "lang")) (fmap (view _1) descrTemplate <|> Just (NonEmpty.head appLanguages))
+ (titleRes, titleView) <- mpreq textField (fslI MsgWorkflowDescriptionTitle & addName (nudge "title")) (view (_2 . _1) <$> descrTemplate)
+ (descrRes, descrView) <- mopt htmlField (fslI MsgWorkflowDescription & addName (nudge "descr")) (view (_2 . _2) <$> descrTemplate)
+ return ((,) <$> langRes <*> ((,) <$> titleRes <*> descrRes), $(widgetFile "widgets/massinput/workflowDescriptions/form"))
+ descrLayout :: MassInputLayout ListLength (Lang, (Text, Maybe Html)) (Lang, (Text, Maybe Html))
+ descrLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDescriptions/layout")
+
+ msgWorkflowDescriptions = case scope of
+ WorkflowDescriptionsFormDefinition -> MsgWorkflowDefinitionDescriptions
+ WorkflowDescriptionsFormInstance -> MsgWorkflowInstanceDescriptions
+ msgWorkflowDescriptionsLanguageExists = case scope of
+ WorkflowDescriptionsFormDefinition -> MsgWorkflowDefinitionDescriptionsLanguageExists
+ WorkflowDescriptionsFormInstance -> MsgWorkflowInstanceDescriptionsLanguageExists
diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs
new file mode 100644
index 000000000..081078001
--- /dev/null
+++ b/src/Handler/Utils/Workflow/Workflow.hs
@@ -0,0 +1,17 @@
+module Handler.Utils.Workflow.Workflow
+ ( ensureScope
+ ) where
+
+import Import
+
+
+ensureScope :: WorkflowScope TermId SchoolId CourseId -> CryptoFileNameWorkflowWorkflow -> MaybeT DB WorkflowWorkflowId
+ensureScope wiScope cID = do
+ wId <- catchMaybeT (Proxy @CryptoIDError) $ decrypt cID
+ WorkflowWorkflow{..} <- MaybeT $ get wId
+ let wiScope' = wiScope
+ & _wisTerm %~ unTermKey
+ & _wisSchool %~ unSchoolKey
+ & _wisCourse %~ view _SqlKey
+ guard $ workflowWorkflowScope == wiScope'
+ return wId
diff --git a/src/Handler/Workflow.hs b/src/Handler/Workflow.hs
index fcf64fb1d..16c668802 100644
--- a/src/Handler/Workflow.hs
+++ b/src/Handler/Workflow.hs
@@ -3,3 +3,5 @@ module Handler.Workflow
) where
import Handler.Workflow.Definition as Handler.Workflow
+import Handler.Workflow.Instance as Handler.Workflow
+import Handler.Workflow.Workflow as Handler.Workflow
diff --git a/src/Handler/Workflow/Definition.hs b/src/Handler/Workflow/Definition.hs
index f9e22acc3..5c5038b14 100644
--- a/src/Handler/Workflow/Definition.hs
+++ b/src/Handler/Workflow/Definition.hs
@@ -6,3 +6,4 @@ import Handler.Workflow.Definition.List as Handler.Workflow.Definition
import Handler.Workflow.Definition.New as Handler.Workflow.Definition
import Handler.Workflow.Definition.Edit as Handler.Workflow.Definition
import Handler.Workflow.Definition.Delete as Handler.Workflow.Definition
+import Handler.Workflow.Definition.Instantiate as Handler.Workflow.Definition
diff --git a/src/Handler/Workflow/Definition/Delete.hs b/src/Handler/Workflow/Definition/Delete.hs
index 616c8e06c..73c84cfa0 100644
--- a/src/Handler/Workflow/Definition/Delete.hs
+++ b/src/Handler/Workflow/Definition/Delete.hs
@@ -11,7 +11,7 @@ import qualified Database.Esqueleto as E
import qualified Data.Set as Set
-getAWDDeleteR, postAWDDeleteR :: WorkflowInstanceScope' -> WorkflowDefinitionName -> Handler Html
+getAWDDeleteR, postAWDDeleteR :: WorkflowScope' -> WorkflowDefinitionName -> Handler Html
getAWDDeleteR = postAWDDeleteR
postAWDDeleteR wds' wdn = do
wdId <- runDB . getKeyBy404 $ UniqueWorkflowDefinition wdn wds'
diff --git a/src/Handler/Workflow/Definition/Edit.hs b/src/Handler/Workflow/Definition/Edit.hs
index 91018416a..1f7dbf8cc 100644
--- a/src/Handler/Workflow/Definition/Edit.hs
+++ b/src/Handler/Workflow/Definition/Edit.hs
@@ -9,17 +9,9 @@ import Handler.Utils
import Handler.Workflow.Definition.Form
import qualified Data.Map as Map
-import Data.Map.Strict ((!))
-
-import Data.Bimap (Bimap)
-import qualified Data.Bimap as Bimap
-
-import qualified Control.Monad.State.Class as State
-
-import qualified Data.CaseInsensitive as CI
-getAWDEditR, postAWDEditR :: WorkflowInstanceScope' -> WorkflowDefinitionName -> Handler Html
+getAWDEditR, postAWDEditR :: WorkflowScope' -> WorkflowDefinitionName -> Handler Html
getAWDEditR = postAWDEditR
postAWDEditR wds' wdn = do
(((_, editForm), editEncoding), act) <- runDB $ do
@@ -30,45 +22,34 @@ postAWDEditR wds' wdn = do
[ (workflowDefinitionDescriptionLanguage, (workflowDefinitionDescriptionTitle, workflowDefinitionDescriptionDescription))
| Entity _ WorkflowDefinitionDescription{..} <- descs
]
+
+ iDescs <- selectList [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId] []
+ let wdfInstanceDescriptions = Map.fromList
+ [ (workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))
+ | Entity _ WorkflowDefinitionInstanceDescription{..} <- iDescs
+ ]
- let recordFile :: forall m. Monad m => FileReference -> StateT (Bimap FileIdent FileReference) m FileIdent
- recordFile fRef@FileReference{..} = do
- prev <- State.gets $ Bimap.lookupR fRef
- case prev of
- Just fIdent -> return fIdent
- Nothing -> do
- cMap <- State.get
- let candidateIdents = map (review _Wrapped . CI.mk) $
- map pack $ fileReferenceTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fileReferenceTitle ]
- fIdent = case filter (`Bimap.notMember` cMap) candidateIdents of
- fIdent' : _ -> fIdent'
- [] -> error "candidateIdents should be infinite; cMap should be finite"
- State.modify $ Bimap.insert fIdent fRef
- return fIdent
-
- (wdfGraph, Bimap.toMap -> wdfFiles) <- (runStateT ?? Bimap.empty) . ($ workflowDefinitionGraph)
- $ traverseOf (typesCustom @WorkflowChildren) recordFile
- >=> traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileIdent SqlBackendKey) @_ @_ @CryptoUUIDUser) (encrypt . review (_SqlKey @User))
+ wdfGraph <- toWorkflowGraphForm workflowDefinitionGraph
return WorkflowDefinitionForm
{ wdfScope = workflowDefinitionScope
, wdfName = workflowDefinitionName
+ , wdfInstanceCategory = workflowDefinitionInstanceCategory
, wdfDescriptions
+ , wdfInstanceDescriptions
, wdfGraph
- , wdfFiles
}
form@((editRes, _), _) <- runFormPost . workflowDefinitionForm $ Just template
act <- formResultMaybe editRes $ \WorkflowDefinitionForm{..} -> do
- wdfGraph' <- wdfGraph
- & over (typesCustom @WorkflowChildren) (wdfFiles !)
- & traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
+ wdfGraph' <- fromWorkflowGraphForm wdfGraph
insConflict <- replaceUnique wdId WorkflowDefinition
{ workflowDefinitionGraph = wdfGraph'
, workflowDefinitionScope = wdfScope
, workflowDefinitionName = wdfName
+ , workflowDefinitionInstanceCategory = wdfInstanceCategory
}
when (is _Nothing insConflict) . iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) -> do
@@ -79,6 +60,14 @@ postAWDEditR wds' wdn = do
, workflowDefinitionDescriptionTitle = wddTitle
, workflowDefinitionDescriptionDescription = wddDesc
}
+ when (is _Nothing insConflict) . iforM_ wdfInstanceDescriptions $ \wddLang (wddTitle, wddDesc) -> do
+ deleteWhere [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId]
+ insert WorkflowDefinitionInstanceDescription
+ { workflowDefinitionInstanceDescriptionDefinition = wdId
+ , workflowDefinitionInstanceDescriptionLanguage = wddLang
+ , workflowDefinitionInstanceDescriptionTitle = wddTitle
+ , workflowDefinitionInstanceDescriptionDescription = wddDesc
+ }
case insConflict of
Just (UniqueWorkflowDefinition wdn' wds'') -> return . Just $
diff --git a/src/Handler/Workflow/Definition/Form.hs b/src/Handler/Workflow/Definition/Form.hs
index 75385a5a0..bbdb331ce 100644
--- a/src/Handler/Workflow/Definition/Form.hs
+++ b/src/Handler/Workflow/Definition/Form.hs
@@ -1,103 +1,43 @@
module Handler.Workflow.Definition.Form
- ( WorkflowDefinitionForm(..), FileIdent
+ ( WorkflowDefinitionForm(..)
, workflowDefinitionForm
+ , module Handler.Utils.Workflow.Form
) where
import Import
import Handler.Utils
-import qualified Data.List.NonEmpty as NonEmpty
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Map ((!))
+import Handler.Utils.Workflow.Form
import qualified Data.CryptoID as C
-import qualified Data.CaseInsensitive as CI
-
-import qualified Data.Conduit.Combinators as C
-
-
-newtype FileIdent = FileIdent (CI Text)
- deriving (Eq, Ord, Read, Show, Generic, Typeable)
- deriving newtype (ToMessage, ToJSON, FromJSON)
-
-makeWrapped ''FileIdent
-
data WorkflowDefinitionForm = WorkflowDefinitionForm
- { wdfScope :: WorkflowInstanceScope'
- , wdfName :: CI Text
+ { wdfScope :: WorkflowScope'
+ , wdfName :: WorkflowDefinitionName
+ , wdfInstanceCategory :: Maybe WorkflowInstanceCategory
, wdfDescriptions :: Map Lang (Text, Maybe Html)
- , wdfGraph :: WorkflowGraph FileIdent CryptoUUIDUser
- , wdfFiles :: Map FileIdent FileReference
+ , wdfInstanceDescriptions :: Map Lang (Text, Maybe Html)
+ , wdfGraph :: WorkflowGraphForm
} deriving (Generic, Typeable)
makeLenses_ ''WorkflowDefinitionForm
workflowDefinitionForm :: Maybe WorkflowDefinitionForm -> Html -> MForm DB (FormResult WorkflowDefinitionForm, Widget)
-workflowDefinitionForm template = validateForm validateWorkflowDefinitionForm . (hoist lift .) . renderAForm FormStandard $ WorkflowDefinitionForm
- <$> apopt (selectField optionsFinite) (fslI MsgWorkflowDefinitionScope) (wdfScope <$> template)
+workflowDefinitionForm template = validateForm validateWorkflowDefinitionForm . renderAForm FormStandard $ WorkflowDefinitionForm
+ <$> apopt (hoistField lift $ selectField optionsFinite) (fslI MsgWorkflowDefinitionScope) (wdfScope <$> template)
<*> areq ciField (fslI MsgWorkflowDefinitionName) (wdfName <$> template)
- <*> descriptionsForm
- <*> areq yamlField (fslI MsgWorkflowDefinitionGraph) (wdfGraph <$> template)
- <*> filesForm
- where
- descriptionsForm = Map.fromList <$> massInputAccumEditA descrAdd descrEdit (const Nothing) descrLayout ("workflow-definition-descriptions" :: Text) (fslI MsgWorkflowDefinitionDescriptions) False (Map.toList . wdfDescriptions <$> template)
- where descrAdd nudge submitView csrf = do
- (formRes, formView) <- descrForm nudge Nothing csrf
- MsgRenderer mr <- getMsgRenderer
- let res' = formRes <&> \newDescr@(newLang, _) oldDescrs -> if
- | any (\(oldLang, _) -> newLang == oldLang) oldDescrs
- -> FormFailure [mr MsgWorkflowDefinitionDescriptionsLanguageExists]
- | otherwise
- -> FormSuccess $ pure newDescr
- return (res', $(widgetFile "widgets/massinput/workflowDefinitionDescriptions/add"))
- descrEdit nudge = descrForm nudge . Just
- descrForm :: (Text -> Text) -> Maybe (Lang, (Text, Maybe Html)) -> Form (Lang, (Text, Maybe Html))
- descrForm nudge descrTemplate csrf = do
- (langRes, langView) <- mpreq (langField False) (fslI MsgWorkflowDefinitionDescriptionLanguage & addName (nudge "lang")) (fmap (view _1) descrTemplate <|> Just (NonEmpty.head appLanguages))
- (titleRes, titleView) <- mpreq textField (fslI MsgWorkflowDefinitionDescriptionTitle & addName (nudge "title")) (view (_2 . _1) <$> descrTemplate)
- (descrRes, descrView) <- mopt htmlField (fslI MsgWorkflowDefinitionDescription & addName (nudge "descr")) (view (_2 . _2) <$> descrTemplate)
- return ((,) <$> langRes <*> ((,) <$> titleRes <*> descrRes), $(widgetFile "widgets/massinput/workflowDefinitionDescriptions/form"))
- descrLayout :: MassInputLayout ListLength (Lang, (Text, Maybe Html)) (Lang, (Text, Maybe Html))
- descrLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDefinitionDescriptions/layout")
-
- filesForm = Map.fromList <$> massInputAccumEditA fileAdd fileEdit (const Nothing) fileLayout ("workflow-definition-files" :: Text) (fslI MsgWorkflowDefinitionFiles) False (Map.toList . wdfFiles <$> template)
- where fileAdd nudge submitView csrf = do
- (formRes, formView) <- fileForm nudge Nothing csrf
- MsgRenderer mr <- getMsgRenderer
- let res' = formRes <&> \newFile@(newFileIdent, _) oldFiles -> if
- | any (\(oldFileIdent, _) -> newFileIdent == oldFileIdent) oldFiles
- -> FormFailure [mr MsgWorkflowDefinitionFileIdentExists]
- | otherwise
- -> FormSuccess $ pure newFile
- return (res', $(widgetFile "widgets/massinput/workflowDefinitionFiles/add"))
- fileEdit nudge = fileForm nudge . Just
- fileForm :: (Text -> Text) -> Maybe (FileIdent, FileReference) -> Form (FileIdent, FileReference)
- fileForm nudge fileTemplate csrf = do
- (fileIdentRes, fileIdentView) <- mpreq (isoField _Unwrapped ciField) (fslI MsgWorkflowDefinitionFileIdent & addName (nudge "ident")) (view _1 <$> fileTemplate)
- (fileRes, fileView) <- mpreq (singleFileField . fromMaybe (return ()) $ views _2 yield <$> fileTemplate) (fslI MsgWorkflowDefinitionFile & addName (nudge "file")) (views _2 yield <$> fileTemplate)
- fileRes' <- liftHandler . runDB $ case fileRes of
- FormSuccess uploads -> maybe FormMissing FormSuccess <$> runConduit (transPipe liftHandler uploads .| C.head)
- FormFailure errs -> return $ FormFailure errs
- FormMissing -> return FormMissing
- return ((,) <$> fileIdentRes <*> fileRes', $(widgetFile "widgets/massinput/workflowDefinitionFiles/form"))
- fileLayout :: MassInputLayout ListLength (FileIdent, FileReference) (FileIdent, FileReference)
- fileLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDefinitionFiles/layout")
-
-
+ <*> aopt ciField (fslI MsgWorkflowDefinitionInstanceCategory) (wdfInstanceCategory <$> template)
+ <*> hoistAForm lift (workflowDescriptionsForm WorkflowDescriptionsFormDefinition $ wdfDescriptions <$> template)
+ <*> hoistAForm lift (workflowDescriptionsForm WorkflowDescriptionsFormInstance $ wdfInstanceDescriptions <$> template)
+ <*> workflowGraphForm (wdfGraph <$> template)
validateWorkflowDefinitionForm :: FormValidator WorkflowDefinitionForm DB ()
validateWorkflowDefinitionForm = do
join . uses _wdfGraph . mapMOf_ (typesCustom @WorkflowChildren) . ensureExists $ Proxy @User
- fIdentsReferenced <- uses _wdfGraph . setOf $ typesCustom @WorkflowChildren
- fIdentsAvailable <- uses _wdfFiles Map.keysSet
- forM_ (fIdentsReferenced `Set.difference` fIdentsAvailable) $ tellValidationError . MsgWorkflowDefinitionFileIdentDoesNotExist . views _Wrapped CI.original
where
ensureExists :: forall record ns p r. _ => p record -> C.CryptoID ns UUID -> FormValidator r DB ()
- ensureExists _ cID = maybeT (tellValidationError . MsgWorkflowDefinitionFileIdentDoesNotExist $ toPathPiece cID) . catchMPlus (Proxy @CryptoIDError) $ do
+ ensureExists _ cID = maybeT (tellValidationError . MsgWorkflowUserDoesNotExist $ toPathPiece cID) . catchMPlus (Proxy @CryptoIDError) $ do
$logDebugS "validateWorkflowDefinitionForm" $ "Checking key for existence: " <> toPathPiece cID
key <- decrypt cID
guardM . lift . lift $ existsKey (key :: Key record)
diff --git a/src/Handler/Workflow/Definition/Instantiate.hs b/src/Handler/Workflow/Definition/Instantiate.hs
new file mode 100644
index 000000000..4f0773167
--- /dev/null
+++ b/src/Handler/Workflow/Definition/Instantiate.hs
@@ -0,0 +1,59 @@
+module Handler.Workflow.Definition.Instantiate
+ ( getAWDInstantiateR, postAWDInstantiateR
+ ) where
+
+import Import
+import Handler.Utils
+import Handler.Utils.Workflow.Form
+
+import Handler.Workflow.Instance.Form
+
+
+getAWDInstantiateR, postAWDInstantiateR :: WorkflowScope' -> WorkflowDefinitionName -> Handler Html
+getAWDInstantiateR = postAWDInstantiateR
+postAWDInstantiateR wds' wdn = do
+ (((_, instForm), instEncoding), act) <- runDB $ do
+ wdId <- getKeyBy404 $ UniqueWorkflowDefinition wdn wds'
+ form@((instRes, _), _) <- runFormPost $ workflowInstanceForm (Just wdId) Nothing
+
+ act <- formResultMaybe instRes $ \WorkflowInstanceForm{..} -> do
+ wifGraph' <- fromWorkflowGraphForm wifGraph
+ let wifScope' = wifScope
+ & over _wisTerm unTermKey
+ & over _wisSchool unSchoolKey
+ & over _wisCourse (view _SqlKey)
+ instId <- insertUnique WorkflowInstance
+ { workflowInstanceDefinition = Just wdId
+ , workflowInstanceGraph = wifGraph'
+ , workflowInstanceScope = wifScope'
+ , workflowInstanceName = wifName
+ , workflowInstanceCategory = wifCategory
+ }
+
+ for_ instId $ \instId' -> iforM_ wifDescriptions $ \widLang (widTitle, widDesc) ->
+ insert WorkflowInstanceDescription
+ { workflowInstanceDescriptionInstance = instId'
+ , workflowInstanceDescriptionLanguage = widLang
+ , workflowInstanceDescriptionTitle = widTitle
+ , workflowInstanceDescriptionDescription = widDesc
+ }
+
+ return . Just $ case instId of
+ Nothing -> addMessageI Error MsgWorkflowInstanceCollision
+ Just _ -> do
+ addMessageI Success MsgWorkflowDefinitionInstantiated
+ redirect AdminWorkflowInstanceListR
+
+ return (form, act)
+
+ forM_ act id
+
+ let instWidget = wrapForm instForm def
+ { formAction = Just . SomeRoute $ AdminWorkflowDefinitionR wds' wdn AWDInstantiateR
+ , formEncoding = instEncoding
+ }
+
+ siteLayoutMsg MsgWorkflowDefinitionInstantiateTitle $ do
+ setTitleI MsgWorkflowDefinitionInstantiateTitle
+
+ instWidget
diff --git a/src/Handler/Workflow/Definition/List.hs b/src/Handler/Workflow/Definition/List.hs
index 5d2ced19b..ae0eeae10 100644
--- a/src/Handler/Workflow/Definition/List.hs
+++ b/src/Handler/Workflow/Definition/List.hs
@@ -1,7 +1,7 @@
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Workflow.Definition.List
- ( getAdminWorkflowDefinitionListR, postAdminWorkflowDefinitionListR
+ ( getAdminWorkflowDefinitionListR
) where
import Import
@@ -35,6 +35,7 @@ queryWorkflowCount = to $ \(view queryWorkflowDefinition -> workflowDefinition)
type WorkflowDefinitionData = DBRow
( Entity WorkflowDefinition
, Maybe (Entity WorkflowDefinitionDescription)
+ , Maybe (Entity WorkflowDefinitionInstanceDescription)
, Int64, Int64
)
@@ -43,15 +44,17 @@ resultDefinition = _dbrOutput . _1
resultDescription :: Traversal' WorkflowDefinitionData (Entity WorkflowDefinitionDescription)
resultDescription = _dbrOutput . _2 . _Just
+
+resultInstanceDescription :: Traversal' WorkflowDefinitionData (Entity WorkflowDefinitionInstanceDescription)
+resultInstanceDescription = _dbrOutput . _3 . _Just
resultWorkflowInstanceCount, resultWorkflowCount :: Lens' WorkflowDefinitionData Int64
-resultWorkflowInstanceCount = _dbrOutput . _3
-resultWorkflowCount = _dbrOutput . _4
+resultWorkflowInstanceCount = _dbrOutput . _4
+resultWorkflowCount = _dbrOutput . _5
-getAdminWorkflowDefinitionListR, postAdminWorkflowDefinitionListR :: Handler Html
-getAdminWorkflowDefinitionListR = postAdminWorkflowDefinitionListR
-postAdminWorkflowDefinitionListR = do
+getAdminWorkflowDefinitionListR :: Handler Html
+getAdminWorkflowDefinitionListR = do
definitionsTable <- runDB $
let
workflowDefinitionsDBTable = DBTable{..}
@@ -70,17 +73,24 @@ postAdminWorkflowDefinitionListR = do
return $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionLanguage
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
desc <- lift . fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowDefinitionDescription wdId descLang'
- (wd, desc,,)
+ idescLangs <- lift . E.select . E.from $ \workflowDefinitionInstanceDescription -> do
+ E.where_ $ workflowDefinitionInstanceDescription E.^. WorkflowDefinitionInstanceDescriptionDefinition E.==. E.val wdId
+ return $ workflowDefinitionInstanceDescription E.^. WorkflowDefinitionInstanceDescriptionLanguage
+ idescLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> idescLangs
+ idesc <- lift . fmap join . for idescLang $ \idescLang' -> getBy $ UniqueWorkflowDefinitionInstanceDescription wdId idescLang'
+ (wd, desc, idesc,,)
<$> view (_2 . _Value)
<*> view (_3 . _Value)
dbtColonnade :: Colonnade Sortable WorkflowDefinitionData _
dbtColonnade = mconcat
[ sortable (Just "name") (i18nCell MsgWorkflowDefinitionName) . anchorEdit $ views (resultDefinition . _entityVal . _workflowDefinitionName) i18n
, sortable (Just "scope") (i18nCell MsgWorkflowDefinitionScope) $ views (resultDefinition . _entityVal . _workflowDefinitionScope) i18nCell
- , sortable (Just "title") (i18nCell MsgWorkflowDefinitionDescriptionTitle) $ maybe mempty (anchorEdit . const . i18n) =<< preview (resultDescription . _entityVal . _workflowDefinitionDescriptionTitle)
+ , sortable (Just "title") (i18nCell MsgWorkflowDescriptionTitle) $ maybe mempty (anchorEdit . const . i18n) =<< preview (resultDescription . _entityVal . _workflowDefinitionDescriptionTitle)
, sortable (Just "instances") (i18nCell MsgWorkflowDefinitionInstanceCount) $ maybe mempty i18nCell . views resultWorkflowInstanceCount (assertM' (> 0))
, sortable (Just "workflows") (i18nCell MsgWorkflowDefinitionWorkflowCount) $ maybe mempty i18nCell . views resultWorkflowCount (assertM' (> 0))
- , sortable (Just "description") (i18nCell MsgWorkflowDefinitionDescription) $ maybe mempty modalCell . preview (resultDescription . _entityVal . _workflowDefinitionDescriptionDescription . _Just)
+ , sortable (Just "description") (i18nCell MsgWorkflowDescription) $ maybe mempty modalCell . preview (resultDescription . _entityVal . _workflowDefinitionDescriptionDescription . _Just)
+ , sortable (Just "instance-title") (i18nCell MsgWorkflowInstanceDescriptionTitle) $ maybe mempty (anchorEdit . const . i18n) =<< preview (resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle)
+ , sortable (Just "instance-description") (i18nCell MsgWorkflowInstanceDescription) $ maybe mempty modalCell . preview (resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionDescription . _Just)
, sortable Nothing (i18nCell MsgWorkflowDefinitionGraph) $ views (resultDefinition . _entityVal . _workflowDefinitionGraph) (modalCell . displayGraph)
]
where
@@ -98,6 +108,8 @@ postAdminWorkflowDefinitionListR = do
, singletonMap "scope" . SortColumn . views queryWorkflowDefinition $ E.orderByEnum . (E.^. WorkflowDefinitionScope)
, singletonMap "title" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle
, singletonMap "description" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowDefinitionDescriptionDescription
+ , singletonMap "instance-title" . SortProjected . comparing . view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle
+ , singletonMap "instance-description" . SortProjected . comparing . view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionDescription
, singletonMap "instances" . SortColumn $ view queryWorkflowInstanceCount
, singletonMap "workflows" . SortColumn $ view queryWorkflowCount
]
@@ -105,11 +117,13 @@ postAdminWorkflowDefinitionListR = do
[ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowDefinitionName)
, singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowDefinitionScope)
, singletonMap "title" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
+ , singletonMap "instance-title" . FilterProjected $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
]
dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowDefinitionName)
- , prismAForm (singletonFilter "scope" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) optionsFinite :: Field _ WorkflowInstanceScope') (fslI MsgWorkflowDefinitionScope)
- , prismAForm (singletonFilter "title") mPrev $ aopt textField (fslI MsgWorkflowDefinitionDescriptionTitle)
+ , prismAForm (singletonFilter "scope" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) optionsFinite :: Field _ WorkflowScope') (fslI MsgWorkflowDefinitionScope)
+ , prismAForm (singletonFilter "title") mPrev $ aopt textField (fslI MsgWorkflowDescriptionTitle)
+ , prismAForm (singletonFilter "instance-title") mPrev $ aopt textField (fslI MsgWorkflowInstanceDescriptionTitle)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
diff --git a/src/Handler/Workflow/Definition/New.hs b/src/Handler/Workflow/Definition/New.hs
index 41ee9a858..898c3b831 100644
--- a/src/Handler/Workflow/Definition/New.hs
+++ b/src/Handler/Workflow/Definition/New.hs
@@ -6,8 +6,6 @@ import Import
import Handler.Utils
import Handler.Workflow.Definition.Form
-import Data.Map.Strict ((!))
-
getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR :: Handler Html
getAdminWorkflowDefinitionNewR = postAdminWorkflowDefinitionNewR
@@ -15,15 +13,14 @@ postAdminWorkflowDefinitionNewR = do
(((_, newForm), newEncoding), act) <- runDB $ do
form@((newRes, _), _) <- runFormPost $ workflowDefinitionForm Nothing
- act <- formResultMaybe newRes $ \WorkflowDefinitionForm{..} -> do
- wdfGraph' <- wdfGraph
- & over (typesCustom @WorkflowChildren) (wdfFiles !)
- & traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
+ act <- formResultMaybe newRes $ \WorkflowDefinitionForm{ .. } -> do
+ wdfGraph' <- fromWorkflowGraphForm wdfGraph
insRes <- insertUnique WorkflowDefinition
{ workflowDefinitionGraph = wdfGraph'
, workflowDefinitionScope = wdfScope
, workflowDefinitionName = wdfName
+ , workflowDefinitionInstanceCategory = wdfInstanceCategory
}
for_ insRes $ \wdId -> iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) ->
@@ -33,6 +30,13 @@ postAdminWorkflowDefinitionNewR = do
, workflowDefinitionDescriptionTitle = wddTitle
, workflowDefinitionDescriptionDescription = wddDesc
}
+ for_ insRes $ \wdId -> iforM_ wdfInstanceDescriptions $ \wddLang (wddTitle, wddDesc) ->
+ insert WorkflowDefinitionInstanceDescription
+ { workflowDefinitionInstanceDescriptionDefinition = wdId
+ , workflowDefinitionInstanceDescriptionLanguage = wddLang
+ , workflowDefinitionInstanceDescriptionTitle = wddTitle
+ , workflowDefinitionInstanceDescriptionDescription = wddDesc
+ }
case insRes of
Just _ -> return . Just $ do
diff --git a/src/Handler/Workflow/Instance.hs b/src/Handler/Workflow/Instance.hs
new file mode 100644
index 000000000..836fa52be
--- /dev/null
+++ b/src/Handler/Workflow/Instance.hs
@@ -0,0 +1,9 @@
+module Handler.Workflow.Instance
+ ( module Handler.Workflow.Instance
+ ) where
+
+import Handler.Workflow.Instance.List as Handler.Workflow.Instance
+import Handler.Workflow.Instance.New as Handler.Workflow.Instance
+import Handler.Workflow.Instance.Edit as Handler.Workflow.Instance
+import Handler.Workflow.Instance.Delete as Handler.Workflow.Instance
+import Handler.Workflow.Instance.Initiate as Handler.Workflow.Instance
diff --git a/src/Handler/Workflow/Instance/Delete.hs b/src/Handler/Workflow/Instance/Delete.hs
new file mode 100644
index 000000000..154b32a3d
--- /dev/null
+++ b/src/Handler/Workflow/Instance/Delete.hs
@@ -0,0 +1,15 @@
+module Handler.Workflow.Instance.Delete
+ ( getGWIDeleteR, postGWIDeleteR
+ , workflowInstanceDeleteR
+ ) where
+
+import Import
+
+
+getGWIDeleteR, postGWIDeleteR :: WorkflowInstanceName -> Handler Html
+getGWIDeleteR = postGWIDeleteR
+postGWIDeleteR win
+ = workflowInstanceDeleteR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
+
+workflowInstanceDeleteR :: WorkflowInstanceId -> Handler Html
+workflowInstanceDeleteR = error "not implemented"
diff --git a/src/Handler/Workflow/Instance/Edit.hs b/src/Handler/Workflow/Instance/Edit.hs
new file mode 100644
index 000000000..189a16dc1
--- /dev/null
+++ b/src/Handler/Workflow/Instance/Edit.hs
@@ -0,0 +1,15 @@
+module Handler.Workflow.Instance.Edit
+ ( getGWIEditR, postGWIEditR
+ , workflowInstanceEditR
+ ) where
+
+import Import
+
+
+getGWIEditR, postGWIEditR :: WorkflowInstanceName -> Handler Html
+getGWIEditR = postGWIEditR
+postGWIEditR win
+ = workflowInstanceEditR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
+
+workflowInstanceEditR :: WorkflowInstanceId -> Handler Html
+workflowInstanceEditR = error "not implemented"
diff --git a/src/Handler/Workflow/Instance/Form.hs b/src/Handler/Workflow/Instance/Form.hs
new file mode 100644
index 000000000..c6815d1a9
--- /dev/null
+++ b/src/Handler/Workflow/Instance/Form.hs
@@ -0,0 +1,79 @@
+module Handler.Workflow.Instance.Form
+ ( WorkflowInstanceForm(..), FileIdent
+ , workflowInstanceForm
+ ) where
+
+import Import
+
+import Handler.Utils
+
+import Handler.Utils.Workflow.Form
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+
+workflowInstanceScopeForm :: Maybe WorkflowScope'
+ -> FieldSettings UniWorX
+ -> Maybe (WorkflowScope TermId SchoolId CourseId)
+ -> AForm Handler (WorkflowScope TermId SchoolId CourseId)
+workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $ classifyWorkflowScope <$> mPrev
+ where
+ scopeOptions' = maybe id (flip Map.restrictKeys . Set.singleton) scopeRestr scopeOptions
+ scopeOptions = Map.fromList
+ [ ( WSGlobal'
+ , pure WSGlobal
+ )
+ , ( WSTerm'
+ , WSTerm <$> apopt termField (fslI MsgTerm) (mPrev ^? _Just . _wisTerm)
+ )
+ , ( WSSchool'
+ , WSSchool <$> apopt schoolField (fslI MsgSchool) (mPrev ^? _Just . _wisSchool)
+ )
+ , ( WSTermSchool'
+ , WSTermSchool <$> apopt termField (fslI MsgTerm) (mPrev ^? _Just . _wisTerm)
+ <*> apopt schoolField (fslI MsgSchool) (mPrev ^? _Just . _wisSchool)
+ )
+ , ( WSCourse'
+ , WSCourse <$> apopt (selectField' Nothing courseOptions) (fslI MsgCourse) (mPrev ^? _Just . _wisCourse)
+ )
+ ]
+ where courseOptions = fmap (fmap entityKey) . optionsPersistCryptoId [] [ Desc CourseTerm, Asc CourseSchool, Asc CourseName ] $ \Course{..} -> MsgCourseOption courseTerm courseSchool courseName
+
+
+data WorkflowInstanceForm = WorkflowInstanceForm
+ { wifScope :: WorkflowScope TermId SchoolId CourseId
+ , wifName :: WorkflowInstanceName
+ , wifCategory :: Maybe WorkflowInstanceCategory
+ , wifDescriptions :: Map Lang (Text, Maybe Html)
+ , wifGraph :: WorkflowGraphForm
+ } deriving (Generic, Typeable)
+
+makeLenses_ ''WorkflowInstanceForm
+
+workflowInstanceForm :: Maybe WorkflowDefinitionId
+ -> Maybe WorkflowInstanceForm
+ -> Html
+ -> MForm DB (FormResult WorkflowInstanceForm, Widget)
+workflowInstanceForm forcedDefId template = renderWForm FormStandard $ do
+ defEnt <- for forcedDefId $ lift . lift . getJustEntity
+ defDescs <- for defEnt $ \(Entity dId _) -> do
+ descs <- lift . lift $ selectList [WorkflowDefinitionInstanceDescriptionDefinition ==. dId] []
+ return $ Map.fromList
+ [ (workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))
+ | Entity _ WorkflowDefinitionInstanceDescription{..} <- descs
+ ]
+ defGraph <- for defEnt $ toWorkflowGraphForm . workflowDefinitionGraph . entityVal
+
+ wifScopeRes <- aFormToWForm . hoistAForm lift $ workflowInstanceScopeForm (workflowDefinitionScope . entityVal <$> defEnt) (fslI MsgWorkflowScope) (wifScope <$> template)
+ wifNameRes <- wreq ciField (fslI MsgWorkflowInstanceName) (fmap wifName template <|> fmap (workflowDefinitionName . entityVal) defEnt)
+ wifCategoryRes <- wopt ciField (fslI MsgWorkflowInstanceCategory) (fmap wifCategory template <|> fmap (workflowDefinitionInstanceCategory . entityVal) defEnt)
+ wifDescriptions <- aFormToWForm . hoistAForm lift $ workflowDescriptionsForm WorkflowDescriptionsFormDefinition (fmap wifDescriptions template <|> defDescs)
+ wifGraphRes <- aFormToWForm $ workflowGraphForm ((template ^? _Just . _wifGraph) <|> defGraph)
+
+ return $ WorkflowInstanceForm
+ <$> wifScopeRes
+ <*> wifNameRes
+ <*> wifCategoryRes
+ <*> wifDescriptions
+ <*> wifGraphRes
diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs
new file mode 100644
index 000000000..18257e210
--- /dev/null
+++ b/src/Handler/Workflow/Instance/Initiate.hs
@@ -0,0 +1,15 @@
+module Handler.Workflow.Instance.Initiate
+ ( getGWIInitiateR, postGWIInitiateR
+ , workflowInstanceInitiateR
+ ) where
+
+import Import
+
+
+getGWIInitiateR, postGWIInitiateR :: WorkflowInstanceName -> Handler Html
+getGWIInitiateR = postGWIInitiateR
+postGWIInitiateR win
+ = workflowInstanceInitiateR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
+
+workflowInstanceInitiateR :: WorkflowInstanceId -> Handler Html
+workflowInstanceInitiateR = error "not implemented"
diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs
new file mode 100644
index 000000000..ad7a61af5
--- /dev/null
+++ b/src/Handler/Workflow/Instance/List.hs
@@ -0,0 +1,125 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Handler.Workflow.Instance.List
+ ( getAdminWorkflowInstanceListR
+ , getGlobalWorkflowInstanceListR
+ , workflowInstanceListR
+ ) where
+
+import Import
+
+import Handler.Utils
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import qualified Data.CaseInsensitive as CI
+
+
+type WorkflowInstanceTableExpr = E.SqlExpr (Entity WorkflowInstance)
+
+queryWorkflowInstance :: Equality' WorkflowInstanceTableExpr (E.SqlExpr (Entity WorkflowInstance))
+queryWorkflowInstance = id
+
+queryWorkflowCount :: Getter WorkflowInstanceTableExpr (E.SqlExpr (E.Value Int64))
+queryWorkflowCount = to $ \(view queryWorkflowInstance -> workflowInstance) ->
+ E.subSelectCount . E.from $ \workflow ->
+ E.where_ $ workflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
+
+
+type WorkflowInstanceData = DBRow
+ ( Entity WorkflowInstance
+ , Maybe (Entity WorkflowInstanceDescription)
+ , Int64
+ )
+
+resultWorkflowInstance :: Lens' WorkflowInstanceData (Entity WorkflowInstance)
+resultWorkflowInstance = _dbrOutput . _1
+
+resultDescription :: Traversal' WorkflowInstanceData (Entity WorkflowInstanceDescription)
+resultDescription = _dbrOutput . _2 . _Just
+
+resultWorkflowCount :: Lens' WorkflowInstanceData Int64
+resultWorkflowCount = _dbrOutput . _3
+
+
+getAdminWorkflowInstanceListR :: Handler Html
+getAdminWorkflowInstanceListR = do
+ instancesTable <- runDB $ do
+ scopeOptions <- do
+ scopes <- fmap (map E.unValue) . E.select . E.from $ \workflowInstance ->
+ return $ workflowInstance E.^. WorkflowInstanceScope
+ fmap mkOptionList . for scopes $ \scope -> do
+ eScope <- traverseOf _wisCourse (encrypt . (review _SqlKey :: SqlBackendKey -> CourseId)) scope :: DB (WorkflowScope TermIdentifier SchoolShorthand CryptoUUIDCourse)
+ wScope <- forOf _wisCourse scope $ fmap ((,,) <$> courseTerm <*> courseSchool <*> courseShorthand) . getJust . review _SqlKey
+ MsgRenderer mr <- getMsgRenderer
+ return Option
+ { optionDisplay = mr wScope
+ , optionInternalValue = scope
+ , optionExternalValue = toPathPiece eScope
+ }
+
+ let workflowInstancesDBTable = DBTable{..}
+ where
+ dbtSQLQuery = runReaderT $ do
+ workflowInstance <- view queryWorkflowInstance
+ workflowCount <- view queryWorkflowCount
+
+ return (workflowInstance, workflowCount)
+ dbtRowKey = (E.^. WorkflowInstanceId)
+ dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
+ wi@(Entity wiId _) <- view _1
+ descLangs <- lift . E.select . E.from $ \workflowInstanceDescription -> do
+ E.where_ $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionInstance E.==. E.val wiId
+ return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
+ descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
+ desc <- lift . fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
+ (wi, desc,)
+ <$> view (_2 . _Value)
+ dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
+ dbtColonnade = mconcat
+ [ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18nCell
+ , sortable (Just "scope") (i18nCell MsgWorkflowScope) . views (resultWorkflowInstance . _entityVal . _workflowInstanceScope) $ \scope ->
+ sqlCell . fmap i18n . forOf _wisCourse scope $ fmap ((,,) <$> courseTerm <*> courseSchool <*> courseShorthand) . getJust . review _SqlKey
+ , sortable (Just "title") (i18nCell MsgWorkflowInstanceDescriptionTitle) $ maybe mempty i18nCell . preview (resultDescription . _entityVal . _workflowInstanceDescriptionTitle)
+ , sortable (Just "workflows") (i18nCell MsgWorkflowInstanceWorkflowCount) $ maybe mempty i18nCell . views resultWorkflowCount (assertM' (> 0))
+ , sortable (Just "description") (i18nCell MsgWorkflowInstanceDescription) $ maybe mempty modalCell . preview (resultDescription . _entityVal . _workflowInstanceDescriptionDescription . _Just)
+ ]
+ dbtSorting = mconcat
+ [ singletonMap "name" . SortColumn $ views queryWorkflowInstance (E.^. WorkflowInstanceName)
+ , singletonMap "scope" . SortColumn $ views queryWorkflowInstance (E.^. WorkflowInstanceScope)
+ , singletonMap "title" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle
+ , singletonMap "description" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowInstanceDescriptionDescription
+ , singletonMap "workflows" . SortColumn $ view queryWorkflowCount
+ ]
+ dbtFilter = mconcat
+ [ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowInstanceName)
+ , singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowInstanceScope)
+ , singletonMap "title" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
+ ]
+ dbtFilterUI mPrev = mconcat
+ [ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowInstanceName)
+ , prismAForm (singletonFilter "scope" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ return scopeOptions) (fslI MsgWorkflowScope)
+ , prismAForm (singletonFilter "title") mPrev $ aopt textField (fslI MsgWorkflowInstanceDescriptionTitle)
+ ]
+ dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
+ dbtParams = def
+ dbtIdent :: Text
+ dbtIdent = "workflow-instances"
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ workflowInstancesDBTableValidator = def
+ & defaultSorting [SortAscBy "scope", SortAscBy "name"]
+ in dbTableDB' workflowInstancesDBTableValidator workflowInstancesDBTable
+
+ siteLayoutMsg MsgWorkflowInstanceListTitle $ do
+ setTitleI MsgWorkflowInstanceListTitle
+
+ instancesTable
+
+
+getGlobalWorkflowInstanceListR :: Handler Html
+getGlobalWorkflowInstanceListR = workflowInstanceListR WSGlobal
+
+workflowInstanceListR :: WorkflowScope TermId SchoolId CourseId -> Handler Html
+workflowInstanceListR = error "not implemented"
diff --git a/src/Handler/Workflow/Instance/New.hs b/src/Handler/Workflow/Instance/New.hs
new file mode 100644
index 000000000..1104ae997
--- /dev/null
+++ b/src/Handler/Workflow/Instance/New.hs
@@ -0,0 +1,76 @@
+module Handler.Workflow.Instance.New
+ ( getAdminWorkflowInstanceNewR, postAdminWorkflowInstanceNewR
+ , adminWorkflowInstanceNewR
+ , getGlobalWorkflowInstanceNewR, postGlobalWorkflowInstanceNewR
+ , workflowInstanceNewR
+ ) where
+
+import Import
+import Handler.Utils
+import Handler.Utils.Workflow.Form
+
+import Handler.Workflow.Instance.Form
+
+getAdminWorkflowInstanceNewR, postAdminWorkflowInstanceNewR :: Handler Html
+getAdminWorkflowInstanceNewR = postAdminWorkflowInstanceNewR
+postAdminWorkflowInstanceNewR = adminWorkflowInstanceNewR Nothing
+
+adminWorkflowInstanceNewR :: Maybe WorkflowDefinitionId -> Handler Html
+adminWorkflowInstanceNewR wdId = do
+ cRoute <- getCurrentRoute
+ (((_, instForm), instEncoding), act) <- runDB $ do
+ form@((instRes, _), _) <- runFormPost $ workflowInstanceForm wdId Nothing
+
+ act <- formResultMaybe instRes $ \WorkflowInstanceForm{..} -> do
+ wifGraph' <- fromWorkflowGraphForm wifGraph
+ let wifScope' = wifScope
+ & over _wisTerm unTermKey
+ & over _wisSchool unSchoolKey
+ & over _wisCourse (view _SqlKey)
+ instId <- insertUnique WorkflowInstance
+ { workflowInstanceDefinition = wdId
+ , workflowInstanceGraph = wifGraph'
+ , workflowInstanceScope = wifScope'
+ , workflowInstanceName = wifName
+ , workflowInstanceCategory = wifCategory
+ }
+
+ for_ instId $ \instId' -> iforM_ wifDescriptions $ \widLang (widTitle, widDesc) ->
+ insert WorkflowInstanceDescription
+ { workflowInstanceDescriptionInstance = instId'
+ , workflowInstanceDescriptionLanguage = widLang
+ , workflowInstanceDescriptionTitle = widTitle
+ , workflowInstanceDescriptionDescription = widDesc
+ }
+
+ return . Just $ case instId of
+ Nothing -> addMessageI Error MsgWorkflowInstanceCollision
+ Just _
+ | is _Just wdId -> do
+ addMessageI Success MsgWorkflowDefinitionInstantiated
+ redirect AdminWorkflowInstanceListR
+ | otherwise -> do
+ addMessageI Success MsgWorkflowInstanceCreated
+ redirect AdminWorkflowInstanceListR
+
+ return (form, act)
+
+ forM_ act id
+
+ let instWidget = wrapForm instForm def
+ { formAction = SomeRoute <$> cRoute
+ , formEncoding = instEncoding
+ }
+
+ siteLayoutMsg MsgWorkflowDefinitionInstantiateTitle $ do
+ setTitleI MsgWorkflowDefinitionInstantiateTitle
+
+ instWidget
+
+
+getGlobalWorkflowInstanceNewR, postGlobalWorkflowInstanceNewR :: Handler Html
+getGlobalWorkflowInstanceNewR = postGlobalWorkflowInstanceNewR
+postGlobalWorkflowInstanceNewR = workflowInstanceNewR WSGlobal
+
+workflowInstanceNewR :: WorkflowScope TermId SchoolId CourseId -> Handler Html
+workflowInstanceNewR = error "not implemented"
diff --git a/src/Handler/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow.hs
new file mode 100644
index 000000000..d7e669f20
--- /dev/null
+++ b/src/Handler/Workflow/Workflow.hs
@@ -0,0 +1,9 @@
+module Handler.Workflow.Workflow
+ ( module Handler.Workflow.Workflow
+ ) where
+
+import Handler.Workflow.Workflow.List as Handler.Workflow.Workflow
+import Handler.Workflow.Workflow.Workflow as Handler.Workflow.Workflow
+import Handler.Workflow.Workflow.Edit as Handler.Workflow.Workflow
+import Handler.Workflow.Workflow.Delete as Handler.Workflow.Workflow
+import Handler.Workflow.Workflow.New as Handler.Workflow.Workflow
diff --git a/src/Handler/Workflow/Workflow/Delete.hs b/src/Handler/Workflow/Workflow/Delete.hs
new file mode 100644
index 000000000..09ae5370d
--- /dev/null
+++ b/src/Handler/Workflow/Workflow/Delete.hs
@@ -0,0 +1,17 @@
+module Handler.Workflow.Workflow.Delete
+ ( getGWWDeleteR, postGWWDeleteR
+ , workflowDeleteR
+ ) where
+
+import Import
+
+import Handler.Utils.Workflow.Workflow
+
+
+getGWWDeleteR, postGWWDeleteR :: CryptoFileNameWorkflowWorkflow -> Handler Html
+getGWWDeleteR = postGWWDeleteR
+postGWWDeleteR cID
+ = workflowDeleteR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
+
+workflowDeleteR :: WorkflowWorkflowId -> Handler Html
+workflowDeleteR = error "not implemented"
diff --git a/src/Handler/Workflow/Workflow/Edit.hs b/src/Handler/Workflow/Workflow/Edit.hs
new file mode 100644
index 000000000..10b1c3d5d
--- /dev/null
+++ b/src/Handler/Workflow/Workflow/Edit.hs
@@ -0,0 +1,17 @@
+module Handler.Workflow.Workflow.Edit
+ ( getGWWEditR, postGWWEditR
+ , workflowEditR
+ ) where
+
+import Import
+
+import Handler.Utils.Workflow.Workflow
+
+
+getGWWEditR, postGWWEditR :: CryptoFileNameWorkflowWorkflow -> Handler Html
+getGWWEditR = postGWWEditR
+postGWWEditR cID
+ = workflowEditR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
+
+workflowEditR :: WorkflowWorkflowId -> Handler Html
+workflowEditR = error "not implemented"
diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs
new file mode 100644
index 000000000..5445c4013
--- /dev/null
+++ b/src/Handler/Workflow/Workflow/List.hs
@@ -0,0 +1,28 @@
+module Handler.Workflow.Workflow.List
+ ( getGlobalWorkflowWorkflowListR
+ , workflowWorkflowListR
+ , getGWIWorkflowsR
+ , workflowInstanceWorkflowsR
+ , getAdminWorkflowWorkflowListR
+ ) where
+
+import Import
+
+
+getGlobalWorkflowWorkflowListR :: Handler Html
+getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
+
+workflowWorkflowListR :: WorkflowScope TermId SchoolId CourseId -> Handler Html
+workflowWorkflowListR = error "not implemented"
+
+
+getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
+getGWIWorkflowsR win
+ = workflowInstanceWorkflowsR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
+
+workflowInstanceWorkflowsR :: WorkflowInstanceId -> Handler Html
+workflowInstanceWorkflowsR = error "not implemented"
+
+
+getAdminWorkflowWorkflowListR :: Handler Html
+getAdminWorkflowWorkflowListR = error "not implemented"
diff --git a/src/Handler/Workflow/Workflow/New.hs b/src/Handler/Workflow/Workflow/New.hs
new file mode 100644
index 000000000..c9d7c1e04
--- /dev/null
+++ b/src/Handler/Workflow/Workflow/New.hs
@@ -0,0 +1,10 @@
+module Handler.Workflow.Workflow.New
+ ( getAdminWorkflowWorkflowNewR, postAdminWorkflowWorkflowNewR
+ ) where
+
+import Import
+
+
+getAdminWorkflowWorkflowNewR, postAdminWorkflowWorkflowNewR :: Handler Html
+getAdminWorkflowWorkflowNewR = postAdminWorkflowWorkflowNewR
+postAdminWorkflowWorkflowNewR = error "not implemented"
diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs
new file mode 100644
index 000000000..c07d3619c
--- /dev/null
+++ b/src/Handler/Workflow/Workflow/Workflow.hs
@@ -0,0 +1,19 @@
+module Handler.Workflow.Workflow.Workflow
+ ( getGWWWorkflowR, postGWWWorkflowR
+ , workflowR
+ ) where
+
+import Import
+
+import Handler.Utils.Workflow.Workflow
+
+
+getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
+getGWWWorkflowR = postGWWWorkflowR
+postGWWWorkflowR cID = do
+ wId <- runDB . maybeT notFound $ ensureScope WSGlobal cID
+
+ workflowR wId
+
+workflowR :: WorkflowWorkflowId -> Handler Html
+workflowR = error "not implemented"
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 345fc7657..6cb3da679 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -55,6 +55,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthSystemExamOffice
| AuthEvaluation
| AuthAllocationAdmin
+ | AuthWorkflow
| AuthAllocationRegistered
| AuthCourseRegistered
| AuthTutorialRegistered
diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs
index 4c61947f7..420388d70 100644
--- a/src/Model/Types/Workflow.hs
+++ b/src/Model/Types/Workflow.hs
@@ -3,8 +3,8 @@
module Model.Types.Workflow
( WorkflowGraph(..)
, WorkflowGraphNodeLabel
- , WorkflowInstanceScope(..)
- , WorkflowInstanceScope'(..)
+ , WorkflowScope(..)
+ , WorkflowScope'(..), classifyWorkflowScope
, WorkflowState
, WorkflowAction(..)
, WorkflowChildren
@@ -48,13 +48,11 @@ data WorkflowGraph fileid userid = WorkflowGraph
newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql)
-newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
- deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
- deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql)
data WorkflowGraphNode fileid userid = WGN
{ wgnDisplayLabel :: Maybe I18nText
- , wgnInitial, wgnFinished :: Bool
+ , wgnInitial :: Maybe (NonNull (Set (WorkflowRole userid)))
+ , wgnFinal :: Bool
, wgnViewers :: Set (WorkflowRole userid)
, wgnEdges :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid)
}
@@ -63,6 +61,10 @@ data WorkflowGraphNode fileid userid = WGN
----- WORKFLOW GRAPH: EDGES -----
+newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
+ deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
+ deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PersistField, PersistFieldSql)
+
data WorkflowGraphEdge fileid userid
= WorkflowGraphEdgeManual
{ wgeTarget :: WorkflowGraphNodeLabel
@@ -122,7 +124,7 @@ data WorkflowPayloadField fileid userid (payload :: Type) where
WorkflowPayloadFieldBool :: { wpfbLabel :: I18nText
, wpfbTooltip :: Maybe I18nHtml
, wpfbDefault :: Maybe Bool
- , wpfbOptional :: Maybe Text -- ^ Optional if `Just`; encodes label of `Nothing`-Option
+ , wpfbOptional :: Maybe I18nText -- ^ Optional if `Just`; encodes label of `Nothing`-Option
} -> WorkflowPayloadField fileid userid Bool
WorkflowPayloadFieldFile :: { wpffLabel :: I18nText
, wpffTooltip :: Maybe I18nHtml
@@ -173,19 +175,26 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work
----- WORKFLOW INSTANCE -----
-data WorkflowInstanceScope termid schoolid courseid
- = WISGlobal
- | WISTerm { wisTerm :: termid }
- | WISSchool { wisSchool :: schoolid }
- | WISTermSchool { wisTerm :: termid, wisSchool :: schoolid }
- | WISCourse { wisCourse :: courseid }
+data WorkflowScope termid schoolid courseid
+ = WSGlobal
+ | WSTerm { wisTerm :: termid }
+ | WSSchool { wisSchool :: schoolid }
+ | WSTermSchool { wisTerm :: termid, wisSchool :: schoolid }
+ | WSCourse { wisCourse :: courseid }
deriving (Eq, Ord, Show, Read, Data, Generic, Typeable)
-data WorkflowInstanceScope'
- = WISGlobal' | WISTerm' | WISSchool' | WISTermSchool' | WISCourse'
+data WorkflowScope'
+ = WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse'
deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable)
deriving anyclass (Universe, Finite)
+classifyWorkflowScope :: WorkflowScope termid schoolid courseid -> WorkflowScope'
+classifyWorkflowScope = \case
+ WSGlobal -> WSGlobal'
+ WSTerm{} -> WSTerm'
+ WSSchool{} -> WSSchool'
+ WSTermSchool{} -> WSTermSchool'
+ WSCourse{} -> WSCourse'
----- WORKFLOW: PAYLOAD -----
@@ -252,9 +261,10 @@ data WorkflowFieldPayload'' = WFPText' | WFPNumber' | WFPBool' | WFPFile' | WFPU
----- PathPiece instances -----
-nullaryPathPiece ''WorkflowInstanceScope' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
+nullaryPathPiece ''WorkflowScope' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
nullaryPathPiece ''WorkflowFieldPayload'' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
+derivePathPiece ''WorkflowScope (camelToPathPiece' 1) "--"
----- Generic traversal -----
@@ -482,9 +492,9 @@ instance ( FromJSON fileid, FromJSON userid
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
- } ''WorkflowInstanceScope
+ } ''WorkflowScope
-pathPieceJSON ''WorkflowInstanceScope'
+pathPieceJSON ''WorkflowScope'
deriveToJSON workflowActionAesonOptions ''WorkflowAction
@@ -556,15 +566,15 @@ instance ( ToJSON fileid, ToJSON userid
instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid
, FromJSON termid, FromJSON schoolid, FromJSON courseid
- ) => PersistField (WorkflowInstanceScope termid schoolid courseid) where
+ ) => PersistField (WorkflowScope termid schoolid courseid) where
toPersistValue = toPersistValueJSON
fromPersistValue = fromPersistValueJSON
instance ( ToJSON termid, ToJSON schoolid, ToJSON courseid
, FromJSON termid, FromJSON schoolid, FromJSON courseid
- ) => PersistFieldSql (WorkflowInstanceScope termid schoolid courseid) where
+ ) => PersistFieldSql (WorkflowScope termid schoolid courseid) where
sqlType _ = sqlTypeJSON
-derivePersistFieldJSON ''WorkflowInstanceScope'
+derivePersistFieldJSON ''WorkflowScope'
instance ( ToJSON fileid, ToJSON userid
, FromJSON fileid, FromJSON userid
@@ -579,3 +589,9 @@ instance ( ToJSON fileid, ToJSON userid
, Typeable fileid, Typeable userid
) => PersistFieldSql (WorkflowState fileid userid) where
sqlType _ = sqlTypeJSON
+
+
+----- Binary instances -----
+
+instance Binary WorkflowScope'
+instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowScope termid schoolid courseid)
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index cbb16f9c1..995bf01d8 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -1110,6 +1110,12 @@ validateFormDB :: ( MonadHandler m
-> (Markup -> MForm m (FormResult a, xml))
validateFormDB (FormValidator valF) = validateForm . FormValidator $ hoist (liftHandler . runDB) valF
+validateAForm :: MonadHandler m
+ => FormValidator a m ()
+ -> AForm m a
+ -> AForm m a
+validateAForm valF form = formToAForm . over (mapped . _2) ($ []) $ validateForm valF (const $ aFormToForm form) mempty
+
tellValidationError :: ( MonadHandler m
, RenderMessage (HandlerSite m) msg
)
diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs
index 75d228abf..68425ce2e 100644
--- a/src/Utils/Icon.hs
+++ b/src/Utils/Icon.hs
@@ -90,6 +90,7 @@ data Icon
| IconAllocationRegister | IconAllocationRegistrationEdit
| IconAllocationApplicationEdit
| IconPersonalIdentification
+ | IconMenuWorkflows
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
iconText :: Icon -> Text
@@ -160,6 +161,7 @@ iconText = \case
IconAllocationRegistrationEdit -> "pencil-alt"
IconAllocationApplicationEdit -> "pencil-alt"
IconPersonalIdentification -> "id-card"
+ IconMenuWorkflows -> "folders"
instance Universe Icon
instance Finite Icon
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 35cc640dc..bd0ea4558 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -247,6 +247,10 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey
makeLenses_ ''WorkflowDefinition
makeLenses_ ''WorkflowDefinitionDescription
+makeLenses_ ''WorkflowDefinitionInstanceDescription
+makeLenses_ ''WorkflowScope
+makeLenses_ ''WorkflowInstance
+makeLenses_ ''WorkflowInstanceDescription
makeWrapped ''Textarea
diff --git a/templates/widgets/massinput/workflowDefinitionDescriptions/add.hamlet b/templates/widgets/massinput/workflowDescriptions/add.hamlet
similarity index 100%
rename from templates/widgets/massinput/workflowDefinitionDescriptions/add.hamlet
rename to templates/widgets/massinput/workflowDescriptions/add.hamlet
diff --git a/templates/widgets/massinput/workflowDefinitionDescriptions/form.hamlet b/templates/widgets/massinput/workflowDescriptions/form.hamlet
similarity index 100%
rename from templates/widgets/massinput/workflowDefinitionDescriptions/form.hamlet
rename to templates/widgets/massinput/workflowDescriptions/form.hamlet
diff --git a/templates/widgets/massinput/workflowDefinitionDescriptions/layout.hamlet b/templates/widgets/massinput/workflowDescriptions/layout.hamlet
similarity index 74%
rename from templates/widgets/massinput/workflowDefinitionDescriptions/layout.hamlet
rename to templates/widgets/massinput/workflowDescriptions/layout.hamlet
index 23a31fe2c..9370a6ea2 100644
--- a/templates/widgets/massinput/workflowDefinitionDescriptions/layout.hamlet
+++ b/templates/widgets/massinput/workflowDescriptions/layout.hamlet
@@ -3,13 +3,13 @@ $newline never
|
- _{MsgWorkflowDefinitionDescriptionLanguage} #
+ _{MsgWorkflowDescriptionLanguage} #
|
- _{MsgWorkflowDefinitionDescriptionTitle} #
+ _{MsgWorkflowDescriptionTitle} #
|
- _{MsgWorkflowDefinitionDescription}
+ _{MsgWorkflowDescription}
|
|
$forall coord <- review liveCoords lLength