diff --git a/src/Database/Persist/Local/Class/PersistEntityGraph.hs b/src/Database/Persist/Local/Class/PersistEntityGraph.hs new file mode 100644 index 0000000..745c682 --- /dev/null +++ b/src/Database/Persist/Local/Class/PersistEntityGraph.hs @@ -0,0 +1,27 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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) diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs index a9feb24..fb8c723 100644 --- a/src/Database/Persist/Local/Sql.hs +++ b/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' diff --git a/vervis.cabal b/vervis.cabal index bb31068..2d4b2e5 100644 --- a/vervis.cabal +++ b/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