feat(workflows): edge messages

2020-12-04 17:50:32 +01:00 · 2020-12-04 17:50:32 +01:00 · c22004e1b2
commit c22004e1b2
parent aa0404a007
7 changed files with 97 additions and 29 deletions
--- a/frontend/src/app.sass
+++ b/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
--- a/src/Handler/Utils/Workflow/EdgeForm.hs
+++ b/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
-                  (Right wwId, Right _) -> do
+                wRoute <- case ctx' of
+                  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
--- a/src/Handler/Utils/Workflow/Restriction.hs
+++ b/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
--- a/src/Handler/Utils/Workflow/Workflow.hs
+++ b/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
--- a/src/Handler/Workflow/Workflow/Workflow.hs
+++ b/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
--- a/src/Model/Types/TH/JSON.hs
+++ b/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
+  }
--- a/src/Model/Types/Workflow.hs
+++ b/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