feat(workflows): improve linter

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:

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)

src/Handler/Utils/Workflow/Form.hs

@@ -1,6 +1,6 @@
 module Handler.Utils.Workflow.Form
   ( FileIdent
-  , WorkflowGraphForm(..)
+  , WorkflowGraphForm(..), FormWorkflowGraph
   , workflowGraphForm
   , toWorkflowGraphForm, fromWorkflowGraphForm
   , WorkflowDescriptionsFormScope(..)

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)

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

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)

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

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