Merge branch 'fill_avn_a' into 'master'

Improved test data

See merge request FraDrive/fradrive!3

.gitlab-ci.yml

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

flake.nix

@@ -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(/.*)?$"

messages/uniworx/categories/I18n/de-de-formal.msg

@@ -1,7 +1,11 @@
-SummerTerm year@Integer: Sommersemester #{year}
+Quarter1st year@Integer: Erstes Quartal #{year}
-WinterTerm year@Integer: Wintersemester #{year}/#{succ year}
+Quarter2nd year@Integer: Zweites Quartal #{year}
-SummerTermShort year@Integer: SoSe #{year}
+Quarter3rd year@Integer: Drittes Quartal #{year}
-WinterTermShort year@Integer: WiSe #{year}/#{mod (succ year) 100}
+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

messages/uniworx/categories/I18n/en-eu.msg

@@ -1,7 +1,11 @@
-SummerTerm year: Summer semester #{year}
+Quarter1st year@Integer: First Quarter of #{year}
-WinterTerm year: Winter semester #{year}/#{succ year}
+Quarter2nd year@Integer: Second Quarter of #{year}
-SummerTermShort year: Summer #{year}
+Quarter3rd year@Integer: Third Quarter of #{year}
-WinterTermShort year: Winter #{year}/#{mod (succ year) 100}
+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

messages/uniworx/categories/workflows/de-de-formal.msg

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

messages/uniworx/categories/workflows/en-eu.msg

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

messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg

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

messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg

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

messages/uniworx/utils/navigation/menu/de-de-formal.msg

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

messages/uniworx/utils/navigation/menu/en-eu.msg

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

models/workflows.model

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

nix/uniworx/backend.nix

@@ -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.uniworxload.build-tools = with final.pkgs; [ llvm_9 ];          
-          components.exes.uniworx-wflint.build-tools = with final.pkgs; [ llvm_9 ];
           components.tests.yesod = {
             build-tools = with final.pkgs; [ llvm_9 final.uniworx.hsPkgs.hspec-discover ];
             testWrapper =

package-lock.json

@@ -4831,9 +4831,9 @@
       }
     },
     "caniuse-lite": {
-      "version": "1.0.30001137",
+      "version": "1.0.30001257",
-      "resolved": "https://registry.npmjs.org/caniuse-lite/-/caniuse-lite-1.0.30001137.tgz",
+      "resolved": "https://registry.npmjs.org/caniuse-lite/-/caniuse-lite-1.0.30001257.tgz",
-      "integrity": "sha512-54xKQZTqZrKVHmVz0+UvdZR6kQc7pJDgfhsMYDG19ID1BWoNnDMFm5Q3uSBSU401pBvKYMsHAt9qhEDcxmk8aw==",
+      "integrity": "sha512-JN49KplOgHSXpIsVSF+LUyhD8PUp6xPpAXeRrrcBh4KBeP7W864jHn6RvzJgDlrReyeVjMFJL3PLpPvKIxlIHA==",
       "dev": true
     },
     "caseless": {

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

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

src/Application.hs

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

src/CryptoID.hs

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

src/Foundation/Authorization.hs

@@ -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.List (findIndex)
-import Data.Semigroup (Last(..))
+-- 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
+  = AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
-  | AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
-  | AuthCacheWorkflowInstanceInitiators WorkflowInstanceName RouteWorkflowScope
-  | AuthCacheWorkflowInstanceWorkflowViewers WorkflowInstanceName RouteWorkflowScope
-  | 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
+tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _ -> case route of
-  mr <- getMsgRenderer
+  EExamListR -> exceptT return return $ do
-  let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-      orAR' = shortCircuitM (is _Authorized) (orAR mr)
+    hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
-      _andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
+      E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
-
+      E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
-      workflowInstanceWorkflowsEmpty rScope win = workflowsEnabledAuth $ selectLanguageI18n <=< $cachedHereBinary (evalCtx, mAuthId, route) . maybeT (unauthorizedI18n MsgUnauthorizedWorkflowWorkflowsNotEmpty) $ do
+        E.||. E.exists (E.from $ \externalExamResult ->
-        roles <- memcacheAuth' (Right diffDay) (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ do
+            E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
-          scope <- fromRouteWorkflowScope rScope
+                  E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
-          let dbScope = scope ^. _DBWorkflowScope
+          )
-              getWorkflowWorkflows = E.selectSource . E.from $ \(workflowWorkflow `E.InnerJoin` workflowInstance) -> do
+    guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
-                E.on $ workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
+    return Authorized
-                E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
+  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
-                     E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val dbScope
+    -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
-                return workflowWorkflow
+    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-              workflowRoles (Entity wwId WorkflowWorkflow{..}) = do
+    assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
-                wwGraph <- getSharedIdWorkflowGraph workflowWorkflowGraph
+    assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
-                let
+      E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
-                  nodeViewers = do
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
-                    WorkflowAction{..} <- otoList workflowWorkflowState
+    return Authorized
-                    (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
+  r -> $unsupportedAuthPredicate AuthEmpty r
-                    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 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

src/Foundation/I18n.hs

@@ -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(..)
+  , ErrorResponseTitle(..)  
-  , WorkflowPayloadBool(..)
   , UniWorXMessages(..)
   , uniworxMessages
   , unRenderMessage, unRenderMessage', unRenderMessageLenient
@@ -59,9 +58,7 @@ import Data.Text.Lens (packed)
 
 import Data.List ((!!))
 
-import qualified Data.Scientific as Scientific
+-- import qualified Data.Scientific as Scientific
-
-import Utils.Workflow (RouteWorkflowScope)
 
 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
+    Q1 -> renderMessage' $ MsgQuarter1st year
-    Winter -> renderMessage' $ MsgWinterTerm 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
+    Q1 -> renderMessage' $ MsgQuarter1stShort year
-    Winter -> renderMessage' $ MsgWinterTermShort 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

src/Foundation/Navigation.hs

@@ -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
+                -- , MonadThrow m
-                , WithRunDB SqlReadBackend (HandlerFor UniWorX) 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

src/Foundation/Routes.hs

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

src/Foundation/Yesod/Middleware.hs

@@ -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
+  , verifyCourseNews  
-  , verifyWorkflowWorkflow
   , 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

src/Handler/Course/Edit.hs

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

src/Handler/Term.hs

@@ -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
+                  { tftName         = Just ntid
-                  , tftStart = Just $ guessDay ntid TermDayStart
+                  , tftStart        = Just tStart 
-                  , tftEnd   = Just $ guessDay ntid TermDayEnd
+                  , tftEnd          = Just tEnd  
-                  , tftLectureStart = Just $ guessDay ntid TermDayLectureStart
+                  , tftLectureStart = Just tLecStart
-                  , tftLectureEnd   = Just $ guessDay ntid TermDayLectureEnd
+                  , 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 ()
+      FormMissing      -> return ()
-      (FormFailure _) -> addMessageI Warning MsgInvalidInput
+      FormFailure []   -> addMessageI Error MsgInvalidInput
+      FormFailure msgs -> forM_ msgs (addMessage Error . toHtml)
     defaultLayout $ do
       setTitleI MsgTermEditHeading
       wrapForm formWidget def

src/Handler/Utils/DateTime.hs

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

src/Handler/Utils/Form.hs

@@ -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 qualified Data.Yaml as Yaml
-
+-- import Control.Monad.Catch.Pure (runCatch)
-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) FormMessage             
-             , RenderMessage (HandlerSite m) UniWorXWorkflowMessage
              )
           => 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

src/Handler/Utils/Workflow.hs

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

src/Handler/Utils/Workflow/CanonicalRoute.hs

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

src/Handler/Utils/Workflow/EdgeForm.hs

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

src/Handler/Utils/Workflow/Form.hs

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

src/Handler/Utils/Workflow/Restriction.hs

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

src/Handler/Utils/Workflow/Workflow.hs

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

src/Handler/Workflow.hs

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

src/Handler/Workflow/Definition.hs

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

src/Handler/Workflow/Definition/Delete.hs

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

src/Handler/Workflow/Definition/Edit.hs

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

src/Handler/Workflow/Definition/Form.hs

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

src/Handler/Workflow/Definition/Instantiate.hs

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

src/Handler/Workflow/Definition/List.hs

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

src/Handler/Workflow/Definition/New.hs

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

src/Handler/Workflow/Instance.hs

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

src/Handler/Workflow/Instance/Delete.hs

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

src/Handler/Workflow/Instance/Edit.hs

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

src/Handler/Workflow/Instance/Form.hs

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

src/Handler/Workflow/Instance/Initiate.hs

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

src/Handler/Workflow/Instance/List.hs

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

src/Handler/Workflow/Instance/New.hs

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

src/Handler/Workflow/Instance/Update.hs

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

src/Handler/Workflow/Workflow.hs

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

src/Handler/Workflow/Workflow/Delete.hs

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

src/Handler/Workflow/Workflow/Edit.hs

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

src/Handler/Workflow/Workflow/List.hs

@@ -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}&nbsp;#{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

src/Handler/Workflow/Workflow/New.hs

@@ -1,10 +0,0 @@
-module Handler.Workflow.Workflow.New
-  ( getAdminWorkflowWorkflowNewR, postAdminWorkflowWorkflowNewR
-  ) where
-
-import Import
-
-
-getAdminWorkflowWorkflowNewR, postAdminWorkflowWorkflowNewR :: Handler Html
-getAdminWorkflowWorkflowNewR = postAdminWorkflowWorkflowNewR
-postAdminWorkflowWorkflowNewR = error "not implemented"

src/Handler/Workflow/Workflow/Workflow.hs

@@ -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}&nbsp;#{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

src/Jobs/Handler/Files.hs

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

src/Model/Migration/Definitions.hs

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

src/Model/Types.hs

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

src/Model/Types/DateTime.hs

@@ -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
+numSeasons :: Int -- to be flexible
-seasonToChar Summer = 'S'
+numSeasons = succ $ fromEnum(maxBound::Season)
-seasonToChar Winter = 'W'
 
-seasonFromChar :: Char -> Either Text Season
+seasonFromText' :: Text -> Either Text Season
-seasonFromChar c
+seasonFromText' t = maybeToRight errmsg (readMaybe $ Text.unpack $ Text.toUpper t)
-  | c ~= 'S'  = Right Summer
+  where 
-  | c ~= 'W'  = Right Winter
+    errmsg = "Invalid season: ‘" <> tshow t <> "’"
-  | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’"
+
+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{..}
+  toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` numSeasons in TermIdentifier{..}
-  fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season
+  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
+  | (ys,s) <- Text.break (~= 'Q') t
-  , Just (review shortened -> year) <- readMaybe ys
+  , Right season <- seasonFromText s
-  , Right season <- seasonFromChar 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
+    seasonOffset = fromIntegral (fromEnum season) % fromIntegral numSeasons
-      | Summer <- season = 0
-      | Winter <- season = 0.5
 
 termFromRational :: Rational -> TermIdentifier
 termFromRational n = TermIdentifier{..}
   where
-    year = floor n
+    year = floor n 
-    remainder = n - fromInteger (floor n)
+    remainder = n - fromInteger (floor n)  -- properFraction problematic for negative year values 
-    season
+    season = toEnum $ floor $ remainder * fromIntegral numSeasons
-      | remainder == 0 = Summer
-      | otherwise      = Winter
 
 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
+guessDay :: TermIdentifier
-time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
+         -> 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

src/Model/Types/Security.hs

@@ -54,8 +54,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthExamOffice
   | AuthSystemExamOffice
   | AuthEvaluation
-  | AuthAllocationAdmin
+  | AuthAllocationAdmin  
-  | AuthWorkflow
   | AuthAllocationRegistered
   | AuthCourseRegistered
   | AuthTutorialRegistered

src/Utils/Holidays.hs

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

src/Utils/Lens.hs

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

src/Utils/Workflow.hs

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

src/Utils/Workflow/Lint.hs

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

src/index.md

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

test/Database/Fill.hs

@@ -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 System.Directory (getModificationTime, doesDirectoryExist)
-
-import Utils.Workflow
-import Utils.Workflow.Lint
-
-import System.Directory (getModificationTime, doesFileExist, 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
+      | 3 >= currentMonth = TermIdentifier currentYear Q1
-      , currentMonth <= 9
+      | 6 >= currentMonth = TermIdentifier currentYear Q2
-      = TermIdentifier  currentYear       Summer
+      | 9 >= currentMonth = TermIdentifier currentYear Q3
-      | otherwise
+      | otherwise         = TermIdentifier currentYear Q4
-      = TermIdentifier (pred currentYear) Winter
     nextTerm = succ currentTerm
     prevTerm = pred currentTerm
     prevPrevTerm = pred prevTerm
 
-    seasonTerm next wSeason
+    seasonTerm next wSeason = until ((wSeason ==) . season) prog currentTerm
-      | wSeason == season currentTerm
+      where prog | next      = succ
-      , next = currentTerm
+                 | otherwise = pred
-      | wSeason == season currentTerm
-      = prevPrevTerm
-      | next
-      = nextTerm
-      | otherwise
-      = prevTerm
 
     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
+        (wYear, wWeek, _) = toWeekDate . addDays (round $ 7 * weekOffset) $ fromGregorian rYear rMonth rDay
-        gYear = year $ seasonTerm next gSeason
+        gTid = seasonTerm next gSeason        
-        (rMonth, rDay)
+        (rYear, rMonth, rDay) = toGregorian $ guessDay gTid $ bool TermDayLectureStart TermDayLectureEnd fromEnd          
-          | Winter <- gSeason
-          , True <- fromEnd
-          = (03, 31)
-          | Winter <- gSeason
-          , False <- fromEnd
-          = (10, 01)
-          | True <- fromEnd
-          = (09, 30)
-          | otherwise
-          = (04, 01)
     
   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
+    , courseRegisterFrom = Just $ termTime True Q1 (-2) False Monday toMidnight
-    , courseRegisterTo = Just $ termTime True Summer 0 True Sunday beforeMidnight
+    , 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
+    , sheetVisibleFrom = Just $ termTime True Q1 0 False Monday toMidnight
-    , sheetActiveFrom = Just $ termTime True Summer 1 False Monday toMidnight
+    , sheetActiveFrom = Just $ termTime True Q1 1 False Monday toMidnight
-    , sheetActiveTo = Just $ termTime True Summer 2 False Sunday beforeMidnight
+    , 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
+    , sheetVisibleFrom = Just $ termTime True Q1 1 False Monday toMidnight
-    , sheetActiveFrom = Just $ termTime True Summer 2 False Monday toMidnight
+    , sheetActiveFrom = Just $ termTime True Q1 2 False Monday toMidnight
-    , sheetActiveTo = Just $ termTime True Summer 3 False Sunday beforeMidnight
+    , 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
+    , sheetVisibleFrom = Just $ termTime True Q1 2 False Monday toMidnight
-    , sheetActiveFrom = Just $ termTime True Summer 3 False Monday toMidnight
+    , sheetActiveFrom = Just $ termTime True Q1 3 False Monday toMidnight
-    , sheetActiveTo = Just $ termTime True Summer 4 False Sunday beforeMidnight
+    , 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
+    , examVisibleFrom = Just $ termTime True Q1 (-4) True Monday toMidnight
-    , examRegisterFrom = Just $ termTime True Summer (-4) True Monday toMidnight
+    , examRegisterFrom = Just $ termTime True Q1 (-4) True Monday toMidnight
-    , examRegisterTo = Just $ termTime True Summer 1 True Sunday beforeMidnight
+    , examRegisterTo = Just $ termTime True Q1 1 True Sunday beforeMidnight
-    , examDeregisterUntil = Just $ termTime True Summer 2 True Wednesday beforeMidnight
+    , examDeregisterUntil = Just $ termTime True Q1 2 True Wednesday beforeMidnight
-    , examPublishOccurrenceAssignments = Just $ termTime True Summer 3 True Monday toMidnight
+    , examPublishOccurrenceAssignments = Just $ termTime True Q1 3 True Monday toMidnight
-    , examStart = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 10 0 0)
+    , examStart = Just $ termTime True Q1 3 True Tuesday (toTimeOfDay 10 0 0)
-    , examEnd = Just $ termTime True Summer 3 True Tuesday (toTimeOfDay 12 0 0)
+    , examEnd = Just $ termTime True Q1 3 True Tuesday (toTimeOfDay 12 0 0)
-    , examFinished = Just $ termTime True Summer 3 True Wednesday (toTimeOfDay 22 0 0)
+    , examFinished = Just $ termTime True Q1 3 True Wednesday (toTimeOfDay 22 0 0)
-    , examPartsFrom = Just $ termTime True Summer (-4) True Monday toMidnight
+    , 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
+    , courseRegisterFrom = Just $ termTime True Q1 0 False Monday toMidnight
-    , courseRegisterTo = Just $ termTime True Summer (-2) True Sunday beforeMidnight
+    , 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
+      , sheetVisibleFrom = Just $ termTime True Q1 prog False Monday toMidnight
-      , sheetActiveFrom = Just $ termTime True Summer (prog + 1) False Monday toMidnight
+      , sheetActiveFrom = Just $ termTime True Q1 (prog + 1) False Monday toMidnight
-      , sheetActiveTo = Just $ termTime True Summer (prog + 2) False Sunday beforeMidnight
+      , sheetActiveTo = Just $ termTime True Q1 (prog + 2) False Sunday beforeMidnight
-      , sheetHintFrom = Just $ termTime True Summer (prog + 1) False Sunday beforeMidnight
+      , sheetHintFrom = Just $ termTime True Q1 (prog + 1) False Sunday beforeMidnight
-      , sheetSolutionFrom = Just $ termTime True Summer (prog + 2) 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
+      , sheetVisibleFrom = Just $ termTime False Q4 (fromInteger shNr) False Monday toMidnight
-      , sheetActiveFrom = Just $ termTime False Winter (fromInteger $ succ shNr) False Monday toMidnight
+      , sheetActiveFrom = Just $ termTime False Q4 (fromInteger $ succ shNr) False Monday toMidnight
-      , sheetActiveTo = Just $ termTime False Winter (fromInteger $ succ shNr) False Sunday beforeMidnight
+      , 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

test/FoundationSpec.hs

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

test/Handler/Utils/Workflow/CanonicalRouteSpec.hs

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

test/Model/Types/WorkflowSpec.hs

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

test/Model/TypesSpec.hs

@@ -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 2017 Q2, "17Q2")
-      , (TermIdentifier 1995 Winter, "W95")
+      , (TermIdentifier 1995 Q4, "95Q4")
-      , (TermIdentifier 3068 Winter, "W3068")
+      , (TermIdentifier 3068 Q1, "3068Q1")
       ]
     it "has compatbile encoding/decoding to/from Rational" . property $
       \term -> termFromRational (termToRational term) == term

wflint.sh

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

wflint/WFLint.hs

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