DB graph cycle existence checking using recursive SQL query

This commit is contained in:
fr33domlover 2016-07-05 08:46:58 +00:00
parent fcb68ceea7
commit 879ad873e3
3 changed files with 227 additions and 1 deletions

View file

@ -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)

View file

@ -16,6 +16,7 @@
module Database.Persist.Local.Sql module Database.Persist.Local.Sql
( dummyFromField ( dummyFromField
, rawSqlWithGraph , rawSqlWithGraph
, containsCycle
) )
where where
@ -24,6 +25,7 @@ import Prelude
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Reader (ReaderT, ask) import Control.Monad.Trans.Reader (ReaderT, ask)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Proxy (Proxy)
import Data.Text (Text) import Data.Text (Text)
import Database.Persist import Database.Persist
import Database.Persist.Sql import Database.Persist.Sql
@ -31,6 +33,7 @@ import Database.Persist.Sql.Util
import qualified Data.Text as T (intercalate) import qualified Data.Text as T (intercalate)
import Database.Persist.Local.Class.PersistEntityGraph
import Database.Persist.Local.Class.PersistQueryForest import Database.Persist.Local.Class.PersistQueryForest
import Database.Persist.Local.Sql.Orphan.Common import Database.Persist.Local.Sql.Orphan.Common
@ -40,6 +43,24 @@ dummyFromKey _ = Nothing
dummyFromField :: EntityField val t -> Maybe val dummyFromField :: EntityField val t -> Maybe val
dummyFromField _ = Nothing 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 rawSqlWithGraph
:: ( RawSql a :: ( RawSql a
, MonadIO m , MonadIO m
@ -103,3 +124,179 @@ rawSqlWithGraph dir root parent child sub vals = do
sql = sqlWith <> sub temp sql = sqlWith <> sub temp
vals' = toPersistValue root : vals vals' = toPersistValue root : vals
rawSql sql 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'

View file

@ -53,6 +53,7 @@ library
Data.EventTime.Local Data.EventTime.Local
Data.Functor.Local Data.Functor.Local
Data.Git.Local Data.Git.Local
Data.Graph.Inductive.Query.Cycle
Data.Graph.Inductive.Query.Layer Data.Graph.Inductive.Query.Layer
Data.HashMap.Lazy.Local Data.HashMap.Lazy.Local
Data.Hourglass.Local Data.Hourglass.Local
@ -66,6 +67,7 @@ library
Database.Esqueleto.Local Database.Esqueleto.Local
Database.Persist.Class.Local Database.Persist.Class.Local
Database.Persist.Sql.Local Database.Persist.Sql.Local
Database.Persist.Local.Class.PersistEntityGraph
Database.Persist.Local.Class.PersistQueryForest Database.Persist.Local.Class.PersistQueryForest
Database.Persist.Local.RecursionDoc Database.Persist.Local.RecursionDoc
Database.Persist.Local.Sql Database.Persist.Local.Sql