From 316097a07ed89e40ecbf3dd8a7160eca95bd7a67 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 6 Dec 2020 16:03:36 +0100 Subject: [PATCH] feat(workflows): improve linter --- package.yaml | 8 +++ src/Data/MultiSet/Instances.hs | 14 ++++ src/Handler/Utils/Workflow/Form.hs | 2 +- src/Import/NoModel.hs | 1 + src/Utils/Sql.hs | 8 +-- src/Utils/Workflow/Lint.hs | 110 +++++++++++++++++++++++++++-- test/Database/Fill.hs | 9 ++- wflint/WFLint.hs | 29 ++++++++ 8 files changed, 168 insertions(+), 13 deletions(-) create mode 100644 src/Data/MultiSet/Instances.hs create mode 100644 wflint/WFLint.hs diff --git a/package.yaml b/package.yaml index 13b6acacc..832774c43 100644 --- a/package.yaml +++ b/package.yaml @@ -301,6 +301,14 @@ executables: when: - condition: flag(library-only) buildable: false + wflint: + main: WFLint.hs + ghc-options: + - -main-is WFLint + source-dirs: [wflint, src] + when: + - condition: flag(library-only) + buildable: false # Test suite tests: diff --git a/src/Data/MultiSet/Instances.hs b/src/Data/MultiSet/Instances.hs new file mode 100644 index 000000000..046daf0ab --- /dev/null +++ b/src/Data/MultiSet/Instances.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.MultiSet.Instances + ( + ) where + +import ClassyPrelude +import Data.MultiSet + + +type instance Element (MultiSet a) = a + +instance MonoFoldable (MultiSet a) +instance GrowingAppend (MultiSet a) diff --git a/src/Handler/Utils/Workflow/Form.hs b/src/Handler/Utils/Workflow/Form.hs index f24c1627e..8dfc47982 100644 --- a/src/Handler/Utils/Workflow/Form.hs +++ b/src/Handler/Utils/Workflow/Form.hs @@ -1,6 +1,6 @@ module Handler.Utils.Workflow.Form ( FileIdent - , WorkflowGraphForm(..) + , WorkflowGraphForm(..), FormWorkflowGraph , workflowGraphForm , toWorkflowGraphForm, fromWorkflowGraphForm , WorkflowDescriptionsFormScope(..) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 991d211d9..941ac6e71 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -186,6 +186,7 @@ import Control.Monad.Catch.Instances as Import () import Text.Shakespeare.Text.Instances as Import () import Ldap.Client.Instances as Import () import Network.URI.Instances as Import () +import Data.MultiSet.Instances as Import () import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512) import Crypto.Random as Import (ChaChaDRG, Seed) diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index b88932062..c892e56fa 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -75,10 +75,10 @@ setSerializable' policy act = do transactionSaveWithIsolation ReadCommitted return res -catchSql :: forall m a. (MonadCatch m, MonadIO m) => SqlPersistT m a -> (SqlError -> SqlPersistT m a) -> SqlPersistT m a +catchSql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => SqlPersistT m a -> (e -> SqlPersistT m a) -> SqlPersistT m a catchSql = flip handleSql -handleSql :: forall m a. (MonadCatch m, MonadIO m) => (SqlError -> SqlPersistT m a) -> SqlPersistT m a -> SqlPersistT m a +handleSql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => (e -> SqlPersistT m a) -> SqlPersistT m a -> SqlPersistT m a handleSql recover act = do savepointName <- liftIO $ UUID.toString <$> getRandom @@ -94,10 +94,10 @@ handleSql recover act = do rawExecute [st|RELEASE SAVEPOINT "#{savepointName}"|] [] return res -catchIfSql :: forall m a. (MonadCatch m, MonadIO m) => (SqlError -> Bool) -> SqlPersistT m a -> (SqlError -> SqlPersistT m a) -> SqlPersistT m a +catchIfSql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => (e -> Bool) -> SqlPersistT m a -> (e -> SqlPersistT m a) -> SqlPersistT m a catchIfSql p = flip $ handleIfSql p -handleIfSql :: forall m a. (MonadCatch m, MonadIO m) => (SqlError -> Bool) -> (SqlError -> SqlPersistT m a) -> SqlPersistT m a -> SqlPersistT m a +handleIfSql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => (e -> Bool) -> (e -> SqlPersistT m a) -> SqlPersistT m a -> SqlPersistT m a handleIfSql p recover = handleSql (\err -> bool throwM recover (p err) err) isUniqueConstraintViolation :: SqlError -> Bool diff --git a/src/Utils/Workflow/Lint.hs b/src/Utils/Workflow/Lint.hs index 5c784679c..a7a3be2ea 100644 --- a/src/Utils/Workflow/Lint.hs +++ b/src/Utils/Workflow/Lint.hs @@ -6,7 +6,10 @@ module Utils.Workflow.Lint import Import.NoFoundation import qualified Data.Set as Set +import Data.MultiSet (MultiSet) +import qualified Data.MultiSet as MultiSet import qualified Data.Map as Map +import qualified Data.Sequence as Seq {-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-} @@ -14,26 +17,46 @@ import qualified Data.Map as Map data WorkflowGraphLinterIssue = WGLUnknownGraphNodeLabel WorkflowGraphNodeLabel + | WGLPayloadInvisibleInTargetNode (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) WorkflowPayloadLabel + | WGLFinalNodeHasOutgoingEdges WorkflowGraphNodeLabel | WGLNonFinalNodeHasNoOutgoingEdges WorkflowGraphNodeLabel + | WGLUndefinedFieldOrder (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) (NonNull (MultiSet WorkflowPayloadLabel)) + | WGLNodeUnreachable WorkflowGraphNodeLabel + | WGLNodeUnfinalizable WorkflowGraphNodeLabel deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Exception WorkflowGraphLinterIssue where displayException = \case - WGLUnknownGraphNodeLabel nodeLbl -> unpack [st|Unknown GraphNodeLabel: “#{toPathPiece nodeLbl}”|] + WGLUnknownGraphNodeLabel nodeLbl + -> unpack [st|Unknown GraphNodeLabel: #{tshow (toPathPiece nodeLbl)}|] + WGLPayloadInvisibleInTargetNode (nodeLbl, edgeLbl) payloadLbl + -> unpack [st|Payload #{tshow (toPathPiece payloadLbl)} has form on edge #{tshow (toPathPiece edgeLbl)} to target node #{tshow (toPathPiece nodeLbl)} but no viewers on target node|] + WGLFinalNodeHasOutgoingEdges nodeLbl + -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} is marked “final” but has outgoing edges|] + WGLNonFinalNodeHasNoOutgoingEdges nodeLbl + -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} isn't marked “final” but has no outgoing edges|] + WGLUndefinedFieldOrder (nodeLbl, edgeLbl) payloads + -> unpack [st|Form for edge #{tshow (toPathPiece edgeLbl)} to target node #{tshow (toPathPiece nodeLbl)} has ill defined field order for payload(s): “#{intercalate ", " (map (tshow . toPathPiece) (MultiSet.elems (toNullable payloads)))}”|] + WGLNodeUnreachable nodeLbl + -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} is unreachable from all initial edges|] + WGLNodeUnfinalizable nodeLbl + -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} has no path to a final node|] -lintWorkflowGraph :: WorkflowGraph fileid userid -> Maybe (NonNull (Set WorkflowGraphLinterIssue)) +lintWorkflowGraph :: forall fileid userid. WorkflowGraph fileid userid -> Maybe (NonNull (Set WorkflowGraphLinterIssue)) lintWorkflowGraph graph = fromNullable . Set.fromList $ concatMap ($ graph) [ checkEdgesForUnknownGraphNodeLabel + , checkFormPayloadVisibleInTargetNode + , finalMatchesOutgoingEdges + , checkUndefinedFieldOrder + , checkNodeUnreachable + , checkNodeUnfinalizable -- Future ideas: - -- - node with no outgoing edges that isn't final - -- - final node with outgoing edges -- - WorkflowRolePayloadReference for unknown payload -- - wgePayloadRestriction for unknown payload - -- - Undefined field order -- - FieldReference for payload not defined in same form -- - WorkflowRolePayloadReference to payload without user fields - -- - unreachable nodes -- - all initial edges have only payload-reference -- - cycles of automatic edges (also consider payload restrictions; computationally equivalent to SAT) + -- - unsatisfiable restrictions ] where checkEdgesForUnknownGraphNodeLabel WorkflowGraph{wgNodes} = foldMap (pure . WGLUnknownGraphNodeLabel) $ Set.fromList edgeNodeLabels `Set.difference` Map.keysSet wgNodes @@ -43,3 +66,78 @@ lintWorkflowGraph graph = fromNullable . Set.fromList $ concatMap ($ graph) WorkflowGraphEdgeManual{wgeSource} -> pure wgeSource WorkflowGraphEdgeAutomatic{wgeSource} -> pure wgeSource WorkflowGraphEdgeInitial{} -> [] + checkFormPayloadVisibleInTargetNode WorkflowGraph{wgNodes} = ifoldMap (\nodeLbl node -> map (\(edgeLbl, payloadLbl) -> WGLPayloadInvisibleInTargetNode (nodeLbl, edgeLbl) payloadLbl) . Set.toList $ doCheck node) wgNodes + where + doCheck :: WorkflowGraphNode fileid userid -> Set (WorkflowGraphEdgeLabel, WorkflowPayloadLabel) + doCheck WGN{wgnEdges, wgnPayloadView} = ifoldMap (\edgeLbl -> Set.map (edgeLbl, ) . doCheck') wgnEdges + where + doCheck' :: WorkflowGraphEdge fileid userid -> Set WorkflowPayloadLabel + doCheck' wge = fromMaybe Set.empty $ do + WorkflowGraphEdgeForm{wgefFields} <- wge ^? _wgeForm + return $ Map.keysSet wgefFields `Set.difference` Map.keysSet wgnPayloadView + finalMatchesOutgoingEdges WorkflowGraph{wgNodes} = foldMap (\nodeLbl -> pure $ bool WGLFinalNodeHasOutgoingEdges WGLNonFinalNodeHasNoOutgoingEdges (nodeLbl `Set.notMember` markedFinalNodes) nodeLbl) $ markedFinalNodes `setSymmDiff` edgeFinalNodes + where + markedFinalNodes = Set.fromList $ do + (nodeLbl, WGN{wgnFinal}) <- Map.toList wgNodes + guard $ is _Just wgnFinal + return nodeLbl + edgeFinalNodes = Set.fromList $ do + nodeLbl <- Map.keys wgNodes + guard $ noneOf (folded . _wgnEdges . folded . _wgeSource) (== nodeLbl) wgNodes + return nodeLbl + checkUndefinedFieldOrder WorkflowGraph{wgNodes} = ifoldMap (\nodeLbl node -> map (\(edgeLbl, payloadLbls) -> WGLUndefinedFieldOrder (nodeLbl, edgeLbl) payloadLbls) . Set.toList $ doCheck node) wgNodes + where + doCheck :: WorkflowGraphNode fileid userid -> Set (WorkflowGraphEdgeLabel, NonNull (MultiSet (WorkflowPayloadLabel))) + doCheck WGN{wgnEdges} = ifoldMap (\edgeLbl -> foldMap (Set.singleton . (edgeLbl, )) . doCheck') wgnEdges + where + doCheck' :: WorkflowGraphEdge fileid userid -> [NonNull (MultiSet WorkflowPayloadLabel)] + doCheck' wge = do + WorkflowGraphEdgeForm{wgefFields} <- hoistMaybe $ wge ^? _wgeForm + let MergeMap orderMap = ifoldMap go wgefFields + where + go :: WorkflowPayloadLabel + -> NonNull (Set (NonNull (Map WorkflowGraphEdgeFormOrder (WorkflowPayloadSpec fileid userid)))) + -> MergeMap WorkflowGraphEdgeFormOrder (NonNull (MultiSet WorkflowPayloadLabel)) + go payloadLbl = foldMap go' . map (Map.keysSet . toNullable) . Set.toList . toNullable + where + go' :: Set WorkflowGraphEdgeFormOrder + -> MergeMap WorkflowGraphEdgeFormOrder (NonNull (MultiSet WorkflowPayloadLabel)) + go' = foldMap $ \formOrder -> MergeMap . Map.singleton formOrder . impureNonNull $ MultiSet.singleton payloadLbl + filter ((> 1) . MultiSet.size . toNullable) $ Map.elems orderMap + checkNodeUnreachable WorkflowGraph{wgNodes} = foldMap (pure . WGLNodeUnreachable) $ Map.keysSet wgNodes `Set.difference` reachableNodes + where + initialNodes = Map.keysSet $ Map.filter isInitial wgNodes + where isInitial WGN{wgnEdges} = any (is _WorkflowGraphEdgeInitial) wgnEdges + reachableNodes = extendAfter graph initialNodes + checkNodeUnfinalizable WorkflowGraph{wgNodes} = foldMap (pure . WGLNodeUnfinalizable) $ Map.keysSet wgNodes `Set.difference` finalizableNodes + where + finalNodes = Map.keysSet $ Map.filter (has $ _wgnFinal . _Just) wgNodes + finalizableNodes = extendBefore graph finalNodes + +extendAfter, extendBefore :: forall fileid userid. WorkflowGraph fileid userid -> Set WorkflowGraphNodeLabel -> Set WorkflowGraphNodeLabel +extendAfter WorkflowGraph{wgNodes} = go Set.empty . Seq.fromList . Set.toList + where + go :: Set WorkflowGraphNodeLabel -- ^ Already known reachable + -> Seq WorkflowGraphNodeLabel -- ^ Queue to check + -> Set WorkflowGraphNodeLabel + go known Seq.Empty = known + go known (n Seq.:<| ns) + | n `Set.member` known = go known ns + | otherwise = go (Set.insert n known) $ ns `searchStrategy` nextNodes + where nextNodes = Map.keysSet $ Map.filter hasSource wgNodes + hasSource WGN{wgnEdges} = anyOf (folded . _wgeSource) (== n) wgnEdges +extendBefore WorkflowGraph{wgNodes} = go Set.empty . Seq.fromList . Set.toList + where + go :: Set WorkflowGraphNodeLabel + -> Seq WorkflowGraphNodeLabel + -> Set WorkflowGraphNodeLabel + go known Seq.Empty = known + go known (n Seq.:<| ns) + | n `Set.member` known = go known ns + | otherwise = go (Set.insert n known) $ ns `searchStrategy` prevNodes + where + prevNodes = flip foldMap (wgNodes Map.!? n) $ \WGN{wgnEdges} -> setOf (folded . _wgeSource) wgnEdges + +searchStrategy :: Seq WorkflowGraphNodeLabel -> Set WorkflowGraphNodeLabel -> Seq WorkflowGraphNodeLabel +-- ^ BFS +searchStrategy queue next = queue <> Seq.fromList (Set.toList next) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 40b90e616..f784485d6 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -39,6 +39,8 @@ import Utils.Workflow.Lint import System.Directory (getModificationTime) import System.FilePath.Glob (glob) +import System.IO (hPutStrLn) + testdataDir :: FilePath testdataDir = "testdata" @@ -1327,7 +1329,10 @@ fillDb = do liftIO . LBS.writeFile (testdataDir "bigAlloc_ordinal.csv") $ Csv.encode ordinalPriorities - do + let displayLinterIssue :: MonadIO m => WorkflowGraphLinterIssue -> m () + displayLinterIssue = liftIO . hPutStrLn stderr . displayException + + handleSql displayLinterIssue $ do workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir "theses.yaml" for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM let @@ -1363,7 +1368,7 @@ fillDb = do , workflowInstanceDescriptionDescription = Just "Hier können Sie Abschlussarbeiten bei der Prüfungsverwaltung angemeldet werden, der relevante Student die Arbeit digital abgeben und im Anschluss auch die Benotung an die Prüfungsverwaltung übermittelt werden." } - do + handleSql displayLinterIssue $ do workflowDefinitionGraph <- Yaml.decodeFileThrow $ testdataDir "recognitions-ifi.yaml" for_ (lintWorkflowGraph workflowDefinitionGraph) $ mapM_ throwM let diff --git a/wflint/WFLint.hs b/wflint/WFLint.hs new file mode 100644 index 000000000..38b86fb54 --- /dev/null +++ b/wflint/WFLint.hs @@ -0,0 +1,29 @@ +module WFLint + ( main + ) where + +import Import +import Utils.Workflow.Lint +import Handler.Utils.Workflow.Form (FormWorkflowGraph) + +import qualified Data.ByteString as ByteString +import qualified Data.Yaml as Yaml + +import System.IO (hPutStrLn) +import System.Exit + + +exitParseError, exitLintIssues :: Int +exitParseError = 2 +exitLintIssues = 3 + +die' :: (MonadIO m, Exception (Element mono), MonoFoldable mono) => Handle -> Int -> mono -> m a +die' h err excs = liftIO $ do + forM_ excs $ hPutStrLn h . displayException + exitWith $ ExitFailure err + +main :: IO () +main = do + mwf <- Yaml.decodeEither' <$> ByteString.getContents + (wf :: FormWorkflowGraph) <- either (die' stderr exitParseError . Identity) return mwf + for_ (lintWorkflowGraph wf) $ die' stdout exitLintIssues