100 lines
4.0 KiB
Haskell
100 lines
4.0 KiB
Haskell
module Handler.Utils.Workflow.Workflow
|
|
( ensureScope
|
|
, followEdge
|
|
, followAutomaticEdges, WorkflowAutomaticEdgeException(..)
|
|
, sourceWorkflowActionInfos
|
|
, 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
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
ensureScope :: IdWorkflowScope -> 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
|
|
)
|
|
=> IdWorkflowGraph -> WorkflowEdgeForm -> Maybe IdWorkflowState -> m IdWorkflowState
|
|
-- | Remember to invalidate auth cache
|
|
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
|
|
)
|
|
=> IdWorkflowGraph -> IdWorkflowState -> m IdWorkflowState
|
|
followAutomaticEdges WorkflowGraph{..} = go []
|
|
where
|
|
go :: [((WorkflowGraphNodeLabel, Set WorkflowPayloadLabel), (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed
|
|
-> IdWorkflowState
|
|
-> m IdWorkflowState
|
|
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 (Just history)
|
|
return (edgeLbl, nodeLbl)
|
|
filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
|
|
edgeDecisionInput = (cState, filledPayloads)
|
|
|
|
|
|
sourceWorkflowActionInfos
|
|
:: forall backend m.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BackendCompatible SqlReadBackend backend
|
|
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
|
|
, MonadCatch m, MonadUnliftIO m
|
|
, MonadAP (ReaderT backend m)
|
|
)
|
|
=> WorkflowWorkflowId
|
|
-> WorkflowState FileReference UserId
|
|
-> ConduitT () (WorkflowActionInfo FileReference UserId) (ReaderT backend m) ()
|
|
-- ^ Does `mayViewWorkflowAction`
|
|
sourceWorkflowActionInfos wwId wState = do
|
|
mAuthId <- maybeAuthId
|
|
let authCheck WorkflowActionInfo{..}
|
|
= mayViewWorkflowAction mAuthId wwId waiAction
|
|
yieldMany (workflowActionInfos wState) .| C.filterM authCheck
|