From c340508385a90b47808501098848e96f59272029 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Thu, 14 Jul 2016 13:48:24 +0000
Subject: [PATCH] Reachability sets of graph nodes using SQL

---
 src/Database/Persist/Local/Sql.hs | 165 ++++++++++++++++++++++++++++++
 1 file changed, 165 insertions(+)

diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs
index 9282ad6..08ece15 100644
--- a/src/Database/Persist/Local/Sql.hs
+++ b/src/Database/Persist/Local/Sql.hs
@@ -51,6 +51,15 @@ module Database.Persist.Local.Sql
     , rmconnects
     , rconnectsm
     , rmconnectsm
+      -- * Finding the nodes reachable from a given node or set of nodes
+      -- $reachable
+      -- ** Standard
+    , reachable
+    , xreachable
+      -- ** Undirected
+    , ureachable
+      -- ** Reversed
+    , rreachable
       -- * Finding paths
       -- $path
       -- ** Standard
@@ -793,6 +802,162 @@ rmconnectsm
     -> ReaderT SqlBackend m Bool
 rmconnectsm = xmconnectsm FollowBackward []
 
+-- $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 []
+
 -- $path
 -- Findings paths between graph nodes.
 --