91 lines
4.3 KiB
Haskell
91 lines
4.3 KiB
Haskell
module Handler.Utils.Workflow.Workflow
|
|
( ensureScope
|
|
, followEdge
|
|
, followAutomaticEdges, WorkflowAutomaticEdgeException(..)
|
|
, checkWorkflowRestriction
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils.Workflow.EdgeForm
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
ensureScope :: WorkflowScope TermId SchoolId CourseId -> CryptoFileNameWorkflowWorkflow -> MaybeT DB WorkflowWorkflowId
|
|
ensureScope wiScope cID = do
|
|
wId <- catchMaybeT (Proxy @CryptoIDError) $ decrypt cID
|
|
WorkflowWorkflow{..} <- MaybeT $ get wId
|
|
let wiScope' = wiScope
|
|
& _wisTerm %~ unTermKey
|
|
& _wisSchool %~ unSchoolKey
|
|
& _wisCourse %~ view _SqlKey
|
|
guard $ workflowWorkflowScope == wiScope'
|
|
return wId
|
|
|
|
followEdge :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadThrow m
|
|
)
|
|
=> WorkflowGraph FileReference UserId -> WorkflowEdgeForm -> Maybe (WorkflowState FileReference UserId) -> m (WorkflowState FileReference UserId)
|
|
followEdge graph edgeRes cState = do
|
|
act <- workflowEdgeFormToAction edgeRes
|
|
followAutomaticEdges graph $ maybe id (<>) cState (act `ncons` mempty)
|
|
|
|
data WorkflowAutomaticEdgeException
|
|
= WorkflowAutomaticEdgeCycle [(WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel)]
|
|
| WorkflowAutomaticEdgeAmbiguity (Set (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
followAutomaticEdges :: forall m.
|
|
( MonadIO m
|
|
, MonadThrow m
|
|
)
|
|
=> WorkflowGraph FileReference UserId
|
|
-> WorkflowState FileReference UserId -> m (WorkflowState FileReference UserId)
|
|
followAutomaticEdges WorkflowGraph{..} = go []
|
|
where
|
|
go :: [((WorkflowGraphNodeLabel, Set WorkflowPayloadLabel), (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed
|
|
-> WorkflowState FileReference UserId
|
|
-> m (WorkflowState FileReference UserId)
|
|
go automaticEdgesTaken history
|
|
| null automaticEdgeOptions = return history
|
|
| [(edgeLbl, nodeLbl)] <- automaticEdgeOptions = if
|
|
| (edgeDecisionInput, (edgeLbl, nodeLbl)) `elem` automaticEdgesTaken
|
|
-> throwM . WorkflowAutomaticEdgeCycle . reverse $ map (view _2) automaticEdgesTaken
|
|
| otherwise -> do
|
|
wpTime <- liftIO getCurrentTime
|
|
let wpUser = Nothing
|
|
wpPayload = mempty
|
|
wpTo = nodeLbl
|
|
wpVia = edgeLbl
|
|
go ((edgeDecisionInput, (edgeLbl, nodeLbl)) : automaticEdgesTaken) $ history <> (WorkflowAction{..} `ncons` mempty)
|
|
| otherwise = throwM . WorkflowAutomaticEdgeAmbiguity $ Set.fromList automaticEdgeOptions
|
|
where
|
|
cState = wpTo $ last history
|
|
automaticEdgeOptions = nub $ do
|
|
(nodeLbl, WGN{..}) <- Map.toList wgNodes
|
|
(edgeLbl, WorkflowGraphEdgeAutomatic{..}) <- Map.toList wgnEdges
|
|
guard $ wgeSource == cState
|
|
whenIsJust wgeRestriction $ guard . checkWorkflowRestriction history
|
|
return (edgeLbl, nodeLbl)
|
|
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
|