feat(workflows): edge messages

frontend/src/app.sass

@@ -683,7 +683,7 @@ section
   color: var(--color-lightblack)
 
 .notification-success
-  color: var(--color-warning)
+  color: var(--color-success-dark)
 
 // "Heated" element.
 // Set custom property "--hotness" to a value from 0 to 1 to turn

src/Handler/Utils/Workflow/EdgeForm.hs

@@ -11,6 +11,7 @@ import Utils.Workflow
 import Handler.Utils.Form
 import Handler.Utils.Workflow.CanonicalRoute
 import Handler.Utils.Widgets
+import Handler.Utils.Workflow.Restriction
 
 import qualified ListT
 
@@ -79,7 +80,7 @@ workflowEdgeForm :: ( MonadHandler m
 workflowEdgeForm mwwId mPrev = runMaybeT $ do
   MsgRenderer mr <- getMsgRenderer
 
-  ctx <- bitraverse (MaybeT . get) (MaybeT . get) mwwId
+  ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getEntity) mwwId
   let (scope, graph) = case ctx of
         Left  WorkflowInstance{..} -> ( _DBWorkflowScope # workflowInstanceScope
                                       , _DBWorkflowGraph # workflowInstanceGraph
@@ -89,6 +90,7 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
                                       )
       wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo
       wPayload' = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState 
+      ctx = bimap entityVal entityVal ctx'
   mAuthId <- maybeAuthId
   wPayload <- case mwwId of
     Right wwId -> workflowStateCurrentPayloads <$> filterM (lift . hoist liftHandler . mayViewWorkflowAction mAuthId wwId) (maybe [] otoList wPayload')
@@ -107,13 +109,13 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
         cID <- lift $ encrypt wwId
         guardM . anyM (Set.toList wgeActors) $ \role -> 
           lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) True
-        return (wgeDisplayLabel, wgeForm)
+        return (wgeDisplayLabel, (wgeForm, wgeMessages))
       WorkflowGraphEdgeInitial{..}  -> do
         guard $ is _Nothing wState
         win <- hoistMaybe $ ctx ^? _Left . _workflowInstanceName
         guardM . anyM (Set.toList wgeActors) $ \role -> 
           lift . lift $ is _Authorized <$> hasWorkflowRole Nothing role (_WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)) True
-        return (wgeDisplayLabel, wgeForm)
+        return (wgeDisplayLabel, (wgeForm, wgeMessages))
       _other -> mzero
 
   guard . not $ null edges
@@ -153,7 +155,21 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
   let edges' = flip sortOn edges $ \(edgeIdent, _) -> flip findIndex (olOptions edgesOptList) $ (== edgeIdent) . optionInternalValue
 
   let edgeForms :: Map (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) (AForm Handler WorkflowEdgeForm)
-      edgeForms = Map.fromList . flip map edges' $ \(edgeIdent@(tState, _), (_, WorkflowGraphEdgeForm{..})) -> (edgeIdent, ) . fmap (WorkflowEdgeForm edgeIdent) . wFormToAForm . fmap sequenceA $ do
+      edgeForms = Map.fromList . flip map edges' $ \(edgeIdent@(tState, _), (_, (WorkflowGraphEdgeForm{..}, edgeMessages))) -> (edgeIdent, ) . fmap (WorkflowEdgeForm edgeIdent) . wFormToAForm . fmap sequenceA $ do
+        forM_ edgeMessages $ \WorkflowEdgeMessage{..} -> void . runMaybeT $ do
+          let hasWorkflowRole' role = liftHandler . runDB $ case ctx' of
+                Right (Entity wwId _) -> do
+                  cID <- encrypt wwId
+                  is _Authorized <$> hasWorkflowRole (Just wwId) role (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) True
+                Left (Entity _ WorkflowInstance{..})
+                  -> is _Authorized <$> hasWorkflowRole Nothing role (_WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)) True
+          guardM $ anyM (otoList wemViewers) hasWorkflowRole'
+          whenIsJust wemRestriction $ guard . checkWorkflowRestriction wPayload'
+          let messageStatus = wemStatus
+              messageIcon = Nothing
+          messageContent <- selectLanguageI18n wemContent
+          lift $ wformMessage Message{..}
+        
         let fieldSort :: [(WorkflowPayloadLabel, [[(Either WorkflowGraphEdgeFormOrder ByteString, WorkflowPayloadSpec FileReference UserId)]])]
                       -> _
             fieldSort
@@ -176,13 +192,12 @@ workflowEdgeForm mwwId mPrev = runMaybeT $ do
             let
               displayNameFromState s = do
                 WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLabel $ Map.findWithDefault Map.empty s (wgnPayloadView <$> wgNodes graph)
-                wRoute <- case (mwwId, ctx) of
+                wRoute <- case ctx' of
-                  (Right wwId, Right _) -> do
+                  Right (Entity wwId _) -> do
                     cID <- encrypt wwId
                     return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
-                  (Left _, Left WorkflowInstance{..})
+                  Left (Entity _ WorkflowInstance{..})
                     -> return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
-                  _other -> error "mwwId and ctx do not agree"
                 guardM . anyM (Set.toList $ toNullable wpvViewers) $ \role ->
                   lift . lift $ is _Authorized <$> hasWorkflowRole (mwwId ^? _Right) role wRoute False
                 (True, ) <$> selectLanguageI18n wpvDisplayLabel

src/Handler/Utils/Workflow/Restriction.hs

@@ -0,0 +1,29 @@
+module Handler.Utils.Workflow.Restriction
+  ( checkWorkflowRestriction
+  ) where
+
+import Import
+
+import Utils.Workflow
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+
+checkWorkflowRestriction :: Maybe IdWorkflowState
+                         -> PredDNF WorkflowGraphRestriction
+                         -> Bool
+checkWorkflowRestriction mHistory dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf'
+  where
+    evalConj = maybe True (ofoldr1 (&&)) . fromNullable . map evalPred
+    evalPred PLVariable{ plVar = WorkflowGraphRestrictionPayloadFilled{..} } = wgrPayloadFilled `Set.member`    filledPayloads
+    evalPred PLNegated{  plVar = WorkflowGraphRestrictionPayloadFilled{..} } = wgrPayloadFilled `Set.notMember` filledPayloads
+    evalPred PLVariable{ plVar = WorkflowGraphRestrictionPreviousNode{..}  } = maybe False (wgrPreviousNode ==) cState
+    evalPred PLNegated{  plVar = WorkflowGraphRestrictionPreviousNode{..}  } = maybe True  (wgrPreviousNode /=) cState
+    evalPred PLVariable{ plVar = WorkflowGraphRestrictionInitial           } = is    _Nothing mHistory
+    evalPred PLNegated{  plVar = WorkflowGraphRestrictionInitial           } = isn't _Nothing mHistory
+    dnf' = map (Set.toList . toNullable) . Set.toList $ dnfTerms dnf
+
+    filledPayloads | Just history <- mHistory = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
+                   | otherwise = Set.empty
+    cState = wpTo . last <$> mHistory

src/Handler/Utils/Workflow/Workflow.hs

@@ -2,13 +2,14 @@ module Handler.Utils.Workflow.Workflow
   ( ensureScope
   , followEdge
   , followAutomaticEdges, WorkflowAutomaticEdgeException(..)
-  , checkWorkflowRestriction
+  , module Handler.Utils.Workflow.Restriction
   ) where
 
 import Import
 
 import Utils.Workflow
 import Handler.Utils.Workflow.EdgeForm
+import Handler.Utils.Workflow.Restriction
 
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -69,22 +70,7 @@ followAutomaticEdges WorkflowGraph{..} = go []
           (nodeLbl, WGN{..}) <- Map.toList wgNodes
           (edgeLbl, WorkflowGraphEdgeAutomatic{..}) <- Map.toList wgnEdges
           guard $ wgeSource == cState
-          whenIsJust wgeRestriction $ guard . checkWorkflowRestriction history
+          whenIsJust wgeRestriction $ guard . checkWorkflowRestriction (Just history)
           return (edgeLbl, nodeLbl)
         filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
         edgeDecisionInput = (cState, filledPayloads)
-
-checkWorkflowRestriction :: IdWorkflowState
-                         -> 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

@@ -218,7 +218,7 @@ workflowR rScope cID = do
               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'
+                whenIsJust wnmRestriction $ guard . checkWorkflowRestriction (Just history')
                 let messageStatus = wnmStatus
                     messageIcon = Nothing
                 messageContent <- selectLanguageI18n wnmContent

src/Model/Types/TH/JSON.hs

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

src/Model/Types/Workflow.hs

@@ -8,6 +8,7 @@ module Model.Types.Workflow
   , WorkflowNodeMessage(..)
   , WorkflowGraphEdgeLabel
   , WorkflowGraphEdge(..)
+  , WorkflowEdgeMessage(..)
   , WorkflowGraphRestriction(..)
   , WorkflowGraphEdgeFormOrder
   , WorkflowGraphEdgeForm(..)
@@ -110,6 +111,7 @@ newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLab
 data WorkflowGraphRestriction
   = WorkflowGraphRestrictionPayloadFilled { wgrPayloadFilled :: WorkflowPayloadLabel }
   | WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel }
+  | WorkflowGraphRestrictionInitial
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 data WorkflowGraphEdge fileid userid
@@ -119,6 +121,7 @@ data WorkflowGraphEdge fileid userid
     , wgeForm         :: WorkflowGraphEdgeForm fileid userid
     , wgeDisplayLabel :: I18nText
     , wgeViewActor    :: Set (WorkflowRole userid)
+    , wgeMessages     :: Set (WorkflowEdgeMessage userid)
     }
   | WorkflowGraphEdgeAutomatic
     { wgeSource      :: WorkflowGraphNodeLabel
@@ -129,6 +132,7 @@ data WorkflowGraphEdge fileid userid
     , wgeForm         :: WorkflowGraphEdgeForm fileid userid
     , wgeDisplayLabel :: I18nText
     , wgeViewActor    :: Set (WorkflowRole userid)
+    , wgeMessages     :: Set (WorkflowEdgeMessage userid)
     }
   deriving (Generic, Typeable)
 
@@ -136,6 +140,13 @@ 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 (WorkflowGraphEdge fileid userid)
 deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdge fileid userid)
 
+data WorkflowEdgeMessage userid = WorkflowEdgeMessage 
+  { wemViewers     :: NonNull (Set (WorkflowRole userid))
+  , wemRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
+  , wemStatus      :: MessageStatus
+  , wemContent     :: I18nHtml
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
 -- | A wrapped `Scientific`
 --
 -- Due to arbitrary precision this allows inserting new fields anywhere
@@ -611,6 +622,7 @@ deriveJSON defaultOptions
 
 deriveToJSON workflowNodeViewAesonOptions ''WorkflowNodeView
 deriveToJSON workflowNodeMessageAesonOptions ''WorkflowNodeMessage
+deriveToJSON workflowEdgeMessageAesonOptions ''WorkflowEdgeMessage
 deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView
 pathPieceJSON ''WorkflowFieldPayload'
 pathPieceJSON ''WorkflowPayloadField'
@@ -622,6 +634,8 @@ deriveJSON defaultOptions
 
 instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeMessage userid) where
   parseJSON = genericParseJSON workflowNodeMessageAesonOptions
+instance (FromJSON userid, Ord userid) => FromJSON (WorkflowEdgeMessage userid) where
+  parseJSON = genericParseJSON workflowEdgeMessageAesonOptions
 instance (FromJSON userid, Ord userid) => FromJSON (WorkflowNodeView userid) where
   parseJSON = genericParseJSON workflowNodeViewAesonOptions
 instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where
@@ -645,7 +659,28 @@ instance ( FromJSON fileid, FromJSON userid
          , FromJSON (FileField fileid)
          , Ord (FileField fileid)
          ) => FromJSON (WorkflowGraphEdge fileid userid) where
-  parseJSON = genericParseJSON workflowGraphEdgeAesonOptions
+  parseJSON = JSON.withObject "WorkflowGraphEdge" $ \o -> do
+    mode <- o JSON..: "mode" :: JSON.Parser Text
+    if | mode == "manual" -> do
+           wgeSource <- o JSON..: "source"
+           wgeActors <- o JSON..:? "actors" JSON..!= Set.empty
+           wgeForm <- o JSON..:? "form" JSON..!= WorkflowGraphEdgeForm Map.empty
+           wgeDisplayLabel <- o JSON..: "display-label"
+           wgeViewActor <- o JSON..:? "view-actor" JSON..!= Set.empty
+           wgeMessages <- o JSON..:? "messages" JSON..!= Set.empty
+           return WorkflowGraphEdgeManual{..}
+       | mode == "automatic" -> do
+           wgeSource <- o JSON..: "source"
+           wgeRestriction <- o JSON..:? "restriction"
+           return WorkflowGraphEdgeAutomatic{..}
+       | mode == "initial" -> do
+           wgeActors <- o JSON..:? "actors" JSON..!= Set.empty
+           wgeForm <- o JSON..:? "form" JSON..!= WorkflowGraphEdgeForm Map.empty
+           wgeDisplayLabel <- o JSON..: "display-label"
+           wgeViewActor <- o JSON..:? "view-actor" JSON..!= Set.empty
+           wgeMessages <- o JSON..:? "messages" JSON..!= Set.empty
+           return WorkflowGraphEdgeInitial{..}
+       | otherwise -> fail "Could not parse WorkflowGraphEdge, expected mode to be one of: manual, automatic, initial"
 
 instance ToJSON WorkflowGraphEdgeFormOrder where
   toJSON WorkflowGraphEdgeFormOrder{..} = case unWorkflowGraphEdgeFormOrder of