diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs index 88795f6..e8a8249 100644 --- a/src/Database/Persist/Local/Sql.hs +++ b/src/Database/Persist/Local/Sql.hs @@ -16,74 +16,12 @@ module Database.Persist.Local.Sql ( dummyFromField , rawSqlWithGraph + , dummyFromFst + , dummyFromSnd + , destFieldFromProxy + , sourceFieldFromProxy + , (?:) , FollowDirection (..) - -- * Checking for cycle existence - -- $cyclic - -- ** Standard - , cyclic - , cyclicn - , xcyclic - , xcyclicn - -- ** Undirected - , ucyclic - , ucyclicn - -- ** Reversed - , rcyclic - , rcyclicn - -- * 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 - -- * Finding the nodes reachable from a given node or set of nodes - -- $reachable - -- ** Standard - , reachable - , xreachable - -- ** Undirected - , ureachable - -- ** Reversed - , rreachable - -- * Finding paths - -- $path - -- ** Standard - , path - , mpath - , pathm - , mpathm - , xpath - , xmpath - , xpathm - , xmpathm - -- ** Undirected - , upath - , umpath - , upathm - , umpathm - -- ** Reversed - , rpath - , rmpath - , rpathm - , rmpathm - -- * Transitive reduction of DAGs - , trrSelect - , trrApply ) where @@ -196,1311 +134,6 @@ rawSqlWithGraph dir root parent child sub vals = do vals' = toPersistValue root : vals rawSql sql vals' --- | 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 [] - --- $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 - (?:) :: Maybe a -> [a] -> [a] (?:) = maybe id (:) infixr 5 ?: - --- | 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 [] - --- $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. --- --- 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 [] - --- | 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 [] diff --git a/src/Database/Persist/Sql/Graph/Connects.hs b/src/Database/Persist/Sql/Graph/Connects.hs new file mode 100644 index 0000000..a5a9150 --- /dev/null +++ b/src/Database/Persist/Sql/Graph/Connects.hs @@ -0,0 +1,403 @@ +{- 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.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 [] diff --git a/src/Database/Persist/Sql/Graph/Cyclic.hs b/src/Database/Persist/Sql/Graph/Cyclic.hs new file mode 100644 index 0000000..207dcbc --- /dev/null +++ b/src/Database/Persist/Sql/Graph/Cyclic.hs @@ -0,0 +1,311 @@ +{- 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.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 [] diff --git a/src/Database/Persist/Sql/Graph/Path.hs b/src/Database/Persist/Sql/Graph/Path.hs new file mode 100644 index 0000000..261d6f3 --- /dev/null +++ b/src/Database/Persist/Sql/Graph/Path.hs @@ -0,0 +1,423 @@ +{- 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.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 [] diff --git a/src/Database/Persist/Sql/Graph/Reachable.hs b/src/Database/Persist/Sql/Graph/Reachable.hs new file mode 100644 index 0000000..2572a58 --- /dev/null +++ b/src/Database/Persist/Sql/Graph/Reachable.hs @@ -0,0 +1,202 @@ +{- 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.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 [] diff --git a/src/Database/Persist/Sql/Graph/TransitiveReduction.hs b/src/Database/Persist/Sql/Graph/TransitiveReduction.hs new file mode 100644 index 0000000..2b26df8 --- /dev/null +++ b/src/Database/Persist/Sql/Graph/TransitiveReduction.hs @@ -0,0 +1,218 @@ +{- 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.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 [] diff --git a/vervis.cabal b/vervis.cabal index 77c9dd0..d2a9a8c 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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