feat(workflows): additional work on WorkflowWorkflowWorkflow

frontend/src/app.sass

@@ -720,7 +720,7 @@ section
      background-color: hsla($hue, 75%, 50%, $opacity) !important
 
 
-.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label
+.uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label, .workflow-payload--text
   font-family: var(--font-monospace)
 
 .token

frontend/src/utils/form/datepicker.js

@@ -3,6 +3,8 @@ import './datepicker.css';
 import { Utility } from '../../core/utility';
 import moment from 'moment';
 
+import * as defer from 'lodash.defer';
+
 const KEYCODE_ESCAPE = 27;
 const Z_INDEX_MODAL = 9999;
 
@@ -77,8 +79,11 @@ export class Datepicker {
   datepickerInstance;
   _element;
   elementType;
+  initialValue;
   _locale;
 
+  _unloadIsDueToSubmit = false;
+
   constructor(element) {
     if (!element) {
       throw new Error('Datepicker utility needs to be passed an element!');
@@ -100,6 +105,9 @@ export class Datepicker {
     // store the previously set type to select the input format
     this.elementType = this._element.getAttribute('type');
 
+    // store initial value prior to changing type
+    this.initialValue = this._element.value || this._element.getAttribute('value');
+
     // manually set the type attribute to text because datepicker handles displaying the date
     this._element.setAttribute('type', 'text');
 
@@ -120,7 +128,7 @@ export class Datepicker {
     // FIXME dirty hack below; fix tail.datetime instead
 
     // get date object from internal format before datetime does nasty things with it
-    let parsedMomentDate = moment(this._element.value, [ FORM_DATE_FORMAT[this.elementType], FORM_DATE_FORMAT_MOMENT[this.elementType] ], true);
+    let parsedMomentDate = moment(this.initialValue, [ FORM_DATE_FORMAT[this.elementType], FORM_DATE_FORMAT_MOMENT[this.elementType] ], true);
     if (parsedMomentDate && parsedMomentDate.isValid()) {
       parsedMomentDate = parsedMomentDate.toDate();
     } else {
@@ -222,7 +230,9 @@ export class Datepicker {
     });
 
     // format the date value of the form input element of this datepicker before form submission
-    this._element.form.addEventListener('submit', () => this.formatElementValue());
+    this._element.form.addEventListener('submit', this._submitHandler.bind(this));
+
+    window.addEventListener('beforeunload', this._beforeUnloadHandler.bind(this));
   }
 
   destroy() {
@@ -257,6 +267,33 @@ export class Datepicker {
     }
   }
 
+  _submitHandler() {
+    this._unloadIsDueToSubmit = true;
+    this.formatElementValue(false);
+
+    defer(() => { // Restore state after event loop is settled
+      this._unloadIsDueToSubmit = false;
+      this.formatElementValue(true);
+    });
+  }
+  /**
+   * Restore input element to it's original type and format it's new value for input-value persisting by the browser
+   */
+  _beforeUnloadHandler() {
+    if (this._unloadIsDueToSubmit)
+      return;
+    
+    let oldValue = this._element.value;
+    let newValue = this.unformat(false);
+    this._element.type = this.elementType;
+    this._element.value = newValue;
+
+    defer(() => { // Restore state after event loop is settled
+      this._element.setAttribute('type', 'text');
+      this._element.value = oldValue;
+    });
+  }
+
   /**
    * Returns a datestring in internal format from the current state of the input element value.
    * @param {*} toFancy Format date from internal to fancy or vice versa. When omitted, toFancy is falsy and results in fancy -> internal

frontend/src/utils/form/navigate-away-prompt.js

@@ -5,6 +5,8 @@ import { AUTO_SUBMIT_INPUT_UTIL_SELECTOR } from './auto-submit-input';
 import { InteractiveFieldset } from './interactive-fieldset';
 import { Datepicker } from './datepicker';
 
+import * as defer from 'lodash.defer';
+
 /**
  * Key generator from an arbitrary number of FormData objects.
  * @param  {...any} formDatas FormData objects
@@ -67,6 +69,7 @@ export class NavigateAwayPrompt {
 
     this._element.addEventListener('submit', () => {
       this._unloadDueToSubmit = true;
+      defer(() => { this._unloadDueToSubmit = false; } ); // Restore state after event loop is settled
     });
   }
 

messages/uniworx/de-de-formal.msg

@@ -527,11 +527,12 @@ UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum
 UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet
 UnauthorizedAllocatedCourseDeregister: Abmeldungen vom Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet
 UnauthorizedAllocatedCourseDelete: Kurse, die an einer Zentralanmeldung teilnehmen, dürfen nicht gelöscht werden
-UnauthorizedWorkflowInitiate: Der Workflow darf nicht im angegebenen Zustand unter Verwendung der angegebenen Kante initiiert werden
+UnauthorizedWorkflowInitiate: Sie dürfen keinen neuen laufenden Workflow initiieren
 UnauthorizedWorkflowWrite: Sie dürfen aktuell keinen Zustandsübergang im Workflow auslösen
 UnauthorizedWorkflowRead: Der Workflow enthält aktuell keine Zustände oder Daten die Sie einsehen dürfen
 UnauthorizedWorkflowInstancesNotEmpty: Es gibt Workflow Instanzen für die Sie einen neuen laufenden Workflow initiieren dürfen
 UnauthorizedWorkflowWorkflowsNotEmpty: Es gibt laufende Workflows, die Sie einsehen dürfen
+UnauthorizedWorkflowFiles: Sie dürfen die angegebenen Workflow-Dateien nicht im angegebenen historischen Zustand herunterladen
 
 WorkflowRoleUserMismatch: Sie sind nicht einer der vom Workflow geforderten Benutzer
 WorkflowRoleAlreadyInitiated: Dieser Workflow wurde bereits initiiert
@@ -1501,6 +1502,7 @@ BreadcrumbWorkflowInstanceInitiate: Workflow starten
 BreadcrumbWorkflowInstanceList: Workflows
 BreadcrumbWorkflowInstanceNew: Neuer Workflow
 BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow: #{toPathPiece workflow}
+BreadcrumbWorkflowWorkflowFiles: Dateien
 BreadcrumbWorkflowWorkflowEdit: Editieren
 BreadcrumbWorkflowWorkflowDelete: Löschen
 BreadcrumbGlobalWorkflowInstanceList: Workflows
@@ -2951,6 +2953,8 @@ WorkflowDefinitionCollision: Es existiert bereits eine Workflow-Definition mit d
 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
@@ -2995,6 +2999,27 @@ WorkflowEdgeFormFieldNumberTooSmall minSci@Scientific: Zahl muss mindestens #{fo
 WorkflowEdgeFormFieldNumberTooLarge maxSci@Scientific: Zahl muss höchstens #{formatScientific Scientific.Generic Nothing maxSci} sein
 WorkflowEdgeFormFieldUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden
 WorkflowEdgeFormFieldMultipleNoneAdded: (Noch) keine Einträge
+WorkflowEdgeFormFieldCaptureUserLabel: Aktueller Benutzer
+
+WorkflowWorkflowWorkflowHistoryHeading: Verlauf
+WorkflowWorkflowWorkflowEdgeFormHeading: Aktion im Workflow auslösen
+WorkflowWorkflowWorkflowEdgeSuccess: Aktion erfolgreich ausgelöst
+WorkflowWorkflowWorkflowHistoryUserSelf: Sie selbst
+WorkflowWorkflowWorkflowHistoryUserNotLoggedIn: Nicht eingeloggter Benutzer
+WorkflowWorkflowWorkflowHistoryUserGone: Gelöschter Benutzer
+WorkflowWorkflowWorkflowHistoryUserHidden: Versteckter Benutzer
+WorkflowWorkflowWorkflowHistoryUserAutomatic: Automatisch
+WorkflowWorkflowWorkflowHistoryActionAutomatic: Automatisch
+WorkflowWorkflowWorkflowHistoryStateHidden: Versteckter Zustand
+WorkflowWorkflowFilesArchiveName wwCID@CryptoFileNameWorkflowWorkflow wpl@WorkflowPayloadLabel stCID@CryptoUUIDWorkflowStateIndex: #{foldCase (toPathPiece wwCID)}-#{foldCase (toPathPiece stCID)}-#{foldCase (foldMap unidecode (toPathPiece wpl))}.zip
+
+WorkflowPayloadFiles: Datei(en)
+WorkflowPayloadBoolTrue: Ja
+WorkflowPayloadBoolFalse: Nein
+WorkflowPayloadUserGone: Gelöschter Benutzer
+
+GlobalWorkflowWorkflowWorkflowHeading workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{toPathPiece workflowWorkflowId}
+GlobalWorkflowWorkflowWorkflowTitle workflowWorkflowId@CryptoFileNameWorkflowWorkflow: Workflow #{toPathPiece workflowWorkflowId}
 
 ChangelogItemFeature: Feature
 ChangelogItemBugfix: Bugfix

routes

@@ -79,6 +79,7 @@
 /workflows                    GlobalWorkflowWorkflowListR GET  !¬empty
 /workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR:
   /                           GWWWorkflowR     GET POST        !workflow
+  /files/#WorkflowPayloadLabel/#CryptoUUIDWorkflowStateIndex GWWFilesR GET !workflow
   /edit                       GWWEditR         GET POST
   /delete                     GWWDeleteR       GET POST
 

src/CryptoID.hs

@@ -77,6 +77,9 @@ decCryptoIDs [ ''SubmissionId
              , ''WorkflowWorkflowId
              ]
 
+type instance CryptoIDNamespace a WorkflowStateIndex = "WorkflowStateIndex"
+type CryptoUUIDWorkflowStateIndex = CryptoUUID WorkflowStateIndex
+
 decCryptoIDKeySize
 
 -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

src/Foundation/Authorization.hs

@@ -1224,6 +1224,8 @@ tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do
         return Authorized
 
   case route of
+    _ | Just (rScope, WorkflowInstanceListR) <- route ^? _WorkflowScopeRoute -> wInstances rScope
+    _ | Just (rScope, WorkflowWorkflowListR) <- route ^? _WorkflowScopeRoute -> wWorkflows rScope
     EExamListR -> exceptT return return $ do
       authId <- maybeExceptT AuthenticationRequired $ return mAuthId
       hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
@@ -1243,8 +1245,6 @@ tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do
         E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
         E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
       return Authorized
-    GlobalWorkflowInstanceListR -> wInstances WSGlobal
-    GlobalWorkflowWorkflowListR -> wWorkflows WSGlobal
     r -> $unsupportedAuthPredicate AuthEmpty r
 tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
@@ -1364,7 +1364,8 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do
       orAR' = shortCircuitM (is _Authorized) (orAR mr)
       _andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
     
-      wInitiate win scope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInitiate) $ do
+      wInitiate win rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInitiate) $ do
+        scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
         Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
         let
           wiGraph :: WorkflowGraph FileReference UserId
@@ -1376,11 +1377,12 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do
         let
           evalRole role = lift $ evalWorkflowRoleFor mAuthId Nothing role route isWrite
           checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
-        ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
+        guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
+        return Authorized
 
       wWorkflow isWrite' cID
         | isWrite' = maybeT (unauthorizedI MsgUnauthorizedWorkflowWrite) $ do
-            wwId <- decrypt cID
+            wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
             WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
 
             let
@@ -1397,9 +1399,10 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do
 
               evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite
               checkEdge actors = ofoldr1 orAR' (mapNonNull evalRole actors)
-            ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
+            guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull checkEdge =<< hoistMaybe (fromNullable edges)
+            return Authorized
         | otherwise = flip orAR' (wWorkflow True cID) . maybeT (unauthorizedI MsgUnauthorizedWorkflowRead) $ do
-            wwId <- decrypt cID
+            wwId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
             WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
 
             let
@@ -1410,18 +1413,36 @@ tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do
                 WorkflowAction{..} <- otoList workflowWorkflowState
                 (node, WGN{..}) <- itoListOf (_wgNodes . ifolded) wwGraph
                 guard $ node == wpTo
-                return wgnViewers
+                WorkflowNodeView{..} <- hoistMaybe wgnViewers
+                return $ toNullable wnvViewers
               payloadViewers = do
                 WorkflowAction{..} <- otoList workflowWorkflowState
                 payload <- Map.keys wpPayload
                 fmap (toNullable . wpvViewers) . hoistMaybe $ wgPayloadView wwGraph Map.!? payload
               
               evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite
-            ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers)
+            guardM . fmap (is _Authorized) $ ofoldr1 orAR' . mapNonNull evalRole =<< hoistMaybe (fromNullable . otoList $ fold nodeViewers <> fold payloadViewers)
+            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
+        let
+          wwGraph :: WorkflowGraph FileReference UserId
+          wwGraph = workflowWorkflowGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId)
+
+          payloadViewers = Map.findWithDefault Set.empty wpl $ toNullable . wpvViewers <$> wgPayloadView wwGraph
+          evalRole role = lift $ evalWorkflowRoleFor mAuthId (Just wwId) role route isWrite
+        guardM . anyM (otoList payloadViewers) $ fmap (is _Authorized) . evalRole
+        WorkflowAction{wpTo} <- workflowStateIndex stIx workflowWorkflowState 
+        WorkflowNodeView{wnvViewers} <- hoistMaybe $ wgnViewers =<< wgNodes wwGraph Map.!? wpTo
+        guardM . anyM (otoList wnvViewers) $ fmap (is _Authorized) . evalRole
+        return Authorized
 
   case route of
-    GlobalWorkflowInstanceR win GWIInitiateR -> wInitiate win WSGlobal
+    _ | Just (rScope, WorkflowInstanceR win WIInitiateR) <- route ^? _WorkflowScopeRoute -> wInitiate win rScope
-    GlobalWorkflowWorkflowR cID GWWWorkflowR -> wWorkflow isWrite cID
+    _ | 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
@@ -1625,7 +1646,7 @@ evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite = $cachedHereBi
     uid <- maybeExceptT AuthenticationRequired $ return mAuthId
     wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId
     WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
-    let uids = maybe Set.empty getLast . foldMap (fmap Last . assertM' (not . Set.null)) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState
+    let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState
     unless (uid `Set.member` uids) $ 
       throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
     return Authorized

src/Foundation/I18n.hs

@@ -15,6 +15,7 @@ module Foundation.I18n
   , ShortStudyFieldType(..)
   , StudyDegreeTermType(..)
   , ErrorResponseTitle(..)
+  , WorkflowPayloadBool(..)
   , UniWorXMessages(..)
   , uniworxMessages
   , unRenderMessage, unRenderMessage', unRenderMessageLenient
@@ -348,6 +349,10 @@ 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)
   deriving newtype (Semigroup, Monoid)

src/Foundation/Navigation.hs

@@ -359,6 +359,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
   breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbGlobalWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR
   breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of
     GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowInstanceListR
+    GWWFilesR _ _ -> i18nCrumb MsgBreadcrumbWorkflowWorkflowFiles . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
     GWWEditR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowEdit . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
     GWWDeleteR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowDelete . Just $ GlobalWorkflowWorkflowR cID GWWWorkflowR
 

src/Foundation/Yesod/Middleware.hs

@@ -23,6 +23,8 @@ import Control.Monad.Writer.Class (MonadWriter(..))
 
 import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))
 
+import qualified Data.Map as Map
+
 
 yesodMiddleware :: ( BearerAuthSite UniWorX
                    , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
@@ -160,6 +162,7 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
   , ncExternalExam
   , ncAdminWorkflowDefinition
   , ncWorkflowInstance
+  , ncWorkflowPayloadLabel
   , verifySubmission
   , verifyCourseApplication
   , verifyCourseNews
@@ -250,6 +253,14 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
       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
+      [wpl'] <- return . filter (== wpl) . Map.keys $ wgPayloadView workflowWorkflowGraph
+      (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 <- $cachedHereBinary cID $ decrypt cID

src/Handler/Utils/Workflow/CanonicalRoute.hs

@@ -18,7 +18,7 @@ data WorkflowInstanceR
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data WorkflowWorkflowR
-  = WWWorkflowR | WWEditR | WWDeleteR
+  = WWWorkflowR | WWFilesR WorkflowPayloadLabel CryptoUUIDWorkflowStateIndex | WWEditR | WWDeleteR
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 
@@ -31,30 +31,32 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
   where
     toRoute = \case
       WSGlobal -> \case
-        WorkflowInstanceListR          -> GlobalWorkflowInstanceListR
+        WorkflowInstanceListR            -> GlobalWorkflowInstanceListR
-        WorkflowInstanceNewR           -> GlobalWorkflowInstanceNewR
+        WorkflowInstanceNewR             -> GlobalWorkflowInstanceNewR
-        WorkflowInstanceR win subRoute -> GlobalWorkflowInstanceR win $ case subRoute of
+        WorkflowInstanceR win subRoute   -> GlobalWorkflowInstanceR win $ case subRoute of
           WIEditR      -> GWIEditR
           WIDeleteR    -> GWIDeleteR
           WIWorkflowsR -> GWIWorkflowsR
           WIInitiateR  -> GWIInitiateR
-        WorkflowWorkflowListR          -> GlobalWorkflowWorkflowListR
+        WorkflowWorkflowListR            -> GlobalWorkflowWorkflowListR
-        WorkflowWorkflowR cID subRoute -> GlobalWorkflowWorkflowR cID $ case subRoute of
+        WorkflowWorkflowR wwCID subRoute -> GlobalWorkflowWorkflowR wwCID $ case subRoute of
-          WWWorkflowR -> GWWWorkflowR
+          WWWorkflowR        -> GWWWorkflowR
-          WWEditR     -> GWWEditR
+          WWFilesR wpl stCID -> GWWFilesR wpl stCID
-          WWDeleteR   -> GWWDeleteR
+          WWEditR            -> GWWEditR
+          WWDeleteR          -> GWWDeleteR
       other -> error $ "not implemented _WorkflowScopeRoute for: " <> show other
     toWorkflowScopeRoute = \case
-      GlobalWorkflowInstanceListR          -> Just ( WSGlobal, WorkflowInstanceListR )
+      GlobalWorkflowInstanceListR            -> Just ( WSGlobal, WorkflowInstanceListR )
-      GlobalWorkflowInstanceNewR           -> Just ( WSGlobal, WorkflowInstanceNewR )
+      GlobalWorkflowInstanceNewR             -> Just ( WSGlobal, WorkflowInstanceNewR )
-      GlobalWorkflowInstanceR win subRoute -> Just . (WSGlobal, ) . WorkflowInstanceR win $ case subRoute of
+      GlobalWorkflowInstanceR win subRoute   -> Just . (WSGlobal, ) . WorkflowInstanceR win $ case subRoute of
         GWIEditR      -> WIEditR
         GWIDeleteR    -> WIDeleteR
         GWIWorkflowsR -> WIWorkflowsR
         GWIInitiateR  -> WIInitiateR
-      GlobalWorkflowWorkflowListR          -> Just ( WSGlobal, WorkflowWorkflowListR )
+      GlobalWorkflowWorkflowListR            -> Just ( WSGlobal, WorkflowWorkflowListR )
-      GlobalWorkflowWorkflowR cID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR cID $ case subRoute of
+      GlobalWorkflowWorkflowR wwCID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of
-        GWWWorkflowR -> WWWorkflowR
+        GWWWorkflowR        -> WWWorkflowR
-        GWWEditR     -> WWEditR
+        GWWFilesR wpl stCID -> WWFilesR wpl stCID
-        GWWDeleteR   -> WWDeleteR
+        GWWEditR            -> WWEditR
+        GWWDeleteR          -> WWDeleteR
       _other -> Nothing

src/Handler/Utils/Workflow/EdgeForm.hs

@@ -10,6 +10,7 @@ import Utils.Form
 import Utils.Workflow
 import Handler.Utils.Form
 import Handler.Utils.Workflow.CanonicalRoute
+import Handler.Utils.Widgets
 
 import qualified ListT
 
@@ -36,6 +37,7 @@ 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
@@ -107,6 +109,8 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
         return (wgeDisplayLabel, wgeForm)
       _other -> mzero
 
+  guard . not $ null edges
+
   -- edgesOptList :: OptionList (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel)
   edgesOptList <- do
     sBoxKey <- secretBoxKey
@@ -124,7 +128,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
     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
+                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'
@@ -156,7 +160,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
               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 payloadSpec'
+                  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
@@ -187,9 +191,9 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
 
         fields' <-
           let payloadReferenceAdjacency = fieldsMap <&> setOf (_2 . _1 . folded . _Left)
-              fieldsMap :: Map WorkflowPayloadLabel ((Text, Bool), ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)))], [FieldView UniWorX]))
+              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 (WorkflowFieldPayloadW FileReference UserId)))], [FieldView UniWorX])))]
+              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
@@ -202,7 +206,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
 
         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.singleton) 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
@@ -235,25 +239,52 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
 
 workflowEdgePayloadFields :: [WorkflowPayloadSpec FileReference UserId]
                           -> Maybe [WorkflowFieldPayloadW FileReference UserId]
-                          -> WForm Handler ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)))], All) -- ^ @isFilled@, @foldMap ala All . map isOptional@
+                          -> 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 (WorkflowFieldPayloadW 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 isOpt fld fs mx = lift . (<* tell (All isOpt)) . lift $ over (_2 . mapped . mapped) (review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . bool (is (_FormSuccess . _Just) &&& id) (True, ) isOpt <$> wopt fld fs (Just <$> mx)
+      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'
+                         ( IsWorkflowFieldPayload' FileReference UserId payload'
                          , State.MonadState [WorkflowFieldPayloadW FileReference UserId] m
                          )
                       => m (Maybe payload')
-          extractPrev = State.state $ foldl' go (Nothing, []) . map (matching $ _WorkflowFieldPayloadW . _WorkflowFieldPayload)
+          extractPrev = extractPrevs $ \p -> \case
-            where go (mPrev' , xs) (Left  x ) = (mPrev', xs ++ [x])
+            Nothing -> Just p
-                  go (Nothing, xs) (Right p ) = (Just p, xs)
+            Just _  -> Nothing
-                  go (Just p , xs) (Right p') = (Just p, xs ++ [_WorkflowFieldPayloadW . _WorkflowFieldPayload # p'])
           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
 
@@ -262,7 +293,7 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec
           prev <- extractPrev @Text
           wSetTooltip' (fmap slI18n wpftTooltip) $
             f wpftOptional
-              (textField & cfStrip)
+              (bool (textField & cfStrip) (textareaField & isoField _Wrapped & cfStrip) wpftLarge)
               ( fsl (slI18n wpftLabel)
                   & maybe id (addPlaceholder . slI18n) wpftPlaceholder
                   & maybe id (addName . ($ "text")) mNudge
@@ -294,10 +325,23 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec
                   & maybe id (addName . ($ "bool")) mNudge
               )
               (prev <|> wpfbDefault)
+        WorkflowPayloadFieldDay{..} -> do
+          prev <- extractPrev @Day
+          wSetTooltip' (fmap slI18n wpfdTooltip) $
+            f wpfdOptional
+               dayField
+              ( fsl (slI18n wpfdLabel)
+                  & maybe id (addName . ($ "day")) mNudge
+              )
+              (prev <|> wpfdDefault)
         WorkflowPayloadFieldFile{..} -> do
-          fRefs <- extractPrev @(Set FileReference)
+          fRefs <- extractPrevs @FileReference $ \p -> if
+            | fieldMultiple wpffConfig -> Just . maybe (Set.singleton p) (Set.insert p)
+            | otherwise -> \case
+                Nothing -> Just $ Set.singleton p
+                Just _  -> Nothing
           wSetTooltip' (fmap slI18n wpffTooltip) $
-            f wpffOptional
+            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
@@ -316,29 +360,44 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec
               )
               (fRefs <|> wpfuDefault)
         WorkflowPayloadFieldCaptureUser -> do
-          mAuthId <- liftHandler maybeAuthId
+          mAuthId <- liftHandler maybeAuth
           case mAuthId of
-            Just uid -> (True,  FormSuccess $ _Just . _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid) <$ tell (All True)
+            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)
         WorkflowPayloadFieldReference{..} -> throwE wpfrTarget
         WorkflowPayloadFieldMultiple{..} -> do
-          fRefs <- extractPrev @(NonEmpty (WorkflowFieldPayloadW FileReference UserId))
+          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 (WorkflowFieldPayloadW FileReference UserId)))
+                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)) $ maybe [] otoList mPrev'
+                mPrev = Just . Map.fromList . zip [0..] . ensureLength . map (\x -> (Just x, Just $ x :| [])) $ mPrev' ^.. _Just . folded
                   where
-                    ensureLength :: forall a. [(Maybe a, Maybe a)] -> [(Maybe a, Maybe a)]
+                    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 (WorkflowFieldPayloadW FileReference UserId)))
+                                FormResult (Map ListPosition (a, Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
-                             -> (Bool, FormResult (Maybe (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 . fmap (review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . nonEmpty $ ress ^.. folded . _2 . _Just)
+                    -> (True, FormSuccess . nonEmpty $ ress ^.. folded . _2 . _Just . folded)
                   Left res'
                     -> (False, res')
                 runMI :: forall a.
@@ -361,31 +420,30 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec
                       -> 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 nudge submitView = Just $ \csrf -> over (_1 . _FormSuccess) tweakRes <$> miForm nudge (Left submitView) csrf
-                  where tweakRes :: Maybe (WorkflowFieldPayloadW FileReference UserId)
+                  where tweakRes :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))
                                  -> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
                                  -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))
-                        tweakRes newDat prevData = Map.fromList . zip [startKey..] <$> pure (pure newDat)
+                        tweakRes newDat prevData = Map.fromList . zip [startKey..] <$> pure (map Just $ newDat ^.. _Just . folded)
                           where startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
 
                 miCell :: ListPosition
                        -> Maybe (WorkflowFieldPayloadW FileReference UserId)
-                       -> Maybe (Maybe (WorkflowFieldPayloadW FileReference UserId))
+                       -> Maybe (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))
                        -> (Text -> Text)
-                       -> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)), Widget))
+                       -> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))), Widget))
-                miCell _pos dat mPrev'' nudge = miForm nudge . Right $ fromMaybe dat mPrev''
+                miCell _pos dat mPrev'' nudge = miForm nudge . Right $ fromMaybe (fmap (:| []) dat) mPrev''
 
                 miForm :: (Text -> Text)
-                       -> Either (FieldView UniWorX) (Maybe (WorkflowFieldPayloadW FileReference UserId))
+                       -> Either (FieldView UniWorX) (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))
-                       -> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)), Widget))
+                       -> (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 (WorkflowFieldPayloadW FileReference UserId))), Ints, Enctype)
+                  let runSpecRender :: WriterT [FieldView UniWorX] Handler (Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))), Ints, Enctype)
-                                    -> ExceptT WorkflowPayloadLabel Handler (((Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId))), [FieldView UniWorX]), 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)
+                  ((fFilled, fmRes), fvs') <- mapRWST runSpecRender . fmap (view _1) $ evalRWST (runExceptT $ renderSpecField wpfmSub) (Just $ fromMaybe id mNudge . nudge) (mode ^.. _Right . _Just . folded)
 
-                  MsgRenderer mr <- getMsgRenderer
                   let fFilled' = fFilled || isn't _FormSuccess fmRes
                       fmRes' | not fFilled' = FormFailure . pure . maybe (mr MsgValueRequired) (mr . valueRequired) $ fvs ^? _head . to fvLabel'
                              | otherwise    = fmRes
@@ -435,7 +493,7 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec
                                   p -> Maybe (SomeRoute UniWorX)
                 miButtonAction _ = Nothing
 
-                miLayout :: MassInputLayout ListLength (Maybe (WorkflowFieldPayloadW FileReference UserId)) (Maybe (WorkflowFieldPayloadW FileReference UserId))
+                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
 

src/Handler/Utils/Workflow/Form.hs

@@ -28,6 +28,8 @@ import qualified Data.List.NonEmpty as NonEmpty
 
 import qualified Data.Aeson as JSON
 
+import Utils.Workflow.Lint
+
 
 newtype FileIdent = FileIdent (CI Text)
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -125,6 +127,18 @@ validateWorkflowGraphForm = do
   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
                        )
                     => WorkflowGraph FileReference SqlBackendKey

src/Handler/Utils/Workflow/Workflow.hs

@@ -1,9 +1,16 @@
 module Handler.Utils.Workflow.Workflow
   ( ensureScope
+  , followEdge
+  , followAutomaticEdges, WorkflowAutomaticEdgeException(..)
   ) where
 
 import Import
 
+import Handler.Utils.Workflow.EdgeForm
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
 
 ensureScope :: WorkflowScope TermId SchoolId CourseId -> CryptoFileNameWorkflowWorkflow -> MaybeT DB WorkflowWorkflowId
 ensureScope wiScope cID = do
@@ -15,3 +22,60 @@ ensureScope wiScope cID = do
         & _wisCourse %~ view _SqlKey
   guard $ workflowWorkflowScope == wiScope'
   return wId
+
+followEdge :: ( MonadHandler m
+              , HandlerSite m ~ UniWorX
+              , MonadThrow m
+              )
+           => WorkflowGraph FileReference UserId -> WorkflowEdgeForm -> Maybe (WorkflowState FileReference UserId) -> m (WorkflowState FileReference UserId)
+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
+                        )
+                     => WorkflowGraph FileReference UserId
+                     -> WorkflowState FileReference UserId -> m (WorkflowState FileReference UserId)
+followAutomaticEdges WorkflowGraph{..} = go []
+  where
+    go :: [(Set WorkflowPayloadLabel, (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed
+       -> WorkflowState FileReference UserId
+       -> m (WorkflowState FileReference UserId)
+    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 = nub $ do
+          (nodeLbl, WGN{..}) <- Map.toList wgNodes
+          (edgeLbl, WorkflowGraphEdgeAutomatic{..}) <- Map.toList wgnEdges
+          guard $ wgeSource == cState
+          whenIsJust wgePayloadRestriction $ guard . checkPayloadRestriction
+          return (edgeLbl, nodeLbl)
+        checkPayloadRestriction :: PredDNF WorkflowPayloadLabel -> Bool
+        checkPayloadRestriction dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf' 
+          where
+            evalConj = maybe True (ofoldr1 (&&)) . fromNullable . map evalPred
+            evalPred PLVariable{..} = plVar `Set.member`    filledPayloads
+            evalPred PLNegated{..}  = plVar `Set.notMember` filledPayloads
+            dnf' = map (Set.toList . toNullable) . Set.toList $ dnfTerms dnf
+        filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
+        edgeDecisionInput = filledPayloads

src/Handler/Workflow/Instance/Initiate.hs

@@ -11,6 +11,7 @@ import Utils.Workflow
 import Handler.Utils
 import Handler.Utils.Workflow.EdgeForm
 import Handler.Utils.Workflow.CanonicalRoute
+import Handler.Utils.Workflow.Workflow (followEdge)
 
 import qualified Data.CaseInsensitive as CI
 import qualified Data.List.NonEmpty as NonEmpty
@@ -23,7 +24,7 @@ postGWIInitiateR win
 
 workflowInstanceInitiateR :: WorkflowInstanceId -> Handler Html
 workflowInstanceInitiateR wiId = do
-  (WorkflowInstance{..}, edgeForm, rScope, mDesc) <- runDB $ do
+  (WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), rScope, mDesc) <- runDB $ do
     wi@WorkflowInstance{..} <- get404 wiId
     edgeForm <- maybeT notFound . MaybeT $ workflowEdgeForm (Left wiId) Nothing
     rScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
@@ -37,29 +38,31 @@ workflowInstanceInitiateR wiId = do
         guard $ workflowInstanceDescriptionLanguage == lang
         return desc
 
-    return (wi, edgeForm, rScope, mDesc)
+    ((edgeRes, edgeView), edgeEnc) <- liftHandler . runFormPost $ renderAForm FormStandard edgeForm
 
-  ((edgeRes, edgeView'), edgeEnc) <- runFormPost $ renderAForm FormStandard edgeForm
+    edgeAct <- formResultMaybe edgeRes $ \edgeRes' -> do
-
+      workflowWorkflowState <- view _DBWorkflowState <$> followEdge (_DBWorkflowGraph # workflowInstanceGraph) edgeRes' Nothing
-  formResult edgeRes $ \edgeRes' -> do
+      
-    wwId <- runDB $ do
+      wwId <- insert WorkflowWorkflow
-      act <- workflowEdgeFormToAction edgeRes'
-
-      insert WorkflowWorkflow
         { workflowWorkflowInstance = Just wiId
         , workflowWorkflowScope = workflowInstanceScope
         , workflowWorkflowGraph = workflowInstanceGraph
-        , workflowWorkflowState = view _DBWorkflowState $ act `ncons` mempty
+        , workflowWorkflowState
         }
 
-    addMessageI Success MsgWorkflowInstanceInitiateSuccess
+      return . Just $ do
-    
+        addMessageI Success MsgWorkflowInstanceInitiateSuccess
-    cID <- encrypt wwId
+
-    redirectAlternatives $ NonEmpty.fromList
+        cID <- encrypt wwId
-      [ _WorkflowScopeRoute # ( rScope, WorkflowWorkflowR cID WWWorkflowR )
+        redirectAlternatives $ NonEmpty.fromList
-      , _WorkflowScopeRoute # ( rScope, WorkflowInstanceR workflowInstanceName WIWorkflowsR )
+          [ _WorkflowScopeRoute # ( rScope, WorkflowWorkflowR cID WWWorkflowR )
-      , _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
+          , _WorkflowScopeRoute # ( rScope, WorkflowInstanceR workflowInstanceName WIWorkflowsR )
-      ]
+          , _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
+          ]
+
+    return (wi, ((edgeAct, edgeView), edgeEnc), rScope, mDesc)
+
+  sequence_ edgeAct
 
   (heading, title) <- case rScope of
     WSGlobal -> return (MsgGlobalWorkflowInstanceInitiateHeading $ maybe (CI.original workflowInstanceName) workflowInstanceDescriptionTitle mDesc, MsgGlobalWorkflowInstanceInitiateTitle)
@@ -67,7 +70,12 @@ workflowInstanceInitiateR wiId = do
 
   siteLayoutMsg heading $ do
     setTitleI title
-    let edgeView = wrapForm edgeView' def
+    let edgeView = wrapForm edgeView' FormSettings
-          { formEncoding = edgeEnc
+          { 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/Workflow/Workflow.hs

@@ -1,12 +1,55 @@
 module Handler.Workflow.Workflow.Workflow
   ( getGWWWorkflowR, postGWWWorkflowR
+  , getGWWFilesR
   , workflowR
   ) where
 
 import Import
 
+import Utils.Form
+import Utils.Workflow
+
+import Handler.Utils
+import Handler.Utils.Workflow.EdgeForm
+import Handler.Utils.Workflow.CanonicalRoute
 import Handler.Utils.Workflow.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, execRWST)
+
+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 Data.List (inits)
+
+import qualified Data.Scientific as Scientific
+import Text.Blaze (toMarkup)
+import Data.Void (absurd)
+
+
+data WorkflowHistoryItemActor = WHIASelf | WHIAOther (Maybe (Entity User)) | WHIAHidden | WHIAGone
+  deriving (Generic, Typeable)
+  
+data WorkflowHistoryItem = WorkflowHistoryItem
+  { whiUser :: Maybe WorkflowHistoryItemActor
+  , whiTime :: UTCTime
+  , whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))]
+  , whiFrom :: Maybe (Maybe Text) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
+  , whiVia :: Maybe Text
+  , whiTo :: Text
+  } deriving (Generic, Typeable)
+
+makePrisms ''WorkflowHistoryItemActor
+
 
 getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
 getGWWWorkflowR = postGWWWorkflowR
@@ -16,4 +59,177 @@ postGWWWorkflowR cID = do
   workflowR wId
 
 workflowR :: WorkflowWorkflowId -> Handler Html
-workflowR = error "not implemented"
+workflowR wwId = do
+  cID <- encrypt wwId
+  
+  (mEdge, rScope, workflowHistory) <- runDB $ do
+    WorkflowWorkflow{..} <- get404 wwId
+    rScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
+    mEdgeForm <- workflowEdgeForm (Right wwId) Nothing
+    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 (_DBWorkflowGraph # workflowWorkflowGraph) edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState
+
+        update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]
+
+        return . Just $ do
+          addMessageI Success MsgWorkflowWorkflowWorkflowEdgeSuccess
+
+          redirect canonRoute
+      return ((edgeAct, edgeView), edgeEnc)
+
+    workflowHistory <-
+      let go :: forall m.
+                ( MonadHandler m
+                , HandlerSite m ~ UniWorX
+                , MonadThrow m
+                )
+             => WorkflowStateIndex
+             -> Maybe WorkflowGraphNodeLabel
+             -> Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))
+             -> WorkflowAction FileReference UserId
+             -> RWST () [WorkflowHistoryItem] (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) ()
+          go stIx wpFrom currentPayload WorkflowAction{..} = maybeT (return ()) $ do
+            stCID <- encrypt stIx
+            let nodeView nodeLbl = do
+                  WorkflowNodeView{..} <- hoistMaybe $ Map.lookup nodeLbl wgNodes >>= wgnViewers
+                  guardM $ anyM (otoList wnvViewers) hasWorkflowRole'
+                  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 <- nodeView wpTo
+            whiVia <- traverse selectLanguageI18n $ preview _wgeDisplayLabel =<< mVia
+            
+            payloadChanges <- State.state $ \oldPayload ->
+              ( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload
+              , currentPayload
+              )
+            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)
+            whiPayloadChanges' <- fmap (map (view _2) . sortBy payloadLabelSort) . forMaybeM (Map.toList payloadChanges) $ \(payloadLbl, newPayload) -> do
+              WorkflowPayloadView{..} <- hoistMaybe $ Map.lookup payloadLbl wgPayloadView
+              guardM . 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 (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of
+                (WFPText a',   WFPText b'  ) -> compareUnicode a' b'
+                (WFPText{},    _           ) -> LT
+                (WFPNumber a', WFPNumber b') -> compare a' b'
+                (WFPNumber{},  WFPText{}   ) -> GT
+                (WFPNumber{},  _           ) -> LT
+                (WFPBool a',   WFPBool b'  ) -> compare a' b'
+                (WFPBool{},    WFPText{}   ) -> GT
+                (WFPBool{},    WFPNumber{} ) -> GT
+                (WFPBool{},    _           ) -> LT
+                (WFPDay a',    WFPDay b'   ) -> compare a' b'
+                (WFPDay{},     WFPText{}   ) -> GT
+                (WFPDay{},     WFPNumber{} ) -> GT
+                (WFPDay{},     WFPBool{}   ) -> GT
+                (WFPDay{},     _           ) -> LT
+                (WFPFile a',   _           ) -> absurd a'
+                (WFPUser a',   WFPUser 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
+                (WFPUser{},    _           ) -> GT
+            whiPayloadChanges <- flip mapM whiPayloadChanges' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort) . over _2 (bool Nothing (Just fRoute). getAny)) . execWriterT . flip mapM_ 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 (WFPFile   _  ) -> tell (mempty, Any True)
+              WorkflowFieldPayloadW (WFPUser   uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
+
+            whiFrom <- for wpFrom $ lift . runMaybeT . nodeView
+
+            mAuthId <- maybeAuthId
+            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
+            tell $ pure WorkflowHistoryItem{..}
+          WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph
+          wState = otoList $ review _DBWorkflowState workflowWorkflowState
+       in fmap (view _2) . (\act -> execRWST act () Map.empty) $ sequence_
+            [ go stIx fromSt payload act
+            | fromSt <- Nothing : map (Just . wpTo) wState 
+            | act <- wState
+            | payload <- map (maybe Map.empty workflowStateCurrentPayloads . fromNullable . Seq.fromList) . tailEx $ inits wState
+            | stIx <- [minBound..]
+            ]
+    return (mEdge, rScope, workflowHistory)
+
+  sequenceOf_ (_Just . _1 . _1 . _Just) mEdge
+
+  (heading, title) <- case rScope of
+    WSGlobal -> return (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
+    _other -> error "not implemented"
+
+  siteLayoutMsg heading $ 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 (WFPUser   mUserEnt) -> case mUserEnt of
+            Nothing                  -> i18n MsgWorkflowPayloadUserGone
+            Just (Entity _ User{..}) -> nameWidget userDisplayName userSurname
+          WorkflowFieldPayloadW (WFPFile   v       ) -> absurd v
+    $(widgetFile "workflows/workflow")
+
+
+getGWWFilesR :: CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
+getGWWFilesR wwCID wpl stCID = do
+  fRefs <- runDB $ do
+    wwId <- decrypt wwCID
+    WorkflowWorkflow{..} <- get404 wwId
+    stIx <- decrypt stCID
+    payloads <- maybeT notFound . workflowStateSection stIx $ _DBWorkflowState # workflowWorkflowState
+    payloads' <- maybe notFound return . Map.lookup wpl $ workflowStateCurrentPayloads 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

@@ -76,7 +76,7 @@ workflowFileReferences :: MonadResource m => ConduitT () FileContentReference (S
 workflowFileReferences = mconcat [ E.selectSource (E.from $ pure . (E.^. WorkflowDefinitionGraph)) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
                                  , E.selectSource (E.from $ pure . (E.^. WorkflowInstanceGraph  )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
                                  , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowGraph  )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
-                                 , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState  )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . folded @Set . _fileReferenceContent . _Just) yield . E.unValue)
+                                 , E.selectSource (E.from $ pure . (E.^. WorkflowWorkflowState  )) .| awaitForever (mapMOf_ (typesCustom @WorkflowChildren . _fileReferenceContent . _Just) yield . E.unValue)
                                  ]
 
 

src/Model/Migration.hs

@@ -988,6 +988,11 @@ customMigrations = Map.fromListWith (>>)
   , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|]
     , return () -- Unused; used to create and fill `ChangelogItemFirstSeen`
     )
+  , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|]
+    , whenM (tableExists "school") $ do
+        schools <- [sqlQQ| SELECT "shorthand", "exam_discouraged_modes" FROM "school"; |]
+        forM_ schools $ \(sid, Single edModes) -> update sid [SchoolExamDiscouragedModes =. Legacy.examModeDNF edModes]
+    )
   ]
 
 

src/Model/Migration/Types.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Model.Migration.Types where
 
 import ClassyPrelude.Yesod
 import Data.Aeson
-import Data.Aeson.TH (deriveJSON)
+import Data.Aeson.TH (deriveJSON, mkParseJSON)
 
 import Utils.PathPiece
 
@@ -12,6 +14,8 @@ import qualified Model.Types.TH.JSON as Current
 import Data.Universe
 import Data.Universe.TH
 
+import qualified Data.Set as Set
+
 
 data SheetType
   = Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben
@@ -84,3 +88,31 @@ deriveJSON defaultOptions
   } ''Transaction
 
 Current.derivePersistFieldJSON ''Transaction
+
+
+
+data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
+  deriving (Eq, Ord)
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = TaggedObject "val" "var"
+  } ''PredLiteral
+  
+newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
+
+$(return [])
+
+instance ToJSON (PredDNF a) where
+  toJSON = error "toJSON @(Legacy.PredDNF _): not implemented"
+instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
+  parseJSON = $(mkParseJSON defaultOptions{ tagSingleConstructors = True, sumEncoding = ObjectWithSingleField } ''PredDNF)
+
+newtype ExamModeDNF = ExamModeDNF (PredDNF Current.ExamModePredicate)
+  deriving newtype (ToJSON, FromJSON)
+
+Current.derivePersistFieldJSON ''ExamModeDNF
+
+examModeDNF :: ExamModeDNF -> Current.ExamModeDNF
+examModeDNF (ExamModeDNF PredDNF{..}) = Current.ExamModeDNF . Current.PredDNF $ Set.map (impureNonNull . Set.map toCurrentPredLiteral . toNullable) dnfTerms
+  where toCurrentPredLiteral PLVariable{..} = Current.PLVariable plVar
+        toCurrentPredLiteral PLNegated{..} = Current.PLNegated plVar

src/Model/Types/Security.hs

@@ -163,7 +163,7 @@ makePrisms ''PredLiteral
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1
   , fieldLabelModifier = camelToPathPiece' 1
-  , sumEncoding = TaggedObject "val" "var"
+  , sumEncoding = TaggedObject "tag" "variable"
   } ''PredLiteral
 
 instance PathPiece a => PathPiece (PredLiteral a) where

src/Model/Types/TH/JSON.hs

@@ -68,7 +68,7 @@ predNFAesonOptions = defaultOptions
   }
   
 
-workflowGraphAesonOptions, workflowGraphEdgeAesonOptions, workflowGraphNodeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions :: Options
+workflowGraphAesonOptions, workflowGraphEdgeAesonOptions, workflowGraphNodeAesonOptions, workflowActionAesonOptions, workflowPayloadViewAesonOptions, workflowNodeViewAesonOptions :: Options
 workflowGraphAesonOptions = defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
   }
@@ -86,3 +86,6 @@ workflowActionAesonOptions = defaultOptions
 workflowPayloadViewAesonOptions = defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
   }
+workflowNodeViewAesonOptions = defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  }

src/Model/Types/Workflow.hs

@@ -4,6 +4,7 @@ module Model.Types.Workflow
   ( WorkflowGraph(..)
   , WorkflowGraphNodeLabel
   , WorkflowGraphNode(..)
+  , WorkflowNodeView(..)
   , WorkflowGraphEdgeLabel
   , WorkflowGraphEdge(..)
   , WorkflowGraphEdgeFormOrder
@@ -15,10 +16,11 @@ module Model.Types.Workflow
   , WorkflowPayloadField(..)
   , WorkflowScope(..)
   , WorkflowScope'(..), classifyWorkflowScope
-  , WorkflowPayloadLabel
+  , WorkflowPayloadLabel(..)
+  , WorkflowStateIndex(..), workflowStateIndex, workflowStateSection
   , WorkflowState
   , WorkflowAction(..), _wpTo, _wpVia, _wpPayload, _wpUser, _wpTime
-  , WorkflowFieldPayloadW(..), _WorkflowFieldPayloadW, IsWorkflowFieldPayload
+  , WorkflowFieldPayloadW(..), _WorkflowFieldPayloadW, IsWorkflowFieldPayload', IsWorkflowFieldPayload
   , WorkflowFieldPayload(..), _WorkflowFieldPayload
   , workflowStatePayload, workflowStateCurrentPayloads
   , WorkflowChildren
@@ -26,7 +28,7 @@ module Model.Types.Workflow
 
 import Import.NoModel
 
-import Model.Types.Security (AuthDNF)
+import Model.Types.Security (AuthDNF, PredDNF)
 import Model.Types.File (FileContentReference, FileFieldUserOption, FileField, _fieldAdditionalFiles, FileReferenceTitleMapConvertible(..))
 
 import Database.Persist.Sql (PersistFieldSql(..))
@@ -74,9 +76,8 @@ newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLab
   deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary)
 
 data WorkflowGraphNode fileid userid = WGN
-  { wgnDisplayLabel :: Maybe I18nText
+  { wgnFinal        :: Bool
-  , wgnFinal        :: Bool
+  , wgnViewers      :: Maybe (WorkflowNodeView userid)
-  , wgnViewers      :: Set (WorkflowRole userid)
   , wgnEdges        :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid)
   }
   deriving (Generic, Typeable)
@@ -85,6 +86,10 @@ deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (F
 deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphNode fileid userid)
 deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphNode fileid userid)
 
+data WorkflowNodeView userid = WorkflowNodeView
+  { wnvViewers :: NonNull (Set (WorkflowRole userid))
+  , wnvDisplayLabel :: I18nText
+  } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
 
 -----  WORKFLOW GRAPH: EDGES  -----
 
@@ -98,14 +103,17 @@ data WorkflowGraphEdge fileid userid
     , wgeActors       :: Set (WorkflowRole userid)
     , wgeForm         :: WorkflowGraphEdgeForm fileid userid
     , wgeDisplayLabel :: I18nText
+    , wgeViewActor    :: Set (WorkflowRole userid)
     }
   | WorkflowGraphEdgeAutomatic
-    { wgeSource       :: WorkflowGraphNodeLabel
+    { wgeSource             :: WorkflowGraphNodeLabel
+    , wgePayloadRestriction :: Maybe (PredDNF WorkflowPayloadLabel)
     }
   | WorkflowGraphEdgeInitial
     { wgeActors       :: Set (WorkflowRole userid)
     , wgeForm         :: WorkflowGraphEdgeForm fileid userid
     , wgeDisplayLabel :: I18nText
+    , wgeViewActor    :: Set (WorkflowRole userid)
     }
   deriving (Generic, Typeable)
 
@@ -167,6 +175,7 @@ data WorkflowPayloadField fileid userid (payload :: Type) where
                                    , wpftPlaceholder :: Maybe I18nText
                                    , wpftTooltip     :: Maybe I18nHtml
                                    , wpftDefault     :: Maybe Text
+                                   , wpftLarge       :: Bool
                                    , wpftOptional    :: Bool
                                    } -> WorkflowPayloadField fileid userid Text
   WorkflowPayloadFieldNumber    :: { wpfnLabel       :: I18nText
@@ -183,6 +192,11 @@ data WorkflowPayloadField fileid userid (payload :: Type) where
                                    , wpfbDefault     :: Maybe Bool
                                    , wpfbOptional    :: Maybe I18nText -- ^ Optional if `Just`; encodes label of `Nothing`-Option
                                    } -> WorkflowPayloadField fileid userid Bool
+  WorkflowPayloadFieldDay       :: { wpfdLabel       :: I18nText
+                                   , wpfdTooltip     :: Maybe I18nHtml
+                                   , wpfdDefault     :: Maybe Day
+                                   , wpfdOptional    :: Bool
+                                   } -> WorkflowPayloadField fileid userid Day
   WorkflowPayloadFieldFile      :: { wpffLabel       :: I18nText
                                    , wpffTooltip     :: Maybe I18nHtml
                                    , wpffConfig      :: FileField fileid
@@ -226,24 +240,32 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileFie
           (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldText{}) -> GT
           (WorkflowPayloadFieldBool{}, WorkflowPayloadFieldNumber{}) -> GT
           (WorkflowPayloadFieldBool{}, _) -> LT
+          (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldText{}) -> GT
+          (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldNumber{}) -> GT
+          (WorkflowPayloadFieldDay{}, WorkflowPayloadFieldBool{}) -> GT
+          (WorkflowPayloadFieldDay{}, _) -> LT
           (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldText{}) -> GT
           (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldNumber{}) -> GT
           (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldBool{}) -> GT
+          (WorkflowPayloadFieldFile{}, WorkflowPayloadFieldDay{}) -> GT
           (WorkflowPayloadFieldFile{}, _) -> LT
           (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldText{}) -> GT
           (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldNumber{}) -> GT
           (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldBool{}) -> GT
+          (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldDay{}) -> GT
           (WorkflowPayloadFieldUser{}, WorkflowPayloadFieldFile{}) -> GT
           (WorkflowPayloadFieldUser{}, _) -> LT
           (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldText{}) -> GT
           (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldNumber{}) -> GT
           (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldBool{}) -> GT
+          (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldDay{}) -> GT
           (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldFile{}) -> GT
           (WorkflowPayloadFieldCaptureUser{}, WorkflowPayloadFieldUser{}) -> GT
           (WorkflowPayloadFieldCaptureUser{}, _) -> LT
           (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldText{}) -> GT
           (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldNumber{}) -> GT
           (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldBool{}) -> GT
+          (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldDay{}) -> GT
           (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldFile{}) -> GT
           (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldUser{}) -> GT
           (WorkflowPayloadFieldReference{}, WorkflowPayloadFieldCaptureUser{}) -> GT
@@ -255,7 +277,7 @@ _WorkflowPayloadSpec :: forall payload fileid userid.
                      => Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload)
 _WorkflowPayloadSpec = prism' WorkflowPayloadSpec $ \(WorkflowPayloadSpec pF) -> cast pF
   
-data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple'
+data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple'
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
@@ -289,8 +311,24 @@ newtype WorkflowPayloadLabel = WorkflowPayloadLabel { unWorkflowPayloadLabel ::
   deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
   deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary)
 
+newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 }
+  deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
+  deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary)
+
 type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid))
 
+workflowStateIndex :: Alternative m
+                   => WorkflowStateIndex
+                   -> WorkflowState fileid userid
+                   -> m (WorkflowAction fileid userid)
+workflowStateIndex (fromIntegral -> i) = maybe empty pure . flip index i . toNullable
+
+workflowStateSection :: MonadPlus m
+                     => WorkflowStateIndex
+                     -> WorkflowState fileid userid
+                     -> m (WorkflowState fileid userid)
+workflowStateSection i wSt = maybe mzero return . fromNullable . Seq.fromList =<< sequenceA (map (flip workflowStateIndex wSt) [0..i])
+
 data WorkflowAction fileid userid = WorkflowAction
   { wpTo      :: WorkflowGraphNodeLabel
   , wpVia     :: WorkflowGraphEdgeLabel
@@ -300,7 +338,7 @@ data WorkflowAction fileid userid = WorkflowAction
   }
   deriving (Eq, Ord, Show, Generic, Typeable)
 
-data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload)
+data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload)
   deriving (Typeable)
 
 instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where
@@ -320,16 +358,16 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work
           (WFPBool{}, WFPText{}) -> GT
           (WFPBool{}, WFPNumber{}) -> GT
           (WFPBool{}, _) -> LT
-          (WFPFiles{}, WFPText{}) -> GT
+          (WFPDay{}, WFPText{}) -> GT
-          (WFPFiles{}, WFPNumber{}) -> GT
+          (WFPDay{}, WFPNumber{}) -> GT
-          (WFPFiles{}, WFPBool{}) -> GT
+          (WFPDay{}, WFPDay{}) -> GT
-          (WFPFiles{}, _) -> LT
+          (WFPDay{}, _) -> LT
-          (WFPUser{}, WFPText{}) -> GT
+          (WFPFile{}, WFPText{}) -> GT
-          (WFPUser{}, WFPNumber{}) -> GT
+          (WFPFile{}, WFPNumber{}) -> GT
-          (WFPUser{}, WFPBool{}) -> GT
+          (WFPFile{}, WFPBool{}) -> GT
-          (WFPUser{}, WFPFiles{}) -> GT
+          (WFPFile{}, WFPDay{}) -> GT
-          (WFPUser{}, _) -> LT
+          (WFPFile{}, _) -> LT
-          (WFPMultiple{}, _) -> GT
+          (WFPUser{}, _) -> GT
 
 instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where
   show (WorkflowFieldPayloadW payload) = show payload
@@ -338,9 +376,9 @@ data WorkflowFieldPayload fileid userid (payload :: Type) where
   WFPText     :: Text       -> WorkflowFieldPayload fileid userid Text
   WFPNumber   :: Scientific -> WorkflowFieldPayload fileid userid Scientific
   WFPBool     :: Bool       -> WorkflowFieldPayload fileid userid Bool
-  WFPFiles    :: Set fileid -> WorkflowFieldPayload fileid userid (Set fileid)
+  WFPDay      :: Day        -> WorkflowFieldPayload fileid userid Day
+  WFPFile     :: fileid     -> WorkflowFieldPayload fileid userid fileid
   WFPUser     :: userid     -> WorkflowFieldPayload fileid userid userid
-  WFPMultiple :: NonEmpty (WorkflowFieldPayloadW fileid userid) -> WorkflowFieldPayload fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid))
   deriving (Typeable)
 
 deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload fileid userid payload)
@@ -348,44 +386,49 @@ deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid) => Eq
 deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload)
 
 _WorkflowFieldPayloadW :: forall payload fileid userid.
-                          ( IsWorkflowFieldPayload fileid userid payload, Typeable fileid, Typeable userid )
+                          ( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid )
                        => Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload)
 _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW fp) -> cast fp
 
-data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPFiles' | WFPUser' | WFPMultiple'
+data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser'
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
-class Typeable payload => IsWorkflowFieldPayload fileid userid payload where
+type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload
-  _WorkflowFieldPayload :: Prism' (WorkflowFieldPayload fileid userid payload) payload
 
-instance IsWorkflowFieldPayload fileid userid Text where
+class Typeable payload => IsWorkflowFieldPayload fileid fileid' userid userid' payload payload' where
+  _WorkflowFieldPayload :: Prism (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload'
+
+instance IsWorkflowFieldPayload fileid fileid userid userid Text Text where
   _WorkflowFieldPayload = prism' WFPText $ \case { WFPText x -> Just x; _other -> Nothing }
-instance IsWorkflowFieldPayload fileid userid Scientific where
+instance IsWorkflowFieldPayload fileid fileid userid userid Scientific Scientific where
   _WorkflowFieldPayload = prism' WFPNumber $ \case { WFPNumber x -> Just x; _other -> Nothing }
-instance IsWorkflowFieldPayload fileid userid Bool where
+instance IsWorkflowFieldPayload fileid fileid userid userid Bool Bool where
   _WorkflowFieldPayload = prism' WFPBool $ \case { WFPBool x -> Just x; _other -> Nothing }
-instance {-# OVERLAPPING #-} Typeable fileid => IsWorkflowFieldPayload fileid userid (Set fileid) where
+instance IsWorkflowFieldPayload fileid fileid userid userid Day Day where
-  _WorkflowFieldPayload = prism' WFPFiles $ \case { WFPFiles x -> Just x; _other -> Nothing }
+  _WorkflowFieldPayload = prism' WFPDay $ \case { WFPDay x -> Just x; _other -> Nothing }
-instance {-# OVERLAPPING #-} Typeable userid => IsWorkflowFieldPayload fileid userid userid where
+instance Typeable fileid => IsWorkflowFieldPayload fileid fileid' userid userid fileid fileid' where
-  _WorkflowFieldPayload = prism' WFPUser $ \case { WFPUser x -> Just x; _other -> Nothing }
+  _WorkflowFieldPayload = prism WFPFile $ \case { WFPFile x -> Right x; other -> Left $ unsafeCoerce other }
-instance (Typeable fileid, Typeable userid) => IsWorkflowFieldPayload fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid)) where
+instance Typeable userid => IsWorkflowFieldPayload fileid fileid userid userid' userid userid' where
-  _WorkflowFieldPayload = iso (\(WFPMultiple x) -> x) WFPMultiple
+  _WorkflowFieldPayload = prism WFPUser $ \case { WFPUser x -> Right x; other -> Left $ unsafeCoerce other }
 
-workflowStatePayload :: forall fileid userid payload.
+-- workflowStatePayload :: forall fileid userid payload.
-                        ( IsWorkflowFieldPayload fileid userid payload
+--                         ( IsWorkflowFieldPayload' fileid userid payload
-                        , Ord fileid, Ord userid, Ord payload
+--                         , Ord fileid, Ord userid, Ord payload
-                        , Typeable fileid, Typeable userid
+--                         , Typeable fileid, Typeable userid
-                        )
+--                         , Show userid, Show fileid
-                     => WorkflowPayloadLabel -> WorkflowState fileid userid -> Seq (Set payload)
+--                         )
-workflowStatePayload label acts = flip ofoldMap acts $ \WorkflowAction{..} -> Seq.singleton . Map.findWithDefault Set.empty label $ fmap (Set.fromList . concatMap extractPayload . otoList) wpPayload
+--                      => WorkflowPayloadLabel -> WorkflowState fileid userid -> Seq (Maybe (Set payload))
-  where extractPayload (WorkflowFieldPayloadW fieldPayload)
+-- workflowStatePayload label acts = flip ofoldMap acts $ \WorkflowAction{..} -> Seq.singleton . Map.lookup label $ fmap (Set.fromList . concatMap extractPayload . otoList) wpPayload
-          | Just HRefl <- typeOf fieldPayload `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload)
+--   where
-          = fieldPayload ^.. _WorkflowFieldPayload
+--     extractPayload :: WorkflowFieldPayloadW fileid userid -> [payload]
-          | Just HRefl <- typeOf fieldPayload `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid (NonEmpty (WorkflowFieldPayloadW fileid userid)))
+--     extractPayload = \case
-          = concatMap extractPayload . maybe mempty otoList $ fieldPayload ^? _WorkflowFieldPayload 
+--       WorkflowFieldPayloadW fieldPayload@(WFPMultiple ps) -> traceShow ("multiple", fieldPayload) . concatMap extractPayload $ otoList ps
-          | otherwise
+--       WorkflowFieldPayloadW fieldPayload
-          = mempty
+--         | Just HRefl <- traceShow ("single", fieldPayload) $ typeOf fieldPayload `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload)
+--           -> fieldPayload ^.. _WorkflowFieldPayload
+--         | otherwise
+--           -> traceShow ("none", fieldPayload) mempty
 
 workflowStateCurrentPayloads :: forall fileid userid.
                                 WorkflowState fileid userid
@@ -420,6 +463,7 @@ type family ChildrenWorkflowChildren a where
   ChildrenWorkflowChildren (Key record) = '[]
   ChildrenWorkflowChildren FileContentReference = '[]
   ChildrenWorkflowChildren UTCTime = '[]
+  ChildrenWorkflowChildren Day = '[]
   ChildrenWorkflowChildren (WorkflowPayloadSpec fileid userid)
            = ChildrenWorkflowChildren I18nText
     `Concat` ChildrenWorkflowChildren (Maybe I18nText)
@@ -427,6 +471,7 @@ type family ChildrenWorkflowChildren a where
     `Concat` ChildrenWorkflowChildren (Maybe Text)
     `Concat` ChildrenWorkflowChildren (Maybe Scientific)
     `Concat` ChildrenWorkflowChildren (Maybe Bool)
+    `Concat` ChildrenWorkflowChildren (Maybe Day)
     `Concat` ChildrenWorkflowChildren (Maybe fileid)
     `Concat` ChildrenWorkflowChildren (Maybe userid)
     `Concat` ChildrenWorkflowChildren Bool
@@ -435,6 +480,7 @@ type family ChildrenWorkflowChildren a where
            = ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Text)
     `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Scientific)
     `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Bool)
+    `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid Day)
     `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid fileid)
     `Concat` ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid userid)
   ChildrenWorkflowChildren (WorkflowFieldPayload fileid userid payload)
@@ -469,6 +515,7 @@ instance (Typeable userid, Typeable fileid, Typeable fileid', Ord fileid', useri
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
+  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldDay{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..}
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}
@@ -481,39 +528,49 @@ instance (Typeable userid, Typeable userid', Typeable fileid, fileid ~ fileid')
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
+  typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldDay{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..}
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldCaptureUser
   typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..}
 
-instance (Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload fileid userid payload, IsWorkflowFieldPayload fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') payload payload' where
+instance (Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') payload payload' where
   typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid payload) of
     Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid payload) @(WorkflowFieldPayload fileid' userid' payload') @payload @payload' f p
     Nothing    -> pure pw
   
-instance {-# OVERLAPPING #-} (Typeable fileid, Typeable userid, IsWorkflowFieldPayload fileid userid userid, IsWorkflowFieldPayload fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') userid userid' where
+instance {-# OVERLAPPING #-} (Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid userid, IsWorkflowFieldPayload' fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') userid userid' where
   typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid userid) of
     Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid userid) @(WorkflowFieldPayload fileid' userid' userid') @userid @userid' f p
     Nothing    -> pure $ unsafeCoerce @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid userid') pw -- We have proof that @p@ does not contain a value of type @userid@, therefor coercion is safe
 
-instance {-# OVERLAPPING #-} (Typeable userid, Typeable fileid, Ord fileid', IsWorkflowFieldPayload fileid userid (Set fileid), IsWorkflowFieldPayload fileid' userid' (Set fileid'), userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') fileid fileid' where
+instance {-# OVERLAPPING #-} (Typeable userid, Typeable fileid, IsWorkflowFieldPayload' fileid userid fileid, IsWorkflowFieldPayload' fileid' userid' fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid' userid') fileid fileid' where
-  typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid (Set fileid)) of
+  typesCustom f pw@(WorkflowFieldPayloadW p) = case typeOf p `eqTypeRep` typeRep @(WorkflowFieldPayload fileid userid fileid) of
-    Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid (Set fileid)) @(WorkflowFieldPayload fileid' userid' (Set fileid')) @(Set fileid) @(Set fileid') (traverseOf (iso Set.toList Set.fromList . traverse) f) p
+    Just HRefl -> WorkflowFieldPayloadW <$> typesCustom @WorkflowChildren @(WorkflowFieldPayload fileid userid fileid) @(WorkflowFieldPayload fileid' userid' fileid') @fileid @fileid' f p
     Nothing    -> pure $ unsafeCoerce @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid' userid) pw -- We have proof that @p@ does not contain a value of type @fileid@, therefor coercion is safe
 
-instance (IsWorkflowFieldPayload fileid userid payload, IsWorkflowFieldPayload fileid' userid' payload') => HasTypesCustom WorkflowChildren (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload' where
+instance (IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload') => HasTypesCustom WorkflowChildren (WorkflowFieldPayload fileid userid payload) (WorkflowFieldPayload fileid' userid' payload') payload payload' where
   typesCustom f x = case x ^? _WorkflowFieldPayload of
     Just x' -> review _WorkflowFieldPayload <$> f x'
     Nothing -> error "@WorkflowFieldPayload fileid userid payload@ does not contain value of type @payload@; this means `IsWorkflowFieldPayload` is invalid"
 
-instance (Ord userid, Ord fileid, Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload fileid userid payload, IsWorkflowFieldPayload fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') payload payload' where
+instance (Ord userid, Ord fileid, Typeable payload, Typeable fileid, Typeable userid, IsWorkflowFieldPayload' fileid userid payload, IsWorkflowFieldPayload' fileid' userid' payload', fileid ~ fileid', userid ~ userid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') payload payload' where
   typesCustom = _wpPayload . typesCustom @WorkflowChildren
   
-instance {-# OVERLAPPING #-} (Ord userid', Ord fileid, Typeable fileid, IsWorkflowFieldPayload fileid userid userid, IsWorkflowFieldPayload fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') userid userid' where
+instance {-# OVERLAPPING #-} (Ord userid', Ord fileid, Typeable fileid, IsWorkflowFieldPayload' fileid userid userid, IsWorkflowFieldPayload' fileid' userid' userid', fileid ~ fileid') => HasTypesCustom WorkflowChildren (WorkflowAction fileid userid) (WorkflowAction fileid' userid') userid userid' where
   typesCustom f WorkflowAction{..} = WorkflowAction wpTo wpVia
     <$> traverseOf (typesCustom @WorkflowChildren @_ @_ @userid @userid') f wpPayload
     <*> traverseOf (_Just . _Just) f wpUser
     <*> pure wpTime
 
+
+workflowStatePayload :: forall fileid userid payload.
+                        ( HasTypesCustom WorkflowChildren (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayloadW fileid userid) payload payload
+                        , Ord payload
+                        )
+                     => WorkflowPayloadLabel -> WorkflowState fileid userid -> Seq (Maybe (Set payload))
+workflowStatePayload label acts = flip ofoldMap acts $ \WorkflowAction{..} -> Seq.singleton . Map.lookup label $ fmap (setOf $ folded . typesCustom @WorkflowChildren @(WorkflowFieldPayloadW fileid userid) @(WorkflowFieldPayloadW fileid userid) @payload @payload) wpPayload
+
+
 ----- PathPiece instances -----
 
 nullaryPathPiece ''WorkflowScope' $ camelToPathPiece' 1 . fromJust . stripSuffix "'"
@@ -528,15 +585,19 @@ derivePathPiece ''WorkflowScope (camelToPathPiece' 1) "--"
 omitNothing :: [JSON.Pair] -> [JSON.Pair]
 omitNothing = filter . hasn't $ _2 . _Null
 
+  
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 2
   , constructorTagModifier = camelToPathPiece' 2
   } ''WorkflowRole
 
+deriveToJSON workflowNodeViewAesonOptions ''WorkflowNodeView
 deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView
 pathPieceJSON ''WorkflowFieldPayload'
 pathPieceJSON ''WorkflowPayloadField'
 
+instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeView userid) where
+  parseJSON = genericParseJSON workflowNodeViewAesonOptions
 instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where
   parseJSON = genericParseJSON workflowPayloadViewAesonOptions
 
@@ -567,7 +628,8 @@ instance ToJSON WorkflowGraphEdgeFormOrder where
 instance FromJSON WorkflowGraphEdgeFormOrder where
   parseJSON v = fmap WorkflowGraphEdgeFormOrder $ asum
     [ Just <$> parseJSON v
-    , JSON.withText "WorkflowGraphEdgeFormOrder" (bool (fail "WorkflowGraphEdgeFormOrder: unexpected String, expecting either number or \"_\"") (pure Nothing) . (== "_")) v
+    , flip (JSON.withText "WorkflowGraphEdgeFormOrder") v $ \t -> maybe (fail "WorkflowGraphEdgeFormOrder: could not parse String as Number") (return . Just) $ readMay t
+    , flip (JSON.withText "WorkflowGraphEdgeFormOrder") v $ bool (fail "WorkflowGraphEdgeFormOrder: unexpected String, expecting either number or \"_\"") (pure Nothing) . (== "_")
     ]
 
 instance ToJSONKey WorkflowGraphEdgeFormOrder where
@@ -575,9 +637,7 @@ instance ToJSONKey WorkflowGraphEdgeFormOrder where
     where toText' = decodeUtf8 . toStrict . JSON.encodingToLazyByteString . JSON.scientific
           toEncoding' = JSON.scientificText
 instance FromJSONKey WorkflowGraphEdgeFormOrder where
-  fromJSONKey = JSON.FromJSONKeyTextParser $ \t -> if
+  fromJSONKey = JSON.FromJSONKeyTextParser $ parseJSON . JSON.String
-    | t == "_"  -> pure $ WorkflowGraphEdgeFormOrder Nothing
-    | otherwise -> WorkflowGraphEdgeFormOrder . Just <$> parseJSON (JSON.String t)
 
 instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (WorkflowGraphEdgeForm fileid userid) where
   toJSON WorkflowGraphEdgeForm{..} = toJSON . flip map wgefFields $ \(toNullable -> disj) -> flip Set.map disj $ \(toNullable -> orderedFields) -> if
@@ -608,6 +668,7 @@ instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (Wo
     , "placeholder" JSON..=  wpftPlaceholder
     , "tooltip"     JSON..=  wpftTooltip
     , "default"     JSON..=  wpftDefault
+    , "large"       JSON..=  wpftLarge
     , "optional"    JSON..=  wpftOptional
     ]
   toJSON (WorkflowPayloadFieldNumber{..}) = JSON.object $ omitNothing
@@ -628,6 +689,13 @@ instance (ToJSON fileid, ToJSON userid, ToJSON (FileField fileid)) => ToJSON (Wo
     , "default"     JSON..=  wpfbDefault
     , "optional"    JSON..=  wpfbOptional
     ]
+  toJSON (WorkflowPayloadFieldDay{..}) = JSON.object $ omitNothing
+    [ "tag"         JSON..=  WPFDay'
+    , "label"       JSON..=  wpfdLabel
+    , "tooltip"     JSON..=  wpfdTooltip
+    , "default"     JSON..=  wpfdDefault
+    , "optional"    JSON..=  wpfdOptional
+    ]
   toJSON (WorkflowPayloadFieldFile{..}) = JSON.object $ omitNothing
     [ "tag"         JSON..=  WPFFile'
     , "label"       JSON..=  wpffLabel
@@ -672,6 +740,7 @@ instance ( FromJSON fileid, FromJSON userid
         wpftPlaceholder <-  o JSON..:? "placeholder"
         wpftTooltip     <-  o JSON..:? "tooltip"
         wpftDefault     <-  o JSON..:? "default"
+        wpftLarge       <-  o JSON..:? "large" JSON..!= False
         wpftOptional    <-  o JSON..:  "optional"
         return $ WorkflowPayloadSpec WorkflowPayloadFieldText{..}
       WPFNumber' -> do
@@ -681,15 +750,21 @@ instance ( FromJSON fileid, FromJSON userid
         wpfnDefault     <- (o JSON..:? "default" :: Parser (Maybe Scientific))
         wpfnMin         <-  o JSON..:? "min"
         wpfnMax         <-  o JSON..:? "max"
-        wpfnStep        <-  o JSON..:  "step"
+        wpfnStep        <-  o JSON..:? "step"
         wpfnOptional    <-  o JSON..:  "optional"
         return $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}
       WPFBool' -> do
         wpfbLabel       <-  o JSON..:  "label"
         wpfbTooltip     <-  o JSON..:? "tooltip"
-        wpfbOptional    <-  o JSON..:  "optional"
+        wpfbOptional    <-  o JSON..:? "optional"
-        wpfbDefault     <- (o JSON..:  "default" :: Parser (Maybe Bool))
+        wpfbDefault     <- (o JSON..:? "default" :: Parser (Maybe Bool))
         return $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..}
+      WPFDay' -> do
+        wpfdLabel       <-  o JSON..:  "label"
+        wpfdTooltip     <-  o JSON..:? "tooltip"
+        wpfdOptional    <-  o JSON..:  "optional"
+        wpfdDefault     <- (o JSON..:? "default" :: Parser (Maybe Day))
+        return $ WorkflowPayloadSpec WorkflowPayloadFieldDay{..}
       WPFFile' -> do
         wpffLabel       <-  o JSON..:  "label"
         wpffTooltip     <-  o JSON..:? "tooltip"
@@ -753,18 +828,18 @@ instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid
     [ "tag"    JSON..= WFPBool' 
     , toPathPiece WFPBool' JSON..= b
     ]
-  toJSON (WorkflowFieldPayloadW (WFPFiles fid)) = JSON.object
+  toJSON (WorkflowFieldPayloadW (WFPDay    d)) = JSON.object
-    [ "tag"    JSON..= WFPFiles'
+    [ "tag"    JSON..= WFPDay' 
-    , toPathPiece WFPFiles' JSON..= fid
+    , toPathPiece WFPDay' JSON..= d
+    ]
+  toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object
+    [ "tag"    JSON..= WFPFile'
+    , toPathPiece WFPFile' JSON..= fid
     ]
   toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object
     [ "tag"    JSON..= WFPUser'
     , toPathPiece WFPUser' JSON..= uid
     ]
-  toJSON (WorkflowFieldPayloadW (WFPMultiple uid)) = JSON.object
-    [ "tag"    JSON..= WFPMultiple'
-    , toPathPiece WFPMultiple' JSON..= uid
-    ]
 instance (Ord fileid, FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where
   parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do
     fieldTag <- o JSON..: "tag"
@@ -778,15 +853,15 @@ instance (Ord fileid, FromJSON fileid, FromJSON userid, Typeable fileid, Typeabl
       WFPBool'   -> do
         b <- o JSON..: toPathPiece WFPBool'
         return $ WorkflowFieldPayloadW $ WFPBool b
-      WFPFiles'  -> do
+      WFPDay'   -> do
-        fid <- o JSON..: toPathPiece WFPFiles'
+        b <- o JSON..: toPathPiece WFPDay'
-        return $ WorkflowFieldPayloadW $ WFPFiles fid
+        return $ WorkflowFieldPayloadW $ WFPDay b
+      WFPFile'  -> do
+        fid <- o JSON..: toPathPiece WFPFile'
+        return $ WorkflowFieldPayloadW $ WFPFile fid
       WFPUser'   -> do
         uid <- o JSON..: toPathPiece WFPUser'
         return $ WorkflowFieldPayloadW $ WFPUser uid
-      WFPMultiple'   -> do
-        uid <- o JSON..: toPathPiece WFPMultiple'
-        return $ WorkflowFieldPayloadW $ WFPMultiple uid
 
 
 

src/Utils/Workflow.hs

@@ -1,12 +1,22 @@
+{-# OPTIONS -Wno-error=redundant-constraints #-}
+
 module Utils.Workflow
   ( _DBWorkflowScope
   , fromRouteWorkflowScope, toRouteWorkflowScope
   , _DBWorkflowGraph
   , _DBWorkflowState
+  , decryptWorkflowStateIndex, encryptWorkflowStateIndex
   ) where
 
 import Import.NoFoundation
 
+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 Language.Haskell.TH (nameBase)
+
 
 _DBWorkflowScope :: Iso' (WorkflowScope TermId SchoolId CourseId) (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey)
 _DBWorkflowScope = iso toScope' toScope
@@ -46,3 +56,31 @@ _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)
+
+
+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

src/Utils/Workflow/Lint.hs

@@ -0,0 +1,41 @@
+module Utils.Workflow.Lint
+  ( lintWorkflowGraph
+  , WorkflowGraphLinterIssue(..)
+  ) where
+
+import Import.NoFoundation
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+
+data WorkflowGraphLinterIssue
+  = WGLUnknownGraphNodeLabel WorkflowGraphNodeLabel
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Exception WorkflowGraphLinterIssue where
+  displayException = \case
+    WGLUnknownGraphNodeLabel nodeLbl -> unpack [st|Unknown GraphNodeLabel: “#{toPathPiece nodeLbl}”|]
+
+lintWorkflowGraph :: WorkflowGraph fileid userid -> Maybe (NonNull (Set WorkflowGraphLinterIssue))
+lintWorkflowGraph graph = fromNullable . Set.fromList $ concatMap ($ graph)
+  [ checkEdgesForUnknownGraphNodeLabel
+    -- Future ideas:
+    --   - node with no outgoing edges that isn't final
+    --   - WorkflowRolePayloadReference for unknown payload
+    --   - wgePayloadRestriction for unknown payload
+    --   - Undefined field order
+    --   - FieldReference for payload not defined in same form
+    --   - WorkflowRolePayloadReference to payload without user fields
+    --   - unreachable nodes
+    --   - all initial edges have only payload-reference
+    --   - cycles of automatic edges (also consider payload restrictions; computationally equivalent to SAT)
+  ]
+  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{} -> []

templates/workflows/workflow.hamlet

@@ -0,0 +1,14 @@
+$newline never
+<section>
+  <h2>
+    _{MsgWorkflowWorkflowWorkflowHistoryHeading}
+
+  <ul .workflow-history>
+    $forall histItem <- workflowHistory
+      ^{historyToWidget histItem}
+$maybe edgeView <- mEdgeView
+  <section>
+    <h2>
+      _{MsgWorkflowWorkflowWorkflowEdgeFormHeading}
+    ^{edgeView}
+  

templates/workflows/workflow/history-item.hamlet

@@ -0,0 +1,59 @@
+$newline never
+<li .workflow-history--item :is (_Just . _WHIASelf) whiUser:.workflow-history-item__self>
+  <div .workflow-history--item-user>
+    $maybe user <- whiUser
+      $case user
+        $of WHIASelf
+          <span .workflow-history--item-user-special>
+            _{MsgWorkflowWorkflowWorkflowHistoryUserSelf}
+        $of WHIAOther mUser
+          $maybe Entity _ User{userDisplayName, userSurname} <- mUser
+            ^{nameWidget userDisplayName userSurname}
+          $nothing
+            <span .workflow-history--item-user-special>
+              _{MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn}
+        $of WHIAGone
+            <span .workflow-history--item-user-special>
+              _{MsgWorkflowWorkflowWorkflowHistoryUserGone}
+        $of WHIAHidden
+            <span .workflow-history--item-user-special>
+              _{MsgWorkflowWorkflowWorkflowHistoryUserHidden}
+    $nothing
+      <span .workflow-history--item-user-special>
+        _{MsgWorkflowWorkflowWorkflowHistoryUserAutomatic}
+  <div .workflow-history--item-time>
+    ^{formatTimeW SelFormatDateTime whiTime}
+  <div .workflow-history--item-action>
+    $maybe actionLbl <- whiVia
+      #{actionLbl}
+    $nothing
+      <span .workflow-history--item-action-special>
+        _{MsgWorkflowWorkflowWorkflowHistoryActionAutomatic}
+  <div .workflow-history--item-states>
+    <div .workflow-history--item-state-from>
+      $maybe mFromLbl <- whiFrom
+        $maybe fromLbl <- mFromLbl
+          #{fromLbl}
+        $nothing
+          <span .workflow-history--item-state-special>
+            _{MsgWorkflowWorkflowWorkflowHistoryStateHidden}
+    <div .workflow-history--item-state-to>
+      #{whiTo}
+  $if not (onull whiPayloadChanges)
+    <div .workflow-history--item-payload-changes>
+      <dl .deflist>
+        $forall (payloadLbl, (newPayload, mFileRoute)) <- whiPayloadChanges
+          <dt .deflist__dt>
+            #{payloadLbl}
+          <dd .deflist__dd>
+            $if is _Nothing mFileRoute && null newPayload
+              —
+            $else
+              <ul .list--iconless>
+                $maybe fileRoute <- mFileRoute
+                  <li>
+                    <a href=@{fileRoute}>
+                      _{MsgWorkflowPayloadFiles}
+                $forall pItem <- newPayload
+                  <li>
+                    ^{payloadToWidget pItem}

test/Data/NonNull/TestInstances.hs

@@ -0,0 +1,9 @@
+module Data.NonNull.TestInstances
+  (
+  ) where
+
+import TestImport
+
+
+instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
+  arbitrary = arbitrary `suchThatMap` fromNullable

test/Database/Fill.hs

@@ -33,6 +33,8 @@ import qualified Data.Conduit.Combinators as C
 
 import qualified Data.Yaml as Yaml
 
+import Utils.Workflow.Lint
+
 
 testdataDir :: FilePath
 testdataDir = "testdata"
@@ -1285,25 +1287,9 @@ fillDb = do
   
   liftIO . LBS.writeFile (testdataDir </> "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities
 
-  do
-    workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir </> "exam-rooms.yaml"
-    let
-      examRoomsWorkflowDef = WorkflowDefinition{..}
-        where workflowDefinitionInstanceCategory = Just "rooms"
-              workflowDefinitionName = "exam-rooms"
-              workflowDefinitionScope = WSGlobal' -- TODO
-    wdId <- insert examRoomsWorkflowDef
-    let
-      examRoomsWorkflowInst = WorkflowInstance{..}
-        where workflowInstanceDefinition = Just wdId
-              workflowInstanceGraph = workflowDefinitionGraph
-              workflowInstanceScope = WSGlobal -- TODO
-              workflowInstanceName = workflowDefinitionName examRoomsWorkflowDef
-              workflowInstanceCategory = workflowDefinitionInstanceCategory examRoomsWorkflowDef
-    insert_ examRoomsWorkflowInst
-  
   do
     workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir </> "theses.yaml"
+    for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM
     let
       thesesWorkflowDef = WorkflowDefinition{..}
         where workflowDefinitionInstanceCategory = Just "theses"

test/Database/Persist/Sql/Types/TestInstances.hs

@@ -0,0 +1,12 @@
+module Database.Persist.Sql.Types.TestInstances
+  (
+  ) where
+
+import TestImport
+
+import Database.Persist.Sql
+  
+
+deriving newtype instance Arbitrary (BackendKey SqlBackend)
+deriving newtype instance Arbitrary (BackendKey SqlWriteBackend)
+deriving newtype instance Arbitrary (BackendKey SqlReadBackend)

test/FoundationSpec.hs

@@ -82,6 +82,18 @@ instance Arbitrary CourseEventR where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary AdminWorkflowDefinitionR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+  
+instance Arbitrary GlobalWorkflowInstanceR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary GlobalWorkflowWorkflowR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 instance Arbitrary (Route UniWorX) where
   arbitrary = genericArbitrary
   shrink = genericShrink

test/Model/Types/FileSpec.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Model.Types.FileSpec where
+
+import TestImport
+import TestInstances ()
+
+import Data.Conduit
+import qualified Data.Conduit.Combinators as C
+
+import Data.Ratio ((%))
+
+import System.FilePath
+import Data.Time
+
+import qualified Data.Map as Map
+
+
+scaleRatio :: Rational -> Int -> Int
+scaleRatio r = ceiling . (* r) . fromIntegral
+
+instance (LazySequence lazy strict, Arbitrary lazy, Monad m) => Arbitrary (ConduitT () strict m ()) where
+  arbitrary = C.sourceLazy <$> arbitrary
+
+instance Monad m => Arbitrary (File m) where
+  arbitrary = do
+    fileTitle <- scale (scaleRatio $ 1 % 8) $ (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
+    date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
+    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
+    fileContent <- oneof
+      [ pure Nothing
+      , Just <$> scale (scaleRatio $ 7 % 8) arbitrary
+      ]
+    return File{..}
+    where
+      inZipRange :: UTCTime -> Bool
+      inZipRange time
+        | time > UTCTime (fromGregorian 1980 1 1) 0
+        , time < UTCTime (fromGregorian 2107 1 1) 0
+        = True
+        | otherwise
+        = False
+
+instance Arbitrary FileReference where
+  arbitrary = pureFileToFileReference <$> arbitrary
+
+instance Arbitrary a => Arbitrary (FileFieldUserOption a) where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary add => Arbitrary (FileReferenceTitleMap FileReference add) where
+  arbitrary = do
+    fRefs <- arbitrary
+    fmap (review _FileReferenceFileReferenceTitleMap . Map.fromList) . for fRefs $ \FileReference{..} -> (fileReferenceTitle, ) . (fileReferenceContent, fileReferenceModified, ) <$> arbitrary
+
+instance Arbitrary (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Arbitrary (FileField fileid) where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+spec :: Spec
+spec = do
+  parallel $ do
+    lawsCheckHspec (Proxy @PureFile)
+      [ eqLaws, ordLaws, showLaws ]
+    lawsCheckHspec (Proxy @FileReference)
+      [ eqLaws, ordLaws, hashableLaws, binaryLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @(FileFieldUserOption Bool))
+      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @(FileReferenceTitleMap FileReference (FileFieldUserOption Bool)))
+      [ eqLaws, ordLaws, semigroupLaws, monoidLaws, semigroupMonoidLaws, idempotentSemigroupLaws, commutativeSemigroupLaws ]
+    lawsCheckHspec (Proxy @(FileField FileReference))
+      [ eqLaws, ordLaws, jsonLaws ]

test/Model/Types/WorkflowSpec.hs

@@ -0,0 +1,150 @@
+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 Control.Lens.Extras (is)
+
+import Utils.I18n
+
+
+instance Arbitrary WorkflowPayloadLabel where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+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 (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 (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
+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
+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 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 (Set 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 WorkflowScope' where
+  arbitrary = genericArbitrary
+
+
+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 ]

test/Model/TypesSpec.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE UndecidableInstances #-}
 
-module Model.TypesSpec where
+module Model.TypesSpec
+  ( module Model.TypesSpec
+  ) where
 
 import TestImport
 import Settings
@@ -17,9 +19,6 @@ import Yesod.Auth.Util.PasswordStore
 
 import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey)
 
-import Text.Blaze.Html
-import Text.Blaze.Renderer.Text
-
 import qualified Data.Set as Set
 
 import Network.IP.Addr
@@ -39,9 +38,10 @@ import qualified Data.ByteString.Lazy as LBS
 
 import qualified Data.CaseInsensitive as CI
 
+import Model.Types.WorkflowSpec as Model.TypesSpec ()
+
+import Text.Blaze.TestInstances ()
 
-instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
-  arbitrary = arbitrary `suchThatMap` fromNullable
 
 instance Arbitrary Season where
   arbitrary = genericArbitrary
@@ -211,10 +211,6 @@ instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key r
   arbitrary = toSqlKey <$> arbitrary
   shrink = map toSqlKey . shrink . fromSqlKey
 
-instance Arbitrary Html where
-  arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary
-  shrink = map preEscapedToHtml . shrink . renderMarkup
-
 instance Arbitrary OccurrenceSchedule where
   arbitrary = genericArbitrary
   shrink = genericShrink

test/ModelSpec.hs

@@ -24,9 +24,6 @@ import qualified Data.Char as Char
 
 import Utils
 
-import System.FilePath
-import Data.Time
-
 import Data.CryptoID.Poly
 import qualified Data.CryptoID.Class.ImplicitNamespace as Implicit
 
@@ -34,11 +31,6 @@ import Control.Monad.Catch.Pure (Catch, runCatch)
 
 import System.IO.Unsafe (unsafePerformIO)
 
-import Data.Conduit
-import qualified Data.Conduit.Combinators as C
-
-import Data.Ratio ((%))
-
 import Data.Universe
 
 
@@ -144,31 +136,6 @@ instance Arbitrary User where
     return User{..}
   shrink = genericShrink
 
-instance (LazySequence lazy strict, Arbitrary lazy, Monad m) => Arbitrary (ConduitT () strict m ()) where
-  arbitrary = C.sourceLazy <$> arbitrary
-
-scaleRatio :: Rational -> Int -> Int
-scaleRatio r = ceiling . (* r) . fromIntegral
-
-instance Monad m => Arbitrary (File m) where
-  arbitrary = do
-    fileTitle <- scale (scaleRatio $ 1 % 8) $ (joinPath <$> arbitrary) `suchThat` (any $ not . isPathSeparator)
-    date <- addDays <$> arbitrary <*> pure (fromGregorian 2043 7 2)
-    fileModified <- (addUTCTime <$> arbitrary <*> pure (UTCTime date 0)) `suchThat` inZipRange
-    fileContent <- oneof
-      [ pure Nothing
-      , Just <$> scale (scaleRatio $ 7 % 8) arbitrary
-      ]
-    return File{..}
-    where
-      inZipRange :: UTCTime -> Bool
-      inZipRange time
-        | time > UTCTime (fromGregorian 1980 1 1) 0
-        , time < UTCTime (fromGregorian 2107 1 1) 0
-        = True
-        | otherwise
-        = False
-
 instance Arbitrary ExamModePredicate where
   arbitrary = elements universeF
 
@@ -208,8 +175,6 @@ spec = do
   parallel $ do
     lawsCheckHspec (Proxy @User)
       [ eqLaws, jsonLaws ]
-    lawsCheckHspec (Proxy @PureFile)
-      [ eqLaws, ordLaws ]
     lawsCheckHspec (Proxy @School)
       [ eqLaws ]
     lawsCheckHspec (Proxy @Term)

test/Test/QuickCheck/Classes/JSON.hs

@@ -1,14 +1,15 @@
 module Test.QuickCheck.Classes.JSON
-  ( jsonKeyLaws
+  ( jsonLaws
+  , jsonKeyLaws
   ) where
 
 import ClassyPrelude
 import Test.QuickCheck
-import Test.QuickCheck.Property (failed)
+import Test.QuickCheck.Property (failed, Property(..))
-import Test.QuickCheck.Classes
+import Test.QuickCheck.Classes hiding (jsonLaws)
 import Data.Aeson
 import Data.Aeson.Encoding.Internal
-import Data.Aeson.Types (parseMaybe)
+import Data.Aeson.Types (parseEither)
 import Data.Proxy
 import Data.Coerce
 
@@ -20,7 +21,7 @@ jsonKeyLaws _ = Laws "ToJSONKey/FromJSONKey"
         -> let (toVal, toEnc) = case toJSONKey of
                  ToJSONKeyText toVal' toEnc' -> (String . toVal', retagEncoding . toEnc')
                  ToJSONKeyValue toVal' toEnc' -> (toVal', toEnc')
-            in decode (encodingToLazyByteString $ toEnc a) == Just (toVal a)
+            in eitherDecode (encodingToLazyByteString $ toEnc a) == Right (toVal a)
     )
   ]
   where
@@ -31,8 +32,40 @@ jsonKeyLaws _ = Laws "ToJSONKey/FromJSONKey"
       (ToJSONKeyText toVal _, FromJSONKeyText fromVal)
         -> property $ fromVal (toVal a) == a
       (ToJSONKeyText toVal _, FromJSONKeyTextParser parser)
-        -> property $ parseMaybe parser (toVal a) == Just a
+        -> property $ parseEither parser (toVal a) == Right a
       (ToJSONKeyValue toVal _, FromJSONKeyValue parser)
-        -> property $ parseMaybe parser (toVal a) == Just a
+        -> property $ parseEither parser (toVal a) == Right a
       (_, _)
         -> property failed
+
+jsonLaws :: (ToJSON a, FromJSON a, Show a, Arbitrary a, Eq a) => Proxy a -> Laws
+jsonLaws p = Laws "ToJSON/FromJSON"
+  [ ("Partial Isomorphism", jsonEncodingPartialIsomorphism p)
+  , ("Encoding Equals Value", jsonEncodingEqualsValue p)
+  ]
+
+-- TODO: improve the quality of the error message if
+-- something does not pass this test.
+jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a, Arbitrary a) => Proxy a -> Property
+jsonEncodingEqualsValue _ = property $ \(a :: a) ->
+  case decode (encode a) of
+    Nothing -> False
+    Just (v :: Value) -> v == toJSON a
+
+jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a, Arbitrary a) => Proxy a -> Property
+jsonEncodingPartialIsomorphism _ = again $
+  MkProperty $
+    arbitrary >>= \(x :: a) ->
+      unProperty $
+      shrinking shrink x $ \x' ->
+        let desc1 = "Right"
+            desc2 = "Data.Aeson.eitherDecode . Data.Aeson.encode"
+            name1 = "Data.Aeson.encode a"
+            name2 = "Data.Aeson.eitherDecode (Data.Aeson.encode a)"
+            b1  = encode x'
+            b2  = eitherDecode b1
+            sb1 = show b1
+            sb2 = show b2
+            description = "  Description: " ++ desc1 ++ " == " ++ desc2
+            err = description ++ "\n" ++ unlines (map ("  " ++) (["a = " ++ show x'])) ++ "  " ++ name1 ++ " = " ++ sb1 ++ "\n  " ++ name2 ++ " = " ++ sb2
+        in counterexample err (Right x' == b2)

test/TestImport.hs

@@ -27,7 +27,7 @@ import Test.QuickCheck.Gen   as X
 import Data.Default          as X
 import Test.QuickCheck.Instances as X ()
 import Test.QuickCheck.Arbitrary.Generic as X
-import Test.QuickCheck.Classes as X
+import Test.QuickCheck.Classes as X hiding (jsonLaws)
 import Test.QuickCheck.Classes.PathPiece as X
 import Test.QuickCheck.Classes.PersistField as X
 import Test.QuickCheck.Classes.Hashable as X

test/TestInstances.hs

@@ -0,0 +1,7 @@
+module TestInstances
+  (
+  ) where
+
+import Text.Blaze.TestInstances as TestInstances ()
+import Database.Persist.Sql.Types.TestInstances as TestInstances ()
+import Data.NonNull.TestInstances as TestInstances ()

test/Text/Blaze/TestInstances.hs

@@ -0,0 +1,13 @@
+module Text.Blaze.TestInstances
+  (
+  ) where
+
+import TestImport
+
+import Text.Blaze.Html
+import Text.Blaze.Renderer.Text
+
+
+instance Arbitrary Html where
+  arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary
+  shrink = map preEscapedToHtml . shrink . renderMarkup

test/Utils/I18nSpec.hs

@@ -0,0 +1,18 @@
+module Utils.I18nSpec where
+
+import TestImport
+
+import Utils.I18n
+
+
+instance Arbitrary a => Arbitrary (I18n a) where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+spec :: Spec
+spec = do
+  parallel $ do
+    lawsCheckHspec (Proxy @I18nText)
+      [ eqLaws, ordLaws, showLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @I18n)
+      [ foldableLaws, functorLaws, traversableLaws ]

testdata/exam-rooms.yaml

@@ -1,30 +0,0 @@
-nodes:
-  "beantragt":
-    display-label: "Beantragt"
-    final: false
-    viewers:
-      - tag: initiator
-      - tag: authorized
-        authorized: { "dnf-terms": [[{"val": "variable", "var": "exam-office"}]] }
-    edges:
-      "beantragen":
-        mode: initial
-        display-label: "Beantragen"
-        actors:
-          - tag: authorized
-            authorized: { "dnf-terms": [[{"val": "variable", "var": "lecturer"}]] }
-        form:
-          "raumbeschreibung":
-            - tag: text
-              label: "Raumbeschreibung"
-              placeholder: null
-              tooltip: null
-              default: null
-              optional: false
-payload-view:
-  "raumbeschreibung":
-    display-label: "Raumbeschreibung"
-    viewers:
-      - tag: initiator
-      - tag: authorized
-        authorized: { "dnf-terms": [[{"val": "variable", "var": "exam-office"}]] }

testdata/theses.yaml

@@ -1,112 +1,293 @@
 nodes:
   "antrag":
-    display-label: "Antrag angelegt"
-    final: false
     viewers:
-      - &pruefungsamt
+      display-label: "Antrag angelegt"
-        tag: authorized
+      viewers:
-        authorized: { "dnf-terms": [[{"val": "variable", "var": "exam-office"}]] }
+        - &pruefungsamt
-      - &hochschullehrer
+          tag: authorized
-        tag: payload-reference
+          authorized: { "dnf-terms": [[{"tag": "variable", "var": "exam-office"}]] }
-        payload-label: "hochschullehrer"
+        - &hochschullehrer
-      - &betreuer
+          tag: payload-reference
-        tag: payload-reference
+          payload-label: "hochschullehrer"
-        payload-label: "betreuer"
+        - &betreuer
-      - &student
+          tag: payload-reference
-        tag: payload-reference
+          payload-label: "betreuer"
-        payload-label: "student"
+        - &student
+          tag: payload-reference
+          payload-label: "student"
+    final: false
     edges:
       "antrag als pruefungsamt":
         mode: initial
         display-label: "Antrag anlegen (als Prüfungsverwaltung)"
         actors:
           - *pruefungsamt
-        form:
+        view-actor:
+          - *pruefungsamt
+        form: &antrag-forms-pruefungsamt
           "hochschullehrer": &hochschullehrer-form
-            - tag: multiple
+            - "1":
-              label: "Verantwortliche Hochschullehrer"
+                tag: multiple
-              tooltip: null
+                label: "Verantwortliche Hochschullehrer"
-              default: null
-              min: 1
-              range: null
-              sub:
-                tag: user
-                label: "Verantwortlicher Hochschullehrer"
                 tooltip: null
                 default: null
-                optional: false
+                min: 1
+                range: null
+                sub:
+                  tag: user
+                  label: "Verantwortlicher Hochschullehrer"
+                  tooltip: null
+                  default: null
+                  optional: false
           "betreuer": &betreuer-form
-            - tag: multiple
+            - "2":
-              label: "Betreuer"
+                tag: multiple
-              tooltip: null
-              default: null
-              min: 0
-              range: null
-              sub:
-                tag: user
                 label: "Betreuer"
                 tooltip: null
                 default: null
-                optional: false
+                min: 0
+                range: null
+                sub:
+                  tag: user
+                  label: "Betreuer"
+                  tooltip: null
+                  default: null
+                  optional: false
           "student": &student-form
-            - tag: user
+            - "3":
-              label: "Student"
+                tag: user
-              tooltip: null
+                label: "Student"
-              default: null
+                tooltip: null
-              optional: false
+                default: null
+                optional: false
+          "anmeldetag": &anmeldetag-form-optional
+            - "4": &anmeldetag-field-optional
+                tag: day
+                label: "Tag der Anmeldung"
+                tooltip: null
+                default: null
+                optional: true
+          "sprache": &sprache-form-optional
+            - "5": &sprache-field-optional
+                tag: text
+                label: "Sprache der Arbeit"
+                tooltip: null
+                default: null
+                optional: true
+          "titel": &titel-form-optional
+            - "6": &titel-field-optional
+                tag: text
+                label: "Titel, in Sprache der Arbeit"
+                tooltip: null
+                default: null
+                optional: true
+          "titel, englisch": &entitel-form-optional
+            - "7": &entitel-field-optional
+                tag: text
+                label: "Titel, Englisch"
+                tooltip: null
+                default: null
+                optional: true
+          "aufgabenstellung": &aufgabenstellung-form
+            - "8":
+                tag: text
+                large: true
+                label: "Aufgabenstellung"
+                tooltip: null
+                default: null
+                optional: true
+          "notizen": &notizen-form
+            - "9":
+                tag: text
+                large: true
+                label: "Notizen"
+                tooltip: "Einsehbar für alle Beteiligten, außer den Studenten"
+                default: null
+                optional: true
+      "korrektur als pruefungsamt": &korrektur-pruefungsamt
+        mode: manual
+        display-label: "Antrag anpassen"
+        source: "antrag"
+        actors:
+          - *pruefungsamt
+        view-actor:
+          - *pruefungsamt
+        form: *antrag-forms-pruefungsamt
+      "korrektur als pruefungsamt, hochschullehrer":
+        <<: *korrektur-pruefungsamt
+        source: "antrag, hochschullehrer"
+      "korrektur als pruefungsamt, student":
+        <<: *korrektur-pruefungsamt
+        source: "antrag, student"
+      "korrektur als pruefungsamt, student&hochschullehrer":
+        <<: *korrektur-pruefungsamt
+        source: "antrag, student&hochschullehrer"
+      "korrektur als pruefungsamt, student&hochschullehrer&anmeldetag":
+        <<: *korrektur-pruefungsamt
+        source: "antrag, student&hochschullehrer, anmeldetag"
       "antrag als hochschullehrer":
         mode: initial
         display-label: "Antrag anlegen (als verantwortlicher Hochschullehrer)"
         actors:
           - tag: authorized
-            authorized: { "dnf-terms": [[{"val": "variable", "var": "lecturer" }]] }
+            authorized: { "dnf-terms": [[{"tag": "variable", "var": "lecturer" }]] }
-        form:
+        view-actor: &view-actor-all
+          - *pruefungsamt
+          - *hochschullehrer
+          - *betreuer
+          - *student
+        form: &antrag-forms-hochschullehrer
           "hochschullehrer":
-            - tag: capture-user
+            - "1":
-            - tag: multiple
+                tag: capture-user
-              label: "Zusätzliche verantwortliche Hochschullehrer"
+            - "1.1":
-              tooltip: null
+                tag: multiple
-              default: null
+                label: "Zusätzliche verantwortliche Hochschullehrer"
-              min: 0
-              range: null
-              sub:
-                tag: user
-                label: "Verantwortlicher Hochschullehrer"
                 tooltip: null
                 default: null
-                optional: false
+                min: 0
+                range: null
+                sub:
+                  tag: user
+                  label: "Verantwortlicher Hochschullehrer"
+                  tooltip: null
+                  default: null
+                  optional: false
           "betreuer": *betreuer-form
           "student": *student-form
+          "anmeldetag": *anmeldetag-form-optional
+          "sprache": *sprache-form-optional
+          "titel": *titel-form-optional
+          "titel, englisch": *entitel-form-optional
+          "aufgabenstellung": *aufgabenstellung-form
+          "notizen": *notizen-form
+      "korrektur als hochschullehrer": &korrektur-hochschullehrer
+        mode: manual
+        display-label: "Antrag anpassen"
+        source: "antrag"
+        actors:
+          - *hochschullehrer
+        view-actor: *view-actor-all
+        form: *antrag-forms-hochschullehrer
+      "korrektur als hochschullehrer, student":
+        <<: *korrektur-hochschullehrer
+        source: "antrag, student"
       "antrag als betreuer":
         mode: initial
         display-label: "Antrag anlegen (als Betreuer)"
         actors:
           - tag: authorized
-            authorized: { "dnf-terms": [[{"val": "variable", "var": "lecturer" }]] }
+            authorized: { "dnf-terms": [[{"tag": "variable", "var": "lecturer" }]] }
-        form:
+        view-actor: *view-actor-all
+        form: &antrag-forms-betreuer
           "betreuer":
-            - tag: capture-user
+            - "2":
-            - tag: multiple
+                tag: capture-user
-              label: "Zusätzliche Betreuer"
+            - "2.1":
-              tooltip: null
+                tag: multiple
-              default: null
+                label: "Zusätzliche Betreuer"
-              min: 0
-              range: null
-              sub:
-                tag: user
-                label: "Betreuer"
                 tooltip: null
                 default: null
-                optional: false
+                min: 0
+                range: null
+                sub:
+                  tag: user
+                  label: "Betreuer"
+                  tooltip: null
+                  default: null
+                  optional: false
           "hochschullehrer": *hochschullehrer-form
           "student": *student-form
+          "anmeldetag": *anmeldetag-form-optional
+          "sprache": *sprache-form-optional
+          "titel": *titel-form-optional
+          "titel, englisch": *entitel-form-optional
+          "aufgabenstellung": *aufgabenstellung-form
+          "notizen": *notizen-form
+      "betreuer als hochschullehrer": &betreuer-hochschullehrer
+        mode: manual
+        display-label: "Eigene Rolle zu Betreuer wechseln"
+        source: "antrag"
+        actors:
+          - *hochschullehrer
+        view-actor: *view-actor-all
+        form: *antrag-forms-betreuer
+      "betreuer als hochschullehrer, student":
+        <<: *betreuer-hochschullehrer
+        source: "antrag, student"
+      "betreuer als hochschullehrer, hochschullehrer":
+        <<: *betreuer-hochschullehrer
+        source: "antrag, hochschullehrer"
+      "betreuer als hochschullehrer, student&hochschullehrer":
+        <<: *betreuer-hochschullehrer
+        source: "antrag, student&hochschullehrer"
+      "betreuer als hochschullehrer, student&hochschullehrer&anmeldetag":
+        <<: *betreuer-hochschullehrer
+        source: "antrag, student&hochschullehrer, anmeldetag"
+      "hochschullehrer als betreuer": &hochschullehrer-betreuer
+        mode: manual
+        display-label: "Eigene Rolle zu Hochschullehrer wechseln"
+        source: "antrag"
+        actors:
+          - *betreuer
+        view-actor: *view-actor-all
+        form: *antrag-forms-hochschullehrer
+      "hochschullehrer als betreuer, hochschullehrer":
+        <<: *hochschullehrer-betreuer
+        source: "antrag, hochschullehrer"
+      "hochschullehrer als betreuer, student":
+        <<: *hochschullehrer-betreuer
+        source: "antrag, student"
+      "hochschullehrer als betreuer, student&hochschullehrer":
+        <<: *hochschullehrer-betreuer
+        source: "antrag, student&hochschullehrer"
+      "hochschullehrer als betreuer, student&hochschullehrer&anmeldetag":
+        <<: *hochschullehrer-betreuer
+        source: "antrag, student&hochschullehrer, anmeldetag"
+      "korrektur als betreuer": &korrektur-betreuer
+        mode: manual
+        display-label: "Antrag anpassen"
+        source: "antrag"
+        actors:
+          - *betreuer
+        view-actor: *view-actor-all
+        form: *antrag-forms-betreuer
+      "korrektur als betreuer, student":
+        <<: *korrektur-betreuer
+        source: "antrag, student"
+      "korrektur als betreuer, hochschullehrer":
+        <<: *korrektur-betreuer
+        source: "antrag, hochschullehrer"
+      "korrektur als betreuer, student&hochschullehrer":
+        <<: *korrektur-betreuer
+        source: "antrag, student&hochschullehrer"
+      "korrektur als betreuer, student&hochschullehrer&anmeldetag":
+        <<: *korrektur-betreuer
+        source: "antrag, student&hochschullehrer, anmeldetag"
+      "korrektur als student": &korrektur-student
+        mode: manual
+        display-label: "Antrag anpassen"
+        source: "antrag"
+        actors:
+          - *student
+        view-actor: *view-actor-all
+        form:
+          "sprache": *sprache-form-optional
+          "titel": *titel-form-optional
+          "titel, englisch": *entitel-form-optional
+          "aufgabenstellung": *aufgabenstellung-form
+      "korrektur als student, hochschullehrer":
+        <<: *korrektur-student
+        source: "antrag, hochschullehrer"
+       
   "antrag, hochschullehrer":
-    display-label: "Antrag angelegt und vom Hochschullehrer bestätigt"
-    final: false
     viewers:
-      - *pruefungsamt
+      display-label: "Antrag angelegt und vom Hochschullehrer bestätigt"
-      - *hochschullehrer
+      viewers:
-      - *betreuer
+        - *pruefungsamt
+        - *hochschullehrer
+        - *betreuer
+    final: false
     edges:
       "antrag bestaetigen als hochschullehrer":
         mode: manual
@@ -115,15 +296,26 @@ nodes:
         actors:
           - *hochschullehrer
           - *pruefungsamt
+        view-actor: *view-actor-all
         form: {}
+      "korrektur als hochschullehrer":
+        <<: *korrektur-hochschullehrer
+        source: "antrag, hochschullehrer"
+      "korrektur als hochschullehrer, student":
+        <<: *korrektur-hochschullehrer
+        source: "antrag, student&hochschullehrer"
+      "korrektur als hochschullehrer, student&anmeldetag":
+        <<: *korrektur-hochschullehrer
+        source: "antrag, student&hochschullehrer, anmeldetag"
   "antrag, student":
-    display-label: "Antrag angelegt und vom Student bestätigt"
-    final: false
     viewers:
-      - *pruefungsamt
+      display-label: "Antrag angelegt und vom Student bestätigt"
-      - *student
+      viewers:
-      - *hochschullehrer
+        - *pruefungsamt
-      - *betreuer
+        - *student
+        - *hochschullehrer
+        - *betreuer
+    final: false
     edges:
       "antrag bestaetigen als student":
         mode: manual
@@ -132,14 +324,25 @@ nodes:
         actors:
           - *student
           - *pruefungsamt
+        view-actor: *view-actor-all
         form: {}
+      "korrektur als student":
+        <<: *korrektur-student
+        source: "antrag, student"
+      "korrektur als student, hochschullehrer":
+        <<: *korrektur-student
+        source: "antrag, student&hochschullehrer"
+      "korrektur als student, hochschullehrer&anmeldetag":
+        <<: *korrektur-student
+        source: "antrag, student&hochschullehrer, anmeldetag"
   "antrag, student&hochschullehrer":
-    display-label: "Antrag angelegt und von Student und Hochschullehrer bestätigt"
-    final: false
     viewers:
-      - *pruefungsamt
+      display-label: "Antrag angelegt und von Student und Hochschullehrer bestätigt"
-      - *hochschullehrer
+      viewers:
-      - *betreuer
+        - *pruefungsamt
+        - *hochschullehrer
+        - *betreuer
+    final: false
     edges:
       "antrag bestaetigen als student":
         mode: manual
@@ -148,6 +351,7 @@ nodes:
         actors:
           - *student
           - *pruefungsamt
+        view-actor: *view-actor-all
         form: {}
       "antrag bestaetigen als hochschullehrer":
         mode: manual
@@ -156,86 +360,187 @@ nodes:
         actors:
           - *hochschullehrer
           - *pruefungsamt
+        view-actor: *view-actor-all
         form: {}
-  "angemeldet":
+  "antrag, student&hochschullehrer, anmeldetag":
-    display-label: "Angemeldet"
-    final: false
     viewers:
-      - *pruefungsamt
+      display-label: "Antrag angelegt, von Student und Hochschullehrer bestätigt, Anmeldetag eingetragen"
-      - *hochschullehrer
+      viewers:
-      - *betreuer
+        - *pruefungsamt
-      - *student
+        - *hochschullehrer
+        - *betreuer
+    final: false
     edges:
+      "anmeldetag ist eingetragen":
+        mode: automatic
+        source: "antrag, student&hochschullehrer"
+        payload-restriction: { "dnf-terms": [[{"tag": "variable", "var": "anmeldetag"}]] }
+  "angemeldet":
+    viewers:
+      display-label: "Angemeldet"
+      viewers:
+        - *pruefungsamt
+        - *hochschullehrer
+        - *betreuer
+        - *student
+    final: false
+    edges:
+      "anmelden, bestaetigt student&hochschullehrer, anmeldetag":
+        mode: manual
+        display-label: "Arbeit anmelden (bestätigt vom Student und verantwortlichem Hochschullehrer)"
+        source: "antrag, student&hochschullehrer, anmeldetag"
+        actors:
+          - *pruefungsamt
+        view-actor:
+          - *pruefungsamt
+        form: {}
       "anmelden, bestaetigt student&hochschullehrer":
         mode: manual
         display-label: "Arbeit anmelden (bestätigt vom Student und verantwortlichem Hochschullehrer)"
         source: "antrag, student&hochschullehrer"
         actors:
           - *pruefungsamt
+        view-actor:
+          - *pruefungsamt
         form:
-          "hochschullehrer": *hochschullehrer-form
+          "anmeldetag":
-          "betreuer": *betreuer-form
+            - "4":
-          "student": *student-form
+                <<: *anmeldetag-field-optional
+                optional: false
       "anmelden, bestaetigt student":
         mode: manual
         display-label: "Arbeit anmelden (bestätigt nur vom Student)"
         source: "antrag, student"
         actors:
           - *pruefungsamt
+        view-actor:
+          - *pruefungsamt
         form:
-          "hochschullehrer": *hochschullehrer-form
+          "anmeldetag":
-          "betreuer": *betreuer-form
+            - "4":
-          "student": *student-form
+                <<: *anmeldetag-field-optional
+                optional: false
       "anmelden, bestaetigt hochschullehrer":
         mode: manual
         display-label: "Arbeit anmelden (bestätigt nur vom Hochschullehrer)"
         source: "antrag, hochschullehrer"
         actors:
           - *pruefungsamt
+        view-actor:
+          - *pruefungsamt
         form:
-          "hochschullehrer": *hochschullehrer-form
+          "anmeldetag":
-          "betreuer": *betreuer-form
+            - "4":
-          "student": *student-form
+                <<: *anmeldetag-field-optional
+                optional: false
   "datei":
-    display-label: "Datei hochgeladen"
-    final: false
     viewers:
-      - *pruefungsamt
+      display-label: "Datei hochgeladen"
-      - *hochschullehrer
+      viewers:
-      - *betreuer
+        - *pruefungsamt
-      - *student
+        - *hochschullehrer
+        - *betreuer
+        - *student
+    final: false
     edges: {}
   "abgegeben":
-    display-label: "Abgabe akzeptiert"
-    final: false
     viewers:
-      - *pruefungsamt
+      display-label: "Abgabe akzeptiert"
-      - *hochschullehrer
+      viewers:
-      - *betreuer
+        - *pruefungsamt
-      - *student
+        - *hochschullehrer
+        - *betreuer
+        - *student
+    final: false
     edges: {}
   "benotet":
-    display-label: "Benotet"
-    final: false
     viewers:
-      - *pruefungsamt
+      display-label: "Benotet"
-      - *hochschullehrer
+      viewers:
-      - *betreuer
+        - *pruefungsamt
-      - *student
+        - *hochschullehrer
+        - *betreuer
+        - *student
+    final: false
     edges: {}
   "abgebrochen":
-    display-label: "Abgebrochen"
+    viewers:
+      display-label: "Abgebrochen"
+      viewers:
+        - *pruefungsamt
+        - *hochschullehrer
+        - *betreuer
+        - *student
     final: false
+    edges: {}
+  "fertig":
+    viewers:
+      display-label: "Fertig"
+      viewers:
+        - *pruefungsamt
+    final: true
+    edges: {}
+payload-view:
+  "hochschullehrer":
     viewers:
       - *pruefungsamt
       - *hochschullehrer
       - *betreuer
       - *student
-    edges: {}
+      - {"tag": "initiator"}
-  "fertig":
+    display-label: "Verantwortliche Hochschullehrer"
-    display-label: "Fertig"
+  "betreuer":
-    final: true
     viewers:
       - *pruefungsamt
-    edges: {}
+      - *hochschullehrer
-payload-view: {}
+      - *betreuer
+      - *student
+      - {"tag": "initiator"}
+    display-label: "Betreuer"
+  "student":
+    viewers:
+      - *pruefungsamt
+      - *hochschullehrer
+      - *betreuer
+      - *student
+      - {"tag": "initiator"}
+    display-label: "Student"
+  "anmeldetag":
+    viewers:
+      - *pruefungsamt
+      - *hochschullehrer
+      - *betreuer
+      - *student
+      - {"tag": "initiator"}
+    display-label: "Tag der Anmeldung"
+  "sprache":
+    viewers:
+      - *pruefungsamt
+      - *hochschullehrer
+      - *betreuer
+      - *student
+      - {"tag": "initiator"}
+    display-label: "Sprache der Arbeit"
+  "titel":
+    viewers:
+      - *pruefungsamt
+      - *hochschullehrer
+      - *betreuer
+      - *student
+      - {"tag": "initiator"}
+    display-label: "Titel, in Sprache der Arbeit"
+  "titel, englisch":
+    viewers:
+      - *pruefungsamt
+      - *hochschullehrer
+      - *betreuer
+      - *student
+      - {"tag": "initiator"}
+    display-label: "Titel, Englisch"
+  "notizen":
+    viewers:
+      - *pruefungsamt
+      - *hochschullehrer
+      - *betreuer
+      - {"tag": "initiator"}
+    display-label: "Notizen"