diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index 09ec59873..601dd206b 100644 --- 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 diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index c30e0475b..232fc18ba 100644 --- 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)) diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs index e3ab6e39d..84b7b6282 100644 --- 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 + } diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index a0d5aecf8..538184a1d 100644 --- 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 diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 345db9881..168c3e132 100644 --- 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 diff --git a/templates/workflows/workflow.hamlet b/templates/workflows/workflow.hamlet index 8cad7b654..e408eade7 100644 --- a/templates/workflows/workflow.hamlet +++ b/templates/workflows/workflow.hamlet @@ -14,6 +14,10 @@ $maybe WorkflowCurrentState{..} <- workflowState $nothing _{MsgWorkflowWorkflowWorkflowStateStateHidden} + + $forall msg <- wcsMessages + ^{notification NotificationBroad msg} + $if not (onull wcsPayload)
diff --git a/testdata/theses.yaml b/testdata/theses.yaml index 49a9a2f9d..6265a30eb 100644 --- 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: {}