From c22004e1b2f3cd85297faaf41d76954c0625e308 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 4 Dec 2020 17:50:32 +0100 Subject: [PATCH] feat(workflows): edge messages --- frontend/src/app.sass | 2 +- src/Handler/Utils/Workflow/EdgeForm.hs | 31 ++++++++++++++----- src/Handler/Utils/Workflow/Restriction.hs | 29 ++++++++++++++++++ src/Handler/Utils/Workflow/Workflow.hs | 20 ++---------- src/Handler/Workflow/Workflow/Workflow.hs | 2 +- src/Model/Types/TH/JSON.hs | 5 ++- src/Model/Types/Workflow.hs | 37 ++++++++++++++++++++++- 7 files changed, 97 insertions(+), 29 deletions(-) create mode 100644 src/Handler/Utils/Workflow/Restriction.hs diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 10b84a687..6fa993d7a 100644 --- 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 diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index e0750743d..1e6b033f1 100644 --- 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 diff --git a/src/Handler/Utils/Workflow/Restriction.hs b/src/Handler/Utils/Workflow/Restriction.hs new file mode 100644 index 000000000..c84951acf --- /dev/null +++ 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 diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index d54c5bab4..cc87a73c4 100644 --- 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 diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index e715f8602..28b4ac29a 100644 --- 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 diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs index b099d1df4..5320d6174 100644 --- 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 + } diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 75f57277d..b69198ee9 100644 --- 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