DB graph cycle existence checking using recursive SQL query
This commit is contained in:
fr33domlover
parent
fcb68ceea7
commit
879ad873e3
3 changed files with 227 additions and 1 deletions
27
src/Database/Persist/Local/Class/PersistEntityGraph.hs
Normal file
27
src/Database/Persist/Local/Class/PersistEntityGraph.hs
Normal 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)
|
||||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue