feat(workflows): node messages

2020-10-28 17:16:42 +01:00 · 2020-10-28 17:16:42 +01:00 · 6a7a892c74
commit 6a7a892c74
parent 5b897c7a42
7 changed files with 84 additions and 29 deletions
--- a/src/Handler/Utils/Workflow/Workflow.hs
+++ b/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
--- a/src/Handler/Workflow/Workflow/Workflow.hs
+++ b/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))

--- a/src/Model/Types/TH/JSON.hs
+++ b/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
+  }
--- a/src/Model/Types/Workflow.hs
+++ b/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
-  = WorkflowGraphEdgeAutomaticRestrictionPayloadFilled { wgearPayloadFilled :: WorkflowPayloadLabel }
-  | WorkflowGraphEdgeAutomaticRestrictionPreviousNode { wgearPreviousNode :: WorkflowGraphNodeLabel }
+data WorkflowGraphRestriction
+  = WorkflowGraphRestrictionPayloadFilled { wgrPayloadFilled :: WorkflowPayloadLabel }
+  | 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
-  } ''WorkflowGraphEdgeAutomaticRestriction
+  , constructorTagModifier = camelToPathPiece' 3
+  } ''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
--- a/src/Utils/Message.hs
+++ b/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 Universe MessageStatus
-instance Finite   MessageStatus
-instance Default  MessageStatus where
+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
--- a/templates/workflows/workflow.hamlet
+++ b/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>
--- a/testdata/theses.yaml
+++ b/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: {}