Merge branch 'fill_avn_a' into 'master'
Improved test data See merge request FraDrive/fradrive!3
This commit is contained in:
Steffen Jost
commit
e344c50dcf
@ -142,31 +142,6 @@ uniworx:exe:uniworx:
|
||||
retry: 2
|
||||
interruptible: true
|
||||
|
||||
uniworx:exe:uniworx-wflint:
|
||||
stage: backend:build
|
||||
script:
|
||||
- xzcat uniworx:lib:uniworx.nar.xz | nix-store --import
|
||||
- source .gitlab-ci/construct-flake-url.sh
|
||||
- nix -L build -o result "${FLAKE}#uniworx:exe:uniworx-wflint"
|
||||
- nix-store --export $(nix-store -qR result) | xz -T0 -2 > uniworx:exe:uniworx-wflint.nar.xz
|
||||
before_script: *nix-before
|
||||
needs:
|
||||
- job: node dependencies # transitive
|
||||
artifacts: false
|
||||
- job: well known # transitive
|
||||
artifacts: false
|
||||
- job: frontend # tranitive
|
||||
artifacts: false
|
||||
- job: uniworx:lib:uniworx
|
||||
artifacts: true
|
||||
artifacts:
|
||||
paths:
|
||||
- uniworx:exe:uniworx-wflint.nar.xz
|
||||
name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}"
|
||||
expire_in: "1 day"
|
||||
retry: 2
|
||||
interruptible: true
|
||||
|
||||
uniworx:exe:uniworxdb:
|
||||
stage: backend:build
|
||||
script:
|
||||
|
||||
@ -87,7 +87,7 @@
|
||||
backendSource = pkgs.lib.sourceByRegex ./. [
|
||||
"^(\.hlint|package|stack-flake)\.yaml$"
|
||||
"^stack\.yaml\.lock$"
|
||||
"^(assets|app|hlint|load|messages|models|src|templates|test|testdata|wflint)(/.*)?$"
|
||||
"^(assets|app|hlint|load|messages|models|src|templates|test|testdata)(/.*)?$"
|
||||
"^config(/(archive-types|mimetypes|personalised-sheet-files-collate|settings\.yml|submission-blacklist|test-settings\.yml|video-types|wordlist\.txt))?$"
|
||||
"^routes$"
|
||||
"^testdata(/.*)?$"
|
||||
|
||||
@ -1,7 +1,11 @@
|
||||
SummerTerm year@Integer: Sommersemester #{year}
|
||||
WinterTerm year@Integer: Wintersemester #{year}/#{succ year}
|
||||
SummerTermShort year@Integer: SoSe #{year}
|
||||
WinterTermShort year@Integer: WiSe #{year}/#{mod (succ year) 100}
|
||||
Quarter1st year@Integer: Erstes Quartal #{year}
|
||||
Quarter2nd year@Integer: Zweites Quartal #{year}
|
||||
Quarter3rd year@Integer: Drittes Quartal #{year}
|
||||
Quarter4th year@Integer: Viertes Quartal #{year}
|
||||
Quarter1stShort year@Integer: #{year}/Q1
|
||||
Quarter2ndShort year@Integer: #{year}/Q2
|
||||
Quarter3rdShort year@Integer: #{year}/Q3
|
||||
Quarter4thShort year@Integer: #{year}/Q4
|
||||
CorByProportionOnly proportion@Rational: #{rationalToFixed3 proportion} Anteile
|
||||
CorByProportionIncludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile - Tutorium
|
||||
CorByProportionExcludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile + Tutorium
|
||||
|
||||
@ -1,7 +1,11 @@
|
||||
SummerTerm year: Summer semester #{year}
|
||||
WinterTerm year: Winter semester #{year}/#{succ year}
|
||||
SummerTermShort year: Summer #{year}
|
||||
WinterTermShort year: Winter #{year}/#{mod (succ year) 100}
|
||||
Quarter1st year@Integer: First Quarter of #{year}
|
||||
Quarter2nd year@Integer: Second Quarter of #{year}
|
||||
Quarter3rd year@Integer: Third Quarter of #{year}
|
||||
Quarter4th year@Integer: Last Quarter of #{year}
|
||||
Quarter1stShort year@Integer: #{year}/Q1st
|
||||
Quarter2ndShort year@Integer: #{year}/Q2nd
|
||||
Quarter3rdShort year@Integer: #{year}/Q3rd
|
||||
Quarter4thShort year@Integer: #{year}/Q4th
|
||||
CorByProportionOnly proportion: #{rationalToFixed3 proportion} parts
|
||||
CorByProportionIncludingTutorial proportion: #{rationalToFixed3 proportion} parts - tutorials
|
||||
CorByProportionExcludingTutorial proportion: #{rationalToFixed3 proportion} parts + tutorials
|
||||
|
||||
@ -1,163 +0,0 @@
|
||||
WorkflowScopeKindGlobal: Systemweit
|
||||
WorkflowScopeKindTerm: Pro Semester
|
||||
WorkflowScopeKindSchool: Pro Institut
|
||||
WorkflowScopeKindTermSchool: Pro Institut & Semester
|
||||
WorkflowScopeKindCourse: Pro Veranstaltung
|
||||
WorkflowDefinitionScope: Bereich
|
||||
WorkflowDefinitionName !ident-ok: Name
|
||||
WorkflowDefinitionDescriptions: Beschreibung
|
||||
WorkflowDefinitionDescriptionsLanguageExists: Eine Beschreibung in dieser Sprache existiert bereits
|
||||
WorkflowDefinitionGraph: Spezifikation
|
||||
WorkflowDefinitionKeyDoesNotExist renderedCryptoID@Text: Referenziert ID existiert nicht: #{renderedCryptoID}
|
||||
WorkflowDefinitionFiles: Dateien
|
||||
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 und Bereich
|
||||
WorkflowDefinitionNewTitle: Workflow-Definition anlegen
|
||||
WorkflowDefinitionEditTitle: Workflow-Definition Bearbeiten
|
||||
WorkflowDefinitionInstanceCategory: Kategorie
|
||||
WorkflowDefinitionWarningLinterIssuesMessage: Es sind Linter issues aufgetreten
|
||||
WorkflowDefinitionWarningLinterIssues: Es sind folgende Linter issues aufgetreten:
|
||||
|
||||
WorkflowDefinitionListTitle: Workflow-Definitionen
|
||||
WorkflowDefinitionInstanceCount: Instanzen
|
||||
WorkflowDefinitionWorkflowCount !ident-ok: Workflows
|
||||
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 !ident-ok: 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 !ident-ok: Workflows
|
||||
|
||||
WorkflowInstanceInitiateSuccess: Workflow erfolgreich initiiert
|
||||
|
||||
WorkflowDescriptionLanguage: Sprach-Code (RFC1766)
|
||||
WorkflowDescriptionTitle: Titel
|
||||
WorkflowDescription: Beschreibung
|
||||
|
||||
GlobalWorkflowInstancesHeading: Workflows (Systemweit)
|
||||
GlobalWorkflowInstancesTitle: Workflows (Systemweit)
|
||||
|
||||
GlobalWorkflowInstanceInitiateHeading workflowInstanceTitle@Text: Workflow initiieren: #{workflowInstanceTitle}
|
||||
GlobalWorkflowInstanceInitiateTitle: Workflow initiieren
|
||||
|
||||
SchoolWorkflowInstancesHeading ssh@SchoolId !ident-ok: Workflows (#{ssh})
|
||||
SchoolWorkflowInstancesTitle ssh@SchoolId !ident-ok: Workflows (#{ssh})
|
||||
|
||||
SchoolWorkflowInstanceInitiateHeading ssh@SchoolId workflowInstanceTitle@Text: Workflow initiieren: #{ssh}, #{workflowInstanceTitle}
|
||||
SchoolWorkflowInstanceInitiateTitle ssh@SchoolId: Workflow initiieren: #{ssh}
|
||||
|
||||
WorkflowInstanceInitiateHeadingDisabled: Workflow initiieren
|
||||
WorkflowInstanceInitiateTitleDisabled: Workflow initiieren
|
||||
|
||||
WorkflowEdgeNumberedVariant edgeLabel@Text i@Natural: #{edgeLabel} (Variante #{i})
|
||||
WorkflowEdgeFormEdge: Aktion
|
||||
WorkflowEdgeFormHiddenPayload i@Natural: Versteckter Datensatz #{i}
|
||||
WorkflowEdgeFormPayloadOneFieldRequired: Es muss mindestens ein Feld pro Datensatz ausgefüllt werden
|
||||
WorkflowEdgeFormPayloadOneFieldRequiredFor payloadDisplayLabel@Text: Es muss mindestens ein Feld für “#{payloadDisplayLabel}” ausgefüllt werden
|
||||
WorkflowEdgeFormFieldNumberTooSmall minSci@Scientific: Zahl muss mindestens #{formatScientific Scientific.Generic Nothing minSci} sein
|
||||
WorkflowEdgeFormFieldNumberTooLarge maxSci@Scientific: Zahl muss höchstens #{formatScientific Scientific.Generic Nothing maxSci} sein
|
||||
WorkflowEdgeFormFieldUserNotFound: E-Mail Adresse konnte keinem/keiner Benutzer:in zugeordnet werden
|
||||
WorkflowEdgeFormFieldMultipleNoneAdded: (Noch) keine Einträge
|
||||
WorkflowEdgeFormFieldCaptureUserLabel: Aktuelle:r Benutzer:in
|
||||
|
||||
WorkflowEdgeFormEnumFieldNothing: Keine Auswahl
|
||||
|
||||
WorkflowEdgeFormFieldDayTooFarPast offset@Integer: Datum liegt zu weit in der Vergangenheit (maximal #{offset} Tage)
|
||||
WorkflowEdgeFormFieldDayTooFarFuture offset@Integer: Datum liegt zu weit in der Zukunft (maximal #{offset} Tage)
|
||||
|
||||
WorkflowEdgeFormFieldCaptureDateLabel: Aktuelles Datum
|
||||
WorkflowEdgeFormFieldCaptureTimeLabel: Aktuelle Uhrzeit
|
||||
WorkflowEdgeFormFieldCaptureDateTimeLabel: Aktuelles Datum/Zeit
|
||||
|
||||
WorkflowWorkflowWorkflowHistoryHeading: Verlauf
|
||||
WorkflowWorkflowWorkflowEdgeFormHeading: Aktion im Workflow auslösen
|
||||
WorkflowWorkflowWorkflowEdgeSuccess: Aktion erfolgreich ausgelöst
|
||||
WorkflowWorkflowWorkflowHistoryUserSelf: Sie selbst
|
||||
WorkflowWorkflowWorkflowHistoryUserNotLoggedIn: Nicht eingeloggter Benutzer
|
||||
WorkflowWorkflowWorkflowHistoryUserGone: Gelöschte:r Benutzer:in
|
||||
WorkflowWorkflowWorkflowHistoryUserHidden: Versteckte:r Benutzer:in
|
||||
WorkflowWorkflowWorkflowHistoryUserAutomatic: Automatisch
|
||||
WorkflowWorkflowWorkflowHistoryActionAutomatic: Automatisch
|
||||
WorkflowWorkflowWorkflowHistoryStateHidden: Versteckter Zustand
|
||||
WorkflowWorkflowWorkflowHistoryActionLabel: Aktion
|
||||
WorkflowWorkflowWorkflowHistoryFromLabel: Vorheriger Zustand
|
||||
WorkflowWorkflowWorkflowHistoryToLabel: Neuer Zustand
|
||||
WorkflowWorkflowWorkflowHistoryPayloadLabel: Datensatz-Änderungen
|
||||
WorkflowWorkflowFilesArchiveName wwCID@CryptoFileNameWorkflowWorkflow wpl@WorkflowPayloadLabel stCID@CryptoUUIDWorkflowStateIndex !ident-ok: #{foldCase (toPathPiece wwCID)}-#{foldCase (toPathPiece stCID)}-#{foldCase (foldMap unidecode (toPathPiece wpl))}.zip
|
||||
WorkflowWorkflowWorkflowStateHeading: Zustand/Daten
|
||||
WorkflowWorkflowWorkflowPayloadHeading: Aktueller Datensatz
|
||||
WorkflowWorkflowWorkflowStateStateLabel: Aktueller Zustand
|
||||
WorkflowWorkflowWorkflowStateStateHidden: Versteckter Zustand
|
||||
WorkflowWorkflowWorkflowHistoryLabelOthers: Aktionen Anderer
|
||||
WorkflowWorkflowWorkflowHistoryLabelOwn: Eigene Aktionen
|
||||
|
||||
WorkflowPayloadFiles: Datei(en)
|
||||
WorkflowPayloadBoolTrue: Ja
|
||||
WorkflowPayloadBoolFalse: Nein
|
||||
WorkflowPayloadUserGone: Gelöschte:r Benutzer:in
|
||||
|
||||
TopWorkflowInstancesHeading !ident-ok: Workflows
|
||||
TopWorkflowInstancesTitle !ident-ok: Workflows
|
||||
|
||||
GlobalWorkflowWorkflowWorkflowHeading workflowWorkflowId@CryptoFileNameWorkflowWorkflow !ident-ok: Workflow #{toPathPiece workflowWorkflowId}
|
||||
GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId@CryptoFileNameWorkflowWorkflow !ident-ok: Workflow #{toPathPiece workflowWorkflowId}
|
||||
|
||||
SchoolWorkflowWorkflowWorkflowHeading ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow !ident-ok: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
SchoolWorkflowWorkflowWorkflowTitle ssh@SchoolId workflowWorkflowId@CryptoFileNameWorkflowWorkflow !ident-ok: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
|
||||
WorkflowWorkflowListScopeTitle rScope@RouteWorkflowScope: Laufende Workflows - _{rScope}
|
||||
WorkflowWorkflowListScopeHeading rScope@RouteWorkflowScope: Laufende Workflows (_{rScope})
|
||||
WorkflowWorkflowListInstanceTitle: Laufende Workflows für Instanz
|
||||
WorkflowWorkflowListInstanceHeading: Laufende Workflows für Instanz
|
||||
WorkflowWorkflowListNamedInstanceTitle rScope@RouteWorkflowScope wiTitle@Text: Laufende Workflows - _{rScope}, #{wiTitle}
|
||||
WorkflowWorkflowListNamedInstanceHeading rScope@RouteWorkflowScope wiTitle@Text: Laufende Workflows (_{rScope}, #{wiTitle})
|
||||
WorkflowWorkflowListNamedInstanceTitleDisabled rScope@RouteWorkflowScope: Laufende Workflows - _{rScope}
|
||||
WorkflowWorkflowListNamedInstanceHeadingDisabled rScope@RouteWorkflowScope: Laufende Workflows (_{rScope})
|
||||
WorkflowWorkflowListTopTitle: Laufende Workflows
|
||||
WorkflowWorkflowListTopHeading: Laufende Workflows
|
||||
AdminWorkflowWorkflowListTitle: Laufende Workflows
|
||||
AdminWorkflowWorkflowListHeading: Laufende Workflows
|
||||
|
||||
WorkflowWorkflowListNumber: Nummer
|
||||
WorkflowWorkflowListScope: Bereich
|
||||
WorkflowWorkflowListInstance: Instanz
|
||||
WorkflowWorkflowListCurrentState: Aktueller Zustand
|
||||
WorkflowWorkflowListLastActionTime: Zeitpunkt, letzte Aktion
|
||||
WorkflowWorkflowListLastActionUser: Benutzer:in, letzte Aktion
|
||||
WorkflowWorkflowListIsFinal: Abgeschlossen?
|
||||
|
||||
WorkflowGraphFormUploadIsDirectory: Upload ist Verzeichnis
|
||||
WorkflowGraphFormInvalidNumberOfFiles: Es muss genau eine Datei hochgeladen werden
|
||||
WorkflowCourseOption tid@TermId ssh@SchoolId coursen@CourseName !ident-ok: #{tid} - #{ssh} - #{coursen}
|
||||
YAMLFieldDecodeFailure yamlFailure@String: Konnte YAML nicht parsen: #{yamlFailure}
|
||||
|
||||
WGFTextInput: Textfeld
|
||||
WGFFileUpload: Dateifeld
|
||||
WorkflowWorkflowListPersons: Beteiligte Benutzer
|
||||
|
||||
BtnWorkflowInstanceUpdate !ident-ok: Update
|
||||
WorkflowInstanceUpdateNoActions: Keine Updates verfügbar
|
||||
WorkflowInstanceUpdateUpdatedGraph: Definitions-Update erfolgreich angewandt
|
||||
WorkflowInstanceUpdateUpdatedCategory: Kategorie-Update erfolgreich angewandt
|
||||
WorkflowInstanceUpdateDeletedDescriptionLanguage lang@Lang: Beschreibung/Titel in Sprache „#{lang}“ gelöscht
|
||||
WorkflowInstanceUpdateUpdatedDescriptionLanguage lang@Lang: Beschreibung/Titel-Update für Sprache „#{lang}“ angewandt
|
||||
|
||||
WorkflowsDisabled: Workflows sind temporär deaktiviert.
|
||||
@ -1,163 +0,0 @@
|
||||
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
|
||||
WorkflowDescriptionLanguage: Language code (RFC1766)
|
||||
WorkflowDescriptionTitle: Title
|
||||
WorkflowDescription: Description
|
||||
|
||||
GlobalWorkflowInstancesHeading: Workflows (system-wide)
|
||||
GlobalWorkflowInstancesTitle: Workflows (system-wide)
|
||||
|
||||
GlobalWorkflowInstanceInitiateHeading workflowInstanceTitle: Initiate workflow: #{workflowInstanceTitle}
|
||||
GlobalWorkflowInstanceInitiateTitle: Initiate workflow
|
||||
|
||||
SchoolWorkflowInstancesHeading ssh: Workflows (#{ssh})
|
||||
SchoolWorkflowInstancesTitle ssh: Workflows (#{ssh})
|
||||
|
||||
SchoolWorkflowInstanceInitiateHeading ssh workflowInstanceTitle: Initiate workflow: #{ssh}, #{workflowInstanceTitle}
|
||||
SchoolWorkflowInstanceInitiateTitle ssh: Initiate workflow: #{ssh}
|
||||
|
||||
WorkflowInstanceInitiateHeadingDisabled: Initiate Workflow
|
||||
WorkflowInstanceInitiateTitleDisabled: Initiate Workflow
|
||||
|
||||
WorkflowEdgeNumberedVariant edgeLabel i: #{edgeLabel} (variant #{i})
|
||||
WorkflowEdgeFormEdge: Action
|
||||
WorkflowEdgeFormHiddenPayload i: Hidden dataset #{i}
|
||||
WorkflowEdgeFormPayloadOneFieldRequired: At least one field per dataset needs to be filled
|
||||
WorkflowEdgeFormPayloadOneFieldRequiredFor payloadDisplayLabel: At least one field for “#{payloadDisplayLabel}” needs to be filled
|
||||
WorkflowEdgeFormFieldNumberTooSmall minSci: Number must be at least #{formatScientific Scientific.Generic Nothing minSci}
|
||||
WorkflowEdgeFormFieldNumberTooLarge maxSci: Number must be at most #{formatScientific Scientific.Generic Nothing maxSci}
|
||||
WorkflowEdgeFormFieldUserNotFound: Email could not be resolved to an user
|
||||
WorkflowEdgeFormFieldMultipleNoneAdded: No entries (yet)
|
||||
WorkflowEdgeFormFieldCaptureUserLabel: Current user
|
||||
|
||||
WorkflowEdgeFormEnumFieldNothing: No selection
|
||||
|
||||
WorkflowEdgeFormFieldDayTooFarPast offset: Date is too far in the past (maximum #{offset} days)
|
||||
WorkflowEdgeFormFieldDayTooFarFuture offset: Date is too far in the future (maximum #{offset} days)
|
||||
|
||||
WorkflowEdgeFormFieldCaptureDateLabel: Current date
|
||||
WorkflowEdgeFormFieldCaptureTimeLabel: Current time
|
||||
WorkflowEdgeFormFieldCaptureDateTimeLabel: Current date/time
|
||||
|
||||
WorkflowWorkflowWorkflowHistoryHeading: History
|
||||
WorkflowWorkflowWorkflowEdgeFormHeading: Trigger action within workflow
|
||||
WorkflowWorkflowWorkflowEdgeSuccess: Successfully triggered action
|
||||
WorkflowWorkflowWorkflowHistoryUserSelf: You
|
||||
WorkflowWorkflowWorkflowHistoryUserNotLoggedIn: Not-logged in user
|
||||
WorkflowWorkflowWorkflowHistoryUserGone: Deleted user
|
||||
WorkflowWorkflowWorkflowHistoryUserHidden: Hidden user
|
||||
WorkflowWorkflowWorkflowHistoryUserAutomatic: Automatic
|
||||
WorkflowWorkflowWorkflowHistoryActionAutomatic: Automatic
|
||||
WorkflowWorkflowWorkflowHistoryStateHidden: Hidden state
|
||||
WorkflowWorkflowWorkflowHistoryActionLabel: Action
|
||||
WorkflowWorkflowWorkflowHistoryFromLabel: Previous state
|
||||
WorkflowWorkflowWorkflowHistoryToLabel: New state
|
||||
WorkflowWorkflowWorkflowHistoryPayloadLabel: Data changes
|
||||
WorkflowWorkflowFilesArchiveName wwCID wpl stCID: #{foldCase (toPathPiece wwCID)}-#{foldCase (toPathPiece stCID)}-#{foldCase (foldMap unidecode (toPathPiece wpl))}.zip
|
||||
WorkflowWorkflowWorkflowStateHeading: State/Data
|
||||
WorkflowWorkflowWorkflowPayloadHeading: Current data
|
||||
WorkflowWorkflowWorkflowStateStateLabel: Current state
|
||||
WorkflowWorkflowWorkflowStateStateHidden: Hidden state
|
||||
WorkflowWorkflowWorkflowHistoryLabelOthers: Other users' actions
|
||||
WorkflowWorkflowWorkflowHistoryLabelOwn: Your actions
|
||||
|
||||
WorkflowPayloadFiles: File(s)
|
||||
WorkflowPayloadBoolTrue: Yes
|
||||
WorkflowPayloadBoolFalse: No
|
||||
WorkflowPayloadUserGone: Deleted user
|
||||
|
||||
TopWorkflowInstancesHeading: Workflows
|
||||
TopWorkflowInstancesTitle: Workflows
|
||||
|
||||
GlobalWorkflowWorkflowWorkflowHeading workflowWorkflowId: Workflow #{toPathPiece workflowWorkflowId}
|
||||
GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId: Workflow #{toPathPiece workflowWorkflowId}
|
||||
|
||||
SchoolWorkflowWorkflowWorkflowHeading ssh workflowWorkflowId: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
SchoolWorkflowWorkflowWorkflowTitle ssh workflowWorkflowId: Workflow #{ssh}, #{toPathPiece workflowWorkflowId}
|
||||
|
||||
WorkflowWorkflowListScopeTitle rScope: Running workflows - _{rScope}
|
||||
WorkflowWorkflowListScopeHeading rScope: Running workflows (_{rScope})
|
||||
WorkflowWorkflowListInstanceTitle: Running workflows for an instance
|
||||
WorkflowWorkflowListInstanceHeading: Running workflows for an instance
|
||||
WorkflowWorkflowListNamedInstanceTitle rScope wiTitle: Running workflows - _{rScope}, #{wiTitle}
|
||||
WorkflowWorkflowListNamedInstanceHeading rScope wiTitle: Running workflows (_{rScope}, #{wiTitle})
|
||||
WorkflowWorkflowListNamedInstanceTitleDisabled rScope: Running Workflows - _{rScope}
|
||||
WorkflowWorkflowListNamedInstanceHeadingDisabled rScope: Running Workflows (_{rScope})
|
||||
WorkflowWorkflowListTopTitle: Running workflows
|
||||
WorkflowWorkflowListTopHeading: Running workflows
|
||||
AdminWorkflowWorkflowListTitle: Running workflows
|
||||
AdminWorkflowWorkflowListHeading: Running workflows
|
||||
|
||||
WorkflowWorkflowListNumber: Number
|
||||
WorkflowWorkflowListScope: Scope
|
||||
WorkflowWorkflowListInstance: Instance
|
||||
WorkflowWorkflowListCurrentState: Current state
|
||||
WorkflowWorkflowListLastActionTime: Timestamp of last action
|
||||
WorkflowWorkflowListLastActionUser: User for last action
|
||||
WorkflowWorkflowListIsFinal: Finalised?
|
||||
|
||||
WorkflowDefinitionGraph: Specification
|
||||
WorkflowDefinitionKeyDoesNotExist renderedCryptoID: Referenced id does not exist: #{renderedCryptoID}
|
||||
WorkflowDefinitionFiles: Files
|
||||
WorkflowFileIdentDoesNotExist fileIdent: Referenced file does not exist: #{fileIdent}
|
||||
WorkflowUserDoesNotExist userIdent: Referenced user does not exist: #{userIdent}
|
||||
WorkflowDefinitionFileIdentExists: A file with the given reference id already exists
|
||||
WorkflowDefinitionFileIdent: File reference id
|
||||
WorkflowDefinitionFile: File
|
||||
WorkflowDefinitionCreated: Successfully created workflow definition
|
||||
WorkflowDefinitionEdited: Successfully replaced workflow definition
|
||||
WorkflowDefinitionCollision: A workflow definition with this name already exists
|
||||
WorkflowDefinitionNewTitle: Create new workflow definition
|
||||
WorkflowDefinitionEditTitle: Edit workflow definition
|
||||
WorkflowDefinitionInstanceCategory: Category
|
||||
WorkflowDefinitionWarningLinterIssuesMessage: There were linter issues
|
||||
WorkflowDefinitionWarningLinterIssues: There are the following linter issues:
|
||||
|
||||
WorkflowDefinitionListTitle: Workflow definitions
|
||||
WorkflowDefinitionInstanceCount: Instances
|
||||
WorkflowDefinitionWorkflowCount: Workflows
|
||||
WorkflowDefinitionConcreteInstanceCount num: #{num} instances
|
||||
WorkflowDefinitionConcreteWorkflowCount num: #{num} workflows
|
||||
WorkflowDefinitionDeleteQuestion: Do you really want to delete the workflow definition listed below?
|
||||
WorkflowDefinitionDeleted: Successfully deleted workflow definition
|
||||
WorkflowDefinitionInstantiateTitle: Instantiate workflow definition
|
||||
WorkflowDefinitionInstantiated: Instance created
|
||||
|
||||
WorkflowScope: Scope
|
||||
WorkflowInstanceName: Name
|
||||
WorkflowInstanceCategory: Category
|
||||
WorkflowInstanceCollision: There already exists a workflow instance with the given name and category
|
||||
WorkflowInstanceListTitle: Workflow instances
|
||||
WorkflowInstanceDescription: Instance description
|
||||
WorkflowInstanceDescriptions: Instance description
|
||||
WorkflowInstanceDescriptionsLanguageExists: A instance description in the given language already exists
|
||||
WorkflowInstanceCreated: Instance created
|
||||
WorkflowInstanceDescriptionTitle: Instance title
|
||||
WorkflowInstanceWorkflowCount: Workflows
|
||||
|
||||
WorkflowInstanceInitiateSuccess: Successfully initiated workflow
|
||||
|
||||
WorkflowGraphFormUploadIsDirectory: Upload is a directory
|
||||
WorkflowGraphFormInvalidNumberOfFiles: You need to upload exactly one file
|
||||
WorkflowCourseOption tid ssh coursen: #{tid} - #{ssh} - #{coursen}
|
||||
YAMLFieldDecodeFailure yamlFailure: Could not parse YAML: #{yamlFailure}
|
||||
|
||||
WGFTextInput: Text field
|
||||
WGFFileUpload: File field
|
||||
WorkflowWorkflowListPersons: Involved users
|
||||
|
||||
BtnWorkflowInstanceUpdate: Update
|
||||
WorkflowInstanceUpdateNoActions: No updates available
|
||||
WorkflowInstanceUpdateUpdatedGraph: Successfully applied updated definition
|
||||
WorkflowInstanceUpdateUpdatedCategory: Successfully applied updated category
|
||||
WorkflowInstanceUpdateDeletedDescriptionLanguage lang: Successfully deleted description/title for language “#{lang}”
|
||||
WorkflowInstanceUpdateUpdatedDescriptionLanguage lang: Successfully applied updated description/title for language “#{lang}”
|
||||
|
||||
WorkflowsDisabled: Workflows are temporarily disabled.
|
||||
@ -80,31 +80,6 @@ BreadcrumbFaq !ident-ok: FAQ
|
||||
BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen
|
||||
BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen
|
||||
BreadcrumbAdminCrontab !ident-ok: Crontab
|
||||
BreadcrumbAdminWorkflowDefinitionList: Workflow-Definitionen
|
||||
BreadcrumbAdminWorkflowDefinitionNew: Neue Workflow-Definition
|
||||
BreadcrumbAdminWorkflowDefinitionEdit renderedWorkflowScope'@Text wfdn@WorkflowDefinitionName !ident-ok: #{wfdn} (#{renderedWorkflowScope'})
|
||||
BreadcrumbAdminWorkflowDefinitionDelete: Löschen
|
||||
BreadcrumbAdminWorkflowDefinitionInstantiate: Instanziieren
|
||||
BreadcrumbAdminWorkflowInstanceList: Workflow-Instanzen
|
||||
BreadcrumbAdminWorkflowInstanceNew: Neue Workflow-Instanz
|
||||
BreadcrumbAdminWorkflowInstanceEdit: Instanz bearbeiten
|
||||
BreadcrumbAdminWorkflowWorkflowList: Initiierte Workflows
|
||||
BreadcrumbAdminWorkflowWorkflowNew: Workflow initiieren
|
||||
BreadcrumbWorkflowInstanceEdit win@WorkflowInstanceName !ident-ok: #{win}
|
||||
BreadcrumbWorkflowInstanceDelete: Löschen
|
||||
BreadcrumbWorkflowInstanceWorkflowList: Laufende Workflows
|
||||
BreadcrumbWorkflowInstanceInitiate: Workflow starten
|
||||
BreadcrumbWorkflowInstanceList !ident-ok: Workflows
|
||||
BreadcrumbWorkflowInstanceNew: Neuer Workflow
|
||||
BreadcrumbWorkflowInstanceUpdate !ident-ok: Update
|
||||
BreadcrumbWorkflowWorkflowList: Laufende Workflows
|
||||
BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow !ident-ok: #{toPathPiece workflow}
|
||||
BreadcrumbWorkflowWorkflowFiles: Dateien
|
||||
BreadcrumbWorkflowWorkflowEdit: Editieren
|
||||
BreadcrumbWorkflowWorkflowDelete: Löschen
|
||||
BreadcrumbGlobalWorkflowInstanceList: Systemweite Workflows
|
||||
BreadcrumbTopWorkflowInstanceList !ident-ok: Workflows
|
||||
BreadcrumbTopWorkflowWorkflowList: Laufende Workflows
|
||||
BreadcrumbError: Fehler
|
||||
BreadcrumbUpload !ident-ok: Upload
|
||||
BreadcrumbUserAdd: Benutzer:in anlegen
|
||||
|
||||
@ -80,31 +80,6 @@ BreadcrumbFaq: FAQ
|
||||
BreadcrumbSheetPersonalisedFiles: Download personalised sheet files
|
||||
BreadcrumbCourseSheetPersonalisedFiles: Download template for personalised sheet files
|
||||
BreadcrumbAdminCrontab: Crontab
|
||||
BreadcrumbAdminWorkflowDefinitionList: Workflow definitions
|
||||
BreadcrumbAdminWorkflowDefinitionNew: New workflow definition
|
||||
BreadcrumbAdminWorkflowDefinitionEdit renderedWorkflowScope' wfdn: #{wfdn} (#{renderedWorkflowScope'})
|
||||
BreadcrumbAdminWorkflowDefinitionDelete: Delete
|
||||
BreadcrumbAdminWorkflowDefinitionInstantiate: Instantiate
|
||||
BreadcrumbAdminWorkflowInstanceList: Workflow instances
|
||||
BreadcrumbAdminWorkflowInstanceNew: New workflow-instance
|
||||
BreadcrumbAdminWorkflowInstanceEdit: Edit instance
|
||||
BreadcrumbAdminWorkflowWorkflowList: Initiated workflows
|
||||
BreadcrumbAdminWorkflowWorkflowNew: Initiate workflow
|
||||
BreadcrumbWorkflowInstanceEdit win: #{win}
|
||||
BreadcrumbWorkflowInstanceDelete: Delete
|
||||
BreadcrumbWorkflowInstanceWorkflowList: Running workflows
|
||||
BreadcrumbWorkflowInstanceInitiate: Start workflow
|
||||
BreadcrumbWorkflowInstanceList: Workflows
|
||||
BreadcrumbWorkflowInstanceNew: New workflow
|
||||
BreadcrumbWorkflowInstanceUpdate !ident-ok: Update
|
||||
BreadcrumbWorkflowWorkflowList: Running workflows
|
||||
BreadcrumbWorkflowWorkflow workflow: #{toPathPiece workflow}
|
||||
BreadcrumbWorkflowWorkflowFiles: Files
|
||||
BreadcrumbWorkflowWorkflowEdit: Edit
|
||||
BreadcrumbWorkflowWorkflowDelete: Delete
|
||||
BreadcrumbGlobalWorkflowInstanceList: System-wide workflows
|
||||
BreadcrumbTopWorkflowInstanceList: Workflows
|
||||
BreadcrumbTopWorkflowWorkflowList: Running workflows
|
||||
BreadcrumbError: Error
|
||||
BreadcrumbUpload: Upload
|
||||
BreadcrumbUserAdd: Add user
|
||||
|
||||
@ -115,24 +115,6 @@ MenuFaq !ident-ok: FAQ
|
||||
MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen
|
||||
MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen
|
||||
MenuAdminCrontab !ident-ok: Crontab
|
||||
MenuAdminWorkflowDefinitionList !ident-ok: Workflows
|
||||
MenuAdminWorkflowDefinitionNew: Neue Workflow-Definition
|
||||
MenuAdminWorkflowDefinitionDelete: Löschen
|
||||
MenuAdminWorkflowInstanceList: Workflow-Instanzen
|
||||
MenuAdminWorkflowInstanceNew: Neue Workflow-Instanz
|
||||
MenuAdminWorkflowDefinitionInstantiate: Instanziieren
|
||||
MenuWorkflowInstanceUpdate !ident-ok: Update
|
||||
MenuWorkflowInstanceDelete: Löschen
|
||||
MenuWorkflowInstanceWorkflows: Laufende Workflows
|
||||
MenuWorkflowInstanceInitiate: Workflow starten
|
||||
MenuWorkflowInstanceEdit: Bearbeiten
|
||||
MenuWorkflowWorkflowList: Laufende Workflows
|
||||
MenuWorkflowWorkflowEdit: Editieren
|
||||
MenuWorkflowWorkflowDelete: Löschen
|
||||
MenuGlobalWorkflowInstanceList: Systemweite Workflows
|
||||
MenuTopWorkflowInstanceList !ident-ok: Workflows
|
||||
MenuTopWorkflowWorkflowList: Laufende Workflows
|
||||
MenuTopWorkflowWorkflowListHeader !ident-ok: Workflows
|
||||
MenuGlossary: Begriffsverzeichnis
|
||||
MenuVersion: Versionsgeschichte
|
||||
MenuCourseNewsNew: Neue Kursnachricht
|
||||
|
||||
@ -116,24 +116,6 @@ MenuFaq: FAQ
|
||||
MenuSheetPersonalisedFiles: Download personalised sheet files
|
||||
MenuCourseSheetPersonalisedFiles: Download template for personalised sheet files
|
||||
MenuAdminCrontab: Crontab
|
||||
MenuAdminWorkflowDefinitionList: Workflows
|
||||
MenuAdminWorkflowDefinitionNew: New workflow definition
|
||||
MenuAdminWorkflowDefinitionDelete: Delete
|
||||
MenuAdminWorkflowInstanceList: Workflow instances
|
||||
MenuAdminWorkflowInstanceNew: New workflow instance
|
||||
MenuAdminWorkflowDefinitionInstantiate: Instantiate
|
||||
MenuWorkflowInstanceUpdate !ident-ok: Update
|
||||
MenuWorkflowInstanceDelete: Delete
|
||||
MenuWorkflowInstanceWorkflows: Running workflows
|
||||
MenuWorkflowInstanceInitiate: Start workflow
|
||||
MenuWorkflowInstanceEdit: Edit
|
||||
MenuWorkflowWorkflowList: Running workflows
|
||||
MenuWorkflowWorkflowEdit: Edit
|
||||
MenuWorkflowWorkflowDelete: Delete
|
||||
MenuGlobalWorkflowInstanceList: System-wide workflows
|
||||
MenuTopWorkflowInstanceList: Workflows
|
||||
MenuTopWorkflowWorkflowList: Running workflows
|
||||
MenuTopWorkflowWorkflowListHeader: Workflows
|
||||
MenuGlossary: Glossary
|
||||
MenuVersion: Version history
|
||||
MenuCourseNewsNew: Add course news
|
||||
|
||||
@ -1,53 +0,0 @@
|
||||
SharedWorkflowGraph
|
||||
hash WorkflowGraphReference
|
||||
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
|
||||
Primary hash
|
||||
deriving Generic
|
||||
|
||||
WorkflowDefinition
|
||||
graph SharedWorkflowGraphId
|
||||
scope WorkflowScope'
|
||||
name WorkflowDefinitionName
|
||||
instanceCategory WorkflowInstanceCategory Maybe
|
||||
UniqueWorkflowDefinition name scope
|
||||
deriving Generic
|
||||
|
||||
WorkflowDefinitionDescription
|
||||
definition WorkflowDefinitionId OnDeleteCascade OnUpdateCascade
|
||||
language Lang
|
||||
title Text
|
||||
description StoredMarkup Maybe
|
||||
UniqueWorkflowDefinitionDescription definition language
|
||||
deriving Generic
|
||||
|
||||
WorkflowDefinitionInstanceDescription
|
||||
definition WorkflowDefinitionId OnDeleteCascade OnUpdateCascade
|
||||
language Lang
|
||||
title Text
|
||||
description StoredMarkup Maybe
|
||||
UniqueWorkflowDefinitionInstanceDescription definition language
|
||||
deriving Generic
|
||||
|
||||
WorkflowInstance
|
||||
definition WorkflowDefinitionId Maybe OnDeleteSetNull OnUpdateCascade
|
||||
graph SharedWorkflowGraphId
|
||||
scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId
|
||||
name WorkflowInstanceName
|
||||
category WorkflowInstanceCategory Maybe
|
||||
UniqueWorkflowInstance name scope
|
||||
deriving Generic
|
||||
|
||||
WorkflowInstanceDescription
|
||||
instance WorkflowInstanceId
|
||||
language Lang
|
||||
title Text
|
||||
description StoredMarkup Maybe
|
||||
UniqueWorkflowInstanceDescription instance language
|
||||
deriving Generic
|
||||
|
||||
WorkflowWorkflow
|
||||
instance WorkflowInstanceId Maybe
|
||||
scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId
|
||||
graph SharedWorkflowGraphId
|
||||
state (WorkflowState FileReference SqlBackendKey) -- UserId
|
||||
deriving Generic
|
||||
@ -66,8 +66,7 @@ in {
|
||||
components.library.build-tools = with final.pkgs; [ llvm_9 ];
|
||||
components.exes.uniworx.build-tools = with final.pkgs; [ llvm_9 ];
|
||||
components.exes.uniworxdb.build-tools = with final.pkgs; [ llvm_9 ];
|
||||
components.exes.uniworxload.build-tools = with final.pkgs; [ llvm_9 ];
|
||||
components.exes.uniworx-wflint.build-tools = with final.pkgs; [ llvm_9 ];
|
||||
components.exes.uniworxload.build-tools = with final.pkgs; [ llvm_9 ];
|
||||
components.tests.yesod = {
|
||||
build-tools = with final.pkgs; [ llvm_9 final.uniworx.hsPkgs.hspec-discover ];
|
||||
testWrapper =
|
||||
|
||||
6
package-lock.json
generated
6
package-lock.json
generated
@ -4831,9 +4831,9 @@
|
||||
}
|
||||
},
|
||||
"caniuse-lite": {
|
||||
"version": "1.0.30001137",
|
||||
"resolved": "https://registry.npmjs.org/caniuse-lite/-/caniuse-lite-1.0.30001137.tgz",
|
||||
"integrity": "sha512-54xKQZTqZrKVHmVz0+UvdZR6kQc7pJDgfhsMYDG19ID1BWoNnDMFm5Q3uSBSU401pBvKYMsHAt9qhEDcxmk8aw==",
|
||||
"version": "1.0.30001257",
|
||||
"resolved": "https://registry.npmjs.org/caniuse-lite/-/caniuse-lite-1.0.30001257.tgz",
|
||||
"integrity": "sha512-JN49KplOgHSXpIsVSF+LUyhD8PUp6xPpAXeRrrcBh4KBeP7W864jHn6RvzJgDlrReyeVjMFJL3PLpPvKIxlIHA==",
|
||||
"dev": true
|
||||
},
|
||||
"caseless": {
|
||||
|
||||
14
package.yaml
14
package.yaml
@ -300,20 +300,6 @@ executables:
|
||||
when:
|
||||
- condition: flag(library-only)
|
||||
buildable: false
|
||||
uniworx-wflint:
|
||||
main: WFLint.hs
|
||||
ghc-options:
|
||||
- -main-is WFLint
|
||||
dependencies:
|
||||
- base
|
||||
- uniworx
|
||||
- bytestring
|
||||
- yaml
|
||||
other-modules: []
|
||||
source-dirs: wflint
|
||||
when:
|
||||
- condition: flag(library-only)
|
||||
buildable: false
|
||||
tests:
|
||||
yesod:
|
||||
main: Main.hs
|
||||
|
||||
48
routes
48
routes
@ -60,37 +60,6 @@
|
||||
/admin/tokens AdminTokensR GET POST
|
||||
/admin/crontab AdminCrontabR GET
|
||||
|
||||
/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/instances/#CryptoUUIDWorkflowInstance AdminWorkflowInstanceR:
|
||||
/edit AWIEditR GET POST
|
||||
/admin/workflows/workflows AdminWorkflowWorkflowListR GET
|
||||
/admin/workflows/workflows/new AdminWorkflowWorkflowNewR GET POST
|
||||
|
||||
/global-workflows/instances GlobalWorkflowInstanceListR GET !free
|
||||
/global-workflows/instances/new GlobalWorkflowInstanceNewR GET POST
|
||||
/global-workflows/instances/#WorkflowInstanceName GlobalWorkflowInstanceR:
|
||||
/edit GWIEditR GET POST
|
||||
/delete GWIDeleteR GET POST
|
||||
/workflows GWIWorkflowsR GET !¬empty
|
||||
/initiate GWIInitiateR GET POST !workflow
|
||||
/update GWIUpdateR POST
|
||||
/global-workflows GlobalWorkflowWorkflowListR GET !free
|
||||
!/global-workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR:
|
||||
/ GWWWorkflowR GET POST !workflow
|
||||
/files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex GWWFilesR GET !workflow
|
||||
/edit GWWEditR GET POST
|
||||
/delete GWWDeleteR GET POST
|
||||
|
||||
/workflow-instances TopWorkflowInstanceListR GET !free
|
||||
/workflows TopWorkflowWorkflowListR GET !free
|
||||
|
||||
/health HealthR GET !free
|
||||
/instance InstanceR GET !free
|
||||
/info InfoR GET !free
|
||||
@ -135,25 +104,12 @@
|
||||
!/term/#TermId TermCourseListR GET !free
|
||||
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
|
||||
|
||||
|
||||
/school SchoolListR GET
|
||||
!/school/new SchoolNewR GET POST
|
||||
/school/#SchoolId SchoolR:
|
||||
/ SchoolEditR GET POST
|
||||
|
||||
/workflows/instances SchoolWorkflowInstanceListR GET !free
|
||||
/workflows/instances/new SchoolWorkflowInstanceNewR GET POST
|
||||
/workflows/instances/#WorkflowInstanceName SchoolWorkflowInstanceR:
|
||||
/edit SWIEditR GET POST
|
||||
/delete SWIDeleteR GET POST
|
||||
/workflows SWIWorkflowsR GET !¬empty
|
||||
/initiate SWIInitiateR GET POST !workflow
|
||||
/update SWIUpdateR POST
|
||||
/workflows SchoolWorkflowWorkflowListR GET !free
|
||||
!/workflows/#CryptoFileNameWorkflowWorkflow SchoolWorkflowWorkflowR:
|
||||
/ SWWWorkflowR GET POST !workflow
|
||||
/files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex SWWFilesR GET !workflow
|
||||
/edit SWWEditR GET POST
|
||||
/delete SWWDeleteR GET POST
|
||||
|
||||
|
||||
/allocation/ AllocationListR GET !free
|
||||
!/allocation/new AllocationNewR GET POST !allocation-admin
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
|
||||
module Application
|
||||
( getAppSettings, getAppDevSettings
|
||||
, appMain
|
||||
@ -143,7 +143,6 @@ import Handler.Metrics
|
||||
import Handler.ExternalExam
|
||||
import Handler.Participants
|
||||
import Handler.StorageKey
|
||||
import Handler.Workflow
|
||||
import Handler.Error
|
||||
import Handler.Upload
|
||||
|
||||
|
||||
@ -53,15 +53,10 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''CourseEventId
|
||||
, ''TutorialId
|
||||
, ''ExternalExamId
|
||||
, ''WorkflowInstanceId
|
||||
, ''WorkflowWorkflowId
|
||||
, ''MaterialFileId
|
||||
, ''AllocationMatchingId
|
||||
]
|
||||
|
||||
type instance CryptoIDNamespace a WorkflowStateIndex = "WorkflowStateIndex"
|
||||
type CryptoUUIDWorkflowStateIndex = CryptoUUID WorkflowStateIndex
|
||||
|
||||
decCryptoIDKeySize
|
||||
|
||||
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
|
||||
@ -99,22 +94,3 @@ 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
|
||||
|
||||
@ -14,9 +14,6 @@ module Foundation.Authorization
|
||||
, BearerAuthSite, MonadAP
|
||||
, routeAuthTags
|
||||
, orAR, andAR, notAR, trueAR, falseAR
|
||||
, evalWorkflowRoleFor, evalWorkflowRoleFor'
|
||||
, hasWorkflowRole
|
||||
, mayViewWorkflowAction, mayViewWorkflowAction'
|
||||
, authoritiveApproot
|
||||
, AuthorizationCacheKey(..)
|
||||
) where
|
||||
@ -31,12 +28,10 @@ import Foundation.DB
|
||||
|
||||
import Handler.Utils.ExamOffice.Exam
|
||||
import Handler.Utils.ExamOffice.ExternalExam
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
import Handler.Utils.Memcached
|
||||
import Handler.Utils.I18n
|
||||
import Handler.Utils.Routes
|
||||
import Utils.Course (courseIsVisible)
|
||||
import Utils.Workflow
|
||||
import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
@ -45,8 +40,8 @@ import qualified Data.HashSet as HashSet
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map ((!?))
|
||||
import qualified Data.Text as Text
|
||||
import Data.List (findIndex, inits)
|
||||
import Data.Semigroup (Last(..))
|
||||
import Data.List (findIndex)
|
||||
-- import Data.Semigroup (Last(..))
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
@ -56,14 +51,14 @@ import Control.Monad.Memo.Class (MonadMemo(..), for4)
|
||||
|
||||
import Data.Aeson.Lens hiding (_Value, key)
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
-- import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import GHC.TypeLits (TypeError)
|
||||
import qualified GHC.TypeLits as TypeError (ErrorMessage(..))
|
||||
|
||||
import Utils.VolatileClusterSettings
|
||||
-- import Utils.VolatileClusterSettings
|
||||
|
||||
|
||||
type BearerAuthSite site
|
||||
@ -466,17 +461,8 @@ maybeCurrentBearerRestrictions = runMaybeT $ do
|
||||
route <- MaybeT getCurrentRoute
|
||||
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|
||||
|
||||
workflowsEnabledAuth :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> m AuthResult
|
||||
-> m AuthResult
|
||||
workflowsEnabledAuth = volatileBool clusterVolatileWorkflowsEnabled (unauthorizedI MsgWorkflowsDisabled)
|
||||
|
||||
data AuthorizationCacheKey
|
||||
= AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
|
||||
| AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
|
||||
| AuthCacheWorkflowInstanceInitiators WorkflowInstanceName RouteWorkflowScope
|
||||
| AuthCacheWorkflowInstanceWorkflowViewers WorkflowInstanceName RouteWorkflowScope
|
||||
| AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
|
||||
= AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
|
||||
| AuthCacheLecturerList | AuthCacheExternalExamStaffList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
|
||||
| AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
|
||||
| AuthCacheVisibleSystemMessages
|
||||
@ -1563,69 +1549,27 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route
|
||||
guard $ not hasOther
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthRegisterGroup r
|
||||
tagAccessPredicate AuthEmpty = APDB $ \evalCtx eval' mAuthId route _ -> do
|
||||
mr <- getMsgRenderer
|
||||
let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
|
||||
orAR' = shortCircuitM (is _Authorized) (orAR mr)
|
||||
_andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
|
||||
|
||||
workflowInstanceWorkflowsEmpty rScope win = workflowsEnabledAuth $ selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
|
||||
roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ do
|
||||
scope <- fromRouteWorkflowScope rScope
|
||||
let dbScope = scope ^. _DBWorkflowScope
|
||||
getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do
|
||||
E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
|
||||
E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope
|
||||
return workflowWorkflow
|
||||
workflowRoles (Entity wwId WorkflowWorkflow{..}) = do
|
||||
wwGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
let
|
||||
nodeViewers = do
|
||||
WorkflowAction{..} <- otoList workflowWorkflowState
|
||||
(node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
|
||||
guard $ node == wpTo
|
||||
WorkflowNodeView{..} <- hoistMaybe wgnViewers
|
||||
return $ toNullable wnvViewers
|
||||
payloadViewers = do
|
||||
(prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
|
||||
prevAct <- hoistMaybe $ prevActs ^? _last
|
||||
payload <- Map.keys $ wpPayload act
|
||||
guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
|
||||
fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
|
||||
return . Set.mapMonotonic ((workflowWorkflowScope, wwId), ) $ fold nodeViewers <> fold payloadViewers
|
||||
lift . runConduit $ getWorkflowWorkflows .| C.foldMapM workflowRoles
|
||||
let
|
||||
evalRole ((wwScope, wwId), role) = do
|
||||
rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope
|
||||
cID <- encrypt wwId
|
||||
let route' = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
|
||||
lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route' False
|
||||
guardM . fmap (isn't _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles)
|
||||
return AuthorizedI18n
|
||||
in case route of
|
||||
r | Just (rScope, WorkflowInstanceR win WIWorkflowsR) <- r ^? _WorkflowScopeRoute
|
||||
-> workflowInstanceWorkflowsEmpty rScope win
|
||||
EExamListR -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
|
||||
E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
|
||||
E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
|
||||
E.||. E.exists (E.from $ \externalExamResult ->
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
|
||||
E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
|
||||
)
|
||||
guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
||||
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
|
||||
assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthEmpty r
|
||||
tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _ -> case route of
|
||||
EExamListR -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
|
||||
E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
|
||||
E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
|
||||
E.||. E.exists (E.from $ \externalExamResult ->
|
||||
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
|
||||
E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
|
||||
)
|
||||
guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
||||
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
|
||||
assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthEmpty r
|
||||
tagAccessPredicate AuthMaterials = APDB $ \_ _ _ route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -1745,91 +1689,6 @@ tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case rout
|
||||
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthAuthentication r
|
||||
tagAccessPredicate AuthWorkflow = APDB $ \evalCtx eval' mAuthId route isWrite -> workflowsEnabledAuth $ do
|
||||
mr <- getMsgRenderer
|
||||
let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
|
||||
orAR' = shortCircuitM (is _Authorized) (orAR mr)
|
||||
_andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
|
||||
|
||||
|
||||
wInitiate win rScope = selectLanguageI18n <=< $memcacheAuthHere' (Right diffDay) (evalCtx, route, mAuthId) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowInitiate) $ do -- @isWrite@ not included since it should make no difference regarding initiation (in the end that will always be a write)
|
||||
roles <- memcacheAuth' @(Set (WorkflowRole UserId)) (Right diffDay) (AuthCacheWorkflowInstanceInitiators win rScope) $ do
|
||||
scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
|
||||
Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
|
||||
wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph
|
||||
return . fold $ do
|
||||
WGN{..} <- wiGraph ^.. _wgNodes . folded
|
||||
WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
|
||||
return wgeActors
|
||||
let evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId Nothing role route isWrite
|
||||
guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ toList roles)
|
||||
return AuthorizedI18n
|
||||
|
||||
wWorkflow isWrite' cID
|
||||
| isWrite' = maybeT (unauthorizedI MsgUnauthorizedWorkflowWrite) $ do
|
||||
(wwId, edges) <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowWorkflowEdgeActors cID) $ do
|
||||
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
|
||||
wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
|
||||
let
|
||||
wwNode = wpTo $ last workflowWorkflowState
|
||||
|
||||
return . (wwId, ) . (Set.fromList :: _ -> Set (WorkflowRole UserId)) . foldMap toNullable $ do
|
||||
WGN{..} <- wwGraph ^.. _wgNodes . folded
|
||||
WorkflowGraphEdgeManual{..} <- wgnEdges ^.. folded
|
||||
guard $ wgeSource == wwNode
|
||||
hoistMaybe . fromNullable $ wgeActors ^.. folded
|
||||
|
||||
let
|
||||
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
|
||||
guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList edges)
|
||||
return Authorized
|
||||
| otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do
|
||||
(wwId, roles) <- memcacheAuth' @(WorkflowWorkflowId, Set (WorkflowRole UserId)) (Right diffDay) (AuthCacheWorkflowWorkflowViewers cID) $ do
|
||||
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
|
||||
wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
|
||||
let
|
||||
nodeViewers = do
|
||||
WorkflowAction{..} <- otoList workflowWorkflowState
|
||||
(node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
|
||||
guard $ node == wpTo
|
||||
WorkflowNodeView{..} <- hoistMaybe wgnViewers
|
||||
return $ toNullable wnvViewers
|
||||
payloadViewers = do
|
||||
(prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
|
||||
prevAct <- hoistMaybe $ prevActs ^? _last
|
||||
payload <- Map.keys $ wpPayload act
|
||||
guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
|
||||
fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
|
||||
|
||||
return (wwId, fold nodeViewers <> fold payloadViewers)
|
||||
|
||||
let
|
||||
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
|
||||
guardM . fmap (is _Authorized) $ ofoldl1' orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable $ otoList roles)
|
||||
return Authorized
|
||||
wFiles wwCID wpl stCID = maybeT (unauthorizedI MsgUnauthorizedWorkflowFiles) $ do
|
||||
wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt wwCID
|
||||
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
|
||||
stIx <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decryptWorkflowStateIndex wwId stCID
|
||||
wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
act <- workflowStateIndex stIx $ _DBWorkflowState # workflowWorkflowState
|
||||
let
|
||||
cState = wpTo act
|
||||
payloadViewers = Map.findWithDefault Set.empty wpl $ toNullable . wpvViewers <$> Map.findWithDefault Map.empty cState (wgnPayloadView <$> wgNodes wwGraph)
|
||||
evalRole role = lift . evalWriterT $ evalWorkflowRoleFor' eval' mAuthId (Just wwId) role route isWrite
|
||||
guardM . anyM (otoList payloadViewers) $ fmap (is _Authorized) . evalRole
|
||||
guardM . lift . evalWriterT $ mayViewWorkflowAction' eval' mAuthId wwId act
|
||||
return Authorized
|
||||
|
||||
case route of
|
||||
_ | Just (rScope, WorkflowInstanceR win WIInitiateR) <- route ^? _WorkflowScopeRoute -> wInitiate win rScope
|
||||
_ | Just (_, WorkflowWorkflowR cID WWWorkflowR) <- route ^? _WorkflowScopeRoute -> wWorkflow isWrite cID
|
||||
_ | Just (_, WorkflowWorkflowR wwCID (WWFilesR wpl stCID)) <- route ^? _WorkflowScopeRoute -> wFiles wwCID wpl stCID
|
||||
r -> $unsupportedAuthPredicate AuthWorkflow r
|
||||
tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do
|
||||
MsgRenderer mr <- ask
|
||||
return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite
|
||||
@ -2021,155 +1880,6 @@ wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo rout
|
||||
wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route
|
||||
|
||||
|
||||
evalWorkflowRoleFor' :: forall m backend.
|
||||
( HasCallStack
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadAP (ReaderT backend m), MonadIO m
|
||||
, MonadThrow m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> (forall m'. MonadAP m' => AuthTagsEval m')
|
||||
-> Maybe UserId
|
||||
-> Maybe WorkflowWorkflowId
|
||||
-> WorkflowRole UserId
|
||||
-> Route UniWorX
|
||||
-> Bool
|
||||
-> WriterT (Set AuthTag) (ReaderT backend m) AuthResult
|
||||
evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = workflowsEnabledAuth $ do
|
||||
mr <- getMsgRenderer
|
||||
|
||||
let
|
||||
orAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
|
||||
orAR' = shortCircuitM (is _Authorized) (orAR mr)
|
||||
|
||||
orDefault = orAR' $ eval defaultAuthDNF mAuthId route isWrite
|
||||
|
||||
case wRole of
|
||||
WorkflowRoleUser{..} -> orDefault . lift . exceptT return return $ do
|
||||
uid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
unless (uid == workflowRoleUser) $
|
||||
throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
|
||||
return Authorized
|
||||
-- `WorkflowRoleInitiator` now means "during initiation".
|
||||
-- The old meaning can be emulated via `WorkflowRolePayloadReference`.
|
||||
WorkflowRoleInitiator{} -> orDefault $ if
|
||||
| is _Nothing mwwId -> return Authorized
|
||||
| otherwise -> unauthorizedI MsgWorkflowRoleAlreadyInitiated
|
||||
-- WorkflowRoleInitiator{} -> exceptT return return $ do
|
||||
-- wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) $ return mwwId
|
||||
-- WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
|
||||
-- let WorkflowAction{..} = head workflowWorkflowState
|
||||
-- wpUser' <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) . return $ review _SqlKey <$> join wpUser
|
||||
-- lift $ evalWorkflowRoleFor' tagActive mAuthId mwwId (WorkflowRoleUser wpUser') route isWrite
|
||||
WorkflowRolePayloadReference{..} -> orDefault . exceptT return return $ do
|
||||
uid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId
|
||||
Entity _ WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift $ getWorkflowWorkflowState wwId
|
||||
-- WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
|
||||
let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState
|
||||
unless (uid `Set.member` uids) $
|
||||
throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
|
||||
return Authorized
|
||||
WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite
|
||||
|
||||
evalWorkflowRoleFor :: ( HasCallStack
|
||||
, MonadAP (ReaderT backend m), MonadIO m
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> Maybe UserId
|
||||
-> Maybe WorkflowWorkflowId
|
||||
-> WorkflowRole UserId
|
||||
-> Route UniWorX
|
||||
-> Bool
|
||||
-> ReaderT backend m AuthResult
|
||||
evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = workflowsEnabledAuth $ do
|
||||
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
|
||||
tagActive <- if
|
||||
| isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
||||
| otherwise -> return . AuthTagActive $ const True
|
||||
(result, deactivated) <-
|
||||
let eval :: forall m'. MonadAP m' => AuthTagsEval m'
|
||||
eval dnf' mAuthId' route' isWrite' = evalAuthTags 'evalWorkflowRoleFor tagActive eval dnf' mAuthId' route' isWrite'
|
||||
in runWriterT $ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite
|
||||
when isSelf $
|
||||
tellSessionJson SessionInactiveAuthTags deactivated
|
||||
return result
|
||||
|
||||
hasWorkflowRole :: ( HasCallStack
|
||||
, MonadAP (ReaderT backend m)
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> Maybe WorkflowWorkflowId
|
||||
-> WorkflowRole UserId
|
||||
-> Route UniWorX
|
||||
-> Bool
|
||||
-> ReaderT backend m AuthResult
|
||||
hasWorkflowRole mwwId wRole route isWrite = workflowsEnabledAuth $ do
|
||||
mAuthId <- maybeAuthId
|
||||
evalWorkflowRoleFor mAuthId mwwId wRole route isWrite
|
||||
|
||||
mayViewWorkflowAction' :: forall backend m fileid.
|
||||
( HasCallStack
|
||||
, MonadAP (ReaderT backend m)
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCatch m
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> (forall m'. MonadAP m' => AuthTagsEval m')
|
||||
-> Maybe UserId
|
||||
-> WorkflowWorkflowId
|
||||
-> WorkflowAction fileid UserId
|
||||
-> WriterT (Set AuthTag) (ReaderT backend m) Bool
|
||||
mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = volatileBool clusterVolatileWorkflowsEnabled (return False) . hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do
|
||||
Entity _ WorkflowWorkflow{..} <- MaybeT . lift $ getWorkflowWorkflowState wwId
|
||||
rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId
|
||||
WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
evalWorkflowRole'' role = lift $ is _Authorized <$> evalWorkflowRoleFor' eval mAuthId (Just wwId) role canonRoute False
|
||||
WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers
|
||||
guardM $ orM
|
||||
[ return $ is _Just mAuthId && wpUser == Just mAuthId
|
||||
, anyM wnvViewers evalWorkflowRole''
|
||||
, anyM (Map.keys wpPayload) $ \payloadLbl -> lift . maybeT (return False) $ do
|
||||
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
|
||||
anyM wpvViewers evalWorkflowRole''
|
||||
]
|
||||
return True
|
||||
|
||||
mayViewWorkflowAction :: forall backend m fileid.
|
||||
( HasCallStack
|
||||
, MonadAP (ReaderT backend m)
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCatch m
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Maybe UserId
|
||||
-> WorkflowWorkflowId
|
||||
-> WorkflowAction fileid UserId
|
||||
-> ReaderT backend m Bool
|
||||
mayViewWorkflowAction mAuthId wwId act = volatileBool clusterVolatileWorkflowsEnabled (return False) $ do
|
||||
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
|
||||
tagActive <- if
|
||||
| isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
||||
| otherwise -> return . AuthTagActive $ const True
|
||||
(result, deactivated) <-
|
||||
let eval :: forall m'. MonadAP m' => AuthTagsEval m'
|
||||
eval dnf' mAuthId' route' isWrite' = evalAuthTags 'mayViewWorkflowAction tagActive eval dnf' mAuthId' route' isWrite'
|
||||
in runWriterT $ mayViewWorkflowAction' eval mAuthId wwId act
|
||||
when isSelf $
|
||||
tellSessionJson SessionInactiveAuthTags deactivated
|
||||
return result
|
||||
|
||||
|
||||
authoritiveApproot :: Route UniWorX -> ApprootScope
|
||||
authoritiveApproot = \case
|
||||
CourseR _ _ _ (MaterialR _ (MFileR _)) -> ApprootUserGenerated
|
||||
@ -2183,5 +1893,4 @@ authoritiveApproot = \case
|
||||
CourseR _ _ _ CRegisterTemplateR -> ApprootUserGenerated
|
||||
CourseR _ _ _ CAppsFilesR -> ApprootUserGenerated
|
||||
CourseR _ _ _ (CourseApplicationR _ CAFilesR) -> ApprootUserGenerated
|
||||
route | Just (_, WorkflowWorkflowR _ (WWFilesR _ _)) <- route ^? _WorkflowScopeRoute -> ApprootUserGenerated
|
||||
_other -> ApprootDefault
|
||||
|
||||
@ -4,7 +4,7 @@
|
||||
module Foundation.I18n
|
||||
( appLanguages, appLanguagesOpts
|
||||
, UniWorXMessage(..), UniWorXTestMessage(..), UniWorXSettingsMessage(..)
|
||||
, UniWorXHelpMessage(..), UniWorXNavigationMessage(..), UniWorXWorkflowMessage(..)
|
||||
, UniWorXHelpMessage(..), UniWorXNavigationMessage(..)
|
||||
, UniWorXCourseMessage(..), UniWorXAllocationMessage(..), UniWorXExamMessage(..)
|
||||
, UniWorXSheetMessage(..), UniWorXAdminMessage(..), UniWorXSubmissionMessage(..)
|
||||
, UniWorXTutorialMessage(..), UniWorXUserMessage(..), UniWorXButtonMessage(..)
|
||||
@ -26,8 +26,7 @@ module Foundation.I18n
|
||||
, StudyDegreeTerm(..)
|
||||
, ShortStudyFieldType(..)
|
||||
, StudyDegreeTermType(..)
|
||||
, ErrorResponseTitle(..)
|
||||
, WorkflowPayloadBool(..)
|
||||
, ErrorResponseTitle(..)
|
||||
, UniWorXMessages(..)
|
||||
, uniworxMessages
|
||||
, unRenderMessage, unRenderMessage', unRenderMessageLenient
|
||||
@ -59,9 +58,7 @@ import Data.Text.Lens (packed)
|
||||
|
||||
import Data.List ((!!))
|
||||
|
||||
import qualified Data.Scientific as Scientific
|
||||
|
||||
import Utils.Workflow (RouteWorkflowScope)
|
||||
-- import qualified Data.Scientific as Scientific
|
||||
|
||||
import Foundation.I18n.TH
|
||||
|
||||
@ -159,7 +156,6 @@ mkMessageAddition ''UniWorX "Test" "messages/uniworx/test" "de-de-formal"
|
||||
mkMessageAddition ''UniWorX "Settings" "messages/uniworx/categories/settings" "de-de-formal"
|
||||
mkMessageAddition ''UniWorX "Help" "messages/uniworx/categories/help" "de-de-formal"
|
||||
mkMessageAddition ''UniWorX "Navigation" "messages/uniworx/utils/navigation" "de-de-formal"
|
||||
mkMessageAddition ''UniWorX "Workflow" "messages/uniworx/categories/workflows" "de-de-formal"
|
||||
mkMessageAddition ''UniWorX "Course" "messages/uniworx/categories/courses/courses" "de-de-formal"
|
||||
mkMessageAddition ''UniWorX "Allocation" "messages/uniworx/categories/courses/allocation" "de-de-formal"
|
||||
mkMessageAddition ''UniWorX "Exam" "messages/uniworx/categories/courses/exam" "de-de-formal"
|
||||
@ -200,14 +196,18 @@ mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal"
|
||||
|
||||
instance RenderMessage UniWorX TermIdentifier where
|
||||
renderMessage foundation ls TermIdentifier{..} = case season of
|
||||
Summer -> renderMessage' $ MsgSummerTerm year
|
||||
Winter -> renderMessage' $ MsgWinterTerm year
|
||||
Q1 -> renderMessage' $ MsgQuarter1st year
|
||||
Q2 -> renderMessage' $ MsgQuarter2nd year
|
||||
Q3 -> renderMessage' $ MsgQuarter3rd year
|
||||
Q4 -> renderMessage' $ MsgQuarter4th year
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
|
||||
instance RenderMessage UniWorX ShortTermIdentifier where
|
||||
renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
|
||||
Summer -> renderMessage' $ MsgSummerTermShort year
|
||||
Winter -> renderMessage' $ MsgWinterTermShort year
|
||||
Q1 -> renderMessage' $ MsgQuarter1stShort year
|
||||
Q2 -> renderMessage' $ MsgQuarter2ndShort year
|
||||
Q3 -> renderMessage' $ MsgQuarter3rdShort year
|
||||
Q4 -> renderMessage' $ MsgQuarter4thShort year
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
|
||||
instance RenderMessage UniWorX String where
|
||||
@ -294,7 +294,6 @@ embedRenderMessage ''UniWorX ''ExamOnlinePreset id
|
||||
embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id
|
||||
embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
|
||||
embedRenderMessage ''UniWorX ''ChangelogItemKind id
|
||||
embedRenderMessage ''UniWorX ''WorkflowScope' $ ("WorkflowScopeKind" <>) . concat . drop 1 . splitCamel . fromMaybe (error "Expected WorkflowScope' to have '") . stripSuffix "'"
|
||||
embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'"
|
||||
|
||||
embedRenderMessage ''UniWorX ''AuthenticationMode id
|
||||
@ -438,9 +437,6 @@ instance HasResolution a => ToMessage (Fixed a) where
|
||||
newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
|
||||
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
|
||||
|
||||
newtype WorkflowPayloadBool = WorkflowPayloadBool { unWorkflowPayloadBool :: Bool }
|
||||
embedRenderMessageVariant ''UniWorX ''WorkflowPayloadBool ("WorkflowPayloadBool" <>)
|
||||
|
||||
|
||||
newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
|
||||
deriving stock (Generic, Typeable)
|
||||
@ -498,17 +494,6 @@ instance RenderMessage UniWorX ShortWeekDay where
|
||||
|
||||
embedRenderMessage ''UniWorX ''ButtonSubmit id
|
||||
|
||||
instance RenderMessage UniWorX RouteWorkflowScope where
|
||||
renderMessage foundation ls = \case
|
||||
WSGlobal -> mr MsgWorkflowScopeGlobal
|
||||
WSTerm{..} -> mr . ShortTermIdentifier $ unTermKey wisTerm
|
||||
WSSchool{..} -> mr $ unSchoolKey wisSchool
|
||||
WSTermSchool{..} -> mr $ MsgWorkflowScopeTermSchool wisTerm 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' :: (Ord a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
|
||||
unRenderMessage' cmp foundation inp = nubOrd $ do
|
||||
|
||||
@ -37,18 +37,6 @@ import Control.Monad.Trans.State (execStateT)
|
||||
|
||||
import Yesod.Core.Types (HandlerContents)
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import Utils.Workflow
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.List (inits)
|
||||
|
||||
import Utils.VolatileClusterSettings
|
||||
|
||||
|
||||
type Breadcrumb = (Text, Maybe (Route UniWorX))
|
||||
|
||||
@ -123,33 +111,7 @@ breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
||||
School{..} <- MaybeT $ get ssh
|
||||
isAdmin <- lift $ hasReadAccessTo SchoolListR
|
||||
return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
|
||||
|
||||
SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR
|
||||
SchoolWorkflowInstanceNewR -> i18nCrumb MsgBreadcrumbWorkflowInstanceNew . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
||||
SchoolWorkflowInstanceR win sRoute' -> case sRoute' of
|
||||
SWIEditR -> do
|
||||
desc <- useRunDB . runMaybeT $ do
|
||||
guardM . lift . hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIWorkflowsR
|
||||
wiId <- MaybeT . getKeyBy . UniqueWorkflowInstance win . WSSchool $ unSchoolKey ssh
|
||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||
let bRoute = SchoolR ssh SchoolWorkflowInstanceListR
|
||||
case desc of
|
||||
Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just bRoute
|
||||
Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just bRoute
|
||||
SWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
SWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
SWIInitiateR -> useRunDB $ do
|
||||
mayEdit <- hasReadAccessTo . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if
|
||||
| mayEdit -> SchoolWorkflowInstanceR win SWIEditR
|
||||
| otherwise -> SchoolWorkflowInstanceListR
|
||||
SWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR
|
||||
SchoolWorkflowWorkflowListR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowList . Just $ SchoolR ssh SchoolWorkflowInstanceListR
|
||||
SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of
|
||||
SWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh SchoolWorkflowWorkflowListR
|
||||
SWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
||||
SWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
||||
SWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just . SchoolR ssh $ SchoolWorkflowWorkflowR cID SWWWorkflowR
|
||||
|
||||
breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR
|
||||
|
||||
breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing
|
||||
@ -397,50 +359,6 @@ breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of
|
||||
EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR
|
||||
|
||||
breadcrumb AdminWorkflowDefinitionListR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionList $ Just AdminR
|
||||
breadcrumb AdminWorkflowDefinitionNewR = i18nCrumb MsgBreadcrumbAdminWorkflowDefinitionNew $ Just AdminWorkflowDefinitionListR
|
||||
breadcrumb (AdminWorkflowDefinitionR wfdScope wfdName sRoute) = case sRoute of
|
||||
AWDEditR -> do
|
||||
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 (AdminWorkflowInstanceR _cID sRoute) = case sRoute of
|
||||
AWIEditR -> i18nCrumb MsgBreadcrumbAdminWorkflowInstanceEdit $ Just AdminWorkflowInstanceListR
|
||||
breadcrumb AdminWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowList $ Just AdminWorkflowInstanceListR
|
||||
breadcrumb AdminWorkflowWorkflowNewR = i18nCrumb MsgBreadcrumbAdminWorkflowWorkflowNew $ Just AdminWorkflowWorkflowListR
|
||||
|
||||
breadcrumb GlobalWorkflowInstanceListR = i18nCrumb MsgBreadcrumbGlobalWorkflowInstanceList Nothing
|
||||
breadcrumb GlobalWorkflowInstanceNewR = i18nCrumb MsgBreadcrumbWorkflowInstanceNew $ Just GlobalWorkflowInstanceListR
|
||||
breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of
|
||||
GWIEditR -> do
|
||||
desc <- useRunDB . runMaybeT $ do
|
||||
guardM . lift . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIWorkflowsR
|
||||
wiId <- MaybeT . getKeyBy $ UniqueWorkflowInstance win WSGlobal
|
||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||
case desc of
|
||||
Nothing -> i18nCrumb (MsgBreadcrumbWorkflowInstanceEdit win) $ Just GlobalWorkflowInstanceListR
|
||||
Just (Entity _ WorkflowInstanceDescription{..}) -> i18nCrumb workflowInstanceDescriptionTitle $ Just GlobalWorkflowInstanceListR
|
||||
GWIDeleteR -> i18nCrumb MsgBreadcrumbWorkflowInstanceDelete . Just $ GlobalWorkflowInstanceR win GWIEditR
|
||||
GWIWorkflowsR -> i18nCrumb MsgBreadcrumbWorkflowInstanceWorkflowList . Just $ GlobalWorkflowInstanceR win GWIEditR
|
||||
GWIInitiateR -> do
|
||||
mayEdit <- useRunDB . hasReadAccessTo $ GlobalWorkflowInstanceR win GWIEditR
|
||||
i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if
|
||||
| mayEdit -> GlobalWorkflowInstanceR win GWIEditR
|
||||
| otherwise -> GlobalWorkflowInstanceListR
|
||||
GWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just $ GlobalWorkflowInstanceR win GWIEditR
|
||||
breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR
|
||||
breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of
|
||||
GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowWorkflowListR
|
||||
GWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
||||
GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
||||
GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
|
||||
|
||||
breadcrumb TopWorkflowInstanceListR = i18nCrumb MsgBreadcrumbTopWorkflowInstanceList Nothing
|
||||
breadcrumb TopWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbTopWorkflowWorkflowList $ Just TopWorkflowInstanceListR
|
||||
|
||||
|
||||
data NavQuickView
|
||||
= NavQuickViewFavourite
|
||||
@ -535,9 +453,6 @@ type family ChildrenNavChildren a where
|
||||
|
||||
data NavigationCacheKey
|
||||
= NavCacheRouteAccess AuthContext NavType (Route UniWorX)
|
||||
| NavCacheHaveWorkflowWorkflowsRoles RouteWorkflowScope
|
||||
| NavCacheHaveTopWorkflowInstancesRoles | NavCacheHaveTopWorkflowWorkflowsRoles
|
||||
| NavCacheHaveTopWorkflowsInstances AuthContext
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
deriving stock instance Eq (AuthId UniWorX) => Eq NavigationCacheKey
|
||||
@ -573,8 +488,8 @@ navLinkAccess NavLink{..} = case navAccess' of
|
||||
|
||||
defaultLinks :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, WithRunDB SqlReadBackend (HandlerFor UniWorX) m
|
||||
-- , MonadThrow m
|
||||
-- , WithRunDB SqlReadBackend (HandlerFor UniWorX) m
|
||||
, BearerAuthSite UniWorX
|
||||
) => m [Nav]
|
||||
defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
|
||||
@ -758,39 +673,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
, do
|
||||
guardVolatile clusterVolatileWorkflowsEnabled
|
||||
|
||||
authCtx <- getAuthContext
|
||||
(haveInstances, haveWorkflows) <- lift . memcachedBy (Just . Right $ 2 * diffMinute) (NavCacheHaveTopWorkflowsInstances authCtx) . useRunDB $ (,)
|
||||
<$> haveTopWorkflowInstances
|
||||
<*> haveTopWorkflowWorkflows
|
||||
|
||||
if | haveInstances -> return NavHeader
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navIcon = IconMenuWorkflows
|
||||
, navLink = NavLink
|
||||
{ navLabel = MsgMenuTopWorkflowInstanceList
|
||||
, navRoute = TopWorkflowInstanceListR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
| haveWorkflows -> return NavHeader
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navIcon = IconMenuWorkflows
|
||||
, navLink = NavLink
|
||||
{ navLabel = MsgMenuTopWorkflowWorkflowListHeader
|
||||
, navRoute = TopWorkflowWorkflowListR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
| otherwise -> mzero
|
||||
, return NavHeaderContainer
|
||||
{ navHeaderRole = NavHeaderPrimary
|
||||
, navLabel = SomeMessage MsgMenuAdminHeading
|
||||
@ -844,14 +726,6 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, NavLink
|
||||
{ navLabel = MsgMenuAdminWorkflowDefinitionList
|
||||
, navRoute = AdminWorkflowDefinitionListR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, NavLink
|
||||
{ navLabel = MsgMenuAdminCrontab
|
||||
, navRoute = AdminCrontabR
|
||||
@ -2509,148 +2383,6 @@ pageActions ParticipantsListR = return
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions AdminWorkflowDefinitionListR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuAdminWorkflowDefinitionNew
|
||||
, navRoute = AdminWorkflowDefinitionNewR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuAdminWorkflowInstanceList
|
||||
, navRoute = AdminWorkflowInstanceListR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions (AdminWorkflowDefinitionR wds wdn AWDEditR) = return
|
||||
[ NavPageActionSecondary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuAdminWorkflowDefinitionDelete
|
||||
, navRoute = AdminWorkflowDefinitionR wds wdn AWDDeleteR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = True }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuAdminWorkflowDefinitionInstantiate
|
||||
, navRoute = AdminWorkflowDefinitionR wds wdn AWDInstantiateR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = True }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions AdminWorkflowInstanceListR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuAdminWorkflowInstanceNew
|
||||
, navRoute = AdminWorkflowInstanceNewR
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions route | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowScopeRoute = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowWorkflowList
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
|
||||
, navAccess' = NavAccessDB $ haveWorkflowWorkflows rScope
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions route | Just (rScope, WorkflowInstanceR win WIEditR) <- route ^? _WorkflowScopeRoute = return
|
||||
[ NavPageActionSecondary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowInstanceDelete
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIDeleteR)
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowInstanceWorkflows
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowInstanceInitiate
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions route | Just (rScope, WorkflowWorkflowR cID WWWorkflowR) <- route ^? _WorkflowScopeRoute = return
|
||||
[ NavPageActionSecondary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowWorkflowEdit
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWEditR)
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
, NavPageActionSecondary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuWorkflowWorkflowDelete
|
||||
, navRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWDeleteR)
|
||||
, navAccess' = NavAccessTrue
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
}
|
||||
]
|
||||
pageActions TopWorkflowInstanceListR = return
|
||||
[ NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuTopWorkflowWorkflowList
|
||||
, navRoute = TopWorkflowWorkflowListR
|
||||
, navAccess' = NavAccessDB haveTopWorkflowWorkflows
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions _ = return []
|
||||
|
||||
submissionList :: ( MonadIO m
|
||||
@ -2685,110 +2417,3 @@ pageQuickActions qView route = do
|
||||
-- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course
|
||||
evalAccessCorrector :: (MonadAP m, MonadThrow m) => TermId -> SchoolId -> CourseShorthand -> m AuthResult
|
||||
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
|
||||
|
||||
|
||||
haveWorkflowWorkflows
|
||||
:: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> RouteWorkflowScope
|
||||
-> ReaderT backend m Bool
|
||||
haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHereBinary rScope . maybeT (return False) $ do
|
||||
roles <- memcachedBy (Just $ Right diffDay) (NavCacheHaveWorkflowWorkflowsRoles rScope) $ do
|
||||
scope <- fromRouteWorkflowScope rScope
|
||||
|
||||
let
|
||||
getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
|
||||
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
return workflowWorkflow
|
||||
workflowRoles (Entity wwId WorkflowWorkflow{..}) = do
|
||||
wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
let
|
||||
nodeViewers = do
|
||||
WorkflowAction{..} <- otoList workflowWorkflowState
|
||||
(node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
|
||||
guard $ node == wpTo
|
||||
WorkflowNodeView{..} <- hoistMaybe wgnViewers
|
||||
return $ toNullable wnvViewers
|
||||
payloadViewers = do
|
||||
(prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
|
||||
prevAct <- hoistMaybe $ prevActs ^? _last
|
||||
payload <- Map.keys $ wpPayload act
|
||||
guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
|
||||
fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
|
||||
|
||||
cID <- encrypt wwId
|
||||
return . Set.mapMonotonic ((wwId, cID), ) $ fold nodeViewers <> fold payloadViewers
|
||||
|
||||
runConduit $ transPipe lift getWorkflows .| C.foldMapM workflowRoles
|
||||
|
||||
let
|
||||
evalRole ((wwId, cID), role) = do
|
||||
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
is _Authorized <$> hasWorkflowRole (Just wwId) role route False
|
||||
|
||||
lift $ anyM roles evalRole
|
||||
|
||||
haveTopWorkflowInstances, haveTopWorkflowWorkflows
|
||||
:: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> ReaderT backend m Bool
|
||||
haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHere . maybeT (return False) $ do
|
||||
roles <- memcachedBy @(Set ((RouteWorkflowScope, WorkflowInstanceName), WorkflowRole UserId)) (Just $ Right diffDay) NavCacheHaveTopWorkflowInstancesRoles $ do
|
||||
let
|
||||
getInstances = E.selectSource . E.from $ \workflowInstance -> do
|
||||
E.where_ . isTopWorkflowScopeSql $ workflowInstance E.^. WorkflowInstanceScope
|
||||
return workflowInstance
|
||||
instanceRoles (Entity _ WorkflowInstance{..}) = do
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
||||
wiGraph <- lift $ getSharedIdWorkflowGraph workflowInstanceGraph
|
||||
return . Set.mapMonotonic ((rScope, workflowInstanceName), ) . fold $ do
|
||||
WGN{..} <- wiGraph ^.. _wgNodes . folded
|
||||
WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
|
||||
return wgeActors
|
||||
runConduit $ transPipe lift getInstances .| C.foldMapM instanceRoles
|
||||
|
||||
let
|
||||
evalRole :: _ -> ReaderT SqlReadBackend (HandlerFor UniWorX) Bool
|
||||
evalRole ((rScope, win), role) = do
|
||||
let route = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
||||
is _Authorized <$> hasWorkflowRole Nothing role route False
|
||||
|
||||
lift $ anyM roles evalRole
|
||||
haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . $cachedHere . maybeT (return False) $ do
|
||||
roles <- memcachedBy (Just $ Right diffDay) NavCacheHaveTopWorkflowWorkflowsRoles $ do
|
||||
let
|
||||
getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
|
||||
E.where_ . isTopWorkflowScopeSql $ workflowWorkflow E.^. WorkflowWorkflowScope
|
||||
return workflowWorkflow
|
||||
workflowRoles (Entity wwId WorkflowWorkflow{..}) = do
|
||||
wwGraph <- lift $ getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
let
|
||||
nodeViewers = do
|
||||
WorkflowAction{..} <- otoList workflowWorkflowState
|
||||
(node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
|
||||
guard $ node == wpTo
|
||||
WorkflowNodeView{..} <- hoistMaybe wgnViewers
|
||||
return $ toNullable wnvViewers
|
||||
payloadViewers = do
|
||||
(prevActs, act) <- zip (inits $ otoList workflowWorkflowState) $ otoList workflowWorkflowState
|
||||
prevAct <- hoistMaybe $ prevActs ^? _last
|
||||
payload <- Map.keys $ wpPayload act
|
||||
guard $ Map.lookup payload (workflowStateCurrentPayloads prevActs) /= Map.lookup payload (wpPayload act)
|
||||
fmap (toNullable . wpvViewers) . hoistMaybe $ Map.lookup payload . wgnPayloadView =<< Map.lookup (wpTo prevAct) (wgNodes wwGraph)
|
||||
|
||||
cID <- encrypt wwId
|
||||
return . Set.mapMonotonic ((wwId, cID, rScope), ) $ fold nodeViewers <> fold payloadViewers
|
||||
runConduit $ transPipe lift getWorkflows .| C.foldMapM workflowRoles
|
||||
|
||||
let
|
||||
evalRole :: _ -> ReaderT SqlReadBackend (HandlerFor UniWorX) Bool
|
||||
evalRole ((wwId, cID, rScope), role) = do
|
||||
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
is _Authorized <$> hasWorkflowRole (Just wwId) role route False
|
||||
|
||||
lift $ anyM roles evalRole
|
||||
|
||||
@ -38,12 +38,6 @@ deriving instance Generic SchoolR
|
||||
deriving instance Generic ExamOfficeR
|
||||
deriving instance Generic CourseNewsR
|
||||
deriving instance Generic CourseEventR
|
||||
deriving instance Generic AdminWorkflowDefinitionR
|
||||
deriving instance Generic AdminWorkflowInstanceR
|
||||
deriving instance Generic GlobalWorkflowInstanceR
|
||||
deriving instance Generic GlobalWorkflowWorkflowR
|
||||
deriving instance Generic SchoolWorkflowInstanceR
|
||||
deriving instance Generic SchoolWorkflowWorkflowR
|
||||
deriving instance Generic AMatchingR
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
@ -65,12 +59,6 @@ deriving instance Ord SchoolR
|
||||
deriving instance Ord ExamOfficeR
|
||||
deriving instance Ord CourseNewsR
|
||||
deriving instance Ord CourseEventR
|
||||
deriving instance Ord AdminWorkflowDefinitionR
|
||||
deriving instance Ord AdminWorkflowInstanceR
|
||||
deriving instance Ord GlobalWorkflowInstanceR
|
||||
deriving instance Ord GlobalWorkflowWorkflowR
|
||||
deriving instance Ord SchoolWorkflowInstanceR
|
||||
deriving instance Ord SchoolWorkflowWorkflowR
|
||||
deriving instance Ord AMatchingR
|
||||
deriving instance Ord (Route UniWorX)
|
||||
|
||||
|
||||
@ -13,9 +13,6 @@ import Foundation.Authorization
|
||||
import Foundation.I18n
|
||||
|
||||
import Utils.Metrics
|
||||
import Utils.Workflow
|
||||
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
|
||||
import qualified Network.Wai as W
|
||||
import qualified Data.Aeson as JSON
|
||||
@ -23,8 +20,6 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
yesodMiddleware :: ( BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
@ -217,13 +212,9 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
|
||||
, ncTutorial
|
||||
, ncExam
|
||||
, ncExternalExam
|
||||
, ncAdminWorkflowDefinition
|
||||
, ncWorkflowInstance
|
||||
, ncWorkflowPayloadLabel
|
||||
, verifySubmission
|
||||
, verifyCourseApplication
|
||||
, verifyCourseNews
|
||||
, verifyWorkflowWorkflow
|
||||
, verifyCourseNews
|
||||
, verifyMaterialVideo
|
||||
, verifyAllocationMatchingLog
|
||||
]
|
||||
@ -299,28 +290,6 @@ 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
|
||||
ncWorkflowInstance = maybeOrig $ \route -> do
|
||||
(rScope, WorkflowInstanceR win _) <- hoistMaybe $ route ^? _WorkflowScopeRoute
|
||||
dbScope <- fmap (view _DBWorkflowScope) . hoist lift $ fromRouteWorkflowScope rScope
|
||||
Entity _ WorkflowInstance{..} <- lift . lift . getBy404 $ UniqueWorkflowInstance win dbScope
|
||||
caseChanged win workflowInstanceName
|
||||
return $ route
|
||||
& typesUsing @RouteChildren @WorkflowInstanceName . filtered (== win) .~ workflowInstanceName
|
||||
ncWorkflowPayloadLabel = maybeOrig $ \route -> do
|
||||
(_, WorkflowWorkflowR cID (WWFilesR wpl _)) <- hoistMaybe $ route ^? _WorkflowScopeRoute
|
||||
wwId <- decrypt cID
|
||||
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId . lift $ get wwId
|
||||
wwGraph <- lift . lift $ getSharedDBWorkflowGraph workflowWorkflowGraph
|
||||
[wpl'] <- return . filter (== wpl) . sortOn (CI.original . unWorkflowPayloadLabel) . foldMap Map.keys $ wgnPayloadView <$> wgNodes wwGraph
|
||||
(caseChanged `on` unWorkflowPayloadLabel) wpl wpl'
|
||||
return $ route
|
||||
& typesUsing @RouteChildren @WorkflowPayloadLabel . filtered (== wpl) .~ wpl'
|
||||
verifySubmission = maybeOrig $ \route -> do
|
||||
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
|
||||
sId <- decrypt cID
|
||||
@ -346,14 +315,6 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
|
||||
let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
verifyWorkflowWorkflow = maybeOrig $ \route -> do
|
||||
(_, WorkflowWorkflowR cID wwR) <- hoistMaybe $ route ^? _WorkflowScopeRoute
|
||||
wwId <- decrypt cID
|
||||
WorkflowWorkflow{..} <- lift . lift $ get404 wwId
|
||||
rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
let newRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID wwR)
|
||||
tell . Any $ route /= newRoute
|
||||
return newRoute
|
||||
verifyMaterialVideo = maybeOrig $ \route -> do
|
||||
CMaterialR _tid _ssh _csh _mnm (MVideoR cID) <- return route
|
||||
mfId <- decrypt cID
|
||||
|
||||
@ -435,7 +435,7 @@ getCourseNewR = do
|
||||
let newTemplate = courseToForm oldTemplate mempty mempty Nothing in
|
||||
return $ Just $ newTemplate
|
||||
{ cfCourseId = Nothing
|
||||
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
|
||||
, cfTerm = TermKey $ TermIdentifier 0 Q1 -- invalid, will be ignored; undefined won't work due to strictness
|
||||
, cfRegFrom = Nothing
|
||||
, cfRegTo = Nothing
|
||||
, cfDeRegUntil = Nothing
|
||||
|
||||
@ -7,6 +7,7 @@ module Handler.Term
|
||||
import Import
|
||||
|
||||
import Utils.Course (mayViewCourse)
|
||||
import Utils.Holidays (bankHolidaysAreaSet, Feiertagsgebiet(..))
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
@ -19,46 +20,13 @@ import qualified Data.Set as Set
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import Data.Time.Calendar.WeekDate
|
||||
|
||||
|
||||
data TermDay
|
||||
= TermDayStart | TermDayEnd
|
||||
| TermDayLectureStart | TermDayLectureEnd
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
guessDay :: TermIdentifier
|
||||
-> TermDay
|
||||
-> Day
|
||||
guessDay TermIdentifier{ year, season = Winter } TermDayStart
|
||||
= fromGregorian year 10 1
|
||||
guessDay TermIdentifier{ year, season = Winter } TermDayEnd
|
||||
= fromGregorian (succ year) 3 31
|
||||
guessDay TermIdentifier{ year, season = Summer } TermDayStart
|
||||
= fromGregorian year 4 1
|
||||
guessDay TermIdentifier{ year, season = Summer } TermDayEnd
|
||||
= fromGregorian year 9 30
|
||||
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureStart
|
||||
= fromWeekDate year (wWeekStart + 2) 1
|
||||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureEnd
|
||||
= fromWeekDate (succ year) ((wWeekStart + 21) `div` bool 53 54 longYear) 5
|
||||
where longYear = is _Just $ fromWeekDateValid year 53 1
|
||||
(_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureStart
|
||||
= fromWeekDate year (wWeekStart + 2) 1
|
||||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureEnd
|
||||
= fromWeekDate year (wWeekStart + 17) 5
|
||||
where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
|
||||
|
||||
validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> FormValidator TermForm m ()
|
||||
validateTerm = do
|
||||
TermForm{..} <- State.get
|
||||
guardValidation MsgTermStartMustMatchName $ tfStart `withinTerm` tfName
|
||||
guardValidation MsgTermStartMustMatchName $ tfStart `withinTermYear` tfName
|
||||
guardValidation MsgTermEndMustBeAfterStart $ tfStart < tfEnd
|
||||
guardValidation MsgTermLectureEndMustBeAfterStart $ tfLectureStart < tfLectureEnd
|
||||
guardValidation MsgTermStartMustBeBeforeLectureStart $ tfStart <= tfLectureStart
|
||||
@ -173,13 +141,22 @@ postTermEditR = do
|
||||
let template = case mbLastTerm of
|
||||
Nothing -> mempty
|
||||
(Just Entity{ entityVal=Term{..}})
|
||||
-> let ntid = succ termName
|
||||
-> let ntid = succ termName
|
||||
tStart = guessDay ntid TermDayStart
|
||||
tEnd = guessDay ntid TermDayEnd
|
||||
tLecStart = guessDay ntid TermDayLectureStart
|
||||
tLecEnd = guessDay ntid TermDayLectureEnd
|
||||
tHolys = Set.toAscList $
|
||||
Set.filter (tStart <=) $
|
||||
Set.filter (tEnd >=) $
|
||||
Set.unions $ bankHolidaysAreaSet Fraport <$> [getYear tStart..getYear tEnd]
|
||||
in mempty
|
||||
{ tftName = Just ntid
|
||||
, tftStart = Just $ guessDay ntid TermDayStart
|
||||
, tftEnd = Just $ guessDay ntid TermDayEnd
|
||||
, tftLectureStart = Just $ guessDay ntid TermDayLectureStart
|
||||
, tftLectureEnd = Just $ guessDay ntid TermDayLectureEnd
|
||||
{ tftName = Just ntid
|
||||
, tftStart = Just tStart
|
||||
, tftEnd = Just tEnd
|
||||
, tftLectureStart = Just tLecStart
|
||||
, tftLectureEnd = Just tLecEnd
|
||||
, tftHolidays = Just tHolys
|
||||
}
|
||||
termEditHandler Nothing template
|
||||
|
||||
@ -228,8 +205,9 @@ termEditHandler mtid template = do
|
||||
lift . audit $ TransactionTermEdit tid
|
||||
addMessageI Success $ MsgTermEdited tid
|
||||
redirect TermShowR
|
||||
FormMissing -> return ()
|
||||
(FormFailure _) -> addMessageI Warning MsgInvalidInput
|
||||
FormMissing -> return ()
|
||||
FormFailure [] -> addMessageI Error MsgInvalidInput
|
||||
FormFailure msgs -> forM_ msgs (addMessage Error . toHtml)
|
||||
defaultLayout $ do
|
||||
setTitleI MsgTermEditHeading
|
||||
wrapForm formWidget def
|
||||
|
||||
@ -15,7 +15,7 @@ module Handler.Utils.DateTime
|
||||
, addLocalDays
|
||||
, addOneWeek, addWeeks
|
||||
, weeksToAdd
|
||||
, setYear
|
||||
, setYear, getYear
|
||||
, ceilingQuarterHour
|
||||
, formatGregorianW
|
||||
) where
|
||||
@ -219,6 +219,11 @@ setYear year date = fromGregorian year m d
|
||||
where
|
||||
(_,m,d) = toGregorian date
|
||||
|
||||
getYear :: Day -> Integer
|
||||
getYear date = y
|
||||
where
|
||||
(y,_,_) = toGregorian date
|
||||
|
||||
addOneWeek :: UTCTime -> UTCTime
|
||||
addOneWeek = addWeeks 1
|
||||
|
||||
|
||||
@ -72,9 +72,8 @@ import qualified Data.ByteString.Base64.URL as Base64
|
||||
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import Control.Monad.Catch.Pure (runCatch)
|
||||
-- import qualified Data.Yaml as Yaml
|
||||
-- import Control.Monad.Catch.Pure (runCatch)
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
@ -1436,10 +1435,10 @@ jsonField fieldKind = Field{..}
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
{- was only used in workflows; if needed recreate MsgYAMLFieldDecodeFailure
|
||||
yamlField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) UniWorXWorkflowMessage
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
)
|
||||
=> Field m a
|
||||
yamlField = Field{..}
|
||||
@ -1454,7 +1453,7 @@ yamlField = Field{..}
|
||||
#{either id (decodeUtf8 . Yaml.encode) val}
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
-}
|
||||
|
||||
boolField :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
|
||||
@ -1,29 +0,0 @@
|
||||
module Handler.Utils.Workflow
|
||||
( workflowsDisabledWarning
|
||||
, module Reexport
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils.I18n
|
||||
|
||||
import Handler.Utils.Workflow.Form as Reexport
|
||||
import Handler.Utils.Workflow.EdgeForm as Reexport
|
||||
import Handler.Utils.Workflow.Restriction as Reexport
|
||||
import Handler.Utils.Workflow.CanonicalRoute as Reexport
|
||||
import Handler.Utils.Workflow.Workflow as Reexport
|
||||
|
||||
|
||||
workflowsDisabledWarning :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, RenderMessage UniWorX titleMsg, RenderMessage UniWorX headingMsg
|
||||
)
|
||||
=> titleMsg -> headingMsg
|
||||
-> m Html
|
||||
-> m Html
|
||||
workflowsDisabledWarning tMsg hMsg = volatileBool clusterVolatileWorkflowsEnabled warningHtml
|
||||
where
|
||||
warningHtml = liftHandler . siteLayoutMsg hMsg $ do
|
||||
setTitleI tMsg
|
||||
|
||||
notificationWidget NotificationBroad Warning $(i18nWidgetFile "workflows-disabled")
|
||||
@ -1,93 +0,0 @@
|
||||
module Handler.Utils.Workflow.CanonicalRoute where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
import Foundation.Routes
|
||||
|
||||
import Utils.Workflow (RouteWorkflowScope)
|
||||
|
||||
|
||||
data WorkflowScopeRoute
|
||||
= WorkflowInstanceListR
|
||||
| WorkflowInstanceNewR
|
||||
| WorkflowInstanceR WorkflowInstanceName WorkflowInstanceR
|
||||
| WorkflowWorkflowListR
|
||||
| WorkflowWorkflowR CryptoFileNameWorkflowWorkflow WorkflowWorkflowR
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
data WorkflowInstanceR
|
||||
= WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR | WIUpdateR
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
data WorkflowWorkflowR
|
||||
= WWWorkflowR | WWFilesR WorkflowPayloadLabel CryptoUUIDWorkflowStateIndex | WWEditR | WWDeleteR
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
_WorkflowScopeRoute :: Prism' (Route UniWorX) (RouteWorkflowScope, WorkflowScopeRoute)
|
||||
_WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
|
||||
where
|
||||
toRoute = \case
|
||||
WSGlobal -> \case
|
||||
WorkflowInstanceListR -> GlobalWorkflowInstanceListR
|
||||
WorkflowInstanceNewR -> GlobalWorkflowInstanceNewR
|
||||
WorkflowInstanceR win subRoute -> GlobalWorkflowInstanceR win $ case subRoute of
|
||||
WIEditR -> GWIEditR
|
||||
WIDeleteR -> GWIDeleteR
|
||||
WIWorkflowsR -> GWIWorkflowsR
|
||||
WIInitiateR -> GWIInitiateR
|
||||
WIUpdateR -> GWIUpdateR
|
||||
WorkflowWorkflowListR -> GlobalWorkflowWorkflowListR
|
||||
WorkflowWorkflowR wwCID subRoute -> GlobalWorkflowWorkflowR wwCID $ case subRoute of
|
||||
WWWorkflowR -> GWWWorkflowR
|
||||
WWFilesR wpl stCID -> GWWFilesR wpl stCID
|
||||
WWEditR -> GWWEditR
|
||||
WWDeleteR -> GWWDeleteR
|
||||
WSSchool ssh -> SchoolR ssh . \case
|
||||
WorkflowInstanceListR -> SchoolWorkflowInstanceListR
|
||||
WorkflowInstanceNewR -> SchoolWorkflowInstanceNewR
|
||||
WorkflowInstanceR win subRoute -> SchoolWorkflowInstanceR win $ case subRoute of
|
||||
WIEditR -> SWIEditR
|
||||
WIDeleteR -> SWIDeleteR
|
||||
WIWorkflowsR -> SWIWorkflowsR
|
||||
WIInitiateR -> SWIInitiateR
|
||||
WIUpdateR -> SWIUpdateR
|
||||
WorkflowWorkflowListR -> SchoolWorkflowWorkflowListR
|
||||
WorkflowWorkflowR wwCID subRoute -> SchoolWorkflowWorkflowR wwCID $ case subRoute of
|
||||
WWWorkflowR -> SWWWorkflowR
|
||||
WWFilesR wpl stCID -> SWWFilesR wpl stCID
|
||||
WWEditR -> SWWEditR
|
||||
WWDeleteR -> SWWDeleteR
|
||||
other -> error $ "not implemented _WorkflowScopeRoute for: " <> show other
|
||||
toWorkflowScopeRoute = \case
|
||||
GlobalWorkflowInstanceListR -> Just ( WSGlobal, WorkflowInstanceListR )
|
||||
GlobalWorkflowInstanceNewR -> Just ( WSGlobal, WorkflowInstanceNewR )
|
||||
GlobalWorkflowInstanceR win subRoute -> Just . (WSGlobal, ) . WorkflowInstanceR win $ case subRoute of
|
||||
GWIEditR -> WIEditR
|
||||
GWIDeleteR -> WIDeleteR
|
||||
GWIWorkflowsR -> WIWorkflowsR
|
||||
GWIInitiateR -> WIInitiateR
|
||||
GWIUpdateR -> WIUpdateR
|
||||
GlobalWorkflowWorkflowListR -> Just ( WSGlobal, WorkflowWorkflowListR )
|
||||
GlobalWorkflowWorkflowR wwCID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of
|
||||
GWWWorkflowR -> WWWorkflowR
|
||||
GWWFilesR wpl stCID -> WWFilesR wpl stCID
|
||||
GWWEditR -> WWEditR
|
||||
GWWDeleteR -> WWDeleteR
|
||||
SchoolR ssh sRoute -> case sRoute of
|
||||
SchoolWorkflowInstanceListR -> Just ( WSSchool ssh, WorkflowInstanceListR )
|
||||
SchoolWorkflowInstanceNewR -> Just ( WSSchool ssh, WorkflowInstanceNewR )
|
||||
SchoolWorkflowInstanceR win subRoute -> Just . (WSSchool ssh, ) . WorkflowInstanceR win $ case subRoute of
|
||||
SWIEditR -> WIEditR
|
||||
SWIDeleteR -> WIDeleteR
|
||||
SWIWorkflowsR -> WIWorkflowsR
|
||||
SWIInitiateR -> WIInitiateR
|
||||
SWIUpdateR -> WIUpdateR
|
||||
SchoolWorkflowWorkflowListR -> Just ( WSSchool ssh, WorkflowWorkflowListR )
|
||||
SchoolWorkflowWorkflowR wwCID subRoute -> Just . (WSSchool ssh, ) . WorkflowWorkflowR wwCID $ case subRoute of
|
||||
SWWWorkflowR -> WWWorkflowR
|
||||
SWWFilesR wpl stCID -> WWFilesR wpl stCID
|
||||
SWWEditR -> WWEditR
|
||||
SWWDeleteR -> WWDeleteR
|
||||
_other -> Nothing
|
||||
_other -> Nothing
|
||||
@ -1,624 +0,0 @@
|
||||
module Handler.Utils.Workflow.EdgeForm
|
||||
( WorkflowEdgeForm(..)
|
||||
, workflowEdgeForm, WorkflowEdgeFormException(..)
|
||||
, workflowEdgeFormToAction
|
||||
) where
|
||||
|
||||
import Import hiding (StateT)
|
||||
|
||||
import Utils.Form
|
||||
import Utils.Workflow
|
||||
import Handler.Utils.Form
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
import Handler.Utils.Widgets
|
||||
import Handler.Utils.Workflow.Restriction
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import qualified ListT
|
||||
|
||||
import Data.RFC5051 (compareUnicode)
|
||||
import qualified Data.Text as Text
|
||||
import Text.Unidecode (unidecode)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map ((!), (!?))
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
|
||||
|
||||
import qualified Crypto.MAC.KMAC as Crypto
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteArray as BA
|
||||
import Crypto.Hash.Algorithms (SHAKE128, SHAKE256)
|
||||
import Crypto.MAC.KMAC (kmacGetDigest)
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Control.Monad.Trans.RWS.Lazy (runRWST, mapRWST)
|
||||
import Control.Monad.Trans.State.Strict (execState, evalStateT)
|
||||
import Control.Monad.Trans.RWS.Strict (RWST, evalRWST)
|
||||
|
||||
import Data.Bitraversable
|
||||
|
||||
import Data.List (findIndex)
|
||||
import qualified Data.List as List (delete)
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Scientific as Scientific
|
||||
|
||||
import Numeric.Lens (subtracting)
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
|
||||
import qualified Topograph
|
||||
|
||||
import qualified Text.Blaze as Blaze
|
||||
import qualified Text.Blaze.Renderer.Text as Blaze
|
||||
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
||||
|
||||
|
||||
data WorkflowEdgeForm = WorkflowEdgeForm
|
||||
{ wefEdge :: (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel)
|
||||
, wefPayload :: Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))
|
||||
}
|
||||
|
||||
data WorkflowEdgeFormException
|
||||
= WorkflowEdgeFormPayloadFieldReferenceCycle [WorkflowPayloadLabel]
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
workflowEdgeForm :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadHandler m'
|
||||
, HandlerSite m' ~ UniWorX
|
||||
, MonadUnliftIO m'
|
||||
, MonadThrow m'
|
||||
)
|
||||
=> Either WorkflowInstanceId WorkflowWorkflowId
|
||||
-> Maybe WorkflowEdgeForm
|
||||
-> SqlPersistT m' (Maybe (AForm m WorkflowEdgeForm))
|
||||
workflowEdgeForm mwwId mPrev = runMaybeT $ do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getWorkflowWorkflowState) mwwId
|
||||
let (scope, sharedGraphId) = case ctx' of
|
||||
Left (Entity _ WorkflowInstance{..}) -> ( _DBWorkflowScope # workflowInstanceScope
|
||||
, workflowInstanceGraph
|
||||
)
|
||||
Right (Entity _ WorkflowWorkflow{..}) -> ( _DBWorkflowScope # workflowWorkflowScope
|
||||
, workflowWorkflowGraph
|
||||
)
|
||||
graph <- lift $ getSharedIdWorkflowGraph sharedGraphId
|
||||
let wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo
|
||||
wPayload' = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState
|
||||
ctx = bimap entityVal entityVal ctx'
|
||||
mAuthId <- maybeAuthId
|
||||
wPayload <- case mwwId of
|
||||
Right wwId -> workflowStateCurrentPayloads <$> filterM (lift . hoist liftHandler . mayViewWorkflowAction mAuthId wwId) (maybe [] otoList wPayload')
|
||||
Left _ -> return Map.empty
|
||||
|
||||
rScope <- toRouteWorkflowScope scope
|
||||
|
||||
-- edges :: [((WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel), (I18nText, Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec FileReference UserId)))))]
|
||||
edges <- ListT.toList $ do
|
||||
(nodeLabel, WGN{..}) <- ListT.fromFoldable . Map.toList $ wgNodes graph
|
||||
(edgeLabel, edge) <- ListT.fromFoldable $ Map.toList wgnEdges
|
||||
((nodeLabel, edgeLabel), ) <$> case edge of
|
||||
WorkflowGraphEdgeManual{..} -> do
|
||||
guard $ Just wgeSource == wState
|
||||
wwId <- hoistMaybe $ mwwId ^? _Right
|
||||
cID <- lift $ encrypt wwId
|
||||
guardM . anyM (Set.toList wgeActors) $ \role ->
|
||||
lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) True
|
||||
return (wgeDisplayLabel, (wgeForm, wgeMessages))
|
||||
WorkflowGraphEdgeInitial{..} -> do
|
||||
guard $ is _Nothing wState
|
||||
win <- hoistMaybe $ ctx ^? _Left . _workflowInstanceName
|
||||
guardM . anyM (Set.toList wgeActors) $ \role ->
|
||||
lift . lift $ is _Authorized <$> hasWorkflowRole Nothing role (_WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)) True
|
||||
return (wgeDisplayLabel, (wgeForm, wgeMessages))
|
||||
_other -> mzero
|
||||
|
||||
guard . not $ null edges
|
||||
|
||||
-- edgesOptList :: OptionList (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel)
|
||||
edgesOptList <- do
|
||||
sBoxKey <- secretBoxKey
|
||||
|
||||
let olReadExternal ciphertext = do
|
||||
edgeIdent <- fromMaybeT . exceptTMaybe $ encodedSecretBoxOpen' sBoxKey ciphertext
|
||||
guard $ any (\(edgeIdent', _) -> edgeIdent == edgeIdent') edges
|
||||
return edgeIdent
|
||||
olOptions' <- ListT.toList $ do
|
||||
(edgeIdent, (edgeLabel, _)) <- ListT.fromFoldable edges
|
||||
optionDisplay <- lift $ selectLanguageI18n edgeLabel
|
||||
let optionInternalValue = edgeIdent
|
||||
optionExternalValue <- encodedSecretBox' sBoxKey SecretBoxShort edgeIdent
|
||||
return Option{..}
|
||||
let olOptions = concat $ do
|
||||
let optSort = (compareUnicode `on` (Text.toLower . optionDisplay))
|
||||
<> comparing (fallbackSortKey . optionInternalValue)
|
||||
where fallbackSortKey = toDigest . kmaclazy ("workflow-edge-sorting" :: ByteString) (Saltine.encode sBoxKey) . Binary.encode . (mwwId, )
|
||||
where toDigest :: Crypto.KMAC (SHAKE256 256) -> ByteString
|
||||
toDigest = BA.convert
|
||||
opts <- sortBy optSort olOptions'
|
||||
& foldr (\opt@Option{..} -> InsOrdHashMap.insertWith (<>) (Text.concatMap (pack . unidecode) optionDisplay) [opt]) InsOrdHashMap.empty
|
||||
& InsOrdHashMap.elems
|
||||
|
||||
if
|
||||
| [_] <- opts
|
||||
-> return opts
|
||||
| otherwise -> do
|
||||
return $ zipWith (\Option{..} i -> Option{ optionDisplay = mr $ MsgWorkflowEdgeNumberedVariant optionDisplay i, ..}) opts [1..]
|
||||
return OptionList{..}
|
||||
|
||||
let edges' = flip sortOn edges $ \(edgeIdent, _) -> flip findIndex (olOptions edgesOptList) $ (== edgeIdent) . optionInternalValue
|
||||
|
||||
let edgeForms :: Map (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) (AForm Handler WorkflowEdgeForm)
|
||||
edgeForms = Map.fromList . flip map edges' $ \(edgeIdent@(tState, _), (_, (WorkflowGraphEdgeForm{..}, edgeMessages))) -> (edgeIdent, ) . fmap (WorkflowEdgeForm edgeIdent) . wFormToAForm . fmap sequenceA $ do
|
||||
forM_ edgeMessages $ \WorkflowEdgeMessage{..} -> void . runMaybeT $ do
|
||||
let hasWorkflowRole' role = liftHandler . runDB $ case ctx' of
|
||||
Right (Entity wwId _) -> do
|
||||
cID <- encrypt wwId
|
||||
is _Authorized <$> hasWorkflowRole (Just wwId) role (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) True
|
||||
Left (Entity _ WorkflowInstance{..})
|
||||
-> is _Authorized <$> hasWorkflowRole Nothing role (_WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)) True
|
||||
guardM $ anyM (otoList wemViewers) hasWorkflowRole'
|
||||
whenIsJust wemRestriction $ guard . checkWorkflowRestriction wPayload'
|
||||
let messageStatus = wemStatus
|
||||
messageIcon = Nothing
|
||||
messageContent <- selectLanguageI18n wemContent
|
||||
lift $ wformMessage Message{..}
|
||||
|
||||
let fieldSort :: [(WorkflowPayloadLabel, [[(Either WorkflowGraphEdgeFormOrder ByteString, WorkflowPayloadSpec FileReference UserId)]])]
|
||||
-> _
|
||||
fieldSort
|
||||
= sortOn ((,) <$> foldOf (_2 . folded . folded . _1 . _Left) <*> foldMapOf (_2 . folded . folded . _1 . _Right) (Just . Min))
|
||||
. over (traverse . _2) (sortOn $ (,) <$> foldOf (folded . _1 . _Left) <*> foldMapOf (folded . _1 . _Right) (Just . Min))
|
||||
. over (traverse . _2 . traverse) (sortOn $ (,) <$> preview (_1 . _Left) <*> preview (_1 . _Right))
|
||||
orderedFields <- lift . lift . fmap fieldSort . for (Map.toList wgefFields) $ \(payloadLabel, Set.toList . toNullable -> payloadSpecs) -> fmap (payloadLabel, ) . for payloadSpecs $ \(Map.toList . toNullable -> payloadSpecs') -> for payloadSpecs' $ \(payloadOrder, payloadSpec) -> if
|
||||
| payloadOrder /= mempty -> return (Left payloadOrder, payloadSpec)
|
||||
| otherwise -> do
|
||||
sBoxKey <- secretBoxKey
|
||||
payloadSpec' <- traverseOf (typesCustom @WorkflowChildren @(WorkflowPayloadSpec FileReference UserId) @(WorkflowPayloadSpec FileReference CryptoUUIDUser) @UserId @CryptoUUIDUser) encrypt payloadSpec
|
||||
let toDigest :: Crypto.KMAC (SHAKE256 256) -> ByteString
|
||||
toDigest = BA.convert
|
||||
fallbackSortKey = toDigest . kmaclazy ("workflow-edge-form-payload-field-sorting" :: ByteString) (Saltine.encode sBoxKey) $ Aeson.encode (mwwId, payloadSpec')
|
||||
return (Right fallbackSortKey, payloadSpec)
|
||||
|
||||
orderedFields' <- flip evalStateT 1 . for orderedFields $ \x@(payloadLabel, _) -> do
|
||||
let generateDisplayLabel = State.state $ \n -> (mr $ MsgWorkflowEdgeFormHiddenPayload n, succ n)
|
||||
(mayView, payloadDisplayLabel) <- hoist (lift . lift . runDB) . maybeT ((False, ) <$> generateDisplayLabel) $
|
||||
let
|
||||
displayNameFromState s = do
|
||||
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLabel $ Map.findWithDefault Map.empty s (wgnPayloadView <$> wgNodes graph)
|
||||
wRoute <- case ctx' of
|
||||
Right (Entity wwId _) -> do
|
||||
cID <- encrypt wwId
|
||||
return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
Left (Entity _ WorkflowInstance{..})
|
||||
-> return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
guardM . anyM (Set.toList $ toNullable wpvViewers) $ \role ->
|
||||
lift . lift $ is _Authorized <$> hasWorkflowRole (mwwId ^? _Right) role wRoute False
|
||||
(True, ) <$> selectLanguageI18n wpvDisplayLabel
|
||||
in displayNameFromState tState <|> maybe mzero displayNameFromState wState
|
||||
return ((mayView, payloadDisplayLabel), x)
|
||||
|
||||
fields <- for orderedFields' $ \((mayView, payloadDisplayLabel), (payloadLabel, payloadSpecs)) -> (payloadLabel, ) <$> do
|
||||
let payloadSpecs' = payloadSpecs ^.. folded . folded . _2
|
||||
payloadFields = workflowEdgePayloadFields payloadSpecs' $ fmap otoList . Map.lookup payloadLabel =<< prevSrc
|
||||
where prevSrc = asum
|
||||
[ wefPayload <$> assertM ((== edgeIdent) . wefEdge) mPrev
|
||||
, guardOn mayView wPayload
|
||||
]
|
||||
((payloadRes, isOptional), payloadFieldViews) <- wFormFields payloadFields
|
||||
return ((payloadDisplayLabel, getAll isOptional), (payloadRes, payloadFieldViews))
|
||||
|
||||
fields' <-
|
||||
let payloadReferenceAdjacency = fieldsMap <&> setOf (_2 . _1 . folded . _Left)
|
||||
fieldsMap :: Map WorkflowPayloadLabel ((Text, Bool), ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], [FieldView UniWorX]))
|
||||
fieldsMap = Map.fromList fields
|
||||
resolveReferences :: forall i. Topograph.G WorkflowPayloadLabel i -> [(WorkflowPayloadLabel, ((Text, Bool), ([(Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], [FieldView UniWorX])))]
|
||||
resolveReferences Topograph.G{gVertices, gFromVertex} = resort . Map.toList . flip execState Map.empty . for topoOrder $ \payloadLabel -> whenIsJust (Map.lookup payloadLabel fieldsMap) $ \(payloadDisplay, (payloadRes, payloadFieldViews)) -> State.modify' $ \oldState ->
|
||||
let payloadRes' = flip concatMap payloadRes $ \case
|
||||
Right res -> pure res
|
||||
Left ref -> Map.lookup ref oldState ^. _Just . _2 . _1
|
||||
in Map.insert payloadLabel (payloadDisplay, (payloadRes', payloadFieldViews)) oldState
|
||||
where
|
||||
topoOrder = map gFromVertex gVertices
|
||||
resort = sortOn $ \(payloadLabel, _) -> findIndex (views _1 (== payloadLabel)) fields
|
||||
in either (throwM . WorkflowEdgeFormPayloadFieldReferenceCycle) return $ Topograph.runG payloadReferenceAdjacency resolveReferences
|
||||
|
||||
fmap Map.fromList . for fields' $ \(payloadLabel, ((payloadDisplayLabel, isOptional), (payloadRes, payloadFieldViews))) -> (payloadLabel, ) <$> do
|
||||
$logWarnS "WorkflowEdgeForm" $ toPathPiece payloadLabel <> ": " <> tshow payloadRes
|
||||
let payloadRes' = let res = foldMap (views _2 . fmap $ maybe Set.empty (Set.fromList . otoList)) payloadRes
|
||||
in if | doErrMsg -> FormFailure $ view _FormFailure res ++ pure (mr $ MsgWorkflowEdgeFormPayloadOneFieldRequiredFor payloadDisplayLabel)
|
||||
| otherwise -> res
|
||||
doErrMsg = flip none payloadRes $ \res -> view _1 res || hasn't (_2 . _FormSuccess) res
|
||||
addErrMsg pErrs = Just
|
||||
[shamlet|
|
||||
$newline never
|
||||
$maybe errs <- pErrs
|
||||
#{errs}
|
||||
<br />
|
||||
#{mr MsgWorkflowEdgeFormPayloadOneFieldRequired}
|
||||
|]
|
||||
case payloadFieldViews of
|
||||
[] -> return ()
|
||||
[fv] -> lift . tell . pure $ fv
|
||||
& _fvRequired .~ not isOptional
|
||||
& _fvErrors %~ bool id addErrMsg doErrMsg
|
||||
_other -> do
|
||||
fvId <- newIdent
|
||||
let fvLabel = toHtml payloadDisplayLabel
|
||||
fvTooltip = Nothing
|
||||
fvInput = renderFieldViews FormWorkflowDataset $ payloadFieldViews
|
||||
& traverse . _fvRequired .~ not isOptional
|
||||
fvErrors = bool id addErrMsg doErrMsg Nothing
|
||||
fvRequired = not isOptional
|
||||
in lift . tell $ pure FieldView{..}
|
||||
return payloadRes'
|
||||
|
||||
return . hoistAForm liftHandler . multiActionAOpts edgeForms (return edgesOptList) actFS $ wefEdge <$> mPrev
|
||||
where
|
||||
actFS = fslI MsgWorkflowEdgeFormEdge
|
||||
|
||||
workflowEdgePayloadFields :: [WorkflowPayloadSpec FileReference UserId]
|
||||
-> Maybe [WorkflowFieldPayloadW FileReference UserId]
|
||||
-> WForm Handler ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], All) -- ^ @isFilled@, @foldMap ala All . map isOptional@
|
||||
workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpecField) Nothing . fromMaybe []
|
||||
where
|
||||
renderSpecField :: WorkflowPayloadSpec FileReference UserId
|
||||
-> ExceptT WorkflowPayloadLabel (RWST (Maybe (Text -> Text)) All [WorkflowFieldPayloadW FileReference UserId] (MForm (WriterT [FieldView UniWorX] Handler))) (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
||||
renderSpecField (WorkflowPayloadSpec (specField :: WorkflowPayloadField FileReference UserId payload)) = do
|
||||
let f' :: forall payload' payload''.
|
||||
_
|
||||
=> (payload' -> Maybe (NonEmpty payload''))
|
||||
-> Bool -- ^ @isOpt@
|
||||
-> Field Handler payload'
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe payload'
|
||||
-> _ (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
||||
f' toNonEmpty' isOpt fld fs mx = lift . (<* tell (All isOpt)) . lift $ over (_2 . mapped) (fmap (fmap . review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . toNonEmpty' =<<) . bool (is (_FormSuccess . _Just) &&& id) (True, ) isOpt <$> wopt fld fs (Just <$> mx)
|
||||
f :: forall payload'.
|
||||
_
|
||||
=> Bool -- ^ @isOpt@
|
||||
-> Field Handler payload'
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe payload'
|
||||
-> _ (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
||||
f = f' (nonEmpty . pure)
|
||||
extractPrevs :: forall payload' m xs.
|
||||
( IsWorkflowFieldPayload' FileReference UserId payload'
|
||||
, State.MonadState [WorkflowFieldPayloadW FileReference UserId] m
|
||||
)
|
||||
=> (payload' -> Maybe xs -> Maybe xs)
|
||||
-> m (Maybe xs)
|
||||
extractPrevs accum = State.state $ foldl' go (Nothing, []) . map (matching $ _WorkflowFieldPayloadW @payload' @FileReference @UserId . _WorkflowFieldPayload)
|
||||
where go (mPrev', xs) (Left x) = (mPrev', xs ++ [x])
|
||||
go (acc, xs) (Right p) = case accum p acc of
|
||||
acc'@(Just _) -> (acc', xs)
|
||||
Nothing -> (acc, xs ++ [_WorkflowFieldPayloadW @payload' @FileReference @UserId . _WorkflowFieldPayload # p])
|
||||
extractPrev :: forall payload' m.
|
||||
( IsWorkflowFieldPayload' FileReference UserId payload'
|
||||
, State.MonadState [WorkflowFieldPayloadW FileReference UserId] m
|
||||
)
|
||||
=> m (Maybe payload')
|
||||
extractPrev = extractPrevs $ \p -> \case
|
||||
Nothing -> Just p
|
||||
Just _ -> Nothing
|
||||
|
||||
delTyp :: forall payload' m.
|
||||
( State.MonadState [WorkflowFieldPayloadW FileReference UserId] m
|
||||
, IsWorkflowFieldPayload' FileReference UserId payload'
|
||||
) => Proxy payload' -> m ()
|
||||
delTyp _ = State.modify $ \xs' ->
|
||||
let go [] = []
|
||||
go (x:xs) | is (_WorkflowFieldPayloadW @payload') x = xs
|
||||
| otherwise = x : go xs
|
||||
in go xs'
|
||||
|
||||
wSetTooltip' :: _ => Maybe Html -> t' (t (MForm (WriterT [FieldView UniWorX] Handler))) a -> t' (t (MForm (WriterT [FieldView UniWorX] Handler))) a
|
||||
wSetTooltip' tip = hoist (hoist (wSetTooltip tip))
|
||||
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
LanguageSelectI18n{..} <- getLanguageSelectI18n
|
||||
mNudge <- ask
|
||||
|
||||
case specField of
|
||||
WorkflowPayloadFieldText{..} | Nothing <- wpftPresets -> do
|
||||
prev <- extractPrev @Text
|
||||
wSetTooltip' (fmap slI18n wpftTooltip) $
|
||||
f wpftOptional
|
||||
(bool (textField & cfStrip) (textareaField & isoField _Wrapped & cfStrip) wpftLarge)
|
||||
( fsl (slI18n wpftLabel)
|
||||
& maybe id (addPlaceholder . slI18n) wpftPlaceholder
|
||||
& maybe id (addName . ($ "text")) mNudge
|
||||
)
|
||||
(prev <|> wpftDefault)
|
||||
WorkflowPayloadFieldText{..} | Just (otoList -> opts) <- wpftPresets -> do
|
||||
prev <- extractPrev @Text
|
||||
sBoxKey <- secretBoxKey
|
||||
let offerNothing = wpftOptional || minLength 2 specs
|
||||
optList = do
|
||||
WorkflowPayloadTextPreset{..} <- opts
|
||||
let optionExternalValue = toPathPiece @(Digest (SHAKE128 128)) . kmacGetDigest . kmaclazy ("payload-field-text-enum" :: ByteString) (Saltine.encode sBoxKey) $ Binary.encode optionInternalValue
|
||||
optionInternalValue = wptpText
|
||||
return ( Option
|
||||
{ optionDisplay = slI18n wptpLabel
|
||||
, ..
|
||||
}
|
||||
, toWidget . slI18n <$> wptpTooltip
|
||||
)
|
||||
readExternal = flip Map.lookup . Map.fromList $ map (views _1 (optionExternalValue &&& optionInternalValue)) optList
|
||||
doExplainedSelectionField = has (folded . _wptpTooltip . _Just) opts
|
||||
wSetTooltip' (fmap slI18n wpftTooltip) $
|
||||
f wpftOptional
|
||||
(bool (selectField' (guardOn offerNothing $ SomeMessage MsgWorkflowEdgeFormEnumFieldNothing) . return $ OptionList (optList ^.. folded . _1) readExternal)
|
||||
(explainedSelectionField (guardOn offerNothing (SomeMessage MsgWorkflowEdgeFormEnumFieldNothing, Nothing)) $ return (optList, readExternal))
|
||||
doExplainedSelectionField
|
||||
)
|
||||
( fsl (slI18n wpftLabel)
|
||||
& maybe id (addName . ($ "text")) mNudge
|
||||
)
|
||||
(prev <|> wpftDefault <|> preview (_head . _1 . to optionInternalValue) optList)
|
||||
WorkflowPayloadFieldNumber{..} -> do
|
||||
prev <- extractPrev @Scientific
|
||||
wSetTooltip' (fmap slI18n wpfnTooltip) $
|
||||
f wpfnOptional
|
||||
( fractionalField
|
||||
& maybe id (\wpfnMin' -> checkBool (>= wpfnMin') $ MsgWorkflowEdgeFormFieldNumberTooSmall wpfnMin') wpfnMin
|
||||
& maybe id (\wpfnMax' -> checkBool (>= wpfnMax') $ MsgWorkflowEdgeFormFieldNumberTooSmall wpfnMax') wpfnMax
|
||||
& maybe id (\wpfnStep' -> flip convertField id . over (maybe id subtracting wpfnMin) $ \n -> fromInteger (round $ n / wpfnStep') * wpfnStep') wpfnStep
|
||||
)
|
||||
( fsl (slI18n wpfnLabel)
|
||||
& maybe id (addPlaceholder . slI18n) wpfnPlaceholder
|
||||
& maybe id (addAttr "min" . tshow . formatScientific Scientific.Fixed Nothing) wpfnMin
|
||||
& maybe id (addAttr "max" . tshow . formatScientific Scientific.Fixed Nothing) wpfnMax
|
||||
& maybe (addAttr "step" "any") (addAttr "step" . tshow . formatScientific Scientific.Fixed Nothing) wpfnStep
|
||||
& maybe id (addName . ($ "number")) mNudge
|
||||
)
|
||||
(prev <|> wpfnDefault)
|
||||
WorkflowPayloadFieldBool{..} -> do
|
||||
prev <- extractPrev @Bool
|
||||
wSetTooltip' (fmap slI18n wpfbTooltip) $
|
||||
f (is _Just wpfbOptional)
|
||||
(maybe checkBoxField (boolField . Just . SomeMessage . slI18n) wpfbOptional)
|
||||
( fsl (slI18n wpfbLabel)
|
||||
& maybe id (addName . ($ "bool")) mNudge
|
||||
)
|
||||
(prev <|> wpfbDefault)
|
||||
WorkflowPayloadFieldDay{..} -> do
|
||||
cDay <- localDay . utcToLocalTime <$> liftIO getCurrentTime
|
||||
let checkPast, checkFuture :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Day -> Field m Day
|
||||
checkPast | Just offset <- wpfdMaxPast
|
||||
= checkBool ((<= offset) . (cDay `diffDays`)) $ MsgWorkflowEdgeFormFieldDayTooFarPast offset
|
||||
| otherwise = id
|
||||
checkFuture | Just offset <- wpfdMaxFuture
|
||||
= checkBool ((<= offset) . (`diffDays` cDay)) $ MsgWorkflowEdgeFormFieldDayTooFarFuture offset
|
||||
| otherwise = id
|
||||
prev <- extractPrev @Day
|
||||
wSetTooltip' (fmap slI18n wpfdTooltip) $
|
||||
f wpfdOptional
|
||||
( dayField & checkPast & checkFuture )
|
||||
( fsl (slI18n wpfdLabel)
|
||||
& maybe id (addName . ($ "day")) mNudge
|
||||
)
|
||||
(prev <|> wpfdDefault)
|
||||
WorkflowPayloadFieldFile{..} -> do
|
||||
fRefs <- extractPrevs @FileReference $ \p -> if
|
||||
| fieldMultiple wpffConfig -> Just . maybe (Set.singleton p) (Set.insert p)
|
||||
| otherwise -> \case
|
||||
Nothing -> Just $ Set.singleton p
|
||||
Just _ -> Nothing
|
||||
let wpffConfig' = wpffConfig & _fieldAdditionalFiles %~ (fRefs' <>)
|
||||
where fRefs' = review _FileReferenceFileReferenceTitleMap . Map.fromList $ do
|
||||
FileReference{..} <- Set.toList =<< hoistMaybe fRefs
|
||||
return (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
||||
wSetTooltip' (fmap slI18n wpffTooltip) $
|
||||
f' (nonEmpty . Set.toList) wpffOptional
|
||||
(convertFieldM (\p -> runConduit $ transPipe liftHandler p .| C.foldMap Set.singleton) yieldMany . genericFileField $ return wpffConfig')
|
||||
( fsl (slI18n wpffLabel)
|
||||
& maybe id (addName . ($ "file")) mNudge
|
||||
)
|
||||
fRefs
|
||||
WorkflowPayloadFieldUser{..} -> do
|
||||
fRefs <- extractPrev @UserId
|
||||
let suggestions uid = E.from $ \user -> do
|
||||
E.where_ $ user E.^. UserId E.==. E.val uid
|
||||
return user
|
||||
wSetTooltip' (fmap slI18n wpfuTooltip) $
|
||||
f wpfuOptional
|
||||
(checkMap (first $ const MsgWorkflowEdgeFormFieldUserNotFound) Right . userField False $ suggestions <$> fRefs)
|
||||
( fslI (slI18n wpfuLabel)
|
||||
& maybe id (addName . ($ "user")) mNudge
|
||||
)
|
||||
(fRefs <|> wpfuDefault)
|
||||
WorkflowPayloadFieldCaptureUser -> do
|
||||
mAuthId <- liftHandler maybeAuth
|
||||
case mAuthId of
|
||||
Just (Entity uid User{userDisplayName, userSurname}) -> do
|
||||
fvId <- newIdent
|
||||
State.modify . List.delete $ _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid
|
||||
lift . lift . lift . tell $ pure FieldView
|
||||
{ fvLabel = [shamlet|#{mr MsgWorkflowEdgeFormFieldCaptureUserLabel}|]
|
||||
, fvTooltip = Nothing
|
||||
, fvId
|
||||
, fvInput = [whamlet|
|
||||
$newline never
|
||||
<span ##{fvId}>
|
||||
^{nameWidget userDisplayName userSurname}
|
||||
|]
|
||||
, fvErrors = Nothing
|
||||
, fvRequired = False
|
||||
}
|
||||
(True, FormSuccess . Just . (:| []) $ _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid) <$ tell (All True)
|
||||
Nothing -> (False, FormMissing) <$ tell (All False)
|
||||
WorkflowPayloadFieldCaptureDateTime{..} -> do
|
||||
let
|
||||
cLabel = case wpfcdtPrecision of
|
||||
WFCaptureDate -> MsgWorkflowEdgeFormFieldCaptureDateLabel
|
||||
WFCaptureTime -> MsgWorkflowEdgeFormFieldCaptureTimeLabel
|
||||
WFCaptureDateTime -> MsgWorkflowEdgeFormFieldCaptureDateTimeLabel
|
||||
|
||||
fvId <- newIdent
|
||||
lift . lift . lift . tell $ pure FieldView
|
||||
{ fvLabel = Blaze.toMarkup $ slI18n wpfcdtLabel
|
||||
, fvTooltip = slI18n <$> wpfcdtTooltip
|
||||
, fvId
|
||||
, fvInput = [whamlet|
|
||||
$newline never
|
||||
<span ##{fvId} .explanation>
|
||||
_{cLabel}
|
||||
|]
|
||||
, fvErrors = Nothing
|
||||
, fvRequired = False
|
||||
}
|
||||
|
||||
t <- liftIO getCurrentTime
|
||||
case wpfcdtPrecision of
|
||||
WFCaptureDate -> do
|
||||
delTyp $ Proxy @Day
|
||||
(True, FormSuccess . Just . (:| []) . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . localDay $ utcToLocalTime t) <$ tell (All True)
|
||||
WFCaptureTime -> do
|
||||
delTyp $ Proxy @TimeOfDay
|
||||
(True, FormSuccess . Just . (:| []) . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . localTimeOfDay $ utcToLocalTime t) <$ tell (All True)
|
||||
WFCaptureDateTime -> do
|
||||
delTyp $ Proxy @UTCTime
|
||||
(True, FormSuccess . Just $ (_WorkflowFieldPayloadW . _WorkflowFieldPayload # t) :| []) <$ tell (All True)
|
||||
WorkflowPayloadFieldReference{..} -> throwE wpfrTarget
|
||||
WorkflowPayloadFieldMultiple{..} -> do
|
||||
fRefs <- nonEmpty <$> State.state (maybe (, []) (splitAt . fromIntegral) $ (+ wpfmMin) <$> wpfmRange)
|
||||
miIdent <- newIdent
|
||||
wSetTooltip' (fmap slI18n wpfmTooltip) $
|
||||
let mPrev' :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))
|
||||
mPrev' = fRefs <|> wpfmDefault
|
||||
mPrev :: Maybe (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId), Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
||||
mPrev = Just . Map.fromList . zip [0..] . ensureLength . map (\x -> (Just x, Just $ x :| [])) $ mPrev' ^.. _Just . folded
|
||||
where
|
||||
ensureLength :: forall a b. [(Maybe a, Maybe b)] -> [(Maybe a, Maybe b)]
|
||||
ensureLength = (\l -> (l ++) $ replicate (fromIntegral wpfmMin - length l) (Nothing, Nothing)) . maybe id (take . fromIntegral) ((+ wpfmMin) <$> wpfmRange)
|
||||
mangleResult :: forall a.
|
||||
FormResult (Map ListPosition (a, Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
||||
-> (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
||||
-- FieldMultiple are always filled since `massInput` ensures cardinality constraints (iff @mPrev'@ correctly initializes `massInput` with a list of fields of the appropriate length)
|
||||
mangleResult res = case matching _FormSuccess res of
|
||||
Right ress
|
||||
-> (True, FormSuccess . nonEmpty $ ress ^.. folded . _2 . _Just . folded)
|
||||
Left res'
|
||||
-> (False, res')
|
||||
runMI :: forall a.
|
||||
WForm (ExceptT WorkflowPayloadLabel Handler) a
|
||||
-> ExceptT WorkflowPayloadLabel (RWST (Maybe (Text -> Text)) All [WorkflowFieldPayloadW FileReference UserId] (MForm (WriterT [FieldView UniWorX] Handler))) a
|
||||
runMI mx = do
|
||||
r <- lift $ lift ask
|
||||
s <- lift $ lift State.get
|
||||
((a, s', w), w') <- ExceptT . lift . lift . lift . runExceptT . runWriterT $ runRWST mx r s
|
||||
lift . lift $ do
|
||||
State.put s'
|
||||
tell w
|
||||
lift $ tell w'
|
||||
lift . tell . All $ wpfmMin <= 0
|
||||
return a
|
||||
|
||||
miAdd :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> (Text -> Text)
|
||||
-> FieldView UniWorX
|
||||
-> Maybe (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))), Widget))
|
||||
miAdd pos dim liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ over (mapped . _1 . _FormSuccess) tweakRes . miForm nudge (Left submitView)
|
||||
where tweakRes :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))
|
||||
-> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
|
||||
-> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))
|
||||
tweakRes newDat prevData = pure . Map.fromList . zip [startKey..] . map Just $ newDat ^.. _Just . folded
|
||||
where startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
|
||||
|
||||
miCell :: ListPosition
|
||||
-> Maybe (WorkflowFieldPayloadW FileReference UserId)
|
||||
-> Maybe (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))
|
||||
-> (Text -> Text)
|
||||
-> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))), Widget))
|
||||
miCell _pos dat mPrev'' nudge = miForm nudge . Right $ fromMaybe (fmap (:| []) dat) mPrev''
|
||||
|
||||
miForm :: (Text -> Text)
|
||||
-> Either (FieldView UniWorX) (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))
|
||||
-> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))), Widget))
|
||||
miForm nudge mode csrf = do
|
||||
let runSpecRender :: WriterT [FieldView UniWorX] Handler (Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))), Ints, Enctype)
|
||||
-> ExceptT WorkflowPayloadLabel Handler (((Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))), [FieldView UniWorX]), Ints, Enctype)
|
||||
runSpecRender mSR = do
|
||||
((eRes, s, w), fvs) <- lift $ runWriterT mSR
|
||||
ExceptT . return $ (, s, w) . (, fvs) <$> eRes
|
||||
((fFilled, fmRes), fvs') <- mapRWST runSpecRender . fmap (view _1) $ evalRWST (runExceptT $ renderSpecField wpfmSub) (Just $ fromMaybe id mNudge . nudge) (mode ^.. _Right . _Just . folded)
|
||||
|
||||
let fFilled' = fFilled || isn't _FormSuccess fmRes
|
||||
fmRes' | not fFilled' = FormFailure . pure . maybe (mr MsgValueRequired) (mr . valueRequired) $ fvs ^? _head . to fvLabel'
|
||||
| otherwise = fmRes
|
||||
fvLabel' = toStrict . Blaze.renderMarkup . Blaze.contents . fvLabel -- Dirty, but probably good enough; if not: `censor` writer with actual `Text` in `renderSpecField` and discard that information in `workflowEdgePayloadFields`
|
||||
fvs | not fFilled' = fvs' <&> \fv -> fv { fvErrors = Just
|
||||
[shamlet|
|
||||
$newline never
|
||||
$maybe errs <- fvErrors fv
|
||||
#{errs}
|
||||
<br />
|
||||
#{mr (valueRequired (fvLabel' fv))}
|
||||
|]
|
||||
}
|
||||
| otherwise = fvs'
|
||||
valueRequired :: forall msg. _ => msg -> ValueRequired UniWorX
|
||||
valueRequired = ValueRequired
|
||||
|
||||
return ( fmRes'
|
||||
, case mode of
|
||||
Left btn -> $(widgetFile "widgets/massinput/workflow-payload-field-multiple/add")
|
||||
Right _ -> $(widgetFile "widgets/massinput/workflow-payload-field-multiple/cell")
|
||||
)
|
||||
|
||||
miDelete :: forall m.
|
||||
Monad m
|
||||
=> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
|
||||
-> ListPosition
|
||||
-> MaybeT m (Map ListPosition ListPosition)
|
||||
miDelete dat pos = do
|
||||
ListLength l <- hoistMaybe . preview liveCoords $ Map.keysSet dat
|
||||
guard $ l > wpfmMin
|
||||
miDeleteList dat pos
|
||||
|
||||
miAllowAdd :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> Bool
|
||||
miAllowAdd _ _ (ListLength l) = maybe True (l <) $ (+ wpfmMin) <$> wpfmRange
|
||||
|
||||
miAddEmpty :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> Set ListPosition
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
|
||||
miButtonAction :: forall p.
|
||||
p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction _ = Nothing
|
||||
|
||||
miLayout :: MassInputLayout ListLength (Maybe (WorkflowFieldPayloadW FileReference UserId)) (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflow-payload-field-multiple/layout")
|
||||
in runMI . fmap mangleResult $ massInputW MassInput{..} (fslI $ slI18n wpfmLabel) False mPrev
|
||||
|
||||
|
||||
workflowEdgeFormToAction :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> WorkflowEdgeForm
|
||||
-> m (WorkflowAction FileReference UserId)
|
||||
workflowEdgeFormToAction WorkflowEdgeForm{..} = do
|
||||
wpUser <- Just <$> maybeAuthId
|
||||
wpTime <- liftIO getCurrentTime
|
||||
return WorkflowAction{..}
|
||||
where
|
||||
(wpTo, wpVia) = wefEdge
|
||||
wpPayload = wefPayload
|
||||
@ -1,252 +0,0 @@
|
||||
module Handler.Utils.Workflow.Form
|
||||
( FileIdent
|
||||
, WorkflowGraphForm(..), FormWorkflowGraph
|
||||
, workflowGraphForm
|
||||
, toWorkflowGraphForm, fromWorkflowGraphForm
|
||||
, WorkflowDescriptionsFormScope(..)
|
||||
, workflowDescriptionsForm
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Form
|
||||
import Utils.Workflow
|
||||
|
||||
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
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
|
||||
import Utils.Workflow.Lint
|
||||
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import Control.Monad.Catch.Pure (runCatch)
|
||||
|
||||
import Handler.Utils.Files (sourceFile)
|
||||
|
||||
|
||||
newtype FileIdent = FileIdent (CI Text)
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (ToMessage, ToJSON, FromJSON)
|
||||
|
||||
makeWrapped ''FileIdent
|
||||
|
||||
newtype instance FileReferenceTitleMap FileIdent add = FileIdentFileReferenceTitleMap
|
||||
{ unFileIdentFileReferenceTitleMap :: Map FilePath (FileIdentFileReferenceTitleMapElem add)
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
data FileIdentFileReferenceTitleMapElem add = FileIdentFileReferenceTitleMapElem
|
||||
{ fIdentTitleMapIdent :: FileIdent
|
||||
, fIdentTitleMapAdditional :: add
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
makePrisms ''FileIdentFileReferenceTitleMapElem
|
||||
|
||||
instance FileReferenceTitleMapConvertible add FileIdent FileIdent where
|
||||
_FileReferenceTitleMap = iso unFileIdentFileReferenceTitleMap FileIdentFileReferenceTitleMap . traverse . _FileIdentFileReferenceTitleMapElem
|
||||
|
||||
instance FileReferenceTitleMapConvertible add FileIdent FileReference where
|
||||
_FileReferenceTitleMap = iso unFileIdentFileReferenceTitleMap FileReferenceFileReferenceTitleMap . iso Map.toList Map.fromList . traverse . iso (view $ _2 . _FileIdentFileReferenceTitleMapElem) (\(FileReference{..}, additional) -> (fileReferenceTitle, FileReferenceFileReferenceTitleMapElem fileReferenceContent fileReferenceModified additional))
|
||||
|
||||
instance FileReferenceTitleMapConvertible add FileReference FileIdent where
|
||||
_FileReferenceTitleMap = iso unFileReferenceFileReferenceTitleMap FileIdentFileReferenceTitleMap . itraverse . (\f fileReferenceTitle FileReferenceFileReferenceTitleMapElem{ fRefTitleMapContent = fileReferenceContent, fRefTitleMapModified = fileReferenceModified, fRefTitleMapAdditional } -> review _FileIdentFileReferenceTitleMapElem <$> f (FileReference{..}, fRefTitleMapAdditional))
|
||||
|
||||
instance ToJSON (FileField FileIdent) where
|
||||
toJSON FileField{..} = JSON.object $ catMaybes
|
||||
[ ("ident" JSON..=) <$> fieldIdent
|
||||
, pure $ "unpack-zips" JSON..= fieldUnpackZips
|
||||
, pure $ "multiple" JSON..= fieldMultiple
|
||||
, pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
|
||||
, pure $ "max-file-size" JSON..= fieldMaxFileSize
|
||||
, pure $ "additional-files" JSON..= addFiles'
|
||||
]
|
||||
where addFiles' = unFileIdentFileReferenceTitleMap fieldAdditionalFiles <&> \FileIdentFileReferenceTitleMapElem{..} -> JSON.object
|
||||
[ "ident" JSON..= fIdentTitleMapIdent
|
||||
, "include" JSON..= fIdentTitleMapAdditional
|
||||
]
|
||||
instance FromJSON (FileField FileIdent) where
|
||||
parseJSON = JSON.withObject "FileField" $ \o -> do
|
||||
fieldIdent <- o JSON..:? "ident"
|
||||
fieldUnpackZips <- o JSON..: "unpack-zips"
|
||||
fieldMultiple <- o JSON..: "multiple"
|
||||
fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
|
||||
fieldMaxFileSize <- o JSON..:? "max-file-size"
|
||||
fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
|
||||
addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
|
||||
fieldAdditionalFiles <- fmap FileIdentFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileIdentFileReferenceTitleMapElem" $ \o' -> do
|
||||
fIdentTitleMapIdent <- o' JSON..: "Ident"
|
||||
fIdentTitleMapAdditional <- o' JSON..: "include"
|
||||
return FileIdentFileReferenceTitleMapElem{..}
|
||||
return FileField{..}
|
||||
|
||||
|
||||
|
||||
type FormWorkflowGraph = WorkflowGraph FileIdent CryptoUUIDUser
|
||||
|
||||
data WorkflowGraphForm = WorkflowGraphForm
|
||||
{ wgfGraph :: FormWorkflowGraph
|
||||
, wgfFiles :: Map FileIdent FileReference
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
makeLenses_ ''WorkflowGraphForm
|
||||
|
||||
data WorkflowGraphFormMode = WGFTextInput | WGFFileUpload
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
nullaryPathPiece ''WorkflowGraphFormMode $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''WorkflowGraphFormMode id
|
||||
|
||||
|
||||
workflowGraphForm :: Maybe WorkflowGraphForm -> AForm DB WorkflowGraphForm
|
||||
workflowGraphForm template = validateAForm validateWorkflowGraphForm . hoistAForm lift $ WorkflowGraphForm
|
||||
<$> multiActionA (mapF wgfGraphOptions) (fslI MsgWorkflowDefinitionGraph) (Just WGFFileUpload)
|
||||
<*> filesForm
|
||||
where
|
||||
wgfGraphOptions = \case
|
||||
WGFTextInput -> apreq yamlField (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
|
||||
WGFFileUpload -> apreq (checkMMap toGraph fromGraph . singleFileField . foldMap fromGraph $ wgfGraph <$> template) (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
|
||||
where
|
||||
toGraph :: FileUploads -> Handler (Either (SomeMessage UniWorX) FormWorkflowGraph)
|
||||
toGraph uploads = runExceptT $ do
|
||||
fRefs <- lift . runConduit $ uploads .| C.take 2 .| C.foldMap pure
|
||||
fRef <- case fRefs of
|
||||
[fRef] -> return fRef
|
||||
_other -> throwE $ SomeMessage MsgWorkflowGraphFormInvalidNumberOfFiles
|
||||
mContent <- for (fileContent $ sourceFile fRef) $ \fContent -> lift . runDB . runConduit $ fContent .| C.fold
|
||||
content <- maybe (throwE $ SomeMessage MsgWorkflowGraphFormUploadIsDirectory) return mContent
|
||||
either (throwE . SomeMessage . MsgYAMLFieldDecodeFailure . displayException) return . runCatch $ Yaml.decodeThrow content
|
||||
fromGraph :: FormWorkflowGraph -> FileUploads
|
||||
fromGraph g = yieldM . runDB $ do
|
||||
fileModified <- liftIO getCurrentTime
|
||||
fRef <- sinkFile $ File
|
||||
{ fileTitle = "graph.yaml"
|
||||
, fileContent = Just . yield $ Yaml.encode g
|
||||
, fileModified
|
||||
}
|
||||
insert_ SessionFile
|
||||
{ sessionFileContent = fileReferenceContent fRef
|
||||
, sessionFileTouched = fileReferenceModified fRef
|
||||
}
|
||||
return fRef
|
||||
|
||||
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 $ maybe (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
|
||||
|
||||
graph <- use _wgfGraph
|
||||
for_ (lintWorkflowGraph graph) $ \lintIssues -> do
|
||||
addMessageModal Warning (i18n MsgWorkflowDefinitionWarningLinterIssuesMessage) $ Right
|
||||
[whamlet|
|
||||
$newline never
|
||||
_{MsgWorkflowDefinitionWarningLinterIssues}
|
||||
<ul>
|
||||
$forall issue <- otoList lintIssues
|
||||
<li>
|
||||
#{displayException issue}
|
||||
|]
|
||||
|
||||
toWorkflowGraphForm :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> DBWorkflowGraph
|
||||
-> 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 . pack) $
|
||||
fileReferenceTitle : [ base <.> show n <.> ext | let (base, ext) = splitExtension fileReferenceTitle, n <- [1..] :: [Natural] ]
|
||||
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 DBWorkflowGraph
|
||||
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)
|
||||
|
||||
nullaryPathPiece ''WorkflowDescriptionsFormScope $ camelToPathPiece' 3
|
||||
|
||||
workflowDescriptionsForm :: WorkflowDescriptionsFormScope -> Maybe (Map Lang (Text, Maybe StoredMarkup)) -> AForm Handler (Map Lang (Text, Maybe StoredMarkup))
|
||||
workflowDescriptionsForm scope template = Map.fromList <$> massInputAccumEditA descrAdd descrEdit (const Nothing) descrLayout ("workflow-descriptions--" <> toPathPiece scope :: 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 StoredMarkup)) -> Form (Lang, (Text, Maybe StoredMarkup))
|
||||
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 StoredMarkup)) (Lang, (Text, Maybe StoredMarkup))
|
||||
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
|
||||
@ -1,29 +0,0 @@
|
||||
module Handler.Utils.Workflow.Restriction
|
||||
( checkWorkflowRestriction
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
checkWorkflowRestriction :: Maybe IdWorkflowState
|
||||
-> PredDNF WorkflowGraphRestriction
|
||||
-> Bool
|
||||
checkWorkflowRestriction mHistory dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf'
|
||||
where
|
||||
evalConj = maybe True (ofoldr1 (&&)) . fromNullable . map evalPred
|
||||
evalPred PLVariable{ plVar = WorkflowGraphRestrictionPayloadFilled{..} } = wgrPayloadFilled `Set.member` filledPayloads
|
||||
evalPred PLNegated{ plVar = WorkflowGraphRestrictionPayloadFilled{..} } = wgrPayloadFilled `Set.notMember` filledPayloads
|
||||
evalPred PLVariable{ plVar = WorkflowGraphRestrictionPreviousNode{..} } = maybe False (wgrPreviousNode ==) cState
|
||||
evalPred PLNegated{ plVar = WorkflowGraphRestrictionPreviousNode{..} } = maybe True (wgrPreviousNode /=) cState
|
||||
evalPred PLVariable{ plVar = WorkflowGraphRestrictionInitial } = is _Nothing mHistory
|
||||
evalPred PLNegated{ plVar = WorkflowGraphRestrictionInitial } = isn't _Nothing mHistory
|
||||
dnf' = map (Set.toList . toNullable) . Set.toList $ dnfTerms dnf
|
||||
|
||||
filledPayloads | Just history <- mHistory = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
|
||||
| otherwise = Set.empty
|
||||
cState = wpTo . last <$> mHistory
|
||||
@ -1,99 +0,0 @@
|
||||
module Handler.Utils.Workflow.Workflow
|
||||
( ensureScope
|
||||
, followEdge
|
||||
, followAutomaticEdges, WorkflowAutomaticEdgeException(..)
|
||||
, sourceWorkflowActionInfos
|
||||
, module Handler.Utils.Workflow.Restriction
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
import Handler.Utils.Workflow.EdgeForm
|
||||
import Handler.Utils.Workflow.Restriction
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
ensureScope :: IdWorkflowScope -> 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
|
||||
|
||||
followEdge :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
)
|
||||
=> IdWorkflowGraph -> WorkflowEdgeForm -> Maybe IdWorkflowState -> m IdWorkflowState
|
||||
-- | Remember to invalidate auth cache
|
||||
followEdge graph edgeRes cState = do
|
||||
act <- workflowEdgeFormToAction edgeRes
|
||||
followAutomaticEdges graph $ maybe id (<>) cState (act `ncons` mempty)
|
||||
|
||||
data WorkflowAutomaticEdgeException
|
||||
= WorkflowAutomaticEdgeCycle [(WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel)]
|
||||
| WorkflowAutomaticEdgeAmbiguity (Set (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
followAutomaticEdges :: forall m.
|
||||
( MonadIO m
|
||||
, MonadThrow m
|
||||
)
|
||||
=> IdWorkflowGraph -> IdWorkflowState -> m IdWorkflowState
|
||||
followAutomaticEdges WorkflowGraph{..} = go []
|
||||
where
|
||||
go :: [((WorkflowGraphNodeLabel, Set WorkflowPayloadLabel), (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed
|
||||
-> IdWorkflowState
|
||||
-> m IdWorkflowState
|
||||
go automaticEdgesTaken history
|
||||
| null automaticEdgeOptions = return history
|
||||
| [(edgeLbl, nodeLbl)] <- automaticEdgeOptions = if
|
||||
| (edgeDecisionInput, (edgeLbl, nodeLbl)) `elem` automaticEdgesTaken
|
||||
-> throwM . WorkflowAutomaticEdgeCycle . reverse $ map (view _2) automaticEdgesTaken
|
||||
| otherwise -> do
|
||||
wpTime <- liftIO getCurrentTime
|
||||
let wpUser = Nothing
|
||||
wpPayload = mempty
|
||||
wpTo = nodeLbl
|
||||
wpVia = edgeLbl
|
||||
go ((edgeDecisionInput, (edgeLbl, nodeLbl)) : automaticEdgesTaken) $ history <> (WorkflowAction{..} `ncons` mempty)
|
||||
| otherwise = throwM . WorkflowAutomaticEdgeAmbiguity $ Set.fromList automaticEdgeOptions
|
||||
where
|
||||
cState = wpTo $ last history
|
||||
automaticEdgeOptions = nubOrd $ do
|
||||
(nodeLbl, WGN{..}) <- Map.toList wgNodes
|
||||
(edgeLbl, WorkflowGraphEdgeAutomatic{..}) <- Map.toList wgnEdges
|
||||
guard $ wgeSource == cState
|
||||
whenIsJust wgeRestriction $ guard . checkWorkflowRestriction (Just history)
|
||||
return (edgeLbl, nodeLbl)
|
||||
filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
|
||||
edgeDecisionInput = (cState, filledPayloads)
|
||||
|
||||
|
||||
sourceWorkflowActionInfos
|
||||
:: forall backend m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCatch m, MonadUnliftIO m
|
||||
, MonadAP (ReaderT backend m)
|
||||
)
|
||||
=> WorkflowWorkflowId
|
||||
-> WorkflowState FileReference UserId
|
||||
-> ConduitT () (WorkflowActionInfo FileReference UserId) (ReaderT backend m) ()
|
||||
-- ^ Does `mayViewWorkflowAction`
|
||||
sourceWorkflowActionInfos wwId wState = do
|
||||
mAuthId <- maybeAuthId
|
||||
let authCheck WorkflowActionInfo{..}
|
||||
= mayViewWorkflowAction mAuthId wwId waiAction
|
||||
yieldMany (workflowActionInfos wState) .| C.filterM authCheck
|
||||
@ -1,7 +0,0 @@
|
||||
module Handler.Workflow
|
||||
( 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
|
||||
@ -1,9 +0,0 @@
|
||||
module Handler.Workflow.Definition
|
||||
( module Handler.Workflow.Definition
|
||||
) where
|
||||
|
||||
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
|
||||
@ -1,52 +0,0 @@
|
||||
module Handler.Workflow.Definition.Delete
|
||||
( getAWDDeleteR, postAWDDeleteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
getAWDDeleteR, postAWDDeleteR :: WorkflowScope' -> WorkflowDefinitionName -> Handler Html
|
||||
getAWDDeleteR = postAWDDeleteR
|
||||
postAWDDeleteR wds' wdn = do
|
||||
wdId <- runDB . getKeyBy404 $ UniqueWorkflowDefinition wdn wds'
|
||||
deleteR DeleteRoute
|
||||
{ drRecords = Set.singleton wdId
|
||||
, drGetInfo = \workflowDefinition -> do
|
||||
let instanceCount = E.subSelectCount . E.from $ \workflowInstance ->
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceDefinition E.==. E.just (workflowDefinition E.^. WorkflowDefinitionId)
|
||||
workflowCount = E.subSelectCount . E.from $ \(workflowInstance `E.InnerJoin` workflow) -> do
|
||||
E.on $ workflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceDefinition E.==. E.just (workflowDefinition E.^. WorkflowDefinitionId)
|
||||
return ( workflowDefinition E.^. WorkflowDefinitionScope
|
||||
, workflowDefinition E.^. WorkflowDefinitionName
|
||||
, instanceCount, workflowCount
|
||||
)
|
||||
, drUnjoin = id
|
||||
, drRenderRecord = \(E.Value scope, E.Value name, E.Value instanceCount, E.Value workflowCount) ->
|
||||
return [whamlet|
|
||||
$newline never
|
||||
#{name}
|
||||
\ (_{scope}
|
||||
$if instanceCount > 0
|
||||
; _{MsgWorkflowDefinitionConcreteInstanceCount instanceCount}
|
||||
$if workflowCount > 0
|
||||
; _{MsgWorkflowDefinitionConcreteWorkflowCount workflowCount}
|
||||
)
|
||||
|]
|
||||
, drRecordConfirmString = \(E.Value scope, E.Value name, _, _) ->
|
||||
return [st|#{toPathPiece scope}.#{name}|]
|
||||
, drCaption = SomeMessage MsgWorkflowDefinitionDeleteQuestion
|
||||
, drSuccessMessage = SomeMessage MsgWorkflowDefinitionDeleted
|
||||
, drFormMessage = const $ return Nothing
|
||||
, drAbort = SomeRoute AdminWorkflowDefinitionListR
|
||||
, drSuccess = SomeRoute AdminWorkflowDefinitionListR
|
||||
, drDelete = \k cascade -> do
|
||||
updateWhere [WorkflowInstanceDefinition ==. Just k] [WorkflowInstanceDefinition =. Nothing]
|
||||
cascade
|
||||
}
|
||||
@ -1,102 +0,0 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Handler.Workflow.Definition.Edit
|
||||
( getAWDEditR, postAWDEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Workflow
|
||||
import Handler.Utils
|
||||
import Handler.Workflow.Definition.Form
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
getAWDEditR, postAWDEditR :: WorkflowScope' -> WorkflowDefinitionName -> Handler Html
|
||||
getAWDEditR = postAWDEditR
|
||||
postAWDEditR wds' wdn = do
|
||||
(((_, editForm), editEncoding), act) <- runDB $ do
|
||||
Entity wdId WorkflowDefinition{..} <- getBy404 $ UniqueWorkflowDefinition wdn wds'
|
||||
template <- do
|
||||
descs <- selectList [WorkflowDefinitionDescriptionDefinition ==. wdId] []
|
||||
let wdfDescriptions = Map.fromList
|
||||
[ (workflowDefinitionDescriptionLanguage, (workflowDefinitionDescriptionTitle, workflowDefinitionDescriptionDescription))
|
||||
| Entity _ WorkflowDefinitionDescription{..} <- descs
|
||||
]
|
||||
|
||||
iDescs <- selectList [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId] []
|
||||
let wdfInstanceDescriptions = Map.fromList
|
||||
[ (workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))
|
||||
| Entity _ WorkflowDefinitionInstanceDescription{..} <- iDescs
|
||||
]
|
||||
|
||||
wdfGraph <- toWorkflowGraphForm =<< getSharedDBWorkflowGraph workflowDefinitionGraph
|
||||
|
||||
return WorkflowDefinitionForm
|
||||
{ wdfScope = workflowDefinitionScope
|
||||
, wdfName = workflowDefinitionName
|
||||
, wdfInstanceCategory = workflowDefinitionInstanceCategory
|
||||
, wdfDescriptions
|
||||
, wdfInstanceDescriptions
|
||||
, wdfGraph
|
||||
}
|
||||
|
||||
form@((editRes, _), _) <- runFormPost . workflowDefinitionForm $ Just template
|
||||
|
||||
act <- formResultMaybe editRes $ \WorkflowDefinitionForm{..} -> do
|
||||
wdfGraph' <- fromWorkflowGraphForm wdfGraph
|
||||
wdfGraph'' <- insertSharedWorkflowGraph wdfGraph'
|
||||
|
||||
insConflict <- replaceUnique wdId WorkflowDefinition
|
||||
{ workflowDefinitionGraph = wdfGraph''
|
||||
, workflowDefinitionScope = wdfScope
|
||||
, workflowDefinitionName = wdfName
|
||||
, workflowDefinitionInstanceCategory = wdfInstanceCategory
|
||||
}
|
||||
|
||||
when (is _Nothing insConflict) $ do
|
||||
deleteWhere [WorkflowDefinitionDescriptionDefinition ==. wdId]
|
||||
insertMany_ $ do
|
||||
(wddLang, (wddTitle, wddDesc)) <- Map.toList wdfDescriptions
|
||||
return WorkflowDefinitionDescription
|
||||
{ workflowDefinitionDescriptionDefinition = wdId
|
||||
, workflowDefinitionDescriptionLanguage = wddLang
|
||||
, workflowDefinitionDescriptionTitle = wddTitle
|
||||
, workflowDefinitionDescriptionDescription = wddDesc
|
||||
}
|
||||
|
||||
deleteWhere [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId]
|
||||
insertMany_ $ do
|
||||
(wddLang, (wddTitle, wddDesc)) <- Map.toList wdfInstanceDescriptions
|
||||
return WorkflowDefinitionInstanceDescription
|
||||
{ workflowDefinitionInstanceDescriptionDefinition = wdId
|
||||
, workflowDefinitionInstanceDescriptionLanguage = wddLang
|
||||
, workflowDefinitionInstanceDescriptionTitle = wddTitle
|
||||
, workflowDefinitionInstanceDescriptionDescription = wddDesc
|
||||
}
|
||||
|
||||
case insConflict of
|
||||
Just (UniqueWorkflowDefinition wdn' wds'') -> return . Just $
|
||||
addMessage' =<< messageIHamlet Error
|
||||
[ihamlet|
|
||||
$newline never
|
||||
<a href=@{AdminWorkflowDefinitionR wds'' wdn' AWDEditR}>
|
||||
_{MsgWorkflowDefinitionCollision}
|
||||
|]
|
||||
Nothing -> return . Just $ do
|
||||
addMessageI Success MsgWorkflowDefinitionEdited
|
||||
redirect AdminWorkflowDefinitionListR
|
||||
|
||||
return (form, act)
|
||||
|
||||
forM_ act id
|
||||
|
||||
let editWidget = wrapForm editForm def
|
||||
{ formAction = Just . SomeRoute $ AdminWorkflowDefinitionR wds' wdn AWDEditR
|
||||
, formEncoding = editEncoding
|
||||
}
|
||||
|
||||
siteLayoutMsg MsgWorkflowDefinitionEditTitle $ do
|
||||
setTitleI MsgWorkflowDefinitionEditTitle
|
||||
|
||||
editWidget
|
||||
@ -1,44 +0,0 @@
|
||||
module Handler.Workflow.Definition.Form
|
||||
( WorkflowDefinitionForm(..)
|
||||
, workflowDefinitionForm
|
||||
, module Handler.Utils.Workflow.Form
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Workflow.Form
|
||||
|
||||
import qualified Data.CryptoID as C
|
||||
|
||||
|
||||
data WorkflowDefinitionForm = WorkflowDefinitionForm
|
||||
{ wdfScope :: WorkflowScope'
|
||||
, wdfName :: WorkflowDefinitionName
|
||||
, wdfInstanceCategory :: Maybe WorkflowInstanceCategory
|
||||
, wdfDescriptions :: Map Lang (Text, Maybe StoredMarkup)
|
||||
, wdfInstanceDescriptions :: Map Lang (Text, Maybe StoredMarkup)
|
||||
, wdfGraph :: WorkflowGraphForm
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
makeLenses_ ''WorkflowDefinitionForm
|
||||
|
||||
workflowDefinitionForm :: Maybe WorkflowDefinitionForm -> Html -> MForm DB (FormResult WorkflowDefinitionForm, Widget)
|
||||
workflowDefinitionForm template = validateForm validateWorkflowDefinitionForm . renderAForm FormStandard $ WorkflowDefinitionForm
|
||||
<$> apopt (hoistField lift $ selectField optionsFinite) (fslI MsgWorkflowDefinitionScope) (wdfScope <$> template)
|
||||
<*> areq ciField (fslI MsgWorkflowDefinitionName) (wdfName <$> template)
|
||||
<*> 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
|
||||
where
|
||||
ensureExists :: forall record ns p r. _ => p record -> C.CryptoID ns UUID -> FormValidator r DB ()
|
||||
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)
|
||||
|
||||
@ -1,61 +0,0 @@
|
||||
module Handler.Workflow.Definition.Instantiate
|
||||
( getAWDInstantiateR, postAWDInstantiateR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Workflow
|
||||
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)
|
||||
workflowInstanceGraph <- insertSharedWorkflowGraph wifGraph'
|
||||
instId <- insertUnique WorkflowInstance
|
||||
{ workflowInstanceDefinition = Just wdId
|
||||
, workflowInstanceGraph
|
||||
, 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
|
||||
@ -1,143 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Workflow.Definition.List
|
||||
( getAdminWorkflowDefinitionListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
type WorkflowDefinitionTableExpr = E.SqlExpr (Entity WorkflowDefinition)
|
||||
|
||||
queryWorkflowDefinition :: Iso' WorkflowDefinitionTableExpr (E.SqlExpr (Entity WorkflowDefinition))
|
||||
queryWorkflowDefinition = id
|
||||
|
||||
queryWorkflowInstanceCount, queryWorkflowCount :: Getter WorkflowDefinitionTableExpr (E.SqlExpr (E.Value Int64))
|
||||
queryWorkflowInstanceCount = to $ \(view queryWorkflowDefinition -> workflowDefinition) ->
|
||||
E.subSelectCount . E.from $ \workflowInstance ->
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceDefinition E.==. E.just (workflowDefinition E.^. WorkflowDefinitionId)
|
||||
queryWorkflowCount = to $ \(view queryWorkflowDefinition -> workflowDefinition) ->
|
||||
E.subSelectCount . E.from $ \(workflowInstance `E.InnerJoin` workflow) -> do
|
||||
E.on $ workflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceDefinition E.==. E.just (workflowDefinition E.^. WorkflowDefinitionId)
|
||||
|
||||
|
||||
|
||||
type WorkflowDefinitionData = DBRow
|
||||
( Entity WorkflowDefinition
|
||||
, Maybe (Entity WorkflowDefinitionDescription)
|
||||
, Maybe (Entity WorkflowDefinitionInstanceDescription)
|
||||
, Int64, Int64
|
||||
)
|
||||
|
||||
resultDefinition :: Lens' WorkflowDefinitionData (Entity WorkflowDefinition)
|
||||
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 . _4
|
||||
resultWorkflowCount = _dbrOutput . _5
|
||||
|
||||
|
||||
getAdminWorkflowDefinitionListR :: Handler Html
|
||||
getAdminWorkflowDefinitionListR = do
|
||||
definitionsTable <- runDB $
|
||||
let
|
||||
workflowDefinitionsDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
workflowDefinition <- view queryWorkflowDefinition
|
||||
workflowInstanceCount <- view queryWorkflowInstanceCount
|
||||
workflowCount <- view queryWorkflowCount
|
||||
|
||||
return (workflowDefinition, workflowInstanceCount, workflowCount)
|
||||
dbtRowKey = (E.^. WorkflowDefinitionId)
|
||||
dbtProj = dbtProjFilteredPostSimple . runReaderT $ do
|
||||
wd@(Entity wdId _) <- view _1
|
||||
descLangs <- lift . E.select . E.from $ \workflowDefinitionDescription -> do
|
||||
E.where_ $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionDefinition E.==. E.val wdId
|
||||
return $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionLanguage
|
||||
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
|
||||
desc <- lift . fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowDefinitionDescription wdId descLang'
|
||||
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 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 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
|
||||
anchorEdit :: (WorkflowDefinitionData -> Widget) -> _
|
||||
anchorEdit = anchorCell' $ \(view $ resultDefinition . _entityVal -> WorkflowDefinition{..}) -> AdminWorkflowDefinitionR workflowDefinitionScope workflowDefinitionName AWDEditR
|
||||
displayGraph graph
|
||||
= [shamlet|
|
||||
$newline never
|
||||
<code .json>
|
||||
#{graph'}
|
||||
|]
|
||||
where graph' = decodeUtf8 $ Yaml.encode graph
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap "name" . SortColumn $ views queryWorkflowDefinition (E.^. WorkflowDefinitionName)
|
||||
, 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
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowDefinitionName)
|
||||
, singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowDefinitionScope)
|
||||
, singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
||||
, singletonMap "instance-title" . mkFilterProjectedPost $ \(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 MsgTableNoFilter) 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
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "workflow-definitions"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = []
|
||||
workflowDefinitionsDBTableValidator = def
|
||||
& defaultPagesize PagesizeAll
|
||||
& defaultSorting [SortAscBy "scope", SortAscBy "name"]
|
||||
in dbTableWidget' workflowDefinitionsDBTableValidator workflowDefinitionsDBTable
|
||||
|
||||
siteLayoutMsg MsgWorkflowDefinitionListTitle $ do
|
||||
setTitleI MsgWorkflowDefinitionListTitle
|
||||
|
||||
definitionsTable
|
||||
@ -1,62 +0,0 @@
|
||||
module Handler.Workflow.Definition.New
|
||||
( getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Workflow.Definition.Form
|
||||
import Utils.Workflow
|
||||
|
||||
|
||||
getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR :: Handler Html
|
||||
getAdminWorkflowDefinitionNewR = postAdminWorkflowDefinitionNewR
|
||||
postAdminWorkflowDefinitionNewR = do
|
||||
(((_, newForm), newEncoding), act) <- runDB $ do
|
||||
form@((newRes, _), _) <- runFormPost $ workflowDefinitionForm Nothing
|
||||
|
||||
act <- formResultMaybe newRes $ \WorkflowDefinitionForm{ .. } -> do
|
||||
wdfGraph' <- fromWorkflowGraphForm wdfGraph
|
||||
workflowDefinitionGraph <- insertSharedWorkflowGraph wdfGraph'
|
||||
|
||||
insRes <- insertUnique WorkflowDefinition
|
||||
{ workflowDefinitionGraph
|
||||
, workflowDefinitionScope = wdfScope
|
||||
, workflowDefinitionName = wdfName
|
||||
, workflowDefinitionInstanceCategory = wdfInstanceCategory
|
||||
}
|
||||
|
||||
for_ insRes $ \wdId -> iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) ->
|
||||
insert WorkflowDefinitionDescription
|
||||
{ workflowDefinitionDescriptionDefinition = wdId
|
||||
, workflowDefinitionDescriptionLanguage = wddLang
|
||||
, 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
|
||||
addMessageI Success MsgWorkflowDefinitionCreated
|
||||
redirect AdminWorkflowDefinitionListR
|
||||
Nothing -> return . Just $
|
||||
addMessageI Error MsgWorkflowDefinitionCollision
|
||||
|
||||
return (form, act)
|
||||
|
||||
forM_ act id
|
||||
|
||||
let newWidget = wrapForm newForm def
|
||||
{ formAction = Just $ SomeRoute AdminWorkflowDefinitionNewR
|
||||
, formEncoding = newEncoding
|
||||
}
|
||||
|
||||
siteLayoutMsg MsgWorkflowDefinitionNewTitle $ do
|
||||
setTitleI MsgWorkflowDefinitionNewTitle
|
||||
|
||||
newWidget
|
||||
@ -1,10 +0,0 @@
|
||||
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
|
||||
import Handler.Workflow.Instance.Update as Handler.Workflow.Instance
|
||||
@ -1,21 +0,0 @@
|
||||
module Handler.Workflow.Instance.Delete
|
||||
( getGWIDeleteR, postGWIDeleteR
|
||||
, getSWIDeleteR, postSWIDeleteR
|
||||
, workflowInstanceDeleteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
|
||||
|
||||
getGWIDeleteR, postGWIDeleteR :: WorkflowInstanceName -> Handler Html
|
||||
getGWIDeleteR = postGWIDeleteR
|
||||
postGWIDeleteR = workflowInstanceDeleteR WSGlobal
|
||||
|
||||
getSWIDeleteR, postSWIDeleteR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
||||
getSWIDeleteR = postSWIDeleteR
|
||||
postSWIDeleteR ssh = workflowInstanceDeleteR $ WSSchool ssh
|
||||
|
||||
workflowInstanceDeleteR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
|
||||
workflowInstanceDeleteR = error "not implemented"
|
||||
@ -1,27 +0,0 @@
|
||||
module Handler.Workflow.Instance.Edit
|
||||
( getGWIEditR, postGWIEditR
|
||||
, getSWIEditR, postSWIEditR
|
||||
, workflowInstanceEditR
|
||||
, getAWIEditR, postAWIEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
|
||||
|
||||
getGWIEditR, postGWIEditR :: WorkflowInstanceName -> Handler Html
|
||||
getGWIEditR = postGWIEditR
|
||||
postGWIEditR = workflowInstanceEditR WSGlobal
|
||||
|
||||
getSWIEditR, postSWIEditR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
||||
getSWIEditR = postSWIEditR
|
||||
postSWIEditR ssh = workflowInstanceEditR $ WSSchool ssh
|
||||
|
||||
workflowInstanceEditR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
|
||||
workflowInstanceEditR = error "not implemented"
|
||||
|
||||
|
||||
getAWIEditR, postAWIEditR :: CryptoUUIDWorkflowInstance -> Handler Html
|
||||
getAWIEditR = postAWIEditR
|
||||
postAWIEditR = error "not implemented"
|
||||
@ -1,80 +0,0 @@
|
||||
module Handler.Workflow.Instance.Form
|
||||
( WorkflowInstanceForm(..), FileIdent
|
||||
, workflowInstanceForm
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import Handler.Utils.Workflow.Form
|
||||
import Utils.Workflow
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
workflowInstanceScopeForm :: Maybe WorkflowScope'
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe IdWorkflowScope
|
||||
-> AForm Handler IdWorkflowScope
|
||||
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 MsgTableTerm) (mPrev ^? _Just . _wisTerm)
|
||||
)
|
||||
, ( WSSchool'
|
||||
, WSSchool <$> apopt schoolField (fslI MsgTableSchool) (mPrev ^? _Just . _wisSchool)
|
||||
)
|
||||
, ( WSTermSchool'
|
||||
, WSTermSchool <$> apopt termField (fslI MsgTableTerm) (mPrev ^? _Just . _wisTerm)
|
||||
<*> apopt schoolField (fslI MsgTableSchool) (mPrev ^? _Just . _wisSchool)
|
||||
)
|
||||
, ( WSCourse'
|
||||
, WSCourse <$> apopt (selectField' Nothing courseOptions) (fslI MsgTableCourse) (mPrev ^? _Just . _wisCourse)
|
||||
)
|
||||
]
|
||||
where courseOptions = fmap (fmap entityKey) . optionsPersistCryptoId [] [ Desc CourseTerm, Asc CourseSchool, Asc CourseName ] $ \Course{..} -> MsgCourseOption courseTerm courseSchool courseShorthand courseName
|
||||
|
||||
|
||||
data WorkflowInstanceForm = WorkflowInstanceForm
|
||||
{ wifScope :: IdWorkflowScope
|
||||
, wifName :: WorkflowInstanceName
|
||||
, wifCategory :: Maybe WorkflowInstanceCategory
|
||||
, wifDescriptions :: Map Lang (Text, Maybe StoredMarkup)
|
||||
, 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 <=< lift . lift . getSharedDBWorkflowGraph . 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
|
||||
@ -1,91 +0,0 @@
|
||||
module Handler.Workflow.Instance.Initiate
|
||||
( getGWIInitiateR, postGWIInitiateR
|
||||
, getSWIInitiateR, postSWIInitiateR
|
||||
, workflowInstanceInitiateR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Form
|
||||
import Utils.Workflow
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Workflow
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
|
||||
getGWIInitiateR, postGWIInitiateR :: WorkflowInstanceName -> Handler Html
|
||||
getGWIInitiateR = postGWIInitiateR
|
||||
postGWIInitiateR = workflowInstanceInitiateR WSGlobal
|
||||
|
||||
getSWIInitiateR, postSWIInitiateR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
||||
getSWIInitiateR = postSWIInitiateR
|
||||
postSWIInitiateR ssh = workflowInstanceInitiateR $ WSSchool ssh
|
||||
|
||||
workflowInstanceInitiateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
|
||||
workflowInstanceInitiateR rScope win = workflowsDisabledWarning MsgWorkflowInstanceInitiateTitleDisabled MsgWorkflowInstanceInitiateHeadingDisabled $ do
|
||||
(WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), mDesc) <- runDB $ do
|
||||
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
|
||||
Entity wiId wi@WorkflowInstance{..} <- getBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
|
||||
edgeForm <- maybeT notFound . MaybeT $ workflowEdgeForm (Left wiId) Nothing
|
||||
|
||||
descs <- selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
|
||||
mDesc <- runMaybeT $ do
|
||||
langs <- hoistMaybe . nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs
|
||||
lang <- selectLanguage langs
|
||||
hoistMaybe . preview _head $ do
|
||||
Entity _ desc@WorkflowInstanceDescription{..} <- descs
|
||||
guard $ workflowInstanceDescriptionLanguage == lang
|
||||
return desc
|
||||
|
||||
((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm
|
||||
|
||||
edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
|
||||
wGraph <- getSharedIdWorkflowGraph workflowInstanceGraph
|
||||
workflowWorkflowState <- view _DBWorkflowState <$> followEdge wGraph edgeRes' Nothing
|
||||
|
||||
wwId <- insert WorkflowWorkflow
|
||||
{ workflowWorkflowInstance = Just wiId
|
||||
, workflowWorkflowScope = workflowInstanceScope
|
||||
, workflowWorkflowGraph = workflowInstanceGraph
|
||||
, workflowWorkflowState
|
||||
}
|
||||
|
||||
return . Just $ do
|
||||
memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId))
|
||||
memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles rScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId))
|
||||
when (isTopWorkflowScope rScope) $
|
||||
memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId))
|
||||
|
||||
|
||||
addMessageI Success MsgWorkflowInstanceInitiateSuccess
|
||||
|
||||
cID <- encrypt wwId
|
||||
redirectAlternatives $ NonEmpty.fromList
|
||||
[ _WorkflowScopeRoute # ( rScope, WorkflowWorkflowR cID WWWorkflowR )
|
||||
, _WorkflowScopeRoute # ( rScope, WorkflowInstanceR workflowInstanceName WIWorkflowsR )
|
||||
, _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
|
||||
]
|
||||
|
||||
return (wi, ((edgeAct, edgeView), edgeEnc), mDesc)
|
||||
|
||||
sequence_ edgeAct
|
||||
|
||||
(heading, title) <- case rScope of
|
||||
WSGlobal -> return (MsgGlobalWorkflowInstanceInitiateHeading $ maybe (CI.original workflowInstanceName) workflowInstanceDescriptionTitle mDesc, MsgGlobalWorkflowInstanceInitiateTitle)
|
||||
WSSchool ssh -> return (MsgSchoolWorkflowInstanceInitiateHeading ssh $ maybe (CI.original workflowInstanceName) workflowInstanceDescriptionTitle mDesc, MsgSchoolWorkflowInstanceInitiateTitle ssh)
|
||||
_other -> error "not implemented"
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI title
|
||||
let edgeView = wrapForm edgeView' FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
, formEncoding = edgeEnc
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Nothing :: Maybe Text
|
||||
}
|
||||
$(widgetFile "workflows/instance-initiate")
|
||||
@ -1,247 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Workflow.Instance.List
|
||||
( getAdminWorkflowInstanceListR
|
||||
, getGlobalWorkflowInstanceListR
|
||||
, getSchoolWorkflowInstanceListR
|
||||
, workflowInstanceListR
|
||||
, getTopWorkflowInstanceListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Utils.Workflow
|
||||
import Handler.Utils.Workflow
|
||||
import Handler.Workflow.Instance.Update
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
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 $ review _DBWorkflowScope . E.unValue) . E.select . E.from $ \workflowInstance ->
|
||||
return $ workflowInstance E.^. WorkflowInstanceScope
|
||||
fmap mkOptionList . for scopes $ \scope -> do
|
||||
eScope <- traverseOf _wisCourse encrypt scope :: DB CryptoIDWorkflowScope
|
||||
wScope <- maybeT notFound $ toRouteWorkflowScope scope
|
||||
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 = dbtProjFilteredPostSimple $ \(wi@(Entity wiId _), E.Value iCount) ->
|
||||
(wi, , iCount) <$> selectWorkflowInstanceDescription wiId
|
||||
dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
|
||||
dbtColonnade = mconcat
|
||||
[ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) . anchorEdit $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18n
|
||||
, sortable (Just "scope") (i18nCell MsgWorkflowScope) . views (resultWorkflowInstance . _entityVal . _workflowInstanceScope . re _DBWorkflowScope) $
|
||||
sqlCell . maybeT (return mempty) . fmap i18n . toRouteWorkflowScope
|
||||
, 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)
|
||||
]
|
||||
where
|
||||
anchorEdit :: (WorkflowInstanceData -> Widget) -> _
|
||||
anchorEdit f x@(view $ resultWorkflowInstance . _entityKey -> wiId) = anchorCellM mkLink $ f x
|
||||
where mkLink = do
|
||||
cID <- encrypt wiId
|
||||
return $ AdminWorkflowInstanceR cID AWIEditR
|
||||
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" . mkFilterProjectedPost $ \(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 MsgTableNoFilter) $ 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
|
||||
dbtExtraReps = []
|
||||
workflowInstancesDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "scope", SortAscBy "name"]
|
||||
in dbTableDB' workflowInstancesDBTableValidator workflowInstancesDBTable
|
||||
|
||||
siteLayoutMsg MsgWorkflowInstanceListTitle $ do
|
||||
setTitleI MsgWorkflowInstanceListTitle
|
||||
|
||||
instancesTable
|
||||
|
||||
|
||||
getGlobalWorkflowInstanceListR :: Handler Html
|
||||
getGlobalWorkflowInstanceListR = workflowInstanceListR WSGlobal
|
||||
|
||||
getSchoolWorkflowInstanceListR :: SchoolId -> Handler Html
|
||||
getSchoolWorkflowInstanceListR = workflowInstanceListR . WSSchool
|
||||
|
||||
|
||||
workflowInstanceListR :: RouteWorkflowScope -> Handler Html
|
||||
workflowInstanceListR rScope = workflowsDisabledWarning title heading $ do
|
||||
instances <- runDB $ do
|
||||
dbScope <- maybeT notFound $ view _DBWorkflowScope <$> fromRouteWorkflowScope rScope
|
||||
|
||||
wis <- selectList [ WorkflowInstanceScope ==. dbScope ] []
|
||||
wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do
|
||||
descs <- lift $ selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
|
||||
desc <- lift . runMaybeT $ do
|
||||
langs <- hoistMaybe . NonEmpty.nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs
|
||||
lang <- selectLanguage langs
|
||||
hoistMaybe . preview _head $ do
|
||||
Entity _ desc@WorkflowInstanceDescription{..} <- descs
|
||||
guard $ workflowInstanceDescriptionLanguage == lang
|
||||
return desc
|
||||
mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute workflowInstanceName
|
||||
mayEdit <- lift . hasReadAccessTo $ toEditRoute workflowInstanceName
|
||||
mayList <- lift . hasReadAccessTo $ toListRoute workflowInstanceName
|
||||
mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute workflowInstanceName
|
||||
guard $ mayInitiate || mayEdit || mayList || mayUpdate
|
||||
canUpdate <- lift $ workflowInstanceCanUpdate wiId
|
||||
return (wi, desc, canUpdate)
|
||||
|
||||
return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc, _)
|
||||
-> ( NTop workflowInstanceCategory
|
||||
, workflowInstanceDescriptionTitle <$> mDesc
|
||||
, workflowInstanceName
|
||||
)
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI title
|
||||
let mPitch = Just $(i18nWidgetFile "workflow-instance-list-explanation")
|
||||
updateForm win = maybeT mempty . guardMOnM (lift . hasWriteAccessTo $ toUpdateRoute win) $ do
|
||||
(updateWdgt, updateEnctype) <- liftHandler . generateFormPost . buttonForm' $ pure BtnWorkflowInstanceUpdate
|
||||
lift $ wrapForm updateWdgt def
|
||||
{ formAction = Just . SomeRoute $ toUpdateRoute win
|
||||
, formEncoding = updateEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
$(widgetFile "workflows/instances")
|
||||
where
|
||||
toInitiateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
||||
toEditRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
|
||||
toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
||||
toUpdateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR)
|
||||
|
||||
(heading, title) = case rScope of
|
||||
WSGlobal -> (MsgGlobalWorkflowInstancesHeading, MsgGlobalWorkflowInstancesTitle)
|
||||
WSSchool ssh -> (MsgSchoolWorkflowInstancesHeading ssh, MsgSchoolWorkflowInstancesTitle ssh)
|
||||
_other -> error "not implemented"
|
||||
|
||||
|
||||
getTopWorkflowInstanceListR :: Handler Html
|
||||
getTopWorkflowInstanceListR = workflowsDisabledWarning title heading $ do
|
||||
gInstances <- runDB $ do
|
||||
wis <- selectList [] []
|
||||
wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do
|
||||
guard $ isTopWorkflowScope workflowInstanceScope
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
||||
descs <- lift $ selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
|
||||
desc <- lift . runMaybeT $ do
|
||||
langs <- hoistMaybe . NonEmpty.nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs
|
||||
lang <- selectLanguage langs
|
||||
hoistMaybe . preview _head $ do
|
||||
Entity _ desc@WorkflowInstanceDescription{..} <- descs
|
||||
guard $ workflowInstanceDescriptionLanguage == lang
|
||||
return desc
|
||||
mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName
|
||||
mayEdit <- lift . hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
|
||||
mayList <- lift . hasReadAccessTo $ toListRoute' rScope workflowInstanceName
|
||||
mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute' rScope workflowInstanceName
|
||||
guard $ mayInitiate || mayEdit || mayList || mayUpdate
|
||||
canUpdate <- lift $ workflowInstanceCanUpdate wiId
|
||||
return (rScope, [(wi, desc, canUpdate)])
|
||||
|
||||
let iSortProj (Entity _ WorkflowInstance{..}, mDesc, _)
|
||||
= ( NTop workflowInstanceCategory
|
||||
, workflowInstanceDescriptionTitle <$> mDesc
|
||||
, workflowInstanceName
|
||||
)
|
||||
return $ sortOn iSortProj <$> Map.fromListWith (<>) wis'
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI title
|
||||
let instanceList rScope instances = $(widgetFile "workflows/instances")
|
||||
where
|
||||
toInitiateRoute = toInitiateRoute' rScope
|
||||
toEditRoute = toEditRoute' rScope
|
||||
toListRoute = toListRoute' rScope
|
||||
toUpdateRoute = toUpdateRoute' rScope
|
||||
mPitch :: Maybe Widget
|
||||
mPitch = Nothing
|
||||
updateForm win = maybeT mempty . guardMOnM (lift . hasWriteAccessTo $ toUpdateRoute win) $ do
|
||||
(updateWdgt, updateEnctype) <- liftHandler . generateFormPost . buttonForm' $ pure BtnWorkflowInstanceUpdate
|
||||
lift $ wrapForm updateWdgt def
|
||||
{ formAction = Just . SomeRoute $ toUpdateRoute win
|
||||
, formEncoding = updateEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
showHeadings = Map.keys gInstances /= [WSGlobal]
|
||||
pitch = $(i18nWidgetFile "workflow-instance-list-explanation")
|
||||
|
||||
$(widgetFile "workflows/top-instances")
|
||||
|
||||
where
|
||||
toInitiateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
||||
toEditRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
|
||||
toListRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
||||
toUpdateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR)
|
||||
|
||||
(title, heading) = (MsgTopWorkflowInstancesTitle, MsgTopWorkflowInstancesHeading)
|
||||
@ -1,83 +0,0 @@
|
||||
module Handler.Workflow.Instance.New
|
||||
( getAdminWorkflowInstanceNewR, postAdminWorkflowInstanceNewR
|
||||
, adminWorkflowInstanceNewR
|
||||
, getGlobalWorkflowInstanceNewR, postGlobalWorkflowInstanceNewR
|
||||
, getSchoolWorkflowInstanceNewR, postSchoolWorkflowInstanceNewR
|
||||
, workflowInstanceNewR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Workflow.Form
|
||||
import Utils.Workflow
|
||||
|
||||
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
|
||||
workflowInstanceGraph <- insertSharedWorkflowGraph wifGraph'
|
||||
let wifScope' = wifScope
|
||||
& over _wisTerm unTermKey
|
||||
& over _wisSchool unSchoolKey
|
||||
& over _wisCourse (view _SqlKey)
|
||||
instId <- insertUnique WorkflowInstance
|
||||
{ workflowInstanceDefinition = wdId
|
||||
, workflowInstanceGraph
|
||||
, 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
|
||||
|
||||
getSchoolWorkflowInstanceNewR, postSchoolWorkflowInstanceNewR :: SchoolId -> Handler Html
|
||||
getSchoolWorkflowInstanceNewR = postSchoolWorkflowInstanceNewR
|
||||
postSchoolWorkflowInstanceNewR = workflowInstanceNewR . WSSchool
|
||||
|
||||
workflowInstanceNewR :: RouteWorkflowScope -> Handler Html
|
||||
workflowInstanceNewR = error "not implemented"
|
||||
@ -1,123 +0,0 @@
|
||||
module Handler.Workflow.Instance.Update
|
||||
( WorkflowInstanceUpdateButton(..)
|
||||
, workflowInstanceCanUpdate
|
||||
, postGWIUpdateR, postSWIUpdateR
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Form
|
||||
import Utils.Workflow
|
||||
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
|
||||
data WorkflowInstanceUpdateButton
|
||||
= BtnWorkflowInstanceUpdate
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
nullaryPathPiece ''WorkflowInstanceUpdateButton $ camelToPathPiece' 3
|
||||
embedRenderMessage ''UniWorX ''WorkflowInstanceUpdateButton id
|
||||
|
||||
instance Button UniWorX WorkflowInstanceUpdateButton where
|
||||
btnClasses _ = [BCIsButton]
|
||||
|
||||
|
||||
data WorkflowInstanceUpdateAction
|
||||
= WIUpdateGraph SharedWorkflowGraphId
|
||||
| WIUpdateCategory (Maybe WorkflowInstanceCategory)
|
||||
| WIUpdateInstanceDescription Lang (Maybe (Text, Maybe StoredMarkup))
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
workflowInstanceUpdates :: WorkflowInstanceId
|
||||
-> DB (Set WorkflowInstanceUpdateAction)
|
||||
workflowInstanceUpdates wiId = execWriterT . maybeT_ $ do
|
||||
WorkflowInstance{..} <- MaybeT . lift $ get wiId
|
||||
wdId <- hoistMaybe workflowInstanceDefinition
|
||||
WorkflowDefinition{..} <- MaybeT . lift $ get wdId
|
||||
|
||||
when (workflowDefinitionGraph /= workflowInstanceGraph) $
|
||||
tellPoint $ WIUpdateGraph workflowDefinitionGraph
|
||||
|
||||
when (workflowDefinitionInstanceCategory /= workflowInstanceCategory) $
|
||||
tellPoint $ WIUpdateCategory workflowDefinitionInstanceCategory
|
||||
|
||||
iDescs <- lift . lift $ selectList [WorkflowInstanceDescriptionInstance ==. wiId] []
|
||||
dDescs <- lift . lift $ selectList [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId] []
|
||||
|
||||
let iDescs' = Map.fromList $ map (\(Entity _ WorkflowInstanceDescription{..}) -> (CI.mk workflowInstanceDescriptionLanguage, (workflowInstanceDescriptionTitle, workflowInstanceDescriptionDescription))) iDescs
|
||||
dDescs' = Map.fromList $ map (\(Entity _ WorkflowDefinitionInstanceDescription{..}) -> (CI.mk workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))) dDescs
|
||||
|
||||
forM_ (Map.keysSet iDescs' `Set.union` Map.keysSet dDescs') $ \lang -> if
|
||||
| Just iDesc <- Map.lookup lang iDescs'
|
||||
, Just dDesc <- Map.lookup lang dDescs'
|
||||
, iDesc /= dDesc
|
||||
-> tellPoint . WIUpdateInstanceDescription (CI.original lang) $ Just dDesc
|
||||
| Just dDesc <- Map.lookup lang dDescs'
|
||||
, not $ Map.member lang iDescs'
|
||||
-> tellPoint . WIUpdateInstanceDescription (CI.original lang) $ Just dDesc
|
||||
| Map.member lang iDescs'
|
||||
, not $ Map.member lang dDescs'
|
||||
-> tellPoint $ WIUpdateInstanceDescription (CI.original lang) Nothing
|
||||
| otherwise
|
||||
-> return ()
|
||||
|
||||
workflowInstanceCanUpdate :: WorkflowInstanceId
|
||||
-> DB Bool
|
||||
workflowInstanceCanUpdate wiId = not . null <$> workflowInstanceUpdates wiId
|
||||
|
||||
|
||||
postGWIUpdateR :: WorkflowInstanceName -> Handler Void
|
||||
postGWIUpdateR = updateR WSGlobal
|
||||
|
||||
postSWIUpdateR :: SchoolId -> WorkflowInstanceName -> Handler Void
|
||||
postSWIUpdateR ssh = updateR $ WSSchool ssh
|
||||
|
||||
|
||||
updateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler a
|
||||
updateR rScope win = do
|
||||
runDB $ do
|
||||
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
|
||||
wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
|
||||
updates <- workflowInstanceUpdates wiId
|
||||
|
||||
when (null updates) $
|
||||
addMessageI Warning MsgWorkflowInstanceUpdateNoActions
|
||||
|
||||
forM_ updates $ \case
|
||||
WIUpdateGraph graphId -> do
|
||||
update wiId [ WorkflowInstanceGraph =. graphId ]
|
||||
addMessageI Success MsgWorkflowInstanceUpdateUpdatedGraph
|
||||
WIUpdateCategory iCat -> do
|
||||
update wiId [ WorkflowInstanceCategory =. iCat ]
|
||||
addMessageI Success MsgWorkflowInstanceUpdateUpdatedCategory
|
||||
WIUpdateInstanceDescription lang Nothing -> do
|
||||
deleteBy $ UniqueWorkflowInstanceDescription wiId lang
|
||||
addMessageI Success $ MsgWorkflowInstanceUpdateDeletedDescriptionLanguage lang
|
||||
WIUpdateInstanceDescription lang (Just (title, mDesc)) -> do
|
||||
void $ upsertBy
|
||||
(UniqueWorkflowInstanceDescription wiId lang)
|
||||
WorkflowInstanceDescription
|
||||
{ workflowInstanceDescriptionInstance = wiId
|
||||
, workflowInstanceDescriptionLanguage = lang
|
||||
, workflowInstanceDescriptionTitle = title
|
||||
, workflowInstanceDescriptionDescription = mDesc
|
||||
}
|
||||
[ WorkflowInstanceDescriptionTitle =. title
|
||||
, WorkflowInstanceDescriptionDescription =. mDesc
|
||||
]
|
||||
addMessageI Success $ MsgWorkflowInstanceUpdateUpdatedDescriptionLanguage lang
|
||||
memcachedByInvalidate (AuthCacheWorkflowInstanceInitiators win rScope) $ Proxy @(Set (WorkflowRole UserId))
|
||||
memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
|
||||
when (isTopWorkflowScope rScope) $
|
||||
memcachedByInvalidate NavCacheHaveTopWorkflowInstancesRoles $ Proxy @(Set ((RouteWorkflowScope, WorkflowInstanceName), WorkflowRole UserId))
|
||||
|
||||
redirect $ _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
|
||||
@ -1,9 +0,0 @@
|
||||
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
|
||||
@ -1,21 +0,0 @@
|
||||
module Handler.Workflow.Workflow.Delete
|
||||
( getGWWDeleteR, postGWWDeleteR
|
||||
, getSWWDeleteR, postSWWDeleteR
|
||||
, workflowDeleteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
|
||||
|
||||
getGWWDeleteR, postGWWDeleteR :: CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getGWWDeleteR = postGWWDeleteR
|
||||
postGWWDeleteR = workflowDeleteR WSGlobal
|
||||
|
||||
getSWWDeleteR, postSWWDeleteR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getSWWDeleteR = postSWWDeleteR
|
||||
postSWWDeleteR ssh = workflowDeleteR $ WSSchool ssh
|
||||
|
||||
workflowDeleteR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
workflowDeleteR = error "not implemented"
|
||||
@ -1,21 +0,0 @@
|
||||
module Handler.Workflow.Workflow.Edit
|
||||
( getGWWEditR, postGWWEditR
|
||||
, getSWWEditR, postSWWEditR
|
||||
, workflowEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Workflow
|
||||
|
||||
|
||||
getGWWEditR, postGWWEditR :: CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getGWWEditR = postGWWEditR
|
||||
postGWWEditR = workflowEditR WSGlobal
|
||||
|
||||
getSWWEditR, postSWWEditR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getSWWEditR = postSWWEditR
|
||||
postSWWEditR ssh = workflowEditR $ WSSchool ssh
|
||||
|
||||
workflowEditR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
workflowEditR = error "not implemented"
|
||||
@ -1,527 +0,0 @@
|
||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
||||
|
||||
module Handler.Workflow.Workflow.List
|
||||
( getGlobalWorkflowWorkflowListR
|
||||
, getSchoolWorkflowWorkflowListR
|
||||
, workflowWorkflowListR
|
||||
, getGWIWorkflowsR
|
||||
, getSWIWorkflowsR
|
||||
, workflowInstanceWorkflowsR
|
||||
, getAdminWorkflowWorkflowListR
|
||||
, getTopWorkflowWorkflowListR
|
||||
) where
|
||||
|
||||
import Import hiding (Last(..), WriterT)
|
||||
|
||||
import Utils.Workflow
|
||||
import Handler.Utils.Workflow
|
||||
|
||||
import Handler.Workflow.Workflow.Workflow (WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor)
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Utils.Form
|
||||
import Handler.Utils hiding (columns)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import Data.Semigroup (Last(..))
|
||||
import qualified Data.Monoid as Monoid (Last(..))
|
||||
|
||||
import Control.Monad.Trans.Writer.Strict (WriterT)
|
||||
import Control.Monad.Trans.State.Strict (execStateT)
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import qualified Data.RFC5051 as RFC5051
|
||||
|
||||
|
||||
data WorkflowWorkflowListFilterProj = WorkflowWorkflowListFilterProj
|
||||
{ wwProjFilterMayAccess :: Maybe Bool
|
||||
, wwProjFilterWorkflowWorkflow :: Maybe [[CI Char]]
|
||||
, wwProjFilterCurrentState :: Maybe [[CI Char]]
|
||||
, wwProjFilterFinal :: Maybe Bool
|
||||
}
|
||||
|
||||
instance Default WorkflowWorkflowListFilterProj where
|
||||
def = WorkflowWorkflowListFilterProj
|
||||
{ wwProjFilterMayAccess = Nothing
|
||||
, wwProjFilterWorkflowWorkflow = Nothing
|
||||
, wwProjFilterCurrentState = Nothing
|
||||
, wwProjFilterFinal = Nothing
|
||||
}
|
||||
|
||||
makeLenses_ ''WorkflowWorkflowListFilterProj
|
||||
|
||||
|
||||
getGlobalWorkflowWorkflowListR :: Handler Html
|
||||
getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
|
||||
|
||||
getSchoolWorkflowWorkflowListR :: SchoolId -> Handler Html
|
||||
getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
|
||||
|
||||
workflowWorkflowListR :: RouteWorkflowScope -> Handler Html
|
||||
workflowWorkflowListR rScope = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) $ do
|
||||
scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
|
||||
workflowWorkflowList headings columns . runReader $ do
|
||||
workflowWorkflow <- view queryWorkflowWorkflow
|
||||
return $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
where
|
||||
columns = def
|
||||
{ wwListColumnScope = False
|
||||
}
|
||||
headings = (MsgWorkflowWorkflowListScopeTitle rScope, MsgWorkflowWorkflowListScopeHeading rScope)
|
||||
|
||||
|
||||
getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
|
||||
getGWIWorkflowsR = workflowInstanceWorkflowsR WSGlobal
|
||||
|
||||
getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html
|
||||
getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh
|
||||
|
||||
workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
|
||||
workflowInstanceWorkflowsR rScope win = workflowsDisabledWarning (MsgWorkflowWorkflowListNamedInstanceTitleDisabled rScope) (MsgWorkflowWorkflowListNamedInstanceHeadingDisabled rScope) $ do
|
||||
(scope, desc) <- runDB $ do
|
||||
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
|
||||
wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
|
||||
desc <- selectWorkflowInstanceDescription wiId
|
||||
return (scope, desc)
|
||||
let headings = case desc of
|
||||
Nothing -> (MsgWorkflowWorkflowListInstanceTitle, MsgWorkflowWorkflowListInstanceHeading)
|
||||
Just (Entity _ WorkflowInstanceDescription{..})
|
||||
-> ( MsgWorkflowWorkflowListNamedInstanceTitle rScope workflowInstanceDescriptionTitle
|
||||
, MsgWorkflowWorkflowListNamedInstanceHeading rScope workflowInstanceDescriptionTitle
|
||||
)
|
||||
workflowWorkflowList headings columns . runReader $ do
|
||||
workflowWorkflow <- view queryWorkflowWorkflow
|
||||
return . E.exists . E.from $ \workflowInstance ->
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
|
||||
E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
E.&&. workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
||||
where
|
||||
columns = def
|
||||
{ wwListColumnInstance = False
|
||||
, wwListColumnScope = False
|
||||
}
|
||||
|
||||
|
||||
getAdminWorkflowWorkflowListR :: Handler Html
|
||||
getAdminWorkflowWorkflowListR = workflowWorkflowList headings def $ const E.true
|
||||
where headings = (MsgAdminWorkflowWorkflowListTitle, MsgAdminWorkflowWorkflowListHeading)
|
||||
|
||||
getTopWorkflowWorkflowListR :: Handler Html
|
||||
getTopWorkflowWorkflowListR = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) . workflowWorkflowList headings def . views queryWorkflowWorkflow $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
|
||||
where headings = (MsgWorkflowWorkflowListTopTitle, MsgWorkflowWorkflowListTopHeading)
|
||||
|
||||
|
||||
type WorkflowWorkflowTableExpr = E.SqlExpr (Entity WorkflowWorkflow)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity WorkflowInstance))
|
||||
|
||||
queryWorkflowWorkflow :: Getter WorkflowWorkflowTableExpr (E.SqlExpr (Entity WorkflowWorkflow))
|
||||
queryWorkflowWorkflow = to $(E.sqlLOJproj 2 1)
|
||||
|
||||
queryWorkflowInstance :: Getter WorkflowWorkflowTableExpr (E.SqlExpr (Maybe (Entity WorkflowInstance)))
|
||||
queryWorkflowInstance = to $(E.sqlLOJproj 2 2)
|
||||
|
||||
type WorkflowWorkflowData = DBRow
|
||||
( CryptoFileNameWorkflowWorkflow
|
||||
, Maybe RouteWorkflowScope
|
||||
, Entity WorkflowWorkflow
|
||||
, Maybe (Entity WorkflowInstance)
|
||||
, Maybe (Entity WorkflowInstanceDescription)
|
||||
, Maybe WorkflowWorkflowActionData
|
||||
, [Entity User]
|
||||
)
|
||||
-- ^ @Maybe `WorkflowWorkflowActionData`@ corresponds to last action
|
||||
|
||||
type WorkflowWorkflowActionData = ( Maybe Text
|
||||
, UTCTime
|
||||
, Maybe WorkflowHistoryItemActor
|
||||
, Maybe Icon
|
||||
)
|
||||
|
||||
data JsonWorkflowWorkflow = JsonWorkflowWorkflow
|
||||
{ jwwScope :: Maybe RouteWorkflowScope
|
||||
, jwwInstance :: Maybe JsonWorkflowInstance
|
||||
, jwwLastAction :: Maybe JsonWorkflowAction
|
||||
, jwwPayload :: Map WorkflowPayloadLabel JsonWorkflowPayload
|
||||
} deriving (Generic)
|
||||
|
||||
data JsonWorkflowAction = JsonWorkflowAction
|
||||
{ jwaIx :: CryptoUUIDWorkflowStateIndex
|
||||
, jwaTo :: Maybe WorkflowGraphNodeLabel
|
||||
, jwaUser :: Maybe JsonWorkflowUser
|
||||
, jwaTime :: UTCTime
|
||||
} deriving (Generic)
|
||||
|
||||
data JsonWorkflowInstance = JsonWorkflowInstance
|
||||
{ jwiScope :: RouteWorkflowScope
|
||||
, jwiName :: WorkflowInstanceName
|
||||
} deriving (Generic)
|
||||
|
||||
data JsonWorkflowPayload = JsonWorkflowPayload
|
||||
{ jwpPayload :: [WorkflowFieldPayloadW Void JsonWorkflowUser]
|
||||
, jwpHasFiles :: Bool
|
||||
} deriving (Generic)
|
||||
|
||||
data JsonWorkflowUser
|
||||
= JsonWorkflowUserUser
|
||||
{ jwuDisplayName :: UserDisplayName
|
||||
, jwuMatriculation :: Maybe UserMatriculation
|
||||
, jwuDisplayEmail :: UserEmail
|
||||
}
|
||||
| JsonWorkflowUserAnonymous
|
||||
| JsonWorkflowUserHidden
|
||||
| JsonWorkflowUserGone
|
||||
deriving (Generic)
|
||||
|
||||
resultWorkflowWorkflowId :: Lens' WorkflowWorkflowData CryptoFileNameWorkflowWorkflow
|
||||
resultWorkflowWorkflowId = _dbrOutput . _1
|
||||
|
||||
resultRouteScope :: Lens' WorkflowWorkflowData (Maybe RouteWorkflowScope)
|
||||
resultRouteScope = _dbrOutput . _2
|
||||
|
||||
resultWorkflowWorkflow :: Lens' WorkflowWorkflowData (Entity WorkflowWorkflow)
|
||||
resultWorkflowWorkflow = _dbrOutput . _3
|
||||
|
||||
resultWorkflowInstance :: Lens' WorkflowWorkflowData (Maybe (Entity WorkflowInstance))
|
||||
resultWorkflowInstance = _dbrOutput . _4
|
||||
|
||||
resultWorkflowInstanceDescription :: Lens' WorkflowWorkflowData (Maybe (Entity WorkflowInstanceDescription))
|
||||
resultWorkflowInstanceDescription = _dbrOutput . _5
|
||||
|
||||
resultWorkflowInstanceTitle :: Getter WorkflowWorkflowData Text
|
||||
resultWorkflowInstanceTitle = to $ \x -> case x ^? resultWorkflowInstanceDescription . _Just . _entityVal . _workflowInstanceDescriptionTitle of
|
||||
Just dTitle -> dTitle
|
||||
Nothing -> x ^. resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName . to CI.original
|
||||
|
||||
resultLastAction :: Lens' WorkflowWorkflowData (Maybe WorkflowWorkflowActionData)
|
||||
resultLastAction = _dbrOutput . _6
|
||||
|
||||
resultPersons :: Traversal' WorkflowWorkflowData (Entity User)
|
||||
resultPersons = _dbrOutput . _7 . traverse
|
||||
|
||||
actionTo :: Lens' WorkflowWorkflowActionData (Maybe Text)
|
||||
actionTo = _1
|
||||
|
||||
actionTime :: Lens' WorkflowWorkflowActionData UTCTime
|
||||
actionTime = _2
|
||||
|
||||
actionActor :: Lens' WorkflowWorkflowActionData (Maybe WorkflowHistoryItemActor)
|
||||
actionActor = _3
|
||||
|
||||
actionFinal :: Lens' WorkflowWorkflowActionData (Maybe Icon)
|
||||
actionFinal = _4
|
||||
|
||||
data WorkflowWorkflowListColumns = WWListColumns
|
||||
{ wwListColumnInstance :: Bool
|
||||
, wwListColumnScope :: Bool
|
||||
}
|
||||
|
||||
instance Default WorkflowWorkflowListColumns where
|
||||
def = WWListColumns
|
||||
{ wwListColumnInstance = True
|
||||
, wwListColumnScope = True
|
||||
}
|
||||
|
||||
workflowWorkflowList :: ( RenderMessage UniWorX title, RenderMessage UniWorX heading)
|
||||
=> (title, heading)
|
||||
-> WorkflowWorkflowListColumns
|
||||
-> (WorkflowWorkflowTableExpr -> E.SqlExpr (E.Value Bool))
|
||||
-> Handler Html
|
||||
workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
||||
mAuthId <- maybeAuthId
|
||||
|
||||
workflowTable <- runDB $
|
||||
let
|
||||
workflowWorkflowDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
workflowWorkflow <- view queryWorkflowWorkflow
|
||||
workflowInstance <- view queryWorkflowInstance
|
||||
lift . E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. workflowInstance E.?. WorkflowInstanceId
|
||||
lift <=< asks $ E.where_ . sqlPred
|
||||
return (workflowWorkflow, workflowInstance)
|
||||
dbtRowKey = views queryWorkflowWorkflow (E.^. WorkflowWorkflowId)
|
||||
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
|
||||
ww@(Entity wwId WorkflowWorkflow{..}) <- view $ _dbtProjRow . _dbrOutput . _1
|
||||
mwi <- view $ _dbtProjRow . _dbrOutput . _2
|
||||
|
||||
cID <- encrypt wwId
|
||||
forMM_ (view $ _dbtProjFilter . _wwProjFilterWorkflowWorkflow) $ \criteria ->
|
||||
let haystack = map CI.mk . unpack $ toPathPiece cID
|
||||
in guard $ any (`isInfixOf` haystack) criteria
|
||||
|
||||
rScope <- lift . lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
forMM_ (view $ _dbtProjFilter . _wwProjFilterMayAccess) $ \needle -> do
|
||||
rScope' <- hoistMaybe rScope
|
||||
guardM . lift . lift $ (== needle) . is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)) False
|
||||
|
||||
wiDesc <- lift . lift . $cachedHereBinary (entityKey <$> mwi) . runMaybeT $ do
|
||||
Entity wiId _ <- hoistMaybe mwi
|
||||
MaybeT $ selectWorkflowInstanceDescription wiId
|
||||
WorkflowGraph{..} <- lift . lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph
|
||||
let hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
|
||||
hasWorkflowRole' role = maybeT (return False) $ do
|
||||
rScope' <- hoistMaybe rScope
|
||||
let canonRoute = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
|
||||
lift . $cachedHereBinary (wwId, role) $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
|
||||
|
||||
let
|
||||
goAction p w = lift . lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p
|
||||
where
|
||||
go Nothing = return Nothing
|
||||
go (Just (act, newSt)) = maybeT (go $ newSt ^? _nullable . p) $ do
|
||||
guardM . lift $ mayViewWorkflowAction mAuthId wwId act
|
||||
Just <$> lift (w act)
|
||||
descAction p = goAction p $ \WorkflowAction{..} ->
|
||||
let actName = runMaybeT $ do
|
||||
WorkflowNodeView{..} <- hoistMaybe $ Map.lookup wpTo wgNodes >>= wgnViewers
|
||||
guardM . lift $ anyM (otoList wnvViewers) hasWorkflowRole'
|
||||
selectLanguageI18n wnvDisplayLabel
|
||||
actUser = for wpUser $ \wpUser' -> if
|
||||
| is _Just mAuthId
|
||||
, wpUser' == mAuthId -> return WHIASelf
|
||||
| otherwise -> maybeT (return WHIAHidden) $ do
|
||||
viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
|
||||
guardM . lift $ anyM (otoList viewActors) hasWorkflowRole'
|
||||
resUser <- lift . for wpUser' $ \uid -> $cachedHereBinary uid $ getEntity uid
|
||||
return $ case resUser of
|
||||
Nothing -> WHIAOther Nothing
|
||||
Just Nothing -> WHIAGone
|
||||
Just (Just uEnt) -> WHIAOther $ Just uEnt
|
||||
where mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes
|
||||
actFinal = do
|
||||
WGN{..} <- Map.lookup wpTo wgNodes
|
||||
wgnFinal
|
||||
in (,,,)
|
||||
<$> actName
|
||||
<*> pure wpTime
|
||||
<*> actUser
|
||||
<*> pure actFinal
|
||||
lastAct <- descAction $ re _nullable . _Snoc . swapped
|
||||
|
||||
persons' <- lift . lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do
|
||||
let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes
|
||||
guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act
|
||||
lift . maybeT_ . hoist (zoom _1) $ do
|
||||
viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
|
||||
guardM . lift . lift $ anyM (otoList viewActors) hasWorkflowRole'
|
||||
State.modify' $ Set.insert wpUser'
|
||||
iforM_ (wpPayload act) $ \pLbl ps -> lift . maybeT_ . hoist (zoom _2) $ do
|
||||
let users = setOf (typesCustom @WorkflowChildren) ps
|
||||
guard . not $ null users
|
||||
WorkflowPayloadView{..} <- hoistMaybe $ do
|
||||
WGN{wgnPayloadView} <- Map.lookup (wpTo act) wgNodes
|
||||
Map.lookup pLbl wgnPayloadView
|
||||
guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole'
|
||||
at pLbl ?= users
|
||||
|
||||
persons <- lift . lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons'
|
||||
|
||||
return (cID, rScope, ww, mwi, wiDesc, lastAct, persons)
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat -- TODO: columns
|
||||
[ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . (toPathPiece :: CryptoFileNameWorkflowWorkflow -> Text)
|
||||
, guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x
|
||||
, guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x
|
||||
, sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x ->
|
||||
let lCell = flip listCell (uncurry userCell) . sortBy personCmp $ x ^.. resultPersons . _entityVal . to ((,) <$> userDisplayName <*> userSurname)
|
||||
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
, sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell
|
||||
, sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell
|
||||
, sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell
|
||||
]
|
||||
where
|
||||
personCmp = (RFC5051.compareUnicode `on` (pack . toListOf (_2 . to (unpack . CI.foldCase) . folded)))
|
||||
<> (RFC5051.compareUnicode `on` (pack . toListOf (_1 . to (unpack . CI.foldCase) . folded)))
|
||||
|
||||
stateCell = \case
|
||||
(Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text)
|
||||
(Just n, Nothing) -> textCell n
|
||||
(Just n, Just fin) -> cell [whamlet|#{icon fin} #{n}|]
|
||||
actorCell = \case
|
||||
Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text)
|
||||
Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text)
|
||||
Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text)
|
||||
Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text)
|
||||
Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text)
|
||||
Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname
|
||||
|
||||
anchorWorkflowWorkflow :: (WorkflowWorkflowData -> Widget) -> _
|
||||
anchorWorkflowWorkflow f = maybeAnchorCellM <$> mkLink <*> f
|
||||
where mkLink = runReaderT $ do
|
||||
cID <- view resultWorkflowWorkflowId
|
||||
rScope <- hoistMaybe =<< view resultRouteScope
|
||||
return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f
|
||||
where mkLink = runReaderT $ do
|
||||
rScope <- hoistMaybe =<< view resultRouteScope
|
||||
return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
|
||||
anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f
|
||||
where mkLink = runReaderT $ do
|
||||
rScope <- hoistMaybe =<< view resultRouteScope
|
||||
win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName)
|
||||
return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
||||
dbtSorting = mconcat
|
||||
[ singletonMap "workflow-workflow" . SortProjected . comparing $ view resultWorkflowWorkflowId
|
||||
, singletonMap "scope" . SortProjected . comparing $ view resultRouteScope
|
||||
, singletonMap "instance" . SortProjected . comparing $ preview resultWorkflowInstanceTitle
|
||||
, singletonMap "current-state" . SortProjected . comparing . preview $ resultLastAction . _Just . actionTo . _Just
|
||||
, singletonMap "last-action-time" . SortProjected . comparing . preview $ resultLastAction . _Just . actionTime
|
||||
, singletonMap "last-action-user" . SortProjected . comparing . preview $ resultLastAction . _Just . actionActor . to (over (mapped . mapped) $ \(Entity _ User{..}) -> (userSurname, userDisplayName))
|
||||
, singletonMap "final" . SortProjected . comparing $ \x -> guardOnM (has (resultLastAction . _Just . actionTo . _Just) x) (x ^? resultLastAction . _Just . actionFinal . _Just)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ singletonMap "workflow-workflow" . FilterProjected $ \(criteria :: Set Text) ->
|
||||
let criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
in _wwProjFilterWorkflowWorkflow ?~ criteria'
|
||||
, singletonMap "current-state" . FilterProjected $ \(criteria :: Set Text) -> -- TODO
|
||||
let criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
in _wwProjFilterCurrentState ?~ criteria'
|
||||
, singletonMap "final" . FilterProjected $ \(criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of -- TODO
|
||||
Nothing -> id
|
||||
Just needle -> _wwProjFilterFinal ?~ needle
|
||||
, singletonMap "may-access" . FilterProjected $ \(Any criterion) -> _wwProjFilterMayAccess ?~ criterion
|
||||
]
|
||||
-- [ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) ->
|
||||
-- let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId
|
||||
-- criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
-- in any (`isInfixOf` cid) criteria'
|
||||
-- ,
|
||||
|
||||
-- , singletonMap "may-access" . FilterPreProjected $ \(x :: DBRow (Entity WorkflowWorkflow, Maybe (Entity WorkflowInstance))) (Any b) -> fmap (== b) . maybeT (return False) $ do
|
||||
-- let Entity wwId WorkflowWorkflow{..} = x ^. _dbrOutput . _1
|
||||
-- cID <- encrypt wwId
|
||||
-- rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
-- lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool
|
||||
-- , singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) ->
|
||||
-- let criteria' = map CI.mk . unpack <$> Set.toList criteria
|
||||
-- in maybe False (\cSt -> any (`isInfixOf` cSt) criteria') $ x ^? resultLastAction . _Just . actionTo . _Just . to (map CI.mk . unpack)
|
||||
-- , singletonMap "final" . FilterProjected $ \x (criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of
|
||||
-- Nothing -> True
|
||||
-- Just needle -> let val = has (resultLastAction . _Just . actionTo . _Just) x
|
||||
-- && has (resultLastAction . _Just . actionFinal . _Just) x
|
||||
-- in needle == val
|
||||
-- ]
|
||||
dbtFilterUI = mconcat
|
||||
[ flip (prismAForm $ singletonFilter "workflow-workflow") $ aopt textField (fslI MsgWorkflowWorkflowListNumber)
|
||||
, flip (prismAForm $ singletonFilter "current-state") $ aopt textField (fslI MsgWorkflowWorkflowListCurrentState)
|
||||
|
||||
, flip (prismAForm (singletonFilter "final" . maybePrism _PathPiece)) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgWorkflowWorkflowListIsFinal)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "workflow-workflows"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
dbtExtraReps = [ DBTExtraRep $ toPrettyJSON <$> repWorkflowWorkflowJson, DBTExtraRep $ toYAML <$> repWorkflowWorkflowJson ]
|
||||
|
||||
repWorkflowWorkflowJson :: ConduitT (E.Value WorkflowWorkflowId, WorkflowWorkflowData) Void DB (Map CryptoFileNameWorkflowWorkflow JsonWorkflowWorkflow)
|
||||
repWorkflowWorkflowJson = C.foldMapM $ \(E.Value wwId, res) -> do
|
||||
cID <- encrypt wwId
|
||||
Map.singleton cID <$> do
|
||||
let jwwScope = guardOnM wwListColumnScope $ res ^. resultRouteScope
|
||||
jwwInstance <- fmap join . for (guardOnM wwListColumnInstance $ res ^. resultWorkflowInstance) $ \(Entity _ WorkflowInstance{..}) -> runMaybeT $ do
|
||||
jwiScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
||||
let jwiName = workflowInstanceName
|
||||
return JsonWorkflowInstance{..}
|
||||
let Entity _ WorkflowWorkflow{..} = res ^. resultWorkflowWorkflow
|
||||
WorkflowGraph{..} <- getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
(fmap getLast -> wState) <-
|
||||
let go :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> WorkflowActionInfo FileReference UserId
|
||||
-> WriterT (Maybe (Last (CryptoUUIDWorkflowStateIndex, Maybe WorkflowGraphNodeLabel, Maybe JsonWorkflowUser, UTCTime, Map WorkflowPayloadLabel JsonWorkflowPayload))) (SqlPersistT m) ()
|
||||
go WorkflowActionInfo{ waiIx = stIx, waiHistory = (workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..}} = maybeT_ $ do
|
||||
stCID <- encryptWorkflowStateIndex wwId stIx
|
||||
|
||||
rScope <- hoistMaybe $ res ^. resultRouteScope
|
||||
|
||||
let toJsonUser (Just (Entity _ User{..})) = JsonWorkflowUserUser
|
||||
{ jwuDisplayName = userDisplayName
|
||||
, jwuMatriculation = userMatrikelnummer
|
||||
, jwuDisplayEmail = userDisplayEmail
|
||||
}
|
||||
toJsonUser Nothing = JsonWorkflowUserGone
|
||||
|
||||
mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes
|
||||
hasWorkflowRole' role = $cachedHereBinary (rScope, wwId, role) . lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
|
||||
canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
|
||||
aUser <- for wpUser $ \wpUser' -> lift . maybeT (return JsonWorkflowUserHidden) $ do
|
||||
viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
|
||||
guardM $ anyM (otoList viewActors) hasWorkflowRole'
|
||||
resUser <- lift . lift $ traverse getEntity wpUser'
|
||||
return $ maybe JsonWorkflowUserAnonymous toJsonUser resUser
|
||||
|
||||
payload <- do
|
||||
payload' <- fmap Map.fromList . forMaybeM (Map.toList currentPayload) $ \x@(payloadLbl, _) -> x <$ do
|
||||
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
|
||||
guardM . $cachedHereBinary payloadLbl . anyM (otoList wpvViewers) $ lift . hasWorkflowRole'
|
||||
forM payload' $ \(otoList -> payloads) -> fmap (uncurry JsonWorkflowPayload . over _2 getAny) . execWriterT @_ @(_, Any) . forM_ payloads $ \case
|
||||
WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
|
||||
WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
|
||||
WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
|
||||
WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
|
||||
WorkflowFieldPayloadW (WFPTime t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPTime t)
|
||||
WorkflowFieldPayloadW (WFPDateTime t) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDateTime t)
|
||||
WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True)
|
||||
WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . toJsonUser =<< lift (lift . lift $ getEntity uid)
|
||||
|
||||
nTo <- runMaybeT $ do
|
||||
WGN{..} <- hoistMaybe $ Map.lookup wpTo wgNodes
|
||||
WorkflowNodeView{..} <- hoistMaybe wgnViewers
|
||||
guardM . lift $ anyM (otoList wnvViewers) hasWorkflowRole'
|
||||
return wpTo
|
||||
|
||||
tell . Just $ Last (stCID, nTo, aUser, wpTime, payload)
|
||||
|
||||
wState = review _DBWorkflowState workflowWorkflowState
|
||||
in runConduit $ sourceWorkflowActionInfos wwId wState .| execWriterC (C.mapM_ go)
|
||||
|
||||
let jwwLastAction = wState <&> \(jwaIx, jwaTo, jwaUser, jwaTime, _) -> JsonWorkflowAction{..}
|
||||
jwwPayload = wState ^. _Just . _5
|
||||
|
||||
return JsonWorkflowWorkflow{..}
|
||||
workflowWorkflowDBTableValidator = def
|
||||
& defaultSorting defSort
|
||||
& forceFilter "may-access" (Any True)
|
||||
defSort | wwListColumnInstance = SortAscBy "instance" : defSort'
|
||||
| otherwise = defSort'
|
||||
where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"]
|
||||
in dbTableDB' workflowWorkflowDBTableValidator workflowWorkflowDBTable
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI title
|
||||
$(widgetFile "workflows/workflow-list")
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''JsonWorkflowWorkflow
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''JsonWorkflowAction
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''JsonWorkflowInstance
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''JsonWorkflowPayload
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 3
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''JsonWorkflowUser
|
||||
@ -1,10 +0,0 @@
|
||||
module Handler.Workflow.Workflow.New
|
||||
( getAdminWorkflowWorkflowNewR, postAdminWorkflowWorkflowNewR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
|
||||
getAdminWorkflowWorkflowNewR, postAdminWorkflowWorkflowNewR :: Handler Html
|
||||
getAdminWorkflowWorkflowNewR = postAdminWorkflowWorkflowNewR
|
||||
postAdminWorkflowWorkflowNewR = error "not implemented"
|
||||
@ -1,280 +0,0 @@
|
||||
module Handler.Workflow.Workflow.Workflow
|
||||
( getGWWWorkflowR, postGWWWorkflowR, getGWWFilesR
|
||||
, getSWWWorkflowR, postSWWWorkflowR, getSWWFilesR
|
||||
, workflowR
|
||||
, WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor
|
||||
) where
|
||||
|
||||
import Import hiding (Last(..), Encoding(None))
|
||||
|
||||
import Utils.Form
|
||||
import Utils.Workflow
|
||||
|
||||
import Data.Semigroup (Last(..))
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Workflow
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
import Control.Monad.Trans.RWS.Strict (RWST)
|
||||
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteArray as BA
|
||||
import Crypto.Hash.Algorithms (SHAKE256)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import Data.RFC5051 (compareUnicode)
|
||||
|
||||
import qualified Data.Scientific as Scientific
|
||||
import Text.Blaze (toMarkup)
|
||||
import Data.Void (absurd)
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
data WorkflowHistoryItemActor' user = WHIASelf | WHIAOther (Maybe user) | WHIAHidden | WHIAGone
|
||||
deriving (Eq, Ord, Functor, Traversable, Foldable, Generic, Typeable)
|
||||
type WorkflowHistoryItemActor = WorkflowHistoryItemActor' (Entity User)
|
||||
|
||||
data WorkflowHistoryItem = WorkflowHistoryItem
|
||||
{ whiUser :: Maybe WorkflowHistoryItemActor
|
||||
, whiTime :: UTCTime
|
||||
, whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
|
||||
, whiFrom :: Maybe (Maybe (Text, Maybe Icon)) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
|
||||
, whiVia :: Maybe Text
|
||||
, whiTo :: Maybe (Text, Maybe Icon)
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
data WorkflowCurrentState = WorkflowCurrentState
|
||||
{ wcsState :: Maybe (Text, Maybe Icon)
|
||||
, wcsMessages :: Set Message
|
||||
, wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
|
||||
}
|
||||
|
||||
makePrisms ''WorkflowHistoryItemActor'
|
||||
|
||||
|
||||
getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getGWWWorkflowR = postGWWWorkflowR
|
||||
postGWWWorkflowR = workflowR WSGlobal
|
||||
|
||||
getGWWFilesR :: CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
|
||||
getGWWFilesR = getWorkflowFilesR WSGlobal
|
||||
|
||||
getSWWWorkflowR, postSWWWorkflowR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getSWWWorkflowR = postSWWWorkflowR
|
||||
postSWWWorkflowR ssh = workflowR $ WSSchool ssh
|
||||
|
||||
getSWWFilesR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
|
||||
getSWWFilesR ssh = getWorkflowFilesR $ WSSchool ssh
|
||||
|
||||
|
||||
workflowR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
workflowR rScope cID = workflowsDisabledWarning title heading $ do
|
||||
(mEdge, (workflowState, workflowHistory)) <- runDB $ do
|
||||
wwId <- decrypt cID
|
||||
WorkflowWorkflow{..} <- get404 wwId
|
||||
maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
|
||||
mEdgeForm <- workflowEdgeForm (Right wwId) Nothing
|
||||
wGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
|
||||
let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
|
||||
mEdge <- for mEdgeForm $ \edgeForm -> do
|
||||
((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm
|
||||
edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
|
||||
nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState
|
||||
|
||||
wInstance <- for workflowWorkflowInstance $ \wiId -> do
|
||||
wInstance@WorkflowInstance{..} <- get404 wiId
|
||||
wiScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
||||
return (wiScope, Entity wiId wInstance)
|
||||
|
||||
update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]
|
||||
|
||||
return . Just $ do
|
||||
whenIsJust wInstance $ \(wiScope, Entity _ WorkflowInstance{..}) -> do
|
||||
memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers workflowInstanceName wiScope) $ Proxy @(Set ((DBWorkflowScope, WorkflowWorkflowId), WorkflowRole UserId))
|
||||
memcachedByInvalidate (NavCacheHaveWorkflowWorkflowsRoles wiScope) $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow), WorkflowRole UserId))
|
||||
when (isTopWorkflowScope wiScope) $
|
||||
memcachedByInvalidate NavCacheHaveTopWorkflowWorkflowsRoles $ Proxy @(Set ((WorkflowWorkflowId, CryptoFileNameWorkflowWorkflow, RouteWorkflowScope), WorkflowRole UserId))
|
||||
memcachedByInvalidate (AuthCacheWorkflowWorkflowEdgeActors cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
|
||||
memcachedByInvalidate (AuthCacheWorkflowWorkflowViewers cID) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
|
||||
|
||||
addMessageI Success MsgWorkflowWorkflowWorkflowEdgeSuccess
|
||||
|
||||
redirect canonRoute
|
||||
return ((edgeAct, edgeView), edgeEnc)
|
||||
|
||||
(fmap getLast -> workflowState, workflowHistory) <-
|
||||
let go :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> WorkflowActionInfo FileReference UserId
|
||||
-> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) ()
|
||||
go WorkflowActionInfo{ waiIx = stIx, waiFrom = wpFrom, waiHistory = history@(workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..} } = maybeT_ $ do
|
||||
mAuthId <- maybeAuthId
|
||||
|
||||
stCID <- encryptWorkflowStateIndex wwId stIx
|
||||
let nodeView nodeLbl = do
|
||||
WGN{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes
|
||||
WorkflowNodeView{..} <- hoistMaybe wgnViewers
|
||||
guardM $ anyM (otoList wnvViewers) hasWorkflowRole'
|
||||
(, wgnFinal) <$> selectLanguageI18n wnvDisplayLabel
|
||||
whiTime = wpTime
|
||||
mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes
|
||||
hasWorkflowRole' role = $cachedHereBinary (rScope, wwId, role) . lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
|
||||
|
||||
whiTo <- lift . runMaybeT $ nodeView wpTo
|
||||
let wcsState = whiTo
|
||||
|
||||
whiUser <- for wpUser $ \wpUser' -> if
|
||||
| is _Just mAuthId
|
||||
, wpUser' == mAuthId -> return WHIASelf
|
||||
| otherwise -> lift . maybeT (return WHIAHidden) $ do
|
||||
viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
|
||||
guardM $ anyM (otoList viewActors) hasWorkflowRole'
|
||||
resUser <- lift . lift $ traverse getEntity wpUser'
|
||||
return $ case resUser of
|
||||
Nothing -> WHIAOther Nothing
|
||||
Just Nothing -> WHIAGone
|
||||
Just (Just uEnt) -> WHIAOther $ Just uEnt
|
||||
|
||||
whiVia <- traverse selectLanguageI18n $ preview _wgeDisplayLabel =<< mVia
|
||||
whiFrom <- for wpFrom $ lift . runMaybeT . nodeView
|
||||
|
||||
let renderPayload payload = do
|
||||
sBoxKey <- secretBoxKey
|
||||
let payloadLabelToDigest :: WorkflowPayloadLabel -> ByteString
|
||||
payloadLabelToDigest = BA.convert . kmaclazy @(SHAKE256 256) ("workflow-workflow-payload-sorting" :: ByteString) (Saltine.encode sBoxKey) . Binary.encode . (wwId, )
|
||||
payloadLabelSort = (compareUnicode `on` views (_2 . _1) Text.toLower)
|
||||
<> comparing (views _1 payloadLabelToDigest)
|
||||
payload' <- fmap (map (view _2) . sortBy payloadLabelSort) . forMaybeM (Map.toList payload) $ \(payloadLbl, newPayload) -> do
|
||||
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes)
|
||||
guardM . $cachedHereBinary payloadLbl . anyM (otoList wpvViewers) $ lift . hasWorkflowRole'
|
||||
let fRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID (WWFilesR payloadLbl stCID))
|
||||
(payloadLbl, ) . (, (newPayload, fRoute)) <$> selectLanguageI18n wpvDisplayLabel
|
||||
let
|
||||
payloadSort :: WorkflowFieldPayloadW Void (Maybe (Entity User))
|
||||
-> WorkflowFieldPayloadW Void (Maybe (Entity User))
|
||||
-> Ordering
|
||||
payloadSort = workflowPayloadSort ordFiles ordUsers
|
||||
where
|
||||
ordFiles = absurd
|
||||
ordUsers a' b' = case (a', b') of
|
||||
(Nothing, _) -> GT
|
||||
(_, Nothing) -> LT
|
||||
(Just (Entity _ uA), Just (Entity _ uB))
|
||||
-> (compareUnicode `on` userSurname) uA uB
|
||||
<> (compareUnicode `on` userDisplayName) uA uB
|
||||
<> comparing userIdent uA uB
|
||||
|
||||
forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl . bool Nothing (Just fRoute) . getAny) <=< execWriterT @_ @(_, Any) . forM_ payloads $ \case
|
||||
WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
|
||||
WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
|
||||
WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
|
||||
WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
|
||||
WorkflowFieldPayloadW (WFPTime t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPTime t)
|
||||
WorkflowFieldPayloadW (WFPDateTime t) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDateTime t)
|
||||
WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True)
|
||||
WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
|
||||
|
||||
payloadChanges <- State.state $ \oldPayload ->
|
||||
( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload
|
||||
, currentPayload
|
||||
)
|
||||
whiPayloadChanges <- renderPayload payloadChanges
|
||||
wcsPayload <- renderPayload currentPayload
|
||||
|
||||
wcsMessages <- do
|
||||
let msgs = maybe Set.empty wgnMessages $ Map.lookup wpTo wgNodes
|
||||
flip foldMapM msgs $ \WorkflowNodeMessage{..} -> lift . maybeT (return Set.empty) . fmap Set.singleton $ do
|
||||
guardM $ anyM (otoList wnmViewers) hasWorkflowRole'
|
||||
history' <- hoistMaybe . fromNullable $ Seq.fromList history
|
||||
whenIsJust wnmRestriction $ guard . checkWorkflowRestriction (Just history')
|
||||
let messageStatus = wnmStatus
|
||||
messageIcon = Nothing
|
||||
messageContent <- selectLanguageI18n wnmContent
|
||||
return Message{..}
|
||||
|
||||
tell ( Just $ Last WorkflowCurrentState{..}
|
||||
, pure WorkflowHistoryItem{..}
|
||||
)
|
||||
WorkflowGraph{..} = wGraph
|
||||
wState = review _DBWorkflowState workflowWorkflowState
|
||||
in fmap (over _2 (sortOn (Down . whiTime) . reverse) . view _2) . runConduit $ sourceWorkflowActionInfos wwId wState .| execRWSC () Map.empty (C.mapM_ go)
|
||||
return (mEdge, (workflowState, workflowHistory))
|
||||
|
||||
sequenceOf_ (_Just . _1 . _1 . _Just) mEdge
|
||||
|
||||
let headingWgt
|
||||
| Just WorkflowCurrentState{..} <- workflowState
|
||||
, Just (_, Just icn) <- wcsState
|
||||
= [whamlet|_{heading} #{icon icn}|]
|
||||
| otherwise = i18n heading
|
||||
|
||||
siteLayout headingWgt $ do
|
||||
setTitleI title
|
||||
let mEdgeView = mEdge <&> \((_, edgeView'), edgeEnc) -> wrapForm edgeView' FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
, formEncoding = edgeEnc
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Nothing :: Maybe Text
|
||||
}
|
||||
historyToWidget WorkflowHistoryItem{..} = $(widgetFile "workflows/workflow/history-item")
|
||||
payloadToWidget :: WorkflowFieldPayloadW Void (Maybe (Entity User)) -> Widget
|
||||
payloadToWidget = \case
|
||||
WorkflowFieldPayloadW (WFPText t )
|
||||
-> [whamlet|
|
||||
$newline never
|
||||
<p .workflow-payload--text>
|
||||
#{t}
|
||||
|]
|
||||
WorkflowFieldPayloadW (WFPNumber n ) -> toWidget . toMarkup $ formatScientific Scientific.Fixed Nothing n
|
||||
WorkflowFieldPayloadW (WFPBool b ) -> i18n $ WorkflowPayloadBool b
|
||||
WorkflowFieldPayloadW (WFPDay d ) -> formatTimeW SelFormatDate d
|
||||
WorkflowFieldPayloadW (WFPTime t ) -> formatTimeW SelFormatTime t
|
||||
WorkflowFieldPayloadW (WFPDateTime t ) -> formatTimeW SelFormatDateTime t
|
||||
WorkflowFieldPayloadW (WFPUser mUserEnt) -> case mUserEnt of
|
||||
Nothing -> i18n MsgWorkflowPayloadUserGone
|
||||
Just (Entity _ User{..}) -> nameWidget userDisplayName userSurname
|
||||
WorkflowFieldPayloadW (WFPFile v ) -> absurd v
|
||||
$(widgetFile "workflows/workflow")
|
||||
where
|
||||
(heading, title) = case rScope of
|
||||
WSGlobal -> (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
|
||||
WSSchool ssh -> (MsgSchoolWorkflowWorkflowWorkflowHeading ssh cID, MsgSchoolWorkflowWorkflowWorkflowTitle ssh cID)
|
||||
_other -> error "not implemented"
|
||||
|
||||
getWorkflowFilesR :: RouteWorkflowScope
|
||||
-> CryptoFileNameWorkflowWorkflow
|
||||
-> WorkflowPayloadLabel
|
||||
-> CryptoUUIDWorkflowStateIndex
|
||||
-> Handler TypedContent
|
||||
getWorkflowFilesR rScope wwCID wpl stCID = do
|
||||
fRefs <- runDB $ do
|
||||
wwId <- decrypt wwCID
|
||||
WorkflowWorkflow{..} <- get404 wwId
|
||||
maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
|
||||
stIx <- decryptWorkflowStateIndex wwId stCID
|
||||
payloads <- maybeT notFound . workflowStateSection stIx $ _DBWorkflowState # workflowWorkflowState
|
||||
mAuthId <- maybeAuthId
|
||||
payloads' <- fmap (Map.findWithDefault Set.empty wpl . workflowStateCurrentPayloads) . filterM (mayViewWorkflowAction mAuthId wwId) $ otoList payloads
|
||||
let
|
||||
payloads'' :: [FileReference]
|
||||
payloads'' = payloads' ^.. folded . _WorkflowFieldPayloadW . _WorkflowFieldPayload
|
||||
when (null payloads'') notFound
|
||||
return payloads''
|
||||
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgWorkflowWorkflowFilesArchiveName wwCID wpl stCID
|
||||
|
||||
serveSomeFiles archiveName $ yieldMany fRefs
|
||||
@ -34,7 +34,6 @@ import Control.Monad.Logger (askLoggerIO, runLoggingT)
|
||||
import System.Clock
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
import Jobs.Handler.Intervals.Utils
|
||||
|
||||
@ -77,12 +76,6 @@ fileReferences fHash'@(E.just -> fHash)
|
||||
E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. chunkLock E.^. FileChunkLockHash
|
||||
]
|
||||
|
||||
workflowFileReferences :: MonadResource m => Map Text (ConduitT () FileContentReference (SqlPersistT m) ())
|
||||
workflowFileReferences = Map.fromList $ over (traverse . _1) nameToPathPiece
|
||||
[ (''SharedWorkflowGraph, E.selectSource (E.from $ pure . (E.^. SharedWorkflowGraphGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue))
|
||||
, (''WorkflowWorkflow, E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue))
|
||||
]
|
||||
|
||||
|
||||
dispatchJobDetectMissingFiles :: JobHandler UniWorX
|
||||
dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
|
||||
@ -103,9 +96,6 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
|
||||
E.distinctOnOrderBy [E.asc ref] $ return ref
|
||||
transPipe lift (E.selectSource fileReferencesQuery) .| C.mapMaybe E.unValue .| C.mapM_ (insertRef refKind)
|
||||
|
||||
iforM_ workflowFileReferences $ \refKind refSource ->
|
||||
transPipe (lift . withReaderT projectBackend) (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind)
|
||||
|
||||
let allMissingDb :: Set Minio.Object
|
||||
allMissingDb = setOf (folded . folded . re minioFileReference) missingDb
|
||||
filterMissingDb :: forall m. Monad m
|
||||
@ -203,15 +193,6 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
|
||||
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
|
||||
return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
|
||||
E.where_ $ chunkIdFilter unreferencedChunkHash
|
||||
|
||||
let unmarkWorkflowFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do
|
||||
let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
|
||||
E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
|
||||
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
|
||||
return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs
|
||||
E.where_ $ chunkIdFilter unreferencedChunkHash
|
||||
chunkSize = 100
|
||||
in runConduit $ sequence_ workflowFileReferences .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkWorkflowFiles
|
||||
|
||||
let
|
||||
getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do
|
||||
|
||||
@ -47,7 +47,6 @@ import Data.Time.Format
|
||||
|
||||
import qualified Data.Time.Zones as TZ
|
||||
|
||||
import Utils.Workflow
|
||||
|
||||
|
||||
data ManualMigration
|
||||
@ -99,7 +98,6 @@ data ManualMigration
|
||||
| Migration20201106StoredMarkup
|
||||
| Migration20201119RoomTypes
|
||||
| Migration20210115ExamPartsFrom
|
||||
| Migration20210201SharedWorkflowGraphs
|
||||
| Migration20210208StudyFeaturesRelevanceCachedUUIDs
|
||||
| Migration20210318CrontabSubmissionRatedNotification
|
||||
| Migration20210608SeparateTermActive
|
||||
@ -981,55 +979,6 @@ customMigrations = mapF $ \case
|
||||
migrateExam _ = return ()
|
||||
in runConduit $ getExam .| C.mapM_ migrateExam
|
||||
|
||||
Migration20210201SharedWorkflowGraphs -> do
|
||||
unlessM (tableExists "shared_workflow_graph")
|
||||
[executeQQ|CREATE TABLE "shared_workflow_graph" ("hash" bytea primary key, "graph" jsonb not null)|]
|
||||
|
||||
whenM (tableExists "workflow_definition") $ do
|
||||
[executeQQ|ALTER TABLE "workflow_definition" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
|
||||
let getDefinitions = [queryQQ|SELECT "id", "graph" FROM "workflow_definition"|]
|
||||
migrateDefinition [ fromPersistValue -> Right (wdId :: WorkflowDefinitionId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
|
||||
swgId <- insertSharedWorkflowGraph graph
|
||||
[executeQQ|UPDATE "workflow_definition" SET "graph_id" = #{swgId} WHERE "id" = #{wdId}|]
|
||||
migrateDefinition _ = return ()
|
||||
in runConduit $ getDefinitions .| C.mapM_ migrateDefinition
|
||||
|
||||
[executeQQ|
|
||||
ALTER TABLE "workflow_definition" DROP COLUMN "graph";
|
||||
ALTER TABLE "workflow_definition" ALTER COLUMN "graph_id" SET not null;
|
||||
ALTER TABLE "workflow_definition" RENAME COLUMN "graph_id" TO "graph";
|
||||
|]
|
||||
|
||||
whenM (tableExists "workflow_instance") $ do
|
||||
[executeQQ|ALTER TABLE "workflow_instance" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
|
||||
let getInstances = [queryQQ|SELECT "id", "graph" FROM "workflow_instance"|]
|
||||
migrateInstance [ fromPersistValue -> Right (wiId :: WorkflowInstanceId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
|
||||
swgId <- insertSharedWorkflowGraph graph
|
||||
[executeQQ|UPDATE "workflow_instance" SET "graph_id" = #{swgId} WHERE "id" = #{wiId}|]
|
||||
migrateInstance _ = return ()
|
||||
in runConduit $ getInstances .| C.mapM_ migrateInstance
|
||||
|
||||
[executeQQ|
|
||||
ALTER TABLE "workflow_instance" DROP COLUMN "graph";
|
||||
ALTER TABLE "workflow_instance" ALTER COLUMN "graph_id" SET not null;
|
||||
ALTER TABLE "workflow_instance" RENAME COLUMN "graph_id" TO "graph";
|
||||
|]
|
||||
|
||||
whenM (tableExists "workflow_workflow") $ do
|
||||
[executeQQ|ALTER TABLE "workflow_workflow" ADD COLUMN "graph_id" bytea references shared_workflow_graph(hash)|]
|
||||
let getWorkflows = [queryQQ|SELECT "id", "graph" FROM "workflow_workflow"|]
|
||||
migrateWorkflow [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fromPersistValue -> Right (graph :: DBWorkflowGraph) ] = do
|
||||
swgId <- insertSharedWorkflowGraph graph
|
||||
[executeQQ|UPDATE "workflow_workflow" SET "graph_id" = #{swgId} WHERE "id" = #{wwId}|]
|
||||
migrateWorkflow _ = return ()
|
||||
in runConduit $ getWorkflows .| C.mapM_ migrateWorkflow
|
||||
|
||||
[executeQQ|
|
||||
ALTER TABLE "workflow_workflow" DROP COLUMN "graph";
|
||||
ALTER TABLE "workflow_workflow" ALTER COLUMN "graph_id" SET not null;
|
||||
ALTER TABLE "workflow_workflow" RENAME COLUMN "graph_id" TO "graph";
|
||||
|]
|
||||
|
||||
Migration20210208StudyFeaturesRelevanceCachedUUIDs ->
|
||||
whenM (tableExists "study_features") $ do
|
||||
[executeQQ|
|
||||
|
||||
@ -17,7 +17,6 @@ import Model.Types.Allocation as Types
|
||||
import Model.Types.Languages as Types
|
||||
import Model.Types.File as Types
|
||||
import Model.Types.User as Types
|
||||
import Model.Types.Workflow as Types
|
||||
import Model.Types.Changelog as Types
|
||||
import Model.Types.Markup as Types
|
||||
import Model.Types.Room as Types
|
||||
|
||||
@ -13,8 +13,11 @@ import Import.NoModel
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Either.Combinators (maybeToRight)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Data.Time.Calendar.WeekDate
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
import Web.HttpApiData
|
||||
@ -25,19 +28,29 @@ import Data.Aeson.Types as Aeson
|
||||
----
|
||||
-- Terms, Seaons, anything loosely related to time
|
||||
|
||||
data Season = Summer | Winter
|
||||
data Season = Q1 | Q2 | Q3 | Q4
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Binary, Universe, Finite, NFData)
|
||||
|
||||
seasonToChar :: Season -> Char
|
||||
seasonToChar Summer = 'S'
|
||||
seasonToChar Winter = 'W'
|
||||
numSeasons :: Int -- to be flexible
|
||||
numSeasons = succ $ fromEnum(maxBound::Season)
|
||||
|
||||
seasonFromChar :: Char -> Either Text Season
|
||||
seasonFromChar c
|
||||
| c ~= 'S' = Right Summer
|
||||
| c ~= 'W' = Right Winter
|
||||
| otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’"
|
||||
seasonFromText' :: Text -> Either Text Season
|
||||
seasonFromText' t = maybeToRight errmsg (readMaybe $ Text.unpack $ Text.toUpper t)
|
||||
where
|
||||
errmsg = "Invalid season: ‘" <> tshow t <> "’"
|
||||
|
||||
seasonFromText :: Text -> Either Text Season
|
||||
seasonFromText t
|
||||
| Just (q, ne) <- Text.uncons t
|
||||
, q ~= 'Q'
|
||||
, Just (n, e) <- Text.uncons ne
|
||||
, Text.null e = case n of '1' -> Right Q1
|
||||
'2' -> Right Q2
|
||||
'3' -> Right Q3
|
||||
'4' -> Right Q4
|
||||
_ -> Left $ "Invalid quarter number: ‘" <> tshow t <> "’"
|
||||
| otherwise = Left $ "Invalid season: ‘" <> tshow t <> "’"
|
||||
where
|
||||
(~=) :: Char -> Char -> Bool
|
||||
(~=) = (==) `on` CI.mk
|
||||
@ -50,8 +63,8 @@ data TermIdentifier = TermIdentifier
|
||||
|
||||
instance Enum TermIdentifier where
|
||||
-- ^ Do not use for conversion – Enumeration only
|
||||
toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}
|
||||
fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season
|
||||
toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` numSeasons in TermIdentifier{..}
|
||||
fromEnum TermIdentifier{..} = fromInteger year * numSeasons + fromEnum season
|
||||
|
||||
-- Conversion TermId <-> TermIdentifier::
|
||||
-- from_TermId_to_TermIdentifier = unTermKey
|
||||
@ -82,32 +95,31 @@ shortened = iso shorten expand
|
||||
| otherwise = year
|
||||
|
||||
termToText :: TermIdentifier -> Text
|
||||
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
|
||||
termToText TermIdentifier{..} = Text.pack $ show (year ^. shortened) ++ show season
|
||||
|
||||
-- also see Hander.Utils.tidFromText
|
||||
termFromText :: Text -> Either Text TermIdentifier
|
||||
termFromText t
|
||||
| (s:ys) <- Text.unpack t
|
||||
, Just (review shortened -> year) <- readMaybe ys
|
||||
, Right season <- seasonFromChar s
|
||||
| (ys,s) <- Text.break (~= 'Q') t
|
||||
, Right season <- seasonFromText s
|
||||
, Just (review shortened -> year) <- readMaybe $ Text.unpack ys
|
||||
= Right TermIdentifier{..}
|
||||
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
|
||||
where
|
||||
(~=) :: Char -> Char -> Bool
|
||||
(~=) = (==) `on` CI.mk
|
||||
|
||||
termToRational :: TermIdentifier -> Rational
|
||||
termToRational TermIdentifier{..} = fromInteger year + seasonOffset
|
||||
termToRational TermIdentifier{..} = toRational year + seasonOffset
|
||||
where
|
||||
seasonOffset
|
||||
| Summer <- season = 0
|
||||
| Winter <- season = 0.5
|
||||
seasonOffset = fromIntegral (fromEnum season) % fromIntegral numSeasons
|
||||
|
||||
termFromRational :: Rational -> TermIdentifier
|
||||
termFromRational n = TermIdentifier{..}
|
||||
where
|
||||
year = floor n
|
||||
remainder = n - fromInteger (floor n)
|
||||
season
|
||||
| remainder == 0 = Summer
|
||||
| otherwise = Winter
|
||||
year = floor n
|
||||
remainder = n - fromInteger (floor n) -- properFraction problematic for negative year values
|
||||
season = toEnum $ floor $ remainder * fromIntegral numSeasons
|
||||
|
||||
instance PersistField TermIdentifier where
|
||||
toPersistValue = PersistRational . termToRational
|
||||
@ -141,9 +153,31 @@ pathPieceCsv ''TermIdentifier
|
||||
See Handler.Utils.Form.termsField and termActiveField
|
||||
-}
|
||||
|
||||
data TermDay
|
||||
= TermDayStart | TermDayEnd
|
||||
| TermDayLectureStart | TermDayLectureEnd
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
withinTerm :: Day -> TermIdentifier -> Bool
|
||||
time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
|
||||
guessDay :: TermIdentifier
|
||||
-> TermDay
|
||||
-> Day
|
||||
guessDay TermIdentifier{ year, season = Q1 } TermDayStart = fromGregorian year 1 1
|
||||
guessDay TermIdentifier{ year, season = Q2 } TermDayStart = fromGregorian year 4 1
|
||||
guessDay TermIdentifier{ year, season = Q3 } TermDayStart = fromGregorian year 7 1
|
||||
guessDay TermIdentifier{ year, season = Q4 } TermDayStart = fromGregorian year 10 1
|
||||
guessDay tid TermDayEnd = pred $ guessDay (succ tid) TermDayStart
|
||||
guessDay tid TermDayLectureStart = fromWeekDate year weekStart 1 -- first Monday within Quarter
|
||||
where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayStart
|
||||
guessDay tid TermDayLectureEnd = fromWeekDate year weekStart 5 -- Friday of last week within Quarter
|
||||
where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayEnd
|
||||
|
||||
withinTerm :: Day -> TermIdentifier -> Bool
|
||||
withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd
|
||||
|
||||
-- | Check only if last two digits within the year numbers match
|
||||
withinTermYear :: Day -> TermIdentifier -> Bool
|
||||
time `withinTermYear` term = timeYear `mod` 100 == termYear `mod` 100
|
||||
where
|
||||
timeYear = fst3 $ toGregorian time
|
||||
termYear = year term
|
||||
|
||||
@ -54,8 +54,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthExamOffice
|
||||
| AuthSystemExamOffice
|
||||
| AuthEvaluation
|
||||
| AuthAllocationAdmin
|
||||
| AuthWorkflow
|
||||
| AuthAllocationAdmin
|
||||
| AuthAllocationRegistered
|
||||
| AuthCourseRegistered
|
||||
| AuthTutorialRegistered
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
123
src/Utils/Holidays.hs
Normal file
123
src/Utils/Holidays.hs
Normal file
@ -0,0 +1,123 @@
|
||||
{-|
|
||||
Module: Utils.Holidays
|
||||
Description: German bank holidays
|
||||
|
||||
Following module Data.Time.Calendar.BankHoliday.EnglandAndWales
|
||||
-}
|
||||
module Utils.Holidays
|
||||
( Feiertagsgebiet(..)
|
||||
, feiertage
|
||||
, bankHolidays, bankHolidaysArea, bankHolidaysAreaSet
|
||||
, isBankHoliday, isBankHolidayArea
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import qualified Data.Set as Set (Set, member, unions)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
--import Data.Time.Calendar.WeekDate
|
||||
import Data.Time.Calendar.Easter (gregorianEaster)
|
||||
|
||||
|
||||
-- | Some areas / companies within Germany.
|
||||
-- | The datatype is not yet complete.
|
||||
data Feiertagsgebiet = Deutschland | Hessen | Bayern | Munich | Fraport
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
-- | List the bank holidays for the given year >= 1995, in ascending order.
|
||||
-- | Holidays on a weekend are legally considered holidays in some German states, hence
|
||||
-- | the behaviour differs from Data.Time.Calendar.BankHoliday.EnglandAndWales by including holidays on Sundays.
|
||||
-- | Included for compatibility with Data.Time.Calendar.BankHoliday.EnglandAndWales
|
||||
bankHolidays :: Integer -> [Day]
|
||||
bankHolidays = bankHolidaysArea Deutschland
|
||||
|
||||
-- | Bank holidays for a region within Germany and a given year >= 1995.
|
||||
-- | Holidays may occur on a sunday.
|
||||
-- | For convenience and compatibility.
|
||||
bankHolidaysArea :: Feiertagsgebiet -> Integer -> [Day]
|
||||
bankHolidaysArea land year = Map.keys $ feiertage land year
|
||||
|
||||
-- | Bank holidays for a region within Germany and a given year >= 1995.
|
||||
-- | Holidays may occur on a sunday.
|
||||
bankHolidaysAreaSet :: Feiertagsgebiet -> Integer -> Set.Set Day
|
||||
bankHolidaysAreaSet land year = Map.keysSet $ feiertage land year
|
||||
|
||||
-- | Bank holidays for a region within Germany and a given year >= 1995,
|
||||
-- | mapped to the german name of each day.
|
||||
-- | Holidays may occur on a sunday.
|
||||
feiertage :: Feiertagsgebiet -> Integer -> Map.Map Day String
|
||||
feiertage land year = case land of
|
||||
Deutschland -> standardHolidays
|
||||
Bayern -> bavarianHolidays
|
||||
Munich -> munichHolidays
|
||||
Hessen -> hessianHolidays
|
||||
Fraport -> fraportHolidays
|
||||
where
|
||||
easterSunday = gregorianEaster year
|
||||
easterSundayPlus = flip addDays easterSunday
|
||||
|
||||
standardHolidays = Map.fromList
|
||||
[ (fromGregorian year 1 1, "Neujahr")
|
||||
, (easterSundayPlus (-2) , "Karfreitag")
|
||||
, (easterSunday , "Ostersonntag")
|
||||
, (easterSundayPlus 1 , "Ostermontag")
|
||||
, (fromGregorian year 5 1, "Erster Mai")
|
||||
, (easterSundayPlus 39 , "Himmelfahrt")
|
||||
, (easterSundayPlus 49 , "Pfingstsonntag")
|
||||
, (easterSundayPlus 50 , "Pfingstmontag")
|
||||
, (fromGregorian year 10 3, "Tag der deutschen Einheit")
|
||||
, (fromGregorian year 12 25, "Erster Weihnachtstag")
|
||||
, (fromGregorian year 12 26, "Zweiter Weihnachtstag")
|
||||
]
|
||||
|
||||
hessianHolidays = standardHolidays <> map_singleton
|
||||
(easterSundayPlus 60 , "Fronleichnam")
|
||||
|
||||
bavarianHolidays = hessianHolidays <> Map.fromList
|
||||
[ (fromGregorian year 1 6, "Heilige Drei Könige")
|
||||
, (fromGregorian year 11 1, "Allerheiligen")
|
||||
]
|
||||
|
||||
munichHolidays = bavarianHolidays <> map_singleton
|
||||
(fromGregorian year 8 15, "Maria Himmelfahrt")
|
||||
|
||||
fraportHolidays = hessianHolidays <> Map.fromList
|
||||
[ (fromGregorian year 12 24, "Heiligabend")
|
||||
, (fromGregorian year 12 31, "Sylvester")
|
||||
]
|
||||
|
||||
map_singleton = uncurry Map.singleton
|
||||
|
||||
-- | For compatibility with with Data.Time.Calendar.BankHoliday.EnglandAndWales
|
||||
-- | only for works for year >= 1995
|
||||
isBankHoliday :: Day -> Bool
|
||||
isBankHoliday = isBankHolidayArea Deutschland
|
||||
|
||||
{-- Inefficient, since entire year of holidays is computed for each call
|
||||
isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
|
||||
isBankHolidayArea land dd = dd `Set.member` holidays
|
||||
where
|
||||
(year, _, _) = toGregorian dd
|
||||
holidays = bankHolidaysAreaSet land year
|
||||
-}
|
||||
|
||||
-- | Returns whether a day is a bank holiday for years >= 1995
|
||||
-- | Repeated calls are handled efficiently using a lazy cache for 2020--2075
|
||||
isBankHolidayArea :: Feiertagsgebiet -> Day -> Bool
|
||||
isBankHolidayArea land dd = dd `Set.member` holidays
|
||||
where
|
||||
(year, _, _) = toGregorian dd
|
||||
holidays
|
||||
| year >= cacheMinYear
|
||||
, year <= cacheMaxYear
|
||||
, (Just hds) <- Map.lookup land cacheHolidays = hds
|
||||
| otherwise = bankHolidaysAreaSet land year
|
||||
|
||||
cacheMinYear, cacheMaxYear :: Integer
|
||||
cacheMinYear = 2020
|
||||
cacheMaxYear = 2075
|
||||
|
||||
cacheHolidays :: Map.Map Feiertagsgebiet (Set.Set Day)
|
||||
cacheHolidays = Map.fromList [ (land, Set.unions $ bankHolidaysAreaSet land <$> [cacheMinYear..cacheMaxYear]) | land <- universeF ]
|
||||
@ -253,21 +253,6 @@ makeLenses_ ''Rating'
|
||||
|
||||
makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
|
||||
makeLenses_ ''WorkflowDefinition
|
||||
makeLenses_ ''WorkflowDefinitionDescription
|
||||
makeLenses_ ''WorkflowDefinitionInstanceDescription
|
||||
makeLenses_ ''WorkflowScope
|
||||
makeLenses_ ''WorkflowInstance
|
||||
makeLenses_ ''WorkflowInstanceDescription
|
||||
makeLenses_ ''WorkflowWorkflow
|
||||
makeLenses_ ''WorkflowPayloadTextPreset
|
||||
|
||||
makeLenses_ ''WorkflowGraph
|
||||
makeLenses_ ''WorkflowGraphNode
|
||||
|
||||
makeLenses_ ''WorkflowGraphEdge
|
||||
makePrisms ''WorkflowGraphEdge
|
||||
|
||||
makeWrapped ''Textarea
|
||||
makeLenses_ ''SentMail
|
||||
|
||||
|
||||
@ -1,224 +0,0 @@
|
||||
module Utils.Workflow
|
||||
( RouteWorkflowScope, DBWorkflowScope, IdWorkflowScope, CryptoIDWorkflowScope
|
||||
, _DBWorkflowScope
|
||||
, fromRouteWorkflowScope, toRouteWorkflowScope
|
||||
, DBWorkflowGraph, IdWorkflowGraph
|
||||
, _DBWorkflowGraph
|
||||
, DBWorkflowState, IdWorkflowState
|
||||
, _DBWorkflowState
|
||||
, DBWorkflowAction, IdWorkflowAction
|
||||
, decryptWorkflowStateIndex, encryptWorkflowStateIndex
|
||||
, isTopWorkflowScope, isTopWorkflowScopeSql
|
||||
, selectWorkflowInstanceDescription
|
||||
, SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph
|
||||
, insertSharedWorkflowGraph
|
||||
, getWorkflowWorkflowState', getWorkflowWorkflowState
|
||||
, WorkflowWorkflowStateParseException(..)
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
||||
import qualified Crypto.MAC.KMAC as Crypto
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.Binary as Binary
|
||||
import Crypto.Hash.Algorithms (SHAKE256)
|
||||
import qualified Crypto.Hash as Crypto
|
||||
import Language.Haskell.TH (nameBase)
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Internal.Internal as E
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
|
||||
|
||||
|
||||
type RouteWorkflowScope = WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
|
||||
type DBWorkflowScope = WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey
|
||||
type IdWorkflowScope = WorkflowScope TermId SchoolId CourseId
|
||||
type CryptoIDWorkflowScope = WorkflowScope TermId SchoolId CryptoUUIDCourse
|
||||
|
||||
|
||||
_DBWorkflowScope :: Iso' IdWorkflowScope DBWorkflowScope
|
||||
_DBWorkflowScope = iso toScope' toScope
|
||||
where
|
||||
toScope' scope = scope
|
||||
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermIdentifier SchoolId CourseId)) unTermKey
|
||||
& over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolId CourseId) @(WorkflowScope TermIdentifier SchoolShorthand CourseId)) unSchoolKey
|
||||
& over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolShorthand CourseId) @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) @CourseId @SqlBackendKey) (view _SqlKey)
|
||||
toScope scope' = scope'
|
||||
& over (typesCustom @WorkflowChildren @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolShorthand SqlBackendKey)) TermKey
|
||||
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolId SqlBackendKey)) SchoolKey
|
||||
& over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId SqlBackendKey) @(WorkflowScope TermId SchoolId CourseId) @SqlBackendKey @CourseId) (review _SqlKey)
|
||||
|
||||
fromRouteWorkflowScope :: ( MonadHandler m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> RouteWorkflowScope
|
||||
-> MaybeT (ReaderT backend m) IdWorkflowScope
|
||||
fromRouteWorkflowScope rScope = $cachedHereBinary rScope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
toRouteWorkflowScope :: ( MonadHandler m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> IdWorkflowScope
|
||||
-> MaybeT (ReaderT backend m) RouteWorkflowScope
|
||||
toRouteWorkflowScope scope = $cachedHereBinary scope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand)
|
||||
|
||||
|
||||
type IdWorkflowGraph = WorkflowGraph FileReference UserId
|
||||
type DBWorkflowGraph = WorkflowGraph FileReference SqlBackendKey
|
||||
|
||||
|
||||
_DBWorkflowGraph :: Iso' IdWorkflowGraph DBWorkflowGraph
|
||||
_DBWorkflowGraph = iso toDB fromDB
|
||||
where
|
||||
toDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference UserId) @(WorkflowGraph FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)
|
||||
fromDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference SqlBackendKey) @(WorkflowGraph FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey)
|
||||
|
||||
|
||||
type IdWorkflowState = WorkflowState FileReference UserId
|
||||
type DBWorkflowState = WorkflowState FileReference SqlBackendKey
|
||||
|
||||
|
||||
_DBWorkflowState :: Iso' IdWorkflowState DBWorkflowState
|
||||
_DBWorkflowState = iso toDB fromDB
|
||||
where
|
||||
toDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference UserId) @(WorkflowState FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)
|
||||
fromDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference SqlBackendKey) @(WorkflowState FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey)
|
||||
|
||||
type IdWorkflowAction = WorkflowAction FileReference UserId
|
||||
type DBWorkflowAction = WorkflowAction FileReference SqlBackendKey
|
||||
|
||||
|
||||
data WorkflowStateIndexKeyException
|
||||
= WorkflowStateIndexCryptoIDKeyCouldNotDecodeRandom
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
workflowStateIndexCryptoIDKey :: (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => WorkflowWorkflowId -> m CryptoIDKey
|
||||
workflowStateIndexCryptoIDKey wwId = cryptoIDKey $ \cIDKey -> either (const $ throwM WorkflowStateIndexCryptoIDKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
|
||||
Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'workflowStateIndexCryptoIDKey) (toStrict $ Binary.encode wwId) cIDKey
|
||||
|
||||
encryptWorkflowStateIndex :: ( MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadHandler m
|
||||
)
|
||||
=> WorkflowWorkflowId -> WorkflowStateIndex -> m CryptoUUIDWorkflowStateIndex
|
||||
encryptWorkflowStateIndex wwId stIx = do
|
||||
cIDKey <- workflowStateIndexCryptoIDKey wwId
|
||||
$cachedHereBinary (wwId, stIx) . flip runReaderT cIDKey $ I.encrypt stIx
|
||||
|
||||
decryptWorkflowStateIndex :: ( MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadHandler m
|
||||
)
|
||||
=> WorkflowWorkflowId -> CryptoUUIDWorkflowStateIndex -> m WorkflowStateIndex
|
||||
decryptWorkflowStateIndex wwId cID = do
|
||||
cIDKey <- workflowStateIndexCryptoIDKey wwId
|
||||
$cachedHereBinary (wwId, cID) . flip runReaderT cIDKey $ I.decrypt cID
|
||||
|
||||
|
||||
isTopWorkflowScope :: WorkflowScope termid schoolid courseid -> Bool
|
||||
isTopWorkflowScope = (`elem` [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScope
|
||||
|
||||
isTopWorkflowScopeSql :: E.SqlExpr (E.Value DBWorkflowScope) -> E.SqlExpr (E.Value Bool)
|
||||
isTopWorkflowScopeSql = (`E.in_` E.valList [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScopeSql
|
||||
where classifyWorkflowScopeSql = (E.->. "tag")
|
||||
|
||||
|
||||
selectWorkflowInstanceDescription :: ( MonadHandler m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> WorkflowInstanceId
|
||||
-> ReaderT backend m (Maybe (Entity WorkflowInstanceDescription))
|
||||
selectWorkflowInstanceDescription wiId = withReaderT (projectBackend @SqlReadBackend) $ do
|
||||
descLangs <- 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
|
||||
fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
|
||||
|
||||
|
||||
data SharedWorkflowGraphException
|
||||
= SharedWorkflowGraphNotFound SharedWorkflowGraphId
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
getSharedDBWorkflowGraph :: ( MonadHandler m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> SharedWorkflowGraphId
|
||||
-> ReaderT backend m DBWorkflowGraph
|
||||
getSharedDBWorkflowGraph swgId = $cachedHereBinary swgId . withReaderT (projectBackend @SqlReadBackend) $ do
|
||||
maybe (liftHandler . throwM $ SharedWorkflowGraphNotFound swgId) (return . sharedWorkflowGraphGraph) =<< get swgId
|
||||
|
||||
getSharedIdWorkflowGraph :: ( MonadHandler m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> SharedWorkflowGraphId
|
||||
-> ReaderT backend m IdWorkflowGraph
|
||||
getSharedIdWorkflowGraph = fmap (review _DBWorkflowGraph) . getSharedDBWorkflowGraph
|
||||
|
||||
insertSharedWorkflowGraph :: ( MonadIO m
|
||||
, BackendCompatible SqlBackend backend
|
||||
)
|
||||
=> DBWorkflowGraph
|
||||
-> ReaderT backend m SharedWorkflowGraphId
|
||||
insertSharedWorkflowGraph graph = withReaderT (projectBackend @SqlBackend) $
|
||||
swgId' <$ repsert swgId' (SharedWorkflowGraph swgId graph)
|
||||
where
|
||||
swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph
|
||||
swgId' = SharedWorkflowGraphKey swgId
|
||||
|
||||
|
||||
newtype WorkflowWorkflowStateParse = WorkflowWorkflowStateParse PersistValue
|
||||
deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Binary)
|
||||
|
||||
newtype WorkflowWorkflowStateParseException = WorkflowWorkflowStateParseException Text
|
||||
deriving stock (Show, Generic, Typeable)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
getWorkflowWorkflowState' :: forall backend m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, MonadThrow m
|
||||
)
|
||||
=> WorkflowWorkflowId
|
||||
-> Maybe WorkflowWorkflow
|
||||
-> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
|
||||
getWorkflowWorkflowState' wwId Nothing = withReaderT (projectBackend @SqlBackend . projectBackend @SqlReadBackend) . runMaybeT $ do
|
||||
res <- MaybeT . E.selectMaybe . E.from $ \workflowWorkflow -> do
|
||||
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowId E.==. E.val wwId
|
||||
return
|
||||
( workflowWorkflow E.^. WorkflowWorkflowInstance
|
||||
, workflowWorkflow E.^. WorkflowWorkflowScope
|
||||
, workflowWorkflow E.^. WorkflowWorkflowGraph
|
||||
, E.veryUnsafeCoerceSqlExprValue $ workflowWorkflow E.^. WorkflowWorkflowState
|
||||
)
|
||||
let
|
||||
( E.Value workflowWorkflowInstance
|
||||
, E.Value workflowWorkflowScope
|
||||
, E.Value workflowWorkflowGraph
|
||||
, E.Value (wwState :: PersistValue) -- Don't parse
|
||||
) = res
|
||||
wwState' <- memcachedBy Nothing (WorkflowWorkflowStateParse wwState) . return $ fromPersistValue wwState
|
||||
case wwState' of
|
||||
Left err -> lift . throwM $ WorkflowWorkflowStateParseException err
|
||||
Right workflowWorkflowState -> return $ Entity wwId WorkflowWorkflow{..}
|
||||
getWorkflowWorkflowState' wwId (Just ww@WorkflowWorkflow{..}) = Just (Entity wwId ww) <$ do
|
||||
memcachedBySet Nothing (WorkflowWorkflowStateParse $ toPersistValue workflowWorkflowState) workflowWorkflowState
|
||||
|
||||
getWorkflowWorkflowState :: forall backend m.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, MonadThrow m
|
||||
)
|
||||
=> WorkflowWorkflowId
|
||||
-> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
|
||||
getWorkflowWorkflowState = flip getWorkflowWorkflowState' Nothing
|
||||
@ -1,142 +0,0 @@
|
||||
module Utils.Workflow.Lint
|
||||
( lintWorkflowGraph
|
||||
, WorkflowGraphLinterIssue(..)
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.MultiSet as MultiSet
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
||||
|
||||
|
||||
data WorkflowGraphLinterIssue
|
||||
= WGLUnknownGraphNodeLabel WorkflowGraphNodeLabel
|
||||
| WGLPayloadInvisibleInTargetNode (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) WorkflowPayloadLabel
|
||||
| WGLFinalNodeHasOutgoingEdges WorkflowGraphNodeLabel | WGLNonFinalNodeHasNoOutgoingEdges WorkflowGraphNodeLabel
|
||||
| WGLUndefinedFieldOrder (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) (NonNull (MultiSet WorkflowPayloadLabel))
|
||||
| WGLNodeUnreachable WorkflowGraphNodeLabel
|
||||
| WGLNodeUnfinalizable WorkflowGraphNodeLabel
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Exception WorkflowGraphLinterIssue where
|
||||
displayException = \case
|
||||
WGLUnknownGraphNodeLabel nodeLbl
|
||||
-> unpack [st|Unknown GraphNodeLabel: #{tshow (toPathPiece nodeLbl)}|]
|
||||
WGLPayloadInvisibleInTargetNode (nodeLbl, edgeLbl) payloadLbl
|
||||
-> unpack [st|Payload #{tshow (toPathPiece payloadLbl)} has form on edge #{tshow (toPathPiece edgeLbl)} to target node #{tshow (toPathPiece nodeLbl)} but no viewers on target node|]
|
||||
WGLFinalNodeHasOutgoingEdges nodeLbl
|
||||
-> unpack [st|Node #{tshow (toPathPiece nodeLbl)} is marked “final” but has outgoing edges|]
|
||||
WGLNonFinalNodeHasNoOutgoingEdges nodeLbl
|
||||
-> unpack [st|Node #{tshow (toPathPiece nodeLbl)} isn't marked “final” but has no outgoing edges|]
|
||||
WGLUndefinedFieldOrder (nodeLbl, edgeLbl) payloads
|
||||
-> unpack [st|Form for edge #{tshow (toPathPiece edgeLbl)} to target node #{tshow (toPathPiece nodeLbl)} has ill defined field order for payload(s): “#{intercalate ", " (map (tshow . toPathPiece) (MultiSet.elems (toNullable payloads)))}”|]
|
||||
WGLNodeUnreachable nodeLbl
|
||||
-> unpack [st|Node #{tshow (toPathPiece nodeLbl)} is unreachable from all initial edges|]
|
||||
WGLNodeUnfinalizable nodeLbl
|
||||
-> unpack [st|Node #{tshow (toPathPiece nodeLbl)} has no path to a final node|]
|
||||
|
||||
lintWorkflowGraph :: forall fileid userid. WorkflowGraph fileid userid -> Maybe (NonNull (Set WorkflowGraphLinterIssue))
|
||||
lintWorkflowGraph graph = fromNullable . Set.fromList $ concatMap ($ graph)
|
||||
[ checkEdgesForUnknownGraphNodeLabel
|
||||
, checkFormPayloadVisibleInTargetNode -- TODO: Satisfiability of automatic edges?
|
||||
, finalMatchesOutgoingEdges
|
||||
, checkUndefinedFieldOrder
|
||||
, checkNodeUnreachable -- TODO: Satisfiability of automatic edges
|
||||
, checkNodeUnfinalizable -- TODO: Satisfiability of automatic edges
|
||||
-- Future ideas:
|
||||
-- - WorkflowRolePayloadReference for unknown payload
|
||||
-- - wgePayloadRestriction for unknown payload
|
||||
-- - FieldReference for payload not defined in same form
|
||||
-- - WorkflowRolePayloadReference to payload without user fields
|
||||
-- - all initial edges have only payload-reference
|
||||
-- - cycles of automatic edges (also consider payload restrictions; computationally equivalent to SAT)
|
||||
-- - unsatisfiable restrictions
|
||||
]
|
||||
where
|
||||
checkEdgesForUnknownGraphNodeLabel WorkflowGraph{wgNodes} = foldMap (pure . WGLUnknownGraphNodeLabel) $ Set.fromList edgeNodeLabels `Set.difference` Map.keysSet wgNodes
|
||||
where
|
||||
edges = foldMap (Map.elems . wgnEdges) wgNodes
|
||||
edgeNodeLabels = flip foldMap edges $ \case
|
||||
WorkflowGraphEdgeManual{wgeSource} -> pure wgeSource
|
||||
WorkflowGraphEdgeAutomatic{wgeSource} -> pure wgeSource
|
||||
WorkflowGraphEdgeInitial{} -> []
|
||||
checkFormPayloadVisibleInTargetNode WorkflowGraph{wgNodes} = ifoldMap (\nodeLbl node -> map (\(edgeLbl, payloadLbl) -> WGLPayloadInvisibleInTargetNode (nodeLbl, edgeLbl) payloadLbl) . Set.toList $ doCheck node) wgNodes
|
||||
where
|
||||
doCheck :: WorkflowGraphNode fileid userid -> Set (WorkflowGraphEdgeLabel, WorkflowPayloadLabel)
|
||||
doCheck WGN{wgnEdges, wgnPayloadView} = ifoldMap (\edgeLbl -> Set.map (edgeLbl, ) . doCheck') wgnEdges
|
||||
where
|
||||
doCheck' :: WorkflowGraphEdge fileid userid -> Set WorkflowPayloadLabel
|
||||
doCheck' wge = fromMaybe Set.empty $ do
|
||||
WorkflowGraphEdgeForm{wgefFields} <- wge ^? _wgeForm
|
||||
return $ Map.keysSet wgefFields `Set.difference` Map.keysSet wgnPayloadView
|
||||
finalMatchesOutgoingEdges WorkflowGraph{wgNodes} = foldMap (\nodeLbl -> pure $ bool WGLFinalNodeHasOutgoingEdges WGLNonFinalNodeHasNoOutgoingEdges (nodeLbl `Set.notMember` markedFinalNodes) nodeLbl) $ markedFinalNodes `setSymmDiff` edgeFinalNodes
|
||||
where
|
||||
markedFinalNodes = Set.fromList $ do
|
||||
(nodeLbl, WGN{wgnFinal}) <- Map.toList wgNodes
|
||||
guard $ is _Just wgnFinal
|
||||
return nodeLbl
|
||||
edgeFinalNodes = Set.fromList $ do
|
||||
nodeLbl <- Map.keys wgNodes
|
||||
guard $ noneOf (folded . _wgnEdges . folded . _wgeSource) (== nodeLbl) wgNodes
|
||||
return nodeLbl
|
||||
checkUndefinedFieldOrder WorkflowGraph{wgNodes} = ifoldMap (\nodeLbl node -> map (\(edgeLbl, payloadLbls) -> WGLUndefinedFieldOrder (nodeLbl, edgeLbl) payloadLbls) . Set.toList $ doCheck node) wgNodes
|
||||
where
|
||||
doCheck :: WorkflowGraphNode fileid userid -> Set (WorkflowGraphEdgeLabel, NonNull (MultiSet WorkflowPayloadLabel))
|
||||
doCheck WGN{wgnEdges} = ifoldMap (\edgeLbl -> foldMap (Set.singleton . (edgeLbl, )) . doCheck') wgnEdges
|
||||
where
|
||||
doCheck' :: WorkflowGraphEdge fileid userid -> [NonNull (MultiSet WorkflowPayloadLabel)]
|
||||
doCheck' wge = do
|
||||
WorkflowGraphEdgeForm{wgefFields} <- hoistMaybe $ wge ^? _wgeForm
|
||||
let MergeMap orderMap = ifoldMap go wgefFields
|
||||
where
|
||||
go :: WorkflowPayloadLabel
|
||||
-> NonNull (Set (NonNull (Map WorkflowGraphEdgeFormOrder (WorkflowPayloadSpec fileid userid))))
|
||||
-> MergeMap WorkflowGraphEdgeFormOrder (NonNull (MultiSet WorkflowPayloadLabel))
|
||||
go payloadLbl = foldMap (go' . Map.keysSet . toNullable) . Set.toList . toNullable
|
||||
where
|
||||
go' :: Set WorkflowGraphEdgeFormOrder
|
||||
-> MergeMap WorkflowGraphEdgeFormOrder (NonNull (MultiSet WorkflowPayloadLabel))
|
||||
go' = foldMap $ \formOrder -> MergeMap . Map.singleton formOrder . impureNonNull $ MultiSet.singleton payloadLbl
|
||||
filter ((> 1) . MultiSet.size . toNullable) $ Map.elems orderMap
|
||||
checkNodeUnreachable WorkflowGraph{wgNodes} = foldMap (pure . WGLNodeUnreachable) $ Map.keysSet wgNodes `Set.difference` reachableNodes
|
||||
where
|
||||
initialNodes = Map.keysSet $ Map.filter isInitial wgNodes
|
||||
where isInitial WGN{wgnEdges} = any (is _WorkflowGraphEdgeInitial) wgnEdges
|
||||
reachableNodes = extendAfter graph initialNodes
|
||||
checkNodeUnfinalizable WorkflowGraph{wgNodes} = foldMap (pure . WGLNodeUnfinalizable) $ Map.keysSet wgNodes `Set.difference` finalizableNodes
|
||||
where
|
||||
finalNodes = Map.keysSet $ Map.filter (has $ _wgnFinal . _Just) wgNodes
|
||||
finalizableNodes = extendBefore graph finalNodes
|
||||
|
||||
extendAfter, extendBefore :: forall fileid userid. WorkflowGraph fileid userid -> Set WorkflowGraphNodeLabel -> Set WorkflowGraphNodeLabel
|
||||
extendAfter WorkflowGraph{wgNodes} = go Set.empty . Seq.fromList . Set.toList
|
||||
where
|
||||
go :: Set WorkflowGraphNodeLabel -- ^ Already known reachable
|
||||
-> Seq WorkflowGraphNodeLabel -- ^ Queue to check
|
||||
-> Set WorkflowGraphNodeLabel
|
||||
go known Seq.Empty = known
|
||||
go known (n Seq.:<| ns)
|
||||
| n `Set.member` known = go known ns
|
||||
| otherwise = go (Set.insert n known) $ ns `searchStrategy` nextNodes
|
||||
where nextNodes = Map.keysSet $ Map.filter hasSource wgNodes
|
||||
hasSource WGN{wgnEdges} = anyOf (folded . _wgeSource) (== n) wgnEdges
|
||||
extendBefore WorkflowGraph{wgNodes} = go Set.empty . Seq.fromList . Set.toList
|
||||
where
|
||||
go :: Set WorkflowGraphNodeLabel
|
||||
-> Seq WorkflowGraphNodeLabel
|
||||
-> Set WorkflowGraphNodeLabel
|
||||
go known Seq.Empty = known
|
||||
go known (n Seq.:<| ns)
|
||||
| n `Set.member` known = go known ns
|
||||
| otherwise = go (Set.insert n known) $ ns `searchStrategy` prevNodes
|
||||
where
|
||||
prevNodes = flip foldMap (wgNodes Map.!? n) $ \WGN{wgnEdges} -> setOf (folded . _wgeSource) wgnEdges
|
||||
|
||||
searchStrategy :: Seq WorkflowGraphNodeLabel -> Set WorkflowGraphNodeLabel -> Seq WorkflowGraphNodeLabel
|
||||
-- ^ BFS
|
||||
searchStrategy queue next = queue <> Seq.fromList (Set.toList next)
|
||||
@ -33,6 +33,9 @@ Utils.DateTime
|
||||
: Template Haskell code-generatoren zum compile-time einbinden von Zeitzone
|
||||
und `TimeLocale`
|
||||
|
||||
Utils.Holidays
|
||||
: Definition deutscher Feiertage
|
||||
|
||||
Handler.Utils, Handler.Utils.*
|
||||
: Hilfsfunktionien, importieren `Import`
|
||||
|
||||
|
||||
@ -12,7 +12,7 @@ import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Time.Calendar.OrdinalDate
|
||||
-- import Data.Time.Calendar.OrdinalDate
|
||||
import Data.Time.Calendar.WeekDate
|
||||
|
||||
import Control.Applicative (ZipList(..))
|
||||
@ -33,34 +33,11 @@ import qualified Data.List as List (splitAt)
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import Utils.Workflow
|
||||
import Utils.Workflow.Lint
|
||||
|
||||
import System.Directory (getModificationTime, doesFileExist, doesDirectoryExist)
|
||||
import System.Directory (getModificationTime, doesDirectoryExist)
|
||||
import System.FilePath.Glob (glob)
|
||||
|
||||
import System.IO (hPutStrLn)
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
import Paths_uniworx (getDataFileName)
|
||||
|
||||
|
||||
data WorkflowIndexItem = WorkflowIndexItem
|
||||
{ wiiGraphFile :: FilePath
|
||||
, wiiCategory :: Maybe WorkflowInstanceCategory
|
||||
, wiiDefinitionScope :: WorkflowScope'
|
||||
, wiiDefinitionDescription :: Maybe (I18n (Text, Maybe StoredMarkup))
|
||||
, wiiInstanceDescription :: Maybe (I18n (Text, Maybe StoredMarkup))
|
||||
, wiiInstances :: Set RouteWorkflowScope
|
||||
}
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''WorkflowIndexItem
|
||||
|
||||
|
||||
testdataFile :: MonadIO m => FilePath -> m FilePath
|
||||
testdataFile = liftIO . getDataFileName . ("testdata" </>)
|
||||
|
||||
@ -81,48 +58,31 @@ fillDb = do
|
||||
|
||||
(currentYear, currentMonth, _) = toGregorian $ utctDay now
|
||||
currentTerm
|
||||
| 4 <= currentMonth
|
||||
, currentMonth <= 9
|
||||
= TermIdentifier currentYear Summer
|
||||
| otherwise
|
||||
= TermIdentifier (pred currentYear) Winter
|
||||
| 3 >= currentMonth = TermIdentifier currentYear Q1
|
||||
| 6 >= currentMonth = TermIdentifier currentYear Q2
|
||||
| 9 >= currentMonth = TermIdentifier currentYear Q3
|
||||
| otherwise = TermIdentifier currentYear Q4
|
||||
nextTerm = succ currentTerm
|
||||
prevTerm = pred currentTerm
|
||||
prevPrevTerm = pred prevTerm
|
||||
|
||||
seasonTerm next wSeason
|
||||
| wSeason == season currentTerm
|
||||
, next = currentTerm
|
||||
| wSeason == season currentTerm
|
||||
= prevPrevTerm
|
||||
| next
|
||||
= nextTerm
|
||||
| otherwise
|
||||
= prevTerm
|
||||
seasonTerm next wSeason = until ((wSeason ==) . season) prog currentTerm
|
||||
where prog | next = succ
|
||||
| otherwise = pred
|
||||
|
||||
termTime :: Bool -- ^ Next term?
|
||||
-> Season
|
||||
-> Rational
|
||||
-> Bool -- ^ Relative to end of semester?
|
||||
-> WeekDay
|
||||
-> (Day -> UTCTime)
|
||||
-> (Day -> UTCTime) -- ^ Add time to day
|
||||
-> UTCTime
|
||||
termTime next gSeason weekOffset fromEnd d = ($ utctDay)
|
||||
where
|
||||
utctDay = fromWeekDate wYear wWeek $ fromEnum d
|
||||
(wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian gYear rMonth rDay
|
||||
gYear = year $ seasonTerm next gSeason
|
||||
(rMonth, rDay)
|
||||
| Winter <- gSeason
|
||||
, True <- fromEnd
|
||||
= (03, 31)
|
||||
| Winter <- gSeason
|
||||
, False <- fromEnd
|
||||
= (10, 01)
|
||||
| True <- fromEnd
|
||||
= (09, 30)
|
||||
| otherwise
|
||||
= (04, 01)
|
||||
(wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian rYear rMonth rDay
|
||||
gTid = seasonTerm next gSeason
|
||||
(rYear, rMonth, rDay) = toGregorian $ guessDay gTid $ bool TermDayLectureStart TermDayLectureEnd fromEnd
|
||||
|
||||
gkleen <- insert User
|
||||
{ userIdent = "G.Kleen@campus.lmu.de"
|
||||
@ -196,7 +156,7 @@ fillDb = do
|
||||
, userTitle = Just "Dr."
|
||||
, userMaxFavourites = 14
|
||||
, userMaxFavouriteTerms = 4
|
||||
, userTheme = ThemeMossGreen
|
||||
, userTheme = userDefaultTheme
|
||||
, userDateTimeFormat = userDefaultDateTimeFormat
|
||||
, userDateFormat = userDefaultDateFormat
|
||||
, userTimeFormat = userDefaultTimeFormat
|
||||
@ -393,42 +353,18 @@ fillDb = do
|
||||
Nothing -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
|
||||
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
|
||||
manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
|
||||
|
||||
forM_ [(pred $ pred prevPrevTerm)..(succ $ succ $ succ $ succ nextTerm)] $ \tid -> do
|
||||
let term = Term { termName = tid
|
||||
, termStart = guessDay tid TermDayStart
|
||||
, termEnd = guessDay tid TermDayEnd
|
||||
, termHolidays = []
|
||||
, termLectureStart = guessDay tid TermDayLectureStart
|
||||
, termLectureEnd = guessDay tid TermDayLectureEnd
|
||||
}
|
||||
void $ repsert (TermKey tid) term
|
||||
void . insert_ $ TermActive (TermKey tid) (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing
|
||||
|
||||
forM_ [prevPrevTerm, prevTerm, currentTerm, nextTerm] $ \term@TermIdentifier{..} -> case season of
|
||||
Summer -> do
|
||||
let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 04 01
|
||||
termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
|
||||
termLectureEnd = fromWeekDate wYearStart (wWeekStart + 16) 5
|
||||
termStart = fromGregorian year 04 01
|
||||
termEnd = fromGregorian year 09 30
|
||||
void . repsert (TermKey term) $ Term
|
||||
{ termName = term
|
||||
, termStart
|
||||
, termEnd
|
||||
, termHolidays = []
|
||||
, termLectureStart
|
||||
, termLectureEnd
|
||||
}
|
||||
void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing
|
||||
Winter -> do
|
||||
let (wYearStart, wWeekStart, _) = toWeekDate $ fromGregorian year 10 01
|
||||
termLectureStart = fromWeekDate wYearStart (wWeekStart + 2) 1
|
||||
(fromIntegral -> wYearOffset, wWeekEnd) = (wWeekStart + 18) `divMod` bool 53 54 longYear
|
||||
termLectureEnd = fromWeekDate (wYearStart + wYearOffset) (bool id succ (wYearOffset /= 0) wWeekEnd) 5
|
||||
longYear = case toWeekDate $ fromOrdinalDate wYearStart 365 of
|
||||
(_, 53, _) -> True
|
||||
_other -> False
|
||||
termStart = fromGregorian year 10 01
|
||||
termEnd = fromGregorian (succ year) 03 31
|
||||
void . repsert (TermKey term) $ Term
|
||||
{ termName = term
|
||||
, termStart
|
||||
, termEnd
|
||||
, termHolidays = []
|
||||
, termLectureStart
|
||||
, termLectureEnd
|
||||
}
|
||||
void . insert_ $ TermActive (TermKey term) (toMidnight $ addDays (-60) termStart) (Just . beforeMidnight $ addDays 60 termEnd) Nothing
|
||||
ifiAuthorshipStatement <- insertAuthorshipStatement I18n
|
||||
{ i18nFallback = htmlToStoredMarkup
|
||||
[shamlet|
|
||||
@ -456,6 +392,8 @@ fillDb = do
|
||||
}
|
||||
ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False
|
||||
mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
|
||||
avn <- insert' $ School "Fahrschule" "AVN-A" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
|
||||
void . insert' $ UserFunction jost avn SchoolAdmin
|
||||
void . insert' $ UserFunction gkleen ifi SchoolAdmin
|
||||
void . insert' $ UserFunction gkleen mi SchoolAdmin
|
||||
void . insert' $ UserFunction fhamann ifi SchoolAdmin
|
||||
@ -470,10 +408,12 @@ fillDb = do
|
||||
void . insert' $ UserFunction gkleen ifi SchoolAllocation
|
||||
void . insert' $ UserFunction sbarth ifi SchoolLecturer
|
||||
void . insert' $ UserFunction sbarth ifi SchoolExamOffice
|
||||
for_ [gkleen, fhamann, jost, maxMuster, svaupel] $ \uid ->
|
||||
for_ [gkleen, fhamann, maxMuster, svaupel] $ \uid ->
|
||||
void . insert' $ UserSchool uid ifi False
|
||||
for_ [gkleen, tinaTester] $ \uid ->
|
||||
void . insert' $ UserSchool uid mi False
|
||||
for_ [jost] $ \uid ->
|
||||
void . insert' $ UserSchool uid avn False
|
||||
let
|
||||
sdBsc = StudyDegreeKey' 82
|
||||
sdMst = StudyDegreeKey' 88
|
||||
@ -640,7 +580,132 @@ fillDb = do
|
||||
now
|
||||
True
|
||||
Nothing
|
||||
|
||||
|
||||
|
||||
-- Fahrschule F
|
||||
fdf <- insert' Course
|
||||
{ courseName = "F - Vorfeldführerschein"
|
||||
, courseDescription = Just $ htmlToStoredMarkup [shamlet|
|
||||
<p>
|
||||
Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.
|
||||
<section>
|
||||
<h3>Benötigte Unterlagen
|
||||
<ul>
|
||||
<li>Sehtest
|
||||
<i>(Bitte vorab hochladen!)
|
||||
<li>Regulärer Führerschein
|
||||
|]
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "F"
|
||||
, courseTerm = TermKey currentTerm
|
||||
, courseSchool = avn
|
||||
, courseCapacity = Nothing
|
||||
, courseVisibleFrom = Just now
|
||||
, courseVisibleTo = Nothing
|
||||
, courseRegisterFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight
|
||||
, courseRegisterTo = Just $ termTime True (season currentTerm) 0 True Saturday beforeMidnight
|
||||
, courseDeregisterUntil = Nothing
|
||||
, courseRegisterSecret = Nothing
|
||||
, courseMaterialFree = True
|
||||
, courseApplicationsRequired = False
|
||||
, courseApplicationsInstructions = Nothing
|
||||
, courseApplicationsText = False
|
||||
, courseApplicationsFiles = NoUpload
|
||||
, courseApplicationsRatingsVisible = False
|
||||
, courseDeregisterNoShow = True
|
||||
}
|
||||
insert_ $ CourseEdit jost now fdf
|
||||
void $ insert Sheet
|
||||
{ sheetCourse = fdf
|
||||
, sheetName = "Sehtest"
|
||||
, sheetDescription = Just $ htmlToStoredMarkup [shamlet|Bitte einen Scan ihres Sehtest hochladen!|]
|
||||
, sheetType = NotGraded
|
||||
, sheetGrouping = Arbitrary 3
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True (season currentTerm) (-2) False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True (season currentTerm) 0 True Saturday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
, sheetAutoDistribute = False
|
||||
, sheetAnonymousCorrection = True
|
||||
, sheetRequireExamRegistration = Nothing
|
||||
, sheetAllowNonPersonalisedSubmission = True
|
||||
, sheetAuthorshipStatementMode = SheetAuthorshipStatementModeExam
|
||||
, sheetAuthorshipStatementExam = Nothing
|
||||
, sheetAuthorshipStatement = Nothing
|
||||
}
|
||||
forM_ [(Monday)..Thursday] $ \td -> do
|
||||
forM_ [(1::Int)..(4*4)] $ \tw -> do
|
||||
let firstTT = termTime True (season currentTerm) (toRational $ tw - 1) False td toMorning
|
||||
secondTT = termTime True (season currentTerm) (toRational $ tw - 1) False (succ td) toMorning
|
||||
regFrom = termTime True (season currentTerm) (toRational $ tw - 8) False td toMorning
|
||||
regTo = termTime True (season currentTerm) (toRational $ tw - 2) False td toMorning
|
||||
tut1 <- insert Tutorial
|
||||
{ tutorialName = CI.mk $ Text.pack $ "KW" ++ show (snd3 $ toWeekDate $ utctDay firstTT) ++ take 3 (show td)
|
||||
, tutorialCourse = fdf
|
||||
, tutorialType = "Schulung"
|
||||
, tutorialCapacity = Just 16
|
||||
, tutorialRoom = Just $ case tw `mod` 4 of
|
||||
1 -> "A380"
|
||||
2 -> "B747"
|
||||
3 -> "MD11"
|
||||
_ -> "B777"
|
||||
, tutorialRoomHidden = False
|
||||
, tutorialTime = Occurrences
|
||||
{ occurrencesScheduled = Set.empty
|
||||
, occurrencesExceptions = Set.fromList
|
||||
[ ExceptOccur
|
||||
{ exceptDay = utctDay firstTT
|
||||
, exceptStart = TimeOfDay 8 30 0
|
||||
, exceptEnd = TimeOfDay 16 0 0
|
||||
}
|
||||
, ExceptOccur
|
||||
{ exceptDay = utctDay secondTT
|
||||
, exceptStart = TimeOfDay 9 0 0
|
||||
, exceptEnd = TimeOfDay 16 0 0
|
||||
}
|
||||
]
|
||||
}
|
||||
, tutorialRegGroup = Just "schulung"
|
||||
, tutorialRegisterFrom = Just regFrom
|
||||
, tutorialRegisterTo = Just regTo
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
, tutorialLastChanged = now
|
||||
, tutorialTutorControlled = True
|
||||
}
|
||||
void . insert $ Tutor tut1 jost
|
||||
void . insert' $ Exam
|
||||
{ examCourse = fdf
|
||||
, examName = "Theorie"
|
||||
, examGradingRule = Nothing
|
||||
, examBonusRule = Nothing
|
||||
, examOccurrenceRule = ExamRoomManual
|
||||
, examExamOccurrenceMapping = Nothing
|
||||
, examVisibleFrom = Just regFrom
|
||||
, examRegisterFrom = Just firstTT
|
||||
, examRegisterTo = Just $ toMidday $ utctDay secondTT
|
||||
, examDeregisterUntil = Nothing
|
||||
, examPublishOccurrenceAssignments = Nothing
|
||||
, examStart = Just $ toTimeOfDay 15 30 0 $ utctDay secondTT
|
||||
, examEnd = Just $ toTimeOfDay 16 30 0 $ utctDay secondTT
|
||||
, examFinished = Nothing
|
||||
, examPartsFrom = Nothing
|
||||
, examClosed = Nothing
|
||||
, examPublicStatistics = True
|
||||
, examGradingMode = ExamGradingPass
|
||||
, examDescription = Just $ htmlToStoredMarkup [shamlet|Theoretische Prüfung mit Fragebogen|]
|
||||
, examExamMode = ExamMode
|
||||
{ examAids = Just $ ExamAidsPreset ExamClosedBook
|
||||
, examOnline = Just $ ExamOnlinePreset ExamOffline
|
||||
, examSynchronicity = Just $ ExamSynchronicityPreset ExamSynchronous
|
||||
, examRequiredEquipment = Just $ ExamRequiredEquipmentPreset ExamRequiredEquipmentNone
|
||||
}
|
||||
, examStaff = Just "Jost"
|
||||
, examAuthorshipStatement = Nothing
|
||||
}
|
||||
|
||||
-- FFP
|
||||
let nbrs :: [Int]
|
||||
nbrs = [1,2,3,27,7,1]
|
||||
@ -660,13 +725,13 @@ fillDb = do
|
||||
|]
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "FFP"
|
||||
, courseTerm = TermKey $ seasonTerm True Summer
|
||||
, courseTerm = TermKey $ seasonTerm True Q1
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just 20
|
||||
, courseVisibleFrom = Just now
|
||||
, courseVisibleTo = Nothing
|
||||
, courseRegisterFrom = Just $ termTime True Summer (-2) False Monday toMidnight
|
||||
, courseRegisterTo = Just $ termTime True Summer 0 True Sunday beforeMidnight
|
||||
, courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight
|
||||
, courseRegisterTo = Just $ termTime True Q1 0 True Sunday beforeMidnight
|
||||
, courseDeregisterUntil = Nothing
|
||||
, courseRegisterSecret = Nothing
|
||||
, courseMaterialFree = True
|
||||
@ -689,9 +754,9 @@ fillDb = do
|
||||
, sheetType = NotGraded
|
||||
, sheetGrouping = Arbitrary 3
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just $ termTime True Summer 0 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Summer 1 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Summer 2 False Sunday beforeMidnight
|
||||
, sheetVisibleFrom = Just $ termTime True Q1 0 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Q1 1 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Q1 2 False Sunday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
@ -711,9 +776,9 @@ fillDb = do
|
||||
, sheetType = NotGraded
|
||||
, sheetGrouping = RegisteredGroups
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just $ termTime True Summer 1 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Summer 2 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Summer 3 False Sunday beforeMidnight
|
||||
, sheetVisibleFrom = Just $ termTime True Q1 1 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Q1 2 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Q1 3 False Sunday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
@ -733,9 +798,9 @@ fillDb = do
|
||||
, sheetType = NotGraded
|
||||
, sheetGrouping = NoGroups
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just $ termTime True Summer 2 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Summer 3 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Summer 4 False Sunday beforeMidnight
|
||||
, sheetVisibleFrom = Just $ termTime True Q1 2 False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Q1 3 False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Q1 4 False Sunday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
@ -761,15 +826,15 @@ fillDb = do
|
||||
, examBonusRule = Nothing
|
||||
, examOccurrenceRule = ExamRoomManual
|
||||
, examExamOccurrenceMapping = Nothing
|
||||
, examVisibleFrom = Just $ termTime True Summer (-4) True Monday toMidnight
|
||||
, examRegisterFrom = Just $ termTime True Summer (-4) True Monday toMidnight
|
||||
, examRegisterTo = Just $ termTime True Summer 1 True Sunday beforeMidnight
|
||||
, examDeregisterUntil = Just $ termTime True Summer 2 True Wednesday beforeMidnight
|
||||
, examPublishOccurrenceAssignments = Just $ termTime True Summer 3 True Monday toMidnight
|
||||
, examStart = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 10 0 0)
|
||||
, examEnd = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 12 0 0)
|
||||
, examFinished = Just $ termTime True Summer 3 True Wednesday (toTimeOfDay 22 0 0)
|
||||
, examPartsFrom = Just $ termTime True Summer (-4) True Monday toMidnight
|
||||
, examVisibleFrom = Just $ termTime True Q1 (-4) True Monday toMidnight
|
||||
, examRegisterFrom = Just $ termTime True Q1 (-4) True Monday toMidnight
|
||||
, examRegisterTo = Just $ termTime True Q1 1 True Sunday beforeMidnight
|
||||
, examDeregisterUntil = Just $ termTime True Q1 2 True Wednesday beforeMidnight
|
||||
, examPublishOccurrenceAssignments = Just $ termTime True Q1 3 True Monday toMidnight
|
||||
, examStart = Just $ termTime True Q1 3 True Tuesday (toTimeOfDay 10 0 0)
|
||||
, examEnd = Just $ termTime True Q1 3 True Tuesday (toTimeOfDay 12 0 0)
|
||||
, examFinished = Just $ termTime True Q1 3 True Wednesday (toTimeOfDay 22 0 0)
|
||||
, examPartsFrom = Just $ termTime True Q1 (-4) True Monday toMidnight
|
||||
, examClosed = Nothing
|
||||
, examPublicStatistics = True
|
||||
, examGradingMode = ExamGradingGrades
|
||||
@ -813,12 +878,12 @@ fillDb = do
|
||||
, courseDescription = Nothing
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "EIP"
|
||||
, courseTerm = TermKey $ seasonTerm False Winter
|
||||
, courseTerm = TermKey $ seasonTerm False Q4
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just 20
|
||||
, courseVisibleFrom = Just now
|
||||
, courseVisibleTo = Nothing
|
||||
, courseRegisterFrom = Just $ termTime False Winter (-4) False Monday toMidnight
|
||||
, courseRegisterFrom = Just $ termTime False Q4 (-4) False Monday toMidnight
|
||||
, courseRegisterTo = Nothing
|
||||
, courseDeregisterUntil = Nothing
|
||||
, courseRegisterSecret = Nothing
|
||||
@ -839,13 +904,13 @@ fillDb = do
|
||||
, courseDescription = Nothing
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "IXD"
|
||||
, courseTerm = TermKey $ seasonTerm True Summer
|
||||
, courseTerm = TermKey $ seasonTerm True Q1
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just 20
|
||||
, courseVisibleFrom = Just now
|
||||
, courseVisibleTo = Nothing
|
||||
, courseRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight
|
||||
, courseRegisterTo = Just $ termTime True Summer (-2) True Sunday beforeMidnight
|
||||
, courseRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight
|
||||
, courseRegisterTo = Just $ termTime True Q1 (-2) True Sunday beforeMidnight
|
||||
, courseDeregisterUntil = Nothing
|
||||
, courseRegisterSecret = Nothing
|
||||
, courseMaterialFree = True
|
||||
@ -865,7 +930,7 @@ fillDb = do
|
||||
, courseDescription = Nothing
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "UX3"
|
||||
, courseTerm = TermKey $ seasonTerm True Winter
|
||||
, courseTerm = TermKey $ seasonTerm True Q4
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just 30
|
||||
, courseVisibleFrom = Just now
|
||||
@ -891,12 +956,12 @@ fillDb = do
|
||||
, courseDescription = Nothing
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "ProMo"
|
||||
, courseTerm = TermKey $ seasonTerm True Summer
|
||||
, courseTerm = TermKey $ seasonTerm True Q1
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just 50
|
||||
, courseVisibleFrom = Just now
|
||||
, courseVisibleTo = Nothing
|
||||
, courseRegisterFrom = Just $ termTime True Summer (-2) False Monday toMidnight
|
||||
, courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight
|
||||
, courseRegisterTo = Nothing
|
||||
, courseDeregisterUntil = Nothing
|
||||
, courseRegisterSecret = Nothing
|
||||
@ -937,7 +1002,7 @@ fillDb = do
|
||||
, let uploadEmptyOk = False
|
||||
]
|
||||
|
||||
sheetCombinations = ((,,) <$> shTypes <*> shGroupings <*> shSubModes)
|
||||
sheetCombinations = (,,) <$> shTypes <*> shGroupings <*> shSubModes
|
||||
|
||||
forM_ (zip [0..] sheetCombinations) $ \(shNr, (sheetType, sheetGrouping, sheetSubmissionMode)) -> do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
@ -982,11 +1047,11 @@ fillDb = do
|
||||
, sheetDescription = Nothing
|
||||
, sheetType, sheetGrouping, sheetSubmissionMode
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just $ termTime True Summer prog False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Summer (prog + 1) False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight
|
||||
, sheetHintFrom = Just $ termTime True Summer (prog + 1) False Sunday beforeMidnight
|
||||
, sheetSolutionFrom = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight
|
||||
, sheetVisibleFrom = Just $ termTime True Q1 prog False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime True Q1 (prog + 1) False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime True Q1 (prog + 2) False Sunday beforeMidnight
|
||||
, sheetHintFrom = Just $ termTime True Q1 (prog + 1) False Sunday beforeMidnight
|
||||
, sheetSolutionFrom = Just $ termTime True Q1 (prog + 2) False Sunday beforeMidnight
|
||||
, sheetAutoDistribute = True
|
||||
, sheetAnonymousCorrection = True
|
||||
, sheetRequireExamRegistration = Nothing
|
||||
@ -1031,7 +1096,7 @@ fillDb = do
|
||||
, occurrencesExceptions = Set.empty
|
||||
}
|
||||
, tutorialRegGroup = Just "tutorium"
|
||||
, tutorialRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight
|
||||
, tutorialRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight
|
||||
, tutorialRegisterTo = Nothing
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
, tutorialLastChanged = now
|
||||
@ -1051,7 +1116,7 @@ fillDb = do
|
||||
, occurrencesExceptions = Set.empty
|
||||
}
|
||||
, tutorialRegGroup = Just "tutorium"
|
||||
, tutorialRegisterFrom = Just $ termTime True Summer 0 False Monday toMidnight
|
||||
, tutorialRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight
|
||||
, tutorialRegisterTo = Nothing
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
, tutorialLastChanged = now
|
||||
@ -1064,7 +1129,7 @@ fillDb = do
|
||||
, courseDescription = Just "Datenbanken banken Daten damit die Daten nicht wanken. Die Datenschützer danken!"
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "DBS"
|
||||
, courseTerm = TermKey $ seasonTerm False Winter
|
||||
, courseTerm = TermKey $ seasonTerm False Q4
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just 50
|
||||
, courseVisibleFrom = Just now
|
||||
@ -1086,7 +1151,7 @@ fillDb = do
|
||||
void . insert' $ DegreeCourse dbs sdBsc sdMath
|
||||
void . insert' $ Lecturer gkleen dbs CourseLecturer
|
||||
void . insert' $ Lecturer jost dbs CourseAssistant
|
||||
|
||||
|
||||
testMsg <- insert SystemMessage
|
||||
{ systemMessageNewsOnly = False
|
||||
, systemMessageFrom = Just now
|
||||
@ -1164,7 +1229,7 @@ fillDb = do
|
||||
funAlloc <- insert' Allocation
|
||||
{ allocationName = "Funktionale Zentralanmeldung"
|
||||
, allocationShorthand = "fun"
|
||||
, allocationTerm = TermKey $ seasonTerm True Summer
|
||||
, allocationTerm = TermKey currentTerm
|
||||
, allocationSchool = ifi
|
||||
, allocationLegacyShorthands = []
|
||||
, allocationDescription = Nothing
|
||||
@ -1178,7 +1243,7 @@ fillDb = do
|
||||
, allocationRegisterByStaffFrom = Nothing
|
||||
, allocationRegisterByStaffTo = Nothing
|
||||
, allocationRegisterByCourse = Nothing
|
||||
, allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
|
||||
, allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight
|
||||
, allocationMatchingSeed = aSeedFunc
|
||||
}
|
||||
insert_ $ AllocationCourse funAlloc pmo 100 Nothing Nothing
|
||||
@ -1197,7 +1262,7 @@ fillDb = do
|
||||
, courseDescription = Nothing
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = "BS"
|
||||
, courseTerm = TermKey $ seasonTerm False Winter
|
||||
, courseTerm = TermKey $ seasonTerm False Q4
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just 50
|
||||
, courseVisibleFrom = Just now
|
||||
@ -1227,9 +1292,9 @@ fillDb = do
|
||||
, sheetType = Normal $ PassPoints 12 6
|
||||
, sheetGrouping = Arbitrary 3
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just $ termTime False Winter (fromInteger shNr) False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime False Winter (fromInteger $ succ shNr) False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime False Winter (fromInteger $ succ shNr) False Sunday beforeMidnight
|
||||
, sheetVisibleFrom = Just $ termTime False Q4 (fromInteger shNr) False Monday toMidnight
|
||||
, sheetActiveFrom = Just $ termTime False Q4 (fromInteger $ succ shNr) False Monday toMidnight
|
||||
, sheetActiveTo = Just $ termTime False Q4 (fromInteger $ succ shNr) False Sunday beforeMidnight
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True Nothing False
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
@ -1273,7 +1338,7 @@ fillDb = do
|
||||
, courseDescription = Nothing
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = CI.mk csh
|
||||
, courseTerm = TermKey $ seasonTerm False Winter
|
||||
, courseTerm = TermKey $ seasonTerm False Q4
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just 50
|
||||
, courseVisibleFrom = Just now
|
||||
@ -1302,7 +1367,7 @@ fillDb = do
|
||||
bigAlloc <- insert' Allocation
|
||||
{ allocationName = "Große Zentralanmeldung"
|
||||
, allocationShorthand = "big"
|
||||
, allocationTerm = TermKey $ seasonTerm True Summer
|
||||
, allocationTerm = TermKey $ seasonTerm True Q1
|
||||
, allocationSchool = ifi
|
||||
, allocationLegacyShorthands = []
|
||||
, allocationDescription = Nothing
|
||||
@ -1316,7 +1381,7 @@ fillDb = do
|
||||
, allocationRegisterByStaffFrom = Nothing
|
||||
, allocationRegisterByStaffTo = Nothing
|
||||
, allocationRegisterByCourse = Nothing
|
||||
, allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
|
||||
, allocationOverrideDeregister = Just $ termTime True Q1 1 False Monday toMidnight
|
||||
, allocationMatchingSeed = aSeedBig
|
||||
}
|
||||
bigAllocShorthands <-
|
||||
@ -1335,7 +1400,7 @@ fillDb = do
|
||||
, courseDescription = Nothing
|
||||
, courseLinkExternal = Nothing
|
||||
, courseShorthand = CI.mk csh
|
||||
, courseTerm = TermKey $ seasonTerm False Winter
|
||||
, courseTerm = TermKey $ seasonTerm False Q4
|
||||
, courseSchool = ifi
|
||||
, courseCapacity = Just cap
|
||||
, courseVisibleFrom = Just now
|
||||
@ -1415,42 +1480,6 @@ fillDb = do
|
||||
LBS.writeFile (bool id ("testdata" </>) haveTestdata "bigAlloc_numeric.csv") $ Csv.encode numericPriorities
|
||||
LBS.writeFile (bool id ("testdata" </>) haveTestdata "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities
|
||||
|
||||
whenM (liftIO . doesFileExist <=< testdataFile $ "workflows" </> "_index.yaml") $ do
|
||||
let displayLinterIssue :: MonadIO m => WorkflowGraphLinterIssue -> m ()
|
||||
displayLinterIssue = liftIO . hPutStrLn stderr . displayException
|
||||
|
||||
wfIndex <- Yaml.decodeFileThrow @_ @(Map WorkflowDefinitionName WorkflowIndexItem) =<< testdataFile ("workflows" </> "_index.yaml")
|
||||
|
||||
iforM_ wfIndex $ \wiName WorkflowIndexItem{..} -> handleSql displayLinterIssue $ do
|
||||
graph <- Yaml.decodeFileThrow =<< testdataFile ("workflows" </> wiiGraphFile)
|
||||
for_ (lintWorkflowGraph graph) $ mapM_ throwM
|
||||
workflowDefinitionGraph <- insertSharedWorkflowGraph graph
|
||||
let workflowDef = WorkflowDefinition{..}
|
||||
where workflowDefinitionInstanceCategory = wiiCategory
|
||||
workflowDefinitionName = wiName
|
||||
workflowDefinitionScope = wiiDefinitionScope
|
||||
wdId <- insert workflowDef
|
||||
let descs = maybe Map.empty (\I18n{..} -> Map.insert (fromMaybe (NonEmpty.head appLanguages) i18nFallbackLang) i18nFallback i18nTranslations) wiiDefinitionDescription
|
||||
iDescs = maybe Map.empty (\I18n{..} -> Map.insert (fromMaybe (NonEmpty.head appLanguages) i18nFallbackLang) i18nFallback i18nTranslations) wiiInstanceDescription
|
||||
iforM_ descs $ \workflowDefinitionDescriptionLanguage (workflowDefinitionDescriptionTitle, workflowDefinitionDescriptionDescription) ->
|
||||
let workflowDefinitionDescriptionDefinition = wdId
|
||||
in insert_ WorkflowDefinitionDescription{..}
|
||||
iforM_ iDescs $ \workflowDefinitionInstanceDescriptionLanguage (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription) ->
|
||||
let workflowDefinitionInstanceDescriptionDefinition = wdId
|
||||
in insert_ WorkflowDefinitionInstanceDescription{..}
|
||||
forM_ wiiInstances $ \rScope -> do
|
||||
dbScope <- fmap (view _DBWorkflowScope) . maybeT (error $ "Could not resolve scope: " <> show rScope) $ fromRouteWorkflowScope rScope
|
||||
wiId <-
|
||||
let workflowInstanceDefinition = Just wdId
|
||||
workflowInstanceGraph = workflowDefinitionGraph
|
||||
workflowInstanceScope = dbScope
|
||||
workflowInstanceName = workflowDefinitionName workflowDef
|
||||
workflowInstanceCategory = workflowDefinitionInstanceCategory workflowDef
|
||||
in insert WorkflowInstance{..}
|
||||
iforM_ iDescs $ \workflowInstanceDescriptionLanguage (workflowInstanceDescriptionTitle, workflowInstanceDescriptionDescription) ->
|
||||
let workflowInstanceDescriptionInstance = wiId
|
||||
in insert_ WorkflowInstanceDescription{..}
|
||||
|
||||
forM_ universeF $ \changelogItem -> do
|
||||
let ptn = "templates/i18n/changelog/" <> unpack (toPathPiece changelogItem) <> ".*"
|
||||
files <- liftIO $ glob ptn
|
||||
|
||||
@ -81,30 +81,6 @@ instance Arbitrary CourseEventR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary AdminWorkflowDefinitionR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary AdminWorkflowInstanceR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary GlobalWorkflowInstanceR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary GlobalWorkflowWorkflowR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SchoolWorkflowInstanceR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary SchoolWorkflowWorkflowR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary AMatchingR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -1,30 +0,0 @@
|
||||
module Handler.Utils.Workflow.CanonicalRouteSpec where
|
||||
|
||||
import TestImport
|
||||
import Handler.Utils.Workflow.CanonicalRoute
|
||||
import ModelSpec ()
|
||||
import FoundationSpec ()
|
||||
|
||||
|
||||
instance Arbitrary WorkflowScopeRoute where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary WorkflowScopeRoute
|
||||
instance Function WorkflowScopeRoute
|
||||
|
||||
instance Arbitrary WorkflowInstanceR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary WorkflowInstanceR
|
||||
instance Function WorkflowInstanceR
|
||||
|
||||
instance Arbitrary WorkflowWorkflowR where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary WorkflowWorkflowR
|
||||
instance Function WorkflowWorkflowR
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "_WorkflowSpecRoute" $
|
||||
before_ (pendingWith "Missing routes") . it "is a prism" . property $ isPrism _WorkflowScopeRoute
|
||||
@ -1,193 +0,0 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model.Types.WorkflowSpec where
|
||||
|
||||
import TestImport hiding (NonEmpty)
|
||||
import TestInstances ()
|
||||
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
|
||||
import Utils.I18nSpec ()
|
||||
import Model.Types.FileSpec ()
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Utils.I18n
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Data.Time.LocalTime (TimeOfDay)
|
||||
|
||||
|
||||
instance Arbitrary WorkflowPayloadLabel where
|
||||
arbitrary = WorkflowPayloadLabel . CI.mk . pack <$> (fmap getPrintableString arbitrary `suchThat` (not . null))
|
||||
shrink = genericShrink
|
||||
instance CoArbitrary WorkflowPayloadLabel
|
||||
instance Function WorkflowPayloadLabel
|
||||
|
||||
instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, Ord fileid, Arbitrary (FileField fileid)) => Arbitrary (WorkflowPayloadSpec fileid userid) where
|
||||
arbitrary = oneof
|
||||
[ WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Text)
|
||||
, WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Scientific)
|
||||
, WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Bool)
|
||||
, WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid Day)
|
||||
, WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid WorkflowPayloadTimeCapture)
|
||||
, WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid (Set fileid))
|
||||
, WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid userid)
|
||||
, WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid WorkflowPayloadFieldReference)
|
||||
, WorkflowPayloadSpec <$> arbitrary @(WorkflowPayloadField fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid)))
|
||||
]
|
||||
|
||||
instance Arbitrary WorkflowPayloadTextPreset where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
instance Arbitrary (WorkflowPayloadField fileid userid Text) where
|
||||
arbitrary = WorkflowPayloadFieldText
|
||||
<$> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
instance Arbitrary (WorkflowPayloadField fileid userid Scientific) where
|
||||
arbitrary = WorkflowPayloadFieldNumber
|
||||
<$> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
instance Arbitrary (WorkflowPayloadField fileid userid Bool) where
|
||||
arbitrary = WorkflowPayloadFieldBool
|
||||
<$> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
instance Arbitrary (WorkflowPayloadField fileid userid Day) where
|
||||
arbitrary = WorkflowPayloadFieldDay
|
||||
<$> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
instance (Arbitrary (FileField fileid)) => Arbitrary (WorkflowPayloadField fileid userid (Set fileid)) where
|
||||
arbitrary = WorkflowPayloadFieldFile
|
||||
<$> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
instance Arbitrary userid => Arbitrary (WorkflowPayloadField fileid userid userid) where
|
||||
arbitrary = oneof
|
||||
[ WorkflowPayloadFieldUser
|
||||
<$> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
, pure WorkflowPayloadFieldCaptureUser
|
||||
]
|
||||
instance Arbitrary (WorkflowPayloadField fileid userid WorkflowPayloadFieldReference) where
|
||||
arbitrary = WorkflowPayloadFieldReference
|
||||
<$> scale (`div` 2) arbitrary
|
||||
instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, Ord fileid, Arbitrary (FileField fileid)) => Arbitrary (WorkflowPayloadField fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid))) where
|
||||
arbitrary = WorkflowPayloadFieldMultiple
|
||||
<$> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
instance Arbitrary (WorkflowPayloadField fileid userid WorkflowPayloadTimeCapture) where
|
||||
arbitrary = WorkflowPayloadFieldCaptureDateTime
|
||||
<$> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
<*> scale (`div` 2) arbitrary
|
||||
|
||||
instance Arbitrary WorkflowPayloadTimeCapturePrecision where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary WorkflowGraphEdgeFormOrder where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance (Arbitrary fileid, Arbitrary userid, Typeable fileid, Typeable userid, Ord fileid, Ord userid, Ord (FileField fileid), Arbitrary (FileField fileid)) => Arbitrary (WorkflowGraphEdgeForm fileid userid) where
|
||||
arbitrary = WorkflowGraphEdgeForm . Map.fromList . mapMaybe (\(l, s) -> (l, ) <$> fromNullable (Set.fromList . mapMaybe fromNullable $ map Map.fromList s)) <$> listOf ((,) <$> scale (`div` 2) arbitrary <*> scale (`div` 2) (listOf . scale (`div` 2) . listOf $ (,) <$> scale (`div` 2) arbitrary <*> scale (`div` 2) arbitrary))
|
||||
shrink = genericShrink
|
||||
|
||||
instance (Arbitrary fileid, Arbitrary userid, Ord fileid, Typeable userid, Typeable fileid) => Arbitrary (WorkflowFieldPayloadW fileid userid) where
|
||||
arbitrary = oneof
|
||||
[ WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Text)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Scientific)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Bool)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid Day)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid TimeOfDay)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid UTCTime)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid fileid)
|
||||
, WorkflowFieldPayloadW <$> arbitrary @(WorkflowFieldPayload fileid userid userid)
|
||||
]
|
||||
|
||||
instance (Arbitrary payload, IsWorkflowFieldPayload' fileid userid payload) => Arbitrary (WorkflowFieldPayload fileid userid payload) where
|
||||
arbitrary = review _WorkflowFieldPayload <$> arbitrary
|
||||
|
||||
instance (Arbitrary termid, Arbitrary courseid) => Arbitrary (WorkflowScope termid SchoolShorthand courseid) where
|
||||
arbitrary = oneof
|
||||
[ pure WSGlobal
|
||||
, WSTerm <$> arbitrary
|
||||
, WSSchool <$> arbitrarySchoolShorthand
|
||||
, WSTermSchool <$> arbitrary <*> arbitrarySchoolShorthand
|
||||
, WSCourse <$> arbitrary
|
||||
]
|
||||
where arbitrarySchoolShorthand = CI.mk . pack <$> (fmap getPrintableString arbitrary `suchThat` (not . null))
|
||||
instance (Arbitrary termid, Arbitrary courseid) => Arbitrary (WorkflowScope termid SchoolId courseid) where
|
||||
arbitrary = over _wisSchool SchoolKey <$> arbitrary
|
||||
instance (CoArbitrary termid, CoArbitrary schoolid, CoArbitrary courseid) => CoArbitrary (WorkflowScope termid schoolid courseid)
|
||||
instance (Function termid, Function schoolid, Function courseid) => Function (WorkflowScope termid schoolid courseid)
|
||||
|
||||
instance Arbitrary WorkflowScope' where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "WorkflowPayloadSpec" $ do
|
||||
it "json-roundtrips some examples" $ do
|
||||
let roundtrip val = Aeson.eitherDecode (Aeson.encode val) `shouldBe` Right val
|
||||
|
||||
-- Generated tests that failed previously
|
||||
roundtrip $ WorkflowPayloadSpec @FileReference @SqlBackendKey (WorkflowPayloadFieldNumber {wpfnLabel = I18n {i18nFallback = "\368366\901557\714616k", i18nFallbackLang = Nothing, i18nTranslations = Map.fromList [("",""),("Jak8","\125553E")]}, wpfnPlaceholder = Just (I18n {i18nFallback = "\303706\543092", i18nFallbackLang = Nothing, i18nTranslations = Map.fromList []}), wpfnTooltip = Nothing, wpfnDefault = Nothing, wpfnMin = Nothing, wpfnMax = Just 0.1, wpfnStep = Nothing, wpfnOptional = False})
|
||||
|
||||
describe "WorkflowGraphEdgeForm" $ do
|
||||
it "json-decodes some examples" $ do
|
||||
let decodes bs = Aeson.decode bs `shouldSatisfy` is (_Just @(WorkflowGraphEdgeForm FileReference SqlBackendKey))
|
||||
|
||||
decodes "{\"\": [{\"tag\": \"capture-user\"}]}"
|
||||
decodes "{\"\": [{\"_\": {\"tag\": \"capture-user\"}}]}"
|
||||
decodes "{\"\": [{\"1\": {\"tag\": \"capture-user\"}}]}"
|
||||
decodes "{\"\": [{\"-1\": {\"tag\": \"capture-user\"}}]}"
|
||||
decodes "{\"\": [{\"tag\": \"capture-user\"}, {\"_\": {\"tag\": \"capture-user\"}}]}"
|
||||
decodes "{\"\": [{\"tag\": \"capture-user\"}, {\"1\": {\"tag\": \"capture-user\"}}]}"
|
||||
decodes "{\"\": [{\"_\": {\"tag\": \"capture-user\"}}, {\"1\": {\"tag\": \"capture-user\"}}]}"
|
||||
decodes "{\"\": [{\"0.1\":{\"tag\": \"capture-user\"}}, {\"-0.1\":{\"tag\": \"capture-user\"}}]}"
|
||||
|
||||
parallel $ do
|
||||
lawsCheckHspec (Proxy @WorkflowGraphEdgeFormOrder)
|
||||
[ eqLaws, ordLaws, semigroupLaws, monoidLaws, semigroupMonoidLaws, commutativeSemigroupLaws, idempotentSemigroupLaws, showLaws, showReadLaws, jsonLaws, jsonKeyLaws ]
|
||||
lawsCheckHspec (Proxy @(WorkflowPayloadSpec FileReference SqlBackendKey))
|
||||
[ eqLaws, ordLaws, jsonLaws ]
|
||||
modifyMaxSize (`div` 4) $ lawsCheckHspec (Proxy @(WorkflowGraphEdgeForm FileReference SqlBackendKey))
|
||||
[ eqLaws, ordLaws, jsonLaws ]
|
||||
lawsCheckHspec (Proxy @WorkflowScope')
|
||||
[ eqLaws, ordLaws, boundedEnumLaws, showLaws, showReadLaws, universeLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
|
||||
lawsCheckHspec (Proxy @(WorkflowFieldPayloadW FileReference SqlBackendKey))
|
||||
[ eqLaws, ordLaws, showLaws, jsonLaws, binaryLaws ]
|
||||
@ -5,6 +5,7 @@ module Model.TypesSpec
|
||||
) where
|
||||
|
||||
import TestImport
|
||||
import TestInstances ()
|
||||
import Settings
|
||||
|
||||
import Data.Aeson (Value)
|
||||
@ -37,7 +38,7 @@ import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Model.Types.WorkflowSpec as Model.TypesSpec ()
|
||||
import Model.Types.FileSpec ()
|
||||
|
||||
import Text.Blaze.TestInstances ()
|
||||
|
||||
@ -450,8 +451,6 @@ spec = do
|
||||
[ persistFieldLaws, jsonLaws, eqLaws, ordLaws ]
|
||||
lawsCheckHspec (Proxy @RoomReference')
|
||||
[ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ]
|
||||
lawsCheckHspec (Proxy @(WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey))
|
||||
[ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
|
||||
lawsCheckHspec (Proxy @UploadNonce)
|
||||
[ eqLaws, ordLaws, showLaws, showReadLaws, pathPieceLaws, jsonLaws, jsonKeyLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @SchoolAuthorshipStatementMode)
|
||||
@ -463,9 +462,9 @@ spec = do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
\term -> termFromText (termToText term) == Right term
|
||||
it "works for some examples" . mapM_ termExample $
|
||||
[ (TermIdentifier 2017 Summer, "S17")
|
||||
, (TermIdentifier 1995 Winter, "W95")
|
||||
, (TermIdentifier 3068 Winter, "W3068")
|
||||
[ (TermIdentifier 2017 Q2, "17Q2")
|
||||
, (TermIdentifier 1995 Q4, "95Q4")
|
||||
, (TermIdentifier 3068 Q1, "3068Q1")
|
||||
]
|
||||
it "has compatbile encoding/decoding to/from Rational" . property $
|
||||
\term -> termFromRational (termToRational term) == term
|
||||
|
||||
@ -1,9 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
set -e
|
||||
|
||||
[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
|
||||
|
||||
stack build --fast --flag uniworx:-library-only --flag uniworx:dev
|
||||
|
||||
stack exec uniworx-wflint -- $@
|
||||
@ -1,29 +0,0 @@
|
||||
module WFLint
|
||||
( main
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Workflow.Lint
|
||||
import Handler.Utils.Workflow.Form (FormWorkflowGraph)
|
||||
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import System.IO (hPutStrLn)
|
||||
import System.Exit
|
||||
|
||||
|
||||
exitParseError, exitLintIssues :: Int
|
||||
exitParseError = 2
|
||||
exitLintIssues = 3
|
||||
|
||||
die' :: (MonadIO m, Exception (Element mono), MonoFoldable mono) => Handle -> Int -> mono -> m a
|
||||
die' h err excs = liftIO $ do
|
||||
forM_ excs $ hPutStrLn h . displayException
|
||||
exitWith $ ExitFailure err
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
mwf <- Yaml.decodeEither' <$> ByteString.getContents
|
||||
(wf :: FormWorkflowGraph) <- either (die' stderr exitParseError . Identity) return mwf
|
||||
for_ (lintWorkflowGraph wf) $ die' stdout exitLintIssues
|
||||
Loading…
Reference in New Issue
Block a user