DB graph cycle existence checking using recursive SQL query

src/Database/Persist/Local/Class/PersistEntityGraph.hs

@@ -0,0 +1,27 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Database.Persist.Local.Class.PersistEntityGraph
+    ( PersistEntityGraph (..)
+    )
+where
+
+import Prelude
+
+import Database.Persist
+
+class (PersistEntity n, PersistEntity e) => PersistEntityGraph n e where
+    parentField :: EntityField e (Key n)
+    childField  :: EntityField e (Key n)

src/Database/Persist/Local/Sql.hs

@@ -16,6 +16,7 @@
 module Database.Persist.Local.Sql
     ( dummyFromField
     , rawSqlWithGraph
+    , containsCycle
     )
 where
 
@@ -24,6 +25,7 @@ import Prelude
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Trans.Reader (ReaderT, ask)
 import Data.Monoid ((<>))
+import Data.Proxy (Proxy)
 import Data.Text (Text)
 import Database.Persist
 import Database.Persist.Sql
@@ -31,6 +33,7 @@ import Database.Persist.Sql.Util
 
 import qualified Data.Text as T (intercalate)
 
+import Database.Persist.Local.Class.PersistEntityGraph
 import Database.Persist.Local.Class.PersistQueryForest
 import Database.Persist.Local.Sql.Orphan.Common
 
@@ -40,6 +43,24 @@ dummyFromKey _ = Nothing
 dummyFromField :: EntityField val t -> Maybe val
 dummyFromField _ = Nothing
 
+dummyFromFst :: Proxy (a, b) -> Maybe a
+dummyFromFst _ = Nothing
+
+dummyFromSnd :: Proxy (a, b) -> Maybe b
+dummyFromSnd _ = Nothing
+
+childFieldFromProxy
+    :: PersistEntityGraph node edge
+    => Proxy (node, edge)
+    -> EntityField edge (Key node)
+childFieldFromProxy _ = childField
+
+parentFieldFromProxy
+    :: PersistEntityGraph node edge
+    => Proxy (node, edge)
+    -> EntityField edge (Key node)
+parentFieldFromProxy _ = parentField
+
 rawSqlWithGraph
     :: ( RawSql a
        , MonadIO m
@@ -103,3 +124,179 @@ rawSqlWithGraph dir root parent child sub vals = do
         sql = sqlWith <> sub temp
         vals' = toPersistValue root : vals
     rawSql sql vals'
+
+containsCycle'
+    :: ( MonadIO m
+       , PersistEntity node
+       , PersistEntity edge
+       , PersistEntityGraph node edge
+       , SqlBackend ~ PersistEntityBackend node
+       , SqlBackend ~ PersistEntityBackend edge
+       )
+    => Proxy (node, edge)
+    -> ReaderT SqlBackend m [Single Int]
+containsCycle' proxy = do
+    conn <- ask
+    let tNode = entityDef $ dummyFromFst proxy
+        tEdge = entityDef $ dummyFromSnd proxy
+        fwd = childFieldFromProxy proxy
+        bwd = parentFieldFromProxy proxy
+        start = DBName "temp_start_cte"
+        temp = DBName "temp_hierarchy_cte"
+        tid = DBName "id"
+        tpath = DBName "path"
+        tcycle = DBName "cycle"
+        dbname = connEscapeName conn
+        sql = mconcat
+            [ "WITH RECURSIVE "
+            , dbname start
+            , " ("
+            , T.intercalate "," $ map dbname [tid, tpath, tcycle]
+            , ") AS ( SELECT "
+                , dbname $ entityDB tNode
+                , "."
+                , dbname $ fieldDB $ entityId tNode
+
+                , ", "
+
+                , "ARRAY["
+                , dbname $ entityDB tNode
+                , "."
+                , dbname $ fieldDB $ entityId tNode
+                , "]"
+
+                , ", "
+
+                , "FALSE"
+
+                , " FROM "
+                , dbname $ entityDB tNode
+                , " LEFT OUTER JOIN "
+                , dbname $ entityDB tEdge
+                , " ON "
+
+                , dbname $ entityDB tNode
+                , "."
+                , dbname $ fieldDB $ entityId tNode
+
+                , " = "
+
+                , dbname $ entityDB tEdge
+                , "."
+                , dbname $ fieldDB $ persistFieldDef fwd
+
+                , " WHERE "
+                , dbname $ entityDB tEdge
+                , "."
+                , dbname $ fieldDB $ persistFieldDef fwd
+                , " IS NULL "
+            , " ), "
+            , dbname temp
+            , " ("
+            , T.intercalate "," $ map dbname [tid, tpath, tcycle]
+            , ") AS ( SELECT "
+                , "* FROM "
+                , dbname start
+
+            , " UNION ALL SELECT "
+                , dbname $ entityDB tEdge
+                , "."
+                , dbname $ fieldDB $ persistFieldDef fwd
+
+                , ", "
+
+                , dbname temp
+                , "."
+                , dbname tpath
+                , " || "
+                , dbname $ entityDB tEdge
+                , "."
+                , dbname $ fieldDB $ persistFieldDef fwd
+
+                , ", "
+
+                , dbname $ entityDB tEdge
+                , "."
+                , dbname $ fieldDB $ persistFieldDef fwd
+                , " = "
+                , "ANY(", dbname temp, ".", dbname tpath, ")"
+
+                , " FROM "
+                , dbname $ entityDB tEdge
+                , " INNER JOIN "
+                , dbname temp
+                , " ON "
+
+                , dbname $ entityDB tEdge
+                , "."
+                , dbname $ fieldDB $ persistFieldDef bwd
+
+                , " = "
+
+                , dbname temp, ".", dbname tid
+
+                , " WHERE NOT "
+                , dbname temp, ".", dbname tcycle
+            , " ) "
+
+            , "("
+                , "SELECT 1 FROM "
+                , dbname start
+
+                , " UNION ALL "
+
+                , "SELECT 1 FROM "
+                , dbname temp
+                , " WHERE ", dbname tcycle, " = TRUE"
+            , ") LIMIT 1"
+            ]
+    rawSql sql []
+
+-- | Check whether the graph contains (directed) cycles.
+--
+-- Start with nodes which don't have in-edges, and traverse through the edges,
+-- either until we visit all the nodes, or until we find a node we visited
+-- before. If we can't find nodes without in-edges, or we found a node we
+-- visited before, then a cycle exists.
+--
+-- > WITH RECURSIVE
+-- >   start (id, path, cycle) AS (
+-- >       SELECT node.id, ARRAY[node.id], false
+-- >       FROM node LEFT OUTER JOIN edge
+-- >       ON node.id = edge.parent
+-- >       WHERE edge.parent IS NULL
+-- >   ),
+-- >   temp (id, path, cycle) AS (
+-- >       SELECT * from start
+-- >     UNION ALL
+-- >       SELECT edge.parent,
+-- >              temp.path || edge.parent,
+-- >              edge.parent = ANY(temp.path)
+-- >       FROM edge INNER JOIN temp
+-- >       ON edge.child = temp.id
+-- >       WHERE NOT temp.cycle
+-- >   )
+-- > ( SELECT 1
+-- >   FROM start
+-- >   UNION ALL
+-- >   SELECT 1
+-- >   FROM temp
+-- >   WHERE cycle = true
+-- > )
+-- > LIMIT 1
+--
+-- The parent and child fields are interchangeable, which is an opportunity to
+-- optimize. Currently the recursion goes from parents to children (i.e.
+-- towards decendants), but it could be changed, or made available for the user
+-- to choose, if benchmarks reveal performace differences.
+containsCycle
+    :: ( MonadIO m
+       , PersistEntity node
+       , PersistEntity edge
+       , PersistEntityGraph node edge
+       , SqlBackend ~ PersistEntityBackend node
+       , SqlBackend ~ PersistEntityBackend edge
+       )
+    => Proxy (node, edge)
+    -> ReaderT SqlBackend m Bool
+containsCycle = fmap (not . null) . containsCycle'

vervis.cabal

@@ -53,6 +53,7 @@ library
                        Data.EventTime.Local
                        Data.Functor.Local
                        Data.Git.Local
+                       Data.Graph.Inductive.Query.Cycle
                        Data.Graph.Inductive.Query.Layer
                        Data.HashMap.Lazy.Local
                        Data.Hourglass.Local
@@ -66,6 +67,7 @@ library
                        Database.Esqueleto.Local
                        Database.Persist.Class.Local
                        Database.Persist.Sql.Local
+                       Database.Persist.Local.Class.PersistEntityGraph
                        Database.Persist.Local.Class.PersistQueryForest
                        Database.Persist.Local.RecursionDoc
                        Database.Persist.Local.Sql
@@ -333,7 +335,7 @@ test-suite test
                      , classy-prelude
                      , classy-prelude-yesod
                      , aeson
-  hs-source-dirs:    test
+  hs-source-dirs:      test
   default-language:    Haskell2010
   ghc-options:       -Wall
   type:              exitcode-stdio-1.0