mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 16:44:52 +09:00
Split recursive SQL query huge module into smaller modules
This commit is contained in:
fr33domlover
parent
8c1d4dd6f1
commit
a41f111bee
7 changed files with 1567 additions and 1372 deletions
File diff suppressed because it is too large
Load diff
403
src/Database/Persist/Sql/Graph/Connects.hs
Normal file
403
src/Database/Persist/Sql/Graph/Connects.hs
Normal file
|
|
@ -0,0 +1,403 @@
|
|||
{- 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.Sql.Graph.Connects
|
||||
( -- * Checking for reachability, i.e. existence of path
|
||||
-- $connects
|
||||
-- ** Standard
|
||||
connects
|
||||
, mconnects
|
||||
, connectsm
|
||||
, mconnectsm
|
||||
, xconnects
|
||||
, xmconnects
|
||||
, xconnectsm
|
||||
, xmconnectsm
|
||||
-- ** Undirected
|
||||
, uconnects
|
||||
, umconnects
|
||||
, uconnectsm
|
||||
, umconnectsm
|
||||
-- ** Reversed
|
||||
, rconnects
|
||||
, rmconnects
|
||||
, rconnectsm
|
||||
, rmconnectsm
|
||||
)
|
||||
where
|
||||
|
||||
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)
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Database.Persist.Sql.Util
|
||||
|
||||
import qualified Data.Text as T (null, intercalate)
|
||||
|
||||
import Database.Persist.Local.Class.PersistEntityGraph
|
||||
import Database.Persist.Local.Class.PersistQueryForest
|
||||
import Database.Persist.Local.Sql
|
||||
import Database.Persist.Local.Sql.Orphan.Common
|
||||
|
||||
-- $connects
|
||||
-- Testing for existence of paths.
|
||||
--
|
||||
-- Names consist of:
|
||||
--
|
||||
-- 1. An optional direction parameter, specifying which nodes to visit next.
|
||||
--
|
||||
-- [(none)] forward: follow edge direction
|
||||
-- [@u@] undirectional: ignore edge direction
|
||||
-- [@r@] reversed: walk edges in reverse
|
||||
-- [@x@] user defined: specify which paths to follow
|
||||
--
|
||||
-- 2. An optional source node parameter, specifying from which nodes to start
|
||||
-- the search.
|
||||
--
|
||||
-- [(none)] one: start with a single specified node
|
||||
-- [@m@] multi: start with a given list of nodes, or /all/ nodes
|
||||
--
|
||||
-- 3. Base name: @connects@.
|
||||
--
|
||||
-- 4. An optional destination node parameter, specifying which paths to pick
|
||||
-- based on their destination nodes.
|
||||
--
|
||||
-- [(none)] one: start with a single specified node
|
||||
-- [@m@] multi: start with a given list of nodes, or /all/ nodes
|
||||
|
||||
-- | It more-or-less looks like this:
|
||||
--
|
||||
-- > WITH RECURSIVE
|
||||
-- > temp (id, path, cycle) AS (
|
||||
-- > SELECT 3, ARRAY[3], false
|
||||
-- > 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 WHERE EXISTS (
|
||||
-- > SELECT path
|
||||
-- > FROM temp
|
||||
-- > WHERE id = 8
|
||||
-- > )
|
||||
xmconnectsm'
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int -- filter on path length max
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Single Int]
|
||||
xmconnectsm' follow filter msource mdest mlen 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"
|
||||
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
|
||||
|
||||
filt = filterClause False conn filter
|
||||
fvals = getFiltsValues conn filter
|
||||
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
|
||||
, if T.null filt
|
||||
then " WHERE NOT " <> temp ^* tcycle
|
||||
else filt <> " AND 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"
|
||||
, case msource of
|
||||
Nothing -> " FROM " <> dbname (entityDB tNode)
|
||||
Just _ -> mconcat
|
||||
[ " FROM ", dbname $ entityDB tNode
|
||||
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
||||
, " IN ?"
|
||||
]
|
||||
, " UNION ALL "
|
||||
, case follow of
|
||||
FollowForward -> sqlStep fwd bwd
|
||||
FollowBackward -> sqlStep bwd fwd
|
||||
FollowBoth -> mconcat
|
||||
[ "("
|
||||
, sqlStep fwd bwd
|
||||
, " UNION ALL "
|
||||
, sqlStep bwd fwd
|
||||
, ")"
|
||||
]
|
||||
, " ) SELECT 1 WHERE EXISTS ( SELECT ", temp ^* tpath
|
||||
, " FROM ", dbname temp
|
||||
, case mdest of
|
||||
Nothing -> ""
|
||||
Just _ -> " WHERE ", temp ^* tid, " IN ?"
|
||||
, case mlen of
|
||||
Nothing -> ""
|
||||
Just _ -> " AND array_length(", temp ^* tpath, ", 1) <= ?"
|
||||
, " )"
|
||||
]
|
||||
toP = fmap toPersistValue
|
||||
toPL = fmap $ PersistList . map toPersistValue
|
||||
vals = toPL msource ?: fvals ++ toPL mdest ?: toP mlen ?: []
|
||||
rawSql sql vals
|
||||
|
||||
connects
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
connects = xconnects FollowForward []
|
||||
|
||||
mconnects
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
mconnects = xmconnects FollowForward []
|
||||
|
||||
connectsm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
connectsm = xconnectsm FollowForward []
|
||||
|
||||
mconnectsm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
mconnectsm = xmconnectsm FollowForward []
|
||||
|
||||
xconnects
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Key node
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
xconnects fw flt src dest = xmconnectsm fw flt (Just [src]) (Just [dest])
|
||||
|
||||
xmconnects
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Maybe [Key node]
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
xmconnects fw flt msrc dest = xmconnectsm fw flt msrc (Just [dest])
|
||||
|
||||
xconnectsm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Key node
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
xconnectsm fw flt src = xmconnectsm fw flt (Just [src])
|
||||
|
||||
xmconnectsm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
xmconnectsm fw flt msrc mdest mlen p =
|
||||
not . null <$> xmconnectsm' fw flt msrc mdest mlen p
|
||||
|
||||
uconnects
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
uconnects = xconnects FollowBoth []
|
||||
|
||||
umconnects
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
umconnects = xmconnects FollowBoth []
|
||||
|
||||
uconnectsm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
uconnectsm = xconnectsm FollowBoth []
|
||||
|
||||
umconnectsm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
umconnectsm = xmconnectsm FollowBoth []
|
||||
|
||||
rconnects
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
rconnects = xconnects FollowBackward []
|
||||
|
||||
rmconnects
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
rmconnects = xmconnects FollowBackward []
|
||||
|
||||
rconnectsm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
rconnectsm = xconnectsm FollowBackward []
|
||||
|
||||
rmconnectsm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
rmconnectsm = xmconnectsm FollowBackward []
|
||||
311
src/Database/Persist/Sql/Graph/Cyclic.hs
Normal file
311
src/Database/Persist/Sql/Graph/Cyclic.hs
Normal file
|
|
@ -0,0 +1,311 @@
|
|||
{- 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.Sql.Graph.Cyclic
|
||||
( -- * Checking for cycle existence
|
||||
-- $cyclic
|
||||
-- ** Standard
|
||||
cyclic
|
||||
, cyclicn
|
||||
, xcyclic
|
||||
, xcyclicn
|
||||
-- ** Undirected
|
||||
, ucyclic
|
||||
, ucyclicn
|
||||
-- ** Reversed
|
||||
, rcyclic
|
||||
, rcyclicn
|
||||
)
|
||||
where
|
||||
|
||||
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)
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Database.Persist.Sql.Util
|
||||
|
||||
import qualified Data.Text as T (null, intercalate)
|
||||
|
||||
import Database.Persist.Local.Class.PersistEntityGraph
|
||||
import Database.Persist.Local.Class.PersistQueryForest
|
||||
import Database.Persist.Local.Sql
|
||||
import Database.Persist.Local.Sql.Orphan.Common
|
||||
|
||||
-- | The actual SQL query for checking for cycles. It's a bit hard to figure
|
||||
-- out the structure of the query from the code, so here's what it more-or-less
|
||||
-- looks like, to help navigate the code:
|
||||
--
|
||||
-- > 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 node LEFT OUTER JOIN temp
|
||||
-- > ON node.id = temp.id
|
||||
-- > WHERE temp.id IS NULL
|
||||
-- > UNION ALL
|
||||
-- > SELECT 1
|
||||
-- > FROM temp
|
||||
-- > WHERE cycle = true
|
||||
-- > )
|
||||
-- > LIMIT 1
|
||||
xcyclicn'
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Maybe [Key node]
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Single Int]
|
||||
xcyclicn' follow filter minitials proxy = do
|
||||
conn <- ask
|
||||
let tNode = entityDef $ dummyFromFst proxy
|
||||
tEdge = entityDef $ dummyFromSnd proxy
|
||||
fwd = persistFieldDef $ destFieldFromProxy proxy
|
||||
bwd = persistFieldDef $ sourceFieldFromProxy proxy
|
||||
start = DBName "temp_start_cte"
|
||||
temp = DBName "temp_hierarchy_cte"
|
||||
tid = DBName "id"
|
||||
tpath = DBName "path"
|
||||
tcycle = DBName "cycle"
|
||||
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
|
||||
|
||||
sqlStartFrom forward = mconcat
|
||||
[ " FROM ", entityDB tNode <# entityDB tEdge
|
||||
, " ON "
|
||||
, entityDB tNode ^* fieldDB (entityId tNode)
|
||||
, " = "
|
||||
, entityDB tEdge ^* fieldDB forward
|
||||
|
||||
, " WHERE "
|
||||
, entityDB tEdge ^* fieldDB forward
|
||||
, " IS NULL"
|
||||
]
|
||||
|
||||
sqlStart = mconcat
|
||||
[ "SELECT "
|
||||
, entityDB tNode ^* fieldDB (entityId tNode), ", "
|
||||
, "ARRAY[", entityDB tNode ^* fieldDB (entityId tNode), "], "
|
||||
, "FALSE"
|
||||
, case minitials of
|
||||
Nothing -> case follow of
|
||||
FollowForward -> sqlStartFrom fwd
|
||||
FollowBackward -> sqlStartFrom bwd
|
||||
FollowBoth -> " FROM " <> dbname (entityDB tNode)
|
||||
Just initials -> mconcat
|
||||
[ " FROM ", dbname $ entityDB tNode
|
||||
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
||||
, " IN ?"
|
||||
]
|
||||
]
|
||||
|
||||
filt = filterClause False conn filter
|
||||
fvals = getFiltsValues conn filter
|
||||
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
|
||||
, if T.null filt
|
||||
then " WHERE NOT " <> temp ^* tcycle
|
||||
else filt <> " AND NOT " <> temp ^* tcycle
|
||||
]
|
||||
|
||||
sqlCycles = mconcat
|
||||
[ "SELECT 1 FROM "
|
||||
, dbname temp
|
||||
, " WHERE ", dbname tcycle, " = TRUE"
|
||||
]
|
||||
|
||||
sql = mconcat
|
||||
[ "WITH RECURSIVE "
|
||||
, dbname start
|
||||
, " ("
|
||||
, T.intercalate "," $ map dbname [tid, tpath, tcycle]
|
||||
, ") AS ( "
|
||||
, sqlStart
|
||||
, " ), "
|
||||
, dbname temp
|
||||
, " ("
|
||||
, T.intercalate "," $ map dbname [tid, tpath, tcycle]
|
||||
, ") AS ( SELECT "
|
||||
, "* FROM "
|
||||
, dbname start
|
||||
|
||||
, " UNION ALL "
|
||||
, case follow of
|
||||
FollowForward -> sqlStep fwd bwd
|
||||
FollowBackward -> sqlStep bwd fwd
|
||||
FollowBoth -> mconcat
|
||||
[ "("
|
||||
, sqlStep fwd bwd
|
||||
, " UNION ALL "
|
||||
, sqlStep bwd fwd
|
||||
, ")"
|
||||
]
|
||||
, " ) "
|
||||
, case follow of
|
||||
FollowBoth -> sqlCycles <> " LIMIT 1"
|
||||
_ -> case minitials of
|
||||
Just _ -> sqlCycles <> " LIMIT 1"
|
||||
Nothing -> mconcat
|
||||
[ "(", sqlCycles, " UNION ALL "
|
||||
, "SELECT 1"
|
||||
, " FROM ", entityDB tNode <# temp
|
||||
, " ON "
|
||||
, entityDB tNode ^* fieldDB (entityId tNode)
|
||||
, " = "
|
||||
, temp ^* tid
|
||||
, " WHERE ", temp ^* tid, " IS NULL"
|
||||
, ") LIMIT 1"
|
||||
]
|
||||
]
|
||||
msval = PersistList . map toPersistValue <$> minitials
|
||||
vals = maybe id (:) msval fvals
|
||||
rawSql sql vals
|
||||
|
||||
-- $cyclic
|
||||
-- Testing for and detecting cycles in graphs.
|
||||
--
|
||||
-- Names consist of:
|
||||
--
|
||||
-- 1. An optional direction parameter, specifying which nodes to visit next.
|
||||
--
|
||||
-- [@u@] undirectional: ignore edge direction
|
||||
-- [@r@] reversed: walk edges in reverse
|
||||
-- [@x@] user defined: specify which paths to follow
|
||||
--
|
||||
-- 2. Base name.
|
||||
--
|
||||
-- [@cyclic@] checks for existence of cycles
|
||||
-- [@cycles@] returns the cyclic paths, if any exist
|
||||
--
|
||||
-- 3. An optional @n@, in which case a user-given subset of the graph's nodes
|
||||
-- will be visited, instead of visiting /all/ the nodes.
|
||||
|
||||
cyclic
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
cyclic = xcyclic FollowForward []
|
||||
|
||||
cyclicn
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> [Key node]
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
cyclicn = xcyclicn FollowForward []
|
||||
|
||||
xcyclic
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
xcyclic fw flt = fmap (not . null) . xcyclicn' fw flt Nothing
|
||||
|
||||
xcyclicn
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> [Key node]
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
xcyclicn fw flt ns = fmap (not . null) . xcyclicn' fw flt (Just ns)
|
||||
|
||||
ucyclic
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
ucyclic = xcyclic FollowBoth []
|
||||
|
||||
ucyclicn
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> [Key node]
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
ucyclicn = xcyclicn FollowBoth []
|
||||
|
||||
rcyclic
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
rcyclic = xcyclic FollowBackward []
|
||||
|
||||
rcyclicn
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> [Key node]
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m Bool
|
||||
rcyclicn = xcyclicn FollowBackward []
|
||||
423
src/Database/Persist/Sql/Graph/Path.hs
Normal file
423
src/Database/Persist/Sql/Graph/Path.hs
Normal file
|
|
@ -0,0 +1,423 @@
|
|||
{- 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.Sql.Graph.Path
|
||||
( -- * Finding paths
|
||||
-- $path
|
||||
-- ** Standard
|
||||
path
|
||||
, mpath
|
||||
, pathm
|
||||
, mpathm
|
||||
, xpath
|
||||
, xmpath
|
||||
, xpathm
|
||||
, xmpathm
|
||||
-- ** Undirected
|
||||
, upath
|
||||
, umpath
|
||||
, upathm
|
||||
, umpathm
|
||||
-- ** Reversed
|
||||
, rpath
|
||||
, rmpath
|
||||
, rpathm
|
||||
, rmpathm
|
||||
)
|
||||
where
|
||||
|
||||
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)
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Database.Persist.Sql.Util
|
||||
|
||||
import qualified Data.Text as T (null, intercalate)
|
||||
|
||||
import Database.Persist.Local.Class.PersistEntityGraph
|
||||
import Database.Persist.Local.Class.PersistQueryForest
|
||||
import Database.Persist.Local.Sql
|
||||
import Database.Persist.Local.Sql.Orphan.Common
|
||||
|
||||
-- $path
|
||||
-- Findings paths between graph nodes.
|
||||
--
|
||||
-- Names consist of:
|
||||
--
|
||||
-- 1. An optional direction parameter, specifying which nodes to visit next.
|
||||
--
|
||||
-- [(none)] forward: follow edge direction
|
||||
-- [@u@] undirectional: ignore edge direction
|
||||
-- [@r@] reversed: walk edges in reverse
|
||||
-- [@x@] user defined: specify which paths to follow
|
||||
--
|
||||
-- 2. An optional source node parameter, specifying from which nodes to start
|
||||
-- the search.
|
||||
--
|
||||
-- [(none)] one: start with a single specified node
|
||||
-- [@m@] multi: start with a given list of nodes, or /all/ nodes
|
||||
--
|
||||
-- 3. Base name: @path@.
|
||||
--
|
||||
-- 4. An optional destination node parameter, specifying which paths to pick
|
||||
-- based on their destination nodes.
|
||||
--
|
||||
-- [(none)] one: start with a single specified node
|
||||
-- [@m@] multi: start with a given list of nodes, or /all/ nodes
|
||||
|
||||
-- | It more-or-less looks like this:
|
||||
--
|
||||
-- > WITH RECURSIVE
|
||||
-- > temp (id, path, cycle) AS (
|
||||
-- > SELECT 3, ARRAY[3], false
|
||||
-- > 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 path
|
||||
-- > FROM temp
|
||||
-- > WHERE id = 8
|
||||
-- > ORDER BY array_length(path, 1)
|
||||
xmpathm'
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int -- filter on path length max
|
||||
-> Maybe Int -- limit number of results
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Single [Key node]]
|
||||
xmpathm' follow filter msource mdest mlen mlim 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"
|
||||
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
|
||||
|
||||
filt = filterClause False conn filter
|
||||
fvals = getFiltsValues conn filter
|
||||
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
|
||||
, if T.null filt
|
||||
then " WHERE NOT " <> temp ^* tcycle
|
||||
else filt <> " AND 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"
|
||||
, case msource of
|
||||
Nothing -> " FROM " <> dbname (entityDB tNode)
|
||||
Just _ -> mconcat
|
||||
[ " FROM ", dbname $ entityDB tNode
|
||||
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
||||
, " IN ?"
|
||||
]
|
||||
, " UNION ALL "
|
||||
, case follow of
|
||||
FollowForward -> sqlStep fwd bwd
|
||||
FollowBackward -> sqlStep bwd fwd
|
||||
FollowBoth -> mconcat
|
||||
[ "("
|
||||
, sqlStep fwd bwd
|
||||
, " UNION ALL "
|
||||
, sqlStep bwd fwd
|
||||
, ")"
|
||||
]
|
||||
, " ) SELECT ", temp ^* tpath
|
||||
, " FROM ", dbname temp
|
||||
, case mdest of
|
||||
Nothing -> ""
|
||||
Just _ -> " WHERE ", temp ^* tid, " IN ?"
|
||||
, case mlen of
|
||||
Nothing -> ""
|
||||
Just _ -> " AND array_length(", temp ^* tpath, ", 1) <= ?"
|
||||
, " ORDER BY array_length(", temp ^* tpath, ", 1)"
|
||||
, case mlim of
|
||||
Nothing -> ""
|
||||
Just _ -> " LIMIT ?"
|
||||
]
|
||||
toP = fmap toPersistValue
|
||||
toPL = fmap $ PersistList . map toPersistValue
|
||||
vals =
|
||||
toPL msource ?: fvals ++ toPL mdest ?: toP mlen ?: toP mlim ?: []
|
||||
rawSql sql vals
|
||||
|
||||
path
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
path = xpath FollowForward []
|
||||
|
||||
mpath
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
mpath = xmpath FollowForward []
|
||||
|
||||
pathm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
pathm = xpathm FollowForward []
|
||||
|
||||
mpathm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
mpathm = xmpathm FollowForward []
|
||||
|
||||
xpath
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Key node
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
xpath fw flt src dest = xmpathm fw flt (Just [src]) (Just [dest])
|
||||
|
||||
xmpath
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Maybe [Key node]
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
xmpath fw flt msrc dest = xmpathm fw flt msrc (Just [dest])
|
||||
|
||||
xpathm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Key node
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
xpathm fw flt src = xmpathm fw flt (Just [src])
|
||||
|
||||
xmpathm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
xmpathm fw flt msrc mdest mlen mlim p =
|
||||
map unSingle <$> xmpathm' fw flt msrc mdest mlen mlim p
|
||||
|
||||
upath
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
upath = xpath FollowBoth []
|
||||
|
||||
umpath
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
umpath = xmpath FollowBoth []
|
||||
|
||||
upathm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
upathm = xpathm FollowBoth []
|
||||
|
||||
umpathm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
umpathm = xmpathm FollowBoth []
|
||||
|
||||
rpath
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
rpath = xpath FollowBackward []
|
||||
|
||||
rmpath
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Key node
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
rmpath = xmpath FollowBackward []
|
||||
|
||||
rpathm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Key node
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
rpathm = xpathm FollowBackward []
|
||||
|
||||
rmpathm
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> Maybe [Key node]
|
||||
-> Maybe [Key node]
|
||||
-> Maybe Int
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [[Key node]]
|
||||
rmpathm = xmpathm FollowBackward []
|
||||
202
src/Database/Persist/Sql/Graph/Reachable.hs
Normal file
202
src/Database/Persist/Sql/Graph/Reachable.hs
Normal file
|
|
@ -0,0 +1,202 @@
|
|||
{- 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.Sql.Graph.Reachable
|
||||
( -- * Finding the nodes reachable from a given node or set of nodes
|
||||
-- $reachable
|
||||
-- ** Standard
|
||||
reachable
|
||||
, xreachable
|
||||
-- ** Undirected
|
||||
, ureachable
|
||||
-- ** Reversed
|
||||
, rreachable
|
||||
)
|
||||
where
|
||||
|
||||
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)
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Database.Persist.Sql.Util
|
||||
|
||||
import qualified Data.Text as T (null, intercalate)
|
||||
|
||||
import Database.Persist.Local.Class.PersistEntityGraph
|
||||
import Database.Persist.Local.Class.PersistQueryForest
|
||||
import Database.Persist.Local.Sql
|
||||
import Database.Persist.Local.Sql.Orphan.Common
|
||||
|
||||
-- $reachable
|
||||
-- Finding the nodes reachable from a given set of starting nodes.
|
||||
--
|
||||
-- Names consist of:
|
||||
--
|
||||
-- 1. An optional direction parameter, specifying which nodes to visit next.
|
||||
--
|
||||
-- [(none)] forward: follow edge direction
|
||||
-- [@u@] undirectional: ignore edge direction
|
||||
-- [@r@] reversed: walk edges in reverse
|
||||
-- [@x@] user defined: specify which paths to follow
|
||||
--
|
||||
-- 2. Base name: @reachable@.
|
||||
|
||||
-- | It more-or-less looks like this:
|
||||
--
|
||||
-- > WITH RECURSIVE
|
||||
-- > temp (id, path, cycle) AS (
|
||||
-- > SELECT 3, ARRAY[3], FALSE
|
||||
-- > 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 DISTINCT id
|
||||
-- > FROM temp
|
||||
-- > WHERE NOT cycle
|
||||
xreachable'
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> [Key node]
|
||||
-> Maybe Int -- filter on path length max
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Key node]
|
||||
xreachable' follow filter initials mlen 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"
|
||||
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
|
||||
|
||||
filt = filterClause False conn filter
|
||||
fvals = getFiltsValues conn filter
|
||||
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
|
||||
, if T.null filt
|
||||
then " WHERE NOT " <> temp ^* tcycle
|
||||
else filt <> " AND 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 "
|
||||
, case follow of
|
||||
FollowForward -> sqlStep fwd bwd
|
||||
FollowBackward -> sqlStep bwd fwd
|
||||
FollowBoth -> mconcat
|
||||
[ "("
|
||||
, sqlStep fwd bwd
|
||||
, " UNION ALL "
|
||||
, sqlStep bwd fwd
|
||||
, ")"
|
||||
]
|
||||
, " ) SELECT DISTINCT ", temp ^* tid
|
||||
, " FROM ", dbname temp
|
||||
, " WHERE NOT ", temp ^* tcycle
|
||||
, case mlen of
|
||||
Nothing -> ""
|
||||
Just _ -> " AND array_length(", temp ^* tpath, ", 1) <= ?"
|
||||
]
|
||||
toP = fmap toPersistValue
|
||||
toPL = PersistList . map toPersistValue
|
||||
vals = toPL initials : fvals ++ toP mlen ?: []
|
||||
rawSql sql vals
|
||||
|
||||
reachable
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Key node]
|
||||
reachable = xreachable FollowForward []
|
||||
|
||||
xreachable
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> FollowDirection
|
||||
-> [Filter edge]
|
||||
-> [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Key node]
|
||||
xreachable = xreachable'
|
||||
|
||||
ureachable
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Key node]
|
||||
ureachable = xreachable FollowBoth []
|
||||
|
||||
rreachable
|
||||
:: ( MonadIO m
|
||||
, PersistEntityGraph node edge
|
||||
, SqlBackend ~ PersistEntityBackend node
|
||||
, SqlBackend ~ PersistEntityBackend edge
|
||||
)
|
||||
=> [Key node]
|
||||
-> Maybe Int
|
||||
-> Proxy (node, edge)
|
||||
-> ReaderT SqlBackend m [Key node]
|
||||
rreachable = xreachable FollowBackward []
|
||||
218
src/Database/Persist/Sql/Graph/TransitiveReduction.hs
Normal file
218
src/Database/Persist/Sql/Graph/TransitiveReduction.hs
Normal file
|
|
@ -0,0 +1,218 @@
|
|||
{- 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.Sql.Graph.TransitiveReduction
|
||||
( -- * Transitive reduction of DAGs
|
||||
trrSelect
|
||||
, trrApply
|
||||
)
|
||||
where
|
||||
|
||||
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)
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Database.Persist.Sql.Util
|
||||
|
||||
import qualified Data.Text as T (null, intercalate)
|
||||
|
||||
import Database.Persist.Local.Class.PersistEntityGraph
|
||||
import Database.Persist.Local.Class.PersistQueryForest
|
||||
import Database.Persist.Local.Sql
|
||||
import Database.Persist.Local.Sql.Orphan.Common
|
||||
|
||||
-- | 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 []
|
||||
|
|
@ -68,6 +68,11 @@ library
|
|||
Data.Tree.Local
|
||||
Database.Esqueleto.Local
|
||||
Database.Persist.Class.Local
|
||||
Database.Persist.Sql.Graph.Connects
|
||||
Database.Persist.Sql.Graph.Cyclic
|
||||
Database.Persist.Sql.Graph.Path
|
||||
Database.Persist.Sql.Graph.Reachable
|
||||
Database.Persist.Sql.Graph.TransitiveReduction
|
||||
Database.Persist.Sql.Local
|
||||
Database.Persist.Local.Class.PersistEntityGraph
|
||||
Database.Persist.Local.Class.PersistEntityHierarchy
|
||||
|
|
|
|||
Loading…
Reference in a new issue