feat(workflows): node messages

src/Handler/Utils/Workflow/Workflow.hs

@@ -2,6 +2,7 @@ module Handler.Utils.Workflow.Workflow
   ( ensureScope
   , followEdge
   , followAutomaticEdges, WorkflowAutomaticEdgeException(..)
+  , checkWorkflowRestriction
   ) where
 
 import Import
@@ -68,16 +69,22 @@ followAutomaticEdges WorkflowGraph{..} = go []
           (nodeLbl, WGN{..}) <- Map.toList wgNodes
           (edgeLbl, WorkflowGraphEdgeAutomatic{..}) <- Map.toList wgnEdges
           guard $ wgeSource == cState
-          whenIsJust wgeRestriction $ guard . checkRestriction
+          whenIsJust wgeRestriction $ guard . checkWorkflowRestriction history
           return (edgeLbl, nodeLbl)
-        checkRestriction :: PredDNF WorkflowGraphEdgeAutomaticRestriction -> Bool
-        checkRestriction dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf' 
-          where
-            evalConj = maybe True (ofoldr1 (&&)) . fromNullable . map evalPred
-            evalPred PLVariable{ plVar = WorkflowGraphEdgeAutomaticRestrictionPayloadFilled{..} } = wgearPayloadFilled `Set.member`    filledPayloads
-            evalPred PLNegated{ plVar = WorkflowGraphEdgeAutomaticRestrictionPayloadFilled{..} }  = wgearPayloadFilled `Set.notMember` filledPayloads
-            evalPred PLVariable{ plVar = WorkflowGraphEdgeAutomaticRestrictionPreviousNode{..} }  = wgearPreviousNode == cState
-            evalPred PLNegated{ plVar = WorkflowGraphEdgeAutomaticRestrictionPreviousNode{..} }   = wgearPreviousNode /= cState
-            dnf' = map (Set.toList . toNullable) . Set.toList $ dnfTerms dnf
         filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
         edgeDecisionInput = (cState, filledPayloads)
+
+checkWorkflowRestriction :: WorkflowState FileReference UserId 
+                         -> PredDNF WorkflowGraphRestriction
+                         -> Bool
+checkWorkflowRestriction history dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf'
+  where
+    evalConj = maybe True (ofoldr1 (&&)) . fromNullable . map evalPred
+    evalPred PLVariable{ plVar = WorkflowGraphRestrictionPayloadFilled{..} } = wgrPayloadFilled `Set.member`    filledPayloads
+    evalPred PLNegated{  plVar = WorkflowGraphRestrictionPayloadFilled{..} } = wgrPayloadFilled `Set.notMember` filledPayloads
+    evalPred PLVariable{ plVar = WorkflowGraphRestrictionPreviousNode{..}  } = wgrPreviousNode == cState
+    evalPred PLNegated{  plVar = WorkflowGraphRestrictionPreviousNode{..}  } = wgrPreviousNode /= cState
+    dnf' = map (Set.toList . toNullable) . Set.toList $ dnfTerms dnf
+
+    filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
+    cState = wpTo $ last history

src/Handler/Workflow/Workflow/Workflow.hs

@@ -18,6 +18,7 @@ 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)
@@ -51,6 +52,7 @@ data WorkflowHistoryItem = WorkflowHistoryItem
 
 data WorkflowCurrentState = WorkflowCurrentState
   { wcsState :: Maybe Text
+  , wcsMessages :: Set Message
   , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))]
   }
 
@@ -73,11 +75,12 @@ workflowR wwId = do
     rScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
     mEdgeForm <- workflowEdgeForm (Right wwId) Nothing
     let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
+        wGraph = _DBWorkflowGraph # workflowWorkflowGraph
 
     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
+        nState <- followEdge wGraph edgeRes' . Just $ _DBWorkflowState # workflowWorkflowState
 
         update wwId [ WorkflowWorkflowState =. view _DBWorkflowState nState ]
 
@@ -95,10 +98,10 @@ workflowR wwId = do
                 )
              => WorkflowStateIndex
              -> Maybe WorkflowGraphNodeLabel
-             -> Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))
+             -> [WorkflowAction FileReference UserId]
              -> WorkflowAction FileReference UserId
              -> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) ()
-          go stIx wpFrom currentPayload act@WorkflowAction{..} = maybeT (return ()) $ do
+          go stIx wpFrom history@(workflowStateCurrentPayloads -> currentPayload) act@WorkflowAction{..} = maybeT (return ()) $ do
             mAuthId <- maybeAuthId
             guardM . lift . lift . hoist liftHandler $ mayViewWorkflowAction mAuthId wwId act
             
@@ -183,17 +186,28 @@ workflowR wwId = do
             whiPayloadChanges <- renderPayload payloadChanges
             wcsPayload <- renderPayload currentPayload
 
+            wcsMessages <- do
+              let msgs = maybe Set.empty wgnMessages $ Map.lookup wpTo wgNodes
+              flip foldMapM msgs $ \WorkflowNodeMessage{..} -> lift . maybeT (return Set.empty) . fmap Set.singleton $ do
+                guardM $ anyM (otoList wnmViewers) hasWorkflowRole'
+                history' <- hoistMaybe . fromNullable $ Seq.fromList history
+                whenIsJust wnmRestriction $ guard . checkWorkflowRestriction history'
+                let messageStatus = wnmStatus
+                    messageIcon = Nothing
+                messageContent <- selectLanguageI18n wnmContent
+                return Message{..}
+
             tell ( Just $ Last WorkflowCurrentState{..}
                  , pure WorkflowHistoryItem{..}
                  )
-          WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph
+          WorkflowGraph{..} = wGraph
           wState = otoList $ review _DBWorkflowState workflowWorkflowState
        in fmap (over _2 (sortOn (Down . whiTime) . reverse) . view _2) . (\act -> execRWST act () Map.empty) $ sequence_
             [ go stIx fromSt payload act
             | fromSt <- Nothing : map (Just . wpTo) wState 
             | act <- wState
             | stIx <- [minBound..]
-            | payload <- map workflowStateCurrentPayloads . tailEx $ inits wState
+            | payload <- tailEx $ inits wState
             ]
     return (mEdge, rScope, (workflowState, workflowHistory))
 

src/Model/Types/TH/JSON.hs

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

src/Model/Types/Workflow.hs

@@ -5,9 +5,10 @@ module Model.Types.Workflow
   , WorkflowGraphNodeLabel
   , WorkflowGraphNode(..)
   , WorkflowNodeView(..)
+  , WorkflowNodeMessage(..)
   , WorkflowGraphEdgeLabel
   , WorkflowGraphEdge(..)
-  , WorkflowGraphEdgeAutomaticRestriction(..)
+  , WorkflowGraphRestriction(..)
   , WorkflowGraphEdgeFormOrder
   , WorkflowGraphEdgeForm(..)
   , WorkflowRole(..)
@@ -78,6 +79,7 @@ newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLab
 data WorkflowGraphNode fileid userid = WGN
   { wgnFinal        :: Bool
   , wgnViewers      :: Maybe (WorkflowNodeView userid)
+  , wgnMessages     :: Set (WorkflowNodeMessage userid)
   , wgnEdges        :: Map WorkflowGraphEdgeLabel (WorkflowGraphEdge fileid userid)
   , wgnPayloadView  :: Map WorkflowPayloadLabel   (WorkflowPayloadView userid)
   }
@@ -92,15 +94,22 @@ data WorkflowNodeView userid = WorkflowNodeView
   , wnvDisplayLabel :: I18nText
   } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
 
+data WorkflowNodeMessage userid = WorkflowNodeMessage 
+  { wnmViewers     :: NonNull (Set (WorkflowRole userid))
+  , wnmRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
+  , wnmStatus      :: MessageStatus
+  , wnmContent     :: I18nHtml
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
 -----  WORKFLOW GRAPH: EDGES  -----
 
 newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
   deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
   deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, PersistFieldSql, Binary)
 
-data WorkflowGraphEdgeAutomaticRestriction
+data WorkflowGraphRestriction
-  = WorkflowGraphEdgeAutomaticRestrictionPayloadFilled { wgearPayloadFilled :: WorkflowPayloadLabel }
+  = WorkflowGraphRestrictionPayloadFilled { wgrPayloadFilled :: WorkflowPayloadLabel }
-  | WorkflowGraphEdgeAutomaticRestrictionPreviousNode { wgearPreviousNode :: WorkflowGraphNodeLabel }
+  | WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data WorkflowGraphEdge fileid userid
@@ -113,7 +122,7 @@ data WorkflowGraphEdge fileid userid
     }
   | WorkflowGraphEdgeAutomatic
     { wgeSource      :: WorkflowGraphNodeLabel
-    , wgeRestriction :: Maybe (PredDNF WorkflowGraphEdgeAutomaticRestriction)
+    , wgeRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
     }
   | WorkflowGraphEdgeInitial
     { wgeActors       :: Set (WorkflowRole userid)
@@ -601,15 +610,18 @@ deriveJSON defaultOptions
   } ''WorkflowRole
 
 deriveToJSON workflowNodeViewAesonOptions ''WorkflowNodeView
+deriveToJSON workflowNodeMessageAesonOptions ''WorkflowNodeMessage
 deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView
 pathPieceJSON ''WorkflowFieldPayload'
 pathPieceJSON ''WorkflowPayloadField'
 
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
-  , constructorTagModifier = camelToPathPiece' 5
+  , constructorTagModifier = camelToPathPiece' 3
-  } ''WorkflowGraphEdgeAutomaticRestriction
+  } ''WorkflowGraphRestriction
 
+instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeMessage userid) where
+  parseJSON = genericParseJSON workflowNodeMessageAesonOptions
 instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeView userid) where
   parseJSON = genericParseJSON workflowNodeViewAesonOptions
 instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where

src/Utils/Message.hs

@@ -30,12 +30,10 @@ import Text.HTML.SanitizeXSS (sanitizeBalance)
 
 
 data MessageStatus = Error | Warning | Info | Success
-  deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)
+  deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
 
-
+instance Default MessageStatus where
-instance Universe MessageStatus
-instance Finite   MessageStatus
-instance Default  MessageStatus where
   def = Info
 
 deriveJSON defaultOptions
@@ -113,7 +111,7 @@ instance FromJSON Message where
   parseJSON = withObject "Message" $ \o -> do
     messageStatus <- o .: "status"
     messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
-    messageIcon <- o .: "icon"
+    messageIcon <- o .:? "icon"
     return Message{..}
 
 statusToUrgencyClass :: MessageStatus -> Text

templates/workflows/workflow.hamlet

@@ -14,6 +14,10 @@ $maybe WorkflowCurrentState{..} <- workflowState
           $nothing
             <span .workflow-state--state-special>
               _{MsgWorkflowWorkflowWorkflowStateStateHidden}
+
+    $forall msg <- wcsMessages
+      ^{notification NotificationBroad msg}
+  
     $if not (onull wcsPayload)
       <div .workflow-payload>
         <div .workflow-payload--label>

testdata/theses.yaml

@@ -79,6 +79,7 @@ nodes:
           - *betreuer
           - {"tag": "initiator"}
         display-label: "Notizen"
+    messages: []
     final: false
     edges:
       "antrag als pruefungsamt":
@@ -352,6 +353,7 @@ nodes:
         - *hochschullehrer
         - *betreuer
     payload-view: *payload-view
+    messages: []
     final: false
     edges:
       "antrag bestaetigen als hochschullehrer":
@@ -381,6 +383,7 @@ nodes:
         - *hochschullehrer
         - *betreuer
     payload-view: *payload-view
+    messages: []
     final: false
     edges:
       "antrag bestaetigen als student":
@@ -409,6 +412,13 @@ nodes:
         - *hochschullehrer
         - *betreuer
     payload-view: *payload-view
+    messages:
+      - viewers:
+          - *hochschullehrer
+          - *betreuer
+        restriction: null
+        status: info
+        content: "Es muss zunächst „Anmeldetag“ eingetragen werden, damit der Antrag weiter von der Prüfungsverwaltung bearbeitet werden kann."
     final: false
     edges:
       "antrag bestaetigen als student":
@@ -437,6 +447,7 @@ nodes:
         - *hochschullehrer
         - *betreuer
     payload-view: *payload-view
+    messages: []
     final: false
     edges:
       "anmeldetag ist eingetragen":
@@ -457,6 +468,7 @@ nodes:
         - *betreuer
         - *student
     payload-view: *payload-view
+    messages: []
     final: false
     edges:
       "anmelden, bestaetigt student&hochschullehrer, anmeldetag":
@@ -516,6 +528,7 @@ nodes:
         - *betreuer
         - *student
     payload-view: *payload-view
+    messages: []
     final: false
     edges: {}
   "abgegeben":
@@ -527,6 +540,7 @@ nodes:
         - *betreuer
         - *student
     payload-view: *payload-view
+    messages: []
     final: false
     edges: {}
   "benotet":
@@ -538,6 +552,7 @@ nodes:
         - *betreuer
         - *student
     payload-view: *payload-view
+    messages: []
     final: false
     edges: {}
   "abgebrochen":
@@ -549,6 +564,7 @@ nodes:
         - *betreuer
         - *student
     payload-view: *payload-view
+    messages: []
     final: false
     edges: {}
   "fertig":
@@ -557,5 +573,6 @@ nodes:
       viewers:
         - *pruefungsamt
     payload-view: *payload-view
+    messages: []
     final: true
     edges: {}