From 8c1d4dd6f1aec0194466ae92c4fea7b1ba3caa1a Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Fri, 15 Jul 2016 00:32:33 +0000 Subject: [PATCH] Transitive reduction of DAGs in SQL --- src/Database/Persist/Local/Sql.hs | 182 ++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs index 08ece15..88795f6 100644 --- a/src/Database/Persist/Local/Sql.hs +++ b/src/Database/Persist/Local/Sql.hs @@ -81,6 +81,9 @@ module Database.Persist.Local.Sql , rmpath , rpathm , rmpathm + -- * Transitive reduction of DAGs + , trrSelect + , trrApply ) where @@ -88,6 +91,7 @@ import Prelude import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT, ask) +import Data.Int (Int64) import Data.Monoid ((<>)) import Data.Proxy (Proxy) import Data.Text (Text) @@ -1322,3 +1326,181 @@ rmpathm -> Proxy (node, edge) -> ReaderT SqlBackend m [[Key node]] rmpathm = xmpathm FollowBackward [] + +-- | It more-or-less looks like this: +-- +-- > WITH RECURSIVE +-- > temp (id, path, cycle) AS ( +-- > SELECT node.id, ARRAY[node.id], FALSE +-- > FROM node +-- > UNION ALL +-- > SELECT edge.dest, +-- > temp.path || edge.dest, +-- > edge.dest = ANY(temp.path) +-- > FROM edge INNER JOIN temp +-- > ON edge.source = temp.id +-- > WHERE NOT temp.cycle +-- > ) +-- > SELECT * +-- > FROM edge +-- > +-- > EXCEPT +-- > +-- > SELECT e.* +-- > FROM edge AS pre +-- > INNER JOIN temp ON pre.dest = temp.path[1] +-- > INNER JOIN edge AS e ON e.source = pre.source AND e.dest = temp.id +-- > WHERE NOT temp.cycle +trrSelect + :: ( MonadIO m + , PersistEntityGraph node edge + , SqlBackend ~ PersistEntityBackend node + , SqlBackend ~ PersistEntityBackend edge + ) + => Proxy (node, edge) + -> ReaderT SqlBackend m [Entity edge] +trrSelect proxy = do + conn <- ask + let tNode = entityDef $ dummyFromFst proxy + tEdge = entityDef $ dummyFromSnd proxy + fwd = persistFieldDef $ destFieldFromProxy proxy + bwd = persistFieldDef $ sourceFieldFromProxy proxy + temp = DBName "temp_hierarchy_cte" + tid = DBName "id" + tpath = DBName "path" + tcycle = DBName "cycle" + edgeP = DBName "pre" + edgeE = DBName "e" + dbname = connEscapeName conn + ecols = T.intercalate ", " $ entityColumnNames tEdge conn + qecols name = + T.intercalate ", " $ + map ((dbname name <>) . ("." <>)) $ + entityColumnNames tEdge conn + t ^* f = dbname t <> "." <> dbname f + t <#> s = dbname t <> " INNER JOIN " <> dbname s + t <# s = dbname t <> " LEFT OUTER JOIN " <> dbname s + + sqlStep forward backward = mconcat + [ "SELECT " + , entityDB tEdge ^* fieldDB forward, ", " + , temp ^* tpath, " || ", entityDB tEdge ^* fieldDB forward, ", " + , entityDB tEdge ^* fieldDB forward, " = ANY(", temp ^* tpath, ")" + , " FROM ", entityDB tEdge <#> temp + , " ON ", entityDB tEdge ^* fieldDB backward, " = ", temp ^* tid + , " WHERE NOT " <> temp ^* tcycle + ] + + sql = mconcat + [ "WITH RECURSIVE " + , dbname temp + , " (" + , T.intercalate "," $ map dbname [tid, tpath, tcycle] + , ") AS ( SELECT " + , entityDB tNode ^* fieldDB (entityId tNode), ", " + , "ARRAY[", entityDB tNode ^* fieldDB (entityId tNode), "], " + , "FALSE" + , " FROM ", dbname $ entityDB tNode + , " WHERE ", entityDB tNode ^* fieldDB (entityId tNode) + , " IN ?" + , " UNION ALL " + , sqlStep fwd bwd + , " )" + , " SELECT ", ecols + , " FROM ", dbname $ entityDB tEdge + , " EXCEPT " + , " SELECT ", qecols edgeE + , " FROM ", dbname $ entityDB tEdge, " AS ", dbname edgeP + , " INNER JOIN ", dbname temp + , " ON ", edgeP ^* fieldDB fwd, " = ", temp ^* tpath, "[1]" + , " INNER JOIN ", dbname $ entityDB tEdge, " AS ", dbname edgeE + , " ON ", edgeE ^* fieldDB bwd, " = ", edgeP ^* fieldDB bwd + , " AND ", edgeE ^* fieldDB fwd, " = ", temp ^* tid + , " WHERE NOT ", temp ^* tcycle + ] + rawSql sql [] + +-- | It more-or-less looks like this: +-- +-- > WITH RECURSIVE +-- > temp (id, path, cycle) AS ( +-- > SELECT node.id, ARRAY[node.id], FALSE +-- > FROM node +-- > UNION ALL +-- > SELECT edge.dest, +-- > temp.path || edge.dest, +-- > edge.dest = ANY(temp.path) +-- > FROM edge INNER JOIN temp +-- > ON edge.source = temp.id +-- > WHERE NOT temp.cycle +-- > ) +-- > DELETE FROM edge +-- > WHERE id IN ( +-- > SELECT e.id +-- > FROM edge AS pre +-- > INNER JOIN temp ON pre.dest = temp.path[1] +-- > INNER JOIN edge AS e ON e.source = pre.source AND e.dest = temp.id +-- > WHERE NOT temp.cycle +-- > ) +trrApply + :: ( MonadIO m + , PersistEntityGraph node edge + , SqlBackend ~ PersistEntityBackend node + , SqlBackend ~ PersistEntityBackend edge + ) + => Proxy (node, edge) + -> ReaderT SqlBackend m Int64 +trrApply proxy = do + conn <- ask + let tNode = entityDef $ dummyFromFst proxy + tEdge = entityDef $ dummyFromSnd proxy + fwd = persistFieldDef $ destFieldFromProxy proxy + bwd = persistFieldDef $ sourceFieldFromProxy proxy + temp = DBName "temp_hierarchy_cte" + tid = DBName "id" + tpath = DBName "path" + tcycle = DBName "cycle" + edgeP = DBName "pre" + edgeE = DBName "e" + dbname = connEscapeName conn + t ^* f = dbname t <> "." <> dbname f + t <#> s = dbname t <> " INNER JOIN " <> dbname s + t <# s = dbname t <> " LEFT OUTER JOIN " <> dbname s + + sqlStep forward backward = mconcat + [ "SELECT " + , entityDB tEdge ^* fieldDB forward, ", " + , temp ^* tpath, " || ", entityDB tEdge ^* fieldDB forward, ", " + , entityDB tEdge ^* fieldDB forward, " = ANY(", temp ^* tpath, ")" + , " FROM ", entityDB tEdge <#> temp + , " ON ", entityDB tEdge ^* fieldDB backward, " = ", temp ^* tid + , " WHERE NOT " <> temp ^* tcycle + ] + + sql = mconcat + [ "WITH RECURSIVE " + , dbname temp + , " (" + , T.intercalate "," $ map dbname [tid, tpath, tcycle] + , ") AS ( SELECT " + , entityDB tNode ^* fieldDB (entityId tNode), ", " + , "ARRAY[", entityDB tNode ^* fieldDB (entityId tNode), "], " + , "FALSE" + , " FROM ", dbname $ entityDB tNode + , " WHERE ", entityDB tNode ^* fieldDB (entityId tNode) + , " IN ?" + , " UNION ALL " + , sqlStep fwd bwd + , " ) DELETE FROM ", dbname $ entityDB tEdge + , " WHERE ", entityDB tEdge ^* fieldDB (entityId tEdge), " IN (" + , " SELECT ", edgeE ^* fieldDB (entityId tEdge) + , " FROM ", dbname $ entityDB tEdge, " AS ", dbname edgeP + , " INNER JOIN ", dbname temp + , " ON ", edgeP ^* fieldDB fwd, " = ", temp ^* tpath, "[1]" + , " INNER JOIN ", dbname $ entityDB tEdge, " AS ", dbname edgeE + , " ON ", edgeE ^* fieldDB bwd, " = ", edgeP ^* fieldDB bwd + , " AND ", edgeE ^* fieldDB fwd, " = ", temp ^* tid + , " WHERE NOT ", temp ^* tcycle + , " )" + ] + rawExecuteCount sql []