From baea302e48dd6c603eebba7040923f0c23266f40 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 30 Sep 2020 16:51:24 +0200 Subject: [PATCH] feat(workflows): placeholder handlers --- messages/uniworx/de-de-formal.msg | 67 ++++++-- messages/uniworx/en-eu.msg | 20 ++- models/workflows.model | 20 ++- routes | 29 +++- src/CryptoID.hs | 20 +++ src/Foundation/Authorization.hs | 1 + src/Foundation/I18n.hs | 13 +- src/Foundation/Navigation.hs | 138 +++++++++++++++++ src/Foundation/Routes.hs | 2 + src/Foundation/Yesod/Middleware.hs | 16 ++ src/Handler/Utils/Workflow/Form.hs | 143 ++++++++++++++++++ src/Handler/Utils/Workflow/Workflow.hs | 17 +++ src/Handler/Workflow.hs | 2 + src/Handler/Workflow/Definition.hs | 1 + src/Handler/Workflow/Definition/Delete.hs | 2 +- src/Handler/Workflow/Definition/Edit.hs | 51 +++---- src/Handler/Workflow/Definition/Form.hs | 90 ++--------- .../Workflow/Definition/Instantiate.hs | 59 ++++++++ src/Handler/Workflow/Definition/List.hs | 36 +++-- src/Handler/Workflow/Definition/New.hs | 16 +- src/Handler/Workflow/Instance.hs | 9 ++ src/Handler/Workflow/Instance/Delete.hs | 15 ++ src/Handler/Workflow/Instance/Edit.hs | 15 ++ src/Handler/Workflow/Instance/Form.hs | 79 ++++++++++ src/Handler/Workflow/Instance/Initiate.hs | 15 ++ src/Handler/Workflow/Instance/List.hs | 125 +++++++++++++++ src/Handler/Workflow/Instance/New.hs | 76 ++++++++++ src/Handler/Workflow/Workflow.hs | 9 ++ src/Handler/Workflow/Workflow/Delete.hs | 17 +++ src/Handler/Workflow/Workflow/Edit.hs | 17 +++ src/Handler/Workflow/Workflow/List.hs | 28 ++++ src/Handler/Workflow/Workflow/New.hs | 10 ++ src/Handler/Workflow/Workflow/Workflow.hs | 19 +++ src/Model/Types/Security.hs | 1 + src/Model/Types/Workflow.hs | 58 ++++--- src/Utils/Form.hs | 6 + src/Utils/Icon.hs | 2 + src/Utils/Lens.hs | 4 + .../add.hamlet | 0 .../form.hamlet | 0 .../layout.hamlet | 6 +- 41 files changed, 1077 insertions(+), 177 deletions(-) create mode 100644 src/Handler/Utils/Workflow/Form.hs create mode 100644 src/Handler/Utils/Workflow/Workflow.hs create mode 100644 src/Handler/Workflow/Definition/Instantiate.hs create mode 100644 src/Handler/Workflow/Instance.hs create mode 100644 src/Handler/Workflow/Instance/Delete.hs create mode 100644 src/Handler/Workflow/Instance/Edit.hs create mode 100644 src/Handler/Workflow/Instance/Form.hs create mode 100644 src/Handler/Workflow/Instance/Initiate.hs create mode 100644 src/Handler/Workflow/Instance/List.hs create mode 100644 src/Handler/Workflow/Instance/New.hs create mode 100644 src/Handler/Workflow/Workflow.hs create mode 100644 src/Handler/Workflow/Workflow/Delete.hs create mode 100644 src/Handler/Workflow/Workflow/Edit.hs create mode 100644 src/Handler/Workflow/Workflow/List.hs create mode 100644 src/Handler/Workflow/Workflow/New.hs create mode 100644 src/Handler/Workflow/Workflow/Workflow.hs rename templates/widgets/massinput/{workflowDefinitionDescriptions => workflowDescriptions}/add.hamlet (100%) rename templates/widgets/massinput/{workflowDefinitionDescriptions => workflowDescriptions}/form.hamlet (100%) rename templates/widgets/massinput/{workflowDefinitionDescriptions => workflowDescriptions}/layout.hamlet (74%) 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