From 8c1d4dd6f1aec0194466ae92c4fea7b1ba3caa1a Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
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 []